tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
lclEnvElts, getInLocalScope, findGlobals,
wrongThingErr, pprBinders,
- refineEnvironment,
tcExtendRecEnv, -- For knot-tying
import TcRnMonad
import TcMType
import TcType
-import TcGadt
-- import TcSuspension
import qualified Type
import Var
import SrcLoc
import Outputable
import Maybes
+import FastString
\end{code}
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
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)
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}
| 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
-- 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
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}
projects / ghc-hetmet.git / blobdiff