module Numeric.Decimal.Conversion
(
toScientificString
, toEngineeringString
, 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
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
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
| e < 0 = indicator . exps
| otherwise = indicator . showChar '+' . exps
where indicator = showChar 'E' :: ShowS
exps = shows e :: ShowS
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