diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Bas van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Bas van Dijk nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,96 @@ +module Main where + +import Criterion.Main +import Data.Scientific + +main :: IO () +main = defaultMain + [ bgroup "realToFrac" + [ bgroup "Scientific->Double" + [ sToD "pos" pos + , sToD "neg" neg + , sToD "int" int + , sToD "negInt" negInt + ] + , bgroup "Double->Scientific" + [ dToS "pos" pos + , dToS "neg" neg + , dToS "int" int + , dToS "negInt" negInt + ] + ] + , bgroup "floor" + [ bench "floor" (nf (floor :: Scientific -> Integer) $! pos) + , bench "floorDefault" (nf floorDefault $! pos) + ] + , bgroup "ceiling" + [ bench "ceiling" (nf (ceiling :: Scientific -> Integer) $! pos) + , bench "ceilingDefault" (nf ceilingDefault $! pos) + ] + , bgroup "truncate" + [ bench "truncate" (nf (truncate :: Scientific -> Integer) $! pos) + , bench "truncateDefault" (nf truncateDefault $! pos) + ] + + , bgroup "round" + [ bench "round" (nf (round :: Scientific -> Integer) $! pos) + , bench "roundDefault" (nf roundDefault $! pos) + ] + ] + where + pos :: Fractional a => a + pos = 12345.12345 + + neg :: Fractional a => a + neg = -pos + + int :: Fractional a => a + int = 12345 + + negInt :: Fractional a => a + negInt = -int + +realToFracStoD :: Scientific -> Double +realToFracStoD = fromRational . toRational +{-# INLINE realToFracStoD #-} + +realToFracDtoS :: Double -> Scientific +realToFracDtoS = fromRational . toRational +{-# INLINE realToFracDtoS #-} + + +sToD :: String -> Scientific -> Benchmark +sToD name f = bgroup name + [ bench "fromScientific" . nf (realToFrac :: Scientific -> Double) $! f + , bench "via Rational" . nf (realToFracStoD :: Scientific -> Double) $! f + ] + +dToS :: String -> Double -> Benchmark +dToS name f = bgroup name + [ bench "fromRealFloat" . nf (realToFrac :: Double -> Scientific) $! f + , bench "via Rational" . nf (realToFracDtoS :: Double -> Scientific) $! f + ] + +floorDefault :: Scientific -> Integer +floorDefault x = if r < 0 then n - 1 else n + where (n,r) = properFraction x +{-# INLINE floorDefault #-} + +ceilingDefault :: Scientific -> Integer +ceilingDefault x = if r > 0 then n + 1 else n + where (n,r) = properFraction x +{-# INLINE ceilingDefault #-} + +truncateDefault :: Scientific -> Integer +truncateDefault x = m where (m,_) = properFraction x +{-# INLINE truncateDefault #-} + +roundDefault :: Scientific -> Integer +roundDefault x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + _ -> error "round default defn: Bad value" +{-# INLINE roundDefault #-} diff --git a/scientific.cabal b/scientific.cabal new file mode 100644 --- /dev/null +++ b/scientific.cabal @@ -0,0 +1,63 @@ +name: scientific +version: 0.0.0.0 +synopsis: Arbitrary-precision floating-point numbers represented using scientific notation +description: A @Scientific@ number is an arbitrary-precision floating-point number + represented using scientific notation. + . + A scientific number with 'coefficient' @c@ and + 'base10Exponent' @e@ corresponds to the + 'Fractional' number: @'fromInteger' c * 10 '^^' e@ + . + Its primary use-case is to serve as the target of + parsing floating point numbers. Since the textual + representation of floating point numbers use + scientific notation they can be efficiently + parsed to a @Scientific@ number. +homepage: https://github.com/basvandijk/scientific +bug-reports: https://github.com/basvandijk/scientific/issues +license: BSD3 +license-file: LICENSE +author: Bas van Dijk +maintainer: Bas van Dijk +category: Data +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/basvandijk/scientific.git + +library + exposed-modules: Data.Scientific + other-extensions: DeriveDataTypeable, BangPatterns + ghc-options: -Wall + build-depends: base >= 4.6 && < 4.7 + , deepseq >= 1.3 && < 1.4 + , text >= 0.8 && < 0.12 + , hashable >= 1.1.2 && < 1.3 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test-scientific + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + default-language: Haskell2010 + ghc-options: -Wall + + build-depends: scientific + , base >= 4.6 && < 4.7 + , tasty >= 0.3.1 && < 0.4 + , tasty-smallcheck >= 0.2 && < 0.3 + , smallcheck >= 1.0 && < 1.1 + , text >= 0.8 && < 0.12 + +benchmark bench-scientific + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: bench.hs + default-language: Haskell2010 + ghc-options: -O2 + build-depends: scientific + , base >= 4.6 && < 4.7 + , criterion >= 0.5 && < 0.9 diff --git a/src/Data/Scientific.hs b/src/Data/Scientific.hs new file mode 100644 --- /dev/null +++ b/src/Data/Scientific.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} + +-- TODO: The following extensions are needed for scientificBuilder: +{-# LANGUAGE MagicHash, OverloadedStrings #-} + +-- | +-- Module : Data.Scientific +-- Copyright : Bas van Dijk 2013 +-- License : BSD3 +-- Maintainer : Bas van Dijk +-- +-- This module is designed to be imported qualified: +-- +-- @import Data.Scientific as Scientific@ +module Data.Scientific + ( Scientific + + , scientific + + , coefficient + , base10Exponent + + -- * Conversions + , toFractional + , fromRealFloat + + -- * Pretty printing + , FPFormat(..) + + , scientificBuilder + , formatScientificBuilder + , formatScientific + + , toDecimalDigits + ) where + +---------------------------------------------------------------------- + +import Control.Applicative (pure, (<|>), (*>)) +import Control.DeepSeq (NFData) +import Data.Char (intToDigit, ord) +import Data.Function (on) +import Data.Functor ((<$>)) +import Data.Hashable (Hashable(..)) +import Data.Ratio ((%), numerator, denominator) +import Data.Typeable (Typeable) +import Foreign.C.Types (CDouble, CFloat) +import Numeric (floatToDigits) +import Text.Read (readPrec) +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.ParserCombinators.ReadP as ReadP +import Text.ParserCombinators.ReadP ( ReadP ) + +-- TODO: The following imports are needed for the scientificBuilder: +import Data.Text.Lazy.Builder (Builder, fromString, singleton, fromText) +import Data.Text.Lazy.Builder.Int (decimal) +import qualified Data.Text as T (replicate) +import Data.Monoid ((<>)) +import GHC.Base (Int(I#), Char(C#), chr#, ord#, (+#)) + + +---------------------------------------------------------------------- + +-- | An arbitrary-precision number represented using +-- . +-- +-- This type describes the set of all @'Real's@ which have a finite +-- decimal expansion. +-- +-- A scientific number with 'coefficient' @c@ and 'base10Exponent' @e@ +-- corresponds to the 'Fractional' number: @'fromInteger' c * 10 '^^' e@ +data Scientific = Scientific + { coefficient :: !Integer -- ^ The coefficient of a scientific number. + , base10Exponent :: {-# UNPACK #-} !Int -- ^ The base-10 exponent of a scientific number. + } deriving (Typeable) + +-- | @scientific c e@ constructs a scientific number with +-- 'coefficient' @c@ and 'base10Exponent' @e@. +scientific :: Integer -> Int -> Scientific +scientific = Scientific +{-# INLINE scientific #-} + +---------------------------------------------------------------------- + +instance NFData Scientific + +instance Hashable Scientific where + hashWithSalt salt = hashWithSalt salt . toRational + +instance Show Scientific where + showsPrec _ = showString . formatScientific Generic Nothing + +instance Read Scientific where + readPrec = ReadPrec.lift scientificP + +scientificP :: ReadP Scientific +scientificP = do + let positive = (('+' ==) <$> ReadP.satisfy isSign) <|> pure True + pos <- positive + + let step :: Num a => a -> Int -> a + step a digit = a * 10 + fromIntegral digit + + n <- foldDigits step 0 + + let s = Scientific n 0 + fractional = foldDigits (\(Scientific a e) digit -> scientific (step a digit) (e-1)) s + + Scientific coeff expnt <- (ReadP.satisfy (== '.') *> fractional) <|> pure s + + let signedCoeff | pos = coeff + | otherwise = negate coeff + + eP = do posE <- positive + e <- foldDigits step 0 + if posE + then pure e + else pure $ negate e + + (ReadP.satisfy isE *> + ((scientific signedCoeff . (expnt +)) <$> eP)) <|> + pure (scientific signedCoeff expnt) + +foldDigits :: (a -> Int -> a) -> a -> ReadP a +foldDigits f z = ReadP.look >>= go z + where + go !a [] = pure a + go !a (c:cs) + | isDecimal c = do + _ <- ReadP.get + let digit = ord c - 48 + go (f a digit) cs + | otherwise = pure a + +isDecimal :: Char -> Bool +isDecimal c = c >= '0' && c <= '9' +{-# INLINE isDecimal #-} + +isSign :: Char -> Bool +isSign c = c == '-' || c == '+' +{-# INLINE isSign #-} + +isE :: Char -> Bool +isE c = c == 'e' || c == 'E' +{-# INLINE isE #-} + +---------------------------------------------------------------------- + +instance Eq Scientific where + (==) = (==) `on` toRational + {-# INLINE (==) #-} + + (/=) = (/=) `on` toRational + {-# INLINE (/=) #-} + +instance Ord Scientific where + (<) = (<) `on` toRational + {-# INLINE (<) #-} + + (<=) = (<=) `on` toRational + {-# INLINE (<=) #-} + + (>) = (>) `on` toRational + {-# INLINE (>) #-} + + (>=) = (>=) `on` toRational + {-# INLINE (>=) #-} + + compare = compare `on` toRational + {-# INLINE compare #-} + +instance Num Scientific where + Scientific c1 e1 + Scientific c2 e2 + | e1 < e2 = scientific (c1 + c2*l) e1 + | otherwise = scientific (c1*r + c2 ) e2 + where + l = 10 ^ (e2 - e1) + r = 10 ^ (e1 - e2) + {-# INLINE (+) #-} + + Scientific c1 e1 - Scientific c2 e2 + | e1 < e2 = scientific (c1 - c2*l) e1 + | otherwise = scientific (c1*r - c2 ) e2 + where + l = 10 ^ (e2 - e1) + r = 10 ^ (e1 - e2) + {-# INLINE (-) #-} + + Scientific c1 e1 * Scientific c2 e2 = + scientific (c1 * c2) (e1 + e2) + {-# INLINE (*) #-} + + abs (Scientific c e) = scientific (abs c) e + {-# INLINE abs #-} + + negate (Scientific c e) = scientific (negate c) e + {-# INLINE negate #-} + + signum (Scientific c _) = scientific (signum c) 0 + {-# INLINE signum #-} + + fromInteger i = scientific i 0 + {-# INLINE fromInteger #-} + +instance Real Scientific where + toRational (Scientific c e) + | e < 0 = c % (10 ^ negate e) + | otherwise = (c * 10 ^ e) % 1 + {-# INLINE toRational #-} + +-- | /WARNING:/ 'recip' and '/' will diverge when their outputs have +-- an infinite decimal expansion. 'fromRational' will diverge when the +-- input 'Rational' has an infinite decimal expansion. +instance Fractional Scientific where + recip = fromRational . recip . toRational + {-# INLINE recip #-} + + fromRational rational + | numer < 0 = negate $ go (negate numer) 0 0 + | otherwise = go numer 0 0 + where + numer = numerator rational + denom = denominator rational + + go :: Integer -> Integer -> Int -> Scientific + go 0 !c !e = scientific c e + go !n !c !e + | n < denom = go (n*10) (c * 10) (e-1) -- TODO: Use a logarithm here! + | otherwise = go r (c + q) e + where + (q, r) = n `quotRem` denom + {-# INLINE fromRational #-} + +instance RealFrac Scientific where + properFraction (Scientific c e) + | e < 0 = let (q, r) = c `quotRem` (10 ^ negate e) + in (fromInteger q, scientific r e) + | otherwise = (fromInteger c * 10 ^ e, 0) + {-# INLINE properFraction #-} + + truncate = whenFloating $ \c e -> + fromInteger $ c `quot` (10 ^ negate e) + {-# INLINE truncate #-} + + round = whenFloating $ \c e -> + let m = c `quot` (10 ^ (negate e - 1)) + (n, r) = m `quotRem` 10 + in fromInteger $ + if c < 0 + then if r < (-5) || (r == (-5) && odd n) then n-1 else n + else if r < 5 || (r == 5 && even n) then n else n+1 + {-# INLINE round #-} + + ceiling = whenFloating $ \c e -> + let (q, r) = c `quotRem` (10 ^ negate e) + in fromInteger $! if r > 0 then q + 1 else q + {-# INLINE ceiling #-} + + floor = whenFloating $ \c e -> + fromInteger (c `div` (10 ^ negate e)) + {-# INLINE floor #-} + +---------------------------------------------------------------------- + +whenFloating :: (Num a) => (Integer -> Int -> a) -> Scientific -> a +whenFloating f (Scientific c e) + | e < 0 = f c e + | otherwise = fromInteger c * 10 ^ e +{-# INLINE whenFloating #-} + +---------------------------------------------------------------------- + +{-# RULES +"realToFrac/Scientific->Scientific" realToFrac = id :: Scientific -> Scientific #-} + +-- | Efficient conversion from a 'Scientific' to a 'Fractional' number. +-- +-- Note that this module provides rewrite RULES that convert +-- 'realToFrac' into 'toFractional' when going from a 'Scientific' to +-- either a 'Double', 'Float', 'CDouble' or 'CFloat' to avoid going +-- via 'Rational'. +-- +-- So it's recommended to use 'realToFrac' to convert to a +-- 'Fractional' number. However, if you don't want to rely on these +-- RULES this function can be used. +toFractional :: (Fractional a) => Scientific -> a +toFractional = whenFloating $ \c e -> fromInteger c / 10 ^ negate e +{-# INLINE toFractional #-} + +{-# RULES +"realToFrac/Scientific->Double" realToFrac = toFractional :: Scientific -> Double +"realToFrac/Scientific->Float" realToFrac = toFractional :: Scientific -> Float +"realToFrac/Scientific->CDouble" realToFrac = toFractional :: Scientific -> CDouble +"realToFrac/Scientific->CFloat" realToFrac = toFractional :: Scientific -> CFloat #-} + +-- | Efficient conversion from a 'RealFloat' into a 'Scientific' +-- number. +-- +-- Note that this module provides rewrite RULES that convert +-- 'realToFrac' into 'fromRealFloat' when going from either a +-- 'Double', 'Float', 'CDouble' or 'CFloat' to a 'Scientific' to avoid +-- going via 'Rational'. +-- +-- So it's recommended to use 'realToFrac' to convert 'Real' numbers +-- into 'Scientific'. However, if you don't want to rely on these +-- RULES this function can be used. +fromRealFloat :: (RealFloat a) => a -> Scientific +fromRealFloat rf + -- integers are way more efficient to convert via Rational. + -- We do pay the cost of always converting to Rational first though. + | denominator rat == 1 = fromRational rat + | rf < 0 = negate $ fromNonNegRealFloat $ negate rf + | otherwise = fromNonNegRealFloat rf + where + rat = toRational rf + + fromNonNegRealFloat r = go digits 0 0 + where + (digits, e) = floatToDigits 10 r + + go [] !c !n = scientific c (e - n) + go (d:ds) !c !n = go ds (c * 10 + fromIntegral d) (n + 1) +{-# INLINE fromRealFloat #-} + +{-# RULES +"realToFrac/Double->Scientific" realToFrac = fromRealFloat :: Double -> Scientific +"realToFrac/Float->Scientific" realToFrac = fromRealFloat :: Float -> Scientific +"realToFrac/CDouble->Scientific" realToFrac = fromRealFloat :: CDouble -> Scientific +"realToFrac/CFloat->Scientific" realToFrac = fromRealFloat :: CFloat -> Scientific #-} + +---------------------------------------------------------------------- + +-- | Similar to 'floatToDigits', @toDecimalDigits@ takes a +-- non-negative 'Scientific' number, and returns a list of digits and +-- a base-10 exponent. In particular, if @x>=0@, and +-- +-- > toDecimalDigits x = ([d1,d2,...,dn], e) +-- +-- then +-- +-- (1) @n >= 1@ +-- +-- (2) @x = 0.d1d2...dn * (10^^e)@ +-- +-- (3) @0 <= di <= 9@ +toDecimalDigits :: Scientific -> ([Int], Int) +toDecimalDigits (Scientific 0 _) = ([0], 0) +toDecimalDigits (Scientific c e) = (is, n + e) + where + (is, n) = reverseAndLength $ digits c + + digits :: Integer -> [Int] + digits 0 = [] + digits i = fromIntegral r : digits q + where + (q, r) = i `quotRem` 10 + + reverseAndLength :: [a] -> ([a], Int) + reverseAndLength l = rev l [] 0 + where + rev [] a !m = (a, m) + rev (x:xs) a !m = rev xs (x:a) (m+1) + +---------------------------------------------------------------------- + +-- | Control the rendering of floating point numbers. +data FPFormat = Exponent + -- ^ Scientific notation (e.g. @2.3e123@). + | Fixed + -- ^ Standard decimal notation. + | Generic + -- ^ Use decimal notation for values between @0.1@ and + -- @9,999,999@, and scientific notation otherwise. + deriving (Enum, Read, Show) + +-- | A @Text@ @Builder@ which renders a scientific number to full +-- precision, using standard decimal notation for arguments whose +-- absolute value lies between @0.1@ and @9,999,999@, and scientific +-- notation otherwise. +scientificBuilder :: Scientific -> Builder +scientificBuilder = formatScientificBuilder Generic Nothing + +-- | Like 'scientificBuilder' but provides rendering options. +formatScientificBuilder :: FPFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Scientific + -> Builder +formatScientificBuilder fmt decs scntfc@(Scientific c _) + | c < 0 = singleton '-' <> doFmt fmt (toDecimalDigits (-scntfc)) + | otherwise = doFmt fmt (toDecimalDigits scntfc) + where + doFmt format (is, e) = + let ds = map i2d is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is,e) + Exponent -> + case decs of + Nothing -> + let show_e' = decimal (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> singleton d <> ".0e" <> show_e' + (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e' + [] -> error "formatRealFloat/doFmt/Exponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0" + _ -> + let + (ei,is') = roundTo (dec'+1) is + (d:ds') = map i2d (if ei > 0 then init is' else is') + in + singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei) + Fixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls} + in + case decs of + Nothing + | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map i2d is') + in + mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs) + else + let + (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + d:ds' = map i2d (if ei > 0 then is' else 0:is') + in + singleton d <> (if null ds' then "" else singleton '.' <> fromString ds') + +-- | Unsafe conversion for decimal digits. +{-# INLINE i2d #-} +i2d :: Int -> Char +i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) + +---------------------------------------------------------------------- + +-- | Like 'show' but provides rendering options. +formatScientific :: FPFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Scientific + -> String +formatScientific fmt decs scntfc@(Scientific c _) + | c < 0 = '-':doFmt fmt (toDecimalDigits (-scntfc)) + | otherwise = doFmt fmt (toDecimalDigits scntfc ) + where + doFmt :: FPFormat -> ([Int], Int) -> String + doFmt format (is, e) = + let ds = map intToDigit is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is, e) + Exponent -> + case decs of + Nothing -> + let show_e' = show (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> d : ".0e" ++ show_e' + (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' + [] -> error "formatScientific/doFmt/FFExponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0" + _ -> + let + (ei,is') = roundTo (dec'+1) is + (d:ds') = map intToDigit (if ei > 0 then init is' else is') + in + d:'.':ds' ++ 'e':show (e-1+ei) + Fixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> ls} + in + case decs of + Nothing + | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map intToDigit is') + in + mk0 ls ++ (if null rs then "" else '.':rs) + else + let + (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + d:ds' = map intToDigit (if ei > 0 then is' else 0:is') + in + d : (if null ds' then "" else '.':ds') + +---------------------------------------------------------------------- + +roundTo :: Int -> [Int] -> (Int,[Int]) +roundTo d is = + case f d True is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + base = 10 + + b2 = base `quot` 2 + + f n _ [] = (0, replicate n 0) + f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, []) -- Round to even when at exactly half the base + | otherwise = (if x >= b2 then 1 else 0, []) + f n _ (i:xs) + | i' == base = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) (even i) xs + i' = c + i diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +import Control.Monad +import Test.Tasty +import Test.Tasty.SmallCheck (testProperty) +import Test.SmallCheck +import Data.Scientific as Scientific +import Test.SmallCheck.Series -- (Serial, series, cons2) +import qualified Data.Text.Lazy as TL (unpack) +import qualified Data.Text.Lazy.Builder as TLB (toLazyText) + +main :: IO () +main = defaultMain $ testGroup "scientific" + [ testGroup "Formatting" + [ testProperty "read . show == id" $ \s -> read (show s) === s + + , testProperty "toDecimalDigits_laws" + toDecimalDigits_laws + , testProperty "Builder" $ \s -> + formatScientific Generic Nothing s == + TL.unpack (TLB.toLazyText $ formatScientificBuilder Generic Nothing s) + ] + + , testGroup "Num" + [ testGroup "Equal to Rational" + [ testProperty "fromInteger" $ \i -> fromInteger i === fromRational (fromInteger i) + , testProperty "+" $ bin (+) + , testProperty "-" $ bin (-) + , testProperty "*" $ bin (*) + , testProperty "abs" $ unary abs + , testProperty "negate" $ unary negate + , testProperty "signum" $ unary signum + ] + + , testProperty "0 identity of +" $ \a -> a + 0 === a + , testProperty "1 identity of *" $ \a -> 1 * a === a + , testProperty "0 identity of *" $ \a -> 0 * a === 0 + + , testProperty "associativity of +" $ \a b c -> a + (b + c) === (a + b) + c + , testProperty "commutativity of +" $ \a b -> a + b === b + a + , testProperty "distributivity of * over +" $ \a b c -> a * (b + c) === a * b + a * c + + , testProperty "subtracting the addition" $ \x y -> x + y - y === x + + , testProperty "+ and negate" $ \x -> x + negate x === 0 + , testProperty "- and negate" $ \x -> x - negate x === x + x + + , testProperty "abs . negate == id" $ over nonNegativeScientifics $ \x -> + abs (negate x) === x + ] + + , testGroup "Real" + [ testProperty "fromRational . toRational == id" $ \x -> + (fromRational . toRational) x === x + ] + + , testGroup "RealFrac" + [ testGroup "Equal to Rational" + [ testProperty "properFraction" $ \x -> + let (n1::Integer, f1::Scientific) = properFraction x + (n2::Integer, f2::Rational) = properFraction (toRational x) + in (n1 == n2) && (f1 == fromRational f2) + + , testProperty "round" $ \(x::Scientific) -> + (round x :: Integer) == round (toRational x) + + , testProperty "truncate" $ \(x::Scientific) -> + (truncate x :: Integer) == truncate (toRational x) + + , testProperty "ceiling" $ \(x::Scientific) -> + (ceiling x :: Integer) == ceiling (toRational x) + + , testProperty "floor" $ \(x::Scientific) -> + (floor x :: Integer) == floor (toRational x) + ] + + , testProperty "properFraction_laws" properFraction_laws + + , testProperty "round" $ \s -> round s == roundDefault s + , testProperty "truncate" $ \s -> truncate s == truncateDefault s + , testProperty "ceiling" $ \s -> ceiling s == ceilingDefault s + , testProperty "floor" $ \s -> floor s == floorDefault s + ] + + , testGroup "Conversions" + [ testProperty "toFractional" $ \s -> + Scientific.toFractional s == toRational s + + , testProperty "fromRealFloat" $ \(d::Double) -> + toRational (Scientific.fromRealFloat d) == toRational d + ] + ] + +-- | ('==') specialized to 'Scientific' so we don't have to put type +-- signatures everywhere. +(===) :: Scientific -> Scientific -> Bool +(===) = (==) +infix 4 === + +bin :: (forall a. Num a => a -> a -> a) -> Scientific -> Scientific -> Bool +bin op a b = toRational (a `op` b) == toRational a `op` toRational b + +unary :: (forall a. Num a => a -> a) -> Scientific -> Bool +unary op a = toRational (op a) == op (toRational a) + +toDecimalDigits_laws :: (Monad m) => Property m +toDecimalDigits_laws = over nonNegativeScientifics $ \x -> + let (ds, e) = Scientific.toDecimalDigits x + + rule1 = length ds >= 1 + + rule2 = toRational x == coeff * 10 ^^ e + coeff = foldr (\di a -> a / 10 + fromIntegral di) 0 (0:ds) + + rule3 = all (\di -> 0 <= di && di <= 9) ds + + in rule1 && rule2 && rule3 + +properFraction_laws :: Scientific -> Bool +properFraction_laws x = fromInteger n + f === x && + (positive n == posX || n == 0) && + (positive f == posX || f == 0) && + abs f < 1 + where + posX = positive x + + (n, f) = properFraction x :: (Integer, Scientific) + +positive :: (Ord a, Num a) => a -> Bool +positive y = y >= 0 + +floorDefault :: Scientific -> Integer +floorDefault x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +ceilingDefault :: Scientific -> Integer +ceilingDefault x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + +truncateDefault :: Scientific -> Integer +truncateDefault x = m where (m,_) = properFraction x + +roundDefault :: Scientific -> Integer +roundDefault x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + _ -> error "round default defn: Bad value" + +---------------------------------------------------------------------- + +instance (Monad m) => Serial m Scientific where + series = scientifics + +scientifics :: (Monad m) => Series m Scientific +scientifics = cons2 scientific + +nonNegativeScientifics :: (Monad m) => Series m Scientific +nonNegativeScientifics = liftM getNonNegative series