module FrontEnd.DataConsAssump (dataConsEnv) where
import Control.Monad.Identity
import qualified Data.Map as Map
import FrontEnd.HsSyn
import FrontEnd.KindInfer
import FrontEnd.Tc.Type
import Name.Name
import Support.FreeVars
dataConsEnv :: KindEnv -> [HsDecl] -> Map.Map Name Sigma
dataConsEnv kt decls
= Map.unions $ map (dataDeclEnv (error "dataConsenvModName") kt) decls
dataDeclEnv :: Module -> KindEnv -> (HsDecl) -> Map.Map Name Sigma
dataDeclEnv modName kt HsDataDecl { hsDeclContext = context, hsDeclName = typeName, hsDeclArgs = args, hsDeclCons = condecls }
= Map.unions $ map (conDeclType modName kt preds resultType) $ condecls
where
typeName' = toName TypeConstructor typeName
typeKind = kindOf typeName' kt
resultType = foldl tAp tycon argVars
tycon = TCon (Tycon typeName' typeKind)
argVars = map fromHsNameToTyVar $ zip argKinds args
argKinds = init $ unfoldKind typeKind
fromHsNameToTyVar :: (Kind, HsName) -> Type
fromHsNameToTyVar (k, n)
= TVar (tyvar (toName TypeVal n) k)
preds = hsContextToPreds kt context
dataDeclEnv _modName _kt _anyOtherDecl
= Map.empty
hsContextToPreds :: KindEnv -> HsContext -> [Pred]
hsContextToPreds kt assts = map (hsAsstToPred kt) assts
conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Map.Map Name Sigma
conDeclType modName kt preds tResult (HsConDecl { hsConDeclName = conName, hsConDeclConArg = bangTypes })
= Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType
where
conType = foldr fn tResult (map (bangTypeToType kt) bangTypes)
qualConType = preds :=> conType
conDeclType modName kt preds tResult rd@HsRecDecl { hsConDeclName = conName }
= Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType
where
conType = foldr fn tResult (map (bangTypeToType kt) (hsConDeclArgs rd))
qualConType = preds :=> conType
bangTypeToType :: KindEnv -> HsBangType -> Type
bangTypeToType kt (HsBangedTy t) = runIdentity $ hsTypeToType kt t
bangTypeToType kt (HsUnBangedTy t) = runIdentity $ hsTypeToType kt t