Major refactoring of CoAxioms
[ghc.git] / compiler / typecheck / TcEnv.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
6 module TcEnv(
7         TyThing(..), TcTyThing(..), TcId,
8
9         -- Instance environment, and InstInfo type
10         InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
11         simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, 
12         InstBindings(..),
13
14         -- Global environment
15         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
16         tcExtendGlobalValEnv,
17         tcLookupLocatedGlobal, tcLookupGlobal, 
18         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
19         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
20         tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
21         
22         -- Local environment
23         tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
24         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
25         tcExtendGhciEnv, tcExtendLetEnv,
26         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
27         tcLookup, tcLookupLocated, tcLookupLocalIds, 
28         tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
29         getInLocalScope,
30         wrongThingErr, pprBinders,
31
32         tcExtendRecEnv,         -- For knot-tying
33
34         -- Rules
35          tcExtendRules,
36
37         -- Defaults
38         tcGetDefaultTys,
39
40         -- Global type variables
41         tcGetGlobalTyVars, zapLclTypeEnv,
42
43         -- Template Haskell stuff
44         checkWellStaged, tcMetaTy, thLevel, 
45         topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
46
47         -- New Ids
48         newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName,
49         mkStableIdFromString, mkStableIdFromName
50   ) where
51
52 #include "HsVersions.h"
53
54 import HsSyn
55 import IfaceEnv
56 import TcRnMonad
57 import TcMType
58 import TcType
59 import TcIface  
60 import PrelNames
61 import TysWiredIn
62 import Id
63 import TcEvidence
64 import Var
65 import VarSet
66 import RdrName
67 import InstEnv
68 import DataCon
69 import TyCon
70 import TypeRep
71 import Class
72 import Name
73 import NameEnv
74 import HscTypes
75 import DynFlags
76 import SrcLoc
77 import BasicTypes
78 import Outputable
79 import Unique
80 import FastString
81 import ListSetOps
82 \end{code}
83
84
85 %************************************************************************
86 %*                                                                      *
87 %*                      tcLookupGlobal                                  *
88 %*                                                                      *
89 %************************************************************************
90
91 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
92 unless you know that the SrcSpan in the monad is already set to the
93 span of the Name.
94
95 \begin{code}
96 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
97 -- c.f. IfaceEnvEnv.tcIfaceGlobal
98 tcLookupLocatedGlobal name
99   = addLocM tcLookupGlobal name
100
101 tcLookupGlobal :: Name -> TcM TyThing
102 -- The Name is almost always an ExternalName, but not always
103 -- In GHCi, we may make command-line bindings (ghci> let x = True)
104 -- that bind a GlobalId, but with an InternalName
105 tcLookupGlobal name
106   = do  { env <- getGblEnv
107         
108                 -- Try local envt
109         ; case lookupNameEnv (tcg_type_env env) name of { 
110                 Just thing -> return thing ;
111                 Nothing    -> do 
112          
113                 -- Try global envt
114         { hsc_env <- getTopEnv
115         ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
116         ; case mb_thing of  {
117             Just thing -> return thing ;
118             Nothing    -> do
119
120                 -- Should it have been in the local envt?
121         { case nameModule_maybe name of
122                 Nothing -> notFound name -- Internal names can happen in GHCi
123
124                 Just mod | mod == tcg_mod env   -- Names from this module 
125                          -> notFound name -- should be in tcg_type_env
126                          | otherwise
127                          -> tcImportDecl name   -- Go find it in an interface
128         }}}}}
129
130 tcLookupField :: Name -> TcM Id         -- Returns the selector Id
131 tcLookupField name 
132   = tcLookupId name     -- Note [Record field lookup]
133
134 {- Note [Record field lookup]
135    ~~~~~~~~~~~~~~~~~~~~~~~~~~
136 You might think we should have tcLookupGlobal here, since record fields
137 are always top level.  But consider
138         f = e { f = True }
139 Then the renamer (which does not keep track of what is a record selector
140 and what is not) will rename the definition thus
141         f_7 = e { f_7 = True }
142 Now the type checker will find f_7 in the *local* type environment, not
143 the global (imported) one. It's wrong, of course, but we want to report a tidy
144 error, not in TcEnv.notFound.  -}
145
146 tcLookupDataCon :: Name -> TcM DataCon
147 tcLookupDataCon name = do
148     thing <- tcLookupGlobal name
149     case thing of
150         ADataCon con -> return con
151         _            -> wrongThingErr "data constructor" (AGlobal thing) name
152
153 tcLookupClass :: Name -> TcM Class
154 tcLookupClass name = do
155     thing <- tcLookupGlobal name
156     case thing of
157         ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
158         _                                           -> wrongThingErr "class" (AGlobal thing) name
159
160 tcLookupTyCon :: Name -> TcM TyCon
161 tcLookupTyCon name = do
162     thing <- tcLookupGlobal name
163     case thing of
164         ATyCon tc -> return tc
165         _         -> wrongThingErr "type constructor" (AGlobal thing) name
166
167 tcLookupAxiom :: Name -> TcM CoAxiom
168 tcLookupAxiom name = do
169     thing <- tcLookupGlobal name
170     case thing of
171         ACoAxiom ax -> return ax
172         _           -> wrongThingErr "axiom" (AGlobal thing) name
173
174 tcLookupLocatedGlobalId :: Located Name -> TcM Id
175 tcLookupLocatedGlobalId = addLocM tcLookupId
176
177 tcLookupLocatedClass :: Located Name -> TcM Class
178 tcLookupLocatedClass = addLocM tcLookupClass
179
180 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
181 tcLookupLocatedTyCon = addLocM tcLookupTyCon
182
183 -- Find the instance that exactly matches a type class application.  The class arguments must be precisely
184 -- the same as in the instance declaration (modulo renaming).
185 --
186 tcLookupInstance :: Class -> [Type] -> TcM ClsInst
187 tcLookupInstance cls tys
188   = do { instEnv <- tcGetInstEnvs
189        ; case lookupUniqueInstEnv instEnv cls tys of
190            Left err             -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err 
191            Right (inst, tys) 
192              | uniqueTyVars tys -> return inst
193              | otherwise        -> failWithTc errNotExact
194        }
195   where
196     errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)")
197     
198     uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys)
199       where
200         extractTyVar (TyVarTy tv) = tv
201         extractTyVar _            = panic "TcEnv.tcLookupInstance: extractTyVar"
202     
203     tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
204                        ; return (eps_inst_env eps, tcg_inst_env env) 
205                        }
206 \end{code}
207
208 \begin{code}
209 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
210     lookupThing = tcLookupGlobal
211 \end{code}
212
213 %************************************************************************
214 %*                                                                      *
215                 Extending the global environment
216 %*                                                                      *
217 %************************************************************************
218
219
220 \begin{code}
221 setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
222 -- Use this to update the global type env 
223 -- It updates both  * the normal tcg_type_env field
224 --                  * the tcg_type_env_var field seen by interface files
225 setGlobalTypeEnv tcg_env new_type_env
226   = do  {     -- Sync the type-envt variable seen by interface files
227            writeMutVar (tcg_type_env_var tcg_env) new_type_env
228          ; return (tcg_env { tcg_type_env = new_type_env }) }
229
230
231 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
232   -- Extend the global environment with some TyThings that can be obtained
233   -- via implicitTyThings from other entities in the environment.  Examples
234   -- are dfuns, famInstTyCons, data cons, etc.
235   -- These TyThings are not added to tcg_tcs.
236 tcExtendGlobalEnvImplicit things thing_inside
237    = do { tcg_env <- getGblEnv
238         ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
239         ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
240         ; setGblEnv tcg_env' thing_inside }
241
242 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
243   -- Given a mixture of Ids, TyCons, Classes, all defined in the
244   -- module being compiled, extend the global environment
245 tcExtendGlobalEnv things thing_inside
246   = do { env <- getGblEnv
247        ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env }
248        ; setGblEnv env' $
249             tcExtendGlobalEnvImplicit things thing_inside
250        }
251
252 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
253   -- Same deal as tcExtendGlobalEnv, but for Ids
254 tcExtendGlobalValEnv ids thing_inside 
255   = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
256
257 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
258 -- Extend the global environments for the type/class knot tying game
259 -- Just like tcExtendGlobalEnv, except the argument is a list of pairs
260 tcExtendRecEnv gbl_stuff thing_inside
261  = do  { tcg_env <- getGblEnv
262        ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff 
263        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
264        ; setGblEnv tcg_env' thing_inside }
265 \end{code}
266
267
268 %************************************************************************
269 %*                                                                      *
270 \subsection{The local environment}
271 %*                                                                      *
272 %************************************************************************
273
274 \begin{code}
275 tcLookupLocated :: Located Name -> TcM TcTyThing
276 tcLookupLocated = addLocM tcLookup
277
278 tcLookup :: Name -> TcM TcTyThing
279 tcLookup name = do
280     local_env <- getLclTypeEnv
281     case lookupNameEnv local_env name of
282         Just thing -> return thing
283         Nothing    -> AGlobal <$> tcLookupGlobal name
284
285 tcLookupTyVar :: Name -> TcM TcTyVar
286 tcLookupTyVar name = do
287     thing <- tcLookup name
288     case thing of
289         ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
290         _           -> pprPanic "tcLookupTyVar" (ppr name)
291
292 tcLookupId :: Name -> TcM Id
293 -- Used when we aren't interested in the binding level, nor refinement. 
294 -- The "no refinement" part means that we return the un-refined Id regardless
295 -- 
296 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
297 tcLookupId name = do
298     thing <- tcLookup name
299     case thing of
300         ATcId { tct_id = id} -> return id
301         AGlobal (AnId id)    -> return id
302         _                    -> pprPanic "tcLookupId" (ppr name)
303
304 tcLookupLocalIds :: [Name] -> TcM [TcId]
305 -- We expect the variables to all be bound, and all at
306 -- the same level as the lookup.  Only used in one place...
307 tcLookupLocalIds ns = do
308     env <- getLclEnv
309     return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
310   where
311     lookup lenv lvl name 
312         = case lookupNameEnv lenv name of
313                 Just (ATcId { tct_id = id, tct_level = lvl1 }) 
314                         -> ASSERT( lvl == lvl1 ) id
315                 _ -> pprPanic "tcLookupLocalIds" (ppr name)
316
317 getInLocalScope :: TcM (Name -> Bool)
318   -- Ids only
319 getInLocalScope = do { lcl_env <- getLclTypeEnv
320                      ; return (`elemNameEnv` lcl_env) }
321 \end{code}
322
323 \begin{code}
324 tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r
325 tcExtendTcTyThingEnv things thing_inside
326   = updLclEnv upd thing_inside
327   where
328     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
329     extend env  = extendNameEnvList env things
330
331 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
332 tcExtendKindEnv things thing_inside
333   = updLclEnv upd thing_inside
334   where
335     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
336     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
337
338 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
339 tcExtendKindEnvTvs bndrs thing_inside
340   = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
341                     (thing_inside bndrs)
342
343 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
344 tcExtendTyVarEnv tvs thing_inside
345   = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
346
347 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
348 tcExtendTyVarEnv2 binds thing_inside 
349   = tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside
350
351 getScopedTyVarBinds :: TcM [(Name, TcType)]
352 getScopedTyVarBinds
353   = do  { lcl_env <- getLclEnv
354         ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
355 \end{code}
356
357
358 \begin{code}
359 tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
360 tcExtendLetEnv closed ids thing_inside 
361   = do  { stage <- getStage
362         ; tc_extend_local_env [ (idName id, ATcId { tct_id = id 
363                                                   , tct_closed = closed
364                                                   , tct_level = thLevel stage })
365                                  | id <- ids]
366           thing_inside }
367
368 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
369 tcExtendIdEnv ids thing_inside 
370   = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
371
372 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
373 tcExtendIdEnv1 name id thing_inside 
374   = tcExtendIdEnv2 [(name,id)] thing_inside
375
376 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
377 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
378 tcExtendIdEnv2 names_w_ids thing_inside
379   = do  { stage <- getStage
380         ; tc_extend_local_env [ (name, ATcId { tct_id = id 
381                                              , tct_closed = NotTopLevel
382                                              , tct_level = thLevel stage })
383                                  | (name,id) <- names_w_ids]
384           thing_inside }
385
386 tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
387 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
388 -- Note especially that we bind them at 
389 --  * TH level 'impLevel'.  That's because it's OK to use a variable bound
390 --    earlier in the interaction in a splice, because
391 --    GHCi has already compiled it to bytecode
392 --  * Closedness flag is TopLevel.  The thing's type is closed
393
394 tcExtendGhciEnv ids thing_inside
395   = tc_extend_local_env [ (idName id, ATcId { tct_id     = id 
396                                             , tct_closed = is_top id
397                                             , tct_level  = impLevel })
398                         | id <- ids]
399     thing_inside
400   where
401     is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel
402               | otherwise                                  = NotTopLevel
403
404
405 tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
406 -- This is the guy who does the work
407 -- Invariant: the TcIds are fully zonked. Reasons:
408 --      (a) The kinds of the forall'd type variables are defaulted
409 --          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
410 --      (b) There are no via-Indirect occurrences of the bound variables
411 --          in the types, because instantiation does not look through such things
412 --      (c) The call to tyVarsOfTypes is ok without looking through refs
413
414 tc_extend_local_env extra_env thing_inside
415   = do  { traceTc "env2" (ppr extra_env)
416         ; env1 <- getLclEnv
417         ; let le'      = extendNameEnvList     (tcl_env env1) extra_env
418               rdr_env' = extendLocalRdrEnvList (tcl_rdr env1) (map fst extra_env)
419               env2     = env1 {tcl_env = le', tcl_rdr = rdr_env'}
420         ; env3 <- extend_gtvs env2
421         ; setLclEnv env3 thing_inside }
422   where
423     extend_gtvs env 
424       | isEmptyVarSet extra_tvs 
425       = return env
426       | otherwise               
427       = do { g_var <- tcExtendGlobalTyVars (tcl_tyvars env) extra_tvs
428            ; return (env { tcl_tyvars = g_var }) }
429
430     extra_tvs = foldr (unionVarSet . get_tvs) emptyVarSet extra_env
431
432     get_tvs (_, ATcId { tct_id = id, tct_closed = closed })
433       = case closed of
434           TopLevel    -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) 
435                          emptyVarSet
436           NotTopLevel -> id_tvs
437       where
438         id_tvs = tcTyVarsOfType (idType id)
439     get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty        -- See Note [Global TyVars]
440     get_tvs other = pprPanic "get_tvs" (ppr other)
441         
442         -- Note [Global TyVars]
443         -- It's important to add the in-scope tyvars to the global tyvar set
444         -- as well.  Consider
445         --      f (_::r) = let g y = y::r in ...
446         -- Here, g mustn't be generalised.  This is also important during
447         -- class and instance decls, when we mustn't generalise the class tyvars
448         -- when typechecking the methods.
449
450 tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
451 tcExtendGlobalTyVars gtv_var extra_global_tvs
452   = do { global_tvs <- readMutVar gtv_var
453        ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) }
454
455 zapLclTypeEnv :: TcM a -> TcM a
456 zapLclTypeEnv thing_inside
457   = do { tvs_var <- newTcRef emptyVarSet 
458        ; let upd env = env { tcl_env = emptyNameEnv
459                            , tcl_rdr = emptyLocalRdrEnv
460                            , tcl_tyvars = tvs_var }
461        ; updLclEnv upd thing_inside }
462 \end{code}
463
464
465 %************************************************************************
466 %*                                                                      *
467 \subsection{Rules}
468 %*                                                                      *
469 %************************************************************************
470
471 \begin{code}
472 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
473         -- Just pop the new rules into the EPS and envt resp
474         -- All the rules come from an interface file, not source
475         -- Nevertheless, some may be for this module, if we read
476         -- its interface instead of its source code
477 tcExtendRules lcl_rules thing_inside
478  = do { env <- getGblEnv
479       ; let
480           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
481       ; setGblEnv env' thing_inside }
482 \end{code}
483
484
485 %************************************************************************
486 %*                                                                      *
487                 Meta level
488 %*                                                                      *
489 %************************************************************************
490
491 \begin{code}
492 checkWellStaged :: SDoc         -- What the stage check is for
493                 -> ThLevel      -- Binding level (increases inside brackets)
494                 -> ThLevel      -- Use stage
495                 -> TcM ()       -- Fail if badly staged, adding an error
496 checkWellStaged pp_thing bind_lvl use_lvl
497   | use_lvl >= bind_lvl         -- OK! Used later than bound
498   = return ()                   -- E.g.  \x -> [| $(f x) |]
499
500   | bind_lvl == outerLevel      -- GHC restriction on top level splices
501   = failWithTc $ 
502     sep [ptext (sLit "GHC stage restriction:") <+>  pp_thing,
503          nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,")
504                       , ptext (sLit "and must be imported, not defined locally")])]
505
506   | otherwise                   -- Badly staged
507   = failWithTc $                -- E.g.  \x -> $(f x)
508     ptext (sLit "Stage error:") <+> pp_thing <+> 
509         hsep   [ptext (sLit "is bound at stage") <+> ppr bind_lvl,
510                 ptext (sLit "but used at stage") <+> ppr use_lvl]
511
512 topIdLvl :: Id -> ThLevel
513 -- Globals may either be imported, or may be from an earlier "chunk" 
514 -- (separated by declaration splices) of this module.  The former
515 --  *can* be used inside a top-level splice, but the latter cannot.
516 -- Hence we give the former impLevel, but the latter topLevel
517 -- E.g. this is bad:
518 --      x = [| foo |]
519 --      $( f x )
520 -- By the time we are prcessing the $(f x), the binding for "x" 
521 -- will be in the global env, not the local one.
522 topIdLvl id | isLocalId id = outerLevel
523             | otherwise    = impLevel
524
525 tcMetaTy :: Name -> TcM Type
526 -- Given the name of a Template Haskell data type, 
527 -- return the type
528 -- E.g. given the name "Expr" return the type "Expr"
529 tcMetaTy tc_name = do
530     t <- tcLookupTyCon tc_name
531     return (mkTyConApp t [])
532
533 thRnBrack :: ThStage
534 -- Used *only* to indicate that we are inside a TH bracket during renaming
535 -- Tested by TcEnv.isBrackStage
536 -- See Note [Top-level Names in Template Haskell decl quotes]
537 thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3") 
538
539 isBrackStage :: ThStage -> Bool
540 isBrackStage (Brack {}) = True
541 isBrackStage _other     = False
542
543 thTopLevelId :: Id -> Bool
544 -- See Note [What is a top-level Id?] in TcSplice
545 thTopLevelId id = isGlobalId id || isExternalName (idName id)
546 \end{code}
547
548
549 %************************************************************************
550 %*                                                                      *
551                  getDefaultTys                                                                          
552 %*                                                                      *
553 %************************************************************************
554
555 \begin{code}
556 tcGetDefaultTys :: Bool         -- True <=> interactive context
557                 -> TcM ([Type], -- Default types
558                         (Bool,  -- True <=> Use overloaded strings
559                          Bool)) -- True <=> Use extended defaulting rules
560 tcGetDefaultTys interactive
561   = do  { dflags <- getDOpts
562         ; let ovl_strings = xopt Opt_OverloadedStrings dflags
563               extended_defaults = interactive
564                                || xopt Opt_ExtendedDefaultRules dflags
565                                         -- See also Trac #1974 
566               flags = (ovl_strings, extended_defaults)
567     
568         ; mb_defaults <- getDeclaredDefaultTys
569         ; case mb_defaults of {
570            Just tys -> return (tys, flags) ;
571                                 -- User-supplied defaults
572            Nothing  -> do
573
574         -- No use-supplied default
575         -- Use [Integer, Double], plus modifications
576         { integer_ty <- tcMetaTy integerTyConName
577         ; checkWiredInTyCon doubleTyCon
578         ; string_ty <- tcMetaTy stringTyConName
579         ; let deflt_tys = opt_deflt extended_defaults unitTy  -- Note [Default unitTy]
580                           ++ [integer_ty, doubleTy]
581                           ++ opt_deflt ovl_strings string_ty
582         ; return (deflt_tys, flags) } } }
583   where
584     opt_deflt True  ty = [ty]
585     opt_deflt False _  = []
586 \end{code}
587
588 Note [Default unitTy]
589 ~~~~~~~~~~~~~~~~~~~~~
590 In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
591 try when defaulting.  This has very little real impact, except in the following case.
592 Consider: 
593         Text.Printf.printf "hello"
594 This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
595 want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
596 default the 'a' to (), rather than to Integer (which is what would otherwise happen;
597 and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
598 () to the list of defaulting types.  See Trac #1200.
599
600
601 %************************************************************************
602 %*                                                                      *
603 \subsection{The InstInfo type}
604 %*                                                                      *
605 %************************************************************************
606
607 The InstInfo type summarises the information in an instance declaration
608
609     instance c => k (t tvs) where b
610
611 It is used just for *local* instance decls (not ones from interface files).
612 But local instance decls includes
613         - derived ones
614         - generic ones
615 as well as explicit user written ones.
616
617 \begin{code}
618 data InstInfo a
619   = InstInfo {
620       iSpec   :: ClsInst,        -- Includes the dfun id.  Its forall'd type
621       iBinds  :: InstBindings a   -- variables scope over the stuff in InstBindings!
622     }
623
624 iDFunId :: InstInfo a -> DFunId
625 iDFunId info = instanceDFunId (iSpec info)
626
627 data InstBindings a
628   = VanillaInst                 -- The normal case
629         (LHsBinds a)            -- Bindings for the instance methods
630         [LSig a]                -- User pragmas recorded for generating 
631                                 -- specialised instances
632         Bool                    -- True <=> This code came from a standalone deriving clause
633                                 --          Used only to improve error messages
634
635   | NewTypeDerived      -- Used for deriving instances of newtypes, where the
636                         -- witness dictionary is identical to the argument 
637                         -- dictionary.  Hence no bindings, no pragmas.
638
639         TcCoercion      -- The coercion maps from newtype to the representation type
640                         -- (quantified over type variables bound by the forall'd iSpec variables)
641                         -- E.g.   newtype instance N [a] = N1 (Tree a)
642                         --        co : forall a. N [a] ~ Tree a
643
644         TyCon           -- The TyCon is the newtype N.  If it's indexed, then it's the 
645                         -- representation TyCon, so that tyConDataCons returns [N1], 
646                         -- the "data constructor".
647                         -- See Note [Newtype deriving and unused constructors]
648                         -- in TcDeriv
649
650 pprInstInfo :: InstInfo a -> SDoc
651 pprInstInfo info = hang (ptext (sLit "instance"))
652                       2 (sep [ ifPprDebug (pprForAll tvs)
653                              , pprThetaArrowTy theta, ppr tau
654                              , ptext (sLit "where")])
655   where
656     (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
657
658
659 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
660 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
661   where
662     details (VanillaInst b _ _) = pprLHsBinds b
663     details (NewTypeDerived {}) = text "Derived from the representation type"
664
665 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
666 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
667                            (_, _, cls, [ty]) -> (cls, ty)
668                            _ -> panic "simpleInstInfoClsTy"
669
670 simpleInstInfoTy :: InstInfo a -> Type
671 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
672
673 simpleInstInfoTyCon :: InstInfo a -> TyCon
674   -- Gets the type constructor for a simple instance declaration,
675   -- i.e. one of the form       instance (...) => C (T a b c) where ...
676 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
677 \end{code}
678
679 Make a name for the dict fun for an instance decl.  It's an *external*
680 name, like otber top-level names, and hence must be made with newGlobalBinder.
681
682 \begin{code}
683 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
684 newDFunName clas tys loc
685   = do  { is_boot <- tcIsHsBoot
686         ; mod     <- getModule
687         ; let info_string = occNameString (getOccName clas) ++ 
688                             concatMap (occNameString.getDFunTyKey) tys
689         ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
690         ; newGlobalBinder mod dfun_occ loc }
691 \end{code}
692
693 Make a name for the representation tycon of a family instance.  It's an
694 *external* name, like other top-level names, and hence must be made with
695 newGlobalBinder.
696
697 \begin{code}
698 newFamInstTyConName, newFamInstAxiomName :: Located Name -> [Type] -> TcM Name
699 newFamInstTyConName = mk_fam_inst_name id
700 newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc
701
702 mk_fam_inst_name :: (OccName -> OccName) -> Located Name -> [Type] -> TcM Name
703 mk_fam_inst_name adaptOcc (L loc tc_name) tys
704   = do  { mod   <- getModule
705         ; let info_string = occNameString (getOccName tc_name) ++ 
706                             concatMap (occNameString.getDFunTyKey) tys
707         ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
708         ; newGlobalBinder mod (adaptOcc occ) loc }
709 \end{code}
710
711 Stable names used for foreign exports and annotations.
712 For stable names, the name must be unique (see #1533).  If the
713 same thing has several stable Ids based on it, the
714 top-level bindings generated must not have the same name.
715 Hence we create an External name (doesn't change), and we
716 append a Unique to the string right here.
717
718 \begin{code}
719 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
720 mkStableIdFromString str sig_ty loc occ_wrapper = do
721     uniq <- newUnique
722     mod <- getModule
723     let uniq_str = showSDoc (pprUnique uniq) :: String
724         occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName
725         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
726         id  = mkExportedLocalId gnm sig_ty :: Id
727     return id
728
729 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
730 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
731 \end{code}
732
733 %************************************************************************
734 %*                                                                      *
735 \subsection{Errors}
736 %*                                                                      *
737 %************************************************************************
738
739 \begin{code}
740 pprBinders :: [Name] -> SDoc
741 -- Used in error messages
742 -- Use quotes for a single one; they look a bit "busy" for several
743 pprBinders [bndr] = quotes (ppr bndr)
744 pprBinders bndrs  = pprWithCommas ppr bndrs
745
746 notFound :: Name -> TcM TyThing
747 notFound name 
748   = do { (_gbl,lcl) <- getEnvs
749        ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> 
750                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
751                      ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)]
752                        -- Take case: printing the whole gbl env can
753                        -- cause an infnite loop, in the case where we
754                        -- are in the middle of a recursive TyCon/Class group;
755                        -- so let's just not print it!  Getting a loop here is
756                        -- very unhelpful, because it hides one compiler bug with another
757                     ) }
758
759 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
760 wrongThingErr expected thing name
761   = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> 
762                 ptext (sLit "used as a") <+> text expected)
763 \end{code}