3 TyThing(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
7 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
13 tcLookupLocatedGlobal, tcLookupGlobal,
14 tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
15 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
19 tcExtendKindEnv, tcExtendKindEnvTvs,
20 tcExtendTyVarEnv, tcExtendTyVarEnv2,
21 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
22 tcLookup, tcLookupLocated, tcLookupLocalIds,
23 tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
24 lclEnvElts, getInLocalScope, findGlobals,
25 wrongThingErr, pprBinders,
28 tcExtendRecEnv, -- For knot-tying
33 -- Global type variables
36 -- Template Haskell stuff
37 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
41 newLocalName, newDFunName, newFamInstTyConName
44 #include "HsVersions.h"
46 import HsSyn ( LRuleDecl, LHsBinds, LSig,
47 LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds,
49 import TcIface ( tcImportDecl )
50 import IfaceEnv ( newGlobalBinder )
52 import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
53 import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, PredType,
54 tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
55 getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
56 tidyOpenType, isRefineableTy
58 import TcGadt ( Refinement, refineType )
59 import qualified Type ( getTyVar_maybe )
60 import Id ( idName, isLocalId )
61 import Var ( TyVar, Id, idType, tyVarName )
64 import RdrName ( extendLocalRdrEnv )
65 import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead )
66 import DataCon ( DataCon )
67 import TyCon ( TyCon )
68 import Class ( Class )
69 import Name ( Name, NamedThing(..), getSrcLoc, nameModule_maybe, nameOccName )
70 import PrelNames ( thFAKE )
72 import OccName ( mkDFunOcc, occNameString, mkInstTyTcOcc )
73 import HscTypes ( extendTypeEnvList, lookupType, TyThing(..),
74 ExternalPackageState(..) )
75 import SrcLoc ( SrcLoc, Located(..) )
80 %************************************************************************
84 %************************************************************************
86 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
87 unless you know that the SrcSpan in the monad is already set to the
91 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
92 -- c.f. IfaceEnvEnv.tcIfaceGlobal
93 tcLookupLocatedGlobal name
94 = addLocM tcLookupGlobal name
96 tcLookupGlobal :: Name -> TcM TyThing
97 -- The Name is almost always an ExternalName, but not always
98 -- In GHCi, we may make command-line bindings (ghci> let x = True)
99 -- that bind a GlobalId, but with an InternalName
101 = do { env <- getGblEnv
104 ; case lookupNameEnv (tcg_type_env env) name of {
105 Just thing -> return thing ;
109 { (eps,hpt) <- getEpsAndHpt
111 ; case lookupType dflags hpt (eps_PTE eps) name of {
112 Just thing -> return thing ;
115 -- Should it have been in the local envt?
116 { case nameModule_maybe name of
117 Nothing -> notFound name -- Internal names can happen in GHCi
119 Just mod | mod == tcg_mod env -- Names from this module
120 -> notFound name -- should be in tcg_type_env
121 | mod == thFAKE -- Names bound in TH declaration brackets
122 -> notFound name -- should be in tcg_env
124 -> tcImportDecl name -- Go find it in an interface
127 tcLookupField :: Name -> TcM Id -- Returns the selector Id
129 = tcLookupGlobal name `thenM` \ thing ->
132 other -> wrongThingErr "field name" (AGlobal thing) name
134 tcLookupDataCon :: Name -> TcM DataCon
136 = tcLookupGlobal name `thenM` \ thing ->
138 ADataCon con -> return con
139 other -> wrongThingErr "data constructor" (AGlobal thing) name
141 tcLookupClass :: Name -> TcM Class
143 = tcLookupGlobal name `thenM` \ thing ->
145 AClass cls -> return cls
146 other -> wrongThingErr "class" (AGlobal thing) name
148 tcLookupTyCon :: Name -> TcM TyCon
150 = tcLookupGlobal name `thenM` \ thing ->
152 ATyCon tc -> return tc
153 other -> wrongThingErr "type constructor" (AGlobal thing) name
155 tcLookupLocatedGlobalId :: Located Name -> TcM Id
156 tcLookupLocatedGlobalId = addLocM tcLookupId
158 tcLookupLocatedClass :: Located Name -> TcM Class
159 tcLookupLocatedClass = addLocM tcLookupClass
161 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
162 tcLookupLocatedTyCon = addLocM tcLookupTyCon
165 %************************************************************************
167 Extending the global environment
169 %************************************************************************
173 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
174 -- Given a mixture of Ids, TyCons, Classes, all from the
175 -- module being compiled, extend the global environment
176 tcExtendGlobalEnv things thing_inside
177 = do { env <- getGblEnv
178 ; let ge' = extendTypeEnvList (tcg_type_env env) things
179 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
181 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
182 -- Same deal as tcExtendGlobalEnv, but for Ids
183 tcExtendGlobalValEnv ids thing_inside
184 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
188 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
189 -- Extend the global environments for the type/class knot tying game
190 tcExtendRecEnv gbl_stuff thing_inside
191 = updGblEnv upd thing_inside
193 upd env = env { tcg_type_env = extend (tcg_type_env env) }
194 extend env = extendNameEnvList env gbl_stuff
198 %************************************************************************
200 \subsection{The local environment}
202 %************************************************************************
205 tcLookupLocated :: Located Name -> TcM TcTyThing
206 tcLookupLocated = addLocM tcLookup
208 tcLookup :: Name -> TcM TcTyThing
210 = getLclEnv `thenM` \ local_env ->
211 case lookupNameEnv (tcl_env local_env) name of
212 Just thing -> returnM thing
213 Nothing -> tcLookupGlobal name `thenM` \ thing ->
214 returnM (AGlobal thing)
216 tcLookupTyVar :: Name -> TcM TcTyVar
218 = tcLookup name `thenM` \ thing ->
220 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
221 other -> pprPanic "tcLookupTyVar" (ppr name)
223 tcLookupId :: Name -> TcM Id
224 -- Used when we aren't interested in the binding level, nor refinement.
225 -- The "no refinement" part means that we return the un-refined Id regardless
227 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
229 = tcLookup name `thenM` \ thing ->
231 ATcId { tct_id = id} -> returnM id
232 AGlobal (AnId id) -> returnM id
233 other -> pprPanic "tcLookupId" (ppr name)
235 tcLookupLocalIds :: [Name] -> TcM [TcId]
236 -- We expect the variables to all be bound, and all at
237 -- the same level as the lookup. Only used in one place...
239 = getLclEnv `thenM` \ env ->
240 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
243 = case lookupNameEnv lenv name of
244 Just (ATcId { tct_id = id, tct_level = lvl1 })
245 -> ASSERT( lvl == lvl1 ) id
246 other -> pprPanic "tcLookupLocalIds" (ppr name)
248 lclEnvElts :: TcLclEnv -> [TcTyThing]
249 lclEnvElts env = nameEnvElts (tcl_env env)
251 getInLocalScope :: TcM (Name -> Bool)
253 getInLocalScope = getLclEnv `thenM` \ env ->
255 lcl_env = tcl_env env
257 return (`elemNameEnv` lcl_env)
261 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
262 tcExtendKindEnv things thing_inside
263 = updLclEnv upd thing_inside
265 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
266 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
268 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
269 tcExtendKindEnvTvs bndrs thing_inside
270 = updLclEnv upd thing_inside
272 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
273 extend env = extendNameEnvList env pairs
274 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
276 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
277 tcExtendTyVarEnv tvs thing_inside
278 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
280 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
281 tcExtendTyVarEnv2 binds thing_inside
282 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
284 tcl_rdr = rdr_env}) ->
286 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
287 new_tv_set = tcTyVarsOfTypes (map snd binds)
288 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
290 -- It's important to add the in-scope tyvars to the global tyvar set
292 -- f (_::r) = let g y = y::r in ...
293 -- Here, g mustn't be generalised. This is also important during
294 -- class and instance decls, when we mustn't generalise the class tyvars
295 -- when typechecking the methods.
296 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
297 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
299 getScopedTyVarBinds :: TcM [(Name, TcType)]
301 = do { lcl_env <- getLclEnv
302 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
307 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
308 -- Invariant: the TcIds are fully zonked. Reasons:
309 -- (a) The kinds of the forall'd type variables are defaulted
310 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
311 -- (b) There are no via-Indirect occurrences of the bound variables
312 -- in the types, because instantiation does not look through such things
313 -- (c) The call to tyVarsOfTypes is ok without looking through refs
314 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
316 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
317 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
319 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
320 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
321 tcExtendIdEnv2 names_w_ids thing_inside
322 = getLclEnv `thenM` \ env ->
324 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
325 th_lvl = thLevel (tcl_th_ctxt env)
326 extra_env = [ (name, ATcId { tct_id = id,
329 tct_co = if isRefineableTy id_ty
330 then Just idHsWrapper
332 | (name,id) <- names_w_ids, let id_ty = idType id]
333 le' = extendNameEnvList (tcl_env env) extra_env
334 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
336 traceTc (text "env2") `thenM_`
337 traceTc (text "env3" <+> ppr extra_env) `thenM_`
338 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
339 (traceTc (text "env4") `thenM_`
340 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
345 -----------------------
346 -- findGlobals looks at the value environment and finds values
347 -- whose types mention the offending type variable. It has to be
348 -- careful to zonk the Id's type first, so it has to be in the monad.
349 -- We must be careful to pass it a zonked type variable, too.
351 findGlobals :: TcTyVarSet
353 -> TcM (TidyEnv, [SDoc])
355 findGlobals tvs tidy_env
356 = getLclEnv `thenM` \ lcl_env ->
357 go tidy_env [] (lclEnvElts lcl_env)
359 go tidy_env acc [] = returnM (tidy_env, acc)
360 go tidy_env acc (thing : things)
361 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
363 Just d -> go tidy_env1 (d:acc) things
364 Nothing -> go tidy_env1 acc things
366 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
368 -----------------------
369 find_thing ignore_it tidy_env (ATcId { tct_id = id })
370 = zonkTcType (idType id) `thenM` \ id_ty ->
371 if ignore_it id_ty then
372 returnM (tidy_env, Nothing)
374 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
375 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
376 nest 2 (parens (ptext SLIT("bound at") <+>
377 ppr (getSrcLoc id)))]
379 returnM (tidy_env', Just msg)
381 find_thing ignore_it tidy_env (ATyVar tv ty)
382 = zonkTcType ty `thenM` \ tv_ty ->
383 if ignore_it tv_ty then
384 returnM (tidy_env, Nothing)
386 -- The name tv is scoped, so we don't need to tidy it
387 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
388 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
390 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
391 getOccName tv == getOccName tv' = empty
392 | otherwise = equals <+> ppr tidy_ty
393 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
394 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
396 returnM (tidy_env1, Just msg)
398 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
402 refineEnvironment :: Refinement -> TcM a -> TcM a
403 -- I don't think I have to refine the set of global type variables in scope
404 -- Reason: the refinement never increases that set
405 refineEnvironment reft thing_inside
406 = do { env <- getLclEnv
407 ; let le' = mapNameEnv refine (tcl_env env)
408 ; setLclEnv (env {tcl_env = le'}) thing_inside }
410 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
411 = let (co', ty') = refineType reft ty
412 in elt { tct_co = Just (co' <.> co), tct_type = ty' }
413 refine (ATyVar tv ty) = ATyVar tv (snd (refineType reft ty))
414 -- Ignore the coercion that refineType returns
418 %************************************************************************
420 \subsection{The global tyvars}
422 %************************************************************************
425 tc_extend_gtvs gtvs extra_global_tvs
426 = readMutVar gtvs `thenM` \ global_tvs ->
427 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
430 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
431 To improve subsequent calls to the same function it writes the zonked set back into
435 tcGetGlobalTyVars :: TcM TcTyVarSet
437 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
438 readMutVar gtv_var `thenM` \ gbl_tvs ->
439 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
440 writeMutVar gtv_var gbl_tvs' `thenM_`
445 %************************************************************************
449 %************************************************************************
452 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
453 -- Just pop the new rules into the EPS and envt resp
454 -- All the rules come from an interface file, not soruce
455 -- Nevertheless, some may be for this module, if we read
456 -- its interface instead of its source code
457 tcExtendRules lcl_rules thing_inside
458 = do { env <- getGblEnv
460 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
461 ; setGblEnv env' thing_inside }
465 %************************************************************************
469 %************************************************************************
472 instance Outputable ThStage where
473 ppr Comp = text "Comp"
474 ppr (Brack l _ _) = text "Brack" <+> int l
475 ppr (Splice l) = text "Splice" <+> int l
478 thLevel :: ThStage -> ThLevel
479 thLevel Comp = topLevel
480 thLevel (Splice l) = l
481 thLevel (Brack l _ _) = l
484 checkWellStaged :: SDoc -- What the stage check is for
485 -> ThLevel -- Binding level
486 -> ThStage -- Use stage
487 -> TcM () -- Fail if badly staged, adding an error
488 checkWellStaged pp_thing bind_lvl use_stage
489 | bind_lvl <= use_lvl -- OK!
492 | bind_lvl == topLevel -- GHC restriction on top level splices
494 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
495 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
497 | otherwise -- Badly staged
499 ptext SLIT("Stage error:") <+> pp_thing <+>
500 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
501 ptext SLIT("but used at stage") <+> ppr use_lvl]
503 use_lvl = thLevel use_stage
506 topIdLvl :: Id -> ThLevel
507 -- Globals may either be imported, or may be from an earlier "chunk"
508 -- (separated by declaration splices) of this module. The former
509 -- *can* be used inside a top-level splice, but the latter cannot.
510 -- Hence we give the former impLevel, but the latter topLevel
514 -- By the time we are prcessing the $(f x), the binding for "x"
515 -- will be in the global env, not the local one.
516 topIdLvl id | isLocalId id = topLevel
517 | otherwise = impLevel
519 -- Indicates the legal transitions on bracket( [| |] ).
520 bracketOK :: ThStage -> Maybe ThLevel
521 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
522 bracketOK stage = Just (thLevel stage + 1)
524 -- Indicates the legal transitions on splice($).
525 spliceOK :: ThStage -> Maybe ThLevel
526 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
527 spliceOK stage = Just (thLevel stage - 1)
529 tcMetaTy :: Name -> TcM Type
530 -- Given the name of a Template Haskell data type,
532 -- E.g. given the name "Expr" return the type "Expr"
534 = tcLookupTyCon tc_name `thenM` \ t ->
535 returnM (mkTyConApp t [])
539 %************************************************************************
541 \subsection{The InstInfo type}
543 %************************************************************************
545 The InstInfo type summarises the information in an instance declaration
547 instance c => k (t tvs) where b
549 It is used just for *local* instance decls (not ones from interface files).
550 But local instance decls includes
553 as well as explicit user written ones.
558 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
559 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
562 iDFunId :: InstInfo -> DFunId
563 iDFunId info = instanceDFunId (iSpec info)
566 = VanillaInst -- The normal case
567 (LHsBinds Name) -- Bindings
568 [LSig Name] -- User pragmas recorded for generating
569 -- specialised instances
571 | NewTypeDerived -- Used for deriving instances of newtypes, where the
572 -- witness dictionary is identical to the argument
573 -- dictionary. Hence no bindings, no pragmas.
575 -- Nothing => The newtype-derived instance involves type variables,
576 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
577 -- Just (r:scs) => The newtype-defined instance has no type variables
578 -- so the dfun is just a constant, df :: Eq T
579 -- In this case we need to know waht the rep dict, r, and the
580 -- superclasses, scs, are. (In the Nothing case these are in the
582 -- Invariant: these PredTypes have no free variables
583 -- NB: In both cases, the representation dict is the *first* dict.
585 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
587 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
589 details (VanillaInst b _) = pprLHsBinds b
590 details (NewTypeDerived _) = text "Derived from the representation type"
592 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
593 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
594 (_, _, cls, [ty]) -> (cls, ty)
596 simpleInstInfoTy :: InstInfo -> Type
597 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
599 simpleInstInfoTyCon :: InstInfo -> TyCon
600 -- Gets the type constructor for a simple instance declaration,
601 -- i.e. one of the form instance (...) => C (T a b c) where ...
602 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
605 Make a name for the dict fun for an instance decl. It's an *external*
606 name, like otber top-level names, and hence must be made with newGlobalBinder.
609 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
610 newDFunName clas (ty:_) loc
611 = do { index <- nextDFunIndex
612 ; is_boot <- tcIsHsBoot
614 ; let info_string = occNameString (getOccName clas) ++
615 occNameString (getDFunTyKey ty)
616 dfun_occ = mkDFunOcc info_string is_boot index
618 ; newGlobalBinder mod dfun_occ loc }
620 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
623 Make a name for the representation tycon of a data/newtype instance. It's an
624 *external* name, like otber top-level names, and hence must be made with
628 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
629 newFamInstTyConName tc_name loc
630 = do { index <- nextDFunIndex
632 ; let occ = nameOccName tc_name
633 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
637 %************************************************************************
641 %************************************************************************
644 pprBinders :: [Name] -> SDoc
645 -- Used in error messages
646 -- Use quotes for a single one; they look a bit "busy" for several
647 pprBinders [bndr] = quotes (ppr bndr)
648 pprBinders bndrs = pprWithCommas ppr bndrs
651 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
652 ptext SLIT("is not in scope"))
654 wrongThingErr expected thing name
655 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
656 ptext SLIT("used as a") <+> text expected)