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