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