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,
51 #include "HsVersions.h"
80 %************************************************************************
84 %************************************************************************
86 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
87 unless you know that the SrcSpan in the monad is already set to the
91 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
92 -- c.f. IfaceEnvEnv.tcIfaceGlobal
93 tcLookupLocatedGlobal name
94 = addLocM tcLookupGlobal name
96 tcLookupGlobal :: Name -> TcM TyThing
97 -- The Name is almost always an ExternalName, but not always
98 -- In GHCi, we may make command-line bindings (ghci> let x = True)
99 -- that bind a GlobalId, but with an InternalName
101 = do { env <- getGblEnv
104 ; case lookupNameEnv (tcg_type_env env) name of {
105 Just thing -> return thing ;
109 { (eps,hpt) <- getEpsAndHpt
111 ; case lookupType dflags hpt (eps_PTE eps) name of {
112 Just thing -> return thing ;
115 -- Should it have been in the local envt?
116 { case nameModule_maybe name of
117 Nothing -> notFound name -- Internal names can happen in GHCi
119 Just mod | mod == tcg_mod env -- Names from this module
120 -> notFound name -- should be in tcg_type_env
121 | mod == thFAKE -- Names bound in TH declaration brackets
122 -> notFound name -- should be in tcg_env
124 -> tcImportDecl name -- Go find it in an interface
127 tcLookupField :: Name -> TcM Id -- Returns the selector Id
129 = tcLookupGlobal name `thenM` \ thing ->
132 other -> wrongThingErr "field name" (AGlobal thing) name
134 tcLookupDataCon :: Name -> TcM DataCon
136 = tcLookupGlobal name `thenM` \ thing ->
138 ADataCon con -> return con
139 other -> wrongThingErr "data constructor" (AGlobal thing) name
141 tcLookupClass :: Name -> TcM Class
143 = tcLookupGlobal name `thenM` \ thing ->
145 AClass cls -> return cls
146 other -> wrongThingErr "class" (AGlobal thing) name
148 tcLookupTyCon :: Name -> TcM TyCon
150 = tcLookupGlobal name `thenM` \ thing ->
152 ATyCon tc -> return tc
153 other -> wrongThingErr "type constructor" (AGlobal thing) name
155 tcLookupLocatedGlobalId :: Located Name -> TcM Id
156 tcLookupLocatedGlobalId = addLocM tcLookupId
158 tcLookupLocatedClass :: Located Name -> TcM Class
159 tcLookupLocatedClass = addLocM tcLookupClass
161 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
162 tcLookupLocatedTyCon = addLocM tcLookupTyCon
164 -- Look up the representation tycon of a family instance.
166 -- The match must be unique - ie, match exactly one instance - but the
167 -- type arguments used for matching may be more specific than those of
168 -- the family instance declaration.
170 -- Return the instance tycon and its type instance. For example, if we have
172 -- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
174 -- then we have a coercion (ie, type instance of family instance coercion)
176 -- :Co:R42T Int :: T [Int] ~ :R42T Int
178 -- which implies that :R42T was declared as 'data instance T [a]'.
180 tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
181 tcLookupFamInst tycon tys
182 | not (isOpenTyCon tycon)
183 = return (tycon, tys)
185 = do { env <- getGblEnv
187 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
188 ; case lookupFamInstEnv instEnv tycon tys of
189 [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
190 other -> famInstNotFound tycon tys other
194 %************************************************************************
196 Extending the global environment
198 %************************************************************************
202 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
203 -- Given a mixture of Ids, TyCons, Classes, all from the
204 -- module being compiled, extend the global environment
205 tcExtendGlobalEnv things thing_inside
206 = do { env <- getGblEnv
207 ; let ge' = extendTypeEnvList (tcg_type_env env) things
208 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
210 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
211 -- Same deal as tcExtendGlobalEnv, but for Ids
212 tcExtendGlobalValEnv ids thing_inside
213 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
217 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
218 -- Extend the global environments for the type/class knot tying game
219 tcExtendRecEnv gbl_stuff thing_inside
220 = updGblEnv upd thing_inside
222 upd env = env { tcg_type_env = extend (tcg_type_env env) }
223 extend env = extendNameEnvList env gbl_stuff
227 %************************************************************************
229 \subsection{The local environment}
231 %************************************************************************
234 tcLookupLocated :: Located Name -> TcM TcTyThing
235 tcLookupLocated = addLocM tcLookup
237 tcLookup :: Name -> TcM TcTyThing
239 = getLclEnv `thenM` \ local_env ->
240 case lookupNameEnv (tcl_env local_env) name of
241 Just thing -> returnM thing
242 Nothing -> tcLookupGlobal name `thenM` \ thing ->
243 returnM (AGlobal thing)
245 tcLookupTyVar :: Name -> TcM TcTyVar
247 = tcLookup name `thenM` \ thing ->
249 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
250 other -> pprPanic "tcLookupTyVar" (ppr name)
252 tcLookupId :: Name -> TcM Id
253 -- Used when we aren't interested in the binding level, nor refinement.
254 -- The "no refinement" part means that we return the un-refined Id regardless
256 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
258 = tcLookup name `thenM` \ thing ->
260 ATcId { tct_id = id} -> returnM id
261 AGlobal (AnId id) -> returnM id
262 other -> pprPanic "tcLookupId" (ppr name)
264 tcLookupLocalIds :: [Name] -> TcM [TcId]
265 -- We expect the variables to all be bound, and all at
266 -- the same level as the lookup. Only used in one place...
268 = getLclEnv `thenM` \ env ->
269 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
272 = case lookupNameEnv lenv name of
273 Just (ATcId { tct_id = id, tct_level = lvl1 })
274 -> ASSERT( lvl == lvl1 ) id
275 other -> pprPanic "tcLookupLocalIds" (ppr name)
277 lclEnvElts :: TcLclEnv -> [TcTyThing]
278 lclEnvElts env = nameEnvElts (tcl_env env)
280 getInLocalScope :: TcM (Name -> Bool)
282 getInLocalScope = getLclEnv `thenM` \ env ->
284 lcl_env = tcl_env env
286 return (`elemNameEnv` lcl_env)
290 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
291 tcExtendKindEnv things thing_inside
292 = updLclEnv upd thing_inside
294 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
295 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
297 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
298 tcExtendKindEnvTvs bndrs thing_inside
299 = updLclEnv upd thing_inside
301 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
302 extend env = extendNameEnvList env pairs
303 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
305 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
306 tcExtendTyVarEnv tvs thing_inside
307 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
309 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
310 tcExtendTyVarEnv2 binds thing_inside
311 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
313 tcl_rdr = rdr_env}) ->
315 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
316 new_tv_set = tcTyVarsOfTypes (map snd binds)
317 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
319 -- It's important to add the in-scope tyvars to the global tyvar set
321 -- f (_::r) = let g y = y::r in ...
322 -- Here, g mustn't be generalised. This is also important during
323 -- class and instance decls, when we mustn't generalise the class tyvars
324 -- when typechecking the methods.
325 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
326 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
328 getScopedTyVarBinds :: TcM [(Name, TcType)]
330 = do { lcl_env <- getLclEnv
331 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
336 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
337 -- Invariant: the TcIds are fully zonked. Reasons:
338 -- (a) The kinds of the forall'd type variables are defaulted
339 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
340 -- (b) There are no via-Indirect occurrences of the bound variables
341 -- in the types, because instantiation does not look through such things
342 -- (c) The call to tyVarsOfTypes is ok without looking through refs
343 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
345 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
346 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
348 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
349 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
350 tcExtendIdEnv2 names_w_ids thing_inside
351 = getLclEnv `thenM` \ env ->
353 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
354 th_lvl = thLevel (tcl_th_ctxt env)
355 extra_env = [ (name, ATcId { tct_id = id,
358 tct_co = if isRefineableTy id_ty
359 then Just idHsWrapper
361 | (name,id) <- names_w_ids, let id_ty = idType id]
362 le' = extendNameEnvList (tcl_env env) extra_env
363 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
365 traceTc (text "env2") `thenM_`
366 traceTc (text "env3" <+> ppr extra_env) `thenM_`
367 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
368 (traceTc (text "env4") `thenM_`
369 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
374 -----------------------
375 -- findGlobals looks at the value environment and finds values
376 -- whose types mention the offending type variable. It has to be
377 -- careful to zonk the Id's type first, so it has to be in the monad.
378 -- We must be careful to pass it a zonked type variable, too.
380 findGlobals :: TcTyVarSet
382 -> TcM (TidyEnv, [SDoc])
384 findGlobals tvs tidy_env
385 = getLclEnv `thenM` \ lcl_env ->
386 go tidy_env [] (lclEnvElts lcl_env)
388 go tidy_env acc [] = returnM (tidy_env, acc)
389 go tidy_env acc (thing : things)
390 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
392 Just d -> go tidy_env1 (d:acc) things
393 Nothing -> go tidy_env1 acc things
395 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
397 -----------------------
398 find_thing ignore_it tidy_env (ATcId { tct_id = id })
399 = zonkTcType (idType id) `thenM` \ id_ty ->
400 if ignore_it id_ty then
401 returnM (tidy_env, Nothing)
403 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
404 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
405 nest 2 (parens (ptext SLIT("bound at") <+>
406 ppr (getSrcLoc id)))]
408 returnM (tidy_env', Just msg)
410 find_thing ignore_it tidy_env (ATyVar tv ty)
411 = zonkTcType ty `thenM` \ tv_ty ->
412 if ignore_it tv_ty then
413 returnM (tidy_env, Nothing)
415 -- The name tv is scoped, so we don't need to tidy it
416 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
417 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
419 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
420 getOccName tv == getOccName tv' = empty
421 | otherwise = equals <+> ppr tidy_ty
422 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
423 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
425 returnM (tidy_env1, Just msg)
427 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
431 refineEnvironment :: Refinement -> TcM a -> TcM a
432 -- I don't think I have to refine the set of global type variables in scope
433 -- Reason: the refinement never increases that set
434 refineEnvironment reft thing_inside
435 | isEmptyRefinement reft -- Common case
438 = do { env <- getLclEnv
439 ; let le' = mapNameEnv refine (tcl_env env)
440 ; setLclEnv (env {tcl_env = le'}) thing_inside }
442 refine elt@(ATcId { tct_co = Just co, tct_type = ty })
443 | Just (co', ty') <- refineType reft ty
444 = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
445 refine (ATyVar tv ty)
446 | Just (_, ty') <- refineType reft ty
447 = ATyVar tv ty' -- Ignore the coercion that refineType returns
449 refine elt = elt -- Common case
452 %************************************************************************
454 \subsection{The global tyvars}
456 %************************************************************************
459 tc_extend_gtvs gtvs extra_global_tvs
460 = readMutVar gtvs `thenM` \ global_tvs ->
461 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
464 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
465 To improve subsequent calls to the same function it writes the zonked set back into
469 tcGetGlobalTyVars :: TcM TcTyVarSet
471 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
472 readMutVar gtv_var `thenM` \ gbl_tvs ->
473 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
474 writeMutVar gtv_var gbl_tvs' `thenM_`
479 %************************************************************************
483 %************************************************************************
486 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
487 -- Just pop the new rules into the EPS and envt resp
488 -- All the rules come from an interface file, not soruce
489 -- Nevertheless, some may be for this module, if we read
490 -- its interface instead of its source code
491 tcExtendRules lcl_rules thing_inside
492 = do { env <- getGblEnv
494 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
495 ; setGblEnv env' thing_inside }
499 %************************************************************************
503 %************************************************************************
506 instance Outputable ThStage where
507 ppr Comp = text "Comp"
508 ppr (Brack l _ _) = text "Brack" <+> int l
509 ppr (Splice l) = text "Splice" <+> int l
512 thLevel :: ThStage -> ThLevel
513 thLevel Comp = topLevel
514 thLevel (Splice l) = l
515 thLevel (Brack l _ _) = l
518 checkWellStaged :: SDoc -- What the stage check is for
519 -> ThLevel -- Binding level
520 -> ThStage -- Use stage
521 -> TcM () -- Fail if badly staged, adding an error
522 checkWellStaged pp_thing bind_lvl use_stage
523 | bind_lvl <= use_lvl -- OK!
526 | bind_lvl == topLevel -- GHC restriction on top level splices
528 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
529 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
531 | otherwise -- Badly staged
533 ptext SLIT("Stage error:") <+> pp_thing <+>
534 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
535 ptext SLIT("but used at stage") <+> ppr use_lvl]
537 use_lvl = thLevel use_stage
540 topIdLvl :: Id -> ThLevel
541 -- Globals may either be imported, or may be from an earlier "chunk"
542 -- (separated by declaration splices) of this module. The former
543 -- *can* be used inside a top-level splice, but the latter cannot.
544 -- Hence we give the former impLevel, but the latter topLevel
548 -- By the time we are prcessing the $(f x), the binding for "x"
549 -- will be in the global env, not the local one.
550 topIdLvl id | isLocalId id = topLevel
551 | otherwise = impLevel
553 -- Indicates the legal transitions on bracket( [| |] ).
554 bracketOK :: ThStage -> Maybe ThLevel
555 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
556 bracketOK stage = Just (thLevel stage + 1)
558 -- Indicates the legal transitions on splice($).
559 spliceOK :: ThStage -> Maybe ThLevel
560 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
561 spliceOK stage = Just (thLevel stage - 1)
563 tcMetaTy :: Name -> TcM Type
564 -- Given the name of a Template Haskell data type,
566 -- E.g. given the name "Expr" return the type "Expr"
568 = tcLookupTyCon tc_name `thenM` \ t ->
569 returnM (mkTyConApp t [])
573 %************************************************************************
575 \subsection{The InstInfo type}
577 %************************************************************************
579 The InstInfo type summarises the information in an instance declaration
581 instance c => k (t tvs) where b
583 It is used just for *local* instance decls (not ones from interface files).
584 But local instance decls includes
587 as well as explicit user written ones.
592 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
593 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
596 iDFunId :: InstInfo -> DFunId
597 iDFunId info = instanceDFunId (iSpec info)
600 = VanillaInst -- The normal case
601 (LHsBinds Name) -- Bindings
602 [LSig Name] -- User pragmas recorded for generating
603 -- specialised instances
605 | NewTypeDerived -- Used for deriving instances of newtypes, where the
606 -- witness dictionary is identical to the argument
607 -- dictionary. Hence no bindings, no pragmas.
609 -- Nothing => The newtype-derived instance involves type variables,
610 -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
611 -- Just (r:scs) => The newtype-defined instance has no type variables
612 -- so the dfun is just a constant, df :: Eq T
613 -- In this case we need to know waht the rep dict, r, and the
614 -- superclasses, scs, are. (In the Nothing case these are in the
616 -- Invariant: these PredTypes have no free variables
617 -- NB: In both cases, the representation dict is the *first* dict.
619 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
621 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
623 details (VanillaInst b _) = pprLHsBinds b
624 details (NewTypeDerived _) = text "Derived from the representation type"
626 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
627 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
628 (_, _, cls, [ty]) -> (cls, ty)
630 simpleInstInfoTy :: InstInfo -> Type
631 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
633 simpleInstInfoTyCon :: InstInfo -> TyCon
634 -- Gets the type constructor for a simple instance declaration,
635 -- i.e. one of the form instance (...) => C (T a b c) where ...
636 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
639 Make a name for the dict fun for an instance decl. It's an *external*
640 name, like otber top-level names, and hence must be made with newGlobalBinder.
643 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
644 newDFunName clas (ty:_) loc
645 = do { index <- nextDFunIndex
646 ; is_boot <- tcIsHsBoot
648 ; let info_string = occNameString (getOccName clas) ++
649 occNameString (getDFunTyKey ty)
650 dfun_occ = mkDFunOcc info_string is_boot index
652 ; newGlobalBinder mod dfun_occ loc }
654 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
657 Make a name for the representation tycon of a family instance. It's an
658 *external* name, like otber top-level names, and hence must be made with
662 newFamInstTyConName :: Name -> SrcSpan -> TcM Name
663 newFamInstTyConName tc_name loc
664 = do { index <- nextDFunIndex
666 ; let occ = nameOccName tc_name
667 ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
671 %************************************************************************
675 %************************************************************************
678 pprBinders :: [Name] -> SDoc
679 -- Used in error messages
680 -- Use quotes for a single one; they look a bit "busy" for several
681 pprBinders [bndr] = quotes (ppr bndr)
682 pprBinders bndrs = pprWithCommas ppr bndrs
685 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
686 ptext SLIT("is not in scope"))
688 wrongThingErr expected thing name
689 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
690 ptext SLIT("used as a") <+> text expected)
692 famInstNotFound tycon tys what
693 = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
695 msg = ptext $ if length what > 1
696 then SLIT("More than one family instance for")
697 else SLIT("No family instance exactly matching")