module DDC.Core.Tetra.Transform.Boxing
(boxingModule)
where
import DDC.Core.Tetra.Compounds
import DDC.Core.Tetra.Prim
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Core.Transform.Boxing (Rep(..), Config(..))
import qualified DDC.Core.Transform.Boxing as Boxing
boxingModule :: Show a => Module a Name -> Module a Name
boxingModule mm
= let
tsForeignSea
= [ (n, t) | (n, ImportValueSea _ t) <- moduleImportValues mm]
in Boxing.boxingModule (config tsForeignSea) mm
config :: [(Name, Type Name)] -> Config a Name
config ntsForeignSea
= Config
{ configRepOfType = repOfType
, configConvertRepType = convertRepType
, configConvertRepExp = convertRepExp
, configValueTypeOfLitName = takeTypeOfLitName
, configValueTypeOfPrimOpName = takeTypeOfPrimOpName
, configValueTypeOfForeignName = \n -> lookup n ntsForeignSea
, configUnboxPrimOpName = unboxPrimOpName
, configUnboxLitName = unboxLitName }
repOfType :: Type Name -> Maybe Rep
repOfType tt
| Just (NamePrimTyCon n, _) <- takePrimTyConApps tt
= case n of
PrimTyConVoid -> Just RepNone
PrimTyConBool -> Just RepBoxed
PrimTyConNat -> Just RepBoxed
PrimTyConInt -> Just RepBoxed
PrimTyConSize -> Just RepBoxed
PrimTyConWord{} -> Just RepBoxed
PrimTyConFloat{} -> Just RepBoxed
PrimTyConVec{} -> Just RepBoxed
PrimTyConAddr{} -> Just RepBoxed
PrimTyConPtr{} -> Just RepBoxed
PrimTyConTextLit{} -> Just RepBoxed
PrimTyConTag{} -> Just RepBoxed
| Just (n, _) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraU <- n
= Just RepUnboxed
| Just (NameTyConTetra n, _) <- takePrimTyConApps tt
= case n of
TyConTetraTuple{} -> Just RepNone
TyConTetraVector{} -> Just RepNone
TyConTetraU{} -> Just RepNone
TyConTetraF{} -> Just RepNone
TyConTetraC{} -> Just RepNone
| otherwise
= Nothing
convertRepType :: Rep -> Type Name -> Maybe (Type Name)
convertRepType RepBoxed tt
| Just (n, [t]) <- takePrimTyConApps tt
, NameTyConTetra TyConTetraU <- n
= Just t
convertRepType RepUnboxed tt
| Just (NamePrimTyCon tc, []) <- takePrimTyConApps tt
= case tc of
PrimTyConBool -> Just $ tUnboxed tBool
PrimTyConNat -> Just $ tUnboxed tNat
PrimTyConInt -> Just $ tUnboxed tInt
PrimTyConSize -> Just $ tUnboxed tSize
PrimTyConWord bits -> Just $ tUnboxed (tWord bits)
PrimTyConFloat bits -> Just $ tUnboxed (tFloat bits)
PrimTyConTextLit -> Just $ tUnboxed tTextLit
_ -> Nothing
| Just (NameTyConTetra tc, []) <- takePrimTyConApps tt
= case tc of
_ -> Nothing
convertRepType _ _
= Nothing
convertRepExp :: Rep -> a -> Type Name -> Exp a Name -> Maybe (Exp a Name)
convertRepExp rep a tSource xx
| Just tResult <- convertRepType rep tSource
= Just $ xCastConvert a tSource tResult xx
| otherwise
= Nothing
unboxPrimOpName :: Name -> Maybe Name
unboxPrimOpName n
= case n of
NamePrimArith op False
-> Just $ NamePrimArith op True
NameOpVector op False
-> Just $ NameOpVector op True
NameOpError op False
-> Just $ NameOpError op True
_ -> Nothing
unboxLitName :: Name -> Maybe Name
unboxLitName n
| isNameLit n && not (isNameLitUnboxed n)
= Just $ NameLitUnboxed n
| otherwise
= Nothing