module Numeric.Decimal.Rounding
( RoundingAlgorithm(..)
, Rounding(..)
, RoundDown
, RoundHalfUp
, RoundHalfEven
, RoundCeiling
, RoundFloor
, RoundHalfDown
, RoundUp
, Round05Up
) where
import Prelude hiding (exponent)
import Numeric.Decimal.Number
import Numeric.Decimal.Precision
import Numeric.Decimal.Arithmetic
data RoundingAlgorithm = RoundDown
| RoundHalfUp
| RoundHalfEven
| RoundCeiling
| RoundFloor
| RoundHalfDown
| RoundUp
| Round05Up
deriving (Eq, Enum)
class Rounding r where
rounding :: r -> RoundingAlgorithm
round :: Precision p => Decimal p r -> Arith p r (Decimal p r)
data RoundDown
instance Rounding RoundDown where
rounding _ = RoundDown
round = roundDown
data RoundHalfUp
instance Rounding RoundHalfUp where
rounding _ = RoundHalfUp
round = roundHalfUp
data RoundHalfEven
instance Rounding RoundHalfEven where
rounding _ = RoundHalfEven
round = roundHalfEven
data RoundCeiling
instance Rounding RoundCeiling where
rounding _ = RoundCeiling
round = roundCeiling
data RoundFloor
instance Rounding RoundFloor where
rounding _ = RoundFloor
round = roundFloor
data RoundHalfDown
instance Rounding RoundHalfDown where
rounding _ = RoundHalfDown
round = roundHalfDown
data RoundUp
instance Rounding RoundUp where
rounding _ = RoundUp
round = roundUp
data Round05Up
instance Rounding Round05Up where
rounding _ = Round05Up
round = round05Up
excessDigits :: Precision p => Decimal p r -> Arith p r (Maybe Int)
excessDigits n@Num { coefficient = c } = result
where result = return (precision n >>= excess)
d = numDigits c
excess p
| d > p = Just (d p)
| otherwise = Nothing
excessDigits _ = return Nothing
rounded :: (Coefficient -> Coefficient -> Coefficient ->
Decimal p r -> Decimal p r -> Decimal p r)
-> Int -> Decimal p r -> Arith p r (Decimal p r)
rounded f d n = raiseSignal Rounded =<< rounded' n'
where rounded'
| r /= 0 = raiseSignal Inexact
| otherwise = return
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 => Decimal p r -> Arith p r (Decimal p r)
roundDown n = excessDigits n >>= roundDown'
where roundDown' Nothing = return n
roundDown' (Just d) = rounded choice d n
choice _h _q _r down _up = down
roundHalfUp :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundHalfUp n = excessDigits n >>= roundHalfUp'
where roundHalfUp' Nothing = return n
roundHalfUp' (Just d) = rounded choice d n
choice h _q r down up
| r >= h = up
| otherwise = down
roundHalfEven :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundHalfEven n = excessDigits n >>= roundHalfEven'
where roundHalfEven' Nothing = return n
roundHalfEven' (Just d) = rounded choice d n
choice h q r down up = case r `Prelude.compare` h of
LT -> down
GT -> up
EQ | even q -> down
| otherwise -> up
roundCeiling :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundCeiling n = excessDigits n >>= roundCeiling'
where roundCeiling' Nothing = return n
roundCeiling' (Just d) = rounded choice d n
choice _h _q r down up
| r == 0 || sign n == Neg = down
| otherwise = up
roundFloor :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundFloor n = excessDigits n >>= roundFloor'
where roundFloor' Nothing = return n
roundFloor' (Just d) = rounded choice d n
choice _h _q r down up
| r == 0 || sign n == Pos = down
| otherwise = up
roundHalfDown :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundHalfDown n = excessDigits n >>= roundHalfDown'
where roundHalfDown' Nothing = return n
roundHalfDown' (Just d) = rounded choice d n
choice h _q r down up
| r > h = up
| otherwise = down
roundUp :: Precision p => Decimal p r -> Arith p r (Decimal p r)
roundUp n = excessDigits n >>= roundUp'
where roundUp' Nothing = return n
roundUp' (Just d) = rounded choice d n
choice _h _q r down up
| r == 0 = down
| otherwise = up
round05Up :: Precision p => Decimal p r -> Arith p r (Decimal p r)
round05Up n = excessDigits n >>= round05Up'
where round05Up' Nothing = return n
round05Up' (Just d) = rounded choice d n
choice _h q r down up
| r == 0 = down
| d == 0 || d == 5 = up
| otherwise = down
where d = q `rem` 10