scientific-notation (empty) → 0.1.0.0
raw patch · 7 files changed
+1345/−0 lines, 7 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed
Dependencies added: QuickCheck, aeson, attoparsec, base, byteslice, bytesmith, bytestring, gauge, primitive, run-st, scientific, scientific-notation, tasty, tasty-hunit, tasty-quickcheck
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Main.hs +193/−0
- scientific-notation.cabal +91/−0
- src/Data/Number/Scientific.hs +836/−0
- test/Main.hs +188/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for scientific-notation++## 0.1.0.0 -- 2019-09-24++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Martin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,193 @@+{-# language BangPatterns #-}+{-# language PackageImports #-}+{-# language MagicHash #-}+{-# language ScopedTypeVariables #-}++import Gauge (bgroup,bench,whnf)+import Gauge.Main (defaultMain)+import Data.ByteString.Internal (ByteString(PS))+import Data.Primitive (SmallArray,PrimArray,ByteArray(..))+import Data.Word (Word16)+import Control.Monad.ST (runST)+import Control.Monad.ST.Run (runPrimArrayST)+import GHC.ForeignPtr (ForeignPtrContents(PlainPtr))+import GHC.ForeignPtr (ForeignPtr(ForeignPtr))++import qualified GHC.Exts as Exts+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Parser as P+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Primitive as PM+import qualified Data.Attoparsec.ByteString.Char8 as Atto+import qualified Data.Aeson.Parser as Aeson++import qualified "scientific" Data.Scientific as SlowSci+import qualified "scientific-notation" Data.Number.Scientific as SCI++main :: IO ()+main = defaultMain+ [ bgroup "scientific-notation"+ [ bgroup "parser"+ [ bench "ten-small"+ (whnf (\b -> P.parseByteArray decodeTen b) tenSmall)+ , bench "ten-large"+ (whnf (\b -> P.parseByteArray decodeTen b) tenLarge)+ ]+ , bgroup "conversion"+ [ bench "twenty-word16"+ (whnf (\b -> convertArray16 b) twentyFastSci)+ ]+ ]+ , bgroup "scientific"+ [ bgroup "parser"+ [ bench "ten-small" $ whnf+ (\b -> Atto.parseOnly+ (aesonDecodeN 10 []) (fromPinned b)+ ) tenSmall+ , bench "ten-large" $ whnf+ (\b -> Atto.parseOnly+ (aesonDecodeN 10 []) (fromPinned b)+ ) tenLarge+ ]+ , bgroup "conversion"+ [ bench "twenty-word16"+ (whnf (\b -> convertSlowArray16 b) twentySlowSci)+ ]+ ]+ ]++-- TODO: In the test suite, we should confirm that parsing this+-- actually succeeds. We intentionally avoid leading plus signs+-- here so that we can compare against aeson.+tenSmall :: ByteArray+tenSmall = pin $ Bytes.toByteArray $ Bytes.fromAsciiString $ concat+ [ ",4256"+ , ",-125e14"+ , ",5.000006"+ , ",1e100"+ , ",-13.25E-100"+ , ",-653467618"+ , ",-17e+6"+ , ",9999.001"+ , ",0000.002"+ , ",0000.002E1"+ ]++-- TODO: In the test suite, we should confirm that parsing this+-- actually succeeds. We intentionally avoid leading plus signs+-- here so that we can compare against aeson.+tenLarge :: ByteArray+tenLarge = pin $ Bytes.toByteArray $ Bytes.fromAsciiString $ concat+ [ ",4221465241250205246754620201240240201451991999956"+ , ",242422432499393113113131313131533753.02031243210e13432"+ , ",-0.999999999999999999999999999999999999"+ , ",4.46246246526345643246256423645246224e100"+ , ",42463523462.46246243246256423645246224E24625"+ , ",-82463523462.56246243246256423645246224e-24625"+ , ",82463523462.56246243246256423645246224e+24625"+ , ",-201.562462432462564236452462240240420"+ , ",-0.777777777777777777777777777777777e-777"+ , ",0.987777777777777777777777777777777e-42"+ ]+++-- All of these can fit inside a Word16.+twentyPairs :: SmallArray (Int,Int)+twentyPairs = Exts.fromList+ [ (2336,0)+ , (43265,0)+ , (17,0)+ , (24,3)+ , (1,4)+ , (25,0)+ , (0,0)+ , (1900,0)+ , (65,0)+ , (1100,0)+ , (5,3)+ , (0,0)+ , (1600,0)+ , (1500,0)+ , (2000,0)+ , (62,2)+ , (500,0)+ , (670,0)+ , (1100,0)+ , (65500,0)+ ]++twentyFastSci :: SmallArray SCI.Scientific+twentyFastSci = fmap (uncurry SCI.small) twentyPairs++twentySlowSci :: SmallArray SlowSci.Scientific+twentySlowSci = fmap+ (\(x,y) -> SlowSci.scientific (fromIntegral x) y)+ twentyPairs++aesonDecodeN :: Int -> [SlowSci.Scientific] -> Atto.Parser [SlowSci.Scientific]+aesonDecodeN !ix !acc = if ix > 0+ then do+ _ <- Atto.char ','+ !num <- Aeson.scientific+ aesonDecodeN (ix - 1) (num : acc)+ else pure acc++decodeTen :: P.Parser () s (SmallArray SCI.Scientific)+decodeTen = do+ arr <- P.effect (PM.newSmallArray 10 errorThunk)+ let go !ix = if ix >= 0+ then do+ Latin.char () ',' + !num <- SCI.parserSignedUtf8Bytes ()+ P.effect (PM.writeSmallArray arr ix num)+ go (ix - 1)+ else P.effect (PM.unsafeFreezeSmallArray arr)+ go 9++convertArray16 ::+ SmallArray SCI.Scientific+ -> PrimArray Word16+convertArray16 xs = runPrimArrayST $ do+ let len = PM.sizeofSmallArray xs+ ws <- PM.newPrimArray len+ let go !ix = if ix >= 0+ then case SCI.toWord16 (PM.indexSmallArray xs ix) of+ Nothing -> error "convertArray16: bad number"+ Just (r :: Word16) -> do+ PM.writePrimArray ws ix r+ go (ix - 1)+ else PM.unsafeFreezePrimArray ws+ go (len - 1)++convertSlowArray16 ::+ SmallArray SlowSci.Scientific+ -> PrimArray Word16+convertSlowArray16 xs = runPrimArrayST $ do+ let len = PM.sizeofSmallArray xs+ ws <- PM.newPrimArray len+ let go !ix = if ix >= 0+ then case SlowSci.toBoundedInteger (PM.indexSmallArray xs ix) of+ Nothing -> error "convertArray16: bad number"+ Just (r :: Word16) -> do+ PM.writePrimArray ws ix r+ go (ix - 1)+ else PM.unsafeFreezePrimArray ws+ go (len - 1)++errorThunk :: a+{-# noinline errorThunk #-}+errorThunk = error "scientific:benchmark error"++-- Convert a pinned immutable byte array to a bytestring.+fromPinned :: ByteArray -> ByteString+{-# inline fromPinned #-}+fromPinned (ByteArray arr# ) = PS+ (ForeignPtr (Exts.byteArrayContents# arr# ) (PlainPtr (Exts.unsafeCoerce# arr#)))+ 0 (Exts.I# (Exts.sizeofByteArray# arr# ))++pin :: ByteArray -> ByteArray+pin src = runST $ do+ let len = PM.sizeofByteArray src+ dst <- PM.newByteArray len+ PM.copyByteArray dst 0 src 0 len+ PM.unsafeFreezeByteArray dst
+ scientific-notation.cabal view
@@ -0,0 +1,91 @@+cabal-version: 2.2+name: scientific-notation+version: 0.1.0.0+synopsis: Scientific notation intended for tokenization+description:+ This library provides a type used to represent a number in+ scientific notation. This is most frequently useful when+ tokenizing or parsing a language. Languages like JSON and SQL+ support numberic literals written in scientific notation, even+ though backends frequently reject numbers outside a given range.+ This library provides a compact representation of numbers in+ scientific notation. In the common case of the coefficient and+ then exponent each being small enough to be represented by a+ machine word, this library avoids the need for any indirections+ to retrieve the number. Consider some tokenization scheme:+ `data Token = ... | Number {-# UNPACK #-} !Scientific`.+ In this case, the unboxed coefficient and exponent are unpacked+ into the `Number` data constructor if they can each be represented+ by a machine word.+ .+ The internal representation does not normalize numbers. That is,+ parsing `300e-2` resulting in a representation that uses `300` and+ `-2` rather than `3` and `0`.+ This work is deferred with the expectation that a number in scientific+ notation is consumed either zero or one times. This library is not+ optimized for use-cases that consume a `Scientific` more than once+ since normalization is reapplied every time.+ .+ The primary library that operates in this same space is `scientific`.+ Compared to `scientific`, this library distinguishes itself from+ `scientific` in the following ways:+ .+ * Correctness: `scientific` does not correctly handle large exponents. See+ <https://github.com/basvandijk/scientific/issues/62 issue #62>.+ .+ * Parsing: The `scientific-notation` parser outperforms the `scientific`+ parser that ships with `aeson` by a factor of five on small numbers.+homepage: https://github.com/andrewthad/scientific-notation+bug-reports: https://github.com/andrewthad/scientific-notation/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2019 Andrew Martin+category: Data+extra-source-files: CHANGELOG.md++library+ exposed-modules: Data.Number.Scientific+ build-depends:+ , base >=4.12 && <5+ , bytesmith >=0.2.0.1 && <0.3+ hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall -O2+ build-depends:+ , QuickCheck >=2.13.1 && <2.14+ , base >=4.12.0.0 && <5+ , byteslice+ , bytestring+ , scientific-notation+ , tasty >=1.2.3 && <1.3+ , tasty-hunit >=0.10.0.2 && <0.11+ , tasty-quickcheck+ , primitive+ , bytesmith++benchmark bench+ type: exitcode-stdio-1.0+ build-depends:+ , base+ , gauge >= 0.2.4+ , byteslice >= 0.1.2+ , scientific-notation+ , primitive+ , bytesmith+ , aeson+ , attoparsec+ , bytestring+ , scientific+ , run-st+ ghc-options: -Wall -O2+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Main.hs
+ src/Data/Number/Scientific.hs view
@@ -0,0 +1,836 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language TypeApplications #-}+{-# language MultiWayIf #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Data.Number.Scientific+ ( Scientific+ , Scientific#+ -- * Produce+ , small+ , large+ , fromFixed+ -- * Consume+ , toWord+ , toWord8+ , toWord16+ , toWord32+ , toWord64+ , toInt+ , toInt32+ , toInt64+ -- * Decode+ , parserSignedUtf8Bytes+ , parserTrailingUtf8Bytes+ , parserUnsignedUtf8Bytes+ , parserNegatedUtf8Bytes+ , parserNegatedTrailingUtf8Bytes+ , parserSignedUtf8Bytes#+ , parserTrailingUtf8Bytes#+ , parserUnsignedUtf8Bytes#+ , parserNegatedUtf8Bytes#+ , parserNegatedTrailingUtf8Bytes#+ ) where++import Prelude hiding (negate)++import GHC.Exts (Int#,Word#,Int(I#),(+#))+import GHC.Word (Word(W#),Word8(W8#),Word16(W16#),Word32(W32#),Word64(W64#))+import GHC.Int (Int64(I64#),Int32(I32#))+import Data.Bytes.Parser (Parser(..))+import Data.Fixed (Fixed(MkFixed),HasResolution)++import qualified Data.Fixed as Fixed+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Unsafe as Unsafe+import qualified GHC.Exts as Exts+import qualified Prelude as Prelude++-- Implementation Notes+--+-- When consuming a Scientific, we are always careful to avoid+-- forcing the LargeScientific. In situations involving small+-- numbers, this field is not used, so we do not want to waste time+-- evaluating it.++data Scientific = Scientific+ {-# UNPACK #-} !Int -- coefficient+ {-# UNPACK #-} !Int -- base-10 exponent, minBound means use unlimited-precision field+ LargeScientific++type Scientific# = (# Int#, Int#, LargeScientific #)++instance Show Scientific where+ showsPrec _ (Scientific coeff e largeNum) = if e /= minBound+ then showsPrec 0 coeff . showChar 'e' . showsPrec 0 e+ else case largeNum of+ LargeScientific coeffLarge eLarge ->+ showsPrec 0 coeffLarge . showChar 'e' . showsPrec 0 eLarge++instance Eq Scientific where+ Scientific coeffA eA largeA == Scientific coeffB eB largeB+ | eA == minBound && eB == minBound = eqLargeScientific largeA largeB+ | eA == minBound = eqLargeScientific largeA (LargeScientific (fromIntegral coeffB) (fromIntegral eB))+ | eB == minBound = eqLargeScientific (LargeScientific (fromIntegral coeffA) (fromIntegral eA)) largeB+ | eA >= maxBound - padding || eB >= maxBound - padding = eqLargeScientific+ (LargeScientific (fromIntegral coeffA) (fromIntegral eA))+ (LargeScientific (fromIntegral coeffA) (fromIntegral eB))+ | otherwise = eqSmall coeffA eA coeffB eB++data LargeScientific = LargeScientific !Integer !Integer++padding :: Int+padding = 50++eqSmall :: Int -> Int -> Int -> Int -> Bool+eqSmall cA0 eA0 cB0 eB0 =+ let (cA,eA) = smallNormalize cA0 eA0+ (cB,eB) = smallNormalize cB0 eB0+ in cA == cB && eA == eB++eqLargeScientific :: LargeScientific -> LargeScientific -> Bool+eqLargeScientific a b =+ let LargeScientific cA eA = largeNormalize a + LargeScientific cB eB = largeNormalize b+ in cA == cB && eA == eB++zeroLarge :: LargeScientific+{-# noinline zeroLarge #-}+zeroLarge = LargeScientific 0 0++-- | Construct a 'Scientific' from a coefficient and exponent+-- that fit in a machine word.+small ::+ Int -- ^ Coefficient+ -> Int -- ^ Exponent+ -> Scientific+small !coeff !e = if e /= minBound+ then Scientific coeff e zeroLarge+ else large (fromIntegral coeff) (fromIntegral e)++-- | Construct a 'Scientific' from a coefficient and exponent+-- of arbitrary size.+large ::+ Integer -- ^ Coefficient+ -> Integer -- ^ Exponent+ -> Scientific+large coeff e =+ let !b = LargeScientific coeff e+ in Scientific 0 minBound b++-- | Construct a 'Scientific' from a fixed-precision number.+-- This does not perform well and is only included for convenience.+fromFixed :: HasResolution e => Fixed e -> Scientific+fromFixed n@(MkFixed coeff) =+ let !b = LargeScientific coeff+ (fromIntegral (Prelude.negate (logBase10 0 (Fixed.resolution n))))+ in Scientific 0 minBound b++toWord8 :: Scientific -> Maybe Word8+{-# inline toWord8 #-}+toWord8 (Scientific (I# coeff) (I# e) largeNum) = case toWord8# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (W8# w)++toWord16 :: Scientific -> Maybe Word16+{-# inline toWord16 #-}+toWord16 (Scientific (I# coeff) (I# e) largeNum) = case toWord16# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (W16# w)++toWord32 :: Scientific -> Maybe Word32+{-# inline toWord32 #-}+toWord32 (Scientific (I# coeff) (I# e) largeNum) = case toWord32# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (W32# w)++toInt32 :: Scientific -> Maybe Int32+{-# inline toInt32 #-}+toInt32 (Scientific (I# coeff) (I# e) largeNum) = case toInt32# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (I32# w)++toWord64 :: Scientific -> Maybe Word64+{-# inline toWord64 #-}+toWord64 (Scientific (I# coeff) (I# e) largeNum) = case toWord# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (W64# w)++toWord :: Scientific -> Maybe Word+{-# inline toWord #-}+toWord (Scientific (I# coeff) (I# e) largeNum) = case toWord# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | w #) -> Just (W# w)++toInt :: Scientific -> Maybe Int+{-# inline toInt #-}+toInt (Scientific (I# coeff) (I# e) largeNum) = case toInt# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | i #) -> Just (I# i)++toInt64 :: Scientific -> Maybe Int64+{-# inline toInt64 #-}+toInt64 (Scientific (I# coeff) (I# e) largeNum) = case toInt# coeff e largeNum of+ (# (# #) | #) -> Nothing+ (# | i #) -> Just (I64# i)++toSmallHelper ::+ (Int -> Int -> (# (# #) | Word# #) ) -- small+ -> (LargeScientific -> (# (# #) | Word# #) ) -- large+ -> Int#+ -> Int#+ -> LargeScientific+ -> (# (# #) | Word# #)+{-# inline toSmallHelper #-}+toSmallHelper fromSmall fromLarge coefficient0# exponent0# large0 =+ if exponent0 /= minBound+ then fromSmall coefficient0 exponent0+ else fromLarge large0+ where+ coefficient0 = I# coefficient0#+ exponent0 = I# exponent0#++toSmallIntHelper ::+ (Int -> Int -> (# (# #) | Int# #) ) -- small+ -> (LargeScientific -> (# (# #) | Int# #) ) -- large+ -> Int#+ -> Int#+ -> LargeScientific+ -> (# (# #) | Int# #)+{-# inline toSmallIntHelper #-}+toSmallIntHelper fromSmall fromLarge coefficient0# exponent0# large0 =+ if exponent0 /= minBound+ then fromSmall coefficient0 exponent0+ else fromLarge large0+ where+ coefficient0 = I# coefficient0#+ exponent0 = I# exponent0#+++toWord8# :: Int# -> Int# -> LargeScientific -> (# (# #) | Word# #)+{-# noinline toWord8# #-}+toWord8# coefficient0# exponent0# large0 = + toSmallHelper smallToWord8 largeToWord8+ coefficient0# exponent0# large0++toWord16# :: Int# -> Int# -> LargeScientific -> (# (# #) | Word# #)+{-# noinline toWord16# #-}+toWord16# coefficient0# exponent0# largeNum =+ toSmallHelper smallToWord16 largeToWord16+ coefficient0# exponent0# largeNum++toWord32# :: Int# -> Int# -> LargeScientific -> (# (# #) | Word# #)+{-# noinline toWord32# #-}+toWord32# coefficient0# exponent0# largeNum =+ toSmallHelper smallToWord32 largeToWord32+ coefficient0# exponent0# largeNum++toInt32# :: Int# -> Int# -> LargeScientific -> (# (# #) | Int# #)+{-# noinline toInt32# #-}+toInt32# coefficient0# exponent0# largeNum =+ toSmallIntHelper smallToInt32 largeToInt32+ coefficient0# exponent0# largeNum++toWord# :: Int# -> Int# -> LargeScientific -> (# (# #) | Word# #)+{-# noinline toWord# #-}+toWord# coefficient0# exponent0# largeNum =+ toSmallHelper smallToWord largeToWord+ coefficient0# exponent0# largeNum++toInt# :: Int# -> Int# -> LargeScientific -> (# (# #) | Int# #)+{-# noinline toInt# #-}+toInt# coefficient0# exponent0# largeNum =+ toSmallIntHelper smallToInt largeToInt+ coefficient0# exponent0# largeNum++-- Arguments are non-normalized coefficient and exponent.+-- We cannot use the same trick that we use for Word8 and+-- Word16.+smallToWord32 :: Int -> Int -> (# (# #) | Word# #)+smallToWord32 !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 10, coefficient >= 0, coefficient <= 0xFFFFFFFF+ = word32Exp10 (fromIntegral @Int @Word coefficient) expon+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized coefficient and exponent.+smallToInt32 :: Int -> Int -> (# (# #) | Int# #)+smallToInt32 !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0# #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 10+ , coefficient >= fromIntegral @Int32 @Int (minBound :: Int32)+ , coefficient <= fromIntegral @Int32 @Int (maxBound :: Int32)+ = if coefficient >= 0+ then posInt32Exp10 coefficient expon+ else negInt32Exp10 coefficient expon+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized coefficient and exponent.+-- We cannot use the same trick that we use for Word8 and+-- Word16.+smallToWord :: Int -> Int -> (# (# #) | Word# #)+smallToWord !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 30, coefficient >= 0+ = wordExp10 (fromIntegral @Int @Word coefficient) expon+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized coefficient and exponent.+smallToInt :: Int -> Int -> (# (# #) | Int# #)+smallToInt !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0# #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 30+ = if coefficient >= 0+ then posIntExp10 coefficient expon+ else negIntExp10 coefficient expon+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized coefficient and exponent+-- With Word16, we can do a neat little trick where we+-- cap the coefficient at 65536 and the exponent at 5. This+-- works because a 32-bit signed int can contain 65535e4.+smallToWord16 :: Int -> Int -> (# (# #) | Word# #)+smallToWord16 !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 5, coefficient >= 0, coefficient < 65536+ , r <- exp10 coefficient expon+ , y@(W16# y# ) <- fromIntegral @Int @Word16 r+ , fromIntegral @Word16 @Int y == r+ = (# | y# #)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized coefficient and exponent+-- With Word8, we can do a neat little trick where we+-- cap the coefficient at 256 and the exponent at 3. This+-- works because a 32-bit signed int can contain 255e2.+smallToWord8 :: Int -> Int -> (# (# #) | Word# #)+smallToWord8 !coefficient0 !exponent0+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- incrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 3, coefficient >= 0, coefficient < 256+ , r <- exp10 coefficient expon+ , y@(W8# y# ) <- fromIntegral @Int @Word8 r+ , fromIntegral @Word8 @Int y == r+ = (# | y# #)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized+largeToWord8 :: LargeScientific -> (# (# #) | Word# #)+largeToWord8 (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 3, coefficient >= 0, coefficient < 256+ , r <- exp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ , y@(W8# y# ) <- fromIntegral @Int @Word8 r+ , fromIntegral @Word8 @Int y == r+ = (# | y# #)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized+largeToWord16 :: LargeScientific -> (# (# #) | Word# #)+largeToWord16 (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 5, coefficient >= 0, coefficient < 65536+ , r <- exp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ , y@(W16# y# ) <- fromIntegral @Int @Word16 r+ , fromIntegral @Word16 @Int y == r+ = (# | y# #)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized+largeToWord32 :: LargeScientific -> (# (# #) | Word# #)+largeToWord32 (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 10, coefficient >= 0, coefficient <= 0xFFFFFFFF+ = word32Exp10 (fromIntegral @Integer @Word coefficient) (fromIntegral @Integer @Int expon)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized, this targets the native word size+largeToWord :: LargeScientific -> (# (# #) | Word# #)+largeToWord (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0## #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 30, coefficient >= 0, coefficient <= (fromIntegral @Word @Integer maxBound)+ = wordExp10 (fromIntegral @Integer @Word coefficient) (fromIntegral @Integer @Int expon)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized+largeToInt32 :: LargeScientific -> (# (# #) | Int# #)+largeToInt32 (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0# #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 10+ , coefficient >= (fromIntegral @Int32 @Integer minBound)+ , coefficient <= (fromIntegral @Int32 @Integer maxBound)+ = if coefficient >= 0+ then posInt32Exp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ else negInt32Exp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ | otherwise = (# (# #) | #)++-- Arguments are non-normalized, this targets the native word size+largeToInt :: LargeScientific -> (# (# #) | Int# #)+largeToInt (LargeScientific coefficient0 exponent0)+ | coefficient0 == 0 = (# | 0# #)+ | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent0+ , expon >= 0, expon < 30+ , coefficient >= (fromIntegral @Int @Integer minBound)+ , coefficient <= (fromIntegral @Int @Integer maxBound)+ = if coefficient >= 0+ then posIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ else negIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon)+ | otherwise = (# (# #) | #)++-- Precondition: the exponent is non-negative. This returns+-- an unboxed Nothing on overflow. This implementation should+-- work even on a 32-bit platform.+word32Exp10 :: Word -> Int -> (# (# #) | Word# #)+word32Exp10 !a@(W# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> let (overflow, a') = timesWord2 a 10 in+ if overflow || (a' > 0xFFFFFFFF)+ then (# (# #) | #)+ else word32Exp10 a' (e - 1)++-- Precondition: the exponent is non-negative, and the+-- coefficient is non-negative. This returns an unboxed+-- Nothing on overflow.+posInt32Exp10 :: Int -> Int -> (# (# #) | Int# #)+posInt32Exp10 !a@(I# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> if a < posInt32PreUpper+ then let a' = a * 10 in+ if a' >= a && a' <= fromIntegral (maxBound :: Int32)+ then posInt32Exp10 a' (e - 1)+ else (# (# #) | #)+ else (# (# #) | #)++-- Precondition: the exponent is non-negative, and the+-- coefficient is non-positive. This returns an unboxed+-- Nothing on overflow.+negInt32Exp10 :: Int -> Int -> (# (# #) | Int# #)+negInt32Exp10 !a@(I# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> if a > negInt32PreLower+ then let a' = a * 10 in+ if a' <= a && a' >= fromIntegral (minBound :: Int32)+ then negInt32Exp10 a' (e - 1)+ else (# (# #) | #)+ else (# (# #) | #)++-- Precondition: the exponent is non-negative. This returns+-- an unboxed Nothing on overflow.+wordExp10 :: Word -> Int -> (# (# #) | Word# #)+wordExp10 !a@(W# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> let (overflow, a') = timesWord2 a 10 in if overflow+ then (# (# #) | #)+ else wordExp10 a' (e - 1)++-- Precondition: The exponent is non-negative, and the+-- coefficient is non-negative. This returns an unboxed+-- Nothing on overflow.+posIntExp10 :: Int -> Int -> (# (# #) | Int# #)+posIntExp10 !a@(I# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> if a < posIntPreUpper+ then let a' = a * 10 in+ if a' >= a+ then posIntExp10 a' (e - 1)+ else (# (# #) | #)+ else (# (# #) | #)++-- Precondition: The exponent is non-negative, and the+-- coefficient is non-positive. This returns an unboxed+-- Nothing on overflow.+negIntExp10 :: Int -> Int -> (# (# #) | Int# #)+negIntExp10 !a@(I# a# ) !e = case e of+ 0 -> (# | a# #)+ _ -> if a > negIntPreLower+ then let a' = a * 10 in+ if a' <= a+ then negIntExp10 a' (e - 1)+ else (# (# #) | #)+ else (# (# #) | #)++-- What are these lower and upper bounds? The problem that+-- we are trying to solve is that overflow is tricky to detect+-- when we multiply by ten. By putting an upper (or lower)+-- bound on the thing we are multiplying by ten, we can+-- make overflow detection simple: just test that the+-- accumulator became larger (or smaller when dealing with+-- a negative coefficient) than it previously was.++posIntPreUpper :: Int+posIntPreUpper = div maxBound 10 + 10++negIntPreLower :: Int+negIntPreLower = div minBound 10 - 10++posInt32PreUpper :: Int+posInt32PreUpper = 214748370++negInt32PreLower :: Int+negInt32PreLower = (-214748370)++-- Bool is true if overflow happened+timesWord2 :: Word -> Word -> (Bool, Word)+timesWord2 (W# a) (W# b) =+ let !(# c, r #) = Exts.timesWord2# a b+ in (case c of { 0## -> False; _ -> True}, W# r)++-- Precondition: the exponent is non-negative+exp10 :: Int -> Int -> Int+exp10 !a !e = case e of+ 0 -> a+ _ -> exp10 (a * 10) (e - 1)++largeNormalize :: LargeScientific -> LargeScientific+largeNormalize s@(LargeScientific w _) = case w of+ 0 -> LargeScientific 0 0+ _ -> largeNormalizeLoop s++-- Precondition: the coefficient is non-zero+largeNormalizeLoop :: LargeScientific -> LargeScientific+largeNormalizeLoop (LargeScientific w e) = case quotRem w 10 of+ (q,r) -> case r of+ 0 -> largeNormalizeLoop (LargeScientific q (e + 1))+ _ -> LargeScientific w e++largeIncrementNegativeExp :: Integer -> Integer -> (Integer,Integer)+largeIncrementNegativeExp w e = if e >= 0+ then (w,e)+ else case quotRem w 10 of+ (q,r) -> case r of+ 0 -> largeIncrementNegativeExp q (e + 1)+ _ -> (w,e)++smallNormalize :: Int -> Int -> (Int,Int)+smallNormalize (I# w) (I# e) = case w of+ 0# -> (0,0)+ _ -> case smallNormalize# w e of+ (# w', e' #) -> (I# w', I# e')++incrementNegativeExp :: Int -> Int -> (Int,Int)+incrementNegativeExp (I# w) (I# e) = case incrementNegativeExp# w e of+ (# w', e' #) -> (I# w', I# e')++-- If the exponent is negative, increase it as long as the+-- coefficient divides ten evenly.+incrementNegativeExp# :: Int# -> Int# -> (# Int#, Int# #)+{-# noinline incrementNegativeExp# #-}+incrementNegativeExp# w# e# = if I# e# >= 0+ then (# w#, e# #)+ else case quotRem (I# w# ) 10 of+ (I# q#,r) -> case r of+ 0 -> incrementNegativeExp# q# (e# +# 1# )+ _ -> (# w#, e# #)++-- Precondition: coefficient is not zero. If it is,+-- this will loop.+smallNormalize# :: Int# -> Int# -> (# Int#, Int# #)+{-# noinline smallNormalize# #-}+smallNormalize# w# e# = case quotRem (I# w# ) 10 of+ (I# q#,r) -> case r of+ 0 -> smallNormalize# q# (e# +# 1# )+ _ -> (# w#, e# #)++-- | Parse a number that is encoded in UTF-8 and in scientific notation.+-- All of these are accepted:+--+-- * 330e-1+-- * 330e+1+-- * 330e1+-- * 330.0e1+-- * -330.0e1+-- * 12+-- * 00012+-- * 2.05+-- * +2.05+-- * +33.6e+1+parserSignedUtf8Bytes :: e -> Parser e s Scientific+parserSignedUtf8Bytes e = boxScientific (parserSignedUtf8Bytes# e)++-- | Variant of 'parserSignedUtf8Bytes' that rejects strings with+-- a leading plus or minus sign.+parserUnsignedUtf8Bytes :: e -> Parser e s Scientific+parserUnsignedUtf8Bytes e = boxScientific (parserUnsignedUtf8Bytes# e)++-- | Variant of 'parserUnsignedUtf8Bytes' that negates the result.+parserNegatedUtf8Bytes :: e -> Parser e s Scientific+parserNegatedUtf8Bytes e = boxScientific (parserNegatedUtf8Bytes# e)++parserTrailingUtf8Bytes# ::+ e -- ^ Error message+ -> Int# -- ^ Leading digit+ -> Parser e s Scientific#+{-# noinline parserTrailingUtf8Bytes# #-}+parserTrailingUtf8Bytes# e leader =+ mapIntPairToScientific (parseSmallTrailing# leader)+ `orElseScientific`+ upcastLargeScientific (parseLargeTrailing e (I# leader))++parserNegatedTrailingUtf8Bytes# ::+ e -- ^ Error message+ -> Int# -- ^ Leading digit+ -> Parser e s Scientific#+{-# noinline parserNegatedTrailingUtf8Bytes# #-}+parserNegatedTrailingUtf8Bytes# e leader =+ mapNegateIntPairToScientific (parseSmallTrailing# leader)+ `orElseScientific`+ upcastNegatedLargeScientific (parseLargeTrailing e (I# leader))++parserSignedUtf8Bytes# ::+ e -- ^ Error message+ -> Parser e s Scientific#+parserSignedUtf8Bytes# e = Latin.any e `bindToScientific` \c -> case c of+ '+' -> parserUnsignedUtf8Bytes# e+ '-' -> parserNegatedUtf8Bytes# e+ _ -> Unsafe.unconsume 1 `bindToScientific` \_ ->+ parserUnsignedUtf8Bytes# e++-- | Variant of 'parseUnsignedUtf8Bytes' where all arguments are+-- unboxed.+parserUnsignedUtf8Bytes# ::+ e -- ^ Error message+ -> Parser e s Scientific#+parserUnsignedUtf8Bytes# e =+ mapIntPairToScientific parseSmall#+ `orElseScientific`+ upcastLargeScientific (parseLarge e)++-- Negates the result after parsing the bytes.+parserNegatedUtf8Bytes# ::+ e -- ^ Error message+ -> Parser e s Scientific#+parserNegatedUtf8Bytes# e =+ mapNegateIntPairToScientific parseSmall#+ `orElseScientific`+ upcastNegatedLargeScientific (parseLarge e)++parserTrailingUtf8Bytes ::+ e -- ^ Error message+ -> Int -- ^ Leading digit, should be between @-9@ and @9@.+ -> Parser e s Scientific+parserTrailingUtf8Bytes e (I# leader) =+ boxScientific (parserTrailingUtf8Bytes# e leader)++parserNegatedTrailingUtf8Bytes ::+ e -- ^ Error message+ -> Int -- ^ Leading digit, should be between @-9@ and @9@.+ -> Parser e s Scientific+parserNegatedTrailingUtf8Bytes e (I# leader) =+ boxScientific (parserNegatedTrailingUtf8Bytes# e leader)+-- +-- parserTrailingUtf8Bytes# ::+-- e -- Error message+-- -> Parser e s Scientific#+-- parserTrailingUtf8Bytes# !leader e =+-- parseSmall# leader+-- `orElseScientific`+-- unboxScientific (P.fail e)++parseLarge :: e -> Parser e s LargeScientific+parseLarge e = do+ coeff <- Latin.decUnsignedInteger e+ parseLargeCommon e coeff++parseLargeTrailing :: e -> Int -> Parser e s LargeScientific+parseLargeTrailing e !leader = do+ coeff <- Latin.decTrailingInteger leader+ parseLargeCommon e coeff++parseLargeCommon :: e -> Integer -> Parser e s LargeScientific+{-# noinline parseLargeCommon #-}+parseLargeCommon e coeff = do+ Latin.trySatisfyThen (pure (LargeScientific coeff 0)) $ \c -> case c of+ '.' -> Just $ do+ !start <- Unsafe.cursor+ afterDot <- Latin.decUnsignedInteger e+ !end <- Unsafe.cursor+ let !logDenom = end - start+ !coeffFinal = (integerTenExp coeff logDenom) + afterDot+ Latin.trySatisfy (\ch -> ch == 'e' || ch == 'E') >>= \case+ True -> attemptLargeExp e coeffFinal (unI (Prelude.negate logDenom))+ False -> pure $! LargeScientific coeffFinal $! fromIntegral $! Prelude.negate logDenom+ 'e' -> Just (attemptLargeExp e coeff 0# )+ 'E' -> Just (attemptLargeExp e coeff 0# )+ _ -> Nothing++-- handles unsigned small numbers+parseSmall# :: Parser () s (# Int#, Int# #)+parseSmall# =+ Latin.decUnsignedInt# () `Parser.bindFromIntToIntPair` \coeff# ->+ parseSmallCommon# coeff#++parseSmallTrailing# :: Int# -> Parser () s (# Int#, Int# #)+parseSmallTrailing# leader =+ Latin.decTrailingInt# () leader `Parser.bindFromIntToIntPair` \coeff# ->+ parseSmallCommon# coeff#++parseSmallCommon# :: Int# -> Parser () s (# Int#, Int# #)+{-# noinline parseSmallCommon# #-}+parseSmallCommon# coeff# =+ Latin.trySatisfyThen (Parser.pureIntPair (# coeff#, 0# #)) $ \c -> case c of+ '.' -> Just $+ Unsafe.cursor `Parser.bindFromLiftedToIntPair` \start ->+ Latin.decUnsignedInt# () `Parser.bindFromIntToIntPair` \afterDot# ->+ Unsafe.cursor `Parser.bindFromLiftedToIntPair` \end ->+ let !logDenom = end - start+ goCoeff !coeffShifted !expon = case expon of+ 0 ->+ let !(I# coeffShifted# ) = coeffShifted+ !(# coeffFinal, overflowed #) =+ Exts.addIntC# coeffShifted# afterDot#+ in case overflowed of+ 0# -> Latin.trySatisfy (\ch -> ch == 'e' || ch == 'E') `Parser.bindFromLiftedToIntPair` \b -> case b of+ True -> attemptSmallExp coeffFinal (unI (Prelude.negate logDenom))+ False -> Parser.pureIntPair (# coeffFinal, unI (Prelude.negate logDenom) #)+ _ -> Parser.failIntPair ()+ _ ->+ let coeffShifted' = coeffShifted * 10+ in if coeffShifted' >= coeffShifted+ then goCoeff coeffShifted' (expon - 1)+ -- If we overflow, fail so that the parser+ -- for large number will handle it instead.+ else Parser.failIntPair ()+ in goCoeff (I# coeff# ) logDenom+ 'e' -> Just (attemptSmallExp coeff# 0#)+ 'E' -> Just (attemptSmallExp coeff# 0#)+ _ -> Nothing+++-- The delta passed to this is only ever a negative integer.+attemptLargeExp ::+ e+ -> Integer+ -> Int#+ -> Parser e s LargeScientific+{-# noinline attemptLargeExp #-}+attemptLargeExp e signedCoeff !deltaExp# = do+ expon <- Latin.decSignedInteger e+ let !exponent' = expon + fromIntegral (I# deltaExp# )+ pure (LargeScientific signedCoeff exponent')++-- The delta passed to this is only ever a negative integer.+-- It is also between -21 and -1. (Or maybe -22 or -20, not sure).+attemptSmallExp :: Int# -> Int# -> Parser () s (# Int#, Int# #)+{-# noinline attemptSmallExp #-}+attemptSmallExp !signedCoeff# !deltaExp# = Parser.unboxIntPair $ do+ e <- Latin.decSignedInt ()+ -- I give this a little extra padding just to be safe.+ if e > (minBound + padding)+ then pure (signedCoeff, e + deltaExp)+ else Parser.fail ()+ where+ signedCoeff = I# signedCoeff#+ deltaExp = I# deltaExp#++-- | Convert a 'Word#' parser to a 'Word32' parser. Precondition:+-- the argument parser only returns words less than 4294967296.+boxScientific :: Parser s e Scientific# -> Parser s e Scientific+boxScientific (Parser f) = Parser+ (\x s0 -> case f x s0 of+ (# s1, r #) -> case r of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# (# w, y, z #), b, c #) #) -> (# s1, (# | (# Scientific (I# w) (I# y) z, b, c #) #) #)+ )++unI :: Int -> Int#+unI (I# i) = i++orElseScientific :: Parser x s Scientific# -> Parser e s Scientific# -> Parser e s Scientific#+{-# inline orElseScientific #-}+orElseScientific (Parser f) (Parser g) = Parser+ (\x s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# _ | #) -> g x s1+ (# | r #) -> (# s1, (# | r #) #)+ )++-- Precondition: argument is non-negative+-- If the argument is r and the exponent is e, the result+-- is described as: r * 10^e+integerTenExp :: Integer -> Int -> Integer+integerTenExp !r !e = case e of+ 0 -> r+ 1 -> r * 10+ 2 -> r * 100+ 3 -> r * 1000+ 4 -> r * 10000+ 5 -> r * 100000+ 6 -> r * 1000000+ 7 -> r * 10000000+ 8 -> r * 100000000+ _ -> integerTenExp (r * 1000000000) (e - 9)++-- This only works if the number is a power of ten.+-- It is only intended to be used by fromFixed.+-- Precondition: the Integer is not zero.+logBase10 :: Int -> Integer -> Int+logBase10 !acc i = if i == 1+ then acc+ else logBase10 (acc + 1) (div i 10)++upcastLargeScientific ::+ Parser e s LargeScientific+ -> Parser e s Scientific#+upcastLargeScientific (Parser g) = Parser+ (\x s0 -> case g x s0 of+ (# s1, r #) -> case r of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# a, b, c #) #) -> (# s1, (# | (# (# 0#, unI minBound, a #), b, c #) #) #)+ )++upcastNegatedLargeScientific ::+ Parser e s LargeScientific+ -> Parser e s Scientific#+upcastNegatedLargeScientific (Parser g) = Parser+ (\x s0 -> case g x s0 of+ (# s1, r #) -> case r of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# LargeScientific w y, b, c #) #) -> (# s1, (# | (# (# 0#, unI minBound, LargeScientific (Prelude.negate w) y #), b, c #) #) #)+ )++mapIntPairToScientific ::+ Parser e s (# Int#, Int# #)+ -> Parser e s Scientific#+mapIntPairToScientific (Parser g) = Parser+ (\x s0 -> case g x s0 of+ (# s1, r #) -> case r of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# (# y, z #), b, c #) #) -> (# s1, (# | (# (# y, z, zeroLarge #), b, c #) #) #)+ )++-- We do not check to see if exponent==minBound since this is called+-- on the result of an unsigned parser. Fortunately, signed fixed-width+-- integers always have one extra number on the low end that is not the+-- negation of anything on the high end.+mapNegateIntPairToScientific ::+ Parser e s (# Int#, Int# #)+ -> Parser e s Scientific#+mapNegateIntPairToScientific (Parser g) = Parser+ (\x s0 -> case g x s0 of+ (# s1, r #) -> case r of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# (# y, z #), b, c #) #) -> (# s1, (# | (# (# Exts.negateInt# y, z, zeroLarge #), b, c #) #) #)+ )++bindToScientific :: Parser s e a -> (a -> Parser s e Scientific#) -> Parser s e Scientific#+{-# inline bindToScientific #-}+bindToScientific (Parser f) g = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# y, b, c #) #) ->+ runParser (g y) (# arr, b, c #) s1+ )
+ test/Main.hs view
@@ -0,0 +1,188 @@+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language OverloadedStrings #-}+{-# language NumDecimals #-}++import Control.Monad (when,replicateM)+import Data.Bool (bool)+import Data.Bytes.Types (Bytes(Bytes))+import Data.Char (ord)+import Data.Fixed (Fixed,E12)+import Data.Int (Int64)+import Data.Number.Scientific (large,small,toWord8,toWord16,toWord32,toWord64)+import Data.Number.Scientific (toInt64,toInt32)+import Data.Primitive (ByteArray)+import Data.Word (Word8)+import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.Tasty.HUnit ((@=?),assertFailure)+import Test.Tasty.QuickCheck (testProperty,(===))++import qualified Data.Bits as Bits+import qualified Data.Number.Scientific as SCI+import qualified Data.Bytes.Parser as P+import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts+import qualified Test.Tasty.HUnit as THU+import qualified Test.Tasty.QuickCheck as QC++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+ [ testGroup "Eq"+ [ THU.testCase "A" $ small 300 (-2) @=? small 3 0+ , THU.testCase "B" $ small 300 (-2) @=? large 3e50 (-50)+ , THU.testCase "C" $ large 3e100 (-99) @=? small 30 0+ , THU.testCase "D" $ large 3e5 9999999995 @=? large 3e6 9999999994+ , THU.testCase "E" $ when+ (small 400 maxBound == small 4 (minBound + 1))+ (assertFailure "")+ , THU.testCase "F" $ small 0 (-2) @=? small 0 5+ , THU.testCase "G" $ large 0 (-2) @=? large 0 5+ , testProperty "small" $ \x y ->+ small x y === small x y+ ]+ , testGroup "Word8"+ [ THU.testCase "A" $ Just 30 @=? toWord8 (small 300 (-1))+ , THU.testCase "B" $ Nothing @=? toWord8 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toWord8 (small 1 999999999)+ , THU.testCase "D" $ Just 255 @=? toWord8 (large 255e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toWord8 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toWord8 (small 0 999999999)+ , THU.testCase "G" $ Nothing @=? toWord8 (small (-1) 1)+ ]+ , testGroup "Word16"+ [ THU.testCase "A" $ Just 30 @=? toWord16 (small 300 (-1))+ , THU.testCase "B" $ Just 300 @=? toWord16 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toWord16 (small 1 999999999)+ , THU.testCase "D" $ Just 65535 @=? toWord16 (large 65535e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toWord16 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toWord16 (small 0 999999999)+ , THU.testCase "G" $ Nothing @=? toWord16 (small (-1) 1)+ , THU.testCase "H" $ Nothing @=? toWord16 (small 65536 0)+ ]+ , testGroup "Word32"+ [ THU.testCase "A" $ Just 30 @=? toWord32 (small 300 (-1))+ , THU.testCase "B" $ Just 300 @=? toWord32 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toWord32 (small 1 999999999)+ , THU.testCase "D" $ Just 65535 @=? toWord32 (large 65535e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toWord32 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toWord32 (small 0 999999999)+ , THU.testCase "G" $ Nothing @=? toWord32 (small (-1) 1)+ , THU.testCase "H" $ Nothing @=? toWord32 (small 4294967296 0)+ , THU.testCase "I" $ Just 4294967295 @=? toWord32 (large 4294967295e40 (-40))+ , THU.testCase "J" $ Just 4294967295 @=? toWord32 (small 4294967295 0)+ ]+ , testGroup "Word64"+ [ THU.testCase "A" $ Just 30 @=? toWord64 (small 300 (-1))+ , THU.testCase "B" $ Just 300 @=? toWord64 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toWord64 (small 1 999999999)+ , THU.testCase "D" $ Just 65535 @=? toWord64 (large 65535e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toWord64 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toWord64 (small 0 999999999)+ , THU.testCase "G" $ Nothing @=? toWord64 (small (-1) 1)+ , THU.testCase "H" $ Just 4294967296 @=? toWord64 (small 4294967296 0)+ , THU.testCase "I" $ Just 4294967295 @=? toWord64 (large 4294967295e40 (-40))+ , THU.testCase "J" $ Just 4294967295 @=? toWord64 (small 4294967295 0)+ , THU.testCase "K" $ Nothing @=? toWord64 (large (2 ^ (64 :: Int)) 0)+ , THU.testCase "L" $ Just maxBound @=? toWord64 (large ((2 ^ (64 :: Int)) - 1) 0)+ , THU.testCase "M" $ Just (fromIntegral (maxBound :: Int)) @=? toWord64 (small (maxBound :: Int) 0)+ ]+ , testGroup "Int32"+ [ THU.testCase "A" $ Just 30 @=? toInt32 (small 300 (-1))+ , THU.testCase "B" $ Just 300 @=? toInt32 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toInt32 (small 1 999999999)+ , THU.testCase "D" $ Just 65535 @=? toInt32 (large 65535e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toInt32 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toInt32 (small 0 999999999)+ , THU.testCase "G" $ Just (-10) @=? toInt32 (small (-1) 1)+ , THU.testCase "H" $ Just 2147483647 @=? toInt32 (small 2147483647 0)+ , THU.testCase "I" $ Nothing @=? toInt32 (large 4294967295e40 (-40))+ , THU.testCase "J" $ Just (-2147483640) @=? toInt32 (small (-214748364) 1)+ , THU.testCase "K" $ Just 2147483640 @=? toInt32 (small 214748364 1)+ , THU.testCase "L" $ Nothing @=? toInt32 (small 214748365 1)+ ]+ , testGroup "Int64"+ [ THU.testCase "A" $ Just 30 @=? toInt64 (small 300 (-1))+ , THU.testCase "B" $ Just 300 @=? toInt64 (small 300 0)+ , THU.testCase "C" $ Nothing @=? toInt64 (small 1 999999999)+ , THU.testCase "D" $ Just 65535 @=? toInt64 (large 65535e40 (-40))+ , THU.testCase "E" $ Just 0 @=? toInt64 (large 0 10e30)+ , THU.testCase "F" $ Just 0 @=? toInt64 (small 0 999999999)+ , THU.testCase "G" $ Just (-10) @=? toInt64 (small (-1) 1)+ , THU.testCase "H" $ Just 4294967296 @=? toInt64 (small 4294967296 0)+ , THU.testCase "I" $ Just 4294967295 @=? toInt64 (large 4294967295e40 (-40))+ , THU.testCase "J" $ Just 4294967295 @=? toInt64 (small 4294967295 0)+ , THU.testCase "K" $ Nothing @=? toInt64 (large (2 ^ (64 :: Int)) 0)+ , THU.testCase "L" $ Just maxBound @=? toInt64 (large ((2 ^ (63 :: Int)) - 1) 0)+ , THU.testCase "M" $ Just (fromIntegral (maxBound :: Int)) @=? toInt64 (small (maxBound :: Int) 0)+ , THU.testCase "N" $ Just (fromIntegral (minBound :: Int)) @=? toInt64 (small (minBound :: Int) 0)+ , THU.testCase "O" $ Nothing @=? toInt64 (large (negate (2 ^ (63 :: Int)) - 1) 0)+ , THU.testCase "P" $ Just (minBound :: Int64) @=? toInt64 (large (negate (2 ^ (63 :: Int))) 0)+ , THU.testCase "Q" $ Just 9.2e18 @=? toInt64 (small 92 17)+ , THU.testCase "R" $ Just 9.3e17 @=? toInt64 (small 93 16)+ , THU.testCase "S" $ Nothing @=? toInt64 (small 93 17)+ , THU.testCase "T" $ Nothing @=? toInt64 (large 93 17)+ , THU.testCase "U" $ Just (-9.3e17) @=? toInt64 (small (-93) 16)+ , THU.testCase "V" $ Nothing @=? toInt64 (large 922337203685477581 1)+ ]+ , testGroup "Parser"+ [ testGroup "UTF-8-signed"+ [ testProperty "small-integer" $ \i ->+ P.Success (small i 0) 0+ ===+ P.parseBytes (SCI.parserSignedUtf8Bytes ())+ (bytes (show i))+ , testProperty "small-exp" $ \i j b ->+ P.Success (small i j) 0+ ===+ P.parseBytes (SCI.parserSignedUtf8Bytes ())+ (bytes (show i ++ bool "e" "E" b ++ show j))+ , testProperty "fixed-e12-no-exp" $ \(i :: Fixed E12) ->+ QC.counterexample (show i)+ $+ P.Success (SCI.fromFixed i) 0+ ===+ P.parseBytes (SCI.parserSignedUtf8Bytes ())+ (bytes (show i))+ , testProperty "large-integer" $ \(LargeInteger i) (LargeInteger j) ->+ QC.counterexample (show (large i j))+ $+ P.Success (large i j) 0+ ===+ P.parseBytes (SCI.parserSignedUtf8Bytes ())+ (bytes (show (large i j)))+ ]+ ]+ ]++bytes :: String -> Bytes+bytes s = let b = pack ('x' : s) in Bytes b 1 (PM.sizeofByteArray b - 1)++pack :: String -> ByteArray+pack = Exts.fromList . map (fromIntegral @Int @Word8 . ord)++-- The Arbitrary instance for Integer that comes with+-- QuickCheck only generates small numbers.+newtype LargeInteger = LargeInteger Integer+ deriving (Eq,Show)++instance QC.Arbitrary LargeInteger where+ arbitrary = do+ n <- QC.choose (1, 17)+ sign <- QC.arbitrary+ r <- (if sign then negate else id) . foldr f 0+ <$> replicateM n QC.arbitrary+ pure (LargeInteger r)+ where+ f :: Word8 -> Integer -> Integer+ f w acc = (acc `Bits.shiftL` 8) + fromIntegral w+ shrink (LargeInteger x)+ | x > 3 =+ [ LargeInteger (div x 2)+ , LargeInteger (div x 3)+ ]+ | otherwise = []+