module DDC.Core.Tetra.Transform.Boxing
(boxingModule)
where
import DDC.Core.Tetra.Compounds
import DDC.Core.Tetra.Prim
import DDC.Core.Transform.Boxing
import DDC.Core.Module
import DDC.Core.Exp
boxingModule :: Show a => Module a Name -> Module a Name
boxingModule mm
= boxing config mm
config :: Config a Name
config = Config
{ configIsValueIndexType = isValueIndexType
, configIsBoxedType = isBoxedType
, configIsUnboxedType = isUnboxedType
, configBoxedOfIndexType = boxedOfIndexType
, configUnboxedOfIndexType = unboxedOfIndexType
, configIndexTypeOfBoxed = indexTypeOfBoxed
, configIndexTypeOfUnboxed = indexTypeOfUnboxed
, configNameIsUnboxedOp = isNameOfUnboxedOp
, configValueTypeOfLitName = takeTypeOfLitName
, configValueTypeOfPrimOpName = takeTypeOfPrimOpName
, configValueTypeOfForeignName = const Nothing
, configBoxedOfValue = boxedOfValue
, configValueOfBoxed = valueOfBoxed
, configBoxedOfUnboxed = boxedOfUnboxed
, configUnboxedOfBoxed = unboxedOfBoxed }
isValueIndexType :: Type Name -> Bool
isValueIndexType tt
| Just (NamePrimTyCon n, _) <- takePrimTyConApps tt
= case n of
PrimTyConVoid -> False
PrimTyConBool -> True
PrimTyConNat -> True
PrimTyConInt -> True
PrimTyConWord{} -> True
PrimTyConFloat{} -> True
PrimTyConVec{} -> True
PrimTyConAddr{} -> True
PrimTyConPtr{} -> True
PrimTyConTag{} -> True
PrimTyConString{} -> True
| Just (NameTyConTetra n, _) <- takePrimTyConApps tt
= case n of
TyConTetraRef{} -> False
TyConTetraTuple{} -> False
TyConTetraB{} -> False
TyConTetraU{} -> False
| otherwise
= False
isBoxedType :: Type Name -> Bool
isBoxedType tt
| Just (n, _) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraB <- n
= True
| otherwise = False
isUnboxedType :: Type Name -> Bool
isUnboxedType tt
| Just (n, _) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraU <- n
= True
| otherwise = False
indexTypeOfBoxed :: Type Name -> Maybe (Type Name)
indexTypeOfBoxed tt
| Just (n, [t]) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraB <- n
= Just t
| otherwise
= Nothing
indexTypeOfUnboxed :: Type Name -> Maybe (Type Name)
indexTypeOfUnboxed tt
| Just (n, [t]) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraU <- n
= Just t
| otherwise
= Nothing
boxedOfIndexType :: Type Name -> Maybe (Type Name)
boxedOfIndexType tt
| Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt
= case tc of
PrimTyConBool -> Just $ tBoxed tBool
PrimTyConNat -> Just $ tBoxed tNat
PrimTyConInt -> Just $ tBoxed tInt
PrimTyConWord bits -> Just $ tBoxed (tWord bits)
_ -> Nothing
| otherwise = Nothing
unboxedOfIndexType :: Type Name -> Maybe (Type Name)
unboxedOfIndexType tt
| Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt
= case tc of
PrimTyConBool -> Just $ tUnboxed tBool
PrimTyConNat -> Just $ tUnboxed tNat
PrimTyConInt -> Just $ tUnboxed tInt
PrimTyConWord bits -> Just $ tUnboxed (tWord bits)
_ -> Nothing
| otherwise = Nothing
isNameOfUnboxedOp :: Name -> Bool
isNameOfUnboxedOp nn
= case nn of
NamePrimArith{} -> True
NamePrimCast{} -> True
_ -> False
boxedOfValue :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)
boxedOfValue a xx tt
| Just tBx <- boxedOfIndexType tt
= Just $ xCastConvert a tt tBx xx
| otherwise = Nothing
valueOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)
valueOfBoxed a xx tt
| Just tBx <- boxedOfIndexType tt
= Just $ xCastConvert a tBx tt xx
| otherwise = Nothing
boxedOfUnboxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)
boxedOfUnboxed a xx tt
| Just tBx <- boxedOfIndexType tt
, Just tUx <- unboxedOfIndexType tt
= Just $ xCastConvert a tUx tBx xx
| otherwise = Nothing
unboxedOfBoxed :: a -> Exp a Name -> Type Name -> Maybe (Exp a Name)
unboxedOfBoxed a xx tt
| Just tBx <- boxedOfIndexType tt
, Just tUx <- unboxedOfIndexType tt
= Just $ xCastConvert a tBx tUx xx
| otherwise = Nothing