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