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