module Deka.Native.FromString where
import Data.Char (toLower)
import Control.Applicative
import Text.Parsec.String
import Text.Parsec.Prim (tokenPrim, try, parse)
import Text.Parsec.Pos
import Text.Parsec.Char (char, string)
import Text.Parsec.Combinator (many1, eof)
import qualified Deka.Native.Abstract as A
import Deka.Native.Abstract
(Decem(..), Novem(..), decemListToInt)
import Deka.Dec (Sign(..))
import qualified Deka.Dec as D
import qualified Data.ByteString.Char8 as BS8
sign :: Parser Sign
sign = tokenPrim show next f
where
next pos c _ = updatePosChar pos c
f c = case c of
'-' -> Just Sign1
'+' -> Just Sign0
_ -> Nothing
optSign :: Parser Sign
optSign = do
s <- optional sign
return $ maybe Sign0 id s
digit :: Parser Decem
digit = tokenPrim show next f
where
next pos c _ = updatePosChar pos c
f c = case c of
{ '0' -> Just D0; '1' -> Just $ Nonem D1; '2' -> Just $ Nonem D2;
'3' -> Just $ Nonem D3; '4' -> Just $ Nonem D4;
'5' -> Just $ Nonem D5; '6' -> Just $ Nonem D6;
'7' -> Just $ Nonem D7; '8' -> Just $ Nonem D8;
'9' -> Just $ Nonem D9; _ -> Nothing }
indicator :: Parser ()
indicator = () <$ char 'e'
digits :: Parser [Decem]
digits = many1 digit
data DecimalPart
= WholeFrac [Decem] [Decem]
| WholeOnly [Decem]
deriving (Eq, Ord, Show)
decimalPart :: Parser DecimalPart
decimalPart = do
ds1 <- optional digits
case ds1 of
Nothing -> do
_ <- char '.'
fmap WholeOnly digits
Just ds -> do
dot <- optional (char '.')
case dot of
Just _ -> do
ds2 <- many digit
return $ WholeFrac ds ds2
Nothing -> return $ WholeOnly ds
data ExponentPart = ExponentPart
{ expSign :: Sign
, expDigits :: [Decem]
} deriving (Eq, Ord, Show)
exponentPart :: Parser ExponentPart
exponentPart = do
indicator
sgn <- optSign
ds <- digits
return $ ExponentPart sgn ds
infinity :: Parser ()
infinity = try $ do
_ <- string "inf"
_ <- optional (string "inity")
return ()
nanId :: Parser A.Noisy
nanId = try (string "nan" >> return A.Quiet)
<|> try (string "snan" >> return A.Signaling)
data NaN = NaN A.Noisy [Decem]
deriving (Eq, Ord, Show)
nan :: Parser NaN
nan = liftA2 NaN nanId (many digit)
data NumericValue
= NVDec DecimalPart (Maybe ExponentPart)
| Infinity
deriving (Eq, Ord, Show)
numericValue :: Parser NumericValue
numericValue =
(Infinity <$ infinity)
<|> liftA2 NVDec decimalPart (optional exponentPart)
data NumericString = NumericString
{ nsSign :: Sign
, nsValue :: Either NumericValue NaN
} deriving (Eq, Ord, Show)
numericString :: Parser NumericString
numericString = liftA2 NumericString optSign ei
where
ei = (fmap Left numericValue <|> fmap Right nan)
parseNumericString :: String -> Either String NumericString
parseNumericString s =
case parse (numericString <* eof) "" (map toLower s) of
Left e -> Left (show e)
Right g -> Right g
numericStringToAbstract :: NumericString -> A.Abstract
numericStringToAbstract (NumericString sgn ei) = A.Abstract sgn val
where
val = case ei of
Left nv -> case nv of
NVDec dp me -> uncurry A.Finite $ finiteToAbstract dp me
Infinity -> A.Infinite
Right nn -> A.NotANumber . nanToAbstract $ nn
nanToAbstract
:: NaN
-> A.NonNum
nanToAbstract (NaN nsy ds) = A.NonNum nsy . fmap A.Diagnostic
. A.decemListToDecuple $ ds
finiteToAbstract
:: DecimalPart
-> Maybe ExponentPart
-> (A.Coefficient, A.Exponent)
finiteToAbstract dp mep = (coe, ex)
where
ex = abstractExponent . actualExponent dp
. givenExponent $ mep
coe = abstractCoeff dp
givenExponent :: Maybe ExponentPart -> Integer
givenExponent me = case me of
Nothing -> 0
Just (ExponentPart s ds) -> getSgn $ decemListToInt ds
where
getSgn = case s of
Sign0 -> id
Sign1 -> negate
actualExponent
:: DecimalPart
-> Integer
-> Integer
actualExponent d i = case d of
WholeFrac _ ds -> i fromIntegral (length ds)
_ -> i
abstractExponent
:: Integer
-> A.Exponent
abstractExponent = A.Exponent . A.intToFirmado
abstractCoeff :: DecimalPart -> A.Coefficient
abstractCoeff d =
let ds = case d of
WholeFrac d1 d2 -> d1 ++ d2
WholeOnly d1 -> d1
in A.Coefficient $ A.decemListToAut ds
stringToAbstract
:: String
-> Either String A.Abstract
stringToAbstract = fmap numericStringToAbstract . parseNumericString
decToAbstract :: D.Dec -> A.Abstract
decToAbstract = either (error msg) id . stringToAbstract
. BS8.unpack . D.toByteString
where
msg = "decToAbstract: error: could not parse output from "
++ "toByteString"