X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=116056bba3aa84cda270622cae6e618af353efbe;hb=8826579a0321cd053da4fbb2fd7e42e932383600;hp=ac55f4b16df5e1c5b6a1062e3bbc4ef87c5cb512;hpb=f014b60bba8432be6f89c0dc99a54988fb4475af;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index ac55f4b..116056b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -35,7 +35,6 @@ module TcEnv( tcLookupId, tcLookupTyVar, getScopedTyVarBinds, lclEnvElts, getInLocalScope, findGlobals, wrongThingErr, pprBinders, - refineEnvironment, tcExtendRecEnv, -- For knot-tying @@ -61,7 +60,6 @@ import IfaceEnv import TcRnMonad import TcMType import TcType -import TcGadt -- import TcSuspension import qualified Type import Var @@ -83,6 +81,7 @@ import HscTypes import SrcLoc import Outputable import Maybes +import FastString \end{code} @@ -135,10 +134,22 @@ tcLookupGlobal name tcLookupField :: Name -> TcM Id -- Returns the selector Id tcLookupField name = do - thing <- tcLookupGlobal name + thing <- tcLookup name -- Note [Record field lookup] case thing of - AnId id -> return id - other -> wrongThingErr "field name" (AGlobal thing) name + 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 name = do @@ -427,7 +438,7 @@ find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do 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 return (tidy_env', Just msg) @@ -439,51 +450,19 @@ find_thing ignore_it tidy_env (ATyVar tv ty) = do 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) + bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) in return (tidy_env1, Just msg) find_thing _ _ thing = pprPanic "find_thing" (ppr thing) \end{code} -\begin{code} -refineEnvironment - :: Refinement - -> Bool -- whether type equations are involved - -> 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 otherEquations thing_inside - | isEmptyRefinement reft -- Common case - , not otherEquations - = 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 = Rigid co, tct_type = ty }) - | Just (co', ty') <- refineType reft ty - = elt { tct_co = Rigid (WpCo co' <.> co), tct_type = ty' } - refine elt@(ATcId { tct_co = Wobbly}) --- Main new idea: make wobbly things invisible whenever there --- is a refinement of any sort --- | otherEquations - = elt { tct_co = WobblyInvisible} - 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} @@ -560,14 +539,14 @@ checkWellStaged pp_thing bind_lvl use_stage | 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 $ -- 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] + 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 @@ -645,7 +624,7 @@ data InstBindings -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] +pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where @@ -711,12 +690,12 @@ pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs 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)] + = 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 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}