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"
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
161 -- Look up the representation tycon of a family instance.
162 -- Return the rep tycon and the corresponding rep args
163 tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
164 tcLookupFamInst tycon tys
165 | not (isOpenTyCon tycon)
166 = return (tycon, tys)
168 = do { env <- getGblEnv
170 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
171 ; case lookupFamInstEnv instEnv tycon tys of
173 [(subst, fam_inst)] | variable_only_subst ->
174 return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
175 where -- NB: assumption is that (tyConTyVars rep_tc) is in
176 -- the domain of the substitution
177 rep_tc = famInstTyCon fam_inst
178 subst_domain = varEnvElts . getTvSubstEnv $ subst
179 tvs = map (Type.getTyVar "tcLookupFamInst")
181 variable_only_subst = all Type.isTyVarTy subst_domain &&
182 sizeVarSet (mkVarSet tvs) == length tvs
183 -- renaming may have no repetitions
185 other -> famInstNotFound tycon tys other
189 %************************************************************************
191 Extending the global environment
193 %************************************************************************
197 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
198 -- Given a mixture of Ids, TyCons, Classes, all from the
199 -- module being compiled, extend the global environment
200 tcExtendGlobalEnv things thing_inside
201 = do { env <- getGblEnv
202 ; let ge' = extendTypeEnvList (tcg_type_env env) things
203 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
205 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
206 -- Same deal as tcExtendGlobalEnv, but for Ids
207 tcExtendGlobalValEnv ids thing_inside
208 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
212 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
213 -- Extend the global environments for the type/class knot tying game
214 tcExtendRecEnv gbl_stuff thing_inside
215 = updGblEnv upd thing_inside
217 upd env = env { tcg_type_env = extend (tcg_type_env env) }
218 extend env = extendNameEnvList env gbl_stuff
222 %************************************************************************
224 \subsection{The local environment}
226 %************************************************************************
229 tcLookupLocated :: Located Name -> TcM TcTyThing
230 tcLookupLocated = addLocM tcLookup
232 tcLookup :: Name -> TcM TcTyThing
234 = getLclEnv `thenM` \ local_env ->
235 case lookupNameEnv (tcl_env local_env) name of
236 Just thing -> returnM thing
237 Nothing -> tcLookupGlobal name `thenM` \ thing ->
238 returnM (AGlobal thing)
240 tcLookupTyVar :: Name -> TcM TcTyVar
242 = tcLookup name `thenM` \ thing ->
244 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
245 other -> pprPanic "tcLookupTyVar" (ppr name)
247 tcLookupId :: Name -> TcM Id
248 -- Used when we aren't interested in the binding level, nor refinement.
249 -- The "no refinement" part means that we return the un-refined Id regardless
251 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
253 = tcLookup name `thenM` \ thing ->
255 ATcId { tct_id = id} -> returnM id
256 AGlobal (AnId id) -> returnM id
257 other -> pprPanic "tcLookupId" (ppr name)
259 tcLookupLocalIds :: [Name] -> TcM [TcId]
260 -- We expect the variables to all be bound, and all at
261 -- the same level as the lookup. Only used in one place...
263 = getLclEnv `thenM` \ env ->
264 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
267 = case lookupNameEnv lenv name of
268 Just (ATcId { tct_id = id, tct_level = lvl1 })
269 -> ASSERT( lvl == lvl1 ) id
270 other -> pprPanic "tcLookupLocalIds" (ppr name)
272 lclEnvElts :: TcLclEnv -> [TcTyThing]
273 lclEnvElts env = nameEnvElts (tcl_env env)
275 getInLocalScope :: TcM (Name -> Bool)
277 getInLocalScope = getLclEnv `thenM` \ env ->
279 lcl_env = tcl_env env
281 return (`elemNameEnv` lcl_env)
285 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
286 tcExtendKindEnv things thing_inside
287 = updLclEnv upd thing_inside
289 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
290 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
292 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
293 tcExtendKindEnvTvs bndrs thing_inside
294 = updLclEnv upd thing_inside
296 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
297 extend env = extendNameEnvList env pairs
298 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
300 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
301 tcExtendTyVarEnv tvs thing_inside
302 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
304 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
305 tcExtendTyVarEnv2 binds thing_inside
306 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
308 tcl_rdr = rdr_env}) ->
310 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
311 new_tv_set = tcTyVarsOfTypes (map snd binds)
312 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
314 -- It's important to add the in-scope tyvars to the global tyvar set
316 -- f (_::r) = let g y = y::r in ...
317 -- Here, g mustn't be generalised. This is also important during
318 -- class and instance decls, when we mustn't generalise the class tyvars
319 -- when typechecking the methods.
320 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
321 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
323 getScopedTyVarBinds :: TcM [(Name, TcType)]
325 = do { lcl_env <- getLclEnv
326 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
331 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
332 -- Invariant: the TcIds are fully zonked. Reasons:
333 -- (a) The kinds of the forall'd type variables are defaulted
334 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
335 -- (b) There are no via-Indirect occurrences of the bound variables
336 -- in the types, because instantiation does not look through such things
337 -- (c) The call to tyVarsOfTypes is ok without looking through refs
338 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
340 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
341 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
343 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
344 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
345 tcExtendIdEnv2 names_w_ids thing_inside
346 = getLclEnv `thenM` \ env ->
348 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
349 th_lvl = thLevel (tcl_th_ctxt env)
350 extra_env = [ (name, ATcId { tct_id = id,
353 tct_co = if isRefineableTy id_ty
354 then Just idHsWrapper
356 | (name,id) <- names_w_ids, let id_ty = idType id]
357 le' = extendNameEnvList (tcl_env env) extra_env
358 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
360 traceTc (text "env2") `thenM_`
361 traceTc (text "env3" <+> ppr extra_env) `thenM_`
362 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
363 (traceTc (text "env4") `thenM_`
364 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
369 -----------------------
370 -- findGlobals looks at the value environment and finds values
371 -- whose types mention the offending type variable. It has to be
372 -- careful to zonk the Id's type first, so it has to be in the monad.
373 -- We must be careful to pass it a zonked type variable, too.
375 findGlobals :: TcTyVarSet
377 -> TcM (TidyEnv, [SDoc])
379 findGlobals tvs tidy_env
380 = getLclEnv `thenM` \ lcl_env ->
381 go tidy_env [] (lclEnvElts lcl_env)
383 go tidy_env acc [] = returnM (tidy_env, acc)
384 go tidy_env acc (thing : things)
385 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
387 Just d -> go tidy_env1 (d:acc) things
388 Nothing -> go tidy_env1 acc things
390 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
392 -----------------------
393 find_thing ignore_it tidy_env (ATcId { tct_id = id })
394 = zonkTcType (idType id) `thenM` \ id_ty ->
395 if ignore_it id_ty then
396 returnM (tidy_env, Nothing)
398 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
399 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
400 nest 2 (parens (ptext SLIT("bound at") <+>
401 ppr (getSrcLoc id)))]
403 returnM (tidy_env', Just msg)
405 find_thing ignore_it tidy_env (ATyVar tv ty)
406 = zonkTcType ty `thenM` \ tv_ty ->
407 if ignore_it tv_ty then
408 returnM (tidy_env, Nothing)
410 -- The name tv is scoped, so we don't need to tidy it
411 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
412 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
414 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
415 getOccName tv == getOccName tv' = empty
416 | otherwise = equals <+> ppr tidy_ty
417 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
418 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
420 returnM (tidy_env1, Just msg)
422 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
426 refineEnvironment :: Refinement -> TcM a -> TcM a
427 -- I don't think I have to refine the set of global type variables in scope
428 -- Reason: the refinement never increases that set
429 refineEnvironment reft thing_inside
430 | isEmptyRefinement reft -- Common case
433 = do { env <- getLclEnv
434 ; let le' = mapNameEnv refine (tcl_env env)
435 ; setLclEnv (env {tcl_env = le'}) thing_inside }
437 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
438 | Just (co', ty') <- refineType reft ty
439 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
440 refine (ATyVar tv ty)
441 | Just (_, ty') <- refineType reft ty
442 = ATyVar tv ty' -- Ignore the coercion that refineType returns
444 refine elt = elt -- Common case
447 %************************************************************************
449 \subsection{The global tyvars}
451 %************************************************************************
454 tc_extend_gtvs gtvs extra_global_tvs
455 = readMutVar gtvs `thenM` \ global_tvs ->
456 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
459 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
460 To improve subsequent calls to the same function it writes the zonked set back into
464 tcGetGlobalTyVars :: TcM TcTyVarSet
466 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
467 readMutVar gtv_var `thenM` \ gbl_tvs ->
468 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
469 writeMutVar gtv_var gbl_tvs' `thenM_`
474 %************************************************************************
478 %************************************************************************
481 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
482 -- Just pop the new rules into the EPS and envt resp
483 -- All the rules come from an interface file, not soruce
484 -- Nevertheless, some may be for this module, if we read
485 -- its interface instead of its source code
486 tcExtendRules lcl_rules thing_inside
487 = do { env <- getGblEnv
489 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
490 ; setGblEnv env' thing_inside }
494 %************************************************************************
498 %************************************************************************
501 instance Outputable ThStage where
502 ppr Comp = text "Comp"
503 ppr (Brack l _ _) = text "Brack" <+> int l
504 ppr (Splice l) = text "Splice" <+> int l
507 thLevel :: ThStage -> ThLevel
508 thLevel Comp = topLevel
509 thLevel (Splice l) = l
510 thLevel (Brack l _ _) = l
513 checkWellStaged :: SDoc -- What the stage check is for
514 -> ThLevel -- Binding level
515 -> ThStage -- Use stage
516 -> TcM () -- Fail if badly staged, adding an error
517 checkWellStaged pp_thing bind_lvl use_stage
518 | bind_lvl <= use_lvl -- OK!
521 | bind_lvl == topLevel -- GHC restriction on top level splices
523 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
524 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
526 | otherwise -- Badly staged
528 ptext SLIT("Stage error:") <+> pp_thing <+>
529 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
530 ptext SLIT("but used at stage") <+> ppr use_lvl]
532 use_lvl = thLevel use_stage
535 topIdLvl :: Id -> ThLevel
536 -- Globals may either be imported, or may be from an earlier "chunk"
537 -- (separated by declaration splices) of this module. The former
538 -- *can* be used inside a top-level splice, but the latter cannot.
539 -- Hence we give the former impLevel, but the latter topLevel
543 -- By the time we are prcessing the $(f x), the binding for "x"
544 -- will be in the global env, not the local one.
545 topIdLvl id | isLocalId id = topLevel
546 | otherwise = impLevel
548 -- Indicates the legal transitions on bracket( [| |] ).
549 bracketOK :: ThStage -> Maybe ThLevel
550 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
551 bracketOK stage = Just (thLevel stage + 1)
553 -- Indicates the legal transitions on splice($).
554 spliceOK :: ThStage -> Maybe ThLevel
555 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
556 spliceOK stage = Just (thLevel stage - 1)
558 tcMetaTy :: Name -> TcM Type
559 -- Given the name of a Template Haskell data type,
561 -- E.g. given the name "Expr" return the type "Expr"
563 = tcLookupTyCon tc_name `thenM` \ t ->
564 returnM (mkTyConApp t [])
568 %************************************************************************
570 \subsection{The InstInfo type}
572 %************************************************************************
574 The InstInfo type summarises the information in an instance declaration
576 instance c => k (t tvs) where b
578 It is used just for *local* instance decls (not ones from interface files).
579 But local instance decls includes
582 as well as explicit user written ones.
587 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
588 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
591 iDFunId :: InstInfo -> DFunId
592 iDFunId info = instanceDFunId (iSpec info)
595 = VanillaInst -- The normal case
596 (LHsBinds Name) -- Bindings
597 [LSig Name] -- User pragmas recorded for generating
598 -- specialised instances
600 | NewTypeDerived -- Used for deriving instances of newtypes, where the
601 -- witness dictionary is identical to the argument
602 -- dictionary. Hence no bindings, no pragmas.
604 -- Nothing => The newtype-derived instance involves type variables,
605 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
606 -- Just (r:scs) => The newtype-defined instance has no type variables
607 -- so the dfun is just a constant, df :: Eq T
608 -- In this case we need to know waht the rep dict, r, and the
609 -- superclasses, scs, are. (In the Nothing case these are in the
611 -- Invariant: these PredTypes have no free variables
612 -- NB: In both cases, the representation dict is the *first* dict.
614 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
616 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
618 details (VanillaInst b _) = pprLHsBinds b
619 details (NewTypeDerived _) = text "Derived from the representation type"
621 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
622 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
623 (_, _, cls, [ty]) -> (cls, ty)
625 simpleInstInfoTy :: InstInfo -> Type
626 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
628 simpleInstInfoTyCon :: InstInfo -> TyCon
629 -- Gets the type constructor for a simple instance declaration,
630 -- i.e. one of the form instance (...) => C (T a b c) where ...
631 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
634 Make a name for the dict fun for an instance decl. It's an *external*
635 name, like otber top-level names, and hence must be made with newGlobalBinder.
638 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
639 newDFunName clas (ty:_) loc
640 = do { index <- nextDFunIndex
641 ; is_boot <- tcIsHsBoot
643 ; let info_string = occNameString (getOccName clas) ++
644 occNameString (getDFunTyKey ty)
645 dfun_occ = mkDFunOcc info_string is_boot index
647 ; newGlobalBinder mod dfun_occ loc }
649 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
652 Make a name for the representation tycon of a family instance. It's an
653 *external* name, like otber top-level names, and hence must be made with
657 newFamInstTyConName :: Name -> SrcLoc -> TcM Name
658 newFamInstTyConName tc_name loc
659 = do { index <- nextDFunIndex
661 ; let occ = nameOccName tc_name
662 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
666 %************************************************************************
670 %************************************************************************
673 pprBinders :: [Name] -> SDoc
674 -- Used in error messages
675 -- Use quotes for a single one; they look a bit "busy" for several
676 pprBinders [bndr] = quotes (ppr bndr)
677 pprBinders bndrs = pprWithCommas ppr bndrs
680 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
681 ptext SLIT("is not in scope"))
683 wrongThingErr expected thing name
684 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
685 ptext SLIT("used as a") <+> text expected)
687 famInstNotFound tycon tys what
688 = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
690 msg = ptext $ if length what > 1
691 then SLIT("More than one family instance for")
692 else SLIT("No family instance exactly matching")