X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=98db64c9760e61fb78ae2c9905e0a36be458a356;hp=497ba235da4b754d889c5220ffa202b360a7b112;hb=9319fbaf14f420cbbd9e670093cc86c5f04b7800;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 497ba23..98db64c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -1,3 +1,7 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -11,19 +15,19 @@ module TcEnv( tcExtendGlobalEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, - tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, + tcLookupLocatedClass, tcLookupFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendGhciEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, lclEnvElts, getInLocalScope, findGlobals, wrongThingErr, pprBinders, - refineEnvironment, tcExtendRecEnv, -- For knot-tying @@ -35,45 +39,41 @@ module TcEnv( -- Template Haskell stuff checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, - topIdLvl, + topIdLvl, thTopLevelId, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName, ) where #include "HsVersions.h" -import HsSyn ( LRuleDecl, LHsBinds, LSig, - LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds ) -import TcIface ( tcImportDecl ) -import IfaceEnv ( newGlobalBinder ) +import HsSyn +import TcIface +import IfaceEnv import TcRnMonad -import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, - getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, - tidyOpenType, isRefineableTy - ) -import qualified Type ( getTyVar_maybe ) -import Id ( idName, isLocalId, setIdType ) -import Var ( TyVar, Id, idType, tyVarName ) +import TcMType +import TcType +-- import TcSuspension +import qualified Type +import Var import VarSet import VarEnv -import RdrName ( extendLocalRdrEnv ) -import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) -import DataCon ( DataCon ) -import TyCon ( TyCon ) -import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName ) -import PrelNames ( thFAKE ) +import RdrName +import InstEnv +import FamInstEnv +import DataCon +import TyCon +import TypeRep +import Class +import Name +import PrelNames import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, - TyThing(..), tyThingId, tyThingDataCon, - ExternalPackageState(..) ) - -import SrcLoc ( SrcLoc, Located(..) ) +import OccName +import HscTypes +import SrcLoc import Outputable +import Maybes +import FastString \end{code} @@ -101,50 +101,68 @@ tcLookupGlobal name = do { env <- getGblEnv -- Try local envt - ; case lookupNameEnv (tcg_type_env env) name of { + ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; Nothing -> do -- Try global envt { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of { + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> do -- Should it have been in the local envt? - { let mod = nameModule name - ; if mod == tcg_mod env || mod == thFAKE then - notFound name -- It should be local, so panic - -- The thFAKE possibility is because it - -- might be in a declaration bracket - else - tcImportDecl name -- Go find it in an interface + { case nameModule_maybe name of + Nothing -> notFound name env -- Internal names can happen in GHCi + + Just mod | mod == tcg_mod env -- Names from this module + -> notFound name env -- should be in tcg_type_env + | mod == thFAKE -- Names bound in TH declaration brackets + -> notFound name env -- should be in tcg_env + | otherwise + -> tcImportDecl name -- Go find it in an interface }}}}} -tcLookupGlobalId :: Name -> TcM Id --- Never used for Haskell-source DataCons, hence no ADataCon case -tcLookupGlobalId name - = tcLookupGlobal name `thenM` \ thing -> - return (tyThingId thing) +tcLookupField :: Name -> TcM Id -- Returns the selector Id +tcLookupField name = do + thing <- tcLookup name -- Note [Record field lookup] + case thing of + AGlobal (AnId id) -> return id + thing -> wrongThingErr "field name" thing name + +{- Note [Record field lookup] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think we should have tcLookupGlobal here, since record fields +are always top level. But consider + f = e { f = True } +Then the renamer (which does not keep track of what is a record selector +and what is not) will rename the definition thus + f_7 = e { f_7 = True } +Now the type checker will find f_7 in the *local* type environment, not +the global one. It's wrong, of course, but we want to report a tidy +error, not in TcEnv.notFound. -} tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon con_name - = tcLookupGlobal con_name `thenM` \ thing -> - return (tyThingDataCon thing) +tcLookupDataCon name = do + thing <- tcLookupGlobal name + case thing of + ADataCon con -> return con + _ -> wrongThingErr "data constructor" (AGlobal thing) name tcLookupClass :: Name -> TcM Class -tcLookupClass name - = tcLookupGlobal name `thenM` \ thing -> +tcLookupClass name = do + thing <- tcLookupGlobal name case thing of AClass cls -> return cls - other -> wrongThingErr "class" (AGlobal thing) name - + _ -> wrongThingErr "class" (AGlobal thing) name + tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name - = tcLookupGlobal name `thenM` \ thing -> +tcLookupTyCon name = do + thing <- tcLookupGlobal name case thing of ATyCon tc -> return tc - other -> wrongThingErr "type constructor" (AGlobal thing) name + _ -> wrongThingErr "type constructor" (AGlobal thing) name tcLookupLocatedGlobalId :: Located Name -> TcM Id tcLookupLocatedGlobalId = addLocM tcLookupId @@ -154,6 +172,36 @@ tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Look up the instance tycon of a family instance. +-- +-- 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 (Maybe (TyCon, [Type])) +tcLookupFamInst tycon tys + | not (isOpenTyCon tycon) + = return Nothing + | otherwise + = do { env <- getGblEnv + ; eps <- getEps + ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) + ; case lookupFamInstEnv instEnv tycon tys of + [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst, + rep_tys) + _ -> return Nothing + } \end{code} %************************************************************************ @@ -200,59 +248,53 @@ tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup tcLookup :: Name -> TcM TcTyThing -tcLookup name - = getLclEnv `thenM` \ local_env -> +tcLookup name = do + local_env <- getLclEnv case lookupNameEnv (tcl_env local_env) name of - Just thing -> returnM thing - Nothing -> tcLookupGlobal name `thenM` \ thing -> - returnM (AGlobal thing) + Just thing -> return thing + Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name - = tcLookup name `thenM` \ thing -> +tcLookupTyVar name = do + thing <- tcLookup name case thing of ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty) - other -> pprPanic "tcLookupTyVar" (ppr name) + _ -> pprPanic "tcLookupTyVar" (ppr name) tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level --- Never a DataCon. (Why does that matter? see TcExpr.tcId) -tcLookupId name - = tcLookup name `thenM` \ thing -> +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) +tcLookupId name = do + thing <- tcLookup name case thing of - ATcId tc_id _ _ -> returnM tc_id - AGlobal (AnId id) -> returnM id - other -> pprPanic "tcLookupId" (ppr name) - -tcLookupLocalId_maybe :: Name -> TcM (Maybe Id) -tcLookupLocalId_maybe name - = getLclEnv `thenM` \ local_env -> - case lookupNameEnv (tcl_env local_env) name of - Just (ATcId tc_id _ _) -> return (Just tc_id) - other -> return Nothing + ATcId { tct_id = id} -> return id + AGlobal (AnId id) -> return id + _ -> pprPanic "tcLookupId" (ppr name) tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at -- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns - = getLclEnv `thenM` \ env -> - returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) +tcLookupLocalIds ns = do + env <- getLclEnv + return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) where lookup lenv lvl name = case lookupNameEnv lenv name of - Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id - other -> pprPanic "tcLookupLocalIds" (ppr name) + Just (ATcId { tct_id = id, tct_level = lvl1 }) + -> ASSERT( lvl == lvl1 ) id + _ -> pprPanic "tcLookupLocalIds" (ppr name) lclEnvElts :: TcLclEnv -> [TcTyThing] lclEnvElts env = nameEnvElts (tcl_env env) getInLocalScope :: TcM (Name -> Bool) -- Ids only -getInLocalScope = getLclEnv `thenM` \ env -> - let - lcl_env = tcl_env env - in - return (`elemNameEnv` lcl_env) +getInLocalScope = do + env <- getLclEnv + let lcl_env = tcl_env env + return (`elemNameEnv` lcl_env) \end{code} \begin{code} @@ -276,22 +318,22 @@ tcExtendTyVarEnv tvs thing_inside = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r -tcExtendTyVarEnv2 binds thing_inside - = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, - tcl_tyvars = gtvs, - tcl_rdr = rdr_env}) -> +tcExtendTyVarEnv2 binds thing_inside = do + env@(TcLclEnv {tcl_env = le, + tcl_tyvars = gtvs, + tcl_rdr = rdr_env}) <- getLclEnv let rdr_env' = extendLocalRdrEnv rdr_env (map fst binds) new_tv_set = tcTyVarsOfTypes (map snd binds) le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds] - in + -- It's important to add the in-scope tyvars to the global tyvar set -- as well. Consider -- f (_::r) = let g y = y::r in ... -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. - tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' -> + gtvs' <- tc_extend_gtvs gtvs new_tv_set setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside getScopedTyVarBinds :: TcM [(Name, TcType)] @@ -303,12 +345,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 @@ -317,20 +353,48 @@ 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 id th_lvl (isRefineableTy (idType id))) - | (name,id) <- names_w_ids] - 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 = case isRefineableTy id_ty of + (True,_) -> Unrefineable + (_,True) -> Rigid idHsWrapper + _ -> Wobbly}) + | (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} @@ -345,61 +409,52 @@ findGlobals :: TcTyVarSet -> TidyEnv -> TcM (TidyEnv, [SDoc]) -findGlobals tvs tidy_env - = getLclEnv `thenM` \ lcl_env -> +findGlobals tvs tidy_env = do + lcl_env <- getLclEnv go tidy_env [] (lclEnvElts lcl_env) where - go tidy_env acc [] = returnM (tidy_env, acc) - go tidy_env acc (thing : things) - = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) -> + go tidy_env acc [] = return (tidy_env, acc) + go tidy_env acc (thing : things) = do + (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing case maybe_doc of Just d -> go tidy_env1 (d:acc) things Nothing -> go tidy_env1 acc things - ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty) + ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty ----------------------- -find_thing ignore_it tidy_env (ATcId id _ _) - = zonkTcType (idType id) `thenM` \ id_ty -> +find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing + -> TcM (TidyEnv, Maybe SDoc) +find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do + id_ty <- zonkTcType (idType id) if ignore_it id_ty then - returnM (tidy_env, Nothing) - else let + return (tidy_env, Nothing) + else let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, - nest 2 (parens (ptext SLIT("bound at") <+> + nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] - in - returnM (tidy_env', Just msg) + in + return (tidy_env', Just msg) -find_thing ignore_it tidy_env (ATyVar tv ty) - = zonkTcType ty `thenM` \ tv_ty -> +find_thing ignore_it tidy_env (ATyVar tv ty) = do + tv_ty <- zonkTcType ty if ignore_it tv_ty then - returnM (tidy_env, Nothing) - else let + return (tidy_env, Nothing) + else let -- The name tv is scoped, so we don't need to tidy it (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty - msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at] + msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at] eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, getOccName tv == getOccName tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv) - in - returnM (tidy_env1, Just msg) -\end{code} + bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) + in + return (tidy_env1, Just msg) -\begin{code} -refineEnvironment :: TvSubst -> TcM a -> TcM a -refineEnvironment reft thing_inside - = do { env <- getLclEnv - ; let le' = mapNameEnv refine (tcl_env env) - ; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env) - ; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside } - where - refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True - refine (ATyVar tv ty) = ATyVar tv (substTy reft ty) - refine elt = elt +find_thing _ _ thing = pprPanic "find_thing" (ppr thing) \end{code} %************************************************************************ @@ -409,14 +464,10 @@ refineEnvironment reft thing_inside %************************************************************************ \begin{code} -tc_extend_gtvs gtvs extra_global_tvs - = readMutVar gtvs `thenM` \ global_tvs -> +tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet) +tc_extend_gtvs gtvs extra_global_tvs = do + global_tvs <- readMutVar gtvs newMutVar (global_tvs `unionVarSet` extra_global_tvs) - -refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet) -refineGlobalTyVars reft gtv_var - = readMutVar gtv_var `thenM` \ gbl_tvs -> - newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs))) \end{code} @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. @@ -425,12 +476,12 @@ the environment. \begin{code} tcGetGlobalTyVars :: TcM TcTyVarSet -tcGetGlobalTyVars - = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) -> - readMutVar gtv_var `thenM` \ gbl_tvs -> - zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' -> - writeMutVar gtv_var gbl_tvs' `thenM_` - returnM gbl_tvs' +tcGetGlobalTyVars = do + (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv + gbl_tvs <- readMutVar gtv_var + gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs) + writeMutVar gtv_var gbl_tvs' + return gbl_tvs' \end{code} @@ -474,23 +525,23 @@ thLevel (Brack l _ _) = l checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level + -> ThLevel -- Binding level (increases inside brackets) -> ThStage -- Use stage -> TcM () -- Fail if badly staged, adding an error checkWellStaged pp_thing bind_lvl use_stage - | bind_lvl <= use_lvl -- OK! - = returnM () + | use_lvl >= bind_lvl -- OK! Used later than bound + = return () -- E.g. \x -> [| $(f x) |] | bind_lvl == topLevel -- GHC restriction on top level splices = failWithTc $ - sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, - nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] + sep [ptext (sLit "GHC stage restriction:") <+> pp_thing, + nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))] | otherwise -- Badly staged - = failWithTc $ - ptext SLIT("Stage error:") <+> pp_thing <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] + = failWithTc $ -- E.g. \x -> $(f x) + ptext (sLit "Stage error:") <+> pp_thing <+> + hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, + ptext (sLit "but used at stage") <+> ppr use_lvl] where use_lvl = thLevel use_stage @@ -522,9 +573,13 @@ tcMetaTy :: Name -> TcM Type -- Given the name of a Template Haskell data type, -- return the type -- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name - = tcLookupTyCon tc_name `thenM` \ t -> - returnM (mkTyConApp t []) +tcMetaTy tc_name = do + t <- tcLookupTyCon tc_name + return (mkTyConApp t []) + +thTopLevelId :: Id -> Bool +-- See Note [What is a top-level Id?] in TcSplice +thTopLevelId id = isGlobalId id || isExternalName (idName id) \end{code} @@ -545,42 +600,43 @@ But local instance decls includes as well as explicit user written ones. \begin{code} -data InstInfo +data InstInfo a = InstInfo { iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings -- variables scope over the stuff in InstBindings! + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } -iDFunId :: InstInfo -> DFunId +iDFunId :: InstInfo a -> DFunId iDFunId info = instanceDFunId (iSpec info) -data InstBindings +data InstBindings a = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings - [LSig Name] -- User pragmas recorded for generating + (LHsBinds a) -- Bindings for the instance methods + [LSig a] -- User pragmas recorded for generating -- specialised instances - | NewTypeDerived -- Used for deriving instances of newtypes, where the - [Type] -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas - -- The [Type] are the representation types - -- See notes in TcDeriv + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] +pprInstInfo :: InstInfo a -> SDoc +pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] +pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where - details (VanillaInst b _) = pprLHsBinds b - details (NewTypeDerived _) = text "Derived from the representation type" + details (VanillaInst b _) = pprLHsBinds b + details NewTypeDerived = text "Derived from the representation type" -simpleInstInfoClsTy :: InstInfo -> (Class, Type) +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of - (_, _, cls, [ty]) -> (cls, ty) + (_, _, cls, [ty]) -> (cls, ty) + _ -> panic "simpleInstInfoClsTy" -simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy :: InstInfo a -> Type simpleInstInfoTy info = snd (simpleInstInfoClsTy info) -simpleInstInfoTyCon :: InstInfo -> TyCon +simpleInstInfoTyCon :: InstInfo a -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) @@ -590,7 +646,7 @@ Make a name for the dict fun for an instance decl. It's an *external* name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name newDFunName clas (ty:_) loc = do { index <- nextDFunIndex ; is_boot <- tcIsHsBoot @@ -599,11 +655,24 @@ newDFunName clas (ty:_) loc occNameString (getDFunTyKey ty) dfun_occ = mkDFunOcc info_string is_boot index - ; newGlobalBinder mod dfun_occ Nothing loc } + ; newGlobalBinder mod dfun_occ loc } newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} +Make a name for the representation tycon of a family instance. It's an +*external* name, like otber top-level names, and hence must be made with +newGlobalBinder. + +\begin{code} +newFamInstTyConName :: Name -> SrcSpan -> TcM Name +newFamInstTyConName tc_name loc + = do { index <- nextDFunIndex + ; mod <- getModule + ; let occ = nameOccName tc_name + ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +\end{code} + %************************************************************************ %* * @@ -618,11 +687,15 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound name - = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> - ptext SLIT("is not in scope")) +notFound :: Name -> TcGblEnv -> TcM TyThing +notFound name env + = failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> + ptext (sLit "is not in scope during type checking, but it passed the renamer"), + ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)] + ) +wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - ptext SLIT("used as a") <+> text expected) + ptext (sLit "used as a") <+> text expected) \end{code}