eac6d9fbc5b16984b9e95705d4a23e2ebb0a8292
[ghc.git] / compiler / typecheck / TcEnv.hs
1 -- (c) The University of Glasgow 2006
2 {-# LANGUAGE CPP, FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
5 -- orphan
6 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
7 -- in module PlaceHolder
8
9 module TcEnv(
10 TyThing(..), TcTyThing(..), TcId,
11
12 -- Instance environment, and InstInfo type
13 InstInfo(..), iDFunId, pprInstInfoDetails,
14 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
15 InstBindings(..),
16
17 -- Global environment
18 tcExtendGlobalEnv, tcExtendTyConEnv,
19 tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
20 tcExtendGlobalValEnv,
21 tcLookupLocatedGlobal, tcLookupGlobal,
22 tcLookupTyCon, tcLookupClass,
23 tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
24 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
25 tcLookupLocatedClass, tcLookupAxiom,
26 lookupGlobal,
27
28 -- Local environment
29 tcExtendKindEnv, tcExtendKindEnvList,
30 tcExtendTyVarEnv, tcExtendTyVarEnv2,
31 tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
32 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
33 tcExtendBinderStack, tcExtendLocalTypeEnv,
34 isTypeClosedLetBndr,
35
36 tcLookup, tcLookupLocated, tcLookupLocalIds,
37 tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
38 tcLookupLcl_maybe,
39 getInLocalScope,
40 wrongThingErr, pprBinders,
41
42 tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
43 getTypeSigNames,
44 tcExtendRecEnv, -- For knot-tying
45
46 -- Tidying
47 tcInitTidyEnv, tcInitOpenTidyEnv,
48
49 -- Instances
50 tcLookupInstance, tcGetInstEnvs,
51
52 -- Rules
53 tcExtendRules,
54
55 -- Defaults
56 tcGetDefaultTys,
57
58 -- Global type variables
59 tcGetGlobalTyCoVars,
60
61 -- Template Haskell stuff
62 checkWellStaged, tcMetaTy, thLevel,
63 topIdLvl, isBrackStage,
64
65 -- New Ids
66 newDFunName, newDFunName', newFamInstTyConName,
67 newFamInstAxiomName,
68 mkStableIdFromString, mkStableIdFromName,
69 mkWrapperName
70 ) where
71
72 #include "HsVersions.h"
73
74 import GhcPrelude
75
76 import HsSyn
77 import IfaceEnv
78 import TcRnMonad
79 import TcMType
80 import TcType
81 import LoadIface
82 import PrelNames
83 import TysWiredIn
84 import Id
85 import Var
86 import VarSet
87 import RdrName
88 import InstEnv
89 import DataCon ( DataCon )
90 import PatSyn ( PatSyn )
91 import ConLike
92 import TyCon
93 import Type
94 import CoAxiom
95 import Class
96 import Name
97 import NameSet
98 import NameEnv
99 import VarEnv
100 import HscTypes
101 import DynFlags
102 import SrcLoc
103 import BasicTypes hiding( SuccessFlag(..) )
104 import Module
105 import Outputable
106 import Encoding
107 import FastString
108 import ListSetOps
109 import Util
110 import Maybes( MaybeErr(..), orElse )
111 import qualified GHC.LanguageExtensions as LangExt
112
113 import Data.IORef
114 import Data.List
115
116
117 {- *********************************************************************
118 * *
119 An IO interface to looking up globals
120 * *
121 ********************************************************************* -}
122
123 lookupGlobal :: HscEnv -> Name -> IO TyThing
124 -- An IO version, used outside the typechecker
125 -- It's more complicated than it looks, because it may
126 -- need to suck in an interface file
127 lookupGlobal hsc_env name
128 = initTcForLookup hsc_env (tcLookupGlobal name)
129 -- This initTcForLookup stuff is massive overkill
130 -- but that's how it is right now, and at least
131 -- this function localises it
132
133 {-
134 ************************************************************************
135 * *
136 * tcLookupGlobal *
137 * *
138 ************************************************************************
139
140 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
141 unless you know that the SrcSpan in the monad is already set to the
142 span of the Name.
143 -}
144
145
146 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
147 -- c.f. IfaceEnvEnv.tcIfaceGlobal
148 tcLookupLocatedGlobal name
149 = addLocM tcLookupGlobal name
150
151 tcLookupGlobal :: Name -> TcM TyThing
152 -- The Name is almost always an ExternalName, but not always
153 -- In GHCi, we may make command-line bindings (ghci> let x = True)
154 -- that bind a GlobalId, but with an InternalName
155 tcLookupGlobal name
156 = do { -- Try local envt
157 env <- getGblEnv
158 ; case lookupNameEnv (tcg_type_env env) name of {
159 Just thing -> return thing ;
160 Nothing ->
161
162 -- Should it have been in the local envt?
163 -- (NB: use semantic mod here, since names never use
164 -- identity module, see Note [Identity versus semantic module].)
165 if nameIsLocalOrFrom (tcg_semantic_mod env) name
166 then notFound name -- Internal names can happen in GHCi
167 else
168
169 -- Try home package table and external package table
170 do { mb_thing <- tcLookupImported_maybe name
171 ; case mb_thing of
172 Succeeded thing -> return thing
173 Failed msg -> failWithTc msg
174 }}}
175
176 tcLookupDataCon :: Name -> TcM DataCon
177 tcLookupDataCon name = do
178 thing <- tcLookupGlobal name
179 case thing of
180 AConLike (RealDataCon con) -> return con
181 _ -> wrongThingErr "data constructor" (AGlobal thing) name
182
183 tcLookupPatSyn :: Name -> TcM PatSyn
184 tcLookupPatSyn name = do
185 thing <- tcLookupGlobal name
186 case thing of
187 AConLike (PatSynCon ps) -> return ps
188 _ -> wrongThingErr "pattern synonym" (AGlobal thing) name
189
190 tcLookupConLike :: Name -> TcM ConLike
191 tcLookupConLike name = do
192 thing <- tcLookupGlobal name
193 case thing of
194 AConLike cl -> return cl
195 _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
196
197 tcLookupClass :: Name -> TcM Class
198 tcLookupClass name = do
199 thing <- tcLookupGlobal name
200 case thing of
201 ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
202 _ -> wrongThingErr "class" (AGlobal thing) name
203
204 tcLookupTyCon :: Name -> TcM TyCon
205 tcLookupTyCon name = do
206 thing <- tcLookupGlobal name
207 case thing of
208 ATyCon tc -> return tc
209 _ -> wrongThingErr "type constructor" (AGlobal thing) name
210
211 tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
212 tcLookupAxiom name = do
213 thing <- tcLookupGlobal name
214 case thing of
215 ACoAxiom ax -> return ax
216 _ -> wrongThingErr "axiom" (AGlobal thing) name
217
218 tcLookupLocatedGlobalId :: Located Name -> TcM Id
219 tcLookupLocatedGlobalId = addLocM tcLookupId
220
221 tcLookupLocatedClass :: Located Name -> TcM Class
222 tcLookupLocatedClass = addLocM tcLookupClass
223
224 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
225 tcLookupLocatedTyCon = addLocM tcLookupTyCon
226
227 -- Find the instance that exactly matches a type class application. The class arguments must be precisely
228 -- the same as in the instance declaration (modulo renaming & casts).
229 --
230 tcLookupInstance :: Class -> [Type] -> TcM ClsInst
231 tcLookupInstance cls tys
232 = do { instEnv <- tcGetInstEnvs
233 ; case lookupUniqueInstEnv instEnv cls tys of
234 Left err -> failWithTc $ text "Couldn't match instance:" <+> err
235 Right (inst, tys)
236 | uniqueTyVars tys -> return inst
237 | otherwise -> failWithTc errNotExact
238 }
239 where
240 errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
241
242 uniqueTyVars tys = all isTyVarTy tys
243 && hasNoDups (map (getTyVar "tcLookupInstance") tys)
244
245 tcGetInstEnvs :: TcM InstEnvs
246 -- Gets both the external-package inst-env
247 -- and the home-pkg inst env (includes module being compiled)
248 tcGetInstEnvs = do { eps <- getEps
249 ; env <- getGblEnv
250 ; return (InstEnvs { ie_global = eps_inst_env eps
251 , ie_local = tcg_inst_env env
252 , ie_visible = tcVisibleOrphanMods env }) }
253
254 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
255 lookupThing = tcLookupGlobal
256
257 {-
258 ************************************************************************
259 * *
260 Extending the global environment
261 * *
262 ************************************************************************
263 -}
264
265 setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
266 -- Use this to update the global type env
267 -- It updates both * the normal tcg_type_env field
268 -- * the tcg_type_env_var field seen by interface files
269 setGlobalTypeEnv tcg_env new_type_env
270 = do { -- Sync the type-envt variable seen by interface files
271 writeMutVar (tcg_type_env_var tcg_env) new_type_env
272 ; return (tcg_env { tcg_type_env = new_type_env }) }
273
274
275 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
276 -- Just extend the global environment with some TyThings
277 -- Do not extend tcg_tcs etc
278 tcExtendGlobalEnvImplicit things thing_inside
279 = do { tcg_env <- getGblEnv
280 ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
281 ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
282 ; setGblEnv tcg_env' thing_inside }
283
284 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
285 -- Given a mixture of Ids, TyCons, Classes, all defined in the
286 -- module being compiled, extend the global environment
287 tcExtendGlobalEnv things thing_inside
288 = do { env <- getGblEnv
289 ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
290 tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
291 ; setGblEnv env' $
292 tcExtendGlobalEnvImplicit things thing_inside
293 }
294
295 tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
296 -- Given a mixture of Ids, TyCons, Classes, all defined in the
297 -- module being compiled, extend the global environment
298 tcExtendTyConEnv tycons thing_inside
299 = do { env <- getGblEnv
300 ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
301 ; setGblEnv env' $
302 tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
303 }
304
305 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
306 -- Same deal as tcExtendGlobalEnv, but for Ids
307 tcExtendGlobalValEnv ids thing_inside
308 = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
309
310 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
311 -- Extend the global environments for the type/class knot tying game
312 -- Just like tcExtendGlobalEnv, except the argument is a list of pairs
313 tcExtendRecEnv gbl_stuff thing_inside
314 = do { tcg_env <- getGblEnv
315 ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
316 ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
317 ; setGblEnv tcg_env' thing_inside }
318
319 {-
320 ************************************************************************
321 * *
322 \subsection{The local environment}
323 * *
324 ************************************************************************
325 -}
326
327 tcLookupLocated :: Located Name -> TcM TcTyThing
328 tcLookupLocated = addLocM tcLookup
329
330 tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
331 tcLookupLcl_maybe name
332 = do { local_env <- getLclTypeEnv
333 ; return (lookupNameEnv local_env name) }
334
335 tcLookup :: Name -> TcM TcTyThing
336 tcLookup name = do
337 local_env <- getLclTypeEnv
338 case lookupNameEnv local_env name of
339 Just thing -> return thing
340 Nothing -> AGlobal <$> tcLookupGlobal name
341
342 tcLookupTyVar :: Name -> TcM TcTyVar
343 tcLookupTyVar name
344 = do { thing <- tcLookup name
345 ; case thing of
346 ATyVar _ tv -> return tv
347 _ -> pprPanic "tcLookupTyVar" (ppr name) }
348
349 tcLookupId :: Name -> TcM Id
350 -- Used when we aren't interested in the binding level, nor refinement.
351 -- The "no refinement" part means that we return the un-refined Id regardless
352 --
353 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
354 tcLookupId name = do
355 thing <- tcLookupIdMaybe name
356 case thing of
357 Just id -> return id
358 _ -> pprPanic "tcLookupId" (ppr name)
359
360 tcLookupIdMaybe :: Name -> TcM (Maybe Id)
361 tcLookupIdMaybe name
362 = do { thing <- tcLookup name
363 ; case thing of
364 ATcId { tct_id = id} -> return $ Just id
365 AGlobal (AnId id) -> return $ Just id
366 _ -> return Nothing }
367
368 tcLookupLocalIds :: [Name] -> TcM [TcId]
369 -- We expect the variables to all be bound, and all at
370 -- the same level as the lookup. Only used in one place...
371 tcLookupLocalIds ns
372 = do { env <- getLclEnv
373 ; return (map (lookup (tcl_env env)) ns) }
374 where
375 lookup lenv name
376 = case lookupNameEnv lenv name of
377 Just (ATcId { tct_id = id }) -> id
378 _ -> pprPanic "tcLookupLocalIds" (ppr name)
379
380 getInLocalScope :: TcM (Name -> Bool)
381 getInLocalScope = do { lcl_env <- getLclTypeEnv
382 ; return (`elemNameEnv` lcl_env) }
383
384 tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
385 -- Used only during kind checking, for TcThings that are
386 -- ATcTyCon or APromotionErr
387 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
388 tcExtendKindEnvList things thing_inside
389 = do { traceTc "txExtendKindEnvList" (ppr things)
390 ; updLclEnv upd_env thing_inside }
391 where
392 upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
393
394 tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
395 -- A variant of tcExtendKindEvnList
396 tcExtendKindEnv extra_env thing_inside
397 = do { traceTc "txExtendKindEnv" (ppr extra_env)
398 ; updLclEnv upd_env thing_inside }
399 where
400 upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
401
402 -----------------------
403 -- Scoped type and kind variables
404 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
405 tcExtendTyVarEnv tvs thing_inside
406 = tcExtendTyVarEnv2 (mkTyVarNamePairs tvs) thing_inside
407
408 tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
409 tcExtendTyVarEnv2 binds thing_inside
410 -- this should be used only for explicitly mentioned scoped variables.
411 -- thus, no coercion variables
412 = do { tc_extend_local_env NotTopLevel
413 [(name, ATyVar name tv) | (name, tv) <- binds] $
414 tcExtendBinderStack tv_binds $
415 thing_inside }
416 where
417 tv_binds :: [TcBinder]
418 tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
419
420 isTypeClosedLetBndr :: Id -> Bool
421 -- See Note [Bindings with closed types] in TcRnTypes
422 isTypeClosedLetBndr = noFreeVarsOfType . idType
423
424 tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
425 -- Used for binding the recurive uses of Ids in a binding
426 -- both top-level value bindings and and nested let/where-bindings
427 -- Does not extend the TcBinderStack
428 tcExtendRecIds pairs thing_inside
429 = tc_extend_local_env NotTopLevel
430 [ (name, ATcId { tct_id = let_id
431 , tct_info = NonClosedLet emptyNameSet False })
432 | (name, let_id) <- pairs ] $
433 thing_inside
434
435 tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
436 -- Used for binding the Ids that have a complete user type signature
437 -- Does not extend the TcBinderStack
438 tcExtendSigIds top_lvl sig_ids thing_inside
439 = tc_extend_local_env top_lvl
440 [ (idName id, ATcId { tct_id = id
441 , tct_info = info })
442 | id <- sig_ids
443 , let closed = isTypeClosedLetBndr id
444 info = NonClosedLet emptyNameSet closed ]
445 thing_inside
446
447
448 tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
449 -> [TcId] -> TcM a -> TcM a
450 -- Used for both top-level value bindings and and nested let/where-bindings
451 -- Adds to the TcBinderStack too
452 tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
453 ids thing_inside
454 = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
455 tc_extend_local_env top_lvl
456 [ (idName id, ATcId { tct_id = id
457 , tct_info = mk_tct_info id })
458 | id <- ids ]
459 thing_inside
460 where
461 mk_tct_info id
462 | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
463 | otherwise = NonClosedLet rhs_fvs type_closed
464 where
465 name = idName id
466 rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
467 type_closed = isTypeClosedLetBndr id &&
468 (fv_type_closed || hasCompleteSig sig_fn name)
469
470 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
471 -- For lambda-bound and case-bound Ids
472 -- Extends the the TcBinderStack as well
473 tcExtendIdEnv ids thing_inside
474 = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
475
476 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
477 -- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
478 tcExtendIdEnv1 name id thing_inside
479 = tcExtendIdEnv2 [(name,id)] thing_inside
480
481 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
482 tcExtendIdEnv2 names_w_ids thing_inside
483 = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
484 | (_,mono_id) <- names_w_ids ] $
485 tc_extend_local_env NotTopLevel
486 [ (name, ATcId { tct_id = id
487 , tct_info = NotLetBound })
488 | (name,id) <- names_w_ids]
489 thing_inside
490
491 tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
492 tc_extend_local_env top_lvl extra_env thing_inside
493 -- Precondition: the argument list extra_env has TcTyThings
494 -- that ATcId or ATyVar, but nothing else
495 --
496 -- Invariant: the ATcIds are fully zonked. Reasons:
497 -- (a) The kinds of the forall'd type variables are defaulted
498 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
499 -- (b) There are no via-Indirect occurrences of the bound variables
500 -- in the types, because instantiation does not look through such things
501 -- (c) The call to tyCoVarsOfTypes is ok without looking through refs
502
503 -- The second argument of type TyVarSet is a set of type variables
504 -- that are bound together with extra_env and should not be regarded
505 -- as free in the types of extra_env.
506 = do { traceTc "env2" (ppr extra_env)
507 ; env0 <- getLclEnv
508 ; env1 <- tcExtendLocalTypeEnv env0 extra_env
509 ; stage <- getStage
510 ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
511 ; setLclEnv env2 thing_inside }
512 where
513 extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
514 -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
515 -- Reason for extending LocalRdrEnv: after running a TH splice we need
516 -- to do renaming.
517 extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
518 , tcl_th_bndrs = th_bndrs })
519 = env { tcl_rdr = extendLocalRdrEnvList rdr_env
520 [ n | (n, _) <- pairs, isInternalName n ]
521 -- The LocalRdrEnv contains only non-top-level names
522 -- (GlobalRdrEnv handles the top level)
523 , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs
524 [(n, thlvl) | (n, ATcId {}) <- pairs] }
525
526 tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
527 tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
528 | isEmptyVarSet extra_tvs
529 = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })
530 | otherwise
531 = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)
532 ; new_g_var <- newMutVar (global_tvs `unionVarSet` extra_tvs)
533 ; return (lcl_env { tcl_tyvars = new_g_var
534 , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
535 where
536 extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
537
538 get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
539 = case closed of
540 ClosedLet ->
541 ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs
542 _ ->
543 tvs `unionVarSet` id_tvs
544 where id_tvs = tyCoVarsOfType (idType id)
545
546 get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars]
547 = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
548
549 get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
550
551 get_tvs (_, AGlobal {}) tvs = tvs
552 get_tvs (_, APromotionErr {}) tvs = tvs
553
554 -- Note [Global TyVars]
555 -- It's important to add the in-scope tyvars to the global tyvar set
556 -- as well. Consider
557 -- f (_::r) = let g y = y::r in ...
558 -- Here, g mustn't be generalised. This is also important during
559 -- class and instance decls, when we mustn't generalise the class tyvars
560 -- when typechecking the methods.
561 --
562 -- Nor must we generalise g over any kind variables free in r's kind
563
564
565 {- *********************************************************************
566 * *
567 The TcBinderStack
568 * *
569 ********************************************************************* -}
570
571 tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
572 tcExtendBinderStack bndrs thing_inside
573 = do { traceTc "tcExtendBinderStack" (ppr bndrs)
574 ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
575 thing_inside }
576
577 tcInitTidyEnv :: TcM TidyEnv
578 -- We initialise the "tidy-env", used for tidying types before printing,
579 -- by building a reverse map from the in-scope type variables to the
580 -- OccName that the programmer originally used for them
581 tcInitTidyEnv
582 = do { lcl_env <- getLclEnv
583 ; go emptyTidyEnv (tcl_bndrs lcl_env) }
584 where
585 go (env, subst) []
586 = return (env, subst)
587 go (env, subst) (b : bs)
588 | TcTvBndr name tyvar <- b
589 = do { let (env', occ') = tidyOccName env (nameOccName name)
590 name' = tidyNameOcc name occ'
591 tyvar1 = setTyVarName tyvar name'
592 ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
593 -- Be sure to zonk here! Tidying applies to zonked
594 -- types, so if we don't zonk we may create an
595 -- ill-kinded type (Trac #14175)
596 ; go (env', extendVarEnv subst tyvar tyvar2) bs }
597 | otherwise
598 = go (env, subst) bs
599
600 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
601 -- type. Useful when tidying open types.
602 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
603 tcInitOpenTidyEnv tvs
604 = do { env1 <- tcInitTidyEnv
605 ; let env2 = tidyFreeTyCoVars env1 tvs
606 ; return env2 }
607
608
609
610 {- *********************************************************************
611 * *
612 Adding placeholders
613 * *
614 ********************************************************************* -}
615
616 tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
617 -- See Note [AFamDataCon: not promoting data family constructors]
618 tcAddDataFamConPlaceholders inst_decls thing_inside
619 = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
620 | lid <- inst_decls, con <- get_cons lid ]
621 thing_inside
622 -- Note [AFamDataCon: not promoting data family constructors]
623 where
624 -- get_cons extracts the *constructor* bindings of the declaration
625 get_cons :: LInstDecl GhcRn -> [Name]
626 get_cons (L _ (TyFamInstD {})) = []
627 get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
628 get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
629 = concatMap (get_fi_cons . unLoc) fids
630
631 get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
632 get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
633 FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
634 = map unLoc $ concatMap (getConNames . unLoc) cons
635
636
637 tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
638 -- See Note [Don't promote pattern synonyms]
639 tcAddPatSynPlaceholders pat_syns thing_inside
640 = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
641 | PSB{ psb_id = L _ name } <- pat_syns ]
642 thing_inside
643
644 getTypeSigNames :: [LSig GhcRn] -> NameSet
645 -- Get the names that have a user type sig
646 getTypeSigNames sigs
647 = foldr get_type_sig emptyNameSet sigs
648 where
649 get_type_sig :: LSig GhcRn -> NameSet -> NameSet
650 get_type_sig sig ns =
651 case sig of
652 L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
653 L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
654 _ -> ns
655
656
657 {- Note [AFamDataCon: not promoting data family constructors]
658 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
659 Consider
660 data family T a
661 data instance T Int = MkT
662 data Proxy (a :: k)
663 data S = MkS (Proxy 'MkT)
664
665 Is it ok to use the promoted data family instance constructor 'MkT' in
666 the data declaration for S (where both declarations live in the same module)?
667 No, we don't allow this. It *might* make sense, but at least it would mean that
668 we'd have to interleave typechecking instances and data types, whereas at
669 present we do data types *then* instances.
670
671 So to check for this we put in the TcLclEnv a binding for all the family
672 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
673 type checking 'S' we'll produce a decent error message.
674
675 Trac #12088 describes this limitation. Of course, when MkT and S live in
676 different modules then all is well.
677
678 Note [Don't promote pattern synonyms]
679 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
680 We never promote pattern synonyms.
681
682 Consider this (Trac #11265):
683 pattern A = True
684 instance Eq A
685 We want a civilised error message from the occurrence of 'A'
686 in the instance, yet 'A' really has not yet been type checked.
687
688 Similarly (Trac #9161)
689 {-# LANGUAGE PatternSynonyms, DataKinds #-}
690 pattern A = ()
691 b :: A
692 b = undefined
693 Here, the type signature for b mentions A. But A is a pattern
694 synonym, which is typechecked as part of a group of bindings (for very
695 good reasons; a view pattern in the RHS may mention a value binding).
696 It is entirely reasonable to reject this, but to do so we need A to be
697 in the kind environment when kind-checking the signature for B.
698
699 Hence tcAddPatSynPlaceholers adds a binding
700 A -> APromotionErr PatSynPE
701 to the environment. Then TcHsType.tcTyVar will find A in the kind
702 environment, and will give a 'wrongThingErr' as a result. But the
703 lookup of A won't fail.
704
705
706 ************************************************************************
707 * *
708 \subsection{Rules}
709 * *
710 ************************************************************************
711 -}
712
713 tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
714 -- Just pop the new rules into the EPS and envt resp
715 -- All the rules come from an interface file, not source
716 -- Nevertheless, some may be for this module, if we read
717 -- its interface instead of its source code
718 tcExtendRules lcl_rules thing_inside
719 = do { env <- getGblEnv
720 ; let
721 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
722 ; setGblEnv env' thing_inside }
723
724 {-
725 ************************************************************************
726 * *
727 Meta level
728 * *
729 ************************************************************************
730 -}
731
732 checkWellStaged :: SDoc -- What the stage check is for
733 -> ThLevel -- Binding level (increases inside brackets)
734 -> ThLevel -- Use stage
735 -> TcM () -- Fail if badly staged, adding an error
736 checkWellStaged pp_thing bind_lvl use_lvl
737 | use_lvl >= bind_lvl -- OK! Used later than bound
738 = return () -- E.g. \x -> [| $(f x) |]
739
740 | bind_lvl == outerLevel -- GHC restriction on top level splices
741 = stageRestrictionError pp_thing
742
743 | otherwise -- Badly staged
744 = failWithTc $ -- E.g. \x -> $(f x)
745 text "Stage error:" <+> pp_thing <+>
746 hsep [text "is bound at stage" <+> ppr bind_lvl,
747 text "but used at stage" <+> ppr use_lvl]
748
749 stageRestrictionError :: SDoc -> TcM a
750 stageRestrictionError pp_thing
751 = failWithTc $
752 sep [ text "GHC stage restriction:"
753 , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
754 , text "and must be imported, not defined locally"])]
755
756 topIdLvl :: Id -> ThLevel
757 -- Globals may either be imported, or may be from an earlier "chunk"
758 -- (separated by declaration splices) of this module. The former
759 -- *can* be used inside a top-level splice, but the latter cannot.
760 -- Hence we give the former impLevel, but the latter topLevel
761 -- E.g. this is bad:
762 -- x = [| foo |]
763 -- $( f x )
764 -- By the time we are prcessing the $(f x), the binding for "x"
765 -- will be in the global env, not the local one.
766 topIdLvl id | isLocalId id = outerLevel
767 | otherwise = impLevel
768
769 tcMetaTy :: Name -> TcM Type
770 -- Given the name of a Template Haskell data type,
771 -- return the type
772 -- E.g. given the name "Expr" return the type "Expr"
773 tcMetaTy tc_name = do
774 t <- tcLookupTyCon tc_name
775 return (mkTyConApp t [])
776
777 isBrackStage :: ThStage -> Bool
778 isBrackStage (Brack {}) = True
779 isBrackStage _other = False
780
781 {-
782 ************************************************************************
783 * *
784 getDefaultTys
785 * *
786 ************************************************************************
787 -}
788
789 tcGetDefaultTys :: TcM ([Type], -- Default types
790 (Bool, -- True <=> Use overloaded strings
791 Bool)) -- True <=> Use extended defaulting rules
792 tcGetDefaultTys
793 = do { dflags <- getDynFlags
794 ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
795 extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
796 -- See also Trac #1974
797 flags = (ovl_strings, extended_defaults)
798
799 ; mb_defaults <- getDeclaredDefaultTys
800 ; case mb_defaults of {
801 Just tys -> return (tys, flags) ;
802 -- User-supplied defaults
803 Nothing -> do
804
805 -- No use-supplied default
806 -- Use [Integer, Double], plus modifications
807 { integer_ty <- tcMetaTy integerTyConName
808 ; list_ty <- tcMetaTy listTyConName
809 ; checkWiredInTyCon doubleTyCon
810 ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
811 -- Note [Extended defaults]
812 ++ [integer_ty, doubleTy]
813 ++ opt_deflt ovl_strings [stringTy]
814 ; return (deflt_tys, flags) } } }
815 where
816 opt_deflt True xs = xs
817 opt_deflt False _ = []
818
819 {-
820 Note [Extended defaults]
821 ~~~~~~~~~~~~~~~~~~~~~
822 In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
823 try when defaulting. This has very little real impact, except in the following case.
824 Consider:
825 Text.Printf.printf "hello"
826 This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
827 want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
828 default the 'a' to (), rather than to Integer (which is what would otherwise happen;
829 and then GHCi doesn't attempt to print the (). So in interactive mode, we add
830 () to the list of defaulting types. See Trac #1200.
831
832 Additionally, the list type [] is added as a default specialization for
833 Traversable and Foldable. As such the default default list now has types of
834 varying kinds, e.g. ([] :: * -> *) and (Integer :: *).
835
836 ************************************************************************
837 * *
838 \subsection{The InstInfo type}
839 * *
840 ************************************************************************
841
842 The InstInfo type summarises the information in an instance declaration
843
844 instance c => k (t tvs) where b
845
846 It is used just for *local* instance decls (not ones from interface files).
847 But local instance decls includes
848 - derived ones
849 - generic ones
850 as well as explicit user written ones.
851 -}
852
853 data InstInfo a
854 = InstInfo
855 { iSpec :: ClsInst -- Includes the dfun id
856 , iBinds :: InstBindings a
857 }
858
859 iDFunId :: InstInfo a -> DFunId
860 iDFunId info = instanceDFunId (iSpec info)
861
862 data InstBindings a
863 = InstBindings
864 { ib_tyvars :: [Name] -- Names of the tyvars from the instance head
865 -- that are lexically in scope in the bindings
866 -- Must correspond 1-1 with the forall'd tyvars
867 -- of the dfun Id. When typechecking, we are
868 -- going to extend the typechecker's envt with
869 -- ib_tyvars -> dfun_forall_tyvars
870
871 , ib_binds :: LHsBinds a -- Bindings for the instance methods
872
873 , ib_pragmas :: [LSig a] -- User pragmas recorded for generating
874 -- specialised instances
875
876 , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
877 -- be enabled when type-checking
878 -- this instance; needed for
879 -- GeneralizedNewtypeDeriving
880
881 , ib_derived :: Bool
882 -- True <=> This code was generated by GHC from a deriving clause
883 -- or standalone deriving declaration
884 -- Used only to improve error messages
885 }
886
887 instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where
888 ppr = pprInstInfoDetails
889
890 pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc
891 pprInstInfoDetails info
892 = hang (pprInstanceHdr (iSpec info) <+> text "where")
893 2 (details (iBinds info))
894 where
895 details (InstBindings { ib_binds = b }) = pprLHsBinds b
896
897 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
898 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
899 (_, cls, [ty]) -> (cls, ty)
900 _ -> panic "simpleInstInfoClsTy"
901
902 simpleInstInfoTy :: InstInfo a -> Type
903 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
904
905 simpleInstInfoTyCon :: InstInfo a -> TyCon
906 -- Gets the type constructor for a simple instance declaration,
907 -- i.e. one of the form instance (...) => C (T a b c) where ...
908 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
909
910 -- | Make a name for the dict fun for an instance decl. It's an *external*
911 -- name, like other top-level names, and hence must be made with
912 -- newGlobalBinder.
913 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
914 newDFunName clas tys loc
915 = do { is_boot <- tcIsHsBootOrSig
916 ; mod <- getModule
917 ; let info_string = occNameString (getOccName clas) ++
918 concatMap (occNameString.getDFunTyKey) tys
919 ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
920 ; newGlobalBinder mod dfun_occ loc }
921
922 -- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.
923 newDFunName' :: Class -> TyCon -> TcM Name
924 newDFunName' clas tycon -- Just a simple wrapper
925 = do { loc <- getSrcSpanM -- The location of the instance decl,
926 -- not of the tycon
927 ; newDFunName clas [mkTyConApp tycon []] loc }
928 -- The type passed to newDFunName is only used to generate
929 -- a suitable string; hence the empty type arg list
930
931 {-
932 Make a name for the representation tycon of a family instance. It's an
933 *external* name, like other top-level names, and hence must be made with
934 newGlobalBinder.
935 -}
936
937 newFamInstTyConName :: Located Name -> [Type] -> TcM Name
938 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
939
940 newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
941 newFamInstAxiomName (L loc name) branches
942 = mk_fam_inst_name mkInstTyCoOcc loc name branches
943
944 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
945 mk_fam_inst_name adaptOcc loc tc_name tyss
946 = do { mod <- getModule
947 ; let info_string = occNameString (getOccName tc_name) ++
948 intercalate "|" ty_strings
949 ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
950 ; newGlobalBinder mod (adaptOcc occ) loc }
951 where
952 ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
953
954 {-
955 Stable names used for foreign exports and annotations.
956 For stable names, the name must be unique (see #1533). If the
957 same thing has several stable Ids based on it, the
958 top-level bindings generated must not have the same name.
959 Hence we create an External name (doesn't change), and we
960 append a Unique to the string right here.
961 -}
962
963 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
964 mkStableIdFromString str sig_ty loc occ_wrapper = do
965 uniq <- newUnique
966 mod <- getModule
967 name <- mkWrapperName "stable" str
968 let occ = mkVarOccFS name :: OccName
969 gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
970 id = mkExportedVanillaId gnm sig_ty :: Id
971 return id
972
973 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
974 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
975
976 mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
977 => String -> String -> m FastString
978 mkWrapperName what nameBase
979 = do dflags <- getDynFlags
980 thisMod <- getModule
981 let -- Note [Generating fresh names for ccall wrapper]
982 wrapperRef = nextWrapperNum dflags
983 pkg = unitIdString (moduleUnitId thisMod)
984 mod = moduleNameString (moduleName thisMod)
985 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
986 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
987 mod_env' = extendModuleEnv mod_env thisMod (num+1)
988 in (mod_env', num)
989 let components = [what, show wrapperNum, pkg, mod, nameBase]
990 return $ mkFastString $ zEncodeString $ intercalate ":" components
991
992 {-
993 Note [Generating fresh names for FFI wrappers]
994
995 We used to use a unique, rather than nextWrapperNum, to distinguish
996 between FFI wrapper functions. However, the wrapper names that we
997 generate are external names. This means that if a call to them ends up
998 in an unfolding, then we can't alpha-rename them, and thus if the
999 unique randomly changes from one compile to another then we get a
1000 spurious ABI change (#4012).
1001
1002 The wrapper counter has to be per-module, not global, so that the number we end
1003 up using is not dependent on the modules compiled before the current one.
1004 -}
1005
1006 {-
1007 ************************************************************************
1008 * *
1009 \subsection{Errors}
1010 * *
1011 ************************************************************************
1012 -}
1013
1014 pprBinders :: [Name] -> SDoc
1015 -- Used in error messages
1016 -- Use quotes for a single one; they look a bit "busy" for several
1017 pprBinders [bndr] = quotes (ppr bndr)
1018 pprBinders bndrs = pprWithCommas ppr bndrs
1019
1020 notFound :: Name -> TcM TyThing
1021 notFound name
1022 = do { lcl_env <- getLclEnv
1023 ; let stage = tcl_th_ctxt lcl_env
1024 ; case stage of -- See Note [Out of scope might be a staging error]
1025 Splice {}
1026 | isUnboundName name -> failM -- If the name really isn't in scope
1027 -- don't report it again (Trac #11941)
1028 | otherwise -> stageRestrictionError (quotes (ppr name))
1029 _ -> failWithTc $
1030 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
1031 text "is not in scope during type checking, but it passed the renamer",
1032 text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
1033 -- Take care: printing the whole gbl env can
1034 -- cause an infinite loop, in the case where we
1035 -- are in the middle of a recursive TyCon/Class group;
1036 -- so let's just not print it! Getting a loop here is
1037 -- very unhelpful, because it hides one compiler bug with another
1038 }
1039
1040 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
1041 -- It's important that this only calls pprTcTyThingCategory, which in
1042 -- turn does not look at the details of the TcTyThing.
1043 -- See Note [Placeholder PatSyn kinds] in TcBinds
1044 wrongThingErr expected thing name
1045 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
1046 text "used as a" <+> text expected)
1047
1048 {- Note [Out of scope might be a staging error]
1049 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1050 Consider
1051 x = 3
1052 data T = MkT $(foo x)
1053
1054 where 'foo' is imported from somewhere.
1055
1056 This is really a staging error, because we can't run code involving 'x'.
1057 But in fact the type checker processes types first, so 'x' won't even be
1058 in the type envt when we look for it in $(foo x). So inside splices we
1059 report something missing from the type env as a staging error.
1060 See Trac #5752 and #5795.
1061 -}