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