X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=94daff05effce3077a785d7a584f21618c4dd3d7;hp=8f4fbc98838aae85025404e142af8bc1ad901ed7;hb=HEAD;hpb=13cd965d80be5c25dc54534a833df39ab7aa7a12 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 8f4fbc9..94daff0 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -12,66 +12,76 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, + tcExtendGlobalEnv, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupFamInst, + tcLookupLocatedClass, + tcLookupFamInst, tcLookupDataFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendGhciEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, - lclEnvElts, getInLocalScope, findGlobals, + getInLocalScope, wrongThingErr, pprBinders, - refineEnvironment, + getHetMetLevel, tcExtendRecEnv, -- For knot-tying -- Rules tcExtendRules, + -- Defaults + tcGetDefaultTys, + -- Global type variables tcGetGlobalTyVars, -- Template Haskell stuff - checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, - topIdLvl, + checkWellStaged, tcMetaTy, thLevel, + topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids - newLocalName, newDFunName, newFamInstTyConName + newLocalName, newDFunName, newFamInstTyConName, + mkStableIdFromString, mkStableIdFromName ) where #include "HsVersions.h" import HsSyn -import TcIface import IfaceEnv import TcRnMonad import TcMType import TcType -import TcGadt -import qualified Type +import TcIface +import PrelNames +import TysWiredIn +-- import qualified Type import Id +import Coercion import Var import VarSet -import VarEnv +-- import VarEnv import RdrName import InstEnv import FamInstEnv import DataCon import TyCon +import TypeRep import Class import Name -import PrelNames import NameEnv -import OccName import HscTypes +import DynFlags import SrcLoc import Outputable +import Unique +import FastString \end{code} @@ -99,56 +109,63 @@ 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 - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do -- Should it have been in the local envt? { case nameModule_maybe name of - Nothing -> notFound name -- Internal names can happen in GHCi + Nothing -> notFound name -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env - | mod == thFAKE -- Names bound in TH declaration brackets - -> notFound name -- should be in tcg_env + -> notFound name -- should be in tcg_type_env | otherwise -> tcImportDecl name -- Go find it in an interface }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id -tcLookupField name - = tcLookupGlobal name `thenM` \ thing -> - case thing of - AnId id -> return id - other -> wrongThingErr "field name" (AGlobal thing) name +tcLookupField name + = tcLookupId name -- Note [Record field lookup] + +{- 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 (imported) one. It's wrong, of course, but we want to report a tidy +error, not in TcEnv.notFound. -} tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name - = tcLookupGlobal name `thenM` \ thing -> +tcLookupDataCon name = do + thing <- tcLookupGlobal name case thing of ADataCon con -> return con - other -> wrongThingErr "data constructor" (AGlobal thing) name + _ -> 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 @@ -159,32 +176,87 @@ tcLookupLocatedClass = addLocM tcLookupClass 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 -tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) +-- Look up the instance tycon of a family instance. +-- +-- The match may be ambiguous (as we know that overlapping instances have +-- identical right-hand sides under overlapping substitutions - see +-- 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used +-- for matching must be equal to or be more specific than those of the family +-- instance declaration. We pick one of the matches in case of ambiguity; as +-- the right-hand sides are identical under the match substitution, the choice +-- does not matter. +-- +-- 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 (tycon, tys) + | not (isFamilyTyCon tycon) + = return Nothing | otherwise = do { env <- getGblEnv ; eps <- getEps ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv) ; 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 + [] -> return Nothing + ((fam_inst, rep_tys):_) + -> return $ Just (famInstTyCon fam_inst, rep_tys) } + +tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) +-- Find the instance of a data family +-- Note [Looking up family instances for deriving] +tcLookupDataFamInst tycon tys + | not (isFamilyTyCon tycon) + = return (tycon, tys) + | otherwise + = ASSERT( isAlgTyCon tycon ) + do { maybeFamInst <- tcLookupFamInst tycon tys + ; case maybeFamInst of + Nothing -> famInstNotFound tycon tys + Just famInst -> return famInst } + +famInstNotFound :: TyCon -> [Type] -> TcM a +famInstNotFound tycon tys + = failWithTc (ptext (sLit "No family instance for") + <+> quotes (pprTypeApp tycon tys)) +\end{code} + +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declrations. + +\begin{code} +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal \end{code} %************************************************************************ @@ -195,28 +267,37 @@ tcLookupFamInst tycon tys \begin{code} +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r -- Given a mixture of Ids, TyCons, Classes, all from the -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env env) things - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside -\end{code} -\begin{code} tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs tcExtendRecEnv gbl_stuff thing_inside - = updGblEnv upd thing_inside - where - upd env = env { tcg_type_env = extend (tcg_type_env env) } - extend env = extendNameEnvList env gbl_stuff + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } \end{code} @@ -231,55 +312,48 @@ tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup tcLookup :: Name -> TcM TcTyThing -tcLookup name - = getLclEnv `thenM` \ local_env -> - case lookupNameEnv (tcl_env local_env) name of - Just thing -> returnM thing - Nothing -> tcLookupGlobal name `thenM` \ thing -> - returnM (AGlobal thing) +tcLookup name = do + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of + 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, 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 - = tcLookup name `thenM` \ thing -> +tcLookupId name = do + thing <- tcLookup name case thing of - ATcId { tct_id = id} -> returnM id - AGlobal (AnId id) -> returnM id - other -> pprPanic "tcLookupId" (ppr name) + 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 { tct_id = id, tct_level = lvl1 }) -> ASSERT( lvl == lvl1 ) id - other -> pprPanic "tcLookupLocalIds" (ppr name) - -lclEnvElts :: TcLclEnv -> [TcTyThing] -lclEnvElts env = nameEnvElts (tcl_env env) + _ -> pprPanic "tcLookupLocalIds" (ppr name) getInLocalScope :: TcM (Name -> Bool) -- Ids only -getInLocalScope = getLclEnv `thenM` \ env -> - let - lcl_env = tcl_env env - in - return (`elemNameEnv` lcl_env) +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } \end{code} \begin{code} @@ -290,35 +364,32 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r +tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r tcExtendKindEnvTvs bndrs thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env pairs - pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs] + = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) + (thing_inside bndrs) tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r 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) + rdr_env' = extendLocalRdrEnvList 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' <- tcExtendGlobalTyVars gtvs new_tv_set setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside getScopedTyVarBinds :: TcM [(Name, TcType)] @@ -330,145 +401,67 @@ 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 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside +getHetMetLevel :: TcM [TyVar] +getHetMetLevel = + do { env <- getEnv + ; return $ case env of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x + } + 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) -\end{code} - - -\begin{code} ------------------------ --- findGlobals looks at the value environment and finds values --- whose types mention the offending type variable. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. - -findGlobals :: TcTyVarSet - -> TidyEnv - -> TcM (TidyEnv, [SDoc]) - -findGlobals tvs tidy_env - = getLclEnv `thenM` \ lcl_env -> - 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) -> - case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things - - ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty - ------------------------ -find_thing ignore_it tidy_env (ATcId { tct_id = id }) - = zonkTcType (idType id) `thenM` \ id_ty -> - if ignore_it id_ty then - returnM (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") <+> - ppr (getSrcLoc id)))] - in - returnM (tidy_env', Just msg) - -find_thing ignore_it tidy_env (ATyVar tv ty) - = zonkTcType ty `thenM` \ tv_ty -> - if ignore_it tv_ty then - returnM (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] - - 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) - -find_thing _ _ thing = pprPanic "find_thing" (ppr thing) -\end{code} - -\begin{code} -refineEnvironment :: Refinement -> TcM a -> TcM a --- I don't think I have to refine the set of global type variables in scope --- Reason: the refinement never increases that set -refineEnvironment reft thing_inside - | isEmptyRefinement reft -- Common case - = thing_inside - | otherwise = do { env <- getLclEnv - ; let le' = mapNameEnv refine (tcl_env env) - ; setLclEnv (env {tcl_env = le'}) thing_inside } - where - refine elt@(ATcId { tct_co = Just co, tct_type = ty }) - | Just (co', ty') <- refineType reft ty - = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' } - refine (ATyVar tv ty) - | Just (_, ty') <- refineType reft ty - = ATyVar tv ty' -- Ignore the coercion that refineType returns - - refine elt = elt -- Common case -\end{code} - -%************************************************************************ -%* * -\subsection{The global tyvars} -%* * -%************************************************************************ + ; hetMetLevel <- getHetMetLevel + ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) hetMetLevel names_w_ids thing_inside } -\begin{code} -tc_extend_gtvs gtvs extra_global_tvs - = readMutVar gtvs `thenM` \ global_tvs -> - newMutVar (global_tvs `unionVarSet` extra_global_tvs) -\end{code} -@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. -To improve subsequent calls to the same function it writes the zonked set back into -the environment. +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 + ; hetMetLevel <- getHetMetLevel + ; tc_extend_local_id_env env impLevel hetMetLevel [(idName id, id) | id <- ids] thing_inside } + +tc_extend_local_id_env -- This is the guy who does the work + :: TcLclEnv + -> ThLevel + -> [TyVar] + -> [(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 -\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' +tc_extend_local_id_env env th_lvl hetMetLevel names_w_ids thing_inside + = do { traceTc "env2" (ppr extra_env) + ; gtvs' <- tcExtendGlobalTyVars (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_hetMetLevel = hetMetLevel + }) + | (name,id) <- names_w_ids] + le' = extendNameEnvList (tcl_env env) extra_env + rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids] + +tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) +tcExtendGlobalTyVars gtv_var extra_global_tvs + = do { global_tvs <- readMutVar gtv_var + ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) } \end{code} @@ -481,7 +474,7 @@ tcGetGlobalTyVars \begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce + -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read -- its interface instead of its source code tcExtendRules lcl_rules thing_inside @@ -499,39 +492,25 @@ tcExtendRules lcl_rules thing_inside %************************************************************************ \begin{code} -instance Outputable ThStage where - ppr Comp = text "Comp" - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel Comp = topLevel -thLevel (Splice l) = l -thLevel (Brack l _ _) = l - - checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level - -> ThStage -- Use stage + -> ThLevel -- Binding level (increases inside brackets) + -> ThLevel -- Use stage -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_stage - | bind_lvl <= use_lvl -- OK! - = returnM () +checkWellStaged pp_thing bind_lvl use_lvl + | use_lvl >= bind_lvl -- OK! Used later than bound + = return () -- E.g. \x -> [| $(f x) |] - | bind_lvl == topLevel -- GHC restriction on top level splices + | bind_lvl == outerLevel -- 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 (vcat [ ptext (sLit "is used in a top-level splice or annotation,") + , ptext (sLit "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] - where - use_lvl = thLevel use_stage - + = 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] topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -543,28 +522,84 @@ topIdLvl :: Id -> ThLevel -- $( f x ) -- By the time we are prcessing the $(f x), the binding for "x" -- will be in the global env, not the local one. -topIdLvl id | isLocalId id = topLevel +topIdLvl id | isLocalId id = outerLevel | otherwise = impLevel --- Indicates the legal transitions on bracket( [| |] ). -bracketOK :: ThStage -> Maybe ThLevel -bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket -bracketOK stage = Just (thLevel stage + 1) - --- Indicates the legal transitions on splice($). -spliceOK :: ThStage -> Maybe ThLevel -spliceOK (Splice _) = Nothing -- Splice illegal inside splice -spliceOK stage = Just (thLevel stage - 1) - 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 []) + +thRnBrack :: ThStage +-- Used *only* to indicate that we are inside a TH bracket during renaming +-- Tested by TcEnv.isBrackStage +-- See Note [Top-level Names in Template Haskell decl quotes] +thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3") + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + +thTopLevelId :: Id -> Bool +-- See Note [What is a top-level Id?] in TcSplice +thTopLevelId id = isGlobalId id || isExternalName (idName id) +\end{code} + + +%************************************************************************ +%* * + getDefaultTys +%* * +%************************************************************************ + +\begin{code} +tcGetDefaultTys :: Bool -- True <=> interactive context + -> TcM ([Type], -- Default types + (Bool, -- True <=> Use overloaded strings + Bool)) -- True <=> Use extended defaulting rules +tcGetDefaultTys interactive + = do { dflags <- getDOpts + ; let ovl_strings = xopt Opt_OverloadedStrings dflags + extended_defaults = interactive + || xopt Opt_ExtendedDefaultRules dflags + -- See also Trac #1974 + flags = (ovl_strings, extended_defaults) + + ; mb_defaults <- getDeclaredDefaultTys + ; case mb_defaults of { + Just tys -> return (tys, flags) ; + -- User-supplied defaults + Nothing -> do + + -- No use-supplied default + -- Use [Integer, Double], plus modifications + { integer_ty <- tcMetaTy integerTyConName + ; checkWiredInTyCon doubleTyCon + ; string_ty <- tcMetaTy stringTyConName + ; let deflt_tys = opt_deflt extended_defaults unitTy -- Note [Default unitTy] + ++ [integer_ty, doubleTy] + ++ opt_deflt ovl_strings string_ty + ; return (deflt_tys, flags) } } } + where + opt_deflt True ty = [ty] + opt_deflt False _ = [] \end{code} +Note [Default unitTy] +~~~~~~~~~~~~~~~~~~~~~ +In interative mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See Trac #1200. + %************************************************************************ %* * @@ -583,50 +618,62 @@ 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! + iSpec :: Instance, -- Includes the dfun id. Its forall'd type + 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 + Bool -- True <=> This code came from a standalone deriving clause + -- Used only to improve error messages + + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. + + Coercion -- The coercion maps from newtype to the representation type + -- (mentioning type variables bound by the forall'd iSpec variables) + -- E.g. newtype instance N [a] = N1 (Tree a) + -- co : N [a] ~ Tree a + + TyCon -- The TyCon is the newtype N. If it's indexed, then it's the + -- representation TyCon, so that tyConDataCons returns [N1], + -- the "data constructor". + -- See Note [Newtype deriving and unused constructors] + -- in TcDeriv + +pprInstInfo :: InstInfo a -> SDoc +pprInstInfo info = hang (ptext (sLit "instance")) + 2 (sep [ ifPprDebug (pprForAll tvs) + , pprThetaArrowTy theta, ppr tau + , ptext (sLit "where")]) + where + (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) - | NewTypeDerived -- Used for deriving instances of newtypes, where the - -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas. - (Maybe [PredType]) - -- Nothing => The newtype-derived instance involves type variables, - -- and the dfun has a type like df :: forall a. Eq a => Eq (T a) - -- Just (r:scs) => The newtype-defined instance has no type variables - -- so the dfun is just a constant, df :: Eq T - -- In this case we need to know waht the rep dict, r, and the - -- superclasses, scs, are. (In the Nothing case these are in the - -- dict fun's type.) - -- Invariant: these PredTypes have no free variables - -- NB: In both cases, the representation dict is the *first* dict. - -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) @@ -636,33 +683,51 @@ 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 clas (ty:_) loc - = do { index <- nextDFunIndex - ; is_boot <- tcIsHsBoot +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name +newDFunName clas tys loc + = do { is_boot <- tcIsHsBoot ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - occNameString (getDFunTyKey ty) - dfun_occ = mkDFunOcc info_string is_boot index - + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; 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 +*external* name, like other top-level names, and hence must be made with newGlobalBinder. \begin{code} -newFamInstTyConName :: Name -> SrcLoc -> TcM Name -newFamInstTyConName tc_name loc - = do { index <- nextDFunIndex - ; mod <- getModule - ; let occ = nameOccName tc_name - ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name +newFamInstTyConName tc_name tys loc + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + concatMap (occNameString.getDFunTyKey) tys + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod occ loc } \end{code} +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. + +\begin{code} +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + let uniq_str = showSDoc (pprUnique uniq) :: String + occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedLocalId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) +\end{code} %************************************************************************ %* * @@ -677,18 +742,17 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs +notFound :: Name -> TcM TyThing notFound name - = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> - ptext SLIT("is not in scope")) - + = do { (gbl,lcl) <- getEnvs + ; 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 gbl), + ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)] + ) } + +wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - ptext SLIT("used as a") <+> text expected) - -famInstNotFound tycon tys what - = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys)) - where - msg = ptext $ if length what > 1 - then SLIT("More than one family instance for") - else SLIT("No family instance exactly matching") + ptext (sLit "used as a") <+> text expected) \end{code}