module Data.Decimal (
DecimalRaw (..),
Decimal,
realFracToDecimal,
decimalConvert,
roundTo,
(*.),
divide,
allocate,
eitherFromRational,
normalizeDecimal,
) where
import Control.Monad.Instances ()
import Control.DeepSeq
import Data.Char
import Data.Ratio
import Data.Word
import Data.Typeable
import Text.ParserCombinators.ReadP
data (Integral i) => DecimalRaw i = Decimal {
decimalPlaces :: ! Word8,
decimalMantissa :: ! i}
deriving (Typeable)
type Decimal = DecimalRaw Integer
instance (Integral i, NFData i) => NFData (DecimalRaw i) where
rnf (Decimal _ i) = rnf i
realFracToDecimal :: (Integral i, RealFrac r) => Word8 -> r -> DecimalRaw i
realFracToDecimal e r = Decimal e $ round (r * (10^e))
divRound :: (Integral a) => a -> a -> a
divRound n1 n2 = if abs r > abs (n2 `quot` 2) then n + signum n else n
where (n, r) = n1 `quotRem` n2
decimalConvert :: (Integral a, Integral b) => DecimalRaw a -> DecimalRaw b
decimalConvert (Decimal e n) = Decimal e $ fromIntegral n
roundTo :: (Integral i) => Word8 -> DecimalRaw i -> DecimalRaw Integer
roundTo d (Decimal e n) = Decimal d $ fromIntegral n1
where
n1 = case compare d e of
LT -> n `divRound` divisor
EQ -> n
GT -> n * multiplier
divisor = 10 ^ (ed)
multiplier = 10 ^ (de)
roundMax :: (Integral i) =>
DecimalRaw i -> DecimalRaw i -> (Word8, Integer, Integer)
roundMax d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
where
e = max e1 e2
(Decimal _ n1) = roundTo e d1
(Decimal _ n2) = roundTo e d2
instance (Integral i, Show i) => Show (DecimalRaw i) where
showsPrec _ (Decimal e n)
| e == 0 = (concat [signStr, strN] ++)
| otherwise = (concat [signStr, intPart, ".", fracPart] ++)
where
strN = show $ abs n
signStr = if n < 0 then "-" else ""
len = length strN
padded = replicate (fromIntegral e + 1 len) '0' ++ strN
(intPart, fracPart) = splitAt (max 1 (len fromIntegral e)) padded
instance (Integral i, Read i) => Read (DecimalRaw i) where
readsPrec _ =
readP_to_S $ do
(intPart, _) <- gather $ do
optional $ char '-'
munch1 isDigit
fractPart <- option "" $ do
_ <- char '.'
munch1 isDigit
return $ Decimal (fromIntegral $ length fractPart) $ read $
intPart ++ fractPart
instance (Integral i) => Eq (DecimalRaw i) where
d1 == d2 = n1 == n2 where (_, n1, n2) = roundMax d1 d2
instance (Integral i) => Ord (DecimalRaw i) where
compare d1 d2 = compare n1 n2 where (_, n1, n2) = roundMax d1 d2
instance (Integral i) => Num (DecimalRaw i) where
d1 + d2 = Decimal e $ fromIntegral (n1 + n2)
where (e, n1, n2) = roundMax d1 d2
d1 d2 = Decimal e $ fromIntegral (n1 n2)
where (e, n1, n2) = roundMax d1 d2
d1 * d2 = normalizeDecimal $ realFracToDecimal maxBound $ (toRational d1) * (toRational d2)
abs (Decimal e n) = Decimal e $ abs n
signum (Decimal _ n) = fromIntegral $ signum n
fromInteger n = Decimal 0 $ fromIntegral n
instance (Integral i) => Real (DecimalRaw i) where
toRational (Decimal e n) = fromIntegral n % (10 ^ e)
instance (Integral i) => Fractional (DecimalRaw i) where
fromRational r = normalizeDecimal $ realFracToDecimal maxBound r
a / b = fromRational $ (toRational a) / (toRational b)
instance (Integral i) => RealFrac (DecimalRaw i) where
properFraction a = (rnd, fromRational rep)
where
(rnd, rep) = properFraction $ toRational a
divide :: (Integral i) => DecimalRaw i -> Int -> [(Int, DecimalRaw i)]
divide (Decimal e n) d
| d > 0 =
case n `divMod` fromIntegral d of
(result, 0) -> [(fromIntegral d, Decimal e result)]
(result, r) -> [(fromIntegral d fromIntegral r,
Decimal e result),
(fromIntegral r, Decimal e (result+1))]
| otherwise = error "Data.Decimal.divide: Divisor must be > 0."
allocate :: (Integral i) => DecimalRaw i -> [Integer] -> [DecimalRaw i]
allocate (Decimal e n) ps
| total == 0 =
error "Data.Decimal.allocate: allocation list must not sum to zero."
| otherwise = map (Decimal e) $ zipWith () ts (tail ts)
where
ts = map fst $ scanl nxt (n, total) ps
nxt (n1, t1) p1 = (n1 (n1 * fromIntegral p1) `zdiv` t1,
t1 fromIntegral p1)
zdiv 0 0 = 0
zdiv x y = x `divRound` y
total = fromIntegral $ sum ps
(*.) :: (Integral i, RealFrac r) => DecimalRaw i -> r -> DecimalRaw i
(Decimal e m) *. d = Decimal e $ round $ fromIntegral m * d
factorN :: (Integral a)
=> a
-> a
-> (a, a)
factorN d val = factorN' val 0
where
factorN' 1 acc = (acc, 1)
factorN' v acc = if md == 0
then factorN' vd (acc + 1)
else (acc, v)
where
(vd, md) = v `divMod` d
eitherFromRational :: (Integral i) => Rational -> Either String (DecimalRaw i)
eitherFromRational r = if done == 1
then do
wres <- we
return $ Decimal wres (fromIntegral m)
else Left $ show r ++ " has no decimal denominator"
where
den = denominator r
num = numerator r
(f2, rest) = factorN 2 den
(f5, done) = factorN 5 rest
e = max f2 f5
m = num * ((10^e) `div` den)
we = if e > (fromIntegral (maxBound :: Word8))
then Left $ show e ++ " is too big ten power to represent as Decimal"
else Right $ fromIntegral e
normalizeDecimal :: (Integral i) => (DecimalRaw i) -> (DecimalRaw i)
normalizeDecimal r = case eitherFromRational $ toRational r of
Right x -> x
Left e -> error $ "Imposible happened: " ++ e