ghc/compiler/typecheck/TcEnv.lhs

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