module DDC.Core.Lite.Env
( primDataDefs
, primKindEnv
, primTypeEnv
, isBoxedType)
where
import DDC.Core.Lite.Compounds
import DDC.Core.Lite.Name
import DDC.Type.DataDef
import DDC.Type.Compounds
import DDC.Type.Exp
import DDC.Type.Env (Env)
import qualified DDC.Type.Env as Env
primDataDefs :: DataDefs Name
primDataDefs
= fromListDataDefs
[ DataDef (NamePrimTyCon PrimTyConBool)
[]
(Just [ (NameLitBool True, [])
, (NameLitBool False, []) ])
, DataDef (NamePrimTyCon PrimTyConNat) [] Nothing
, DataDef (NamePrimTyCon PrimTyConInt) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing
, DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing
, DataDef
(NameDataTyCon DataTyConUnit)
[]
(Just [ ( NamePrimDaCon PrimDaConUnit
, []) ])
, DataDef
(NameDataTyCon DataTyConBool)
[kRegion]
(Just [ ( NamePrimDaCon PrimDaConBoolU
, [tBoolU]) ])
, DataDef
(NameDataTyCon DataTyConNat)
[kRegion]
(Just [ ( NamePrimDaCon PrimDaConNatU
, [tNatU]) ])
, DataDef
(NameDataTyCon DataTyConInt)
[kRegion]
(Just [ ( NamePrimDaCon PrimDaConIntU
, [tIntU]) ])
, DataDef
(NameDataTyCon DataTyConPair)
[kRegion, kData, kData]
(Just [ ( NamePrimDaCon PrimDaConPr
, [tIx kData 1, tIx kData 0]) ])
, DataDef
(NameDataTyCon DataTyConList)
[kRegion, kData]
(Just [ (NamePrimDaCon PrimDaConNil, [tUnit])
, (NamePrimDaCon PrimDaConCons,
[tIx kData 0, tList (tIx kRegion 1) (tIx kData 0)])])
]
primKindEnv :: Env Name
primKindEnv = Env.setPrimFun kindOfPrimName Env.empty
kindOfPrimTyCon :: PrimTyCon -> Kind Name
kindOfPrimTyCon tc
= case tc of
PrimTyConVoid -> kData
PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData)
PrimTyConAddr -> kData
PrimTyConBool -> kData
PrimTyConNat -> kData
PrimTyConInt -> kData
PrimTyConWord _ -> kData
PrimTyConFloat _ -> kData
PrimTyConTag -> kData
PrimTyConString -> kData
kindOfPrimName :: Name -> Maybe (Kind Name)
kindOfPrimName nn
= case nn of
NameEffectTyCon EffectTyConConsole
-> Just $ kEffect
NameDataTyCon DataTyConUnit
-> Just $ kData
NameDataTyCon DataTyConBool
-> Just $ kFun kRegion kData
NameDataTyCon DataTyConInt
-> Just $ kFun kRegion kData
NameDataTyCon DataTyConNat
-> Just $ kFun kRegion kData
NameDataTyCon DataTyConPair
-> Just $ kRegion `kFun` kData `kFun` kData `kFun` kData
NameDataTyCon DataTyConList
-> Just $ kRegion `kFun` kData `kFun` kData
NamePrimTyCon tc
-> Just $ kindOfPrimTyCon tc
_ -> Nothing
primTypeEnv :: Env Name
primTypeEnv = Env.setPrimFun typeOfPrimName Env.empty
typeOfPrimName :: Name -> Maybe (Type Name)
typeOfPrimName dc
= case dc of
NamePrimDaCon PrimDaConBoolU
-> Just $ tForall kRegion $ \tR
-> tFunEC tBoolU (tAlloc tR)
(tBot kClosure)
$ tBool tR
NamePrimDaCon PrimDaConNatU
-> Just $ tForall kRegion $ \tR
-> tFunEC tNatU (tAlloc tR)
(tBot kClosure)
$ tNat tR
NamePrimDaCon PrimDaConIntU
-> Just $ tForall kRegion $ \tR
-> tFunEC tIntU (tAlloc tR)
(tBot kClosure)
$ tInt tR
NamePrimDaCon PrimDaConUnit
-> Just $ tUnit
NamePrimDaCon PrimDaConPr
-> Just $ tForalls [kRegion, kData, kData] $ \[tR, tA, tB]
-> tFunEC tA (tBot kEffect)
(tBot kClosure)
$ tFunEC tB (tSum kEffect [tAlloc tR])
(tSum kClosure [tDeepUse tA])
$ tPair tR tA tB
NamePrimDaCon PrimDaConNil
-> Just $ tForalls [kRegion, kData] $ \[tR, tA]
-> tFunEC tUnit (tAlloc tR)
(tBot kClosure)
$ tList tR tA
NamePrimDaCon PrimDaConCons
-> Just $ tForalls [kRegion, kData] $ \[tR, tA]
-> tFunEC tA (tBot kEffect)
(tBot kClosure)
$ tFunEC (tList tR tA) (tSum kEffect [tAlloc tR])
(tSum kClosure [tDeepUse tA])
$ tList tR tA
NamePrimArith p
-> Just $ typeOfPrimArith p
NameLitBool _ -> Just $ tBoolU
NameLitNat _ -> Just $ tNatU
NameLitInt _ -> Just $ tIntU
NameLitWord _ bits -> Just $ tWordU bits
_ -> Nothing
typeOfPrimArith :: PrimArith -> Type Name
typeOfPrimArith op
= case op of
PrimArithNeg -> tForall kData $ \t -> t `tFunPE` t
PrimArithAdd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithSub -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithMul -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithDiv -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithMod -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithRem -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithEq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithNeq -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithGt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithLt -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithLe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithGe -> tForall kData $ \t -> t `tFunPE` t `tFunPE` tBoolU
PrimArithAnd -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU
PrimArithOr -> tBoolU `tFunPE` tBoolU `tFunPE` tBoolU
PrimArithShl -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithShr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBAnd -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
PrimArithBXOr -> tForall kData $ \t -> t `tFunPE` t `tFunPE` t
isBoxedType :: Type Name -> Bool
isBoxedType tt
| TVar _ <- tt = True
| TForall _ t <- tt = isBoxedType t
| TSum{} <- tt = False
| otherwise
= case takeTyConApps tt of
Nothing -> False
Just (TyConSpec TcConUnit, _) -> True
Just (TyConBound (UName (NameDataTyCon _)) _, _) -> True
Just (TyConBound (UPrim (NameDataTyCon _) _) _, _) -> True
_ -> False