diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Robert Leslie + +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 Robert Leslie 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ + +General Decimal Arithmetic +========================== + +This is a decimal arithmetic package for Haskell, suitable for +arbitrary-precision decimal floating point and integer calculations. + +For details and the specification on which the implementation is based, see +Mike Cowlishaw's [General Decimal Arithmetic][]. + + [General Decimal Arithmetic]: http://speleotrove.com/decimal/ + +While usable, the implementation is currently in its infancy. Additional +operations as well as an API for manipulating context flags are planned. 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/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,7 @@ +-*- Outline -*- + +* To Do +** Test suite +** instance Floating (Number p r) +** instance RealFloat (Number p r) +** instance PrintfArg (Number p r) diff --git a/decimal-arithmetic.cabal b/decimal-arithmetic.cabal new file mode 100644 --- /dev/null +++ b/decimal-arithmetic.cabal @@ -0,0 +1,60 @@ + +name: decimal-arithmetic +version: 0.1.0.0 + +synopsis: An implementation of Mike Cowlishaw's + General Decimal Arithmetic Specification + +description: This package provides an implementation of the General + Decimal Arithmetic Specification by Mike Cowlishaw. + . + For details, see: http://speleotrove.com/decimal/ + +homepage: https://github.com/verement/decimal-arithmetic#readme +bug-reports: https://github.com/verement/decimal-arithmetic/issues + +license: BSD3 +license-file: LICENSE + +copyright: © 2016 Robert Leslie +author: Rob Leslie +maintainer: Rob Leslie + +stability: alpha +category: Numeric + +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.md + TODO + stack.yaml + +source-repository head + type: git + location: https://github.com/verement/decimal-arithmetic.git + +library + hs-source-dirs: src + + exposed-modules: Numeric.Decimal + Numeric.Decimal.Conversion + Numeric.Decimal.Operation + other-modules: Numeric.Decimal.Number + Numeric.Decimal.Precision + Numeric.Decimal.Rounding + + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + default-extensions: Trustworthy + other-extensions: RoleAnnotations + +test-suite decimal-arithmetic-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , decimal-arithmetic + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 diff --git a/src/Numeric/Decimal.hs b/src/Numeric/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal.hs @@ -0,0 +1,102 @@ +{-| +Module : Numeric.Decimal +Description : General arbitrary-precision decimal floating-point number type +Copyright : © 2016 Robert Leslie +License : BSD3 +Maintainer : rob@mars.org +Stability : experimental + +This module provides a general-purpose 'Number' type supporting decimal +arithmetic for both limited precision floating-point (IEEE 754-2008) and for +arbitrary precision floating-point (following the same principles as IEEE 754 +and IEEE 854-1987) as described in the + +by Mike Cowlishaw. In addition to floating-point arithmetic, integer and +unrounded floating-point arithmetic are included as subsets. + +Unlike the binary floating-point types 'Float' and 'Double', the 'Number' type +can represent and perform arithmetic with decimal numbers exactly. +Internally, a 'Number' is represented with an integral coefficient and base-10 +exponent. + +The 'Number' type supports lossless conversion to and from a string +representation via the 'Show' and 'Read' instances. Note that there may be +multiple representations of values that are numerically equal (e.g. 1 and +1.00) which are preserved by this conversion. +-} +module Numeric.Decimal + ( -- * Usage + -- $usage + + -- * Arbitrary-precision decimal numbers + Number + , BasicDecimal + , ExtendedDecimal + , GeneralDecimal + + -- ** Precision types + , module Numeric.Decimal.Precision + + -- ** Rounding types + , Rounding + + , RoundHalfUp + , RoundHalfEven + , RoundHalfDown + , RoundCeiling + , RoundFloor + , RoundUp + , Round05Up + , RoundDown + + -- * Functions + , cast + ) where + +import Numeric.Decimal.Number +import Numeric.Decimal.Precision +import Numeric.Decimal.Rounding + +-- | A basic decimal floating point number with 9 digits of precision, rounding half up +type BasicDecimal = Number P9 RoundHalfUp + +-- | A decimal floating point number with selectable precision, rounding half even +type ExtendedDecimal p = Number p RoundHalfEven + +-- | A decimal floating point number with infinite precision +type GeneralDecimal = ExtendedDecimal PInfinite + +basicDefaultContext :: TrapHandler P9 RoundHalfUp -> Context P9 RoundHalfUp +basicDefaultContext handler = defaultContext { trapHandler = trap } + where trap Inexact = id + trap Rounded = id + trap Subnormal = id + trap sig = handler sig + +extendedDefaultContext :: Context p RoundHalfEven +extendedDefaultContext = defaultContext + +-- $usage +-- +-- It is recommended that you create an alias for the type of numbers you wish +-- to support in your application. For example: +-- +-- > type Decimal = BasicDecimal +-- +-- This is a basic number type with 9 decimal digits of precision that rounds +-- half up. +-- +-- > type Decimal = ExtendedDecimal P19 +-- +-- This is a number type with 19 decimal digits of precision that rounds half +-- even. +-- +-- > type Decimal = GeneralDecimal +-- +-- This is a number type with infinite precision. (Note that not all +-- operations support numbers with infinite precision.) +-- +-- It is also possible to use a decimal number type in a @default@ +-- declaration, possibly replacing 'Double' or 'Integer'. For example: +-- +-- > default (Integer, Decimal) diff --git a/src/Numeric/Decimal/Conversion.hs b/src/Numeric/Decimal/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Conversion.hs @@ -0,0 +1,257 @@ + +-- | The functions in this module implement conversions between 'Number' and +-- 'String' as described in the /General Decimal Arithmetic Specification/. +-- +-- Because these functions are also used to implement 'Show' and 'Read' class +-- methods, it is not usually necessary to import this module except to use +-- the 'toEngineeringString' function. + +module Numeric.Decimal.Conversion + ( -- * Numeric string syntax + -- $numeric-string-syntax + + -- * Conversion to numeric string + toScientificString + , toEngineeringString + + -- * Conversion from numeric string + , toNumber + ) where + +import Prelude hiding (exponent, round) + +import Control.Applicative ((<|>)) +import Data.Char (isDigit, digitToInt, toLower, toUpper) +import Data.List (foldl') +import Text.ParserCombinators.ReadP (ReadP, char, many, many1, option, optional, + satisfy) + +import Numeric.Decimal.Number +import Numeric.Decimal.Precision +import Numeric.Decimal.Rounding + +-- | Convert a number to a string, using scientific notation if an exponent is +-- needed. +toScientificString :: Number p r -> ShowS +toScientificString = showNumber exponential + + where exponential :: Exponent -> String -> Exponent -> ShowS + exponential e (d1:ds@(_:_)) _ = showChar d1 . showChar '.' . + showString ds . showExponent e + exponential e ds _ = showString ds . showExponent e + +-- | Convert a number to a string, using engineering notation if an exponent +-- is needed. +toEngineeringString :: Number p r -> ShowS +toEngineeringString = showNumber exponential + + where exponential :: Exponent -> String -> Exponent -> ShowS + exponential e ds@"0" _ = showString ds' . showExponent (e + adj) + where adj = (3 - e `mod` 3) `mod` 3 + ds' | adj > 0 = '0' : '.' : replicate (fromIntegral adj) '0' + | otherwise = ds + exponential e ds cl = shift adj (e - adj) ds' + where adj = e `mod` 3 + ds' | cl - 1 < adj = ds ++ + replicate (fromIntegral (adj - cl + 1)) '0' + | otherwise = ds + + shift :: Exponent -> Exponent -> String -> ShowS + shift 2 e (d1:d2:d3:ds@(_:_)) = showChar d1 . showChar d2 . + showChar d3 . showChar '.' . + showString ds . showExponent e + + shift 1 e (d1:d2:ds@(_:_)) = showChar d1 . showChar d2 . + showChar '.' . + showString ds . showExponent e + + shift 0 e (d1:ds@(_:_)) = showChar d1 . showChar '.' . + showString ds . showExponent e + + shift _ e ds = showString ds . showExponent e + +showNumber :: (Exponent -> String -> Exponent -> ShowS) + -> Number p r -> ShowS +showNumber exponential num = signStr . case num of + Num { coefficient = c, exponent = e } + | e <= 0 && ae >= -6 -> nonExponential + | otherwise -> exponential ae cs cl + + where cs = show c :: String + cl = fromIntegral (length cs) :: Exponent + ae = e + cl - 1 :: Exponent + + nonExponential :: ShowS + nonExponential + | e == 0 = showString cs + | -e < cl = let (ca, cb) = splitAt (fromIntegral $ cl + e) cs + in showString ca . showChar '.' . showString cb + | otherwise = showChar '0' . showChar '.' . + showString (replicate (fromIntegral $ -e - cl) '0') . + showString cs + + Inf { } -> showString "Infinity" + QNaN { payload = p } -> showString "NaN" . diag p + SNaN { payload = p } -> showString "sNaN" . diag p + + where signStr :: ShowS + signStr = showString $ case sign num of + Pos -> "" + Neg -> "-" + + diag :: Payload -> ShowS + diag 0 = showString "" + diag d = shows d + +showExponent :: Exponent -> ShowS +showExponent e + | e == 0 = id -- do not show zero exponent + | e < 0 = indicator . exps + | otherwise = indicator . showChar '+' . exps + where indicator = showChar 'E' :: ShowS + exps = shows e :: ShowS + +-- | Convert a string to a number, as defined by its abstract representation. +-- The string is expected to conform to the numeric string syntax described +-- here. +toNumber :: (Precision p, Rounding r) => ReadP (Number p r) +toNumber = round <$> (parseSign flipSign <*> parseNumericString) + + where parseSign :: (a -> a) -> ReadP (a -> a) + parseSign negate = char '-' *> pure negate + <|> optional (char '+') *> pure id + + parseNumericString :: ReadP (Number p r) + parseNumericString = parseNumericValue <|> parseNaN + + parseNumericValue :: ReadP (Number p r) + parseNumericValue = parseDecimalPart <*> option 0 parseExponentPart + <|> parseInfinity + + parseDecimalPart :: ReadP (Exponent -> Number p r) + parseDecimalPart = digitsWithPoint <|> digitsWithOptionalPoint + + where digitsWithPoint = do + digits <- many1 parseDigit + char '.' + fracDigits <- many parseDigit + return $ \e -> + Num { context = defaultContext + , sign = Pos + , coefficient = readDigits (digits ++ fracDigits) + , exponent = e - fromIntegral (length fracDigits) + } + + digitsWithOptionalPoint = fractionalDigits <|> wholeDigits + + fractionalDigits = do + char '.' + fracDigits <- many1 parseDigit + return $ \e -> + Num { context = defaultContext + , sign = Pos + , coefficient = readDigits fracDigits + , exponent = e - fromIntegral (length fracDigits) + } + + wholeDigits = do + digits <- many1 parseDigit + return $ \e -> Num { context = defaultContext + , sign = Pos + , coefficient = readDigits digits + , exponent = e + } + + parseExponentPart :: ReadP Exponent + parseExponentPart = do + parseString "E" + parseSign negate <*> (readDigits <$> many1 parseDigit) + + parseInfinity :: ReadP (Number p r) + parseInfinity = do + parseString "Inf" + optional $ parseString "inity" + return Inf { context = defaultContext, sign = Pos } + + parseNaN :: ReadP (Number p r) + parseNaN = parseQNaN <|> parseSNaN + + parseQNaN :: ReadP (Number p r) + parseQNaN = do + p <- parseNaNPayload + return QNaN { context = defaultContext, sign = Pos, payload = p } + + parseSNaN :: ReadP (Number p r) + parseSNaN = do + parseString "s" + p <- parseNaNPayload + return SNaN { context = defaultContext, sign = Pos, payload = p } + + parseNaNPayload :: ReadP Payload + parseNaNPayload = do + parseString "NaN" + readDigits <$> many parseDigit + + parseDigit :: ReadP Int + parseDigit = digitToInt <$> satisfy isDigit + + parseString :: String -> ReadP () + parseString = mapM_ $ \c -> char (toLower c) <|> char (toUpper c) + + readDigits :: Num c => [Int] -> c + readDigits = foldl' (\a b -> a * 10 + fromIntegral b) 0 + +-- $numeric-string-syntax +-- +-- (The following description is from the +-- /General Decimal Arithmetic Specification/.) +-- +-- Strings which are acceptable for conversion to the abstract representation +-- of numbers, or which might result from conversion from the abstract +-- representation to a string, are called /numeric strings/. +-- +-- A /numeric string/ is a character string that describes either a /finite number/ or a /special value/. +-- +-- * If it describes a /finite number/, it includes one or more decimal +-- digits, with an optional decimal point. The decimal point may be embedded +-- in the digits, or may be prefixed or suffixed to them. The group of +-- digits (and optional point) thus constructed may have an optional sign +-- (“@+@” or “@-@”) which must come before any digits or decimal point. +-- +-- The string thus described may optionally be followed by an “@E@” +-- (indicating an exponential part), an optional sign, and an integer +-- following the sign that represents a power of ten that is to be +-- applied. The “@E@” may be in uppercase or lowercase. +-- +-- * If it describes a /special value/, it is one of the case-independent +-- names “@Infinity@”, “@Inf@”, “@NaN@”, or “@sNaN@” (where the first two +-- represent /infinity/ and the second two represent /quiet NaN/ and +-- /signaling NaN/ respectively). The name may be preceded by an optional +-- sign, as for finite numbers. If a NaN, the name may also be followed by +-- one or more digits, which encode any diagnostic information. +-- +-- No blanks or other white space characters are permitted in a numeric string. +-- +-- == Examples +-- +-- Some numeric strings are: +-- +-- > "0" -- zero +-- > "12" -- a whole number +-- > "-76" -- a signed whole number +-- > "12.70" -- some decimal places +-- > "+0.003" -- a plus sign is allowed, too +-- > "017." -- the same as 17 +-- > ".5" -- the same as 0.5 +-- > "4E+9" -- exponential notation +-- > "0.73e-7" -- exponential notation, negative power +-- > "Inf" -- the same as Infinity +-- > "-infinity" -- the same as -Inf +-- > "NaN" -- not-a-Number +-- > "NaN8275" -- diagnostic NaN +-- +-- == Notes +-- +-- 1. A single period alone or with a sign is not a valid numeric string. +-- 2. A sign alone is not a valid numeric string. +-- 3. Significant (after the decimal point) and insignificant leading zeros are permitted. diff --git a/src/Numeric/Decimal/Conversion.hs-boot b/src/Numeric/Decimal/Conversion.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Conversion.hs-boot @@ -0,0 +1,15 @@ +-- -*- Haskell -*- + +module Numeric.Decimal.Conversion + ( toScientificString + , toNumber + ) where + +import Text.ParserCombinators.ReadP (ReadP) + +import {-# SOURCE #-} Numeric.Decimal.Number +import Numeric.Decimal.Precision (Precision) +import {-# SOURCE #-} Numeric.Decimal.Rounding (Rounding) + +toScientificString :: Number p r -> ShowS +toNumber :: (Precision p, Rounding r) => ReadP (Number p r) diff --git a/src/Numeric/Decimal/Number.hs b/src/Numeric/Decimal/Number.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Number.hs @@ -0,0 +1,401 @@ + +module Numeric.Decimal.Number + ( Sign(..) + , negateSign + , xorSigns + + , Coefficient + , numDigits + + , Exponent + , Payload + + , Number(..) + , zero + , one + , negativeOne + , infinity + , qNaN + , sNaN + + , flipSign + , cast + , excessDigits + + , isPositive + , isNegative + , isFinite + , isZero + , isNormal + , isSubnormal + + , Context(..) + , TrapHandler + , defaultContext + , mergeContexts + + , Signal(..) + , raiseSignal + ) where + +import Prelude hiding (exponent, round) + +import Data.Bits (bit, complement, testBit, (.&.), (.|.)) +import Data.Coerce (coerce) +import Data.Monoid ((<>)) +import Data.Ratio (numerator, denominator, (%)) +import Numeric.Natural (Natural) +import Text.ParserCombinators.ReadP (readP_to_S) + +import {-# SOURCE #-} Numeric.Decimal.Conversion +import Numeric.Decimal.Precision +import {-# SOURCE #-} Numeric.Decimal.Rounding + +import {-# SOURCE #-} qualified Numeric.Decimal.Operation as Op + +import qualified GHC.Real + +data Sign = Pos | Neg + deriving (Eq, Enum, Show) + +negateSign :: Sign -> Sign +negateSign Pos = Neg +negateSign Neg = Pos + +xorSigns :: Sign -> Sign -> Sign +xorSigns Pos Pos = Pos +xorSigns Pos Neg = Neg +xorSigns Neg Pos = Neg +xorSigns Neg Neg = Pos + +signFactor :: Num a => Sign -> a +signFactor Pos = 1 +signFactor Neg = -1 + +signFunc :: Num a => Sign -> a -> a +signFunc Pos = id +signFunc Neg = negate + +type Coefficient = Natural +type Exponent = Integer + +type Payload = Coefficient + +-- | A decimal floating point number with selectable precision and rounding +-- algorithm +data Number p r + = Num { context :: Context p r + , sign :: Sign + , coefficient :: Coefficient + , exponent :: Exponent + } + | Inf { context :: Context p r + , sign :: Sign + } + | QNaN { context :: Context p r + , sign :: Sign + , payload :: Payload + } + | SNaN { context :: Context p r + , sign :: Sign + , payload :: Payload + } + +instance Precision p => Precision (Number p r) where + precision = precision . numberPrecision + where numberPrecision :: Number p r -> p + numberPrecision = undefined + +instance Show (Number p r) where + showsPrec d n = showParen (d > 0 && isNegative n) $ toScientificString n + +instance (Precision p, Rounding r) => Read (Number p r) where + readsPrec _ = readP_to_S toNumber + +instance (Precision p, Rounding r) => Eq (Number p r) where + x == y = case x `Op.compare` y of + Num { coefficient = 0 } -> True + _ -> False + +instance (Precision p, Rounding r) => Ord (Number p r) where + x `compare` y = case x `Op.compare` y of + Num { coefficient = 0 } -> EQ + Num { sign = Neg } -> LT + Num { sign = Pos } -> GT + _ -> GT -- match Prelude behavior for NaN + + x < y = case x `Op.compare` y of + Num { sign = Neg } -> True + _ -> False + + x <= y = case x `Op.compare` y of + Num { sign = Neg } -> True + Num { coefficient = 0 } -> True + _ -> False + + x > y = case x `Op.compare` y of + Num { coefficient = 0 } -> False + Num { sign = Pos } -> True + _ -> False + + x >= y = case x `Op.compare` y of + Num { sign = Pos } -> True + _ -> False + + max nan@SNaN{} _ = nan + max _ nan@SNaN{} = nan + max nan@QNaN{} _ = nan + max _ nan@QNaN{} = nan + max x y + | x >= y = x + | otherwise = y + + min nan@SNaN{} _ = nan + min _ nan@SNaN{} = nan + min nan@QNaN{} _ = nan + min _ nan@QNaN{} = nan + min x y + | x < y = x + | otherwise = y + +instance (FinitePrecision p, Rounding r) => Enum (Number p r) where + toEnum = fromIntegral + fromEnum = truncate + +instance (Precision p, Rounding r) => Num (Number p r) where + (+) = Op.add + (-) = Op.subtract + (*) = Op.multiply + negate = Op.minus + abs = Op.abs + + signum n = case n of + Num { coefficient = 0 } -> zero + Num { sign = s } -> one { sign = s } + Inf { sign = s } -> one { sign = s } + _ -> n + + fromInteger x = Num { context = defaultContext + , sign = sx + , coefficient = fromInteger (abs x) + , exponent = 0 + } + where sx = case signum x of + -1 -> Neg + _ -> Pos + +instance (Precision p, Rounding r) => Real (Number p r) where + toRational Num { sign = s, coefficient = c, exponent = e } + | e >= 0 = fromInteger (signFactor s * fromIntegral c * 10^e) + | otherwise = (signFactor s * fromIntegral c) % 10^(-e) + toRational n = signFunc (sign n) $ case n of + Inf{} -> GHC.Real.infinity + _ -> GHC.Real.notANumber + +instance (FinitePrecision p, Rounding r) => Fractional (Number p r) where + (/) = Op.divide + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + +instance (FinitePrecision p, Rounding r) => RealFrac (Number p r) where + properFraction x@Num { sign = s, coefficient = c, exponent = e } + | e < 0 = (n, f) + | otherwise = (signFactor s * fromIntegral c * 10^e, zero) + where n = signFactor s * fromIntegral q + f = x { coefficient = r, exponent = -(fromIntegral $ numDigits r) } + (q, r) = c `quotRem` (10^(-e)) + properFraction nan = (0, nan) + +-- | A 'Number' representing the value zero +zero :: Number p r +zero = Num { context = defaultContext + , sign = Pos + , coefficient = 0 + , exponent = 0 + } + +-- | A 'Number' representing the value one +one :: Number p r +one = zero { coefficient = 1 } + +-- | A 'Number' representing the value negative one +negativeOne :: Number p r +negativeOne = one { sign = Neg } + +-- | A 'Number' representing the value positive infinity +infinity :: Number p r +infinity = Inf { context = defaultContext, sign = Pos } + +-- | A 'Number' representing undefined results +qNaN :: Number p r +qNaN = QNaN { context = defaultContext, sign = Pos, payload = 0 } + +-- | A signaling 'Number' representing undefined results +sNaN :: Number p r +sNaN = SNaN { context = defaultContext, sign = Pos, payload = 0 } + +-- | Negate the given 'Number' by directly flipping its sign. +flipSign :: Number p r -> Number p r +flipSign n = n { sign = negateSign (sign n) } + +-- | Cast a 'Number' to another precision and/or rounding algorithm, +-- immediately rounding if necessary to the new precision using the new +-- algorithm. +cast :: (Precision p, Rounding r) => Number a b -> Number p r +cast = round . coerce + +numDigits :: Coefficient -> Int +numDigits x + | x < 10 = 1 + | x < 100 = 2 + | x < 1000 = 3 + | x < 10000 = 4 + | x < 100000 = 5 + | x < 1000000 = 6 + | x < 10000000 = 7 + | x < 100000000 = 8 + | x < 1000000000 = 9 + | otherwise = 9 + numDigits (x `quot` 1000000000) + +excessDigits :: Precision p => Number p r -> Maybe Int +excessDigits x@Num { coefficient = c } = precision x >>= excess + where excess p + | d > p = Just (d - p) + | otherwise = Nothing + where d = numDigits c +excessDigits _ = Nothing + +maxCoefficient :: Precision p => p -> Maybe Coefficient +maxCoefficient p = (\d -> 10 ^ d - 1) <$> precision p + +-- | Is the sign of the given 'Number' positive? +isPositive :: Number p r -> Bool +isPositive n = case sign n of + Pos -> True + Neg -> False + +-- | Is the sign of the given 'Number' negative? +isNegative :: Number p r -> Bool +isNegative n = case sign n of + Neg -> True + Pos -> False + +-- | Does the given 'Number' represent a finite value? +isFinite :: Number p r -> Bool +isFinite Num{} = True +isFinite _ = False + +-- | Does the given 'Number' represent the value zero? +isZero :: Number p r -> Bool +isZero Num { coefficient = 0 } = True +isZero _ = False + +-- | Is the given 'Number' normal? +isNormal :: Precision p => Number p r -> Bool +isNormal n + | isFinite n && not (isZero n) && + maybe True (adjustedExponent n >=) (eMin n) = True + | otherwise = False + +-- | Is the given 'Number' subnormal? +isSubnormal :: Precision p => Number p r -> Bool +isSubnormal n + | isFinite n && not (isZero n) && + maybe False (adjustedExponent n <) (eMin n) = True + | otherwise = False + +-- | Upper limit on the absolute value of the exponent +eLimit :: Precision p => Number p r -> Maybe Exponent +eLimit = eMax + +-- | Minimum value of the adjusted exponent +eMin :: Precision p => Number p r -> Maybe Exponent +eMin n = (1 -) <$> eMax n + +-- | Maximum value of the adjusted exponent +eMax :: Precision p => Number p r -> Maybe Exponent +eMax n = subtract 1 . (10 ^) . numDigits <$> base + where mlength = precision n :: Maybe Int + base = (10 *) . fromIntegral <$> mlength :: Maybe Natural + +-- | Minimum value of the exponent for subnormal results +eTiny :: Precision p => Number p r -> Maybe Exponent +eTiny n = (-) <$> eMin n <*> (fromIntegral . subtract 1 <$> precision n) + +-- | Range of permissible exponent values +eRange :: Precision p => Number p r -> Maybe (Exponent, Exponent) +eRange n@Num { coefficient = c } = range <$> eLimit n + where range :: Exponent -> (Exponent, Exponent) + range lim = (-lim - clm1 + 1, lim - clm1) + clength = numDigits c :: Int + clm1 = fromIntegral (clength - 1) :: Exponent +eRange _ = Nothing + +adjustedExponent :: Number p r -> Exponent +adjustedExponent Num { coefficient = c, exponent = e } = + e + fromIntegral (clength - 1) + where clength = numDigits c :: Int +adjustedExponent _ = error "adjustedExponent: not a finite number" + +type TrapHandler p r = Signal -> Number p r -> Number p r + +data Context p r = Context { signalFlags :: Signals + , trapHandler :: TrapHandler p r + } + +instance Precision p => Precision (Context p r) where + precision = precision . contextPrecision + where contextPrecision :: Context p r -> p + contextPrecision = undefined + +defaultContext :: Context p r +defaultContext = Context mempty (const id) + +setSignal :: Signal -> Context p r -> Context p r +setSignal sig cxt = cxt { signalFlags = signalFlags cxt <> signal sig } + +modifyContext :: (Context p r -> Context p r) -> Number p r -> Number p r +modifyContext f n = n { context = f (context n) } + +mergeContexts :: Context p r -> Context p r -> Context p r +mergeContexts cxt1 cxt2 = + cxt1 { signalFlags = signalFlags cxt1 <> signalFlags cxt2 } + +data Signal + = Clamped + | DivisionByZero + | Inexact + | InvalidOperation + | Overflow + | Rounded + | Subnormal + | Underflow + deriving (Enum, Bounded, Show) + +newtype Signals = Signals Int + +instance Show Signals where + showsPrec d sigs = showParen (d > 10) $ + showString "signals " . showsPrec 11 (signalList sigs) + +instance Monoid Signals where + mempty = Signals 0 + Signals x `mappend` Signals y = Signals (x .|. y) + +signal :: Signal -> Signals +signal = Signals . bit . fromEnum + +unsignal :: Signal -> Signals -> Signals +unsignal sig (Signals ss) = Signals $ ss .&. complement (bit $ fromEnum sig) + +signals :: [Signal] -> Signals +signals = foldr (\s n -> signal s <> n) mempty + +signalList :: Signals -> [Signal] +signalList sigs = filter (testSignal sigs) [minBound..maxBound] + +testSignal :: Signals -> Signal -> Bool +testSignal (Signals ss) = testBit ss . fromEnum + +raiseSignal :: Signal -> Number p r -> Number p r +raiseSignal sig n = let n' = modifyContext (setSignal sig) n + in trapHandler (context n') sig n' diff --git a/src/Numeric/Decimal/Number.hs-boot b/src/Numeric/Decimal/Number.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Number.hs-boot @@ -0,0 +1,10 @@ +-- -*- Haskell -*- + +{-# LANGUAGE RoleAnnotations #-} + +module Numeric.Decimal.Number + ( Number + ) where + +type role Number phantom phantom +data Number p r diff --git a/src/Numeric/Decimal/Operation.hs b/src/Numeric/Decimal/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Operation.hs @@ -0,0 +1,202 @@ + +-- | Eventually most or all of the arithmetic operations described in the +-- /General Decimal Arithmetic Specification/ will be provided here. For now, +-- the operations are mostly limited to those exposed through various class +-- methods. +-- +-- It is not usually necessary to import this module. + +module Numeric.Decimal.Operation + ( abs + , add + , subtract + , multiply + , divide + , plus + , minus + , compare + ) where + +import Prelude hiding (abs, compare, exponent, round, subtract) +import qualified Prelude + +import Numeric.Decimal.Number +import Numeric.Decimal.Precision +import {-# SOURCE #-} Numeric.Decimal.Rounding + +invalidOperation :: Number p r -> Number p r +invalidOperation n = raiseSignal InvalidOperation qNaN { context = context n } + +toQNaN :: Number p r -> Number p r +toQNaN SNaN { context = t, sign = s, payload = p } = + QNaN { context = t, sign = s, payload = p } +toQNaN n@QNaN{} = n +toQNaN n = qNaN { context = context n, sign = sign n } + +toQNaN2 :: Number p r -> Number p r -> Number p r +toQNaN2 nan@SNaN{} _ = toQNaN nan +toQNaN2 _ nan@SNaN{} = toQNaN nan +toQNaN2 nan@QNaN{} _ = nan +toQNaN2 _ nan@QNaN{} = nan +toQNaN2 n _ = toQNaN n + +-- | Add two operands. +add :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +add Num { context = xt, sign = xs, coefficient = xc, exponent = xe } + Num { context = yt, sign = ys, coefficient = yc, exponent = ye } = round rn + + where rn = Num { context = rt, sign = rs, coefficient = rc, exponent = re } + rt = mergeContexts xt yt + rs | rc /= 0 = if xac > yac then xs else ys + | xs == Neg && ys == Neg = Neg + | xs /= ys && isRoundFloor rn = Neg + | otherwise = Pos + rc | xs == ys = xac + yac + | xac > yac = xac - yac + | otherwise = yac - xac + re = min xe ye + (xac, yac) | xe == ye = (xc, yc) + | xe > ye = (xc * 10^n, yc) + | otherwise = (xc, yc * 10^n) + where n = Prelude.abs (xe - ye) + +add inf@Inf { context = xt, sign = xs } Inf { context = yt, sign = ys } + | xs == ys = inf { context = mergeContexts xt yt } + | otherwise = invalidOperation inf { context = mergeContexts xt yt } +add inf@Inf{} Num{} = inf +add Num{} inf@Inf{} = inf +add x y = toQNaN2 x y + +-- | Subtract the second operand from the first. +subtract :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +subtract x = add x . flipSign + +-- | Unary minus (negation) +minus :: (Precision p, Rounding r) => Number p r -> Number p r +minus x = zero { exponent = exponent x } `subtract` x + +-- | Unary plus +plus :: (Precision p, Rounding r) => Number p r -> Number p r +plus x = zero { exponent = exponent x } `add` x + +-- | Multiply two operands. +multiply :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +multiply Num { context = xt, sign = xs, coefficient = xc, exponent = xe } + Num { context = yt, sign = ys, coefficient = yc, exponent = ye } = + round rn + + where rn = Num { context = rt, sign = rs, coefficient = rc, exponent = re } + rt = mergeContexts xt yt + rs = xorSigns xs ys + rc = xc * yc + re = xe + ye + +multiply Inf { context = xt, sign = xs } Inf { context = yt, sign = ys } = + Inf { context = mergeContexts xt yt, sign = xorSigns xs ys } +multiply Inf { context = xt, sign = xs } Num { context = yt, sign = ys } = + Inf { context = mergeContexts xt yt, sign = xorSigns xs ys } +multiply Num { context = xt, sign = xs } Inf { context = yt, sign = ys } = + Inf { context = mergeContexts xt yt, sign = xorSigns xs ys } +multiply x y = toQNaN2 x y + +-- | Divide the first dividend operand by the second divisor using long division. +divide :: (FinitePrecision p, Rounding r) + => Number p r -> Number p r -> Number p r +divide dividend@Num{ sign = xs } Num { coefficient = 0, sign = ys } + | isZero dividend = invalidOperation qNaN + | otherwise = raiseSignal DivisionByZero + infinity { sign = xorSigns xs ys } +divide Num { context = xt, sign = xs, coefficient = xc, exponent = xe } + Num { context = yt, sign = ys, coefficient = yc, exponent = ye } = + result + + where rn = Num { context = rt, sign = rs, coefficient = rc, exponent = re } + rt = mergeContexts xt yt + rs = xorSigns xs ys + (rc, rem, dv, adjust) = longDivision xc yc p + re = xe - (ye + adjust) + Just p = precision rn + result + | rem == 0 = rn + | otherwise = round $ case (rem * 2) `Prelude.compare` dv of + LT -> rn { coefficient = rc * 10 + 1, exponent = re - 1 } + EQ -> rn { coefficient = rc * 10 + 5, exponent = re - 1 } + GT -> rn { coefficient = rc * 10 + 9, exponent = re - 1 } + +divide Inf{} Inf{} = invalidOperation qNaN +divide Inf { context = xt, sign = xs } Num { context = yt, sign = ys } = + Inf { context = mergeContexts xt yt, sign = xorSigns xs ys } +divide Num { context = xt, sign = xs } Inf { context = yt, sign = ys } = + zero { context = mergeContexts xt yt, sign = xorSigns xs ys } +divide x y = toQNaN2 x y + +type Dividend = Coefficient +type Divisor = Coefficient +type Quotient = Coefficient +type Remainder = Coefficient + +longDivision :: Dividend -> Divisor -> Int + -> (Quotient, Remainder, Divisor, Exponent) +longDivision 0 dv _ = (0, 0, dv, 0) +longDivision dd dv p = step1 dd dv 0 + + where step1 dd dv adjust + | dd < dv = step1 (dd * 10) dv (adjust + 1) + | dd >= 10 * dv = step1 dd (dv * 10) (adjust - 1) + | otherwise = step2 dd dv adjust + + step2 = step3 0 + + step3 r dd dv adjust + | dv <= dd = step3 (r + 1) (dd - dv) dv adjust + | (dd == 0 && adjust >= 0) || + numDigits r == p = step4 r dd dv adjust + | otherwise = step3 (r * 10) (dd * 10) dv (adjust + 1) + + step4 = (,,,) + +-- | If the operand is negative, the result is the same as using the 'minus' +-- operation on the operand. Otherwise, the result is the same as using the +-- 'plus' operation on the operand. +abs :: (Precision p, Rounding r) => Number p r -> Number p r +abs x + | isNegative x = minus x + | otherwise = plus x + +-- | Compare the values of two operands numerically, returning @-1@ if the +-- first is less than the second, @0@ if they are equal, or @1@ if the first +-- is greater than the second. +compare :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +compare x@Num{} y@Num{} = (nzp $ xn `subtract` yn) { context = rt } + + where (xn, yn) | sign x /= sign y = (nzp x, nzp y) + | otherwise = (x, y) + + rt = mergeContexts (context x) (context y) + + nzp :: Number p r -> Number p r + nzp Num { context = t, sign = s, coefficient = c } + | c == 0 = zero { context = t } + | s == Pos = one { context = t } + | otherwise = negativeOne { context = t } + nzp Inf { context = t, sign = s } + | s == Pos = one { context = t } + | otherwise = negativeOne { context = t } + nzp n = toQNaN n + +compare Inf { context = xt, sign = xs } Inf { context = yt, sign = ys } + | xs == ys = zero { context = rt } + | xs == Neg = negativeOne { context = rt } + | otherwise = one { context = rt } + where rt = mergeContexts xt yt +compare Inf { context = xt, sign = xs } Num { context = yt } + | xs == Neg = negativeOne { context = rt } + | otherwise = one { context = rt } + where rt = mergeContexts xt yt +compare Num { context = xt } Inf { context = yt, sign = ys } + | ys == Pos = negativeOne { context = rt } + | otherwise = one { context = rt } + where rt = mergeContexts xt yt +compare nan@SNaN{} _ = invalidOperation nan +compare _ nan@SNaN{} = invalidOperation nan +compare x y = toQNaN2 x y diff --git a/src/Numeric/Decimal/Operation.hs-boot b/src/Numeric/Decimal/Operation.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Operation.hs-boot @@ -0,0 +1,26 @@ +-- -*- Haskell -*- + +module Numeric.Decimal.Operation + ( add + , subtract + , multiply + , divide + , minus + , abs + , compare + ) where + +import Prelude hiding (abs, compare, subtract) + +import {-# SOURCE #-} Numeric.Decimal.Number +import Numeric.Decimal.Precision +import {-# SOURCE #-} Numeric.Decimal.Rounding + +add :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +subtract :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +multiply :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r +divide :: (FinitePrecision p, Rounding r) => + Number p r -> Number p r -> Number p r +minus :: (Precision p, Rounding r) => Number p r -> Number p r +abs :: (Precision p, Rounding r) => Number p r -> Number p r +compare :: (Precision p, Rounding r) => Number p r -> Number p r -> Number p r diff --git a/src/Numeric/Decimal/Precision.hs b/src/Numeric/Decimal/Precision.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Precision.hs @@ -0,0 +1,100 @@ + +module Numeric.Decimal.Precision + ( Precision(..) + , FinitePrecision + + , P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 , P10 + , P11, P12, P13, P14, P15, P16, P17, P18, P19, P20 + , P21, P22, P23, P24, P25, P26, P27, P28, P29, P30 + , P31, P32, P33, P34, P35, P36, P37, P38, P39, P40 + , P41, P42, P43, P44, P45, P46, P47, P48, P49, P50 + + , P75, P100, P150, P200, P250, P300, P400, P500, P1000, P2000 + + , PPlus1, PTimes2 + + , PInfinite + ) where + +-- | Precision indicates the maximum number of significant digits a number may +-- have. +class Precision p where + -- | Return the precision of the argument, or 'Nothing' if the precision is infinite. + precision :: p -> Maybe Int + +-- | A subclass of precisions which are finite +class Precision p => FinitePrecision p + +-- | A precision of unlimited significant digits +data PInfinite +instance Precision PInfinite where + precision _ = Nothing + +-- | A precision of 1 significant digit +data P1 +instance Precision P1 where + precision _ = Just 1 +instance FinitePrecision P1 + +-- | A precision of (@p@ + 1) significant digits +data PPlus1 p +instance Precision p => Precision (PPlus1 p) where + precision pp = (+ 1) <$> precision (minus1 pp) + where minus1 :: PPlus1 p -> p + minus1 = undefined +instance FinitePrecision p => FinitePrecision (PPlus1 p) + +-- | A precision of (@p@ × 2) significant digits +data PTimes2 p +instance Precision p => Precision (PTimes2 p) where + precision pp = (* 2) <$> precision (div2 pp) + where div2 :: PTimes2 p -> p + div2 = undefined +instance FinitePrecision p => FinitePrecision (PTimes2 p) + +-- | A precision of 2 significant digits +type P2 = PTimes2 P1 ; type P3 = PPlus1 P2 +-- ^ A precision of 3 significant digits + +-- | Et cetera +type P4 = PTimes2 P2 ; type P5 = PPlus1 P4 +type P6 = PTimes2 P3 ; type P7 = PPlus1 P6 +type P8 = PTimes2 P4 ; type P9 = PPlus1 P8 +type P10 = PTimes2 P5 ; type P11 = PPlus1 P10 +type P12 = PTimes2 P6 ; type P13 = PPlus1 P12 +type P14 = PTimes2 P7 ; type P15 = PPlus1 P14 +type P16 = PTimes2 P8 ; type P17 = PPlus1 P16 +type P18 = PTimes2 P9 ; type P19 = PPlus1 P18 +type P20 = PTimes2 P10; type P21 = PPlus1 P20 +type P22 = PTimes2 P11; type P23 = PPlus1 P22 +type P24 = PTimes2 P12; type P25 = PPlus1 P24 +type P26 = PTimes2 P13; type P27 = PPlus1 P26 +type P28 = PTimes2 P14; type P29 = PPlus1 P28 +type P30 = PTimes2 P15; type P31 = PPlus1 P30 +type P32 = PTimes2 P16; type P33 = PPlus1 P32 +type P34 = PTimes2 P17; type P35 = PPlus1 P34 +type P36 = PTimes2 P18; type P37 = PPlus1 P36 +type P38 = PTimes2 P19; type P39 = PPlus1 P38 +type P40 = PTimes2 P20; type P41 = PPlus1 P40 +type P42 = PTimes2 P21; type P43 = PPlus1 P42 +type P44 = PTimes2 P22; type P45 = PPlus1 P44 +type P46 = PTimes2 P23; type P47 = PPlus1 P46 +type P48 = PTimes2 P24; type P49 = PPlus1 P48 + +type P50 = PTimes2 P25 +type P62 = PTimes2 P31 +type P74 = PTimes2 P37; type P75 = PPlus1 P74 + +type P100 = PTimes2 P50 +type P124 = PTimes2 P62; type P125 = PPlus1 P124 +type P150 = PTimes2 P75 + +type P200 = PTimes2 P100 +type P250 = PTimes2 P125 + +type P300 = PTimes2 P150 +type P400 = PTimes2 P200 +type P500 = PTimes2 P250 + +type P1000 = PTimes2 P500 +type P2000 = PTimes2 P1000 diff --git a/src/Numeric/Decimal/Rounding.hs b/src/Numeric/Decimal/Rounding.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Rounding.hs @@ -0,0 +1,172 @@ + +module Numeric.Decimal.Rounding + ( Rounding(..) + + , RoundDown + , RoundHalfUp + , RoundHalfEven + , RoundCeiling + , RoundFloor + + , RoundHalfDown + , RoundUp + , Round05Up + ) where + +import Prelude hiding (exponent) + +import Numeric.Decimal.Number +import Numeric.Decimal.Precision + +-- | A rounding algorithm to use when the result of an arithmetic operation +-- exceeds the precision of the result type +class Rounding r where + round :: Precision p => Number p r -> Number p r + + isRoundFloor :: Number p r -> Bool + isRoundFloor _ = False + +-- Required... + +-- | Round toward 0 (truncate) +data RoundDown +instance Rounding RoundDown where + round = roundDown + +-- | If the discarded digits represent greater than or equal to half (0.5) of +-- the value of a one in the next left position then the value is rounded +-- up. If they represent less than half, the value is rounded down. +data RoundHalfUp +instance Rounding RoundHalfUp where + round = roundHalfUp + +-- | If the discarded digits represent greater than half (0.5) of the value of +-- a one in the next left position then the value is rounded up. If they +-- represent less than half, the value is rounded down. If they represent +-- exactly half, the value is rounded to make its rightmost digit even. +data RoundHalfEven +instance Rounding RoundHalfEven where + round = roundHalfEven + +-- | Round toward +∞ +data RoundCeiling +instance Rounding RoundCeiling where + round = roundCeiling + +-- | Round toward −∞ +data RoundFloor +instance Rounding RoundFloor where + round = roundFloor + isRoundFloor _ = True + +-- Optional... + +-- | If the discarded digits represent greater than half (0.5) of the value of +-- a one in the next left position then the value is rounded up. If they +-- represent less than half or exactly half, the value is rounded down. +data RoundHalfDown +instance Rounding RoundHalfDown where + round = roundHalfDown + +-- | Round away from 0 +data RoundUp +instance Rounding RoundUp where + round = roundUp + +-- | Round zero or five away from 0 +data Round05Up +instance Rounding Round05Up where + round = round05Up + +-- Implementations + +rounded :: (Coefficient -> Coefficient -> Coefficient -> + Number p r -> Number p r -> Number p r) + -> Int -> Number p r -> Number p r +rounded f d n = raiseSignal Rounded rounded' + where rounded' + | r /= 0 = raiseSignal Inexact n' + | otherwise = n' + p = 10 ^ d + (q, r) = coefficient n `quotRem` p + n' = f (p `quot` 2) q r down up + down = n { coefficient = q + , exponent = exponent n + fromIntegral d + } + up = n { coefficient = q + 1 + , exponent = exponent n + fromIntegral d + } + +roundDown :: Precision p => Number p r -> Number p r +roundDown n = roundDown' (excessDigits n) + where roundDown' Nothing = n + roundDown' (Just d) = rounded choice d n + + choice _h _q _r down _up = down + +roundHalfUp :: Precision p => Number p r -> Number p r +roundHalfUp n = roundHalfUp' (excessDigits n) + where roundHalfUp' Nothing = n + roundHalfUp' (Just d) = rounded choice d n + + choice h _q r down up + | r >= h = roundHalfUp up + | otherwise = down + +roundHalfEven :: Precision p => Number p r -> Number p r +roundHalfEven n = roundHalfEven' (excessDigits n) + where roundHalfEven' Nothing = n + roundHalfEven' (Just d) = rounded choice d n + + choice h q r down up = case r `Prelude.compare` h of + LT -> down + GT -> roundHalfEven up + EQ | even q -> down + | otherwise -> roundHalfEven up + +roundCeiling :: Precision p => Number p r -> Number p r +roundCeiling n = roundCeiling' (excessDigits n) + where roundCeiling' Nothing = n + roundCeiling' (Just d) = rounded choice d n + + choice _h _q r down up + | r == 0 || sign n == Neg = down + | otherwise = roundCeiling up + +roundFloor :: Precision p => Number p r -> Number p r +roundFloor n = roundFloor' (excessDigits n) + where roundFloor' Nothing = n + roundFloor' (Just d) = rounded choice d n + + choice _h _q r down up + | r == 0 || sign n == Pos = down + | otherwise = roundFloor up + +roundHalfDown :: Precision p => Number p r -> Number p r +roundHalfDown n = roundHalfDown' (excessDigits n) + where roundHalfDown' Nothing = n + roundHalfDown' (Just d) = rounded choice d n + + choice h _q r down up + | r > h = roundHalfDown up + | otherwise = down + +roundUp :: Precision p => Number p r -> Number p r +roundUp n = roundUp' (excessDigits n) + where roundUp' Nothing = n + roundUp' (Just d) = rounded choice d n + + choice _h _q r down up + | r == 0 = down + | otherwise = roundUp up + +round05Up :: Precision p => Number p r -> Number p r +round05Up n = round05Up' (excessDigits n) + where round05Up' Nothing = n + round05Up' (Just d) = rounded choice d n + + choice _h q r down up + | r == 0 = down + | d == 0 || d == 5 = round05Up up -- overflow -> roundDown? + | otherwise = down + where d = q `rem` 10 diff --git a/src/Numeric/Decimal/Rounding.hs-boot b/src/Numeric/Decimal/Rounding.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/Rounding.hs-boot @@ -0,0 +1,14 @@ +-- -*- Haskell -*- + +module Numeric.Decimal.Rounding + ( Rounding(..) + ) where + +import {-# SOURCE #-} Numeric.Decimal.Number (Number) +import Numeric.Decimal.Precision (Precision) + +class Rounding r where + round :: Precision p => Number p r -> Number p r + + isRoundFloor :: Number p r -> Bool + isRoundFloor _ = False diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,35 @@ +# This file was automatically generated by stack init +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-5.15 + +# Local packages, usually specified by relative directory name +packages: +- '.' +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,30 @@ + +import Numeric.Decimal +import Test.QuickCheck + +main :: IO () +main = putStrLn "Test suite not yet implemented" + +infinity :: (Precision p, Rounding r) => Number p r +infinity = read "Infinity" + +instance (Precision p, Rounding r) => Arbitrary (Number p r) where + arbitrary = frequency [(85, genNum), (10, genInf)] + +genNum :: (Precision p, Rounding r) => Gen (Number p r) +genNum = do + c <- choose (-(10^10), 10^10) :: Gen Integer + e <- choose (-99, 99) :: Gen Integer + return $ read (show c ++ 'E' : show e) + +genInf :: (Precision p, Rounding r) => Gen (Number p r) +genInf = do + s <- elements [-1, 1] + return (s * infinity) + +genNaN :: (Precision p, Rounding r) => Gen (Number p r) +genNaN = oneof [nan "", nan "s"] + where nan kind = do + s <- elements ["", "-"] + p <- choose (0, 10000) :: Gen Integer + return $ read (s ++ kind ++ "NaN" ++ show p)