2 % (c) The University of Glasgow 2006
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 TyThing(..), TcTyThing(..), TcId,
16 -- Instance environment, and InstInfo type
17 InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
18 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
24 tcLookupLocatedGlobal, tcLookupGlobal,
25 tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
26 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
27 tcLookupLocatedClass, tcLookupFamInst,
30 tcExtendKindEnv, tcExtendKindEnvTvs,
31 tcExtendTyVarEnv, tcExtendTyVarEnv2,
33 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
34 tcLookup, tcLookupLocated, tcLookupLocalIds,
35 tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
36 lclEnvElts, getInLocalScope, findGlobals,
37 wrongThingErr, pprBinders,
39 tcExtendRecEnv, -- For knot-tying
44 -- Global type variables
47 -- Template Haskell stuff
48 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
49 topIdLvl, thTopLevelId,
52 newLocalName, newDFunName, newFamInstTyConName,
55 #include "HsVersions.h"
63 -- import TcSuspension
88 %************************************************************************
92 %************************************************************************
94 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
95 unless you know that the SrcSpan in the monad is already set to the
99 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
100 -- c.f. IfaceEnvEnv.tcIfaceGlobal
101 tcLookupLocatedGlobal name
102 = addLocM tcLookupGlobal name
104 tcLookupGlobal :: Name -> TcM TyThing
105 -- The Name is almost always an ExternalName, but not always
106 -- In GHCi, we may make command-line bindings (ghci> let x = True)
107 -- that bind a GlobalId, but with an InternalName
109 = do { env <- getGblEnv
112 ; case lookupNameEnv (tcg_type_env env) name of {
113 Just thing -> return thing ;
117 { (eps,hpt) <- getEpsAndHpt
119 ; case lookupType dflags hpt (eps_PTE eps) name of {
120 Just thing -> return thing ;
123 -- Should it have been in the local envt?
124 { case nameModule_maybe name of
125 Nothing -> notFound name env -- Internal names can happen in GHCi
127 Just mod | mod == tcg_mod env -- Names from this module
128 -> notFound name env -- should be in tcg_type_env
129 | mod == thFAKE -- Names bound in TH declaration brackets
130 -> notFound name env -- should be in tcg_env
132 -> tcImportDecl name -- Go find it in an interface
135 tcLookupField :: Name -> TcM Id -- Returns the selector Id
136 tcLookupField name = do
137 thing <- tcLookup name -- Note [Record field lookup]
139 AGlobal (AnId id) -> return id
140 thing -> wrongThingErr "field name" thing name
142 {- Note [Record field lookup]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~
144 You might think we should have tcLookupGlobal here, since record fields
145 are always top level. But consider
147 Then the renamer (which does not keep track of what is a record selector
148 and what is not) will rename the definition thus
149 f_7 = e { f_7 = True }
150 Now the type checker will find f_7 in the *local* type environment, not
151 the global one. It's wrong, of course, but we want to report a tidy
152 error, not in TcEnv.notFound. -}
154 tcLookupDataCon :: Name -> TcM DataCon
155 tcLookupDataCon name = do
156 thing <- tcLookupGlobal name
158 ADataCon con -> return con
159 other -> wrongThingErr "data constructor" (AGlobal thing) name
161 tcLookupClass :: Name -> TcM Class
162 tcLookupClass name = do
163 thing <- tcLookupGlobal name
165 AClass cls -> return cls
166 other -> wrongThingErr "class" (AGlobal thing) name
168 tcLookupTyCon :: Name -> TcM TyCon
169 tcLookupTyCon name = do
170 thing <- tcLookupGlobal name
172 ATyCon tc -> return tc
173 other -> wrongThingErr "type constructor" (AGlobal thing) name
175 tcLookupLocatedGlobalId :: Located Name -> TcM Id
176 tcLookupLocatedGlobalId = addLocM tcLookupId
178 tcLookupLocatedClass :: Located Name -> TcM Class
179 tcLookupLocatedClass = addLocM tcLookupClass
181 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
182 tcLookupLocatedTyCon = addLocM tcLookupTyCon
184 -- Look up the instance tycon of a family instance.
186 -- The match must be unique - ie, match exactly one instance - but the
187 -- type arguments used for matching may be more specific than those of
188 -- the family instance declaration.
190 -- Return the instance tycon and its type instance. For example, if we have
192 -- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
194 -- then we have a coercion (ie, type instance of family instance coercion)
196 -- :Co:R42T Int :: T [Int] ~ :R42T Int
198 -- which implies that :R42T was declared as 'data instance T [a]'.
200 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
201 tcLookupFamInst tycon tys
202 | not (isOpenTyCon tycon)
205 = do { env <- getGblEnv
207 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
208 ; case lookupFamInstEnv instEnv tycon tys of
209 [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
211 other -> return Nothing
215 %************************************************************************
217 Extending the global environment
219 %************************************************************************
223 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
224 -- Given a mixture of Ids, TyCons, Classes, all from the
225 -- module being compiled, extend the global environment
226 tcExtendGlobalEnv things thing_inside
227 = do { env <- getGblEnv
228 ; let ge' = extendTypeEnvList (tcg_type_env env) things
229 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
231 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
232 -- Same deal as tcExtendGlobalEnv, but for Ids
233 tcExtendGlobalValEnv ids thing_inside
234 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
238 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
239 -- Extend the global environments for the type/class knot tying game
240 tcExtendRecEnv gbl_stuff thing_inside
241 = updGblEnv upd thing_inside
243 upd env = env { tcg_type_env = extend (tcg_type_env env) }
244 extend env = extendNameEnvList env gbl_stuff
248 %************************************************************************
250 \subsection{The local environment}
252 %************************************************************************
255 tcLookupLocated :: Located Name -> TcM TcTyThing
256 tcLookupLocated = addLocM tcLookup
258 tcLookup :: Name -> TcM TcTyThing
260 local_env <- getLclEnv
261 case lookupNameEnv (tcl_env local_env) name of
262 Just thing -> return thing
263 Nothing -> AGlobal <$> tcLookupGlobal name
265 tcLookupTyVar :: Name -> TcM TcTyVar
266 tcLookupTyVar name = do
267 thing <- tcLookup name
269 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
270 other -> pprPanic "tcLookupTyVar" (ppr name)
272 tcLookupId :: Name -> TcM Id
273 -- Used when we aren't interested in the binding level, nor refinement.
274 -- The "no refinement" part means that we return the un-refined Id regardless
276 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
278 thing <- tcLookup name
280 ATcId { tct_id = id} -> return id
281 AGlobal (AnId id) -> return id
282 other -> pprPanic "tcLookupId" (ppr name)
284 tcLookupLocalIds :: [Name] -> TcM [TcId]
285 -- We expect the variables to all be bound, and all at
286 -- the same level as the lookup. Only used in one place...
287 tcLookupLocalIds ns = do
289 return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
292 = case lookupNameEnv lenv name of
293 Just (ATcId { tct_id = id, tct_level = lvl1 })
294 -> ASSERT( lvl == lvl1 ) id
295 other -> pprPanic "tcLookupLocalIds" (ppr name)
297 lclEnvElts :: TcLclEnv -> [TcTyThing]
298 lclEnvElts env = nameEnvElts (tcl_env env)
300 getInLocalScope :: TcM (Name -> Bool)
304 let lcl_env = tcl_env env
305 return (`elemNameEnv` lcl_env)
309 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
310 tcExtendKindEnv things thing_inside
311 = updLclEnv upd thing_inside
313 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
314 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
316 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
317 tcExtendKindEnvTvs bndrs thing_inside
318 = updLclEnv upd thing_inside
320 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
321 extend env = extendNameEnvList env pairs
322 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
324 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
325 tcExtendTyVarEnv tvs thing_inside
326 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
328 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
329 tcExtendTyVarEnv2 binds thing_inside = do
330 env@(TcLclEnv {tcl_env = le,
332 tcl_rdr = rdr_env}) <- getLclEnv
334 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
335 new_tv_set = tcTyVarsOfTypes (map snd binds)
336 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
338 -- It's important to add the in-scope tyvars to the global tyvar set
340 -- f (_::r) = let g y = y::r in ...
341 -- Here, g mustn't be generalised. This is also important during
342 -- class and instance decls, when we mustn't generalise the class tyvars
343 -- when typechecking the methods.
344 gtvs' <- tc_extend_gtvs gtvs new_tv_set
345 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
347 getScopedTyVarBinds :: TcM [(Name, TcType)]
349 = do { lcl_env <- getLclEnv
350 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
355 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
356 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
358 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
359 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
361 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
362 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
363 tcExtendIdEnv2 names_w_ids thing_inside
364 = do { env <- getLclEnv
365 ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
367 tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
368 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
369 -- Note especially that we bind them at TH level 'impLevel'. That's because it's
370 -- OK to use a variable bound earlier in the interaction in a splice, becuase
371 -- GHCi has already compiled it to bytecode
372 tcExtendGhciEnv ids thing_inside
373 = do { env <- getLclEnv
374 ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
376 tc_extend_local_id_env -- This is the guy who does the work
381 -- Invariant: the TcIds are fully zonked. Reasons:
382 -- (a) The kinds of the forall'd type variables are defaulted
383 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
384 -- (b) There are no via-Indirect occurrences of the bound variables
385 -- in the types, because instantiation does not look through such things
386 -- (c) The call to tyVarsOfTypes is ok without looking through refs
388 tc_extend_local_id_env env th_lvl names_w_ids thing_inside
389 = do { traceTc (text "env2")
390 ; traceTc (text "env3" <+> ppr extra_env)
391 ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
392 ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
393 ; setLclEnv env' thing_inside }
395 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
396 extra_env = [ (name, ATcId { tct_id = id,
399 tct_co = case isRefineableTy id_ty of
400 (True,_) -> Unrefineable
401 (_,True) -> Rigid idHsWrapper
403 | (name,id) <- names_w_ids, let id_ty = idType id]
404 le' = extendNameEnvList (tcl_env env) extra_env
405 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
410 -----------------------
411 -- findGlobals looks at the value environment and finds values
412 -- whose types mention the offending type variable. It has to be
413 -- careful to zonk the Id's type first, so it has to be in the monad.
414 -- We must be careful to pass it a zonked type variable, too.
416 findGlobals :: TcTyVarSet
418 -> TcM (TidyEnv, [SDoc])
420 findGlobals tvs tidy_env = do
422 go tidy_env [] (lclEnvElts lcl_env)
424 go tidy_env acc [] = return (tidy_env, acc)
425 go tidy_env acc (thing : things) = do
426 (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
428 Just d -> go tidy_env1 (d:acc) things
429 Nothing -> go tidy_env1 acc things
431 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
433 -----------------------
434 find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
435 id_ty <- zonkTcType (idType id)
436 if ignore_it id_ty then
437 return (tidy_env, Nothing)
439 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
440 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
441 nest 2 (parens (ptext SLIT("bound at") <+>
442 ppr (getSrcLoc id)))]
444 return (tidy_env', Just msg)
446 find_thing ignore_it tidy_env (ATyVar tv ty) = do
447 tv_ty <- zonkTcType ty
448 if ignore_it tv_ty then
449 return (tidy_env, Nothing)
451 -- The name tv is scoped, so we don't need to tidy it
452 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
453 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
455 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
456 getOccName tv == getOccName tv' = empty
457 | otherwise = equals <+> ppr tidy_ty
458 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
459 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
461 return (tidy_env1, Just msg)
463 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
466 %************************************************************************
468 \subsection{The global tyvars}
470 %************************************************************************
473 tc_extend_gtvs gtvs extra_global_tvs = do
474 global_tvs <- readMutVar gtvs
475 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
478 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
479 To improve subsequent calls to the same function it writes the zonked set back into
483 tcGetGlobalTyVars :: TcM TcTyVarSet
484 tcGetGlobalTyVars = do
485 (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
486 gbl_tvs <- readMutVar gtv_var
487 gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
488 writeMutVar gtv_var gbl_tvs'
493 %************************************************************************
497 %************************************************************************
500 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
501 -- Just pop the new rules into the EPS and envt resp
502 -- All the rules come from an interface file, not soruce
503 -- Nevertheless, some may be for this module, if we read
504 -- its interface instead of its source code
505 tcExtendRules lcl_rules thing_inside
506 = do { env <- getGblEnv
508 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
509 ; setGblEnv env' thing_inside }
513 %************************************************************************
517 %************************************************************************
520 instance Outputable ThStage where
521 ppr Comp = text "Comp"
522 ppr (Brack l _ _) = text "Brack" <+> int l
523 ppr (Splice l) = text "Splice" <+> int l
526 thLevel :: ThStage -> ThLevel
527 thLevel Comp = topLevel
528 thLevel (Splice l) = l
529 thLevel (Brack l _ _) = l
532 checkWellStaged :: SDoc -- What the stage check is for
533 -> ThLevel -- Binding level (increases inside brackets)
534 -> ThStage -- Use stage
535 -> TcM () -- Fail if badly staged, adding an error
536 checkWellStaged pp_thing bind_lvl use_stage
537 | use_lvl >= bind_lvl -- OK! Used later than bound
538 = return () -- E.g. \x -> [| $(f x) |]
540 | bind_lvl == topLevel -- GHC restriction on top level splices
542 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
543 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
545 | otherwise -- Badly staged
546 = failWithTc $ -- E.g. \x -> $(f x)
547 ptext SLIT("Stage error:") <+> pp_thing <+>
548 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
549 ptext SLIT("but used at stage") <+> ppr use_lvl]
551 use_lvl = thLevel use_stage
554 topIdLvl :: Id -> ThLevel
555 -- Globals may either be imported, or may be from an earlier "chunk"
556 -- (separated by declaration splices) of this module. The former
557 -- *can* be used inside a top-level splice, but the latter cannot.
558 -- Hence we give the former impLevel, but the latter topLevel
562 -- By the time we are prcessing the $(f x), the binding for "x"
563 -- will be in the global env, not the local one.
564 topIdLvl id | isLocalId id = topLevel
565 | otherwise = impLevel
567 -- Indicates the legal transitions on bracket( [| |] ).
568 bracketOK :: ThStage -> Maybe ThLevel
569 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
570 bracketOK stage = Just (thLevel stage + 1)
572 -- Indicates the legal transitions on splice($).
573 spliceOK :: ThStage -> Maybe ThLevel
574 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
575 spliceOK stage = Just (thLevel stage - 1)
577 tcMetaTy :: Name -> TcM Type
578 -- Given the name of a Template Haskell data type,
580 -- E.g. given the name "Expr" return the type "Expr"
581 tcMetaTy tc_name = do
582 t <- tcLookupTyCon tc_name
583 return (mkTyConApp t [])
585 thTopLevelId :: Id -> Bool
586 -- See Note [What is a top-level Id?] in TcSplice
587 thTopLevelId id = isGlobalId id || isExternalName (idName id)
591 %************************************************************************
593 \subsection{The InstInfo type}
595 %************************************************************************
597 The InstInfo type summarises the information in an instance declaration
599 instance c => k (t tvs) where b
601 It is used just for *local* instance decls (not ones from interface files).
602 But local instance decls includes
605 as well as explicit user written ones.
610 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
611 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
614 iDFunId :: InstInfo -> DFunId
615 iDFunId info = instanceDFunId (iSpec info)
618 = VanillaInst -- The normal case
619 (LHsBinds Name) -- Bindings for the instance methods
620 [LSig Name] -- User pragmas recorded for generating
621 -- specialised instances
623 | NewTypeDerived -- Used for deriving instances of newtypes, where the
624 -- witness dictionary is identical to the argument
625 -- dictionary. Hence no bindings, no pragmas.
627 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
629 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
631 details (VanillaInst b _) = pprLHsBinds b
632 details NewTypeDerived = text "Derived from the representation type"
634 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
635 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
636 (_, _, cls, [ty]) -> (cls, ty)
638 simpleInstInfoTy :: InstInfo -> Type
639 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
641 simpleInstInfoTyCon :: InstInfo -> TyCon
642 -- Gets the type constructor for a simple instance declaration,
643 -- i.e. one of the form instance (...) => C (T a b c) where ...
644 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
647 Make a name for the dict fun for an instance decl. It's an *external*
648 name, like otber top-level names, and hence must be made with newGlobalBinder.
651 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
652 newDFunName clas (ty:_) loc
653 = do { index <- nextDFunIndex
654 ; is_boot <- tcIsHsBoot
656 ; let info_string = occNameString (getOccName clas) ++
657 occNameString (getDFunTyKey ty)
658 dfun_occ = mkDFunOcc info_string is_boot index
660 ; newGlobalBinder mod dfun_occ loc }
662 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
665 Make a name for the representation tycon of a family instance. It's an
666 *external* name, like otber top-level names, and hence must be made with
670 newFamInstTyConName :: Name -> SrcSpan -> TcM Name
671 newFamInstTyConName tc_name loc
672 = do { index <- nextDFunIndex
674 ; let occ = nameOccName tc_name
675 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
679 %************************************************************************
683 %************************************************************************
686 pprBinders :: [Name] -> SDoc
687 -- Used in error messages
688 -- Use quotes for a single one; they look a bit "busy" for several
689 pprBinders [bndr] = quotes (ppr bndr)
690 pprBinders bndrs = pprWithCommas ppr bndrs
693 = failWithTc (vcat[ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
694 ptext SLIT("is not in scope during type checking, but it passed the renamer"),
695 ptext SLIT("tcg_type_env of environment:") <+> ppr (tcg_type_env env)]
698 wrongThingErr expected thing name
699 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
700 ptext SLIT("used as a") <+> text expected)