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.
163 -- Return the rep tycon and the corresponding rep args
164 tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
165 tcLookupFamInst tycon tys
166 | not (isOpenTyCon tycon)
167 = return (tycon, tys)
169 = do { env <- getGblEnv
171 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
172 ; case lookupFamInstEnv instEnv tycon tys of
174 [(subst, fam_inst)] | variable_only_subst ->
175 return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
176 where -- NB: assumption is that (tyConTyVars rep_tc) is in
177 -- the domain of the substitution
178 rep_tc = famInstTyCon fam_inst
179 subst_domain = varEnvElts . getTvSubstEnv $ subst
180 tvs = map (Type.getTyVar "tcLookupFamInst")
182 variable_only_subst = all Type.isTyVarTy subst_domain &&
183 sizeVarSet (mkVarSet tvs) == length tvs
184 -- renaming may have no repetitions
186 other -> famInstNotFound tycon tys other
190 %************************************************************************
192 Extending the global environment
194 %************************************************************************
198 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
199 -- Given a mixture of Ids, TyCons, Classes, all from the
200 -- module being compiled, extend the global environment
201 tcExtendGlobalEnv things thing_inside
202 = do { env <- getGblEnv
203 ; let ge' = extendTypeEnvList (tcg_type_env env) things
204 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
206 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
207 -- Same deal as tcExtendGlobalEnv, but for Ids
208 tcExtendGlobalValEnv ids thing_inside
209 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
213 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
214 -- Extend the global environments for the type/class knot tying game
215 tcExtendRecEnv gbl_stuff thing_inside
216 = updGblEnv upd thing_inside
218 upd env = env { tcg_type_env = extend (tcg_type_env env) }
219 extend env = extendNameEnvList env gbl_stuff
223 %************************************************************************
225 \subsection{The local environment}
227 %************************************************************************
230 tcLookupLocated :: Located Name -> TcM TcTyThing
231 tcLookupLocated = addLocM tcLookup
233 tcLookup :: Name -> TcM TcTyThing
235 = getLclEnv `thenM` \ local_env ->
236 case lookupNameEnv (tcl_env local_env) name of
237 Just thing -> returnM thing
238 Nothing -> tcLookupGlobal name `thenM` \ thing ->
239 returnM (AGlobal thing)
241 tcLookupTyVar :: Name -> TcM TcTyVar
243 = tcLookup name `thenM` \ thing ->
245 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
246 other -> pprPanic "tcLookupTyVar" (ppr name)
248 tcLookupId :: Name -> TcM Id
249 -- Used when we aren't interested in the binding level, nor refinement.
250 -- The "no refinement" part means that we return the un-refined Id regardless
252 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
254 = tcLookup name `thenM` \ thing ->
256 ATcId { tct_id = id} -> returnM id
257 AGlobal (AnId id) -> returnM id
258 other -> pprPanic "tcLookupId" (ppr name)
260 tcLookupLocalIds :: [Name] -> TcM [TcId]
261 -- We expect the variables to all be bound, and all at
262 -- the same level as the lookup. Only used in one place...
264 = getLclEnv `thenM` \ env ->
265 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
268 = case lookupNameEnv lenv name of
269 Just (ATcId { tct_id = id, tct_level = lvl1 })
270 -> ASSERT( lvl == lvl1 ) id
271 other -> pprPanic "tcLookupLocalIds" (ppr name)
273 lclEnvElts :: TcLclEnv -> [TcTyThing]
274 lclEnvElts env = nameEnvElts (tcl_env env)
276 getInLocalScope :: TcM (Name -> Bool)
278 getInLocalScope = getLclEnv `thenM` \ env ->
280 lcl_env = tcl_env env
282 return (`elemNameEnv` lcl_env)
286 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
287 tcExtendKindEnv things thing_inside
288 = updLclEnv upd thing_inside
290 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
291 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
293 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
294 tcExtendKindEnvTvs bndrs thing_inside
295 = updLclEnv upd thing_inside
297 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
298 extend env = extendNameEnvList env pairs
299 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
301 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
302 tcExtendTyVarEnv tvs thing_inside
303 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
305 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
306 tcExtendTyVarEnv2 binds thing_inside
307 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
309 tcl_rdr = rdr_env}) ->
311 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
312 new_tv_set = tcTyVarsOfTypes (map snd binds)
313 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
315 -- It's important to add the in-scope tyvars to the global tyvar set
317 -- f (_::r) = let g y = y::r in ...
318 -- Here, g mustn't be generalised. This is also important during
319 -- class and instance decls, when we mustn't generalise the class tyvars
320 -- when typechecking the methods.
321 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
322 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
324 getScopedTyVarBinds :: TcM [(Name, TcType)]
326 = do { lcl_env <- getLclEnv
327 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
332 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
333 -- Invariant: the TcIds are fully zonked. Reasons:
334 -- (a) The kinds of the forall'd type variables are defaulted
335 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
336 -- (b) There are no via-Indirect occurrences of the bound variables
337 -- in the types, because instantiation does not look through such things
338 -- (c) The call to tyVarsOfTypes is ok without looking through refs
339 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
341 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
342 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
344 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
345 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
346 tcExtendIdEnv2 names_w_ids thing_inside
347 = getLclEnv `thenM` \ env ->
349 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
350 th_lvl = thLevel (tcl_th_ctxt env)
351 extra_env = [ (name, ATcId { tct_id = id,
354 tct_co = if isRefineableTy id_ty
355 then Just idHsWrapper
357 | (name,id) <- names_w_ids, let id_ty = idType id]
358 le' = extendNameEnvList (tcl_env env) extra_env
359 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
361 traceTc (text "env2") `thenM_`
362 traceTc (text "env3" <+> ppr extra_env) `thenM_`
363 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
364 (traceTc (text "env4") `thenM_`
365 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
370 -----------------------
371 -- findGlobals looks at the value environment and finds values
372 -- whose types mention the offending type variable. It has to be
373 -- careful to zonk the Id's type first, so it has to be in the monad.
374 -- We must be careful to pass it a zonked type variable, too.
376 findGlobals :: TcTyVarSet
378 -> TcM (TidyEnv, [SDoc])
380 findGlobals tvs tidy_env
381 = getLclEnv `thenM` \ lcl_env ->
382 go tidy_env [] (lclEnvElts lcl_env)
384 go tidy_env acc [] = returnM (tidy_env, acc)
385 go tidy_env acc (thing : things)
386 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
388 Just d -> go tidy_env1 (d:acc) things
389 Nothing -> go tidy_env1 acc things
391 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
393 -----------------------
394 find_thing ignore_it tidy_env (ATcId { tct_id = id })
395 = zonkTcType (idType id) `thenM` \ id_ty ->
396 if ignore_it id_ty then
397 returnM (tidy_env, Nothing)
399 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
400 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
401 nest 2 (parens (ptext SLIT("bound at") <+>
402 ppr (getSrcLoc id)))]
404 returnM (tidy_env', Just msg)
406 find_thing ignore_it tidy_env (ATyVar tv ty)
407 = zonkTcType ty `thenM` \ tv_ty ->
408 if ignore_it tv_ty then
409 returnM (tidy_env, Nothing)
411 -- The name tv is scoped, so we don't need to tidy it
412 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
413 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
415 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
416 getOccName tv == getOccName tv' = empty
417 | otherwise = equals <+> ppr tidy_ty
418 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
419 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
421 returnM (tidy_env1, Just msg)
423 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
427 refineEnvironment :: Refinement -> TcM a -> TcM a
428 -- I don't think I have to refine the set of global type variables in scope
429 -- Reason: the refinement never increases that set
430 refineEnvironment reft thing_inside
431 | isEmptyRefinement reft -- Common case
434 = do { env <- getLclEnv
435 ; let le' = mapNameEnv refine (tcl_env env)
436 ; setLclEnv (env {tcl_env = le'}) thing_inside }
438 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
439 | Just (co', ty') <- refineType reft ty
440 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
441 refine (ATyVar tv ty)
442 | Just (_, ty') <- refineType reft ty
443 = ATyVar tv ty' -- Ignore the coercion that refineType returns
445 refine elt = elt -- Common case
448 %************************************************************************
450 \subsection{The global tyvars}
452 %************************************************************************
455 tc_extend_gtvs gtvs extra_global_tvs
456 = readMutVar gtvs `thenM` \ global_tvs ->
457 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
460 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
461 To improve subsequent calls to the same function it writes the zonked set back into
465 tcGetGlobalTyVars :: TcM TcTyVarSet
467 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
468 readMutVar gtv_var `thenM` \ gbl_tvs ->
469 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
470 writeMutVar gtv_var gbl_tvs' `thenM_`
475 %************************************************************************
479 %************************************************************************
482 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
483 -- Just pop the new rules into the EPS and envt resp
484 -- All the rules come from an interface file, not soruce
485 -- Nevertheless, some may be for this module, if we read
486 -- its interface instead of its source code
487 tcExtendRules lcl_rules thing_inside
488 = do { env <- getGblEnv
490 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
491 ; setGblEnv env' thing_inside }
495 %************************************************************************
499 %************************************************************************
502 instance Outputable ThStage where
503 ppr Comp = text "Comp"
504 ppr (Brack l _ _) = text "Brack" <+> int l
505 ppr (Splice l) = text "Splice" <+> int l
508 thLevel :: ThStage -> ThLevel
509 thLevel Comp = topLevel
510 thLevel (Splice l) = l
511 thLevel (Brack l _ _) = l
514 checkWellStaged :: SDoc -- What the stage check is for
515 -> ThLevel -- Binding level
516 -> ThStage -- Use stage
517 -> TcM () -- Fail if badly staged, adding an error
518 checkWellStaged pp_thing bind_lvl use_stage
519 | bind_lvl <= use_lvl -- OK!
522 | bind_lvl == topLevel -- GHC restriction on top level splices
524 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
525 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
527 | otherwise -- Badly staged
529 ptext SLIT("Stage error:") <+> pp_thing <+>
530 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
531 ptext SLIT("but used at stage") <+> ppr use_lvl]
533 use_lvl = thLevel use_stage
536 topIdLvl :: Id -> ThLevel
537 -- Globals may either be imported, or may be from an earlier "chunk"
538 -- (separated by declaration splices) of this module. The former
539 -- *can* be used inside a top-level splice, but the latter cannot.
540 -- Hence we give the former impLevel, but the latter topLevel
544 -- By the time we are prcessing the $(f x), the binding for "x"
545 -- will be in the global env, not the local one.
546 topIdLvl id | isLocalId id = topLevel
547 | otherwise = impLevel
549 -- Indicates the legal transitions on bracket( [| |] ).
550 bracketOK :: ThStage -> Maybe ThLevel
551 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
552 bracketOK stage = Just (thLevel stage + 1)
554 -- Indicates the legal transitions on splice($).
555 spliceOK :: ThStage -> Maybe ThLevel
556 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
557 spliceOK stage = Just (thLevel stage - 1)
559 tcMetaTy :: Name -> TcM Type
560 -- Given the name of a Template Haskell data type,
562 -- E.g. given the name "Expr" return the type "Expr"
564 = tcLookupTyCon tc_name `thenM` \ t ->
565 returnM (mkTyConApp t [])
569 %************************************************************************
571 \subsection{The InstInfo type}
573 %************************************************************************
575 The InstInfo type summarises the information in an instance declaration
577 instance c => k (t tvs) where b
579 It is used just for *local* instance decls (not ones from interface files).
580 But local instance decls includes
583 as well as explicit user written ones.
588 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
589 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
592 iDFunId :: InstInfo -> DFunId
593 iDFunId info = instanceDFunId (iSpec info)
596 = VanillaInst -- The normal case
597 (LHsBinds Name) -- Bindings
598 [LSig Name] -- User pragmas recorded for generating
599 -- specialised instances
601 | NewTypeDerived -- Used for deriving instances of newtypes, where the
602 -- witness dictionary is identical to the argument
603 -- dictionary. Hence no bindings, no pragmas.
605 -- Nothing => The newtype-derived instance involves type variables,
606 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
607 -- Just (r:scs) => The newtype-defined instance has no type variables
608 -- so the dfun is just a constant, df :: Eq T
609 -- In this case we need to know waht the rep dict, r, and the
610 -- superclasses, scs, are. (In the Nothing case these are in the
612 -- Invariant: these PredTypes have no free variables
613 -- NB: In both cases, the representation dict is the *first* dict.
615 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
617 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
619 details (VanillaInst b _) = pprLHsBinds b
620 details (NewTypeDerived _) = text "Derived from the representation type"
622 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
623 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
624 (_, _, cls, [ty]) -> (cls, ty)
626 simpleInstInfoTy :: InstInfo -> Type
627 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
629 simpleInstInfoTyCon :: InstInfo -> TyCon
630 -- Gets the type constructor for a simple instance declaration,
631 -- i.e. one of the form instance (...) => C (T a b c) where ...
632 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
635 Make a name for the dict fun for an instance decl. It's an *external*
636 name, like otber top-level names, and hence must be made with newGlobalBinder.
639 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
640 newDFunName clas (ty:_) loc
641 = do { index <- nextDFunIndex
642 ; is_boot <- tcIsHsBoot
644 ; let info_string = occNameString (getOccName clas) ++
645 occNameString (getDFunTyKey ty)
646 dfun_occ = mkDFunOcc info_string is_boot index
648 ; newGlobalBinder mod dfun_occ loc }
650 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
653 Make a name for the representation tycon of a family instance. It's an
654 *external* name, like otber top-level names, and hence must be made with
658 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
659 newFamInstTyConName tc_name loc
660 = do { index <- nextDFunIndex
662 ; let occ = nameOccName tc_name
663 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
667 %************************************************************************
671 %************************************************************************
674 pprBinders :: [Name] -> SDoc
675 -- Used in error messages
676 -- Use quotes for a single one; they look a bit "busy" for several
677 pprBinders [bndr] = quotes (ppr bndr)
678 pprBinders bndrs = pprWithCommas ppr bndrs
681 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
682 ptext SLIT("is not in scope"))
684 wrongThingErr expected thing name
685 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
686 ptext SLIT("used as a") <+> text expected)
688 famInstNotFound tycon tys what
689 = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
691 msg = ptext $ if length what > 1
692 then SLIT("More than one family instance for")
693 else SLIT("No family instance exactly matching")