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