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