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