X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=330e73b8a23efea76c33a975d0c2ff57aa02fba5;hb=b99310f05faee2abec850da4349fcd5c0498f7ca;hp=787616aa3e60c0c9f6a106cae148ffe898c85371;hpb=940524aec90652b5ef81789c9a453c57c0e42cc9;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 787616a..330e73b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -22,6 +22,7 @@ module TcEnv( -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendGhciEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, @@ -42,7 +43,10 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName, newFamInstTyConName + newLocalName, newDFunName, newFamInstTyConName, + + -- Errors + famInstNotFound ) where #include "HsVersions.h" @@ -159,7 +163,21 @@ tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Look up the representation tycon of a family instance. --- Return the rep tycon and the corresponding rep args +-- +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of +-- the family instance declaration. +-- +-- Return the instance tycon and its type instance. For example, if we have +-- +-- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') +-- +-- then we have a coercion (ie, type instance of family instance coercion) +-- +-- :Co:R42T Int :: T [Int] ~ :R42T Int +-- +-- which implies that :R42T was declared as 'data instance T [a]'. +-- tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) tcLookupFamInst tycon tys | not (isOpenTyCon tycon) @@ -169,20 +187,8 @@ tcLookupFamInst tycon tys ; eps <- getEps ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) ; case lookupFamInstEnv instEnv tycon tys of - - [(subst, fam_inst)] | variable_only_subst -> - return (rep_tc, substTyVars subst (tyConTyVars rep_tc)) - where -- NB: assumption is that (tyConTyVars rep_tc) is in - -- the domain of the substitution - rep_tc = famInstTyCon fam_inst - subst_domain = varEnvElts . getTvSubstEnv $ subst - tvs = map (Type.getTyVar "tcLookupFamInst") - subst_domain - variable_only_subst = all Type.isTyVarTy subst_domain && - sizeVarSet (mkVarSet tvs) == length tvs - -- renaming may have no repetitions - - other -> famInstNotFound tycon tys other + [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys) + other -> famInstNotFound tycon tys other } \end{code} @@ -329,12 +335,6 @@ getScopedTyVarBinds \begin{code} tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- Invariant: the TcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in zonkQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyVarsOfTypes is ok without looking through refs tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a @@ -343,25 +343,47 @@ tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside - = getLclEnv `thenM` \ env -> - let - extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] - th_lvl = thLevel (tcl_th_ctxt env) - extra_env = [ (name, ATcId { tct_id = id, - tct_level = th_lvl, - tct_type = id_ty, - tct_co = if isRefineableTy id_ty - then Just idHsWrapper - else Nothing }) - | (name,id) <- names_w_ids, let id_ty = idType id] - le' = extendNameEnvList (tcl_env env) extra_env - rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids] - in - traceTc (text "env2") `thenM_` - traceTc (text "env3" <+> ppr extra_env) `thenM_` - tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' -> - (traceTc (text "env4") `thenM_` - setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside) + = do { env <- getLclEnv + ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside } + +tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a +-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction +-- Note especially that we bind them at TH level 'impLevel'. That's because it's +-- OK to use a variable bound earlier in the interaction in a splice, becuase +-- GHCi has already compiled it to bytecode +tcExtendGhciEnv ids thing_inside + = do { env <- getLclEnv + ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside } + +tc_extend_local_id_env -- This is the guy who does the work + :: TcLclEnv + -> ThLevel + -> [(Name,TcId)] + -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in zonkQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyVarsOfTypes is ok without looking through refs + +tc_extend_local_id_env env th_lvl names_w_ids thing_inside + = do { traceTc (text "env2") + ; traceTc (text "env3" <+> ppr extra_env) + ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars + ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'} + ; setLclEnv env' thing_inside } + where + extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] + extra_env = [ (name, ATcId { tct_id = id, + tct_level = th_lvl, + tct_type = id_ty, + tct_co = if isRefineableTy id_ty + then Just idHsWrapper + else Nothing }) + | (name,id) <- names_w_ids, let id_ty = idType id] + le' = extendNameEnvList (tcl_env env) extra_env + rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids] \end{code} @@ -685,7 +707,7 @@ wrongThingErr expected thing name ptext SLIT("used as a") <+> text expected) famInstNotFound tycon tys what - = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys)) + = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys)) where msg = ptext $ if length what > 1 then SLIT("More than one family instance for")