388828ee4b051946af8920347eeb43d61289e5ae
[ghc.git] / compiler / typecheck / TcEnv.lhs
1 \begin{code}
2 module TcEnv(
3         TyThing(..), TcTyThing(..), TcId,
4
5         -- Instance environment, and InstInfo type
6         InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
7         simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, 
8         InstBindings(..),
9
10         -- Global environment
11         tcExtendGlobalEnv, 
12         tcExtendGlobalValEnv,
13         tcLookupLocatedGlobal,  tcLookupGlobal, 
14         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
15         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
16         tcLookupLocatedClass, 
17         
18         -- Local environment
19         tcExtendKindEnv, tcExtendKindEnvTvs,
20         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
21         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
22         tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe,
23         tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
24         lclEnvElts, getInLocalScope, findGlobals, 
25         wrongThingErr, pprBinders,
26         refineEnvironment,
27
28         tcExtendRecEnv,         -- For knot-tying
29
30         -- Rules
31         tcExtendRules,
32
33         -- Global type variables
34         tcGetGlobalTyVars,
35
36         -- Template Haskell stuff
37         checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, 
38         topIdLvl, 
39
40         -- New Ids
41         newLocalName, newDFunName
42   ) where
43
44 #include "HsVersions.h"
45
46 import HsSyn            ( LRuleDecl, LHsBinds, LSig, 
47                           LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
48 import TcIface          ( tcImportDecl )
49 import IfaceEnv         ( newGlobalBinder )
50 import TcRnMonad
51 import TcMType          ( zonkTcType, zonkTcTyVarsAndFV )
52 import TcType           ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
53                           substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
54                           getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
55                           tidyOpenType, isRefineableTy
56                         )
57 import qualified Type   ( getTyVar_maybe )
58 import Id               ( idName, isLocalId, setIdType )
59 import Var              ( TyVar, Id, idType, tyVarName )
60 import VarSet
61 import VarEnv
62 import RdrName          ( extendLocalRdrEnv )
63 import InstEnv          ( Instance, DFunId, instanceDFunId, instanceHead )
64 import DataCon          ( DataCon )
65 import TyCon            ( TyCon )
66 import Class            ( Class )
67 import Name             ( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName )
68 import PrelNames        ( thFAKE )
69 import NameEnv
70 import OccName          ( mkDFunOcc, occNameString )
71 import HscTypes         ( extendTypeEnvList, lookupType,
72                           TyThing(..), tyThingId, tyThingDataCon,
73                           ExternalPackageState(..) )
74
75 import SrcLoc           ( SrcLoc, Located(..) )
76 import Outputable
77 \end{code}
78
79
80 %************************************************************************
81 %*                                                                      *
82 %*                      tcLookupGlobal                                  *
83 %*                                                                      *
84 %************************************************************************
85
86 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
87 unless you know that the SrcSpan in the monad is already set to the
88 span of the Name.
89
90 \begin{code}
91 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
92 -- c.f. IfaceEnvEnv.tcIfaceGlobal
93 tcLookupLocatedGlobal name
94   = addLocM tcLookupGlobal name
95
96 tcLookupGlobal :: Name -> TcM TyThing
97 -- The Name is almost always an ExternalName, but not always
98 -- In GHCi, we may make command-line bindings (ghci> let x = True)
99 -- that bind a GlobalId, but with an InternalName
100 tcLookupGlobal name
101   = do  { env <- getGblEnv
102         
103                 -- Try local envt
104         ; case lookupNameEnv (tcg_type_env env) name of {
105                 Just thing -> return thing ;
106                 Nothing    -> do 
107          
108                 -- Try global envt
109         { (eps,hpt) <- getEpsAndHpt
110         ; case lookupType hpt (eps_PTE eps) name of  {
111             Just thing -> return thing ;
112             Nothing    -> do
113
114                 -- Should it have been in the local envt?
115         { let mod = nameModule name
116         ; if mod == tcg_mod env || mod == thFAKE then
117                 notFound name   -- It should be local, so panic
118                                 -- The thFAKE possibility is because it
119                                 -- might be in a declaration bracket
120           else
121                 tcImportDecl name       -- Go find it in an interface
122         }}}}}
123
124 tcLookupField :: Name -> TcM Id         -- Returns the selector Id
125 tcLookupField name
126   = tcLookupGlobal name         `thenM` \ thing ->
127     case thing of
128         AnId id -> return id
129         other   -> wrongThingErr "field name" (AGlobal thing) name
130
131 tcLookupDataCon :: Name -> TcM DataCon
132 tcLookupDataCon name
133   = tcLookupGlobal name `thenM` \ thing ->
134     case thing of
135         ADataCon con -> return con
136         other        -> wrongThingErr "data constructor" (AGlobal thing) name
137
138 tcLookupClass :: Name -> TcM Class
139 tcLookupClass name
140   = tcLookupGlobal name         `thenM` \ thing ->
141     case thing of
142         AClass cls -> return cls
143         other      -> wrongThingErr "class" (AGlobal thing) name
144         
145 tcLookupTyCon :: Name -> TcM TyCon
146 tcLookupTyCon name
147   = tcLookupGlobal name         `thenM` \ thing ->
148     case thing of
149         ATyCon tc -> return tc
150         other     -> wrongThingErr "type constructor" (AGlobal thing) name
151
152 tcLookupLocatedGlobalId :: Located Name -> TcM Id
153 tcLookupLocatedGlobalId = addLocM tcLookupId
154
155 tcLookupLocatedClass :: Located Name -> TcM Class
156 tcLookupLocatedClass = addLocM tcLookupClass
157
158 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
159 tcLookupLocatedTyCon = addLocM tcLookupTyCon
160 \end{code}
161
162 %************************************************************************
163 %*                                                                      *
164                 Extending the global environment
165 %*                                                                      *
166 %************************************************************************
167
168
169 \begin{code}
170 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
171   -- Given a mixture of Ids, TyCons, Classes, all from the
172   -- module being compiled, extend the global environment
173 tcExtendGlobalEnv things thing_inside
174    = do { env <- getGblEnv
175         ; let ge'  = extendTypeEnvList (tcg_type_env env) things
176         ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
177
178 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
179   -- Same deal as tcExtendGlobalEnv, but for Ids
180 tcExtendGlobalValEnv ids thing_inside 
181   = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
182 \end{code}
183
184 \begin{code}
185 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
186 -- Extend the global environments for the type/class knot tying game
187 tcExtendRecEnv gbl_stuff thing_inside
188  = updGblEnv upd thing_inside
189  where
190    upd env = env { tcg_type_env = extend (tcg_type_env env) }
191    extend env = extendNameEnvList env gbl_stuff
192 \end{code}
193
194
195 %************************************************************************
196 %*                                                                      *
197 \subsection{The local environment}
198 %*                                                                      *
199 %************************************************************************
200
201 \begin{code}
202 tcLookupLocated :: Located Name -> TcM TcTyThing
203 tcLookupLocated = addLocM tcLookup
204
205 tcLookup :: Name -> TcM TcTyThing
206 tcLookup name
207   = getLclEnv           `thenM` \ local_env ->
208     case lookupNameEnv (tcl_env local_env) name of
209         Just thing -> returnM thing
210         Nothing    -> tcLookupGlobal name `thenM` \ thing ->
211                       returnM (AGlobal thing)
212
213 tcLookupTyVar :: Name -> TcM TcTyVar
214 tcLookupTyVar name
215   = tcLookup name       `thenM` \ thing -> 
216     case thing of
217         ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
218         other       -> pprPanic "tcLookupTyVar" (ppr name)
219
220 tcLookupId :: Name -> TcM Id
221 -- Used when we aren't interested in the binding level
222 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
223 tcLookupId name
224   = tcLookup name       `thenM` \ thing -> 
225     case thing of
226         ATcId tc_id _ _   -> returnM tc_id
227         AGlobal (AnId id) -> returnM id
228         other             -> pprPanic "tcLookupId" (ppr name)
229
230 tcLookupLocalId_maybe :: Name -> TcM (Maybe Id)
231 tcLookupLocalId_maybe name
232   = getLclEnv           `thenM` \ local_env ->
233     case lookupNameEnv (tcl_env local_env) name of
234         Just (ATcId tc_id _ _) -> return (Just tc_id)
235         other                  -> return Nothing
236
237 tcLookupLocalIds :: [Name] -> TcM [TcId]
238 -- We expect the variables to all be bound, and all at
239 -- the same level as the lookup.  Only used in one place...
240 tcLookupLocalIds ns
241   = getLclEnv           `thenM` \ env ->
242     returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
243   where
244     lookup lenv lvl name 
245         = case lookupNameEnv lenv name of
246                 Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
247                 other                  -> pprPanic "tcLookupLocalIds" (ppr name)
248
249 lclEnvElts :: TcLclEnv -> [TcTyThing]
250 lclEnvElts env = nameEnvElts (tcl_env env)
251
252 getInLocalScope :: TcM (Name -> Bool)
253   -- Ids only
254 getInLocalScope = getLclEnv     `thenM` \ env ->
255                   let 
256                         lcl_env = tcl_env env
257                   in
258                   return (`elemNameEnv` lcl_env)
259 \end{code}
260
261 \begin{code}
262 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
263 tcExtendKindEnv things thing_inside
264   = updLclEnv upd thing_inside
265   where
266     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
267     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
268
269 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
270 tcExtendKindEnvTvs bndrs thing_inside
271   = updLclEnv upd thing_inside
272   where
273     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
274     extend env  = extendNameEnvList env pairs
275     pairs       = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
276
277 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
278 tcExtendTyVarEnv tvs thing_inside
279   = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
280
281 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
282 tcExtendTyVarEnv2 binds thing_inside
283   = getLclEnv      `thenM` \ env@(TcLclEnv {tcl_env = le, 
284                                             tcl_tyvars = gtvs, 
285                                             tcl_rdr = rdr_env}) ->
286     let
287         rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
288         new_tv_set = tcTyVarsOfTypes (map snd binds)
289         le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
290     in
291         -- It's important to add the in-scope tyvars to the global tyvar set
292         -- as well.  Consider
293         --      f (_::r) = let g y = y::r in ...
294         -- Here, g mustn't be generalised.  This is also important during
295         -- class and instance decls, when we mustn't generalise the class tyvars
296         -- when typechecking the methods.
297     tc_extend_gtvs gtvs new_tv_set              `thenM` \ gtvs' ->
298     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
299
300 getScopedTyVarBinds :: TcM [(Name, TcType)]
301 getScopedTyVarBinds
302   = do  { lcl_env <- getLclEnv
303         ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
304 \end{code}
305
306
307 \begin{code}
308 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
309 -- Invariant: the TcIds are fully zonked. Reasons:
310 --      (a) The kinds of the forall'd type variables are defaulted
311 --          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
312 --      (b) There are no via-Indirect occurrences of the bound variables
313 --          in the types, because instantiation does not look through such things
314 --      (c) The call to tyVarsOfTypes is ok without looking through refs
315 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
316
317 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
318 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
319
320 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
321 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
322 tcExtendIdEnv2 names_w_ids thing_inside
323   = getLclEnv           `thenM` \ env ->
324     let
325         extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
326         th_lvl              = thLevel (tcl_th_ctxt   env)
327         extra_env           = [ (name, ATcId id th_lvl (isRefineableTy (idType id)))
328                               | (name,id) <- names_w_ids]
329         le'                 = extendNameEnvList (tcl_env env) extra_env
330         rdr_env'            = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
331     in
332     traceTc (text "env2") `thenM_`
333     traceTc (text "env3" <+> ppr extra_env) `thenM_`
334     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
335     (traceTc (text "env4") `thenM_`
336     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
337 \end{code}
338
339
340 \begin{code}
341 -----------------------
342 -- findGlobals looks at the value environment and finds values
343 -- whose types mention the offending type variable.  It has to be 
344 -- careful to zonk the Id's type first, so it has to be in the monad.
345 -- We must be careful to pass it a zonked type variable, too.
346
347 findGlobals :: TcTyVarSet
348             -> TidyEnv 
349             -> TcM (TidyEnv, [SDoc])
350
351 findGlobals tvs tidy_env
352   = getLclEnv           `thenM` \ lcl_env ->
353     go tidy_env [] (lclEnvElts lcl_env)
354   where
355     go tidy_env acc [] = returnM (tidy_env, acc)
356     go tidy_env acc (thing : things)
357       = find_thing ignore_it tidy_env thing     `thenM` \ (tidy_env1, maybe_doc) ->
358         case maybe_doc of
359           Just d  -> go tidy_env1 (d:acc) things
360           Nothing -> go tidy_env1 acc     things
361
362     ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
363
364 -----------------------
365 find_thing ignore_it tidy_env (ATcId id _ _)
366   = zonkTcType  (idType id)     `thenM` \ id_ty ->
367     if ignore_it id_ty then
368         returnM (tidy_env, Nothing)
369     else let
370         (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
371         msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, 
372                    nest 2 (parens (ptext SLIT("bound at") <+>
373                                    ppr (getSrcLoc id)))]
374     in
375     returnM (tidy_env', Just msg)
376
377 find_thing ignore_it tidy_env (ATyVar tv ty)
378   = zonkTcType ty               `thenM` \ tv_ty ->
379     if ignore_it tv_ty then
380         returnM (tidy_env, Nothing)
381     else let
382         -- The name tv is scoped, so we don't need to tidy it
383         (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
384         msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
385
386         eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, 
387                    getOccName tv == getOccName tv' = empty
388                  | otherwise = equals <+> ppr tidy_ty
389                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
390         bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
391     in
392     returnM (tidy_env1, Just msg)
393 \end{code}
394
395 \begin{code}
396 refineEnvironment :: TvSubst -> TcM a -> TcM a
397 refineEnvironment reft thing_inside
398   = do  { env <- getLclEnv
399         ; let le' = mapNameEnv refine (tcl_env env)
400         ; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env) 
401         ; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside }
402   where
403     refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True
404     refine (ATyVar tv ty)      = ATyVar tv (substTy reft ty)
405     refine elt                 = elt
406 \end{code}
407
408 %************************************************************************
409 %*                                                                      *
410 \subsection{The global tyvars}
411 %*                                                                      *
412 %************************************************************************
413
414 \begin{code}
415 tc_extend_gtvs gtvs extra_global_tvs
416   = readMutVar gtvs             `thenM` \ global_tvs ->
417     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
418
419 refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet)
420 refineGlobalTyVars reft gtv_var
421   = readMutVar gtv_var                          `thenM` \ gbl_tvs ->
422     newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs)))
423 \end{code}
424
425 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
426 To improve subsequent calls to the same function it writes the zonked set back into
427 the environment.
428
429 \begin{code}
430 tcGetGlobalTyVars :: TcM TcTyVarSet
431 tcGetGlobalTyVars
432   = getLclEnv                                   `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
433     readMutVar gtv_var                          `thenM` \ gbl_tvs ->
434     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenM` \ gbl_tvs' ->
435     writeMutVar gtv_var gbl_tvs'                `thenM_` 
436     returnM gbl_tvs'
437 \end{code}
438
439
440 %************************************************************************
441 %*                                                                      *
442 \subsection{Rules}
443 %*                                                                      *
444 %************************************************************************
445
446 \begin{code}
447 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
448         -- Just pop the new rules into the EPS and envt resp
449         -- All the rules come from an interface file, not soruce
450         -- Nevertheless, some may be for this module, if we read
451         -- its interface instead of its source code
452 tcExtendRules lcl_rules thing_inside
453  = do { env <- getGblEnv
454       ; let
455           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
456       ; setGblEnv env' thing_inside }
457 \end{code}
458
459
460 %************************************************************************
461 %*                                                                      *
462                 Meta level
463 %*                                                                      *
464 %************************************************************************
465
466 \begin{code}
467 instance Outputable ThStage where
468    ppr Comp          = text "Comp"
469    ppr (Brack l _ _) = text "Brack" <+> int l
470    ppr (Splice l)    = text "Splice" <+> int l
471
472
473 thLevel :: ThStage -> ThLevel
474 thLevel Comp          = topLevel
475 thLevel (Splice l)    = l
476 thLevel (Brack l _ _) = l
477
478
479 checkWellStaged :: SDoc         -- What the stage check is for
480                 -> ThLevel      -- Binding level
481                 -> ThStage      -- Use stage
482                 -> TcM ()       -- Fail if badly staged, adding an error
483 checkWellStaged pp_thing bind_lvl use_stage
484   | bind_lvl <= use_lvl         -- OK!
485   = returnM ()  
486
487   | bind_lvl == topLevel        -- GHC restriction on top level splices
488   = failWithTc $ 
489     sep [ptext SLIT("GHC stage restriction:") <+>  pp_thing,
490          nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
491
492   | otherwise                   -- Badly staged
493   = failWithTc $ 
494     ptext SLIT("Stage error:") <+> pp_thing <+> 
495         hsep   [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
496                 ptext SLIT("but used at stage") <+> ppr use_lvl]
497   where
498     use_lvl = thLevel use_stage
499
500
501 topIdLvl :: Id -> ThLevel
502 -- Globals may either be imported, or may be from an earlier "chunk" 
503 -- (separated by declaration splices) of this module.  The former
504 --  *can* be used inside a top-level splice, but the latter cannot.
505 -- Hence we give the former impLevel, but the latter topLevel
506 -- E.g. this is bad:
507 --      x = [| foo |]
508 --      $( f x )
509 -- By the time we are prcessing the $(f x), the binding for "x" 
510 -- will be in the global env, not the local one.
511 topIdLvl id | isLocalId id = topLevel
512             | otherwise    = impLevel
513
514 -- Indicates the legal transitions on bracket( [| |] ).
515 bracketOK :: ThStage -> Maybe ThLevel
516 bracketOK (Brack _ _ _) = Nothing       -- Bracket illegal inside a bracket
517 bracketOK stage         = Just (thLevel stage + 1)
518
519 -- Indicates the legal transitions on splice($).
520 spliceOK :: ThStage -> Maybe ThLevel
521 spliceOK (Splice _) = Nothing   -- Splice illegal inside splice
522 spliceOK stage      = Just (thLevel stage - 1)
523
524 tcMetaTy :: Name -> TcM Type
525 -- Given the name of a Template Haskell data type, 
526 -- return the type
527 -- E.g. given the name "Expr" return the type "Expr"
528 tcMetaTy tc_name
529   = tcLookupTyCon tc_name       `thenM` \ t ->
530     returnM (mkTyConApp t [])
531 \end{code}
532
533
534 %************************************************************************
535 %*                                                                      *
536 \subsection{The InstInfo type}
537 %*                                                                      *
538 %************************************************************************
539
540 The InstInfo type summarises the information in an instance declaration
541
542     instance c => k (t tvs) where b
543
544 It is used just for *local* instance decls (not ones from interface files).
545 But local instance decls includes
546         - derived ones
547         - generic ones
548 as well as explicit user written ones.
549
550 \begin{code}
551 data InstInfo
552   = InstInfo {
553       iSpec  :: Instance,               -- Includes the dfun id.  Its forall'd type 
554       iBinds :: InstBindings            -- variables scope over the stuff in InstBindings!
555     }
556
557 iDFunId :: InstInfo -> DFunId
558 iDFunId info = instanceDFunId (iSpec info)
559
560 data InstBindings
561   = VanillaInst                 -- The normal case
562         (LHsBinds Name)         -- Bindings
563         [LSig Name]             -- User pragmas recorded for generating 
564                                 -- specialised instances
565
566   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
567         [Type]                  -- witness dictionary is identical to the argument 
568                                 -- dictionary.  Hence no bindings, no pragmas
569         -- The [Type] are the representation types
570         -- See notes in TcDeriv
571
572 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
573
574 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
575   where
576     details (VanillaInst b _)  = pprLHsBinds b
577     details (NewTypeDerived _) = text "Derived from the representation type"
578
579 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
580 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
581                           (_, _, cls, [ty]) -> (cls, ty)
582
583 simpleInstInfoTy :: InstInfo -> Type
584 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
585
586 simpleInstInfoTyCon :: InstInfo -> TyCon
587   -- Gets the type constructor for a simple instance declaration,
588   -- i.e. one of the form       instance (...) => C (T a b c) where ...
589 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
590 \end{code}
591
592 Make a name for the dict fun for an instance decl.  It's an *external*
593 name, like otber top-level names, and hence must be made with newGlobalBinder.
594
595 \begin{code}
596 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
597 newDFunName clas (ty:_) loc
598   = do  { index   <- nextDFunIndex
599         ; is_boot <- tcIsHsBoot
600         ; mod     <- getModule
601         ; let info_string = occNameString (getOccName clas) ++ 
602                             occNameString (getDFunTyKey ty)
603               dfun_occ = mkDFunOcc info_string is_boot index
604
605         ; newGlobalBinder mod dfun_occ Nothing loc }
606
607 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
608 \end{code}
609
610
611 %************************************************************************
612 %*                                                                      *
613 \subsection{Errors}
614 %*                                                                      *
615 %************************************************************************
616
617 \begin{code}
618 pprBinders :: [Name] -> SDoc
619 -- Used in error messages
620 -- Use quotes for a single one; they look a bit "busy" for several
621 pprBinders [bndr] = quotes (ppr bndr)
622 pprBinders bndrs  = pprWithCommas ppr bndrs
623
624 notFound name 
625   = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> 
626                 ptext SLIT("is not in scope"))
627
628 wrongThingErr expected thing name
629   = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> 
630                 ptext SLIT("used as a") <+> text expected)
631 \end{code}