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