scientific (empty) → 0.0.0.0
raw patch · 6 files changed
+895/−0 lines, 6 filesdep +basedep +criteriondep +deepseqsetup-changed
Dependencies added: base, criterion, deepseq, hashable, scientific, smallcheck, tasty, tasty-smallcheck, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/bench.hs +96/−0
- scientific.cabal +63/−0
- src/Data/Scientific.hs +538/−0
- test/test.hs +166/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -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 #-}
+ scientific.cabal view
@@ -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 <v.dijk.bas@gmail.com>+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
+ src/Data/Scientific.hs view
@@ -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 <v.dijk.bas@gmail.com>+--+-- 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+-- <http://en.wikipedia.org/wiki/Scientific_notation scientific notation>.+--+-- 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
+ test/test.hs view
@@ -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