    -------------------------------------------------------------------------
    -- |
    -- 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 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
                                      e <- rd d
                                      return $ val a (length post) 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
    ""