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 = do { env <- getLclEnv
404 ; let le' = mapNameEnv refine (tcl_env env)
405 ; setLclEnv (env {tcl_env = le'}) thing_inside }
407 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
408 | Just (co', ty') <- refineType reft ty
409 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
410 refine (ATyVar tv ty)
411 | Just (_, ty') <- refineType reft ty
412 = ATyVar tv ty' -- Ignore the coercion that refineType returns
414 refine elt = elt -- Common case
417 %************************************************************************
419 \subsection{The global tyvars}
421 %************************************************************************
424 tc_extend_gtvs gtvs extra_global_tvs
425 = readMutVar gtvs `thenM` \ global_tvs ->
426 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
429 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
430 To improve subsequent calls to the same function it writes the zonked set back into
434 tcGetGlobalTyVars :: TcM TcTyVarSet
436 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
437 readMutVar gtv_var `thenM` \ gbl_tvs ->
438 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
439 writeMutVar gtv_var gbl_tvs' `thenM_`
444 %************************************************************************
448 %************************************************************************
451 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
452 -- Just pop the new rules into the EPS and envt resp
453 -- All the rules come from an interface file, not soruce
454 -- Nevertheless, some may be for this module, if we read
455 -- its interface instead of its source code
456 tcExtendRules lcl_rules thing_inside
457 = do { env <- getGblEnv
459 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
460 ; setGblEnv env' thing_inside }
464 %************************************************************************
468 %************************************************************************
471 instance Outputable ThStage where
472 ppr Comp = text "Comp"
473 ppr (Brack l _ _) = text "Brack" <+> int l
474 ppr (Splice l) = text "Splice" <+> int l
477 thLevel :: ThStage -> ThLevel
478 thLevel Comp = topLevel
479 thLevel (Splice l) = l
480 thLevel (Brack l _ _) = l
483 checkWellStaged :: SDoc -- What the stage check is for
484 -> ThLevel -- Binding level
485 -> ThStage -- Use stage
486 -> TcM () -- Fail if badly staged, adding an error
487 checkWellStaged pp_thing bind_lvl use_stage
488 | bind_lvl <= use_lvl -- OK!
491 | bind_lvl == topLevel -- GHC restriction on top level splices
493 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
494 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
496 | otherwise -- Badly staged
498 ptext SLIT("Stage error:") <+> pp_thing <+>
499 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
500 ptext SLIT("but used at stage") <+> ppr use_lvl]
502 use_lvl = thLevel use_stage
505 topIdLvl :: Id -> ThLevel
506 -- Globals may either be imported, or may be from an earlier "chunk"
507 -- (separated by declaration splices) of this module. The former
508 -- *can* be used inside a top-level splice, but the latter cannot.
509 -- Hence we give the former impLevel, but the latter topLevel
513 -- By the time we are prcessing the $(f x), the binding for "x"
514 -- will be in the global env, not the local one.
515 topIdLvl id | isLocalId id = topLevel
516 | otherwise = impLevel
518 -- Indicates the legal transitions on bracket( [| |] ).
519 bracketOK :: ThStage -> Maybe ThLevel
520 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
521 bracketOK stage = Just (thLevel stage + 1)
523 -- Indicates the legal transitions on splice($).
524 spliceOK :: ThStage -> Maybe ThLevel
525 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
526 spliceOK stage = Just (thLevel stage - 1)
528 tcMetaTy :: Name -> TcM Type
529 -- Given the name of a Template Haskell data type,
531 -- E.g. given the name "Expr" return the type "Expr"
533 = tcLookupTyCon tc_name `thenM` \ t ->
534 returnM (mkTyConApp t [])
538 %************************************************************************
540 \subsection{The InstInfo type}
542 %************************************************************************
544 The InstInfo type summarises the information in an instance declaration
546 instance c => k (t tvs) where b
548 It is used just for *local* instance decls (not ones from interface files).
549 But local instance decls includes
552 as well as explicit user written ones.
557 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
558 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
561 iDFunId :: InstInfo -> DFunId
562 iDFunId info = instanceDFunId (iSpec info)
565 = VanillaInst -- The normal case
566 (LHsBinds Name) -- Bindings
567 [LSig Name] -- User pragmas recorded for generating
568 -- specialised instances
570 | NewTypeDerived -- Used for deriving instances of newtypes, where the
571 -- witness dictionary is identical to the argument
572 -- dictionary. Hence no bindings, no pragmas.
574 -- Nothing => The newtype-derived instance involves type variables,
575 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
576 -- Just (r:scs) => The newtype-defined instance has no type variables
577 -- so the dfun is just a constant, df :: Eq T
578 -- In this case we need to know waht the rep dict, r, and the
579 -- superclasses, scs, are. (In the Nothing case these are in the
581 -- Invariant: these PredTypes have no free variables
582 -- NB: In both cases, the representation dict is the *first* dict.
584 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
586 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
588 details (VanillaInst b _) = pprLHsBinds b
589 details (NewTypeDerived _) = text "Derived from the representation type"
591 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
592 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
593 (_, _, cls, [ty]) -> (cls, ty)
595 simpleInstInfoTy :: InstInfo -> Type
596 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
598 simpleInstInfoTyCon :: InstInfo -> TyCon
599 -- Gets the type constructor for a simple instance declaration,
600 -- i.e. one of the form instance (...) => C (T a b c) where ...
601 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
604 Make a name for the dict fun for an instance decl. It's an *external*
605 name, like otber top-level names, and hence must be made with newGlobalBinder.
608 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
609 newDFunName clas (ty:_) loc
610 = do { index <- nextDFunIndex
611 ; is_boot <- tcIsHsBoot
613 ; let info_string = occNameString (getOccName clas) ++
614 occNameString (getDFunTyKey ty)
615 dfun_occ = mkDFunOcc info_string is_boot index
617 ; newGlobalBinder mod dfun_occ loc }
619 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
622 Make a name for the representation tycon of a data/newtype instance. It's an
623 *external* name, like otber top-level names, and hence must be made with
627 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
628 newFamInstTyConName tc_name loc
629 = do { index <- nextDFunIndex
631 ; let occ = nameOccName tc_name
632 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
636 %************************************************************************
640 %************************************************************************
643 pprBinders :: [Name] -> SDoc
644 -- Used in error messages
645 -- Use quotes for a single one; they look a bit "busy" for several
646 pprBinders [bndr] = quotes (ppr bndr)
647 pprBinders bndrs = pprWithCommas ppr bndrs
650 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
651 ptext SLIT("is not in scope"))
653 wrongThingErr expected thing name
654 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
655 ptext SLIT("used as a") <+> text expected)