diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,15 @@ # Revision history for scientific-notation -## 0.1.6.0 -- 2023-??-??O +## 0.1.7.0 -- 2024-02-12 +* Add `toInteger`. + +## 0.1.6.1 -- 2024-02-06 + +* Update package metadata. + +## 0.1.6.0 -- 2023-06-27 + * Support GHC 9.4 and 9.6. Drop support for GHCs older than 9.4. * Add `fromInt` and `fromInt(8|16|32|64)`. @@ -38,4 +46,4 @@ ## 0.1.0.0 -- 2019-09-24 -* First version. Released on an unsuspecting world. +* First version. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,189 +1,222 @@ -{-# language BangPatterns #-} -{-# language PackageImports #-} -{-# language MagicHash #-} -{-# language ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# 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 Data.ByteString.Internal (ByteString (PS)) +import Data.Primitive (ByteArray (..), PrimArray, SmallArray) +import Data.Word (Word16) +import GHC.ForeignPtr (ForeignPtr (ForeignPtr), ForeignPtrContents (PlainPtr)) +import Gauge (bench, bgroup, whnf) +import Gauge.Main (defaultMain) -import qualified GHC.Exts as Exts +import qualified Data.Aeson.Parser as Aeson +import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.Bytes as Bytes import qualified Data.Bytes.Parser as P import qualified Data.Bytes.Parser.Latin as Latin +import qualified Data.Bytes.Text.Ascii as Ascii import qualified Data.Primitive as PM -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.Aeson.Parser as Aeson +import qualified GHC.Exts as Exts -import qualified "scientific" Data.Scientific as SlowSci -import qualified "scientific-notation" Data.Number.Scientific as SCI +import qualified Data.Number.Scientific as SCI +import qualified Data.Scientific as SlowSci 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) - ] +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" - ] +tenSmall = + pin $ + Bytes.toByteArray $ + Ascii.fromString $ + 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" - ] - +tenLarge = + pin $ + Bytes.toByteArray $ + Ascii.fromString $ + 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) - ] +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 +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 +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) + 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 + 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 + 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 + 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 + 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 #-} +{-# 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# )) +{-# 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 diff --git a/scientific-notation.cabal b/scientific-notation.cabal --- a/scientific-notation.cabal +++ b/scientific-notation.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 -name: scientific-notation -version: 0.1.6.0 -synopsis: Scientific notation intended for tokenization +cabal-version: 2.4 +name: scientific-notation +version: 0.1.7.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 @@ -31,70 +31,78 @@ `scientific` in the following ways: . * Correctness: `scientific` does not correctly handle large exponents. See - . + . . * 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 + parser that ships with `aeson` by a factor of five on small numbers. +homepage: https://github.com/byteverse/scientific-notation +bug-reports: https://github.com/byteverse/scientific-notation/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2019 Andrew Martin +category: Data +extra-doc-files: CHANGELOG.md +tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 + +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + library + import: build-settings exposed-modules: Data.Number.Scientific build-depends: - , base >=4.17.1 && <5 - , bytebuild >=0.3.5 && <0.4 - , bytesmith >=0.3 && <0.4 - , byteslice >=0.2.6 && <0.3 - , natural-arithmetic >=0.1.1 && <0.3 - , text-short >=0.1.3 - , primitive >=0.7.1 - , bytestring >=0.10.12 - , word-compat >= 0.0.2 - hs-source-dirs: src - ghc-options: -O2 -Wall - default-language: Haskell2010 + , base >=4.17.1 && <5 + , bytebuild >=0.3.5 && <0.4 + , byteslice >=0.2.6 && <0.3 + , bytesmith >=0.3 && <0.4 + , bytestring >=0.10.12 + , natural-arithmetic >=0.1.1 && <0.3 + , primitive >=0.7.1 + , text-short >=0.1.3 + , word-compat >=0.0.2 + hs-source-dirs: src + ghc-options: -O2 + test-suite test - default-language: Haskell2010 - type: exitcode-stdio-1.0 + import: build-settings + type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Main.hs - ghc-options: -Wall -O2 + main-is: Main.hs build-depends: - , QuickCheck >=2.13.1 - , base >=4.12.0.0 && <5 - , bytebuild + , base >=4.12.0.0 && <5 , byteslice - , bytestring + , bytesmith + , primitive , scientific-notation - , tasty >=1.2.3 - , tasty-hunit >=0.10.0.2 + , tasty >=1.2.3 + , tasty-hunit >=0.10.0.2 , tasty-quickcheck - , primitive - , bytesmith benchmark bench - type: exitcode-stdio-1.0 + import: build-settings + type: exitcode-stdio-1.0 build-depends: + , attoparsec + , attoparsec-aeson , base - , gauge >= 0.2.4 - , byteslice >= 0.1.2 - , scientific-notation - , primitive + , byteslice >=0.1.2 , bytesmith - , aeson - , attoparsec , bytestring - , scientific + , gauge >=0.2.4 + , primitive , run-st - ghc-options: -Wall -O2 - default-language: Haskell2010 + , scientific + , scientific-notation + + ghc-options: -O2 hs-source-dirs: bench - main-is: Main.hs + main-is: Main.hs + +source-repository head + type: git + location: git://github.com/byteverse/scientific-notation.git diff --git a/src/Data/Number/Scientific.hs b/src/Data/Number/Scientific.hs --- a/src/Data/Number/Scientific.hs +++ b/src/Data/Number/Scientific.hs @@ -1,1220 +1,1408 @@ -{-# language BangPatterns #-} -{-# language DuplicateRecordFields #-} -{-# language LambdaCase #-} -{-# language NumericUnderscores #-} -{-# language TypeApplications #-} -{-# language MultiWayIf #-} -{-# language MagicHash #-} -{-# language UnboxedTuples #-} - -module Data.Number.Scientific - ( Scientific - , Scientific# - -- * Produce - , small - , large - , fromFixed - , fromWord8 - , fromWord16 - , fromWord32 - , fromWord64 - , fromInt - , fromInt8 - , fromInt16 - , fromInt32 - , fromInt64 - -- * Consume - , toWord - , toWord8 - , toWord16 - , toWord32 - , toWord64 - , toInt - , toInt32 - , toInt64 - , withExposed - -- * Scale and Consume - , roundShiftedToInt64 - -- * Compare - , greaterThanInt64 - -- * Decode - , parserSignedUtf8Bytes - , parserTrailingUtf8Bytes - , parserUnsignedUtf8Bytes - , parserNegatedUtf8Bytes - , parserNegatedTrailingUtf8Bytes - , parserSignedUtf8Bytes# - , parserTrailingUtf8Bytes# - , parserUnsignedUtf8Bytes# - , parserNegatedUtf8Bytes# - , parserNegatedTrailingUtf8Bytes# - -- * Encode - , encode - , builderUtf8 - ) where - -import Prelude hiding (negate) - -import Control.Monad.ST (runST) -import Data.ByteString.Short.Internal (ShortByteString(SBS)) -import Data.Bytes.Builder (Builder) -import Data.Bytes.Parser.Unsafe (Parser(..)) -import Data.Bytes.Types (Bytes(Bytes)) -import Data.Fixed (Fixed(MkFixed),HasResolution) -import Data.Primitive (ByteArray(ByteArray)) -import Data.Text.Short (ShortText) -import GHC.Exts (Int#,Word#,(+#),intToInt64#,int64ToInt#) -import GHC.Int.Compat -import GHC.Word.Compat - -import qualified Arithmetic.Nat as Nat -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Builder as Builder -import qualified Data.Bytes.Builder.Bounded as BB -import qualified Data.Bytes.Builder.Bounded.Unsafe as BBU -import qualified Data.Bytes.Chunks as Chunks -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 Data.Bytes.Types as BT -import qualified Data.Fixed as Fixed -import qualified Data.Primitive as PM -import qualified Data.Text.Short.Unsafe as TS -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 -- coefficent - !Integer -- exponent - --- Padding just needs to be any number larger than the number of decimal --- digits that could represent a 64-bit integer. Normalization of scientific --- numbers using the small representation is only sound when we know that we --- are not going to trigger an overflow. -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# (intToInt64# i)) - --- | This works even if the number has a fractional component. For example: --- --- >>> roundShiftedToInt64 2 (fromFixed @E3 1.037) --- 103 --- --- The shift amount should be a small constant between -100 and 100. --- The behavior of a shift outside this range is undefined. -roundShiftedToInt64 :: - Int -- ^ Exponent @e@, @n@ is multiplied by @10^e@ before rounding - -> Scientific -- ^ Number @n@ - -> Maybe Int64 -{-# inline roundShiftedToInt64 #-} -roundShiftedToInt64 (I# adj) (Scientific (I# coeff) (I# e) largeNum) = - case roundToInt# coeff e adj largeNum of - (# (# #) | #) -> Nothing - (# | i #) -> Just (I64# (intToInt64# i)) - --- | Convert a 64-bit unsigned word to a 'Scientific'. -fromWord64 :: Word64 -> Scientific -fromWord64 !w = if w <= 9223372036854775807 - then Scientific (fromIntegral w) 0 zeroLarge - else - let !b = LargeScientific (fromIntegral w) 0 - in Scientific 0 minBound b - -fromInt :: Int -> Scientific -{-# inline fromInt #-} -fromInt coeff = Scientific coeff 0 zeroLarge - -fromInt8 :: Int8 -> Scientific -{-# inline fromInt8 #-} -fromInt8 coeff = Scientific (fromIntegral coeff) 0 zeroLarge - -fromInt16 :: Int16 -> Scientific -{-# inline fromInt16 #-} -fromInt16 coeff = Scientific (fromIntegral coeff) 0 zeroLarge - -fromInt32 :: Int32 -> Scientific -{-# inline fromInt32 #-} -fromInt32 coeff = Scientific (fromIntegral coeff) 0 zeroLarge - -fromInt64 :: Int64 -> Scientific -{-# inline fromInt64 #-} -fromInt64 coeff = Scientific (fromIntegral coeff) 0 zeroLarge - --- | Convert an 8-bit unsigned word to a 'Scientific'. -fromWord8 :: Word8 -> Scientific -{-# inline fromWord8 #-} -fromWord8 !w = Scientific (fromIntegral w) 0 zeroLarge - --- | Convert a 16-bit unsigned word to a 'Scientific'. -fromWord16 :: Word16 -> Scientific -{-# inline fromWord16 #-} -fromWord16 !w = Scientific (fromIntegral w) 0 zeroLarge - --- | Convert a 32-bit unsigned word to a 'Scientific'. -fromWord32 :: Word32 -> Scientific -{-# inline fromWord32 #-} -fromWord32 !w = Scientific (fromIntegral w) 0 zeroLarge - --- | Is the number represented in scientific notation greater than the --- 64-bit integer argument? -greaterThanInt64 :: Scientific -> Int64 -> Bool -greaterThanInt64 (Scientific coeff0@(I# coeff0# ) e0 large0) tgt@(I64# tgt# ) - | e0 == minBound = largeGreaterThanInt64 large0 tgt - | coeff0 == 0 = 0 > tgt - | e0 == 0 = I64# (intToInt64# coeff0#) > tgt - | coeff0 > 0 = - if | tgt <= 0 -> True - | e0 > 0 -> case smallToInt coeff0 e0 of - (# (# #) | #) -> True - (# | i# #) -> I64# (intToInt64# i#) > tgt - -- In last case, e0 is less than zero. - | otherwise -> case posIntExp10 (I# (int64ToInt# tgt#)) (Prelude.negate e0) of - (# (# #) | #) -> False - (# | i# #) -> I64# (intToInt64# coeff0#) > I64# (intToInt64# i#) - | otherwise = -- Coefficent is negative - if | tgt >= 0 -> False - | e0 > 0 -> case smallToInt coeff0 e0 of - (# (# #) | #) -> False - (# | i# #) -> I64# (intToInt64# i#) > tgt - -- In last case, e0 is less than zero. - | otherwise -> case negIntExp10 (I# (int64ToInt# tgt#)) (Prelude.negate e0) of - (# (# #) | #) -> True - (# | i# #) -> I64# (intToInt64# coeff0#) > I64# (intToInt64# i#) - -largeGreaterThanInt64 :: LargeScientific -> Int64 -> Bool -largeGreaterThanInt64 large0@(LargeScientific coeff e) !tgt - | coeff == 0 = 0 > tgt - | e == 0 = coeff > fromIntegral @Int64 @Integer tgt - | coeff > 0 = - if | tgt <= 0 -> True - | e > 0 -> case largeToInt large0 of - (# (# #) | #) -> True - (# | i# #) -> I64# (intToInt64# i#) > tgt - | otherwise -> case posSciLowerBound False coeff e of - Exactly n -> n > fromIntegral @Int64 @Integer tgt - LowerBoundedMagnitude n -> (n+1) > fromIntegral @Int64 @Integer tgt - | otherwise = -- Coefficent is negative - if | tgt >= 0 -> False - | e > 0 -> case largeToInt large0 of - (# (# #) | #) -> False - (# | i# #) -> I64# (intToInt64# i#) > tgt - | otherwise -> case posSciLowerBound False coeff e of - Exactly n -> n > fromIntegral @Int64 @Integer tgt - LowerBoundedMagnitude n -> n > fromIntegral @Int64 @Integer tgt - --- | Expose the non-normalized exponent and coefficient. -withExposed :: - (Int -> Int -> a) - -- ^ Called when coefficient and exponent are small - -> (Integer -> Integer -> a) - -- ^ Called when coefficient and exponent are large - -> Scientific - -> a -withExposed f g (Scientific coeff theExp big) = if theExp /= minBound - then f coeff theExp - else case big of - LargeScientific coeff' theExp' -> g coeff' theExp' - -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 - -roundToInt# :: Int# -> Int# -> Int# -> LargeScientific -> (# (# #) | Int# #) -{-# noinline roundToInt# #-} -roundToInt# coefficient0# exponent0# adjustment0# largeNum = - if exponent0 /= minBound - then - if | coefficient0 == 0 -> (# | 0# #) - | exponent0 > (maxBound - 200) -> (# (# #) | #) - | exponent0 < (minBound + 200) -> (# (# #) | #) - | adjustment0 > 100 -> (# (# #) | #) - | adjustment0 < (-100) -> (# (# #) | #) - | otherwise -> - roundSmallToInt coefficient0 (I# (exponent0# +# adjustment0#)) - else roundLargeToInt adjustment0 largeNum - where - coefficient0 = I# coefficient0# - exponent0 = I# exponent0# - adjustment0 = I# adjustment0# - --- 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. --- This is similar to smallToInt except that we round numbers with fractional --- parts. And by round, I actually mean truncate. Fractional parts only show --- up when the exponent is negative. -roundSmallToInt :: Int -> Int -> (# (# #) | Int# #) -roundSmallToInt !coefficient0 !exponent0 - | coefficient0 == 0 = (# | 0# #) - | (coefficient@(I# coefficient# ),expon) <- incrementNegativeExp coefficient0 exponent0 - , expon < 30 = case compare expon 0 of - EQ -> (# | coefficient# #) - GT -> if coefficient >= 0 - then posIntExp10 coefficient expon - else negIntExp10 coefficient expon - LT -> if coefficient >= 0 - then (# | roundPosIntNegExp10 coefficient expon #) - else (# | roundNegIntNegExp10 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 = (# (# #) | #) - --- Arguments are non-normalized, this targets the native word size -roundLargeToInt :: Int -> LargeScientific -> (# (# #) | Int# #) -roundLargeToInt !adj (LargeScientific coefficient0 exponent0) - | coefficient0 == 0 = (# | 0# #) - | (coefficient,expon) <- largeIncrementNegativeExp coefficient0 exponent1 - , expon < 30 - = case compare expon 0 of - EQ -> case fromIntegral @Integer @Int coefficient of - I# r -> (# | r #) - GT -> - if coefficient >= (fromIntegral @Int @Integer minBound) && coefficient <= (fromIntegral @Int @Integer maxBound) - then if coefficient >= 0 - then posIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon) - else negIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon) - else (# (# #) | #) - LT -> if expon < (-100_000_000_000) - then -- Due to the realities of hardward, a negative exponent with high - -- magnitude is guaranteed to produce a zero result. A coefficient - -- large enough to resist the zero result would consume all memory. - (# | 0# #) - else if coefficient >= 0 - then roundPosIntegerNegExp10 coefficient (fromInteger expon) - else roundNegIntegerNegExp10 coefficient (fromInteger expon) - | otherwise = (# (# #) | #) - where - exponent1 = exponent0 + toInteger adj - --- 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-positive, and the --- coefficient is non-negative. This returns an unboxed --- Nothing on overflow. -roundPosIntNegExp10 :: Int -> Int -> Int# -roundPosIntNegExp10 !a@(I# a# ) !e = case e of - 0 -> a# - _ -> roundPosIntNegExp10 (quot a 10) (e + 1) - --- Precondition: The exponent is non-positive, and the --- coefficient is non-negative. This returns an unboxed --- Nothing on overflow. -roundPosIntegerNegExp10 :: Integer -> Int -> (# (# #) | Int# #) -roundPosIntegerNegExp10 !a !e = case e of - 0 -> if a > fromIntegral @Int @Integer maxBound - then (# (# #) | #) - else case fromInteger a of - I# a# -> (# | a# #) - _ -> case a of - 0 -> (# | 0# #) - _ -> roundPosIntegerNegExp10 (quot a 10) (e + 1) - --- 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 (# (# #) | #) - --- Precondition: The exponent is non-position, and the --- coefficient is non-positive. This returns an unboxed --- Nothing on overflow. -roundNegIntNegExp10 :: Int -> Int -> Int# -roundNegIntNegExp10 !a@(I# a# ) !e = case e of - 0 -> a# - _ -> roundNegIntNegExp10 (quot a 10) (e + 1) - --- Precondition: The exponent is non-position, and the --- coefficient is non-positive. This returns an unboxed --- Nothing on overflow. -roundNegIntegerNegExp10 :: Integer -> Int -> (# (# #) | Int# #) -roundNegIntegerNegExp10 !a !e = case e of - 0 -> if a > fromIntegral @Int @Integer maxBound - then (# (# #) | #) - else case fromInteger a of - I# a# -> (# | a# #) - _ -> case a of - 0 -> (# | 0# #) - _ -> roundNegIntegerNegExp10 (quot a 10) (e + 1) - --- 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. --- This only ever causes the coefficient to decrease, never increase. -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) - -data Estimate - = Exactly !Integer - | LowerBoundedMagnitude !Integer - -- For positive N, LowerBoundedMagnitude N means that x > N and x < N+1. - -- For negative N, LowerBoundedMagnitude N means that x < N and x > N-1. - --- Precondition: Exponent is non-positive. Coefficient is non-zero. --- When calling this from elsewhere, set wasTruncated to False. -posSciLowerBound :: Bool -> Integer -> Integer -> Estimate -posSciLowerBound !wasTruncated !coeff !e - | e == 0 = case wasTruncated of - True -> LowerBoundedMagnitude coeff - False -> Exactly coeff - | otherwise = let (q,r) = quotRem coeff 10 in - case q of - 0 -> LowerBoundedMagnitude 0 - _ -> posSciLowerBound (wasTruncated || r /= 0) q (e + 1) - --- 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 - ) - --- | Encode a number as text. If the exponent is between -50 and +50 (exclusive), --- this represents the number without any exponent. For example: --- --- >>> encode (small 87654321 (-3)) --- "87654.321" --- >>> encode (small 5000 (-3)) --- "-5000" --- --- The decision of when to use an exponent is not considered stable part of --- this library\'s API. Check the test suite for examples of what to expect, --- and feel free to open an issue or contribute if the output of this function --- is unsightly in certain situations. -encode :: Scientific -> ShortText -encode s = case Chunks.concatU (Builder.run 128 (builderUtf8 s)) of - ByteArray x -> TS.fromShortByteStringUnsafe (SBS x) - --- | Variant of 'encode' that provides a builder instead. -builderUtf8 :: Scientific -> Builder -builderUtf8 (Scientific coeff e big) - | e == 0 = Builder.intDec coeff - | e == minBound = let LargeScientific coeff' e' = big in - if | coeff' == 0 -> Builder.ascii '0' - | e' == 0 -> Builder.integerDec coeff' - | e' > 0 && e' < 50 -> - -- TODO: Add a replicate function to builder to improve this. - Builder.integerDec coeff' <> Builder.bytes (Bytes.replicate (fromInteger e') 0x30) - | e' < 0, e' > (-50), coeff' > 0, coeff' < 18446744073709551616 -> - let coeff'' = fromInteger coeff' :: Word - e'' = fromInteger e' :: Int - in Builder.bytes (encodePosCoeffNegExp coeff'' e'') - | e' < 0, e' > (-50), coeff' < 0, coeff' > (-18446744073709551616) -> - let coeff'' = fromInteger (Prelude.negate coeff') :: Word - e'' = fromInteger e' :: Int - in Builder.bytes (encodeNegCoeffNegExp coeff'' e'') - | otherwise -> - Builder.integerDec coeff' - <> - Builder.ascii 'e' - <> - Builder.integerDec e' - | otherwise = - if | coeff == 0 -> Builder.ascii '0' - | e > 0 && e < 50 -> - -- TODO: Add a replicate function to builder to improve this. - Builder.intDec coeff <> Builder.bytes (Bytes.replicate e 0x30) - | e < 0 && e > (-50) -> if coeff > 0 - then Builder.bytes (encodePosCoeffNegExp (fromIntegral @Int @Word coeff) e) - else Builder.bytes (encodeNegCoeffNegExp (fromIntegral @Int @Word (Prelude.negate coeff)) e) - | otherwise -> Builder.fromBounded Nat.constant $ - BB.intDec coeff - `BB.append` - BB.ascii 'e' - `BB.append` - BB.intDec e - --- Precondition: exponent is negative. --- This is convoluted, so if a reader of this code thinks of a better --- way to do this, feel free to PR a more simple replacement. -encodePosCoeffNegExp :: Word -> Int -> Bytes -encodePosCoeffNegExp !w !e = runST $ do - dst <- PM.newByteArray 128 - PM.setByteArray dst 0 128 (0x30 :: Word8) - end <- BBU.pasteST (BB.wordDec w) dst 100 - let dotIx = end + e - let coeffMag = end - 100 - let extra = if coeffMag > Prelude.negate e - then (coeffMag - Prelude.negate e) - 1 - else 0 - PM.moveByteArray dst 0 dst 1 dotIx - PM.writeByteArray dst (dotIx - 1) (0x2E :: Word8) - dst' <- PM.unsafeFreezeByteArray dst - pure Bytes - { BT.array=dst' - , BT.offset=dotIx - 2 - extra - , BT.length=Prelude.negate e + 2 + extra - } - --- Precondition: exponent is negative. --- This is convoluted, so if a reader of this code thinks of a better --- way to do this, feel free to PR a more simple replacement. -encodeNegCoeffNegExp :: Word -> Int -> Bytes -encodeNegCoeffNegExp !w !e = runST $ do - dst <- PM.newByteArray 128 - PM.setByteArray dst 0 128 (0x30 :: Word8) - end <- BBU.pasteST (BB.wordDec w) dst 100 - let dotIx = end + e - let coeffMag = end - 100 - let extra = if coeffMag > Prelude.negate e - then (coeffMag - Prelude.negate e) - 1 - else 0 - PM.moveByteArray dst 0 dst 1 dotIx - PM.writeByteArray dst (dotIx - 1) (0x2E :: Word8) - PM.writeByteArray dst (dotIx - 3 - extra) (0x2D :: Word8) - dst' <- PM.unsafeFreezeByteArray dst - pure Bytes - { BT.array=dst' - , BT.offset=dotIx - 3 - extra - , BT.length=Prelude.negate e + 3 + extra - } +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} + +module Data.Number.Scientific + ( Scientific + , Scientific# + + -- * Produce + , small + , large + , fromFixed + , fromWord8 + , fromWord16 + , fromWord32 + , fromWord64 + , fromInt + , fromInt8 + , fromInt16 + , fromInt32 + , fromInt64 + + -- * Consume + , toWord + , toWord8 + , toWord16 + , toWord32 + , toWord64 + , toInt + , toInt32 + , toInt64 + , toInteger + , withExposed + + -- * Scale and Consume + , roundShiftedToInt64 + + -- * Compare + , greaterThanInt64 + + -- * Decode + , parserSignedUtf8Bytes + , parserTrailingUtf8Bytes + , parserUnsignedUtf8Bytes + , parserNegatedUtf8Bytes + , parserNegatedTrailingUtf8Bytes + , parserSignedUtf8Bytes# + , parserTrailingUtf8Bytes# + , parserUnsignedUtf8Bytes# + , parserNegatedUtf8Bytes# + , parserNegatedTrailingUtf8Bytes# + + -- * Encode + , encode + , builderUtf8 + ) where + +import Prelude hiding (negate,toInteger) + +import Control.Monad.ST (runST) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import Data.Bytes.Builder (Builder) +import Data.Bytes.Parser.Unsafe (Parser (..)) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Fixed (Fixed (MkFixed), HasResolution) +import Data.Primitive (ByteArray (ByteArray)) +import Data.Text.Short (ShortText) +import GHC.Exts (Int#, Word#, int64ToInt#, intToInt64#, (+#)) +import GHC.Int.Compat +import GHC.Word.Compat + +import qualified Arithmetic.Nat as Nat +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Builder as Builder +import qualified Data.Bytes.Builder.Bounded as BB +import qualified Data.Bytes.Builder.Bounded.Unsafe as BBU +import qualified Data.Bytes.Chunks as Chunks +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 Data.Bytes.Types as BT +import qualified Data.Fixed as Fixed +import qualified Data.Primitive as PM +import qualified Data.Text.Short.Unsafe as TS +import qualified GHC.Exts as Exts +import qualified 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 -- coefficent + !Integer -- exponent + +-- Padding just needs to be any number larger than the number of decimal +-- digits that could represent a 64-bit integer. Normalization of scientific +-- numbers using the small representation is only sound when we know that we +-- are not going to trigger an overflow. +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 :: + -- | Coefficient + Int -> + -- | Exponent + Int -> + 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 :: + -- | Coefficient + Integer -> + -- | Exponent + Integer -> + 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# (intToInt64# i)) + +-- | This can exhaust memory. Do not use on untrusted input. +toInteger :: Scientific -> Maybe Integer +toInteger (Scientific coeff e largeNum) + | e == minBound = case largeNum of + LargeScientific bigCoeff bigExp -> case compare bigExp 0 of + GT -> Just (bigCoeff * ((10 :: Integer) ^ bigExp)) + EQ -> Just bigCoeff + LT -> case attemptLargeNegativeExponentiate bigCoeff (Prelude.negate bigExp) of + Nothing -> Nothing + Just i -> Just i + | otherwise = case compare e 0 of + GT -> Just (Prelude.toInteger coeff * ((10 :: Integer) ^ e)) + EQ -> Just (Prelude.toInteger coeff) + LT -> case attemptNegativeExponentiate coeff (Prelude.negate e) of + Nothing -> Nothing + Just i -> Just (Prelude.toInteger i) + +-- The exponent argument must be non-negative, but we interpret it as +-- a negative number. +attemptNegativeExponentiate :: Int -> Int -> Maybe Int +attemptNegativeExponentiate c0 e0 = go c0 e0 where + -- Note: This is unoptimized and has poor performance. + go :: Int -> Int -> Maybe Int + go !c !e = case compare e 0 of + EQ -> Just c + GT -> + let c' = div c 10 + in if c' * 10 == c + then go c' (e - 1) + else Nothing + LT -> errorWithoutStackTrace "attemptNegativeExponentiate: invariant violated" + +-- The exponent argument must be non-negative, but we interpret it as +-- a negative number. +attemptLargeNegativeExponentiate :: Integer -> Integer -> Maybe Integer +attemptLargeNegativeExponentiate c0 e0 = go c0 e0 where + -- Note: This is unoptimized and has poor performance. + go :: Integer -> Integer -> Maybe Integer + go !c !e = case compare e 0 of + EQ -> Just c + GT -> + let c' = div c 10 + in if c' * 10 == c + then go c' (e - 1) + else Nothing + LT -> errorWithoutStackTrace "attemptLargeNegativeExponentiate: invariant violated" + +{- | This works even if the number has a fractional component. For example: + +>>> roundShiftedToInt64 2 (fromFixed @E3 1.037) +103 + +The shift amount should be a small constant between -100 and 100. +The behavior of a shift outside this range is undefined. +-} +roundShiftedToInt64 :: + -- | Exponent @e@, @n@ is multiplied by @10^e@ before rounding + Int -> + -- | Number @n@ + Scientific -> + Maybe Int64 +{-# INLINE roundShiftedToInt64 #-} +roundShiftedToInt64 (I# adj) (Scientific (I# coeff) (I# e) largeNum) = + case roundToInt# coeff e adj largeNum of + (# (# #) | #) -> Nothing + (# | i #) -> Just (I64# (intToInt64# i)) + +-- | Convert a 64-bit unsigned word to a 'Scientific'. +fromWord64 :: Word64 -> Scientific +fromWord64 !w = + if w <= 9223372036854775807 + then Scientific (fromIntegral w) 0 zeroLarge + else + let !b = LargeScientific (fromIntegral w) 0 + in Scientific 0 minBound b + +fromInt :: Int -> Scientific +{-# INLINE fromInt #-} +fromInt coeff = Scientific coeff 0 zeroLarge + +fromInt8 :: Int8 -> Scientific +{-# INLINE fromInt8 #-} +fromInt8 coeff = Scientific (fromIntegral coeff) 0 zeroLarge + +fromInt16 :: Int16 -> Scientific +{-# INLINE fromInt16 #-} +fromInt16 coeff = Scientific (fromIntegral coeff) 0 zeroLarge + +fromInt32 :: Int32 -> Scientific +{-# INLINE fromInt32 #-} +fromInt32 coeff = Scientific (fromIntegral coeff) 0 zeroLarge + +fromInt64 :: Int64 -> Scientific +{-# INLINE fromInt64 #-} +fromInt64 coeff = Scientific (fromIntegral coeff) 0 zeroLarge + +-- | Convert an 8-bit unsigned word to a 'Scientific'. +fromWord8 :: Word8 -> Scientific +{-# INLINE fromWord8 #-} +fromWord8 !w = Scientific (fromIntegral w) 0 zeroLarge + +-- | Convert a 16-bit unsigned word to a 'Scientific'. +fromWord16 :: Word16 -> Scientific +{-# INLINE fromWord16 #-} +fromWord16 !w = Scientific (fromIntegral w) 0 zeroLarge + +-- | Convert a 32-bit unsigned word to a 'Scientific'. +fromWord32 :: Word32 -> Scientific +{-# INLINE fromWord32 #-} +fromWord32 !w = Scientific (fromIntegral w) 0 zeroLarge + +{- | Is the number represented in scientific notation greater than the +64-bit integer argument? +-} +greaterThanInt64 :: Scientific -> Int64 -> Bool +greaterThanInt64 (Scientific coeff0@(I# coeff0#) e0 large0) tgt@(I64# tgt#) + | e0 == minBound = largeGreaterThanInt64 large0 tgt + | coeff0 == 0 = 0 > tgt + | e0 == 0 = I64# (intToInt64# coeff0#) > tgt + | coeff0 > 0 = + if + | tgt <= 0 -> True + | e0 > 0 -> case smallToInt coeff0 e0 of + (# (# #) | #) -> True + (# | i# #) -> I64# (intToInt64# i#) > tgt + -- In last case, e0 is less than zero. + | otherwise -> case posIntExp10 (I# (int64ToInt# tgt#)) (Prelude.negate e0) of + (# (# #) | #) -> False + (# | i# #) -> I64# (intToInt64# coeff0#) > I64# (intToInt64# i#) + | otherwise -- Coefficent is negative + = + if + | tgt >= 0 -> False + | e0 > 0 -> case smallToInt coeff0 e0 of + (# (# #) | #) -> False + (# | i# #) -> I64# (intToInt64# i#) > tgt + -- In last case, e0 is less than zero. + | otherwise -> case negIntExp10 (I# (int64ToInt# tgt#)) (Prelude.negate e0) of + (# (# #) | #) -> True + (# | i# #) -> I64# (intToInt64# coeff0#) > I64# (intToInt64# i#) + +largeGreaterThanInt64 :: LargeScientific -> Int64 -> Bool +largeGreaterThanInt64 large0@(LargeScientific coeff e) !tgt + | coeff == 0 = 0 > tgt + | e == 0 = coeff > fromIntegral @Int64 @Integer tgt + | coeff > 0 = + if + | tgt <= 0 -> True + | e > 0 -> case largeToInt large0 of + (# (# #) | #) -> True + (# | i# #) -> I64# (intToInt64# i#) > tgt + | otherwise -> case posSciLowerBound False coeff e of + Exactly n -> n > fromIntegral @Int64 @Integer tgt + LowerBoundedMagnitude n -> (n + 1) > fromIntegral @Int64 @Integer tgt + | otherwise -- Coefficent is negative + = + if + | tgt >= 0 -> False + | e > 0 -> case largeToInt large0 of + (# (# #) | #) -> False + (# | i# #) -> I64# (intToInt64# i#) > tgt + | otherwise -> case posSciLowerBound False coeff e of + Exactly n -> n > fromIntegral @Int64 @Integer tgt + LowerBoundedMagnitude n -> n > fromIntegral @Int64 @Integer tgt + +-- | Expose the non-normalized exponent and coefficient. +withExposed :: + -- | Called when coefficient and exponent are small + (Int -> Int -> a) -> + -- | Called when coefficient and exponent are large + (Integer -> Integer -> a) -> + Scientific -> + a +withExposed f g (Scientific coeff theExp big) = + if theExp /= minBound + then f coeff theExp + else case big of + LargeScientific coeff' theExp' -> g coeff' theExp' + +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 + +roundToInt# :: Int# -> Int# -> Int# -> LargeScientific -> (# (# #) | Int# #) +{-# NOINLINE roundToInt# #-} +roundToInt# coefficient0# exponent0# adjustment0# largeNum = + if exponent0 /= minBound + then + if + | coefficient0 == 0 -> (# | 0# #) + | exponent0 > (maxBound - 200) -> (# (# #) | #) + | exponent0 < (minBound + 200) -> (# (# #) | #) + | adjustment0 > 100 -> (# (# #) | #) + | adjustment0 < (-100) -> (# (# #) | #) + | otherwise -> + roundSmallToInt coefficient0 (I# (exponent0# +# adjustment0#)) + else roundLargeToInt adjustment0 largeNum + where + coefficient0 = I# coefficient0# + exponent0 = I# exponent0# + adjustment0 = I# adjustment0# + +-- 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. +-- This is similar to smallToInt except that we round numbers with fractional +-- parts. And by round, I actually mean truncate. Fractional parts only show +-- up when the exponent is negative. +roundSmallToInt :: Int -> Int -> (# (# #) | Int# #) +roundSmallToInt !coefficient0 !exponent0 + | coefficient0 == 0 = (# | 0# #) + | (coefficient@(I# coefficient#), expon) <- incrementNegativeExp coefficient0 exponent0 + , expon < 30 = case compare expon 0 of + EQ -> (# | coefficient# #) + GT -> + if coefficient >= 0 + then posIntExp10 coefficient expon + else negIntExp10 coefficient expon + LT -> + if coefficient >= 0 + then (# | roundPosIntNegExp10 coefficient expon #) + else (# | roundNegIntNegExp10 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 = (# (# #) | #) + +-- Arguments are non-normalized, this targets the native word size +roundLargeToInt :: Int -> LargeScientific -> (# (# #) | Int# #) +roundLargeToInt !adj (LargeScientific coefficient0 exponent0) + | coefficient0 == 0 = (# | 0# #) + | (coefficient, expon) <- largeIncrementNegativeExp coefficient0 exponent1 + , expon < 30 = + case compare expon 0 of + EQ -> case fromIntegral @Integer @Int coefficient of + I# r -> (# | r #) + GT -> + if coefficient >= (fromIntegral @Int @Integer minBound) && coefficient <= (fromIntegral @Int @Integer maxBound) + then + if coefficient >= 0 + then posIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon) + else negIntExp10 (fromIntegral @Integer @Int coefficient) (fromIntegral @Integer @Int expon) + else (# (# #) | #) + LT -> + if expon < (-100_000_000_000) + then -- Due to the realities of hardward, a negative exponent with high + -- magnitude is guaranteed to produce a zero result. A coefficient + -- large enough to resist the zero result would consume all memory. + (# | 0# #) + else + if coefficient >= 0 + then roundPosIntegerNegExp10 coefficient (fromInteger expon) + else roundNegIntegerNegExp10 coefficient (fromInteger expon) + | otherwise = (# (# #) | #) + where + exponent1 = exponent0 + Prelude.toInteger adj + +-- 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-positive, and the +-- coefficient is non-negative. This returns an unboxed +-- Nothing on overflow. +roundPosIntNegExp10 :: Int -> Int -> Int# +roundPosIntNegExp10 !a@(I# a#) !e = case e of + 0 -> a# + _ -> roundPosIntNegExp10 (quot a 10) (e + 1) + +-- Precondition: The exponent is non-positive, and the +-- coefficient is non-negative. This returns an unboxed +-- Nothing on overflow. +roundPosIntegerNegExp10 :: Integer -> Int -> (# (# #) | Int# #) +roundPosIntegerNegExp10 !a !e = case e of + 0 -> + if a > fromIntegral @Int @Integer maxBound + then (# (# #) | #) + else case fromInteger a of + I# a# -> (# | a# #) + _ -> case a of + 0 -> (# | 0# #) + _ -> roundPosIntegerNegExp10 (quot a 10) (e + 1) + +-- 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 (# (# #) | #) + +-- Precondition: The exponent is non-position, and the +-- coefficient is non-positive. This returns an unboxed +-- Nothing on overflow. +roundNegIntNegExp10 :: Int -> Int -> Int# +roundNegIntNegExp10 !a@(I# a#) !e = case e of + 0 -> a# + _ -> roundNegIntNegExp10 (quot a 10) (e + 1) + +-- Precondition: The exponent is non-position, and the +-- coefficient is non-positive. This returns an unboxed +-- Nothing on overflow. +roundNegIntegerNegExp10 :: Integer -> Int -> (# (# #) | Int# #) +roundNegIntegerNegExp10 !a !e = case e of + 0 -> + if a > fromIntegral @Int @Integer maxBound + then (# (# #) | #) + else case fromInteger a of + I# a# -> (# | a# #) + _ -> case a of + 0 -> (# | 0# #) + _ -> roundNegIntegerNegExp10 (quot a 10) (e + 1) + +-- 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. +-- This only ever causes the coefficient to decrease, never increase. +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# :: + -- | Error message + e -> + -- | Leading digit + Int# -> + Parser e s Scientific# +{-# NOINLINE parserTrailingUtf8Bytes# #-} +parserTrailingUtf8Bytes# e leader = + mapIntPairToScientific (parseSmallTrailing# leader) + `orElseScientific` upcastLargeScientific (parseLargeTrailing e (I# leader)) + +parserNegatedTrailingUtf8Bytes# :: + -- | Error message + e -> + -- | Leading digit + Int# -> + Parser e s Scientific# +{-# NOINLINE parserNegatedTrailingUtf8Bytes# #-} +parserNegatedTrailingUtf8Bytes# e leader = + mapNegateIntPairToScientific (parseSmallTrailing# leader) + `orElseScientific` upcastNegatedLargeScientific (parseLargeTrailing e (I# leader)) + +parserSignedUtf8Bytes# :: + -- | Error message + e -> + 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# :: + -- | Error message + e -> + Parser e s Scientific# +parserUnsignedUtf8Bytes# e = + mapIntPairToScientific parseSmall# + `orElseScientific` upcastLargeScientific (parseLarge e) + +-- Negates the result after parsing the bytes. +parserNegatedUtf8Bytes# :: + -- | Error message + e -> + Parser e s Scientific# +parserNegatedUtf8Bytes# e = + mapNegateIntPairToScientific parseSmall# + `orElseScientific` upcastNegatedLargeScientific (parseLarge e) + +parserTrailingUtf8Bytes :: + -- | Error message + e -> + -- | Leading digit, should be between @-9@ and @9@. + Int -> + Parser e s Scientific +parserTrailingUtf8Bytes e (I# leader) = + boxScientific (parserTrailingUtf8Bytes# e leader) + +parserNegatedTrailingUtf8Bytes :: + -- | Error message + e -> + -- | Leading digit, should be between @-9@ and @9@. + Int -> + 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) + else -- If we overflow, fail so that the parser + -- for large number will handle it instead. + 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) + +data Estimate + = Exactly !Integer + | LowerBoundedMagnitude !Integer + +-- For positive N, LowerBoundedMagnitude N means that x > N and x < N+1. +-- For negative N, LowerBoundedMagnitude N means that x < N and x > N-1. + +-- Precondition: Exponent is non-positive. Coefficient is non-zero. +-- When calling this from elsewhere, set wasTruncated to False. +posSciLowerBound :: Bool -> Integer -> Integer -> Estimate +posSciLowerBound !wasTruncated !coeff !e + | e == 0 = case wasTruncated of + True -> LowerBoundedMagnitude coeff + False -> Exactly coeff + | otherwise = + let (q, r) = quotRem coeff 10 + in case q of + 0 -> LowerBoundedMagnitude 0 + _ -> posSciLowerBound (wasTruncated || r /= 0) q (e + 1) + +-- 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 + ) + +{- | Encode a number as text. If the exponent is between -50 and +50 (exclusive), +this represents the number without any exponent. For example: + +>>> encode (small 87654321 (-3)) +"87654.321" +>>> encode (small 5000 (-3)) +"-5000" + +The decision of when to use an exponent is not considered stable part of +this library\'s API. Check the test suite for examples of what to expect, +and feel free to open an issue or contribute if the output of this function +is unsightly in certain situations. +-} +encode :: Scientific -> ShortText +encode s = case Chunks.concatU (Builder.run 128 (builderUtf8 s)) of + ByteArray x -> TS.fromShortByteStringUnsafe (SBS x) + +-- | Variant of 'encode' that provides a builder instead. +builderUtf8 :: Scientific -> Builder +builderUtf8 (Scientific coeff e big) + | e == 0 = Builder.intDec coeff + | e == minBound = + let LargeScientific coeff' e' = big + in if + | coeff' == 0 -> Builder.ascii '0' + | e' == 0 -> Builder.integerDec coeff' + | e' > 0 && e' < 50 -> + -- TODO: Add a replicate function to builder to improve this. + Builder.integerDec coeff' <> Builder.bytes (Bytes.replicate (fromInteger e') 0x30) + | e' < 0 + , e' > (-50) + , coeff' > 0 + , coeff' < 18446744073709551616 -> + let coeff'' = fromInteger coeff' :: Word + e'' = fromInteger e' :: Int + in Builder.bytes (encodePosCoeffNegExp coeff'' e'') + | e' < 0 + , e' > (-50) + , coeff' < 0 + , coeff' > (-18446744073709551616) -> + let coeff'' = fromInteger (Prelude.negate coeff') :: Word + e'' = fromInteger e' :: Int + in Builder.bytes (encodeNegCoeffNegExp coeff'' e'') + | otherwise -> + Builder.integerDec coeff' + <> Builder.ascii 'e' + <> Builder.integerDec e' + | otherwise = + if + | coeff == 0 -> Builder.ascii '0' + | e > 0 && e < 50 -> + -- TODO: Add a replicate function to builder to improve this. + Builder.intDec coeff <> Builder.bytes (Bytes.replicate e 0x30) + | e < 0 && e > (-50) -> + if coeff > 0 + then Builder.bytes (encodePosCoeffNegExp (fromIntegral @Int @Word coeff) e) + else Builder.bytes (encodeNegCoeffNegExp (fromIntegral @Int @Word (Prelude.negate coeff)) e) + | otherwise -> + Builder.fromBounded Nat.constant $ + BB.intDec coeff + `BB.append` BB.ascii 'e' + `BB.append` BB.intDec e + +-- Precondition: exponent is negative. +-- This is convoluted, so if a reader of this code thinks of a better +-- way to do this, feel free to PR a more simple replacement. +encodePosCoeffNegExp :: Word -> Int -> Bytes +encodePosCoeffNegExp !w !e = runST $ do + dst <- PM.newByteArray 128 + PM.setByteArray dst 0 128 (0x30 :: Word8) + end <- BBU.pasteST (BB.wordDec w) dst 100 + let dotIx = end + e + let coeffMag = end - 100 + let extra = + if coeffMag > Prelude.negate e + then (coeffMag - Prelude.negate e) - 1 + else 0 + PM.moveByteArray dst 0 dst 1 dotIx + PM.writeByteArray dst (dotIx - 1) (0x2E :: Word8) + dst' <- PM.unsafeFreezeByteArray dst + pure + Bytes + { BT.array = dst' + , BT.offset = dotIx - 2 - extra + , BT.length = Prelude.negate e + 2 + extra + } + +-- Precondition: exponent is negative. +-- This is convoluted, so if a reader of this code thinks of a better +-- way to do this, feel free to PR a more simple replacement. +encodeNegCoeffNegExp :: Word -> Int -> Bytes +encodeNegCoeffNegExp !w !e = runST $ do + dst <- PM.newByteArray 128 + PM.setByteArray dst 0 128 (0x30 :: Word8) + end <- BBU.pasteST (BB.wordDec w) dst 100 + let dotIx = end + e + let coeffMag = end - 100 + let extra = + if coeffMag > Prelude.negate e + then (coeffMag - Prelude.negate e) - 1 + else 0 + PM.moveByteArray dst 0 dst 1 dotIx + PM.writeByteArray dst (dotIx - 1) (0x2E :: Word8) + PM.writeByteArray dst (dotIx - 3 - extra) (0x2D :: Word8) + dst' <- PM.unsafeFreezeByteArray dst + pure + Bytes + { BT.array = dst' + , BT.offset = dotIx - 3 - extra + , BT.length = Prelude.negate e + 3 + extra + } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,27 +1,27 @@ -{-# language BangPatterns #-} -{-# language NumericUnderscores #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language OverloadedStrings #-} -{-# language NumDecimals #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Control.Monad (when,replicateM) +import Prelude hiding (toInteger) + +import Control.Monad (replicateM, when) import Data.Bool (bool) -import Data.Bytes.Types (Bytes(Bytes)) +import Data.Bytes.Types (Bytes (Bytes)) import Data.Char (ord) -import Data.Fixed (Fixed,E12) +import Data.Fixed (E12, Fixed) import Data.Int (Int64) -import Data.Number.Scientific (large,small,toWord8,toWord16,toWord32,toWord64) -import Data.Number.Scientific (toInt64,toInt32,roundShiftedToInt64) +import Data.Number.Scientific (large, roundShiftedToInt64, small, toInt32, toInt64, toWord16, toWord32, toWord64, toWord8, toInteger) 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 Test.Tasty (TestTree, defaultMain, testGroup) +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.Number.Scientific as SCI import qualified Data.Primitive as PM import qualified GHC.Exts as Exts import qualified Test.Tasty.HUnit as THU @@ -31,231 +31,249 @@ 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) - , THU.testCase "W" $ Just 12 @=? roundShiftedToInt64 1 (small 129 (-2)) - , THU.testCase "X" $ Just (-12) @=? roundShiftedToInt64 1 (small (-129) (-2)) - , THU.testCase "Y" $ Nothing @=? roundShiftedToInt64 31 (small 129 (-2)) - , THU.testCase "Z" $ Just (1.29e18) @=? roundShiftedToInt64 18 (small 129 (-2)) - , THU.testCase "AA" $ Just 9223372 @=? roundShiftedToInt64 (-26) (large 9223372036854775817425364203 5) - , THU.testCase "AB" $ Just (-9223372) @=? roundShiftedToInt64 (-26) (large (-9223372036854775817425364203) 5) - , THU.testCase "AC" $ Just 0 @=? roundShiftedToInt64 0 (large (-9223372036854775817425364203) (-1_000_000_000)) - , THU.testCase "AD" $ Just 0 @=? roundShiftedToInt64 0 (large (50000000000000000000000000000) (-1_000_000_000)) - , THU.testCase "AE" $ Just 2 @=? toInt64 (small 2 0) - , THU.testCase "AF" $ Just 2 @=? toInt64 (large 2 0) - ] - , testGroup "Compare" - [ THU.testCase "A" $ SCI.greaterThanInt64 (small 300 (-2)) 2 @=? True - , THU.testCase "B" $ SCI.greaterThanInt64 (small 300 (-2)) 3 @=? False - , THU.testCase "C" $ SCI.greaterThanInt64 (small 300 (-2)) 4 @=? False - , THU.testCase "D" $ SCI.greaterThanInt64 (small (-300) (-2)) (-2) @=? False - , THU.testCase "E" $ SCI.greaterThanInt64 (small (-300) (-2)) (-3) @=? False - , THU.testCase "F" $ SCI.greaterThanInt64 (small (-300) (-2)) (-4) @=? True - , THU.testCase "G" $ SCI.greaterThanInt64 (small (-300) (-2)) 5 @=? False - , THU.testCase "H" $ SCI.greaterThanInt64 (small 300 (-2)) (-5) @=? True - , THU.testCase "I" $ SCI.greaterThanInt64 (small 300 (-2)) 0 @=? True - , THU.testCase "J" $ SCI.greaterThanInt64 (small 3 0) 0 @=? True - , THU.testCase "K" $ SCI.greaterThanInt64 (small 0 0) 0 @=? False - , THU.testCase "L" $ SCI.greaterThanInt64 (small 0 10) 0 @=? False - , THU.testCase "M" $ SCI.greaterThanInt64 (small 1 100) 20 @=? True - , THU.testCase "N" $ SCI.greaterThanInt64 (small (-5) 100) (-20) @=? False - , THU.testCase "O" $ SCI.greaterThanInt64 (small (-5) (-100)) (-1) @=? True - , THU.testCase "P" $ SCI.greaterThanInt64 (small 42 (-2)) 1 @=? False - , THU.testCase "Q" $ SCI.greaterThanInt64 (small 42 (-1)) 1 @=? True - , THU.testCase "R" $ SCI.greaterThanInt64 (large 5430747472779717375525059 0) 1 @=? True - , THU.testCase "S" $ SCI.greaterThanInt64 (large 5430747472779717375525059 (-100)) 1 @=? False - , THU.testCase "T" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) 0) 1 @=? False - , THU.testCase "U" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) (-100)) (-1) @=? True - , THU.testCase "V" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) (-100)) 0 @=? False - , THU.testCase "W" $ SCI.greaterThanInt64 (large (4e30) (-30)) 4 @=? False - , THU.testCase "X" $ SCI.greaterThanInt64 (large (4e30) (-30)) 3 @=? True - , THU.testCase "Y" $ SCI.greaterThanInt64 (large (-4e30) (-30)) (-4) @=? False - , THU.testCase "Z" $ SCI.greaterThanInt64 (large (-4e30) (-30)) (-5) @=? True - ] - , testGroup "Parser" - [ testGroup "UTF-8-signed" - [ testProperty "small-integer" $ \i -> - let str = show i in - P.Success (P.Slice (length str + 1) 0 (small i 0)) - === - P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) - , testProperty "small-exp" $ \i j b -> - let str = show i ++ bool "e" "E" b ++ show j in - P.Success (P.Slice (length str + 1) 0 (small i j)) - === - P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) - , testProperty "fixed-e12-no-exp" $ \(i :: Fixed E12) -> - let str = show i in - QC.counterexample str - $ - P.Success (P.Slice (length str + 1) 0 (SCI.fromFixed i)) - === - P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) - , testProperty "large-integer" $ \(LargeInteger i) (LargeInteger j) -> - let str = show (large i j) in - QC.counterexample str - $ - P.Success (P.Slice (length str + 1) 0 (large i j)) - === - P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) - ] - ] - , testGroup "Encode" - [ testGroup "small" - [ THU.testCase "A" $ "5000" @=? SCI.encode (small 5 3) - , THU.testCase "B" $ "-5000" @=? SCI.encode (small (-5) 3) - , THU.testCase "C" $ "0.0006" @=? SCI.encode (small 6 (-4)) - , THU.testCase "D" $ "0.087654321" @=? SCI.encode (small 87654321 (-9)) - , THU.testCase "E" $ "0.87654321" @=? SCI.encode (small 87654321 (-8)) - , THU.testCase "F" $ "8.7654321" @=? SCI.encode (small 87654321 (-7)) - , THU.testCase "G" $ "87.654321" @=? SCI.encode (small 87654321 (-6)) - , THU.testCase "H" $ "876.54321" @=? SCI.encode (small 87654321 (-5)) - , THU.testCase "I" $ "8765.4321" @=? SCI.encode (small 87654321 (-4)) - , THU.testCase "J" $ "87654.321" @=? SCI.encode (small 87654321 (-3)) - , THU.testCase "K" $ "876543.21" @=? SCI.encode (small 87654321 (-2)) - , THU.testCase "L" $ "8765432.1" @=? SCI.encode (small 87654321 (-1)) - , THU.testCase "M" $ "87654321" @=? SCI.encode (small 87654321 0) - , THU.testCase "N" $ "876543210" @=? SCI.encode (small 87654321 1) - , THU.testCase "O" $ "87654321.0" @=? SCI.encode (small 876543210 (-1)) - , THU.testCase "P" $ "-0.087654321" @=? SCI.encode (small (-87654321) (-9)) - , THU.testCase "Q" $ "-0.87654321" @=? SCI.encode (small (-87654321) (-8)) - , THU.testCase "R" $ "-8.7654321" @=? SCI.encode (small (-87654321) (-7)) - , THU.testCase "S" $ "-87.654321" @=? SCI.encode (small (-87654321) (-6)) - , THU.testCase "T" $ "-876.54321" @=? SCI.encode (small (-87654321) (-5)) - , THU.testCase "U" $ "-8765.4321" @=? SCI.encode (small (-87654321) (-4)) - , THU.testCase "V" $ "-87654.321" @=? SCI.encode (small (-87654321) (-3)) - , THU.testCase "W" $ "-876543.21" @=? SCI.encode (small (-87654321) (-2)) - , THU.testCase "X" $ "-8765432.1" @=? SCI.encode (small (-87654321) (-1)) - , THU.testCase "Y" $ "-87654321" @=? SCI.encode (small (-87654321) 0) - , THU.testCase "Z" $ "-876543210" @=? SCI.encode (small (-87654321) 1) - , THU.testCase "AA" $ "-87654321.0" @=? SCI.encode (small (-876543210) (-1)) - ] - , testGroup "large" - [ THU.testCase "A" $ "5000" @=? SCI.encode (large 5 3) - , THU.testCase "B" $ "-5000" @=? SCI.encode (large (-5) 3) - , THU.testCase "C" $ "0.0006" @=? SCI.encode (large 6 (-4)) - , THU.testCase "D" $ "0.087654321" @=? SCI.encode (large 87654321 (-9)) - , THU.testCase "E" $ "0.87654321" @=? SCI.encode (large 87654321 (-8)) - , THU.testCase "F" $ "8.7654321" @=? SCI.encode (large 87654321 (-7)) - , THU.testCase "G" $ "87.654321" @=? SCI.encode (large 87654321 (-6)) - , THU.testCase "H" $ "876.54321" @=? SCI.encode (large 87654321 (-5)) - , THU.testCase "I" $ "8765.4321" @=? SCI.encode (large 87654321 (-4)) - , THU.testCase "J" $ "87654.321" @=? SCI.encode (large 87654321 (-3)) - , THU.testCase "K" $ "876543.21" @=? SCI.encode (large 87654321 (-2)) - , THU.testCase "L" $ "8765432.1" @=? SCI.encode (large 87654321 (-1)) - , THU.testCase "M" $ "87654321" @=? SCI.encode (large 87654321 0) - , THU.testCase "N" $ "876543210" @=? SCI.encode (large 87654321 1) - , THU.testCase "O" $ "87654321.0" @=? SCI.encode (large 876543210 (-1)) - , THU.testCase "P" $ "-0.087654321" @=? SCI.encode (large (-87654321) (-9)) - , THU.testCase "Q" $ "-0.87654321" @=? SCI.encode (large (-87654321) (-8)) - , THU.testCase "R" $ "-8.7654321" @=? SCI.encode (large (-87654321) (-7)) - , THU.testCase "S" $ "-87.654321" @=? SCI.encode (large (-87654321) (-6)) - , THU.testCase "T" $ "-876.54321" @=? SCI.encode (large (-87654321) (-5)) - , THU.testCase "U" $ "-8765.4321" @=? SCI.encode (large (-87654321) (-4)) - , THU.testCase "V" $ "-87654.321" @=? SCI.encode (large (-87654321) (-3)) - , THU.testCase "W" $ "-876543.21" @=? SCI.encode (large (-87654321) (-2)) - , THU.testCase "X" $ "-8765432.1" @=? SCI.encode (large (-87654321) (-1)) - , THU.testCase "Y" $ "-87654321" @=? SCI.encode (large (-87654321) 0) - , THU.testCase "Z" $ "-876543210" @=? SCI.encode (large (-87654321) 1) - , THU.testCase "AA" $ "-87654321.0" @=? SCI.encode (large (-876543210) (-1)) - ] +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) + , THU.testCase "W" $ Just 12 @=? roundShiftedToInt64 1 (small 129 (-2)) + , THU.testCase "X" $ Just (-12) @=? roundShiftedToInt64 1 (small (-129) (-2)) + , THU.testCase "Y" $ Nothing @=? roundShiftedToInt64 31 (small 129 (-2)) + , THU.testCase "Z" $ Just (1.29e18) @=? roundShiftedToInt64 18 (small 129 (-2)) + , THU.testCase "AA" $ Just 9223372 @=? roundShiftedToInt64 (-26) (large 9223372036854775817425364203 5) + , THU.testCase "AB" $ Just (-9223372) @=? roundShiftedToInt64 (-26) (large (-9223372036854775817425364203) 5) + , THU.testCase "AC" $ Just 0 @=? roundShiftedToInt64 0 (large (-9223372036854775817425364203) (-1_000_000_000)) + , THU.testCase "AD" $ Just 0 @=? roundShiftedToInt64 0 (large (50000000000000000000000000000) (-1_000_000_000)) + , THU.testCase "AE" $ Just 2 @=? toInt64 (small 2 0) + , THU.testCase "AF" $ Just 2 @=? toInt64 (large 2 0) + ] + , testGroup + "Integer" + [ THU.testCase "A" $ Just 30 @=? toInteger (small 300 (-1)) + , THU.testCase "B" $ Just 300 @=? toInteger (small 300 0) + , THU.testCase "C" $ Just 65535 @=? toInteger (large 65535e40 (-40)) + , THU.testCase "D" $ Just 999_999_999_999_999_999_999_999_999_999_999_000 @=? toInteger (large 999_999_999_999_999_999_999_999_999_999_999 3) + , THU.testCase "E" $ Just 999_999_999_999_999_999_999_999_999_999_999 @=? toInteger (large 999_999_999_999_999_999_999_999_999_999_999_000 (-3)) + ] + , testGroup + "Compare" + [ THU.testCase "A" $ SCI.greaterThanInt64 (small 300 (-2)) 2 @=? True + , THU.testCase "B" $ SCI.greaterThanInt64 (small 300 (-2)) 3 @=? False + , THU.testCase "C" $ SCI.greaterThanInt64 (small 300 (-2)) 4 @=? False + , THU.testCase "D" $ SCI.greaterThanInt64 (small (-300) (-2)) (-2) @=? False + , THU.testCase "E" $ SCI.greaterThanInt64 (small (-300) (-2)) (-3) @=? False + , THU.testCase "F" $ SCI.greaterThanInt64 (small (-300) (-2)) (-4) @=? True + , THU.testCase "G" $ SCI.greaterThanInt64 (small (-300) (-2)) 5 @=? False + , THU.testCase "H" $ SCI.greaterThanInt64 (small 300 (-2)) (-5) @=? True + , THU.testCase "I" $ SCI.greaterThanInt64 (small 300 (-2)) 0 @=? True + , THU.testCase "J" $ SCI.greaterThanInt64 (small 3 0) 0 @=? True + , THU.testCase "K" $ SCI.greaterThanInt64 (small 0 0) 0 @=? False + , THU.testCase "L" $ SCI.greaterThanInt64 (small 0 10) 0 @=? False + , THU.testCase "M" $ SCI.greaterThanInt64 (small 1 100) 20 @=? True + , THU.testCase "N" $ SCI.greaterThanInt64 (small (-5) 100) (-20) @=? False + , THU.testCase "O" $ SCI.greaterThanInt64 (small (-5) (-100)) (-1) @=? True + , THU.testCase "P" $ SCI.greaterThanInt64 (small 42 (-2)) 1 @=? False + , THU.testCase "Q" $ SCI.greaterThanInt64 (small 42 (-1)) 1 @=? True + , THU.testCase "R" $ SCI.greaterThanInt64 (large 5430747472779717375525059 0) 1 @=? True + , THU.testCase "S" $ SCI.greaterThanInt64 (large 5430747472779717375525059 (-100)) 1 @=? False + , THU.testCase "T" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) 0) 1 @=? False + , THU.testCase "U" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) (-100)) (-1) @=? True + , THU.testCase "V" $ SCI.greaterThanInt64 (large (-5430747472779717375525059) (-100)) 0 @=? False + , THU.testCase "W" $ SCI.greaterThanInt64 (large (4e30) (-30)) 4 @=? False + , THU.testCase "X" $ SCI.greaterThanInt64 (large (4e30) (-30)) 3 @=? True + , THU.testCase "Y" $ SCI.greaterThanInt64 (large (-4e30) (-30)) (-4) @=? False + , THU.testCase "Z" $ SCI.greaterThanInt64 (large (-4e30) (-30)) (-5) @=? True + ] + , testGroup + "Parser" + [ testGroup + "UTF-8-signed" + [ testProperty "small-integer" $ \i -> + let str = show i + in P.Success (P.Slice (length str + 1) 0 (small i 0)) + === P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) + , testProperty "small-exp" $ \i j b -> + let str = show i ++ bool "e" "E" b ++ show j + in P.Success (P.Slice (length str + 1) 0 (small i j)) + === P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) + , testProperty "fixed-e12-no-exp" $ \(i :: Fixed E12) -> + let str = show i + in QC.counterexample str $ + P.Success (P.Slice (length str + 1) 0 (SCI.fromFixed i)) + === P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) + , testProperty "large-integer" $ \(LargeInteger i) (LargeInteger j) -> + let str = show (large i j) + in QC.counterexample str $ + P.Success (P.Slice (length str + 1) 0 (large i j)) + === P.parseBytes (SCI.parserSignedUtf8Bytes ()) (bytes str) + ] + ] + , testGroup + "Encode" + [ testGroup + "small" + [ THU.testCase "A" $ "5000" @=? SCI.encode (small 5 3) + , THU.testCase "B" $ "-5000" @=? SCI.encode (small (-5) 3) + , THU.testCase "C" $ "0.0006" @=? SCI.encode (small 6 (-4)) + , THU.testCase "D" $ "0.087654321" @=? SCI.encode (small 87654321 (-9)) + , THU.testCase "E" $ "0.87654321" @=? SCI.encode (small 87654321 (-8)) + , THU.testCase "F" $ "8.7654321" @=? SCI.encode (small 87654321 (-7)) + , THU.testCase "G" $ "87.654321" @=? SCI.encode (small 87654321 (-6)) + , THU.testCase "H" $ "876.54321" @=? SCI.encode (small 87654321 (-5)) + , THU.testCase "I" $ "8765.4321" @=? SCI.encode (small 87654321 (-4)) + , THU.testCase "J" $ "87654.321" @=? SCI.encode (small 87654321 (-3)) + , THU.testCase "K" $ "876543.21" @=? SCI.encode (small 87654321 (-2)) + , THU.testCase "L" $ "8765432.1" @=? SCI.encode (small 87654321 (-1)) + , THU.testCase "M" $ "87654321" @=? SCI.encode (small 87654321 0) + , THU.testCase "N" $ "876543210" @=? SCI.encode (small 87654321 1) + , THU.testCase "O" $ "87654321.0" @=? SCI.encode (small 876543210 (-1)) + , THU.testCase "P" $ "-0.087654321" @=? SCI.encode (small (-87654321) (-9)) + , THU.testCase "Q" $ "-0.87654321" @=? SCI.encode (small (-87654321) (-8)) + , THU.testCase "R" $ "-8.7654321" @=? SCI.encode (small (-87654321) (-7)) + , THU.testCase "S" $ "-87.654321" @=? SCI.encode (small (-87654321) (-6)) + , THU.testCase "T" $ "-876.54321" @=? SCI.encode (small (-87654321) (-5)) + , THU.testCase "U" $ "-8765.4321" @=? SCI.encode (small (-87654321) (-4)) + , THU.testCase "V" $ "-87654.321" @=? SCI.encode (small (-87654321) (-3)) + , THU.testCase "W" $ "-876543.21" @=? SCI.encode (small (-87654321) (-2)) + , THU.testCase "X" $ "-8765432.1" @=? SCI.encode (small (-87654321) (-1)) + , THU.testCase "Y" $ "-87654321" @=? SCI.encode (small (-87654321) 0) + , THU.testCase "Z" $ "-876543210" @=? SCI.encode (small (-87654321) 1) + , THU.testCase "AA" $ "-87654321.0" @=? SCI.encode (small (-876543210) (-1)) + ] + , testGroup + "large" + [ THU.testCase "A" $ "5000" @=? SCI.encode (large 5 3) + , THU.testCase "B" $ "-5000" @=? SCI.encode (large (-5) 3) + , THU.testCase "C" $ "0.0006" @=? SCI.encode (large 6 (-4)) + , THU.testCase "D" $ "0.087654321" @=? SCI.encode (large 87654321 (-9)) + , THU.testCase "E" $ "0.87654321" @=? SCI.encode (large 87654321 (-8)) + , THU.testCase "F" $ "8.7654321" @=? SCI.encode (large 87654321 (-7)) + , THU.testCase "G" $ "87.654321" @=? SCI.encode (large 87654321 (-6)) + , THU.testCase "H" $ "876.54321" @=? SCI.encode (large 87654321 (-5)) + , THU.testCase "I" $ "8765.4321" @=? SCI.encode (large 87654321 (-4)) + , THU.testCase "J" $ "87654.321" @=? SCI.encode (large 87654321 (-3)) + , THU.testCase "K" $ "876543.21" @=? SCI.encode (large 87654321 (-2)) + , THU.testCase "L" $ "8765432.1" @=? SCI.encode (large 87654321 (-1)) + , THU.testCase "M" $ "87654321" @=? SCI.encode (large 87654321 0) + , THU.testCase "N" $ "876543210" @=? SCI.encode (large 87654321 1) + , THU.testCase "O" $ "87654321.0" @=? SCI.encode (large 876543210 (-1)) + , THU.testCase "P" $ "-0.087654321" @=? SCI.encode (large (-87654321) (-9)) + , THU.testCase "Q" $ "-0.87654321" @=? SCI.encode (large (-87654321) (-8)) + , THU.testCase "R" $ "-8.7654321" @=? SCI.encode (large (-87654321) (-7)) + , THU.testCase "S" $ "-87.654321" @=? SCI.encode (large (-87654321) (-6)) + , THU.testCase "T" $ "-876.54321" @=? SCI.encode (large (-87654321) (-5)) + , THU.testCase "U" $ "-8765.4321" @=? SCI.encode (large (-87654321) (-4)) + , THU.testCase "V" $ "-87654.321" @=? SCI.encode (large (-87654321) (-3)) + , THU.testCase "W" $ "-876543.21" @=? SCI.encode (large (-87654321) (-2)) + , THU.testCase "X" $ "-8765432.1" @=? SCI.encode (large (-87654321) (-1)) + , THU.testCase "Y" $ "-87654321" @=? SCI.encode (large (-87654321) 0) + , THU.testCase "Z" $ "-876543210" @=? SCI.encode (large (-87654321) 1) + , THU.testCase "AA" $ "-87654321.0" @=? SCI.encode (large (-876543210) (-1)) + ] + ] ] - ] bytes :: String -> Bytes bytes s = let b = pack ('x' : s) in Bytes b 1 (PM.sizeofByteArray b - 1) @@ -266,22 +284,22 @@ -- The Arbitrary instance for Integer that comes with -- QuickCheck only generates small numbers. newtype LargeInteger = LargeInteger Integer - deriving (Eq,Show) + 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 + 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 + 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 = [] -