2 % (c) The University of Glasgow 2006
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 TyThing(..), TcTyThing(..), TcId,
16 -- Instance environment, and InstInfo type
17 InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
18 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
24 tcLookupLocatedGlobal, tcLookupGlobal,
25 tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
26 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
27 tcLookupLocatedClass, tcLookupFamInst,
30 tcExtendKindEnv, tcExtendKindEnvTvs,
31 tcExtendTyVarEnv, tcExtendTyVarEnv2,
33 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
34 tcLookup, tcLookupLocated, tcLookupLocalIds,
35 tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
36 lclEnvElts, getInLocalScope, findGlobals,
37 wrongThingErr, pprBinders,
39 tcExtendRecEnv, -- For knot-tying
44 -- Global type variables
47 -- Template Haskell stuff
48 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
49 topIdLvl, thTopLevelId,
52 newLocalName, newDFunName, newFamInstTyConName,
55 #include "HsVersions.h"
63 -- import TcSuspension
87 %************************************************************************
91 %************************************************************************
93 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
94 unless you know that the SrcSpan in the monad is already set to the
98 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
99 -- c.f. IfaceEnvEnv.tcIfaceGlobal
100 tcLookupLocatedGlobal name
101 = addLocM tcLookupGlobal name
103 tcLookupGlobal :: Name -> TcM TyThing
104 -- The Name is almost always an ExternalName, but not always
105 -- In GHCi, we may make command-line bindings (ghci> let x = True)
106 -- that bind a GlobalId, but with an InternalName
108 = do { env <- getGblEnv
111 ; case lookupNameEnv (tcg_type_env env) name of {
112 Just thing -> return thing ;
116 { (eps,hpt) <- getEpsAndHpt
118 ; case lookupType dflags hpt (eps_PTE eps) name of {
119 Just thing -> return thing ;
122 -- Should it have been in the local envt?
123 { case nameModule_maybe name of
124 Nothing -> notFound name env -- Internal names can happen in GHCi
126 Just mod | mod == tcg_mod env -- Names from this module
127 -> notFound name env -- should be in tcg_type_env
128 | mod == thFAKE -- Names bound in TH declaration brackets
129 -> notFound name env -- should be in tcg_env
131 -> tcImportDecl name -- Go find it in an interface
134 tcLookupField :: Name -> TcM Id -- Returns the selector Id
135 tcLookupField name = do
136 thing <- tcLookupGlobal name
139 other -> wrongThingErr "field name" (AGlobal thing) name
141 tcLookupDataCon :: Name -> TcM DataCon
142 tcLookupDataCon name = do
143 thing <- tcLookupGlobal name
145 ADataCon con -> return con
146 other -> wrongThingErr "data constructor" (AGlobal thing) name
148 tcLookupClass :: Name -> TcM Class
149 tcLookupClass name = do
150 thing <- tcLookupGlobal name
152 AClass cls -> return cls
153 other -> wrongThingErr "class" (AGlobal thing) name
155 tcLookupTyCon :: Name -> TcM TyCon
156 tcLookupTyCon name = do
157 thing <- tcLookupGlobal name
159 ATyCon tc -> return tc
160 other -> wrongThingErr "type constructor" (AGlobal thing) name
162 tcLookupLocatedGlobalId :: Located Name -> TcM Id
163 tcLookupLocatedGlobalId = addLocM tcLookupId
165 tcLookupLocatedClass :: Located Name -> TcM Class
166 tcLookupLocatedClass = addLocM tcLookupClass
168 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
169 tcLookupLocatedTyCon = addLocM tcLookupTyCon
171 -- Look up the instance tycon of a family instance.
173 -- The match must be unique - ie, match exactly one instance - but the
174 -- type arguments used for matching may be more specific than those of
175 -- the family instance declaration.
177 -- Return the instance tycon and its type instance. For example, if we have
179 -- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
181 -- then we have a coercion (ie, type instance of family instance coercion)
183 -- :Co:R42T Int :: T [Int] ~ :R42T Int
185 -- which implies that :R42T was declared as 'data instance T [a]'.
187 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
188 tcLookupFamInst tycon tys
189 | not (isOpenTyCon tycon)
192 = do { env <- getGblEnv
194 ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
195 ; case lookupFamInstEnv instEnv tycon tys of
196 [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
198 other -> return Nothing
202 %************************************************************************
204 Extending the global environment
206 %************************************************************************
210 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
211 -- Given a mixture of Ids, TyCons, Classes, all from the
212 -- module being compiled, extend the global environment
213 tcExtendGlobalEnv things thing_inside
214 = do { env <- getGblEnv
215 ; let ge' = extendTypeEnvList (tcg_type_env env) things
216 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
218 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
219 -- Same deal as tcExtendGlobalEnv, but for Ids
220 tcExtendGlobalValEnv ids thing_inside
221 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
225 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
226 -- Extend the global environments for the type/class knot tying game
227 tcExtendRecEnv gbl_stuff thing_inside
228 = updGblEnv upd thing_inside
230 upd env = env { tcg_type_env = extend (tcg_type_env env) }
231 extend env = extendNameEnvList env gbl_stuff
235 %************************************************************************
237 \subsection{The local environment}
239 %************************************************************************
242 tcLookupLocated :: Located Name -> TcM TcTyThing
243 tcLookupLocated = addLocM tcLookup
245 tcLookup :: Name -> TcM TcTyThing
247 local_env <- getLclEnv
248 case lookupNameEnv (tcl_env local_env) name of
249 Just thing -> return thing
250 Nothing -> AGlobal <$> tcLookupGlobal name
252 tcLookupTyVar :: Name -> TcM TcTyVar
253 tcLookupTyVar name = do
254 thing <- tcLookup name
256 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
257 other -> pprPanic "tcLookupTyVar" (ppr name)
259 tcLookupId :: Name -> TcM Id
260 -- Used when we aren't interested in the binding level, nor refinement.
261 -- The "no refinement" part means that we return the un-refined Id regardless
263 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
265 thing <- tcLookup name
267 ATcId { tct_id = id} -> return id
268 AGlobal (AnId id) -> return id
269 other -> pprPanic "tcLookupId" (ppr name)
271 tcLookupLocalIds :: [Name] -> TcM [TcId]
272 -- We expect the variables to all be bound, and all at
273 -- the same level as the lookup. Only used in one place...
274 tcLookupLocalIds ns = do
276 return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
279 = case lookupNameEnv lenv name of
280 Just (ATcId { tct_id = id, tct_level = lvl1 })
281 -> ASSERT( lvl == lvl1 ) id
282 other -> pprPanic "tcLookupLocalIds" (ppr name)
284 lclEnvElts :: TcLclEnv -> [TcTyThing]
285 lclEnvElts env = nameEnvElts (tcl_env env)
287 getInLocalScope :: TcM (Name -> Bool)
291 let lcl_env = tcl_env env
292 return (`elemNameEnv` lcl_env)
296 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
297 tcExtendKindEnv things thing_inside
298 = updLclEnv upd thing_inside
300 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
301 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
303 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
304 tcExtendKindEnvTvs bndrs thing_inside
305 = updLclEnv upd thing_inside
307 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
308 extend env = extendNameEnvList env pairs
309 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
311 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
312 tcExtendTyVarEnv tvs thing_inside
313 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
315 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
316 tcExtendTyVarEnv2 binds thing_inside = do
317 env@(TcLclEnv {tcl_env = le,
319 tcl_rdr = rdr_env}) <- getLclEnv
321 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
322 new_tv_set = tcTyVarsOfTypes (map snd binds)
323 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
325 -- It's important to add the in-scope tyvars to the global tyvar set
327 -- f (_::r) = let g y = y::r in ...
328 -- Here, g mustn't be generalised. This is also important during
329 -- class and instance decls, when we mustn't generalise the class tyvars
330 -- when typechecking the methods.
331 gtvs' <- tc_extend_gtvs gtvs new_tv_set
332 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
334 getScopedTyVarBinds :: TcM [(Name, TcType)]
336 = do { lcl_env <- getLclEnv
337 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
342 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
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 = do { env <- getLclEnv
352 ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
354 tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
355 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
356 -- Note especially that we bind them at TH level 'impLevel'. That's because it's
357 -- OK to use a variable bound earlier in the interaction in a splice, becuase
358 -- GHCi has already compiled it to bytecode
359 tcExtendGhciEnv ids thing_inside
360 = do { env <- getLclEnv
361 ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
363 tc_extend_local_id_env -- This is the guy who does the work
368 -- Invariant: the TcIds are fully zonked. Reasons:
369 -- (a) The kinds of the forall'd type variables are defaulted
370 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
371 -- (b) There are no via-Indirect occurrences of the bound variables
372 -- in the types, because instantiation does not look through such things
373 -- (c) The call to tyVarsOfTypes is ok without looking through refs
375 tc_extend_local_id_env env th_lvl names_w_ids thing_inside
376 = do { traceTc (text "env2")
377 ; traceTc (text "env3" <+> ppr extra_env)
378 ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
379 ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
380 ; setLclEnv env' thing_inside }
382 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
383 extra_env = [ (name, ATcId { tct_id = id,
386 tct_co = case isRefineableTy id_ty of
387 (True,_) -> Unrefineable
388 (_,True) -> Rigid idHsWrapper
390 | (name,id) <- names_w_ids, let id_ty = idType id]
391 le' = extendNameEnvList (tcl_env env) extra_env
392 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
397 -----------------------
398 -- findGlobals looks at the value environment and finds values
399 -- whose types mention the offending type variable. It has to be
400 -- careful to zonk the Id's type first, so it has to be in the monad.
401 -- We must be careful to pass it a zonked type variable, too.
403 findGlobals :: TcTyVarSet
405 -> TcM (TidyEnv, [SDoc])
407 findGlobals tvs tidy_env = do
409 go tidy_env [] (lclEnvElts lcl_env)
411 go tidy_env acc [] = return (tidy_env, acc)
412 go tidy_env acc (thing : things) = do
413 (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
415 Just d -> go tidy_env1 (d:acc) things
416 Nothing -> go tidy_env1 acc things
418 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
420 -----------------------
421 find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
422 id_ty <- zonkTcType (idType id)
423 if ignore_it id_ty then
424 return (tidy_env, Nothing)
426 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
427 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
428 nest 2 (parens (ptext SLIT("bound at") <+>
429 ppr (getSrcLoc id)))]
431 return (tidy_env', Just msg)
433 find_thing ignore_it tidy_env (ATyVar tv ty) = do
434 tv_ty <- zonkTcType ty
435 if ignore_it tv_ty then
436 return (tidy_env, Nothing)
438 -- The name tv is scoped, so we don't need to tidy it
439 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
440 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
442 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
443 getOccName tv == getOccName tv' = empty
444 | otherwise = equals <+> ppr tidy_ty
445 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
446 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
448 return (tidy_env1, Just msg)
450 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
453 %************************************************************************
455 \subsection{The global tyvars}
457 %************************************************************************
460 tc_extend_gtvs gtvs extra_global_tvs = do
461 global_tvs <- readMutVar gtvs
462 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
465 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
466 To improve subsequent calls to the same function it writes the zonked set back into
470 tcGetGlobalTyVars :: TcM TcTyVarSet
471 tcGetGlobalTyVars = do
472 (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
473 gbl_tvs <- readMutVar gtv_var
474 gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
475 writeMutVar gtv_var gbl_tvs'
480 %************************************************************************
484 %************************************************************************
487 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
488 -- Just pop the new rules into the EPS and envt resp
489 -- All the rules come from an interface file, not soruce
490 -- Nevertheless, some may be for this module, if we read
491 -- its interface instead of its source code
492 tcExtendRules lcl_rules thing_inside
493 = do { env <- getGblEnv
495 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
496 ; setGblEnv env' thing_inside }
500 %************************************************************************
504 %************************************************************************
507 instance Outputable ThStage where
508 ppr Comp = text "Comp"
509 ppr (Brack l _ _) = text "Brack" <+> int l
510 ppr (Splice l) = text "Splice" <+> int l
513 thLevel :: ThStage -> ThLevel
514 thLevel Comp = topLevel
515 thLevel (Splice l) = l
516 thLevel (Brack l _ _) = l
519 checkWellStaged :: SDoc -- What the stage check is for
520 -> ThLevel -- Binding level (increases inside brackets)
521 -> ThStage -- Use stage
522 -> TcM () -- Fail if badly staged, adding an error
523 checkWellStaged pp_thing bind_lvl use_stage
524 | use_lvl >= bind_lvl -- OK! Used later than bound
525 = return () -- E.g. \x -> [| $(f x) |]
527 | bind_lvl == topLevel -- GHC restriction on top level splices
529 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
530 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
532 | otherwise -- Badly staged
533 = failWithTc $ -- E.g. \x -> $(f x)
534 ptext SLIT("Stage error:") <+> pp_thing <+>
535 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
536 ptext SLIT("but used at stage") <+> ppr use_lvl]
538 use_lvl = thLevel use_stage
541 topIdLvl :: Id -> ThLevel
542 -- Globals may either be imported, or may be from an earlier "chunk"
543 -- (separated by declaration splices) of this module. The former
544 -- *can* be used inside a top-level splice, but the latter cannot.
545 -- Hence we give the former impLevel, but the latter topLevel
549 -- By the time we are prcessing the $(f x), the binding for "x"
550 -- will be in the global env, not the local one.
551 topIdLvl id | isLocalId id = topLevel
552 | otherwise = impLevel
554 -- Indicates the legal transitions on bracket( [| |] ).
555 bracketOK :: ThStage -> Maybe ThLevel
556 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
557 bracketOK stage = Just (thLevel stage + 1)
559 -- Indicates the legal transitions on splice($).
560 spliceOK :: ThStage -> Maybe ThLevel
561 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
562 spliceOK stage = Just (thLevel stage - 1)
564 tcMetaTy :: Name -> TcM Type
565 -- Given the name of a Template Haskell data type,
567 -- E.g. given the name "Expr" return the type "Expr"
568 tcMetaTy tc_name = do
569 t <- tcLookupTyCon tc_name
570 return (mkTyConApp t [])
572 thTopLevelId :: Id -> Bool
573 -- See Note [What is a top-level Id?] in TcSplice
574 thTopLevelId id = isGlobalId id || isExternalName (idName id)
578 %************************************************************************
580 \subsection{The InstInfo type}
582 %************************************************************************
584 The InstInfo type summarises the information in an instance declaration
586 instance c => k (t tvs) where b
588 It is used just for *local* instance decls (not ones from interface files).
589 But local instance decls includes
592 as well as explicit user written ones.
597 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
598 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
601 iDFunId :: InstInfo -> DFunId
602 iDFunId info = instanceDFunId (iSpec info)
605 = VanillaInst -- The normal case
606 (LHsBinds Name) -- Bindings for the instance methods
607 [LSig Name] -- User pragmas recorded for generating
608 -- specialised instances
610 | NewTypeDerived -- Used for deriving instances of newtypes, where the
611 -- witness dictionary is identical to the argument
612 -- dictionary. Hence no bindings, no pragmas.
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] -> SrcSpan -> 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 -> SrcSpan -> 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 (vcat[ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
681 ptext SLIT("is not in scope during type checking, but it passed the renamer"),
682 ptext SLIT("tcg_type_env of environment:") <+> ppr (tcg_type_env env)]
685 wrongThingErr expected thing name
686 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
687 ptext SLIT("used as a") <+> text expected)