2 % (c) The University of Glasgow 2006
7 TyThing(..), TcTyThing(..), TcId,
9 -- Instance environment, and InstInfo type
10 InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
11 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
17 tcLookupLocatedGlobal, tcLookupGlobal,
18 tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
19 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
20 tcLookupLocatedClass, tcLookupFamInst,
23 tcExtendKindEnv, tcExtendKindEnvTvs,
24 tcExtendTyVarEnv, tcExtendTyVarEnv2,
25 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
26 tcLookup, tcLookupLocated, tcLookupLocalIds,
27 tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
28 lclEnvElts, getInLocalScope, findGlobals,
29 wrongThingErr, pprBinders,
32 tcExtendRecEnv, -- For knot-tying
37 -- Global type variables
40 -- Template Haskell stuff
41 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
45 newLocalName, newDFunName, newFamInstTyConName
48 #include "HsVersions.h"
78 %************************************************************************
82 %************************************************************************
84 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
85 unless you know that the SrcSpan in the monad is already set to the
89 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
90 -- c.f. IfaceEnvEnv.tcIfaceGlobal
91 tcLookupLocatedGlobal name
92 = addLocM tcLookupGlobal name
94 tcLookupGlobal :: Name -> TcM TyThing
95 -- The Name is almost always an ExternalName, but not always
96 -- In GHCi, we may make command-line bindings (ghci> let x = True)
97 -- that bind a GlobalId, but with an InternalName
99 = do { env <- getGblEnv
102 ; case lookupNameEnv (tcg_type_env env) name of {
103 Just thing -> return thing ;
107 { (eps,hpt) <- getEpsAndHpt
109 ; case lookupType dflags hpt (eps_PTE eps) name of {
110 Just thing -> return thing ;
113 -- Should it have been in the local envt?
114 { case nameModule_maybe name of
115 Nothing -> notFound name -- Internal names can happen in GHCi
117 Just mod | mod == tcg_mod env -- Names from this module
118 -> notFound name -- should be in tcg_type_env
119 | mod == thFAKE -- Names bound in TH declaration brackets
120 -> notFound name -- should be in tcg_env
122 -> tcImportDecl name -- Go find it in an interface
125 tcLookupField :: Name -> TcM Id -- Returns the selector Id
127 = tcLookupGlobal name `thenM` \ thing ->
130 other -> wrongThingErr "field name" (AGlobal thing) name
132 tcLookupDataCon :: Name -> TcM DataCon
134 = tcLookupGlobal name `thenM` \ thing ->
136 ADataCon con -> return con
137 other -> wrongThingErr "data constructor" (AGlobal thing) name
139 tcLookupClass :: Name -> TcM Class
141 = tcLookupGlobal name `thenM` \ thing ->
143 AClass cls -> return cls
144 other -> wrongThingErr "class" (AGlobal thing) name
146 tcLookupTyCon :: Name -> TcM TyCon
148 = tcLookupGlobal name `thenM` \ thing ->
150 ATyCon tc -> return tc
151 other -> wrongThingErr "type constructor" (AGlobal thing) name
153 tcLookupLocatedGlobalId :: Located Name -> TcM Id
154 tcLookupLocatedGlobalId = addLocM tcLookupId
156 tcLookupLocatedClass :: Located Name -> TcM Class
157 tcLookupLocatedClass = addLocM tcLookupClass
159 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
160 tcLookupLocatedTyCon = addLocM tcLookupTyCon
162 -- Look up the representation tycon of a family instance.
164 tcLookupFamInst :: TyCon -> [Type] -> TcM TyCon
165 tcLookupFamInst tycon tys
166 = do { env <- getGblEnv
168 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
169 ; case lookupFamInstEnvExact instEnv tycon tys of
170 Nothing -> famInstNotFound tycon tys
171 Just famInst -> return $ famInstTyCon famInst
175 %************************************************************************
177 Extending the global environment
179 %************************************************************************
183 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
184 -- Given a mixture of Ids, TyCons, Classes, all from the
185 -- module being compiled, extend the global environment
186 tcExtendGlobalEnv things thing_inside
187 = do { env <- getGblEnv
188 ; let ge' = extendTypeEnvList (tcg_type_env env) things
189 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
191 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
192 -- Same deal as tcExtendGlobalEnv, but for Ids
193 tcExtendGlobalValEnv ids thing_inside
194 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
198 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
199 -- Extend the global environments for the type/class knot tying game
200 tcExtendRecEnv gbl_stuff thing_inside
201 = updGblEnv upd thing_inside
203 upd env = env { tcg_type_env = extend (tcg_type_env env) }
204 extend env = extendNameEnvList env gbl_stuff
208 %************************************************************************
210 \subsection{The local environment}
212 %************************************************************************
215 tcLookupLocated :: Located Name -> TcM TcTyThing
216 tcLookupLocated = addLocM tcLookup
218 tcLookup :: Name -> TcM TcTyThing
220 = getLclEnv `thenM` \ local_env ->
221 case lookupNameEnv (tcl_env local_env) name of
222 Just thing -> returnM thing
223 Nothing -> tcLookupGlobal name `thenM` \ thing ->
224 returnM (AGlobal thing)
226 tcLookupTyVar :: Name -> TcM TcTyVar
228 = tcLookup name `thenM` \ thing ->
230 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
231 other -> pprPanic "tcLookupTyVar" (ppr name)
233 tcLookupId :: Name -> TcM Id
234 -- Used when we aren't interested in the binding level, nor refinement.
235 -- The "no refinement" part means that we return the un-refined Id regardless
237 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
239 = tcLookup name `thenM` \ thing ->
241 ATcId { tct_id = id} -> returnM id
242 AGlobal (AnId id) -> returnM id
243 other -> pprPanic "tcLookupId" (ppr name)
245 tcLookupLocalIds :: [Name] -> TcM [TcId]
246 -- We expect the variables to all be bound, and all at
247 -- the same level as the lookup. Only used in one place...
249 = getLclEnv `thenM` \ env ->
250 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
253 = case lookupNameEnv lenv name of
254 Just (ATcId { tct_id = id, tct_level = lvl1 })
255 -> ASSERT( lvl == lvl1 ) id
256 other -> pprPanic "tcLookupLocalIds" (ppr name)
258 lclEnvElts :: TcLclEnv -> [TcTyThing]
259 lclEnvElts env = nameEnvElts (tcl_env env)
261 getInLocalScope :: TcM (Name -> Bool)
263 getInLocalScope = getLclEnv `thenM` \ env ->
265 lcl_env = tcl_env env
267 return (`elemNameEnv` lcl_env)
271 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
272 tcExtendKindEnv things thing_inside
273 = updLclEnv upd thing_inside
275 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
276 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
278 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
279 tcExtendKindEnvTvs bndrs thing_inside
280 = updLclEnv upd thing_inside
282 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
283 extend env = extendNameEnvList env pairs
284 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
286 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
287 tcExtendTyVarEnv tvs thing_inside
288 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
290 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
291 tcExtendTyVarEnv2 binds thing_inside
292 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
294 tcl_rdr = rdr_env}) ->
296 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
297 new_tv_set = tcTyVarsOfTypes (map snd binds)
298 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
300 -- It's important to add the in-scope tyvars to the global tyvar set
302 -- f (_::r) = let g y = y::r in ...
303 -- Here, g mustn't be generalised. This is also important during
304 -- class and instance decls, when we mustn't generalise the class tyvars
305 -- when typechecking the methods.
306 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
307 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
309 getScopedTyVarBinds :: TcM [(Name, TcType)]
311 = do { lcl_env <- getLclEnv
312 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
317 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
318 -- Invariant: the TcIds are fully zonked. Reasons:
319 -- (a) The kinds of the forall'd type variables are defaulted
320 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
321 -- (b) There are no via-Indirect occurrences of the bound variables
322 -- in the types, because instantiation does not look through such things
323 -- (c) The call to tyVarsOfTypes is ok without looking through refs
324 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
326 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
327 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
329 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
330 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
331 tcExtendIdEnv2 names_w_ids thing_inside
332 = getLclEnv `thenM` \ env ->
334 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
335 th_lvl = thLevel (tcl_th_ctxt env)
336 extra_env = [ (name, ATcId { tct_id = id,
339 tct_co = if isRefineableTy id_ty
340 then Just idHsWrapper
342 | (name,id) <- names_w_ids, let id_ty = idType id]
343 le' = extendNameEnvList (tcl_env env) extra_env
344 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
346 traceTc (text "env2") `thenM_`
347 traceTc (text "env3" <+> ppr extra_env) `thenM_`
348 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
349 (traceTc (text "env4") `thenM_`
350 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
355 -----------------------
356 -- findGlobals looks at the value environment and finds values
357 -- whose types mention the offending type variable. It has to be
358 -- careful to zonk the Id's type first, so it has to be in the monad.
359 -- We must be careful to pass it a zonked type variable, too.
361 findGlobals :: TcTyVarSet
363 -> TcM (TidyEnv, [SDoc])
365 findGlobals tvs tidy_env
366 = getLclEnv `thenM` \ lcl_env ->
367 go tidy_env [] (lclEnvElts lcl_env)
369 go tidy_env acc [] = returnM (tidy_env, acc)
370 go tidy_env acc (thing : things)
371 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
373 Just d -> go tidy_env1 (d:acc) things
374 Nothing -> go tidy_env1 acc things
376 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
378 -----------------------
379 find_thing ignore_it tidy_env (ATcId { tct_id = id })
380 = zonkTcType (idType id) `thenM` \ id_ty ->
381 if ignore_it id_ty then
382 returnM (tidy_env, Nothing)
384 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
385 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
386 nest 2 (parens (ptext SLIT("bound at") <+>
387 ppr (getSrcLoc id)))]
389 returnM (tidy_env', Just msg)
391 find_thing ignore_it tidy_env (ATyVar tv ty)
392 = zonkTcType ty `thenM` \ tv_ty ->
393 if ignore_it tv_ty then
394 returnM (tidy_env, Nothing)
396 -- The name tv is scoped, so we don't need to tidy it
397 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
398 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
400 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
401 getOccName tv == getOccName tv' = empty
402 | otherwise = equals <+> ppr tidy_ty
403 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
404 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
406 returnM (tidy_env1, Just msg)
408 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
412 refineEnvironment :: Refinement -> TcM a -> TcM a
413 -- I don't think I have to refine the set of global type variables in scope
414 -- Reason: the refinement never increases that set
415 refineEnvironment reft thing_inside
416 | isEmptyRefinement reft -- Common case
419 = do { env <- getLclEnv
420 ; let le' = mapNameEnv refine (tcl_env env)
421 ; setLclEnv (env {tcl_env = le'}) thing_inside }
423 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
424 | Just (co', ty') <- refineType reft ty
425 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
426 refine (ATyVar tv ty)
427 | Just (_, ty') <- refineType reft ty
428 = ATyVar tv ty' -- Ignore the coercion that refineType returns
430 refine elt = elt -- Common case
433 %************************************************************************
435 \subsection{The global tyvars}
437 %************************************************************************
440 tc_extend_gtvs gtvs extra_global_tvs
441 = readMutVar gtvs `thenM` \ global_tvs ->
442 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
445 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
446 To improve subsequent calls to the same function it writes the zonked set back into
450 tcGetGlobalTyVars :: TcM TcTyVarSet
452 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
453 readMutVar gtv_var `thenM` \ gbl_tvs ->
454 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
455 writeMutVar gtv_var gbl_tvs' `thenM_`
460 %************************************************************************
464 %************************************************************************
467 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
468 -- Just pop the new rules into the EPS and envt resp
469 -- All the rules come from an interface file, not soruce
470 -- Nevertheless, some may be for this module, if we read
471 -- its interface instead of its source code
472 tcExtendRules lcl_rules thing_inside
473 = do { env <- getGblEnv
475 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
476 ; setGblEnv env' thing_inside }
480 %************************************************************************
484 %************************************************************************
487 instance Outputable ThStage where
488 ppr Comp = text "Comp"
489 ppr (Brack l _ _) = text "Brack" <+> int l
490 ppr (Splice l) = text "Splice" <+> int l
493 thLevel :: ThStage -> ThLevel
494 thLevel Comp = topLevel
495 thLevel (Splice l) = l
496 thLevel (Brack l _ _) = l
499 checkWellStaged :: SDoc -- What the stage check is for
500 -> ThLevel -- Binding level
501 -> ThStage -- Use stage
502 -> TcM () -- Fail if badly staged, adding an error
503 checkWellStaged pp_thing bind_lvl use_stage
504 | bind_lvl <= use_lvl -- OK!
507 | bind_lvl == topLevel -- GHC restriction on top level splices
509 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
510 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
512 | otherwise -- Badly staged
514 ptext SLIT("Stage error:") <+> pp_thing <+>
515 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
516 ptext SLIT("but used at stage") <+> ppr use_lvl]
518 use_lvl = thLevel use_stage
521 topIdLvl :: Id -> ThLevel
522 -- Globals may either be imported, or may be from an earlier "chunk"
523 -- (separated by declaration splices) of this module. The former
524 -- *can* be used inside a top-level splice, but the latter cannot.
525 -- Hence we give the former impLevel, but the latter topLevel
529 -- By the time we are prcessing the $(f x), the binding for "x"
530 -- will be in the global env, not the local one.
531 topIdLvl id | isLocalId id = topLevel
532 | otherwise = impLevel
534 -- Indicates the legal transitions on bracket( [| |] ).
535 bracketOK :: ThStage -> Maybe ThLevel
536 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
537 bracketOK stage = Just (thLevel stage + 1)
539 -- Indicates the legal transitions on splice($).
540 spliceOK :: ThStage -> Maybe ThLevel
541 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
542 spliceOK stage = Just (thLevel stage - 1)
544 tcMetaTy :: Name -> TcM Type
545 -- Given the name of a Template Haskell data type,
547 -- E.g. given the name "Expr" return the type "Expr"
549 = tcLookupTyCon tc_name `thenM` \ t ->
550 returnM (mkTyConApp t [])
554 %************************************************************************
556 \subsection{The InstInfo type}
558 %************************************************************************
560 The InstInfo type summarises the information in an instance declaration
562 instance c => k (t tvs) where b
564 It is used just for *local* instance decls (not ones from interface files).
565 But local instance decls includes
568 as well as explicit user written ones.
573 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
574 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
577 iDFunId :: InstInfo -> DFunId
578 iDFunId info = instanceDFunId (iSpec info)
581 = VanillaInst -- The normal case
582 (LHsBinds Name) -- Bindings
583 [LSig Name] -- User pragmas recorded for generating
584 -- specialised instances
586 | NewTypeDerived -- Used for deriving instances of newtypes, where the
587 -- witness dictionary is identical to the argument
588 -- dictionary. Hence no bindings, no pragmas.
590 -- Nothing => The newtype-derived instance involves type variables,
591 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
592 -- Just (r:scs) => The newtype-defined instance has no type variables
593 -- so the dfun is just a constant, df :: Eq T
594 -- In this case we need to know waht the rep dict, r, and the
595 -- superclasses, scs, are. (In the Nothing case these are in the
597 -- Invariant: these PredTypes have no free variables
598 -- NB: In both cases, the representation dict is the *first* dict.
600 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
602 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
604 details (VanillaInst b _) = pprLHsBinds b
605 details (NewTypeDerived _) = text "Derived from the representation type"
607 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
608 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
609 (_, _, cls, [ty]) -> (cls, ty)
611 simpleInstInfoTy :: InstInfo -> Type
612 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
614 simpleInstInfoTyCon :: InstInfo -> TyCon
615 -- Gets the type constructor for a simple instance declaration,
616 -- i.e. one of the form instance (...) => C (T a b c) where ...
617 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
620 Make a name for the dict fun for an instance decl. It's an *external*
621 name, like otber top-level names, and hence must be made with newGlobalBinder.
624 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
625 newDFunName clas (ty:_) loc
626 = do { index <- nextDFunIndex
627 ; is_boot <- tcIsHsBoot
629 ; let info_string = occNameString (getOccName clas) ++
630 occNameString (getDFunTyKey ty)
631 dfun_occ = mkDFunOcc info_string is_boot index
633 ; newGlobalBinder mod dfun_occ loc }
635 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
638 Make a name for the representation tycon of a data/newtype instance. It's an
639 *external* name, like otber top-level names, and hence must be made with
643 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
644 newFamInstTyConName tc_name loc
645 = do { index <- nextDFunIndex
647 ; let occ = nameOccName tc_name
648 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
652 %************************************************************************
656 %************************************************************************
659 pprBinders :: [Name] -> SDoc
660 -- Used in error messages
661 -- Use quotes for a single one; they look a bit "busy" for several
662 pprBinders [bndr] = quotes (ppr bndr)
663 pprBinders bndrs = pprWithCommas ppr bndrs
666 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
667 ptext SLIT("is not in scope"))
669 wrongThingErr expected thing name
670 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
671 ptext SLIT("used as a") <+> text expected)
673 famInstNotFound tycon tys
674 = failWithTc (quotes famInst <+> ptext SLIT("is not in scope"))
676 famInst = ppr tycon <+> hsep (map pprParendType tys)