module Data.Numbers.FloatingHex (hf, readHFloat, showHFloat) where
import Data.Char (toLower)
import Data.Ratio ((%))
import Numeric (showHex, floatToDigits)
import GHC.Float
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote
class RealFloat a => FloatingHexReader a where
readHFloat :: String -> Maybe a
instance FloatingHexReader Float where
readHFloat s = double2Float `fmap` readHFloatAsDouble s
instance FloatingHexReader Double where
readHFloat = readHFloatAsDouble
readHFloatAsDouble :: String -> Maybe Double
readHFloatAsDouble = cvt
where cvt ('-' : cs) = ((1) *) `fmap` go cs
cvt cs = go cs
go "NaN" = Just $ 0/0
go "Infinity" = Just $ 1/0
go cs = parseHexFloat cs
parseHexFloat :: String -> Maybe Double
parseHexFloat = goS . map toLower
where goS ('+':rest) = go0 rest
goS cs = go0 cs
go0 ('0':'x':rest) = go1 rest
go0 _ = Nothing
go1 cs = case break (== 'p') cs of
(pre, 'p':'+':d) -> go2 pre d
(pre, 'p': d) -> go2 pre d
_ -> Nothing
go2 cs = case break (== '.') cs of
(pre, '.':post) -> construct pre post
_ -> construct cs ""
rd :: Read a => String -> Maybe a
rd s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
construct pre post d = do a <- rd $ "0x" ++ pre ++ post
e <- rd d
return $ val a (length post) e
val :: Integer -> Int -> Integer -> Double
val a b e
| e > 0 = fromRational $ (top * power) % bot
| True = fromRational $ top % (power * bot)
where top, bot, power :: Integer
top = a
bot = 16 ^ b
power = 2 ^ abs e
hf :: QuasiQuoter
hf = QuasiQuoter { quoteExp = q
, quotePat = p
, quoteType = error "Unexpected hexadecimal float in a type context"
, quoteDec = error "Unexpected hexadecimal float in a declaration context"
}
where q :: String -> TH.Q TH.Exp
q s = case parseHexFloat s of
Just d -> TH.lift d
Nothing -> fail $ "Invalid hexadecimal floating point number: |" ++ s ++ "|"
p :: String -> TH.Q TH.Pat
p s = case parseHexFloat s of
Just d -> return (TH.LitP (TH.RationalL (toRational d)))
Nothing -> fail $ "Invalid hexadecimal floating point number: |" ++ s ++ "|"
showHFloat :: RealFloat a => a -> ShowS
showHFloat = showString . fmt
where fmt x | isNaN x = "NaN"
| isInfinite x = (if x < 0 then "-" else "") ++ "Infinity"
| x < 0 || isNegativeZero x = '-' : cvt (x)
| True = cvt x
cvt x
| x == 0 = "0x0p+0"
| True = case floatToDigits 2 x of
r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r
(d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e1)
frac digits
| all (== 0) digits = ""
| True = "." ++ hex digits
where hex ds
| null ds = ""
| length ds < 4 = hex (take 4 (ds ++ repeat 0))
| True = let (d, r) = splitAt 4 ds in hexDigit d ++ hex r
hexDigit d = showHex (foldl (\a b -> 2*a+b) 0 d) ""