{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module GHC.Types.Literal.Floating
  ( LitFloating
  , LitFloatingType(..)
  , ConstantFoldingPrecision(..)

  , floatToLitFloating, doubleToLitFloating, rationalToLitFloating
  , unsafeLitFloatingToRational, litFloatingToHostFloat, litFloatingToHostDouble
  , pprLitFloating

  -- ** Arithmetic on floating-point literals
  , litRationalToFloatOp
  , litFloatingUnaryOp, litFloatingBinaryOp, litFloatingTernaryOp
  , litFloatingComparisonOp
  , truncateLitFloating, decodeLitFloating
  , encodeLitFloat, encodeLitDouble

  , isZeroLF, isPositiveZeroLF, isPositiveLF, isOneLF, isFiniteLF
  , isPositiveZero, litFloatingIsNonStandardNaN
  ) where

import GHC.Prelude

import GHC.Platform
import GHC.Utils.Binary
import GHC.Utils.Panic
import GHC.Utils.Outputable

import Control.DeepSeq ( NFData(..) )
import Data.Data ( Data )
import Data.Function
import GHC.Exts ( dataToTag#, isTrue#, (<#) )
import GHC.Float
import Numeric ( showHex )

-- For now, this assumes that Float/Double arithmetic on the target
-- machine is the same as that on the host machine. And that's OK.

-- | Represents a known @Float#@ or @Double#@ literal on the target machine.
data LitFloating
  = LitFloatingF !Float
  | LitFloatingD !Double
  | LitFloatingR !Rational
  deriving (Typeable LitFloating
Typeable LitFloating =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> LitFloating -> c LitFloating)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c LitFloating)
-> (LitFloating -> Constr)
-> (LitFloating -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c LitFloating))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c LitFloating))
-> ((forall b. Data b => b -> b) -> LitFloating -> LitFloating)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> LitFloating -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> LitFloating -> r)
-> (forall u. (forall d. Data d => d -> u) -> LitFloating -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> LitFloating -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> LitFloating -> m LitFloating)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LitFloating -> m LitFloating)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LitFloating -> m LitFloating)
-> Data LitFloating
LitFloating -> Constr
LitFloating -> DataType
(forall b. Data b => b -> b) -> LitFloating -> LitFloating
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> LitFloating -> u
forall u. (forall d. Data d => d -> u) -> LitFloating -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloating
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloating -> c LitFloating
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloating)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloating)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloating -> c LitFloating
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloating -> c LitFloating
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloating
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloating
$ctoConstr :: LitFloating -> Constr
toConstr :: LitFloating -> Constr
$cdataTypeOf :: LitFloating -> DataType
dataTypeOf :: LitFloating -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloating)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloating)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloating)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloating)
$cgmapT :: (forall b. Data b => b -> b) -> LitFloating -> LitFloating
gmapT :: (forall b. Data b => b -> b) -> LitFloating -> LitFloating
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloating -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LitFloating -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> LitFloating -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> LitFloating -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> LitFloating -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LitFloating -> m LitFloating
Data, Int -> LitFloating -> ShowS
[LitFloating] -> ShowS
LitFloating -> String
(Int -> LitFloating -> ShowS)
-> (LitFloating -> String)
-> ([LitFloating] -> ShowS)
-> Show LitFloating
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LitFloating -> ShowS
showsPrec :: Int -> LitFloating -> ShowS
$cshow :: LitFloating -> String
show :: LitFloating -> String
$cshowList :: [LitFloating] -> ShowS
showList :: [LitFloating] -> ShowS
Show)

instance NFData LitFloating where
  rnf :: LitFloating -> ()
rnf = \case
    LitFloatingF Float
f -> Float -> ()
forall a. NFData a => a -> ()
rnf Float
f
    LitFloatingD Double
d -> Double -> ()
forall a. NFData a => a -> ()
rnf Double
d
    LitFloatingR Rational
r -> Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r

data LitFloatingType = LitFloat | LitDouble
  deriving stock (Typeable LitFloatingType
Typeable LitFloatingType =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> LitFloatingType -> c LitFloatingType)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c LitFloatingType)
-> (LitFloatingType -> Constr)
-> (LitFloatingType -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c LitFloatingType))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c LitFloatingType))
-> ((forall b. Data b => b -> b)
    -> LitFloatingType -> LitFloatingType)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> LitFloatingType -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> LitFloatingType -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> LitFloatingType -> m LitFloatingType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> LitFloatingType -> m LitFloatingType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> LitFloatingType -> m LitFloatingType)
-> Data LitFloatingType
LitFloatingType -> Constr
LitFloatingType -> DataType
(forall b. Data b => b -> b) -> LitFloatingType -> LitFloatingType
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> LitFloatingType -> u
forall u. (forall d. Data d => d -> u) -> LitFloatingType -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloatingType
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloatingType -> c LitFloatingType
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloatingType)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloatingType)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloatingType -> c LitFloatingType
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LitFloatingType -> c LitFloatingType
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloatingType
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LitFloatingType
$ctoConstr :: LitFloatingType -> Constr
toConstr :: LitFloatingType -> Constr
$cdataTypeOf :: LitFloatingType -> DataType
dataTypeOf :: LitFloatingType -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloatingType)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LitFloatingType)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloatingType)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LitFloatingType)
$cgmapT :: (forall b. Data b => b -> b) -> LitFloatingType -> LitFloatingType
gmapT :: (forall b. Data b => b -> b) -> LitFloatingType -> LitFloatingType
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LitFloatingType -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LitFloatingType -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> LitFloatingType -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LitFloatingType -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LitFloatingType -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LitFloatingType -> m LitFloatingType
Data, LitFloatingType -> LitFloatingType -> Bool
(LitFloatingType -> LitFloatingType -> Bool)
-> (LitFloatingType -> LitFloatingType -> Bool)
-> Eq LitFloatingType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LitFloatingType -> LitFloatingType -> Bool
== :: LitFloatingType -> LitFloatingType -> Bool
$c/= :: LitFloatingType -> LitFloatingType -> Bool
/= :: LitFloatingType -> LitFloatingType -> Bool
Eq, Eq LitFloatingType
Eq LitFloatingType =>
(LitFloatingType -> LitFloatingType -> Ordering)
-> (LitFloatingType -> LitFloatingType -> Bool)
-> (LitFloatingType -> LitFloatingType -> Bool)
-> (LitFloatingType -> LitFloatingType -> Bool)
-> (LitFloatingType -> LitFloatingType -> Bool)
-> (LitFloatingType -> LitFloatingType -> LitFloatingType)
-> (LitFloatingType -> LitFloatingType -> LitFloatingType)
-> Ord LitFloatingType
LitFloatingType -> LitFloatingType -> Bool
LitFloatingType -> LitFloatingType -> Ordering
LitFloatingType -> LitFloatingType -> LitFloatingType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LitFloatingType -> LitFloatingType -> Ordering
compare :: LitFloatingType -> LitFloatingType -> Ordering
$c< :: LitFloatingType -> LitFloatingType -> Bool
< :: LitFloatingType -> LitFloatingType -> Bool
$c<= :: LitFloatingType -> LitFloatingType -> Bool
<= :: LitFloatingType -> LitFloatingType -> Bool
$c> :: LitFloatingType -> LitFloatingType -> Bool
> :: LitFloatingType -> LitFloatingType -> Bool
$c>= :: LitFloatingType -> LitFloatingType -> Bool
>= :: LitFloatingType -> LitFloatingType -> Bool
$cmax :: LitFloatingType -> LitFloatingType -> LitFloatingType
max :: LitFloatingType -> LitFloatingType -> LitFloatingType
$cmin :: LitFloatingType -> LitFloatingType -> LitFloatingType
min :: LitFloatingType -> LitFloatingType -> LitFloatingType
Ord, Int -> LitFloatingType -> ShowS
[LitFloatingType] -> ShowS
LitFloatingType -> String
(Int -> LitFloatingType -> ShowS)
-> (LitFloatingType -> String)
-> ([LitFloatingType] -> ShowS)
-> Show LitFloatingType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LitFloatingType -> ShowS
showsPrec :: Int -> LitFloatingType -> ShowS
$cshow :: LitFloatingType -> String
show :: LitFloatingType -> String
$cshowList :: [LitFloatingType] -> ShowS
showList :: [LitFloatingType] -> ShowS
Show)

instance NFData LitFloatingType where
  rnf :: LitFloatingType -> ()
rnf !LitFloatingType
_ = ()

data ConstantFoldingPrecision
  = FloatPrecision
  | DoublePrecision
  | ExcessPrecision

litFloatingIsNonStandardNaN :: LitFloatingType -> LitFloating -> Bool
litFloatingIsNonStandardNaN :: LitFloatingType -> LitFloating -> Bool
litFloatingIsNonStandardNaN LitFloatingType
ty LitFloating
lit =
  case LitFloatingType
ty of
    LitFloatingType
LitFloat -> Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f Bool -> Bool -> Bool
&& Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x7FC00000
      where f :: Float
f = LitFloating -> Float
litFloatingToHostFloat LitFloating
lit
            w :: Word32
w = Float -> Word32
castFloatToWord32 Float
f
    LitFloatingType
LitDouble -> Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f Bool -> Bool -> Bool
&& Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0x7FF8000000000000
      where f :: Double
f = LitFloating -> Double
litFloatingToHostDouble LitFloating
lit
            w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
f

pprLitFloating :: LitFloatingType -> LitFloating -> SDoc
pprLitFloating :: LitFloatingType -> LitFloating -> SDoc
pprLitFloating LitFloatingType
ty LitFloating
lit = (Bool -> SDoc) -> SDoc
forall doc. IsOutput doc => (Bool -> doc) -> doc
getPprDebug ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \ Bool
dbg -> (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \ PprStyle
sty ->
  case LitFloatingType
ty of
    LitFloatingType
LitFloat ->
      if
        | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f
        , Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x7FC00000 -- not equal to the standard NaN
        -> case PprStyle
sty of

            -- For assembly data sections, print the corresponding unsigned integer literal.
            PprCode {}
              -> Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
w

            -- For the user (and without -debug-ppr), just print "NaN" regardless of sign/payload.
            PprUser {}
              | Bool -> Bool
not Bool
dbg
              -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NaN"

            -- For debugging, print the NaN including its sign and payload.
            PprStyle
_ -> Bool -> Bool -> Word32 -> SDoc
forall a. (Integral a, Show a) => Bool -> Bool -> a -> SDoc
format_non_standard_NaN (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
31) (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
22) (Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x3FFFFF)
        | Bool
otherwise
        -> Float -> SDoc
forall a. Outputable a => a -> SDoc
ppr Float
f
        where
          f :: Float
f = LitFloating -> Float
litFloatingToHostFloat LitFloating
lit
          w :: Word32
w = Float -> Word32
castFloatToWord32 Float
f
    LitFloatingType
LitDouble ->
      if
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f
        , Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0x7FF8000000000000 -- not equal to the standard NaN
        -> case PprStyle
sty of
            PprCode {}
              -> Word64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word64
w
            PprUser {}
              | Bool -> Bool
not Bool
dbg
              -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NaN"
            PprStyle
_ -> Bool -> Bool -> Word64 -> SDoc
forall a. (Integral a, Show a) => Bool -> Bool -> a -> SDoc
format_non_standard_NaN (Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w Int
63) (Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w Int
51) (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7FFFFFFFFFFFF)
        | Bool
otherwise
        -> Double -> SDoc
forall a. Outputable a => a -> SDoc
ppr Double
f
        where
          f :: Double
f = LitFloating -> Double
litFloatingToHostDouble LitFloating
lit
          w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
f

format_non_standard_NaN :: (Integral a, Show a) => Bool -> Bool -> a -> SDoc
format_non_standard_NaN :: forall a. (Integral a, Show a) => Bool -> Bool -> a -> SDoc
format_non_standard_NaN Bool
neg Bool
is_quiet a
payload =
  [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
    [ if Bool
neg then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" else SDoc
forall doc. IsOutput doc => doc
empty
    , if Bool
is_quiet then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"qNaN" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sNaN"
    , if a
payload a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
      then SDoc
forall doc. IsOutput doc => doc
empty
      else SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"0x" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
payload String
""))
    ]

instance Binary LitFloating where
  put_ :: WriteBinHandle -> LitFloating -> IO ()
put_ WriteBinHandle
bh (LitFloatingF Float
f) = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> Float -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Float
f
  put_ WriteBinHandle
bh (LitFloatingD Double
d) = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> Double -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Double
d
  put_ WriteBinHandle
bh (LitFloatingR Rational
r) = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> Rational -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Rational
r
  get :: ReadBinHandle -> IO LitFloating
get ReadBinHandle
bh = do
    h <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case  h  of
      Word8
0 -> Float -> LitFloating
Float -> LitFloating
LitFloatingF (Float -> LitFloating) -> IO Float -> IO LitFloating
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Float
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
1 -> Double -> LitFloating
Double -> LitFloating
LitFloatingD (Double -> LitFloating) -> IO Double -> IO LitFloating
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Double
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
2 -> Rational -> LitFloating
Rational -> LitFloating
LitFloatingR (Rational -> LitFloating) -> IO Rational -> IO LitFloating
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Rational
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> SDoc -> IO LitFloating
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary:LitFloating" (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h))

-- | This instance intentionally disagrees with the equality predicate
-- @(==)@ on @Float@ or @Double@ values: It is reflexive even on NaNs and
-- distinguishes between positive and negative zero.
-- Use 'litFloatingComparisonOp' if you need to match @Float@ or @Double@.
instance Eq LitFloating where
  LitFloating
v1 == :: LitFloating -> LitFloating -> Bool
== LitFloating
v2 = LitFloating
v1 LitFloating -> LitFloating -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` LitFloating
v2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- | The ordering represented by this instance is pretty arbitrary and
-- may change without notice.  Do not rely on its behavior!
instance Ord LitFloating where
  LitFloating
v1 compare :: LitFloating -> LitFloating -> Ordering
`compare` LitFloating
v2 = case  (LitFloating -> LitFloating
canonicalizeLF LitFloating
v1, LitFloating -> LitFloating
canonicalizeLF LitFloating
v2)  of
    (LitFloatingF Float
f1, LitFloatingF Float
f2)
      -> (Word32 -> Word32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word32 -> Word32 -> Ordering)
-> (Float -> Word32) -> Float -> Float -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Float -> Word32
castFloatToWord32 ) Float
f1 Float
f2
    (LitFloatingD Double
d1, LitFloatingD Double
d2)
      -> (Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Word64 -> Ordering)
-> (Double -> Word64) -> Double -> Double -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Double -> Word64
castDoubleToWord64) Double
d1 Double
d2
    (LitFloatingR Rational
r1, LitFloatingR Rational
r2) -> Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Rational
r1 Rational
r2
    (LitFloating
cv1, LitFloating
cv2) | Int# -> Bool
isTrue# (LitFloating -> Int#
forall a. DataToTag a => a -> Int#
dataToTag# LitFloating
cv1 Int# -> Int# -> Int#
<# LitFloating -> Int#
forall a. DataToTag a => a -> Int#
dataToTag# LitFloating
cv2) -> Ordering
LT
               | Bool
otherwise -> Ordering
GT

-- | Canonicalize a 'LitFloating' to allow comparison.
--
--  - NaNs remain as they are (whether 'Float' or 'Double')
--  - infinities and negative zero are represented as 'Double'
--  - finite values (including subnormals) are represented as 'Rational'
canonicalizeLF :: LitFloating -> LitFloating
-- allow different representations of the same value to compare equal
canonicalizeLF :: LitFloating -> LitFloating
canonicalizeLF LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f
    | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f -> LitFloating
v -- (double2Float . float2Double) destroys NaN payloads
    | Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
f Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Float
f -> Double -> LitFloating
LitFloatingD (Float -> Double
float2Double Float
f)
    | Bool
otherwise -> Rational -> LitFloating
LitFloatingR (Float -> Rational
forall a. Real a => a -> Rational
toRational Float
f)
  LitFloatingD Double
d
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
d -> LitFloating
v
    | Bool
otherwise -> Rational -> LitFloating
LitFloatingR (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d)
  LitFloatingR Rational
_ -> LitFloating
v

floatToLitFloating :: Float -> LitFloating
floatToLitFloating :: Float -> LitFloating
floatToLitFloating = Float -> LitFloating
Float -> LitFloating
LitFloatingF
doubleToLitFloating :: Double -> LitFloating
doubleToLitFloating :: Double -> LitFloating
doubleToLitFloating = Double -> LitFloating
Double -> LitFloating
LitFloatingD
rationalToLitFloating :: Rational -> LitFloating
rationalToLitFloating :: Rational -> LitFloating
rationalToLitFloating = Rational -> LitFloating
Rational -> LitFloating
LitFloatingR

litFloatingToHostFloat :: LitFloating -> Float
litFloatingToHostFloat :: LitFloating -> Float
litFloatingToHostFloat LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float
f
  LitFloatingD Double
d -> Double -> Float
double2Float Double
d
  LitFloatingR Rational
r -> Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r

litFloatingToHostDouble :: LitFloating -> Double
litFloatingToHostDouble :: LitFloating -> Double
litFloatingToHostDouble LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float -> Double
float2Double Float
f
  LitFloatingD Double
d -> Double
d
  LitFloatingR Rational
r -> Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r

-- | Attempts to convert a 'LitFloating' to a rational number.
--
-- Returns nonsense if its argument is a NaN or an infinity.
-- Equates @0.0@ with @-0.0@.
unsafeLitFloatingToRational :: LitFloating -> Rational
unsafeLitFloatingToRational :: LitFloating -> Rational
unsafeLitFloatingToRational LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float -> Rational
forall a. Real a => a -> Rational
toRational Float
f
  LitFloatingD Double
d -> Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d
  LitFloatingR Rational
r -> Rational
r

-- | Losslessly convert a 'LitFloating' to a 'Rational'.
--
-- Returns 'Nothing' precisely for 'NaN', infinities and negative zero.
litFloatingRational_maybe :: LitFloating -> Maybe Rational
litFloatingRational_maybe :: LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
v
  | LitFloating -> Bool
isFiniteLF LitFloating
v
  , Bool -> Bool
not (LitFloating -> Bool
isNegativeZeroLF LitFloating
v)
  = Rational -> Maybe Rational
Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Rational -> Maybe Rational) -> Rational -> Maybe Rational
forall a b. (a -> b) -> a -> b
$ LitFloating -> Rational
unsafeLitFloatingToRational LitFloating
v
  | Bool
otherwise
  = Maybe Rational
forall a. Maybe a
Nothing

isZeroLF :: LitFloating -> Bool
isZeroLF :: LitFloating -> Bool
isZeroLF LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0
  LitFloatingD Double
d -> Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
  LitFloatingR Rational
r -> Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0

isNegativeZeroLF :: LitFloating -> Bool
isNegativeZeroLF :: LitFloating -> Bool
isNegativeZeroLF LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Float
f
  LitFloatingD Double
d -> Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
d
  LitFloatingR Rational
_ -> Bool
False

isPositiveZero :: RealFloat a => a -> Bool
isPositiveZero :: forall a. RealFloat a => a -> Bool
isPositiveZero a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x)
{-# INLINEABLE isPositiveZero #-}

isPositiveZeroLF :: LitFloating -> Bool
isPositiveZeroLF :: LitFloating -> Bool
isPositiveZeroLF LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float -> Bool
forall a. RealFloat a => a -> Bool
isPositiveZero Float
f
  LitFloatingD Double
d -> Double -> Bool
forall a. RealFloat a => a -> Bool
isPositiveZero Double
d
  LitFloatingR Rational
r -> Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0

isOneLF :: LitFloating -> Bool
isOneLF :: LitFloating -> Bool
isOneLF LitFloating
v = case  LitFloating
v  of
  LitFloatingF Float
f -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
1
  LitFloatingD Double
d -> Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1
  LitFloatingR Rational
r -> Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
1

-- | Returns True if its argument represents a real number,
-- and False if its argument represents a NaN or an infinity.
isFiniteLF :: LitFloating -> Bool
isFiniteLF :: LitFloating -> Bool
isFiniteLF LitFloating
v = case LitFloating
v of
  LitFloatingF Float
f -> Bool -> Bool
not (Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
f Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f)
  LitFloatingD Double
d -> Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d)
  LitFloatingR Rational
_ -> Bool
True

-- | Is this a positive floating-point value?
--
-- Handles negative zero, infinities and signed NaNs.
isPositiveLF :: LitFloating -> Bool
isPositiveLF :: LitFloating -> Bool
isPositiveLF LitFloating
v =
  case LitFloating
v of
    LitFloatingF Float
f -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Float -> Word32
castFloatToWord32  Float
f) Int
31
    LitFloatingD Double
d -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Double -> Word64
castDoubleToWord64 Double
d) Int
63
    LitFloatingR Rational
q -> Rational
q Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0

-- Constant folding helpers for LitFloating

litRationalToFloatOp
  :: ConstantFoldingPrecision
  -> Rational -> LitFloating
litRationalToFloatOp :: ConstantFoldingPrecision -> Rational -> LitFloating
litRationalToFloatOp ConstantFoldingPrecision
prec Rational
rat = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision -> Rational -> LitFloating
LitFloatingR Rational
rat
  ConstantFoldingPrecision
FloatPrecision  -> Float -> LitFloating
LitFloatingF (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
rat)
  ConstantFoldingPrecision
DoublePrecision -> Double -> LitFloating
LitFloatingD (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
rat)

litFloatingUnaryOp
  :: ConstantFoldingPrecision
  -> (forall t. Fractional t => t -> t)
  -> LitFloating -> LitFloating
litFloatingUnaryOp :: ConstantFoldingPrecision
-> (forall t. Fractional t => t -> t) -> LitFloating -> LitFloating
litFloatingUnaryOp ConstantFoldingPrecision
prec forall t. Fractional t => t -> t
op LitFloating
lit = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision
    | Just Rational
r <- LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
lit -> Rational -> LitFloating
LitFloatingR (Rational -> Rational
forall t. Fractional t => t -> t
op Rational
r)
    | Bool
otherwise -> LitFloating
dres
  ConstantFoldingPrecision
FloatPrecision -> Float -> LitFloating
LitFloatingF (Float -> Float
forall t. Fractional t => t -> t
op (LitFloating -> Float
litFloatingToHostFloat  LitFloating
lit))
  ConstantFoldingPrecision
DoublePrecision -> LitFloating
dres
  where  dres :: LitFloating
dres = Double -> LitFloating
LitFloatingD (Double -> Double
forall t. Fractional t => t -> t
op (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit))

litFloatingBinaryOp
  :: ConstantFoldingPrecision
  -> (forall t. Fractional t => t -> t -> t)
  -> LitFloating -> LitFloating -> LitFloating
litFloatingBinaryOp :: ConstantFoldingPrecision
-> (forall t. Fractional t => t -> t -> t)
-> LitFloating
-> LitFloating
-> LitFloating
litFloatingBinaryOp ConstantFoldingPrecision
prec forall t. Fractional t => t -> t -> t
op LitFloating
lit1 LitFloating
lit2 = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision
    | Just Rational
res <- ((Rational -> Rational -> Rational)
-> Maybe Rational -> Maybe Rational -> Maybe Rational
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Rational -> Rational -> Rational
forall t. Fractional t => t -> t -> t
op (Maybe Rational -> Maybe Rational -> Maybe Rational)
-> (LitFloating -> Maybe Rational)
-> LitFloating
-> LitFloating
-> Maybe Rational
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Maybe Rational
litFloatingRational_maybe) LitFloating
lit1 LitFloating
lit2 -> Rational -> LitFloating
LitFloatingR Rational
res
    | Bool
otherwise -> LitFloating
dres
  ConstantFoldingPrecision
FloatPrecision
    -> Float -> LitFloating
LitFloatingF ((Float -> Float -> Float
forall t. Fractional t => t -> t -> t
op (Float -> Float -> Float)
-> (LitFloating -> Float) -> LitFloating -> LitFloating -> Float
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Float
litFloatingToHostFloat)  LitFloating
lit1 LitFloating
lit2)
  ConstantFoldingPrecision
DoublePrecision -> LitFloating
dres
  where  dres :: LitFloating
dres = Double -> LitFloating
LitFloatingD ((Double -> Double -> Double
forall t. Fractional t => t -> t -> t
op (Double -> Double -> Double)
-> (LitFloating -> Double) -> LitFloating -> LitFloating -> Double
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Double
litFloatingToHostDouble) LitFloating
lit1 LitFloating
lit2)

litFloatingTernaryOp
  :: ConstantFoldingPrecision
  -> (forall t. Fractional t => t -> t -> t -> t)
  -> LitFloating -> LitFloating -> LitFloating -> LitFloating
litFloatingTernaryOp :: ConstantFoldingPrecision
-> (forall t. Fractional t => t -> t -> t -> t)
-> LitFloating
-> LitFloating
-> LitFloating
-> LitFloating
litFloatingTernaryOp ConstantFoldingPrecision
prec forall t. Fractional t => t -> t -> t -> t
op LitFloating
lit1 LitFloating
lit2 LitFloating
lit3 = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision
    | Just Rational
l1' <- LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
lit1
    , Just Rational
l2' <- LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
lit2
    , Just Rational
l3' <- LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
lit3
    -> Rational -> LitFloating
LitFloatingR (Rational -> Rational -> Rational -> Rational
forall t. Fractional t => t -> t -> t -> t
op Rational
l1' Rational
l2' Rational
l3')
    | Bool
otherwise
    -> LitFloating
dres
  ConstantFoldingPrecision
FloatPrecision
    -> Float -> LitFloating
Float -> LitFloating
LitFloatingF (Float -> LitFloating) -> Float -> LitFloating
forall a b. (a -> b) -> a -> b
$
         Float -> Float -> Float -> Float
forall t. Fractional t => t -> t -> t -> t
op (LitFloating -> Float
litFloatingToHostFloat LitFloating
lit1)
            (LitFloating -> Float
litFloatingToHostFloat LitFloating
lit2)
            (LitFloating -> Float
litFloatingToHostFloat LitFloating
lit3)
  ConstantFoldingPrecision
DoublePrecision -> LitFloating
dres
  where
    dres :: LitFloating
dres =
      Double -> LitFloating
Double -> LitFloating
LitFloatingD (Double -> LitFloating) -> Double -> LitFloating
forall a b. (a -> b) -> a -> b
$
         Double -> Double -> Double -> Double
forall t. Fractional t => t -> t -> t -> t
op (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit1)
            (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit2)
            (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit3)

litFloatingComparisonOp
  :: ConstantFoldingPrecision -> (forall t. Ord t => t -> t -> res)
  -> LitFloating -> LitFloating -> res
litFloatingComparisonOp :: forall res.
ConstantFoldingPrecision
-> (forall t. Ord t => t -> t -> res)
-> LitFloating
-> LitFloating
-> res
litFloatingComparisonOp ConstantFoldingPrecision
prec forall t. Ord t => t -> t -> res
op LitFloating
lit1 LitFloating
lit2 = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision
    | Just res
res <- ((Rational -> Rational -> res)
-> Maybe Rational -> Maybe Rational -> Maybe res
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Rational -> Rational -> res
forall t. Ord t => t -> t -> res
op (Maybe Rational -> Maybe Rational -> Maybe res)
-> (LitFloating -> Maybe Rational)
-> LitFloating
-> LitFloating
-> Maybe res
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Maybe Rational
litFloatingRational_maybe) LitFloating
lit1 LitFloating
lit2 -> res
res
    | Bool
otherwise -> res
dres
  ConstantFoldingPrecision
FloatPrecision -> (Float -> Float -> res
forall t. Ord t => t -> t -> res
op (Float -> Float -> res)
-> (LitFloating -> Float) -> LitFloating -> LitFloating -> res
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Float
litFloatingToHostFloat)  LitFloating
lit1 LitFloating
lit2
  ConstantFoldingPrecision
DoublePrecision -> res
dres
  where  dres :: res
dres = (Double -> Double -> res
forall t. Ord t => t -> t -> res
op (Double -> Double -> res)
-> (LitFloating -> Double) -> LitFloating -> LitFloating -> res
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LitFloating -> Double
litFloatingToHostDouble) LitFloating
lit1 LitFloating
lit2

truncateLitFloating :: ConstantFoldingPrecision -> LitFloating -> Integer
truncateLitFloating :: ConstantFoldingPrecision -> LitFloating -> Integer
truncateLitFloating ConstantFoldingPrecision
prec LitFloating
lit = case  ConstantFoldingPrecision
prec  of
  ConstantFoldingPrecision
ExcessPrecision
    | Just Rational
r <- LitFloating -> Maybe Rational
litFloatingRational_maybe LitFloating
lit -> Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
r
    | Bool
otherwise -> Integer
dres
  ConstantFoldingPrecision
FloatPrecision  -> Float -> Integer
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (LitFloating -> Float
litFloatingToHostFloat  LitFloating
lit)
  ConstantFoldingPrecision
DoublePrecision -> Integer
dres
  where  dres :: Integer
dres = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit)

decodeLitFloating :: LitFloatingType -> Platform -> LitFloating -> (Integer, Int)
decodeLitFloating :: LitFloatingType -> Platform -> LitFloating -> (Integer, Int)
decodeLitFloating LitFloatingType
LitFloat  Platform
_ LitFloating
lit = Float -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat (LitFloating -> Float
litFloatingToHostFloat  LitFloating
lit)
decodeLitFloating LitFloatingType
LitDouble Platform
_ LitFloating
lit = Double -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat (LitFloating -> Double
litFloatingToHostDouble LitFloating
lit)

encodeLitFloat, encodeLitDouble
  :: Integer -> Int -> LitFloating
encodeLitFloat :: Integer -> Int -> LitFloating
encodeLitFloat  Integer
m Int
e
  = Float -> LitFloating
LitFloatingF (forall a. RealFloat a => Integer -> Int -> a
encodeFloat @Float  Integer
m Int
e)
encodeLitDouble :: Integer -> Int -> LitFloating
encodeLitDouble Integer
m Int
e
  = Double -> LitFloating
LitFloatingD (forall a. RealFloat a => Integer -> Int -> a
encodeFloat @Double Integer
m Int
e)