-------------------------------------------------------------------------
-- |
-- Module      :  Data.Numbers.FloatingHex
-- Copyright   :  (c) Levent Erkok
-- License     :  BSD3
-- Maintainer  :  erkokl@gmail.com
-- Stability   :  experimental
--
-- Reading/Writing hexadecimal floating-point numbers.
--
-- See: <http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf>, pages 57-58.
-- We slightly diverge from the standard and do not allow for the "floating-suffix,"
-- as the type inference of Haskell makes this unnecessary.
-----------------------------------------------------------------------------
module Data.Numbers.FloatingHex (
        -- ** QuasiQuoting
        hf
        -- ** Reading hex-floats
        , FloatingHexReader(..)
        -- ** Showing hex-floats
        , showHFloat
        ) where

import Data.Char  (toLower)
import Data.Ratio ((%))
import Numeric    (showHex)
import GHC.Float

import qualified Language.Haskell.TH.Syntax as TH
import           Language.Haskell.TH.Quote

-- | Due to intricacies of conversion between
-- @Float@ and @Double@ types (see <http://ghc.haskell.org/trac/ghc/ticket/3676>), we explicitly introduce
-- a class to do the reading properly.
class RealFloat a => FloatingHexReader a where
   -- | Convert a hex-float from a string, if possible.
   readHFloat :: String -> Maybe a

-- | The Float instance
instance FloatingHexReader Float where
   readHFloat :: String -> Maybe Float
readHFloat String
s = Double -> Float
double2Float (Double -> Float) -> Maybe Double -> Maybe Float
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe Double
readHFloatAsDouble String
s

-- | The Double instance
instance FloatingHexReader Double where
   readHFloat :: String -> Maybe Double
readHFloat = String -> Maybe Double
readHFloatAsDouble

-- | Read a float in hexadecimal binary format. Supports negative numbers, and nan/infinity as well.
-- For regular usage, the quasiquoter (`hf`) should be employed. But this function can be handy for
-- programmatic interfaces.
readHFloatAsDouble :: String -> Maybe Double
readHFloatAsDouble :: String -> Maybe Double
readHFloatAsDouble = String -> Maybe Double
cvt
  where cvt :: String -> Maybe Double
cvt (Char
'-' : String
cs) = ((-Double
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Double) -> Maybe Double -> Maybe Double
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe Double
go String
cs
        cvt String
cs         = String -> Maybe Double
go String
cs

        go :: String -> Maybe Double
go String
"NaN"      = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Double
0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0
        go String
"Infinity" = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0
        go String
cs         = String -> Maybe Double
parseHexFloat String
cs

-- | Turn a hexadecimal float to an internal double, if parseable. Does not support the leading
-- '-' bit, although it does allow a leading +. (The former is best done out of the quasiquote,
-- since TH does not cannot represent negative 0! See <https://ghc.haskell.org/trac/ghc/ticket/13124>
-- for why we avoid this here.)
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 (Char
'+':String
rest) = String -> Maybe Double
go0 String
rest
        goS String
cs         = String -> Maybe Double
go0 String
cs

        go0 :: String -> Maybe Double
go0 (Char
'0':Char
'x':String
rest) = String -> Maybe Double
go1 String
rest
        go0 String
_              = Maybe Double
forall a. Maybe a
Nothing

        go1 :: String -> Maybe Double
go1 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
== Char
'p') String
cs of
                   (String
pre, Char
'p':Char
'+':String
d) -> String -> String -> Maybe Double
go2 String
pre String
d
                   (String
pre, Char
'p':    String
d) -> String -> String -> Maybe Double
go2 String
pre String
d
                   (String, String)
_                -> Maybe Double
forall a. Maybe a
Nothing

        go2 :: String -> String -> Maybe Double
go2 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
== Char
'.') String
cs of
                   (String
pre, Char
'.':String
post) -> String -> String -> String -> Maybe Double
construct String
pre String
post
                   (String, String)
_               -> String -> String -> String -> Maybe Double
construct String
cs  String
""

        rd :: Read a => String -> Maybe a
        rd :: forall a. Read a => String -> Maybe a
rd String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
                 [(a
x, String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                 [(a, String)]
_         -> Maybe a
forall a. Maybe a
Nothing

        construct :: String -> String -> String -> Maybe Double
construct String
pre String
post 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
$ String
"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 a. a -> Maybe a
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 a. [a] -> 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 Integer
a Int
b Integer
e
          | Integer
e Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
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   = Integer
16 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
b
                power :: Integer
power =  Integer
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

-- | A quasiquoter for hexadecimal floating-point literals.
-- See: <http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf>, pages 57-58.
-- We slightly diverge from the standard and do not allow for the "floating-suffix,"
-- as the type inference of Haskell makes this unnecessary.
--
-- Example:
--
--  > {-# LANGUAGE QuasiQuotes #-}
--  > import Data.Numbers.FloatingHex
--  >
--  > f :: Double
--  > f = [hf|0x1.f44abd5aa7ca4p+25|]
--
--  With these definitions, @f@ will be equal to the number @6.5574266708245546e7@
hf :: QuasiQuoter
hf :: QuasiQuoter
hf = 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 String
"Unexpected hexadecimal float in a type context"
                 , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Unexpected hexadecimal float in a declaration context"
                 }
   where q :: String -> TH.Q TH.Exp
         q :: String -> Q Exp
q String
s = case String -> Maybe Double
parseHexFloat String
s of
                  Just Double
d  -> Double -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Double -> m Exp
TH.lift Double
d
                  Maybe Double
Nothing -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Invalid hexadecimal floating point number: |" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"|"

         p :: String -> TH.Q TH.Pat
         p :: String -> Q Pat
p String
s = case String -> Maybe Double
parseHexFloat String
s of
                  Just Double
d  -> Pat -> Q Pat
forall a. a -> Q a
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)))
                  Maybe Double
Nothing -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String
"Invalid hexadecimal floating point number: |" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"|"

-- | Show a floating-point value in the hexadecimal format, similar to the @%a@ specifier in C's printf.
--
-- >>> showHFloat (212.21 :: Double) ""
-- "0x1.a86b851eb851fp7"
-- >>> showHFloat (-12.76 :: Float) ""
-- "-0x1.9851ecp3"
-- >>> showHFloat (-0 :: Double) ""
-- "-0x0p+0"
showHFloat :: RealFloat a => a -> ShowS
showHFloat :: forall a. RealFloat a => 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 a
x | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x                   = String
"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
< a
0 then String
"-" else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Infinity"
              | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x = Char
'-' 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 a
x
          | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = String
"0x0p+0"
          | Bool
True   = case Integer -> a -> ([Int], Int)
forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits Integer
2 a
x of
                       r :: ([Int], Int)
r@([], Int
_) -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Impossible happened: showHFloat: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Int], Int) -> String
forall a. Show a => a -> String
show ([Int], Int)
r
                       (Int
d:[Int]
ds, Int
e) -> String
"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 => [a] -> String
frac [Int]
ds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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
-Int
1)

        -- Given binary digits, convert them to hex in blocks of 4
        -- Special case: If all 0's, just drop it.
        frac :: [a] -> String
frac [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
== a
0) [a]
digits = String
""
          | Bool
True              = String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall {a}. Integral a => [a] -> String
hex [a]
digits
          where hex :: [a] -> String
hex [a]
ds
                  | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ds       = String
""
                  | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 = [a] -> String
hex (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
4 ([a]
ds [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a]
forall a. a -> [a]
repeat a
0))
                  | Bool
True          = let ([a]
d, [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
4 [a]
ds in [a] -> String
forall {a} {t :: * -> *}. (Integral 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 t a
d        = a -> String -> String
forall a. Integral a => a -> String -> String
showHex ((a -> a -> a) -> a -> t a -> a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a
a a
b -> a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
aa -> a -> a
forall a. Num a => a -> a -> a
+a
b) a
0 t a
d) String
""