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