module Numeric.Decimal.Rounding
( RoundingAlgorithm(..)
, Rounding(rounding)
, RoundDown
, RoundHalfUp
, RoundHalfEven
, RoundCeiling
, RoundFloor
, RoundHalfDown
, RoundUp
, Round05Up
, getRounder
, Rounder
, roundDecimal
) where
import Prelude hiding (exponent)
import Data.Coerce (coerce)
import {-# SOURCE #-} Numeric.Decimal.Arithmetic
import {-# SOURCE #-} Numeric.Decimal.Exception
import {-# SOURCE #-} Numeric.Decimal.Number
import Numeric.Decimal.Precision
data RoundingAlgorithm = RoundDown
| RoundHalfUp
| RoundHalfEven
| RoundCeiling
| RoundFloor
| RoundHalfDown
| RoundUp
| Round05Up
deriving Eq
class Rounding r where
rounding :: r -> RoundingAlgorithm
roundCoefficient :: r -> Rounder
type Remainder = Coefficient
type Divisor = Coefficient
type Rounder = Sign -> Remainder -> Divisor -> Coefficient -> Coefficient
getRounder :: Rounding r => Arith p r Rounder
getRounder = ($ undefined) <$> getRounder'
where getRounder' :: Rounding r => Arith p r (r -> Rounder)
getRounder' = return roundCoefficient
roundDecimal :: (Precision p, Rounding r)
=> Decimal a b -> Arith p r (Decimal p r)
roundDecimal n@Num { sign = s, coefficient = c, exponent = e } = do
p <- getPrecision
case excessDigits c =<< p of
Just d -> do
rounder <- getRounder
let b = 10 ^ d
(q, r) = c `quotRem` b
c' = rounder s r b q
e' = e + fromIntegral d
n' = case excessDigits c' =<< p of
Nothing -> n { coefficient = c' , exponent = e' }
_ -> n { coefficient = c' `quot` 10, exponent = succ e' }
rounded =<< (if r /= 0 then inexact else return) n'
Nothing -> return (coerce n)
roundDecimal n@NaN { payload = p } = do
prec <- getPrecision
case excessDigits p =<< (pred <$> prec) of
Just _ -> return n { payload = 0 }
Nothing -> return (coerce n)
roundDecimal n = return (coerce n)
excessDigits :: Coefficient -> Int -> Maybe Int
excessDigits c p | d > p = Just (d - p)
| otherwise = Nothing
where d = numDigits c :: Int
data RoundDown
instance Rounding RoundDown where
rounding _ = RoundDown
roundCoefficient _ _ _ _ = id
data RoundHalfUp
instance Rounding RoundHalfUp where
rounding _ = RoundHalfUp
roundCoefficient _ _ r v | r * 2 >= v = succ
| otherwise = id
data RoundHalfEven
instance Rounding RoundHalfEven where
rounding _ = RoundHalfEven
roundCoefficient _ _ r v q = case (r * 2) `Prelude.compare` v of
GT -> succ q
EQ | odd q -> succ q
_ -> q
data RoundCeiling
instance Rounding RoundCeiling where
rounding _ = RoundCeiling
roundCoefficient _ Pos r _ | r /= 0 = succ
roundCoefficient _ _ _ _ = id
data RoundFloor
instance Rounding RoundFloor where
rounding _ = RoundFloor
roundCoefficient _ Neg r _ | r /= 0 = succ
roundCoefficient _ _ _ _ = id
data RoundHalfDown
instance Rounding RoundHalfDown where
rounding _ = RoundHalfDown
roundCoefficient _ _ r v | r * 2 > v = succ
| otherwise = id
data RoundUp
instance Rounding RoundUp where
rounding _ = RoundUp
roundCoefficient _ _ r _ | r /= 0 = succ
| otherwise = id
data Round05Up
instance Rounding Round05Up where
rounding _ = Round05Up
roundCoefficient _ _ r _ q | r /= 0 && rem q 10 `elem` [0, 5] = succ q
| otherwise = q