module Data.Numbers.FloatingHex (
hf
, FloatingHexReader(..)
, 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 :: String -> Maybe Float
readHFloat s :: String
s = Double -> Float
double2Float (Double -> Float) -> Maybe Double -> Maybe Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe Double
readHFloatAsDouble String
s
instance FloatingHexReader Double where
readHFloat :: String -> Maybe Double
readHFloat = String -> Maybe Double
readHFloatAsDouble
readHFloatAsDouble :: String -> Maybe Double
readHFloatAsDouble :: String -> Maybe Double
readHFloatAsDouble = String -> Maybe Double
cvt
where cvt :: String -> Maybe Double
cvt ('-' : cs :: String
cs) = ((-1) Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Double) -> Maybe Double -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe Double
go String
cs
cvt cs :: String
cs = String -> Maybe Double
go String
cs
go :: String -> Maybe Double
go "NaN" = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ 0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0
go "Infinity" = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ 1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0
go cs :: String
cs = String -> Maybe Double
parseHexFloat String
cs
parseHexFloat :: String -> Maybe Double
parseHexFloat :: String -> Maybe Double
parseHexFloat = String -> Maybe Double
goS (String -> Maybe Double)
-> (String -> String) -> String -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
where goS :: String -> Maybe Double
goS ('+':rest :: String
rest) = String -> Maybe Double
go0 String
rest
goS cs :: String
cs = String -> Maybe Double
go0 String
cs
go0 :: String -> Maybe Double
go0 ('0':'x':rest :: String
rest) = String -> Maybe Double
go1 String
rest
go0 _ = Maybe Double
forall a. Maybe a
Nothing
go1 :: String -> Maybe Double
go1 cs :: String
cs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'p') String
cs of
(pre :: String
pre, 'p':'+':d :: String
d) -> String -> String -> Maybe Double
go2 String
pre String
d
(pre :: String
pre, 'p': d :: String
d) -> String -> String -> Maybe Double
go2 String
pre String
d
_ -> Maybe Double
forall a. Maybe a
Nothing
go2 :: String -> String -> Maybe Double
go2 cs :: String
cs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') String
cs of
(pre :: String
pre, '.':post :: String
post) -> String -> String -> String -> Maybe Double
construct String
pre String
post
_ -> String -> String -> String -> Maybe Double
construct String
cs ""
rd :: Read a => String -> Maybe a
rd :: String -> Maybe a
rd s :: String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
[(x :: a
x, "")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
_ -> Maybe a
forall a. Maybe a
Nothing
construct :: String -> String -> String -> Maybe Double
construct pre :: String
pre post :: String
post d :: String
d = do Integer
a <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
rd (String -> Maybe Integer) -> String -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ "0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
post
Integer
e <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
rd String
d
Double -> Maybe Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Integer -> Double
val Integer
a (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
post) Integer
e
val :: Integer -> Int -> Integer -> Double
val :: Integer -> Int -> Integer -> Double
val a :: Integer
a b :: Int
b e :: Integer
e
| Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ (Integer
top Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
power) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
bot
| Bool
True = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Integer
top Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Integer
power Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
bot)
where top, bot, power :: Integer
top :: Integer
top = Integer
a
bot :: Integer
bot = 16 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
b
power :: Integer
power = 2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer -> Integer
forall a. Num a => a -> a
abs Integer
e
hf :: QuasiQuoter
hf :: QuasiQuoter
hf = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
q
, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
p
, quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error "Unexpected hexadecimal float in a type context"
, quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error "Unexpected hexadecimal float in a declaration context"
}
where q :: String -> TH.Q TH.Exp
q :: String -> Q Exp
q s :: String
s = case String -> Maybe Double
parseHexFloat String
s of
Just d :: Double
d -> Double -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift Double
d
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Invalid hexadecimal floating point number: |" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "|"
p :: String -> TH.Q TH.Pat
p :: String -> Q Pat
p s :: String
s = case String -> Maybe Double
parseHexFloat String
s of
Just d :: Double
d -> Pat -> Q Pat
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
TH.LitP (Rational -> Lit
TH.RationalL (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d)))
Nothing -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ "Invalid hexadecimal floating point number: |" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "|"
showHFloat :: RealFloat a => a -> ShowS
showHFloat :: a -> String -> String
showHFloat = String -> String -> String
showString (String -> String -> String)
-> (a -> String) -> a -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. RealFloat a => a -> String
fmt
where fmt :: a -> String
fmt x :: a
x | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x = "NaN"
| a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x = (if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then "-" else "") String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Infinity"
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x = '-' Char -> String -> String
forall a. a -> [a] -> [a]
: a -> String
forall a. RealFloat a => a -> String
cvt (-a
x)
| Bool
True = a -> String
forall a. RealFloat a => a -> String
cvt a
x
cvt :: a -> String
cvt x :: a
x
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = "0x0p+0"
| Bool
True = case Integer -> a -> ([Int], Int)
forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits 2 a
x of
r :: ([Int], Int)
r@([], _) -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Impossible happened: showHFloat: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Int], Int) -> String
forall a. Show a => a -> String
show ([Int], Int)
r
(d :: Int
d:ds :: [Int]
ds, e :: Int
e) -> "0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. (Integral a, Show a) => [a] -> String
frac [Int]
ds String -> String -> String
forall a. [a] -> [a] -> [a]
++ "p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
frac :: [a] -> String
frac digits :: [a]
digits
| (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0) [a]
digits = ""
| Bool
True = "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. (Integral a, Show a) => [a] -> String
hex [a]
digits
where hex :: [a] -> String
hex ds :: [a]
ds
| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ds = ""
| [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4 = [a] -> String
hex (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take 4 ([a]
ds [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a]
forall a. a -> [a]
repeat 0))
| Bool
True = let (d :: [a]
d, r :: [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt 4 [a]
ds in [a] -> String
forall a (t :: * -> *).
(Integral a, Show a, Foldable t) =>
t a -> String
hexDigit [a]
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
hex [a]
r
hexDigit :: t a -> String
hexDigit d :: t a
d = a -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex ((a -> a -> a) -> a -> t a -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a :: a
a b :: a
b -> 2a -> a -> a
forall a. Num a => a -> a -> a
*a
aa -> a -> a
forall a. Num a => a -> a -> a
+a
b) 0 t a
d) ""