-----------------------------------------------------------------------------
-- |
-- Module    : Data.SBV.Utils.CrackNum
-- Copyright : (c) Levent Erkok
-- License   : BSD3
-- Maintainer: erkokl@gmail.com
-- Stability : experimental
--
-- Crack internal representation for numeric types
-----------------------------------------------------------------------------

{-# LANGUAGE NamedFieldPuns #-}

{-# OPTIONS_GHC -Wall -Werror #-}

module Data.SBV.Utils.CrackNum (
        crackNum
      ) where

import Data.SBV.Core.Concrete
import Data.SBV.Core.Kind
import Data.SBV.Core.SizedFloats
import Data.SBV.Utils.Numeric
import Data.SBV.Utils.PrettyNum (showFloatAtBase)

import Data.Char (intToDigit, toUpper, isSpace)

import Data.Bits
import Data.List

import LibBF hiding (Zero, bfToString)

import Numeric

-- | A class for cracking things deeper, if we know how.
class CrackNum a where
  crackNum :: a -> Maybe String

-- | CVs are easy to crack
instance CrackNum CV where
  crackNum :: CV -> Maybe String
crackNum CV
cv = case CV -> Kind
forall a. HasKind a => a -> Kind
kindOf CV
cv of
                  -- Maybe one day we'll have a use for these, currently cracking them
                  -- any further seems overkill
                  KBool      {}  -> Maybe String
forall a. Maybe a
Nothing
                  KUnbounded {}  -> Maybe String
forall a. Maybe a
Nothing
                  KReal      {}  -> Maybe String
forall a. Maybe a
Nothing
                  KUserSort  {}  -> Maybe String
forall a. Maybe a
Nothing
                  KChar      {}  -> Maybe String
forall a. Maybe a
Nothing
                  KString    {}  -> Maybe String
forall a. Maybe a
Nothing
                  KList      {}  -> Maybe String
forall a. Maybe a
Nothing
                  KSet       {}  -> Maybe String
forall a. Maybe a
Nothing
                  KTuple     {}  -> Maybe String
forall a. Maybe a
Nothing
                  KMaybe     {}  -> Maybe String
forall a. Maybe a
Nothing
                  KEither    {}  -> Maybe String
forall a. Maybe a
Nothing
                  KRational  {}  -> Maybe String
forall a. Maybe a
Nothing

                  -- Actual crackables
                  KFloat{}       -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ let CFloat   Float
f = CV -> CVal
cvVal CV
cv in Float -> String
forall a. HasFloatData a => a -> String
float Float
f
                  KDouble{}      -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ let CDouble  Double
d = CV -> CVal
cvVal CV
cv in Double -> String
forall a. HasFloatData a => a -> String
float Double
d
                  KFP{}          -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ let CFP      FP
f = CV -> CVal
cvVal CV
cv in FP -> String
forall a. HasFloatData a => a -> String
float FP
f
                  KBounded Bool
sg Int
sz -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ let CInteger Integer
i = CV -> CVal
cvVal CV
cv in Bool -> Int -> Integer -> String
int   Bool
sg Int
sz Integer
i

-- How far off the screen we want displayed? Somewhat experimentally found.
tab :: String
tab :: String
tab = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
18 Char
' '

-- Make splits of 4, top one has the remainder
split4 :: Int -> [Int]
split4 :: Int -> [Int]
split4 Int
n
  | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =     [Int]
rest
  | Bool
True   = Int
m Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
rest
  where (Int
d, Int
m) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
4
        rest :: [Int]
rest   = Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
d Int
4

-- Convert bits to the corresponding integer.
getVal :: [Bool] -> Integer
getVal :: [Bool] -> Integer
getVal = (Integer -> Bool -> Integer) -> Integer -> [Bool] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Integer
s Bool
b -> Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ if Bool
b then Integer
1 else Integer
0) Integer
0

-- Show in hex, but pay attention to how wide a field it should be in
mkHex :: [Bool] -> String
mkHex :: [Bool] -> String
mkHex [Bool]
bin = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex ([Bool] -> Integer
getVal [Bool]
bin) String
""

-- | Show a sized word/int in detail
int :: Bool -> Int -> Integer -> String
int :: Bool -> Int -> Integer -> String
int Bool
signed Int
sz Integer
v = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ruler [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
info
  where splits :: [Int]
splits = Int -> [Int]
split4 Int
sz

        ruler :: [String]
ruler = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
tab String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [String]
mkRuler Int
sz [Int]
splits

        bitRep :: [[Bool]]
        bitRep :: [[Bool]]
bitRep = [Int] -> [Bool] -> [[Bool]]
forall a. [Int] -> [a] -> [[a]]
split [Int]
splits [Integer
v Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

        flatHex :: String
flatHex = ([Bool] -> String) -> [[Bool]] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Bool] -> String
mkHex [[Bool]]
bitRep
        iprec :: String
iprec
          | Bool
signed = String
"Signed "   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-bit 2's complement integer"
          | Bool
True   = String
"Unsigned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-bit word"

        signBit :: Bool
signBit = Integer
v Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` (Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        s :: String
s | Bool
signed Bool -> Bool -> Bool
&& Bool
signBit = String
"-"
          | Bool
True              = String
""

        av :: Integer
av = Integer -> Integer
forall a. Num a => a -> a
abs Integer
v

        info :: [String]
info = [ String
"   Binary layout: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [(Bool -> String) -> [Bool] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Bool
b -> if Bool
b then String
"1" else String
"0") [Bool]
is | [Bool]
is <- [[Bool]]
bitRep]
               , String
"      Hex layout: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ([Int] -> String -> [String]
forall a. [Int] -> [a] -> [[a]]
split (Int -> [Int]
split4 (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
flatHex)) String
flatHex)
               , String
"            Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
iprec
               ]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"            Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
signBit then String
"Negative" else String
"Positive" | Bool
signed]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"          Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"0b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> (Int -> Char) -> Integer -> String -> String
forall a.
(Integral a, Show a) =>
a -> (Int -> Char) -> a -> String -> String
showIntAtBase Integer
2 Int -> Char
intToDigit Integer
av String
""
               , String
"           Octal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"0o" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showOct Integer
av String
""
               , String
"         Decimal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
v
               , String
"             Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Integer
av String
""
               ]

-- | What kind of Float is this?
data FPKind = Zero       Bool  -- with sign
            | Infty      Bool  -- with sign
            | NaN
            | Subnormal
            | Normal
            deriving FPKind -> FPKind -> Bool
(FPKind -> FPKind -> Bool)
-> (FPKind -> FPKind -> Bool) -> Eq FPKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FPKind -> FPKind -> Bool
$c/= :: FPKind -> FPKind -> Bool
== :: FPKind -> FPKind -> Bool
$c== :: FPKind -> FPKind -> Bool
Eq

-- | Show instance for Kind, not for reading back!
instance Show FPKind where
  show :: FPKind -> String
show Zero{}    = String
"FP_ZERO"
  show Infty{}   = String
"FP_INFINITE"
  show FPKind
NaN       = String
"FP_NAN"
  show FPKind
Subnormal = String
"FP_SUBNORMAL"
  show FPKind
Normal    = String
"FP_NORMAL"

-- | Find out what kind this float is. We specifically ask
-- the caller to provide if the number is zero, neg-inf, and pos-inf. Why?
-- Because the FP type doesn't have those recognizers that also work with Float/Double.
getKind :: RealFloat a => a -> FPKind
getKind :: a -> FPKind
getKind a
fp
 | a
fp a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0           = Bool -> FPKind
Zero  (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
fp)
 | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
fp     = Bool -> FPKind
Infty (a
fp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0)
 | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
fp          = FPKind
NaN
 | a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
fp = FPKind
Subnormal
 | Bool
True              = FPKind
Normal

-- Show the value in different bases
showAtBases :: FPKind -> (String, String, String, String) -> Either String (String, String, String, String)
showAtBases :: FPKind
-> (String, String, String, String)
-> Either String (String, String, String, String)
showAtBases FPKind
k (String, String, String, String)
bvs = case FPKind
k of
                     Zero Bool
False  -> (String, String, String, String)
-> Either String (String, String, String, String)
forall a b. b -> Either a b
Right (String
"0b0.0",  String
"0o0.0",  String
"0.0",  String
"0x0")
                     Zero Bool
True   -> (String, String, String, String)
-> Either String (String, String, String, String)
forall a b. b -> Either a b
Right (String
"-0b0.0", String
"-0o0.0", String
"-0.0", String
"-0o0")
                     Infty Bool
False -> String -> Either String (String, String, String, String)
forall a b. a -> Either a b
Left  String
"Infinity"
                     Infty Bool
True  -> String -> Either String (String, String, String, String)
forall a b. a -> Either a b
Left  String
"-Infinity"
                     FPKind
NaN         -> String -> Either String (String, String, String, String)
forall a b. a -> Either a b
Left  String
"NaN"
                     FPKind
Subnormal   -> (String, String, String, String)
-> Either String (String, String, String, String)
forall a b. b -> Either a b
Right ((String, String, String, String)
-> (String, String, String, String)
dropSuffixes (String, String, String, String)
bvs)
                     FPKind
Normal      -> (String, String, String, String)
-> Either String (String, String, String, String)
forall a b. b -> Either a b
Right ((String, String, String, String)
-> (String, String, String, String)
dropSuffixes (String, String, String, String)
bvs)
  where dropSuffixes :: (String, String, String, String)
-> (String, String, String, String)
dropSuffixes (String
a, String
b, String
c, String
d) = (String -> String
bfRemoveRedundantExp String
a, String -> String
bfRemoveRedundantExp String
b, String -> String
bfRemoveRedundantExp String
c, String -> String
bfRemoveRedundantExp String
d)

-- | Float data for display purposes
data FloatData = FloatData { FloatData -> String
prec   :: String
                           , FloatData -> Int
eb     :: Int
                           , FloatData -> Int
sb     :: Int
                           , FloatData -> Integer
bits   :: Integer
                           , FloatData -> FPKind
fpKind :: FPKind
                           , FloatData -> Either String (String, String, String, String)
fpVals :: Either String (String, String, String, String)
                           }

-- | A simple means to organize different bits and pieces of float data
-- for display purposes
class HasFloatData a where
  getFloatData :: a -> FloatData

-- | Float instance
instance HasFloatData Float where
  getFloatData :: Float -> FloatData
getFloatData Float
f = FloatData :: String
-> Int
-> Int
-> Integer
-> FPKind
-> Either String (String, String, String, String)
-> FloatData
FloatData {
      prec :: String
prec   = String
"Single"
    , eb :: Int
eb     =  Int
8
    , sb :: Int
sb     = Int
24
    , bits :: Integer
bits   = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Word32
floatToWord Float
f)
    , fpKind :: FPKind
fpKind = FPKind
k
    , fpVals :: Either String (String, String, String, String)
fpVals = FPKind
-> (String, String, String, String)
-> Either String (String, String, String, String)
showAtBases FPKind
k (Int -> Float -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
2 Float
f String
"", Int -> Float -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
8 Float
f String
"", Float -> String
forall a. Show a => a -> String
show Float
f, Int -> Float -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
16 Float
f String
"")
    }
    where k :: FPKind
k = Float -> FPKind
forall a. RealFloat a => a -> FPKind
getKind Float
f

-- | Double instance
instance HasFloatData Double where
  getFloatData :: Double -> FloatData
getFloatData Double
d  = FloatData :: String
-> Int
-> Int
-> Integer
-> FPKind
-> Either String (String, String, String, String)
-> FloatData
FloatData {
      prec :: String
prec   = String
"Double"
    , eb :: Int
eb     = Int
11
    , sb :: Int
sb     = Int
53
    , bits :: Integer
bits   = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Word64
doubleToWord Double
d)
    , fpKind :: FPKind
fpKind = FPKind
k
    , fpVals :: Either String (String, String, String, String)
fpVals = FPKind
-> (String, String, String, String)
-> Either String (String, String, String, String)
showAtBases FPKind
k (Int -> Double -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
2 Double
d String
"", Int -> Double -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
8 Double
d String
"", Double -> String
forall a. Show a => a -> String
show Double
d, Int -> Double -> String -> String
forall a. (Show a, RealFloat a) => Int -> a -> String -> String
showFloatAtBase Int
16 Double
d String
"")
    }
    where k :: FPKind
k = Double -> FPKind
forall a. RealFloat a => a -> FPKind
getKind Double
d

-- | Find the exponent values, (exponent value, exponent as stored, bias)
getExponentData :: FloatData -> (Integer, Integer, Integer)
getExponentData :: FloatData -> (Integer, Integer, Integer)
getExponentData FloatData{Int
eb :: Int
eb :: FloatData -> Int
eb, Int
sb :: Int
sb :: FloatData -> Int
sb, Integer
bits :: Integer
bits :: FloatData -> Integer
bits, FPKind
fpKind :: FPKind
fpKind :: FloatData -> FPKind
fpKind} = (Integer
expValue, Integer
expStored, Integer
bias)
  where -- | Bias is 2^(eb-1) - 1
        bias :: Integer
        bias :: Integer
bias = (Integer
2 :: Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ ((Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
eb :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

        -- | Exponent as stored is simply bit extraction
        expStored :: Integer
expStored = [Bool] -> Integer
getVal [Integer
bits Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ebInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2]]

        -- | Exponent value is stored exponent - bias, unless the number is subnormal. In that case it is 1 - bias
        expValue :: Integer
expValue = case FPKind
fpKind of
                     FPKind
Subnormal -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bias
                     FPKind
_         -> Integer
expStored Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bias

-- | FP instance
instance HasFloatData FP where
  getFloatData :: FP -> FloatData
getFloatData v :: FP
v@(FP Int
eb Int
sb BigFloat
f) = FloatData :: String
-> Int
-> Int
-> Integer
-> FPKind
-> Either String (String, String, String, String)
-> FloatData
FloatData {
      prec :: String
prec   = case (Int
eb, Int
sb) of
                 ( Int
5,  Int
11) -> String
"Half (5 exponent bits, 10 significand bits.)"
                 ( Int
8,  Int
24) -> String
"Single (8 exponent bits, 23 significand bits.)"
                 (Int
11,  Int
53) -> String
"Double (11 exponent bits, 52 significand bits.)"
                 (Int
15, Int
113) -> String
"Quad (15 exponent bits, 112 significand bits.)"
                 ( Int
_,   Int
_) -> Int -> String
forall a. Show a => a -> String
show Int
eb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exponent bits, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" significand bit" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Int
sb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 then String
"s" else String
""
    , eb :: Int
eb     = Int
eb
    , sb :: Int
sb     = Int
sb
    , bits :: Integer
bits   = BFOpts -> BigFloat -> Integer
bfToBits (Int -> Int -> RoundMode -> BFOpts
forall a. Integral a => a -> a -> RoundMode -> BFOpts
mkBFOpts Int
eb Int
sb RoundMode
NearEven) BigFloat
f
    , fpKind :: FPKind
fpKind = FPKind
k
    , fpVals :: Either String (String, String, String, String)
fpVals = FPKind
-> (String, String, String, String)
-> Either String (String, String, String, String)
showAtBases FPKind
k (Int -> Bool -> Bool -> FP -> String
bfToString Int
2 Bool
True Bool
True FP
v, Int -> Bool -> Bool -> FP -> String
bfToString Int
8 Bool
True Bool
True FP
v, Int -> Bool -> Bool -> FP -> String
bfToString Int
10 Bool
True Bool
False FP
v, Int -> Bool -> Bool -> FP -> String
bfToString Int
16 Bool
True Bool
True FP
v)
    }
    where opts :: BFOpts
opts = Int -> Int -> RoundMode -> BFOpts
forall a. Integral a => a -> a -> RoundMode -> BFOpts
mkBFOpts Int
eb Int
sb RoundMode
NearEven
          k :: FPKind
k | BigFloat -> Bool
bfIsZero BigFloat
f           = Bool -> FPKind
Zero  (BigFloat -> Bool
bfIsNeg BigFloat
f)
            | BigFloat -> Bool
bfIsInf BigFloat
f            = Bool -> FPKind
Infty (BigFloat -> Bool
bfIsNeg BigFloat
f)
            | BigFloat -> Bool
bfIsNaN BigFloat
f            = FPKind
NaN
            | BFOpts -> BigFloat -> Bool
bfIsSubnormal BFOpts
opts BigFloat
f = FPKind
Subnormal
            | Bool
True                 = FPKind
Normal

-- | Show a float in detail
float :: HasFloatData a => a -> String
float :: a -> String
float a
f = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ruler [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
legend String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
info
   where fd :: FloatData
fd@FloatData{String
prec :: String
prec :: FloatData -> String
prec, Int
eb :: Int
eb :: FloatData -> Int
eb, Int
sb :: Int
sb :: FloatData -> Int
sb, Integer
bits :: Integer
bits :: FloatData -> Integer
bits, FPKind
fpKind :: FPKind
fpKind :: FloatData -> FPKind
fpKind, Either String (String, String, String, String)
fpVals :: Either String (String, String, String, String)
fpVals :: FloatData -> Either String (String, String, String, String)
fpVals} = a -> FloatData
forall a. HasFloatData a => a -> FloatData
getFloatData a
f

         splits :: [Int]
splits = [Int
1, Int
eb, Int
sb]
         ruler :: [String]
ruler  = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
tab String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [String]
mkRuler (Int
eb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sb) [Int]
splits

         legend :: String
legend = String
tab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"S " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Int -> String
mkTag (Char
'E' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
eb) Int
eb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Int -> String
mkTag (Char
'S' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) (Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

         mkTag :: String -> Int -> String
mkTag String
t Int
len = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
len (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate ((Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Char
'-' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
'-'

         allBits :: [Bool]
         allBits :: [Bool]
allBits = [Integer
bits Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Int
eb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

         flatHex :: String
flatHex = ([Bool] -> String) -> [[Bool]] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Bool] -> String
mkHex ([Int] -> [Bool] -> [[Bool]]
forall a. [Int] -> [a] -> [[a]]
split (Int -> [Int]
split4 (Int
eb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sb)) [Bool]
allBits)
         sign :: Bool
sign    = Integer
bits Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` (Int
ebInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

         (Integer
exponentVal, Integer
storedExponent, Integer
bias) = FloatData -> (Integer, Integer, Integer)
getExponentData FloatData
fd

         esInfo :: String
esInfo = String
"Stored: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
storedExponent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", Bias: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
bias

         isSubNormal :: Bool
isSubNormal = case FPKind
fpKind of
                         FPKind
Subnormal -> Bool
True
                         FPKind
_         -> Bool
False

         info :: [String]
info =   [ String
"   Binary layout: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [(Bool -> String) -> [Bool] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Bool
b -> if Bool
b then String
"1" else String
"0") [Bool]
is | [Bool]
is <- [Int] -> [Bool] -> [[Bool]]
forall a. [Int] -> [a] -> [[a]]
split [Int]
splits [Bool]
allBits]
                  , String
"      Hex layout: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ([Int] -> String -> [String]
forall a. [Int] -> [a] -> [[a]]
split (Int -> [Int]
split4 (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
flatHex)) String
flatHex)
                  , String
"       Precision: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prec
                  , String
"            Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
sign then String
"Negative" else String
"Positive"
                  ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"        Exponent: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
exponentVal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (Subnormal, with fixed exponent value. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
esInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" | Bool
isSubNormal    ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"        Exponent: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
exponentVal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("                                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
esInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" | Bool -> Bool
not Bool
isSubNormal]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"  Classification: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FPKind -> String
forall a. Show a => a -> String
show FPKind
fpKind]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (case Either String (String, String, String, String)
fpVals of
                     Left String
val                       -> [ String
"           Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val]
                     Right (String
bval, String
oval, String
dval, String
hval) -> [ String
"          Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bval
                                                       , String
"           Octal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
oval
                                                       , String
"         Decimal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dval
                                                       , String
"             Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hval
                                                       ])
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"            Note: Representation for NaN's is not unique" | FPKind
fpKind FPKind -> FPKind -> Bool
forall a. Eq a => a -> a -> Bool
== FPKind
NaN]


-- | Build a ruler with given split points
mkRuler :: Int -> [Int] -> [String]
mkRuler :: Int -> [Int] -> [String]
mkRuler Int
n [Int]
splits = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
trimRight (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> String -> [String]
forall a. [Int] -> [a] -> [[a]]
split [Int]
splits (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> String -> String
trim Maybe Char
forall a. Maybe a
Nothing) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [[a]] -> [[a]]
transpose ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
pad ([Int] -> [String]) -> [Int] -> [String]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  where len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
        pad :: a -> String
pad a
i = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
len (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (a -> String
forall a. Show a => a -> String
show a
i) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
'0'

        trim :: Maybe Char -> String -> String
trim Maybe Char
_      String
"" = String
""
        trim Maybe Char
mbPrev (Char
c:String
cs)
          | Maybe Char
mbPrev Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Maybe Char -> String -> String
trim Maybe Char
mbPrev   String
cs
          | Bool
True             =  Char
c  Char -> String -> String
forall a. a -> [a] -> [a]
: Maybe Char -> String -> String
trim (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c) String
cs

        trimRight :: String -> String
trimRight = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse

split :: [Int] -> [a] -> [[a]]
split :: [Int] -> [a] -> [[a]]
split [Int]
_      [] = []
split []     [a]
xs = [[a]
xs]
split (Int
i:[Int]
is) [a]
xs = case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs of
                   ([a]
pre, [])   -> [[a]
pre]
                   ([a]
pre, [a]
post) -> [a]
pre [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
forall a. [Int] -> [a] -> [[a]]
split [Int]
is [a]
post