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,
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"
77 %************************************************************************
81 %************************************************************************
83 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
84 unless you know that the SrcSpan in the monad is already set to the
88 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
89 -- c.f. IfaceEnvEnv.tcIfaceGlobal
90 tcLookupLocatedGlobal name
91 = addLocM tcLookupGlobal name
93 tcLookupGlobal :: Name -> TcM TyThing
94 -- The Name is almost always an ExternalName, but not always
95 -- In GHCi, we may make command-line bindings (ghci> let x = True)
96 -- that bind a GlobalId, but with an InternalName
98 = do { env <- getGblEnv
101 ; case lookupNameEnv (tcg_type_env env) name of {
102 Just thing -> return thing ;
106 { (eps,hpt) <- getEpsAndHpt
108 ; case lookupType dflags hpt (eps_PTE eps) name of {
109 Just thing -> return thing ;
112 -- Should it have been in the local envt?
113 { case nameModule_maybe name of
114 Nothing -> notFound name -- Internal names can happen in GHCi
116 Just mod | mod == tcg_mod env -- Names from this module
117 -> notFound name -- should be in tcg_type_env
118 | mod == thFAKE -- Names bound in TH declaration brackets
119 -> notFound name -- should be in tcg_env
121 -> tcImportDecl name -- Go find it in an interface
124 tcLookupField :: Name -> TcM Id -- Returns the selector Id
126 = tcLookupGlobal name `thenM` \ thing ->
129 other -> wrongThingErr "field name" (AGlobal thing) name
131 tcLookupDataCon :: Name -> TcM DataCon
133 = tcLookupGlobal name `thenM` \ thing ->
135 ADataCon con -> return con
136 other -> wrongThingErr "data constructor" (AGlobal thing) name
138 tcLookupClass :: Name -> TcM Class
140 = tcLookupGlobal name `thenM` \ thing ->
142 AClass cls -> return cls
143 other -> wrongThingErr "class" (AGlobal thing) name
145 tcLookupTyCon :: Name -> TcM TyCon
147 = tcLookupGlobal name `thenM` \ thing ->
149 ATyCon tc -> return tc
150 other -> wrongThingErr "type constructor" (AGlobal thing) name
152 tcLookupLocatedGlobalId :: Located Name -> TcM Id
153 tcLookupLocatedGlobalId = addLocM tcLookupId
155 tcLookupLocatedClass :: Located Name -> TcM Class
156 tcLookupLocatedClass = addLocM tcLookupClass
158 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
159 tcLookupLocatedTyCon = addLocM tcLookupTyCon
162 %************************************************************************
164 Extending the global environment
166 %************************************************************************
170 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
171 -- Given a mixture of Ids, TyCons, Classes, all from the
172 -- module being compiled, extend the global environment
173 tcExtendGlobalEnv things thing_inside
174 = do { env <- getGblEnv
175 ; let ge' = extendTypeEnvList (tcg_type_env env) things
176 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
178 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
179 -- Same deal as tcExtendGlobalEnv, but for Ids
180 tcExtendGlobalValEnv ids thing_inside
181 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
185 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
186 -- Extend the global environments for the type/class knot tying game
187 tcExtendRecEnv gbl_stuff thing_inside
188 = updGblEnv upd thing_inside
190 upd env = env { tcg_type_env = extend (tcg_type_env env) }
191 extend env = extendNameEnvList env gbl_stuff
195 %************************************************************************
197 \subsection{The local environment}
199 %************************************************************************
202 tcLookupLocated :: Located Name -> TcM TcTyThing
203 tcLookupLocated = addLocM tcLookup
205 tcLookup :: Name -> TcM TcTyThing
207 = getLclEnv `thenM` \ local_env ->
208 case lookupNameEnv (tcl_env local_env) name of
209 Just thing -> returnM thing
210 Nothing -> tcLookupGlobal name `thenM` \ thing ->
211 returnM (AGlobal thing)
213 tcLookupTyVar :: Name -> TcM TcTyVar
215 = tcLookup name `thenM` \ thing ->
217 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
218 other -> pprPanic "tcLookupTyVar" (ppr name)
220 tcLookupId :: Name -> TcM Id
221 -- Used when we aren't interested in the binding level, nor refinement.
222 -- The "no refinement" part means that we return the un-refined Id regardless
224 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
226 = tcLookup name `thenM` \ thing ->
228 ATcId { tct_id = id} -> returnM id
229 AGlobal (AnId id) -> returnM id
230 other -> pprPanic "tcLookupId" (ppr name)
232 tcLookupLocalIds :: [Name] -> TcM [TcId]
233 -- We expect the variables to all be bound, and all at
234 -- the same level as the lookup. Only used in one place...
236 = getLclEnv `thenM` \ env ->
237 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
240 = case lookupNameEnv lenv name of
241 Just (ATcId { tct_id = id, tct_level = lvl1 })
242 -> ASSERT( lvl == lvl1 ) id
243 other -> pprPanic "tcLookupLocalIds" (ppr name)
245 lclEnvElts :: TcLclEnv -> [TcTyThing]
246 lclEnvElts env = nameEnvElts (tcl_env env)
248 getInLocalScope :: TcM (Name -> Bool)
250 getInLocalScope = getLclEnv `thenM` \ env ->
252 lcl_env = tcl_env env
254 return (`elemNameEnv` lcl_env)
258 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
259 tcExtendKindEnv things thing_inside
260 = updLclEnv upd thing_inside
262 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
263 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
265 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
266 tcExtendKindEnvTvs bndrs thing_inside
267 = updLclEnv upd thing_inside
269 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
270 extend env = extendNameEnvList env pairs
271 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
273 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
274 tcExtendTyVarEnv tvs thing_inside
275 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
277 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
278 tcExtendTyVarEnv2 binds thing_inside
279 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
281 tcl_rdr = rdr_env}) ->
283 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
284 new_tv_set = tcTyVarsOfTypes (map snd binds)
285 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
287 -- It's important to add the in-scope tyvars to the global tyvar set
289 -- f (_::r) = let g y = y::r in ...
290 -- Here, g mustn't be generalised. This is also important during
291 -- class and instance decls, when we mustn't generalise the class tyvars
292 -- when typechecking the methods.
293 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
294 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
296 getScopedTyVarBinds :: TcM [(Name, TcType)]
298 = do { lcl_env <- getLclEnv
299 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
304 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
305 -- Invariant: the TcIds are fully zonked. Reasons:
306 -- (a) The kinds of the forall'd type variables are defaulted
307 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
308 -- (b) There are no via-Indirect occurrences of the bound variables
309 -- in the types, because instantiation does not look through such things
310 -- (c) The call to tyVarsOfTypes is ok without looking through refs
311 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
313 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
314 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
316 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
317 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
318 tcExtendIdEnv2 names_w_ids thing_inside
319 = getLclEnv `thenM` \ env ->
321 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
322 th_lvl = thLevel (tcl_th_ctxt env)
323 extra_env = [ (name, ATcId { tct_id = id,
326 tct_co = if isRefineableTy id_ty
327 then Just idHsWrapper
329 | (name,id) <- names_w_ids, let id_ty = idType id]
330 le' = extendNameEnvList (tcl_env env) extra_env
331 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
333 traceTc (text "env2") `thenM_`
334 traceTc (text "env3" <+> ppr extra_env) `thenM_`
335 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
336 (traceTc (text "env4") `thenM_`
337 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
342 -----------------------
343 -- findGlobals looks at the value environment and finds values
344 -- whose types mention the offending type variable. It has to be
345 -- careful to zonk the Id's type first, so it has to be in the monad.
346 -- We must be careful to pass it a zonked type variable, too.
348 findGlobals :: TcTyVarSet
350 -> TcM (TidyEnv, [SDoc])
352 findGlobals tvs tidy_env
353 = getLclEnv `thenM` \ lcl_env ->
354 go tidy_env [] (lclEnvElts lcl_env)
356 go tidy_env acc [] = returnM (tidy_env, acc)
357 go tidy_env acc (thing : things)
358 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
360 Just d -> go tidy_env1 (d:acc) things
361 Nothing -> go tidy_env1 acc things
363 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
365 -----------------------
366 find_thing ignore_it tidy_env (ATcId { tct_id = id })
367 = zonkTcType (idType id) `thenM` \ id_ty ->
368 if ignore_it id_ty then
369 returnM (tidy_env, Nothing)
371 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
372 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
373 nest 2 (parens (ptext SLIT("bound at") <+>
374 ppr (getSrcLoc id)))]
376 returnM (tidy_env', Just msg)
378 find_thing ignore_it tidy_env (ATyVar tv ty)
379 = zonkTcType ty `thenM` \ tv_ty ->
380 if ignore_it tv_ty then
381 returnM (tidy_env, Nothing)
383 -- The name tv is scoped, so we don't need to tidy it
384 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
385 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
387 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
388 getOccName tv == getOccName tv' = empty
389 | otherwise = equals <+> ppr tidy_ty
390 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
391 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
393 returnM (tidy_env1, Just msg)
395 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
399 refineEnvironment :: Refinement -> TcM a -> TcM a
400 -- I don't think I have to refine the set of global type variables in scope
401 -- Reason: the refinement never increases that set
402 refineEnvironment reft thing_inside
403 | isEmptyRefinement reft -- Common case
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 | Just (co', ty') <- refineType reft ty
412 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
413 refine (ATyVar tv ty)
414 | Just (_, ty') <- refineType reft ty
415 = ATyVar tv ty' -- Ignore the coercion that refineType returns
417 refine elt = elt -- Common case
420 %************************************************************************
422 \subsection{The global tyvars}
424 %************************************************************************
427 tc_extend_gtvs gtvs extra_global_tvs
428 = readMutVar gtvs `thenM` \ global_tvs ->
429 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
432 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
433 To improve subsequent calls to the same function it writes the zonked set back into
437 tcGetGlobalTyVars :: TcM TcTyVarSet
439 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
440 readMutVar gtv_var `thenM` \ gbl_tvs ->
441 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
442 writeMutVar gtv_var gbl_tvs' `thenM_`
447 %************************************************************************
451 %************************************************************************
454 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
455 -- Just pop the new rules into the EPS and envt resp
456 -- All the rules come from an interface file, not soruce
457 -- Nevertheless, some may be for this module, if we read
458 -- its interface instead of its source code
459 tcExtendRules lcl_rules thing_inside
460 = do { env <- getGblEnv
462 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
463 ; setGblEnv env' thing_inside }
467 %************************************************************************
471 %************************************************************************
474 instance Outputable ThStage where
475 ppr Comp = text "Comp"
476 ppr (Brack l _ _) = text "Brack" <+> int l
477 ppr (Splice l) = text "Splice" <+> int l
480 thLevel :: ThStage -> ThLevel
481 thLevel Comp = topLevel
482 thLevel (Splice l) = l
483 thLevel (Brack l _ _) = l
486 checkWellStaged :: SDoc -- What the stage check is for
487 -> ThLevel -- Binding level
488 -> ThStage -- Use stage
489 -> TcM () -- Fail if badly staged, adding an error
490 checkWellStaged pp_thing bind_lvl use_stage
491 | bind_lvl <= use_lvl -- OK!
494 | bind_lvl == topLevel -- GHC restriction on top level splices
496 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
497 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
499 | otherwise -- Badly staged
501 ptext SLIT("Stage error:") <+> pp_thing <+>
502 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
503 ptext SLIT("but used at stage") <+> ppr use_lvl]
505 use_lvl = thLevel use_stage
508 topIdLvl :: Id -> ThLevel
509 -- Globals may either be imported, or may be from an earlier "chunk"
510 -- (separated by declaration splices) of this module. The former
511 -- *can* be used inside a top-level splice, but the latter cannot.
512 -- Hence we give the former impLevel, but the latter topLevel
516 -- By the time we are prcessing the $(f x), the binding for "x"
517 -- will be in the global env, not the local one.
518 topIdLvl id | isLocalId id = topLevel
519 | otherwise = impLevel
521 -- Indicates the legal transitions on bracket( [| |] ).
522 bracketOK :: ThStage -> Maybe ThLevel
523 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
524 bracketOK stage = Just (thLevel stage + 1)
526 -- Indicates the legal transitions on splice($).
527 spliceOK :: ThStage -> Maybe ThLevel
528 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
529 spliceOK stage = Just (thLevel stage - 1)
531 tcMetaTy :: Name -> TcM Type
532 -- Given the name of a Template Haskell data type,
534 -- E.g. given the name "Expr" return the type "Expr"
536 = tcLookupTyCon tc_name `thenM` \ t ->
537 returnM (mkTyConApp t [])
541 %************************************************************************
543 \subsection{The InstInfo type}
545 %************************************************************************
547 The InstInfo type summarises the information in an instance declaration
549 instance c => k (t tvs) where b
551 It is used just for *local* instance decls (not ones from interface files).
552 But local instance decls includes
555 as well as explicit user written ones.
560 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
561 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
564 iDFunId :: InstInfo -> DFunId
565 iDFunId info = instanceDFunId (iSpec info)
568 = VanillaInst -- The normal case
569 (LHsBinds Name) -- Bindings
570 [LSig Name] -- User pragmas recorded for generating
571 -- specialised instances
573 | NewTypeDerived -- Used for deriving instances of newtypes, where the
574 -- witness dictionary is identical to the argument
575 -- dictionary. Hence no bindings, no pragmas.
577 -- Nothing => The newtype-derived instance involves type variables,
578 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
579 -- Just (r:scs) => The newtype-defined instance has no type variables
580 -- so the dfun is just a constant, df :: Eq T
581 -- In this case we need to know waht the rep dict, r, and the
582 -- superclasses, scs, are. (In the Nothing case these are in the
584 -- Invariant: these PredTypes have no free variables
585 -- NB: In both cases, the representation dict is the *first* dict.
587 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
589 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
591 details (VanillaInst b _) = pprLHsBinds b
592 details (NewTypeDerived _) = text "Derived from the representation type"
594 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
595 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
596 (_, _, cls, [ty]) -> (cls, ty)
598 simpleInstInfoTy :: InstInfo -> Type
599 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
601 simpleInstInfoTyCon :: InstInfo -> TyCon
602 -- Gets the type constructor for a simple instance declaration,
603 -- i.e. one of the form instance (...) => C (T a b c) where ...
604 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
607 Make a name for the dict fun for an instance decl. It's an *external*
608 name, like otber top-level names, and hence must be made with newGlobalBinder.
611 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
612 newDFunName clas (ty:_) loc
613 = do { index <- nextDFunIndex
614 ; is_boot <- tcIsHsBoot
616 ; let info_string = occNameString (getOccName clas) ++
617 occNameString (getDFunTyKey ty)
618 dfun_occ = mkDFunOcc info_string is_boot index
620 ; newGlobalBinder mod dfun_occ loc }
622 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
625 Make a name for the representation tycon of a data/newtype instance. It's an
626 *external* name, like otber top-level names, and hence must be made with
630 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
631 newFamInstTyConName tc_name loc
632 = do { index <- nextDFunIndex
634 ; let occ = nameOccName tc_name
635 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
639 %************************************************************************
643 %************************************************************************
646 pprBinders :: [Name] -> SDoc
647 -- Used in error messages
648 -- Use quotes for a single one; they look a bit "busy" for several
649 pprBinders [bndr] = quotes (ppr bndr)
650 pprBinders bndrs = pprWithCommas ppr bndrs
653 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
654 ptext SLIT("is not in scope"))
656 wrongThingErr expected thing name
657 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
658 ptext SLIT("used as a") <+> text expected)