X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=42a6c9b3f98cb8dba1e874df4f4c551bb22374ef;hb=0596517a9b4b2b32e5d375a986351102ac4540fc;hp=c2b831dcaa6e1ea35fbb4aa59caa38f583728cf0;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index c2b831d..42a6c9b 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -6,14 +6,16 @@ module TcEnv( initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, - tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv, - tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey, + tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar, + + tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, + tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, tcExtendGlobalValEnv, tcExtendLocalValEnv, - tcLookupLocalValue, tcLookupLocalValueOK, + tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcTyVarScope, newMonoIds, newLocalIds, + newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars ) where @@ -22,12 +24,12 @@ import Ubiq import TcMLoop -- for paranoia checking import Id ( Id(..), GenId, idType, mkUserLocal ) -import TcHsSyn ( TcIdBndr(..) ) +import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) ) import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars ) import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) -import TyCon ( TyCon, getTyConKind ) +import TyCon ( TyCon, Arity(..), getTyConKind, getSynTyConArity ) import Class ( Class(..), GenClass, getClassSig ) import TcMonad @@ -46,135 +48,126 @@ Data type declarations \begin{code} data TcEnv s = TcEnv (TyVarEnv s) + (TyConEnv s) + (ClassEnv s) (ValueEnv Id) -- Globals (ValueEnv (TcIdBndr s)) -- Locals (MutableVar s (TcTyVarSet s)) -- Free type variables of locals -- ...why mutable? see notes with tcGetGlobalTyVars - (KindEnv s) -- Gives TcKinds of TyCons and Classes - TyConEnv - ClassEnv type TyVarEnv s = UniqFM (TcKind s, TyVar) -type TyConEnv = UniqFM TyCon -type KindEnv s = UniqFM (TcKind s) -type ClassEnv = UniqFM Class +type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only +type ClassEnv s = UniqFM (TcKind s, Class) type ValueEnv id = UniqFM id initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s -initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM +initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut -getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls -getEnv_TyCons (TcEnv _ _ _ _ _ ts _) = ts -getEnv_Classes (TcEnv _ _ _ _ _ _ cs) = cs +getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls +getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts] +getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs] \end{code} Making new TcTyVars, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyVarScope :: [Name] -- Names of some type variables - -> ([TyVar] -> TcM s a) -- Thing to type check in their scope - -> TcM s a -- Result - -tcTyVarScope tyvar_names thing_inside - = newKindVars (length tyvar_names) `thenNF_Tc` \ tyvar_kinds -> +tcTyVarScopeGivenKinds + :: [Name] -- Names of some type variables + -> [TcKind s] + -> ([TyVar] -> TcM s a) -- Thing to type check in their scope + -> TcM s a -- Result - fixTc (\ ~(tyvars, _) -> - -- Ok to look at kinds, but not tyvars! - tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) ( +tcTyVarScopeGivenKinds names kinds thing_inside + = fixTc (\ ~(rec_tyvars, _) -> + -- Ok to look at names, kinds, but not tyvars! - -- Do the thing inside - thing_inside tyvars `thenTc` \ result -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + let + tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars)) + in + tcSetEnv (TcEnv tve' tce ce gve lve gtvs) + (thing_inside rec_tyvars) `thenTc` \ result -> -- Get the tyvar's Kinds from their TcKinds - mapNF_Tc tcKindToKind tyvar_kinds `thenNF_Tc` \ tyvar_kinds' -> + mapNF_Tc tcKindToKind kinds `thenNF_Tc` \ kinds' -> -- Construct the real TyVars let - tyvars = zipWithEqual mk_tyvar tyvar_names tyvar_kinds' + tyvars = zipWithEqual mk_tyvar names kinds' mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind in returnTc (tyvars, result) - )) `thenTc` \ (_,result) -> + ) `thenTc` \ (_,result) -> returnTc result + +tcTyVarScope names thing_inside + = newKindVars (length names) `thenNF_Tc` \ kinds -> + tcTyVarScopeGivenKinds names kinds thing_inside \end{code} The Kind, TyVar, Class and TyCon envs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Extending the environments +Extending the environments. Notice the uses of @zipLazy@, which makes sure +that the knot-tied TyVars, TyCons and Classes aren't looked at too early. \begin{code} -tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r -tcExtendKindEnv names kinds scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - ke' = addListToUFM ke (names `zip` kinds) - in - tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope - -tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r -tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars) - in - tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope - -tcExtendTyConEnv tycons scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> +tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r +tcExtendTyConEnv names_w_arities tycons scope + = newKindVars (length names_w_arities) `thenNF_Tc` \ kinds -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons] + tce' = addListToUFM tce [ (name, (kind, arity, tycon)) + | ((name,arity), (kind,tycon)) <- names_w_arities `zip` + (kinds `zipLazy` tycons) + ] in - tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope + tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope -tcExtendClassEnv classes scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> +tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r +tcExtendClassEnv names classes scope + = newKindVars (length names) `thenNF_Tc` \ kinds -> + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes] + ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes)) in - tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope + tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope \end{code} -Looking up in the environments +Looking up in the environments. \begin{code} tcLookupTyVar name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name) tcLookupTyCon (WiredInTyCon tc) -- wired in tycons - = returnNF_Tc (kindToTcKind (getTyConKind tc), tc) + = returnNF_Tc (kindToTcKind (getTyConKind tc), getSynTyConArity tc, tc) tcLookupTyCon name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon") name - kind = lookupWithDefaultUFM ke (kindToTcKind (getTyConKind tycon)) name - -- The KE will bind tycon in the current mutually-recursive set. - -- If the KE doesn't, then the tycon is already defined, and we - -- can safely grab the kind from the TyCon itself - in - returnNF_Tc (kind,tycon) + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name) +tcLookupTyConByKey uniq + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + let + (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce (panic "tcLookupTyCon") uniq + in + returnNF_Tc tycon tcLookupClass name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> - let - clas = lookupWithDefaultUFM ce (panic "tcLookupClass") name - (tyvar, _, _) = getClassSig clas - kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name - in - returnNF_Tc (kind,clas) + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name) tcLookupClassByKey uniq - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq + (kind, clas) = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq in - returnNF_Tc (clas) + returnNF_Tc clas \end{code} @@ -183,14 +176,14 @@ Extending and consulting the value environment ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcExtendGlobalValEnv ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids] in - tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope + tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope tcExtendLocalValEnv names ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> let lve' = addListToUFM lve (names `zip` ids) @@ -199,7 +192,7 @@ tcExtendLocalValEnv names ids scope in tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' -> - tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope + tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope \end{code} @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. @@ -209,7 +202,7 @@ the environment. \begin{code} tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s) tcGetGlobalTyVars - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' -> tcWriteMutVar gtvs global_tvs' `thenNF_Tc_` @@ -219,12 +212,17 @@ tcGetGlobalTyVars \begin{code} tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s)) tcLookupLocalValue name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM lve name) +tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s)) +tcLookupLocalValueByKey uniq + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupUFM_Directly lve uniq) + tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s) tcLookupLocalValueOK err name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM lve (panic err) name) @@ -234,7 +232,7 @@ tcLookupGlobalValue (WiredInVal id) -- wired in ids = returnNF_Tc id tcLookupGlobalValue name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM gve def name) where #ifdef DEBUG @@ -246,7 +244,7 @@ tcLookupGlobalValue name tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq - = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) -> + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq) where #ifdef DEBUG @@ -275,13 +273,19 @@ newMonoIds names kind m where no_of_names = length names -newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s] +newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s) +newLocalId name ty + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (TcId (mkUserLocal name uniq ty loc)) + +newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s] newLocalIds names tys = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUniques (length names) `thenNF_Tc` \ uniqs -> let new_ids = zipWith3Equal mk_id names uniqs tys - mk_id name uniq ty = mkUserLocal name uniq ty loc + mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc) in returnNF_Tc new_ids \end{code}