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