X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=0c299a5669d76c4626ef6b42061efed7e9691ad2;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=8ca00347863390a8509709297fd7549f3818fd6e;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8ca0034..0c299a5 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -10,39 +10,43 @@ module TcEnv( tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, + tcGetTyConsAndClasses, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, - tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc, + tcLookupGlobalValue, tcLookupGlobalValueByKey, newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars ) where -import Ubiq -import TcMLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(TcMLoop) -- for paranoia checking import Id ( Id(..), GenId, idType, mkUserLocal ) import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) ) import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), - newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars + newTyVarTys, tcInstTyVars, zonkTcTyVars ) -import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet ) +import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) -import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity ) -import Class ( Class(..), GenClass, getClassSig ) +import TyCon ( TyCon, tyConKind, synTyConArity ) +import Class ( Class(..), GenClass, classSig ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) -import Name ( Name(..), getNameShortName ) +import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} ) import PprStyle import Pretty -import Type ( splitForAllTy ) -import Unique ( Unique ) -import UniqFM -import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic ) +import RnHsSyn ( RnName(..) ) +import Type ( splitForAllTy ) +import Unique ( pprUnique10, pprUnique{-ToDo:rm-} ) +import UniqFM +import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy, + panic, pprPanic, pprTrace{-ToDo:rm-} + ) \end{code} Data type declarations @@ -75,10 +79,10 @@ Making new TcTyVars, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcTyVarScopeGivenKinds - :: [Name] -- Names of some type variables + :: [Name] -- Names of some type variables -> [TcKind s] - -> ([TyVar] -> TcM s a) -- Thing to type check in their scope - -> TcM s a -- Result + -> ([TyVar] -> TcM s a) -- Thing to type check in their scope + -> TcM s a -- Result tcTyVarScopeGivenKinds names kinds thing_inside = fixTc (\ ~(rec_tyvars, _) -> @@ -86,7 +90,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars)) + tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars)) in tcSetEnv (TcEnv tve' tce ce gve lve gtvs) (thing_inside rec_tyvars) `thenTc` \ result -> @@ -96,8 +100,8 @@ tcTyVarScopeGivenKinds names kinds thing_inside -- Construct the real TyVars let - tyvars = zipWithEqual mk_tyvar names kinds' - mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind + tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mk_tyvar names kinds' + mk_tyvar name kind = mkTyVar name (uniqueOf name) kind in returnTc (tyvars, result) ) `thenTc` \ (_,result) -> @@ -116,14 +120,15 @@ 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} -tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r +tcExtendTyConEnv :: [(RnName,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 tce [ (name, (kind, arity, tycon)) - | ((name,arity), (kind,tycon)) <- names_w_arities `zip` - (kinds `zipLazy` tycons) + | ((name,arity), (kind,tycon)) + <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons) ] in tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result -> @@ -131,12 +136,12 @@ tcExtendTyConEnv names_w_arities tycons scope returnTc result -tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r +tcExtendClassEnv :: [RnName] -> [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 ce (names `zip` (kinds `zipLazy` classes)) + ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes)) in tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result -> mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` @@ -149,7 +154,7 @@ Looking up in the environments. \begin{code} tcLookupTyVar name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name) + returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name) tcLookupTyCon (WiredInTyCon tc) -- wired in tycons @@ -157,29 +162,37 @@ tcLookupTyCon (WiredInTyCon tc) -- wired in tycons tcLookupTyCon name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name) + returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name) tcLookupTyConByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce - (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq)) + (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) uniq in returnNF_Tc tycon tcLookupClass name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name) +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $ +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $ + returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name) tcLookupClassByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let (kind, clas) = lookupWithDefaultUFM_Directly ce - (pprPanic "tcLookupClas:" (ppr PprDebug uniq)) + (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq)) uniq in returnNF_Tc clas + +tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class]) +tcGetTyConsAndClasses + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce], + [c | (_, c) <- eltsUFM ce]) \end{code} @@ -190,7 +203,7 @@ Extending and consulting the value environment tcExtendGlobalValEnv ids scope = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids] + gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids] in tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope @@ -198,7 +211,7 @@ tcExtendLocalValEnv names ids scope = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> let - lve' = addListToUFM lve (names `zip` ids) + lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids) extra_global_tyvars = tyVarsOfTypes (map idType ids) new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tyvars in @@ -222,7 +235,7 @@ tcGetGlobalTyVars \end{code} \begin{code} -tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s)) +tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s)) tcLookupLocalValue name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM lve name) @@ -232,15 +245,15 @@ 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 :: String -> RnName -> NF_TcM s (TcIdBndr s) tcLookupLocalValueOK err name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM lve (panic err) name) -tcLookupGlobalValue :: Name -> NF_TcM s Id +tcLookupGlobalValue :: RnName -> NF_TcM s Id -tcLookupGlobalValue (WiredInVal id) -- wired in ids +tcLookupGlobalValue (WiredInId id) -- wired in ids = returnNF_Tc id tcLookupGlobalValue name @@ -253,30 +266,13 @@ tcLookupGlobalValue name def = panic "tcLookupGlobalValue" #endif --- A useful function that takes an occurrence of a global thing --- and instantiates its type with fresh type variables -tcGlobalOcc :: Name - -> NF_TcM s (Id, -- The Id - [TcType s], -- Instance types - TcType s) -- Rest of its type - -tcGlobalOcc name - = tcLookupGlobalValue name `thenNF_Tc` \ id -> - let - (tyvars, rho) = splitForAllTy (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - tcInstType tenv rho `thenNF_Tc` \ rho' -> - returnNF_Tc (id, arg_tys, rho') - - tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq) where #ifdef DEBUG - def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq) + def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq) #else def = panic "tcLookupGlobalValueByKey" #endif @@ -288,14 +284,19 @@ Constructing new Ids ~~~~~~~~~~~~~~~~~~~~ \begin{code} -newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a +newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a + newMonoIds names kind m = newTyVarTys no_of_names kind `thenNF_Tc` \ tys -> tcGetUniques no_of_names `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys - mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty - (getSrcLoc name) + new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys + + mk_id name uniq ty + = let + name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n } + in + mkUserLocal name_str uniq ty (getSrcLoc name) in tcExtendLocalValEnv names new_ids (m new_ids) where @@ -312,7 +313,7 @@ newLocalIds names tys = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUniques (length names) `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys + new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc) in returnNF_Tc new_ids