#if __GLASGOW_HASKELL__ < 710
#endif
module Ivory.Language.Cast
( safeCast
, ivoryCast
, castWith
, castDefault
, signCast
, SafeCast(), RuntimeCast(), Default(), SignCast()
, toMaxSize
, toMinSize
) where
import Ivory.Language.Float
import Ivory.Language.IBool
import Ivory.Language.IChar
import Ivory.Language.IIntegral
import Ivory.Language.Proxy
import Ivory.Language.Sint
import Ivory.Language.Type
import Ivory.Language.Uint
import qualified Ivory.Language.Syntax as AST
import Data.Word
import Data.Int
class (IvoryExpr from, IvoryExpr to) => SafeCast from to where
safeCast :: from -> to
safeCast = ivoryCast
castWith :: RuntimeCast from to => to -> from -> to
castWith deflt from = inBounds deflt from ? (ivoryCast from, deflt)
castDefault :: (Default to, RuntimeCast from to) => from -> to
castDefault = castWith defaultVal
class (IvoryExpr from, IvoryExpr to) => SignCast from to where
signCast :: from -> to
upperBoundCast :: forall from to
. (IvoryOrd from, IvoryExpr from, IvoryExpr to, Num to, Bounded to)
=> from -> to
upperBoundCast f = (f <=? bound) ? (ivoryCast f, 0)
where bound = ivoryCast (maxBound :: to)
lowerBoundCast :: forall from to
. (IvoryOrd from, IvoryExpr from, IvoryExpr to, Num to, Bounded to)
=> from -> to
lowerBoundCast f = (f >? bound) ? (ivoryCast f, 0)
where bound = ivoryCast (minBound :: to)
class (IvoryExpr from, IvoryExpr to, Default to) => RuntimeCast from to where
inBounds :: to -> from -> IBool
instance SafeCast IBool IBool where
safeCast = id
instance SafeCast IBool IChar
instance SafeCast IBool Uint16
instance SafeCast IBool Uint8
instance SafeCast IBool Uint32
instance SafeCast IBool Uint64
instance SafeCast IBool Sint8
instance SafeCast IBool Sint16
instance SafeCast IBool Sint32
instance SafeCast IBool Sint64
instance SafeCast IBool IFloat
instance SafeCast IBool IDouble
instance SafeCast Uint8 Uint8 where
safeCast = id
instance SafeCast Uint8 Uint16
instance SafeCast Uint8 Uint32
instance SafeCast Uint8 Uint64
instance SafeCast Uint8 Sint16
instance SafeCast Uint8 Sint32
instance SafeCast Uint8 Sint64
instance SafeCast Uint8 IFloat
instance SafeCast Uint8 IDouble
instance SignCast Uint8 Sint8 where
signCast = upperBoundCast
instance SafeCast Uint16 Uint16 where
safeCast = id
instance SafeCast Uint16 Uint32
instance SafeCast Uint16 Uint64
instance SafeCast Uint16 Sint32
instance SafeCast Uint16 Sint64
instance SafeCast Uint16 IFloat
instance SafeCast Uint16 IDouble
instance SignCast Uint16 Sint16 where
signCast = upperBoundCast
instance SafeCast Uint32 Uint32 where
safeCast = id
instance SafeCast Uint32 Uint64
instance SafeCast Uint32 Sint64
instance SafeCast Uint32 IFloat
instance SafeCast Uint32 IDouble
instance SignCast Uint32 Sint32 where
signCast = upperBoundCast
instance SafeCast Uint64 Uint64 where
safeCast = id
instance SafeCast Uint64 IDouble
instance SignCast Uint64 Sint64 where
signCast = upperBoundCast
instance SafeCast Sint8 Sint8 where
safeCast = id
instance SafeCast Sint8 Sint16
instance SafeCast Sint8 Sint32
instance SafeCast Sint8 Sint64
instance SafeCast Sint8 IFloat
instance SafeCast Sint8 IDouble
instance SignCast Sint8 Uint8 where
signCast = lowerBoundCast
instance SafeCast Sint16 Sint16 where
safeCast = id
instance SafeCast Sint16 Sint32
instance SafeCast Sint16 Sint64
instance SafeCast Sint16 IFloat
instance SafeCast Sint16 IDouble
instance SignCast Sint16 Uint16 where
signCast = lowerBoundCast
instance SafeCast Sint32 Sint32 where
safeCast = id
instance SafeCast Sint32 Sint64
instance SafeCast Sint32 IFloat
instance SafeCast Sint32 IDouble
instance SignCast Sint32 Uint32 where
signCast = lowerBoundCast
instance SafeCast Sint64 Sint64 where
safeCast = id
instance SafeCast Sint64 IDouble
instance SignCast Sint64 Uint64 where
signCast = lowerBoundCast
instance SafeCast IFloat IFloat where
safeCast = id
instance SafeCast IFloat IDouble
instance SafeCast IDouble IDouble where
safeCast = id
instance SafeCast IChar IChar where
safeCast = id
instance
#if __GLASGOW_HASKELL__ >= 710
#endif
( Bounded from, Bounded to
, IvoryOrd from, IvoryOrd to
, IvoryExpr from, IvoryExpr to
, Default from, Default to
, SafeCast to from
) => RuntimeCast from to where
inBounds = boundPred
class Default a where
defaultVal :: a
instance Default Uint8 where defaultVal = 0
instance Default Uint16 where defaultVal = 0
instance Default Uint32 where defaultVal = 0
instance Default Uint64 where defaultVal = 0
instance Default Sint8 where defaultVal = 0
instance Default Sint16 where defaultVal = 0
instance Default Sint32 where defaultVal = 0
instance Default Sint64 where defaultVal = 0
instance Default IFloat where defaultVal = 0
instance Default IDouble where defaultVal = 0
instance ( Default to
, Bounded to
, IvoryIntegral to
, SafeCast to IFloat
) => RuntimeCast IFloat to where
inBounds to from = iNot (isnan from) .&& boundPred to from
instance ( Default to
, Bounded to
, IvoryIntegral to
, SafeCast to IDouble
) => RuntimeCast IDouble to where
inBounds to from = iNot (isnan from) .&& boundPred to from
boundPred :: forall from to .
( IvoryExpr from
, IvoryExpr to
, Bounded to
, IvoryOrd from
) => to -> from -> IBool
boundPred _ from = (from <=? ivoryCast (maxBound :: to))
.&& (from >=? ivoryCast (minBound :: to))
ivoryCast :: forall a b. (IvoryExpr a, IvoryExpr b) => a -> b
ivoryCast x = wrapExpr (AST.ExpSafeCast ty (unwrapExpr x))
where ty = ivoryType (Proxy :: Proxy a)
toMaxSize :: AST.Type -> Maybe Integer
toMaxSize ty =
case ty of
AST.TyInt i -> Just $ case i of
AST.Int8 -> fromIntegral (maxBound :: Int8)
AST.Int16 -> fromIntegral (maxBound :: Int16)
AST.Int32 -> fromIntegral (maxBound :: Int32)
AST.Int64 -> fromIntegral (maxBound :: Int64)
AST.TyWord w -> Just $ case w of
AST.Word8 -> fromIntegral (maxBound :: Word8)
AST.Word16 -> fromIntegral (maxBound :: Word16)
AST.Word32 -> fromIntegral (maxBound :: Word32)
AST.Word64 -> fromIntegral (maxBound :: Word64)
AST.TyIndex n -> Just n
_ -> Nothing
toMinSize :: AST.Type -> Maybe Integer
toMinSize ty =
case ty of
AST.TyInt i -> Just $ case i of
AST.Int8 -> fromIntegral (minBound :: Int8)
AST.Int16 -> fromIntegral (minBound :: Int16)
AST.Int32 -> fromIntegral (minBound :: Int32)
AST.Int64 -> fromIntegral (minBound :: Int64)
AST.TyWord w -> Just $ case w of
AST.Word8 -> fromIntegral (minBound :: Word8)
AST.Word16 -> fromIntegral (minBound :: Word16)
AST.Word32 -> fromIntegral (minBound :: Word32)
AST.Word64 -> fromIntegral (minBound :: Word64)
AST.TyIndex _ -> Just 0
_ -> Nothing