ghc/compiler/typecheck/TcRnDriver.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 module TcRnDriver (
   8 #ifdef GHCI
   9         mkExportEnv, getModuleContents, tcRnStmt,
  10         tcRnThing, tcRnExpr, tcRnType,
  11 #endif
  12         tcRnModule,
  13         tcTopSrcDecls,
  14         tcRnExtCore
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 #ifdef GHCI
  20 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
  21 #endif
  22
  23 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
  24 import DriverState      ( v_MainModIs, v_MainFunIs )
  25 import HsSyn            ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
  26                           nlHsApp, nlHsVar, pprLHsBinds )
  27 import RdrHsSyn         ( findSplice )
  28
  29 import PrelNames        ( runIOName, rootMainName, mAIN_Name,
  30                           main_RDR_Unqual )
  31 import RdrName          ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
  32                           plusGlobalRdrEnv )
  33 import TcHsSyn          ( zonkTopDecls )
  34 import TcExpr           ( tcInferRho )
  35 import TcRnMonad
  36 import TcType           ( tidyTopType, isUnLiftedType )
  37 import Inst             ( showLIE )
  38 import TcBinds          ( tcTopBinds )
  39 import TcDefaults       ( tcDefaults )
  40 import TcEnv            ( tcExtendGlobalValEnv )
  41 import TcRules          ( tcRules )
  42 import TcForeign        ( tcForeignImports, tcForeignExports )
  43 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  44 import TcIface          ( tcExtCoreBindings )
  45 import TcSimplify       ( tcSimplifyTop )
  46 import TcTyClsDecls     ( tcTyAndClassDecls )
  47 import LoadIface        ( loadOrphanModules )
  48 import RnNames          ( importsFromLocalDecls, rnImports, exportsFromAvail,
  49                           reportUnusedNames, reportDeprecations )
  50 import RnEnv            ( lookupSrcOcc_maybe )
  51 import RnSource         ( rnSrcDecls, rnTyClDecls, checkModDeprec )
  52 import PprCore          ( pprIdRules, pprCoreBindings )
  53 import CoreSyn          ( IdCoreRule, bindersOfBinds )
  54 import ErrUtils         ( Messages, mkDumpDoc, showPass )
  55 import Id               ( mkExportedLocalId, isLocalId, idName, idType )
  56 import Var              ( Var )
  57 import Module           ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
  58 import OccName          ( mkVarOcc )
  59 import Name             ( Name, isExternalName, getSrcLoc, getOccName )
  60 import NameSet
  61 import TyCon            ( tyConHasGenerics )
  62 import SrcLoc           ( srcLocSpan, Located(..), noLoc )
  63 import Outputable
  64 import HscTypes         ( ModGuts(..), HscEnv(..),
  65                           GhciMode(..), Dependencies(..), noDependencies,
  66                           Deprecs( NoDeprecs ), plusDeprecs,
  67                           ForeignStubs(NoStubs), TypeEnv,
  68                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
  69                           emptyFixityEnv
  70                         )
  71 #ifdef GHCI
  72 import HsSyn            ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
  73                           LStmt, LHsExpr, LHsType,
  74                           collectStmtsBinders, mkSimpleMatch, placeHolderType,
  75                           nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
  76 import RdrName          ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
  77                           Provenance(..), ImportSpec(..),
  78                           lookupLocalRdrEnv, extendLocalRdrEnv )
  79 import RnSource         ( addTcgDUs )
  80 import TcHsSyn          ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
  81 import TcHsType         ( kcHsType )
  82 import TcExpr           ( tcCheckRho )
  83 import TcMType          ( zonkTcType )
  84 import TcMatches        ( tcStmtsAndThen, TcStmtCtxt(..) )
  85 import TcSimplify       ( tcSimplifyInteractive, tcSimplifyInfer )
  86 import TcType           ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
  87 import TcEnv            ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
  88 import RnTypes          ( rnLHsType )
  89 import Inst             ( tcStdSyntaxName )
  90 import RnExpr           ( rnStmts, rnLExpr )
  91 import RnNames          ( exportsToAvails )
  92 import LoadIface        ( loadSrcInterface )
  93 import IfaceSyn         ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
  94                           IfaceExtName(..), IfaceConDecls(..),
  95                           tyThingToIfaceDecl )
  96 import RnEnv            ( lookupOccRn, dataTcOccs, lookupFixityRn )
  97 import Id               ( Id, isImplicitId, globalIdDetails )
  98 import FieldLabel       ( fieldLabelTyCon )
  99 import MkId             ( unsafeCoerceId )
 100 import DataCon          ( dataConTyCon )
 101 import TysWiredIn       ( mkListTy, unitTy )
 102 import IdInfo           ( GlobalIdDetails(..) )
 103 import SrcLoc           ( interactiveSrcLoc, unLoc )
 104 import Kind             ( Kind )
 105 import Var              ( globaliseId )
 106 import Name             ( nameOccName, nameModuleName )
 107 import NameEnv          ( delListFromNameEnv )
 108 import PrelNames        ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
 109 import Module           ( ModuleName, lookupModuleEnvByName )
 110 import HscTypes         ( InteractiveContext(..),
 111                           HomeModInfo(..), typeEnvElts,
 112                           TyThing(..), availName, availNames, icPrintUnqual,
 113                           ModIface(..), ModDetails(..) )
 114 import BasicTypes       ( RecFlag(..), Fixity )
 115 import Bag              ( unitBag )
 116 import ListSetOps       ( removeDups )
 117 import Panic            ( ghcError, GhcException(..) )
 118 #endif
 119
 120 import FastString       ( mkFastString )
 121 import Util             ( sortLt )
 122 import Bag              ( unionBags, snocBag )
 123
 124 import Maybe            ( isJust )
 125 \end{code}
 126
 127
 128
 129 %************************************************************************
 130 %*                                                                      *
 131         Typecheck and rename a module
 132 %*                                                                      *
 133 %************************************************************************
 134
 135
 136 \begin{code}
 137 tcRnModule :: HscEnv
 138            -> Located (HsModule RdrName)
 139            -> IO (Messages, Maybe TcGblEnv)
 140
 141 tcRnModule hsc_env (L loc (HsModule maybe_mod exports
 142                                 import_decls local_decls mod_deprec))
 143  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 144
 145    let { this_mod = case maybe_mod of
 146                         Nothing  -> mkHomeModule mAIN_Name
 147                                         -- 'module M where' is omitted
 148                         Just (L _ mod) -> mod } ;
 149                                         -- The normal case
 150
 151    initTc hsc_env this_mod $
 152    addSrcSpan loc $
 153    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
 154         (rdr_env, imports) <- rnImports import_decls ;
 155         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
 156                                    tcg_imports = tcg_imports gbl `plusImportAvails` imports })
 157                      $ do {
 158         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
 159                 -- Fail if there are any errors so far
 160                 -- The error printing (if needed) takes advantage
 161                 -- of the tcg_env we have now set
 162         failIfErrsM ;
 163
 164                 -- Load any orphan-module interfaces, so that
 165                 -- their rules and instance decls will be found
 166         loadOrphanModules (imp_orphs imports) ;
 167
 168         traceRn (text "rn1a") ;
 169                 -- Rename and type check the declarations
 170         tcg_env <- tcRnSrcDecls local_decls ;
 171         setGblEnv tcg_env               $ do {
 172
 173         traceRn (text "rn3") ;
 174
 175                 -- Report the use of any deprecated things
 176                 -- We do this before processsing the export list so
 177                 -- that we don't bleat about re-exporting a deprecated
 178                 -- thing (especially via 'module Foo' export item)
 179                 -- Only uses in the body of the module are complained about
 180         reportDeprecations tcg_env ;
 181
 182                 -- Process the export list
 183         exports <- exportsFromAvail (isJust maybe_mod) exports ;
 184
 185 {-      Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
 186                 -- Get any supporting decls for the exports that have not already
 187                 -- been sucked in for the declarations in the body of the module.
 188                 -- (This can happen if something is imported only to be re-exported.)
 189                 --
 190                 -- Importing these supporting declarations is required
 191                 --      *only* to gether usage information
 192                 --      (see comments with MkIface.mkImportInfo for why)
 193                 -- We don't need the results, but sucking them in may side-effect
 194                 -- the ExternalPackageState, apart from recording usage
 195         mappM (tcLookupGlobal . availName) export_avails ;
 196 -}
 197
 198                 -- Check whether the entire module is deprecated
 199                 -- This happens only once per module
 200         let { mod_deprecs = checkModDeprec mod_deprec } ;
 201
 202                 -- Add exports and deprecations to envt
 203         let { final_env  = tcg_env { tcg_exports = exports,
 204                                      tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
 205                                      tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
 206                                                    mod_deprecs }
 207                 -- A module deprecation over-rides the earlier ones
 208              } ;
 209
 210                 -- Report unused names
 211         reportUnusedNames final_env ;
 212
 213                 -- Dump output and return
 214         tcDump final_env ;
 215         return final_env
 216     }}}}
 217 \end{code}
 218
 219
 220 %************************************************************************
 221 %*                                                                      *
 222                 The interactive interface
 223 %*                                                                      *
 224 %************************************************************************
 225
 226 \begin{code}
 227 #ifdef GHCI
 228 tcRnStmt :: HscEnv
 229          -> InteractiveContext
 230          -> LStmt RdrName
 231          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 232                 -- The returned [Name] is the same as the input except for
 233                 -- ExprStmt, in which case the returned [Name] is [itName]
 234                 --
 235                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 236                 -- a list of the bound values, coerced to ().
 237
 238 tcRnStmt hsc_env ictxt rdr_stmt
 239   = initTcPrintErrors hsc_env iNTERACTIVE $
 240     setInteractiveContext ictxt $ do {
 241
 242     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 243     ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
 244     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 245     failIfErrsM ;
 246
 247     -- The real work is done here
 248     (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
 249
 250     traceTc (text "tcs 1") ;
 251     let {       -- Make all the bound ids "global" ids, now that
 252                 -- they're notionally top-level bindings.  This is
 253                 -- important: otherwise when we come to compile an expression
 254                 -- using these ids later, the byte code generator will consider
 255                 -- the occurrences to be free rather than global.
 256         global_ids     = map (globaliseId VanillaGlobal) bound_ids ;
 257
 258                 -- Update the interactive context
 259         rn_env   = ic_rn_local_env ictxt ;
 260         type_env = ic_type_env ictxt ;
 261
 262         bound_names = map idName global_ids ;
 263         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 264
 265                 -- Remove any shadowed bindings from the type_env;
 266                 -- they are inaccessible but might, I suppose, cause
 267                 -- a space leak if we leave them there
 268         shadowed = [ n | name <- bound_names,
 269                          let rdr_name = mkRdrUnqual (nameOccName name),
 270                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 271
 272         filtered_type_env = delListFromNameEnv type_env shadowed ;
 273         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 274
 275         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 276                          ic_type_env     = new_type_env }
 277     } ;
 278
 279     dumpOptTcRn Opt_D_dump_tc
 280         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 281                text "Typechecked expr" <+> ppr tc_expr]) ;
 282
 283     returnM (new_ic, bound_names, tc_expr)
 284     }
 285 \end{code}
 286
 287
 288 Here is the grand plan, implemented in tcUserStmt
 289
 290         What you type                   The IO [HValue] that hscStmt returns
 291         -------------                   ------------------------------------
 292         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 293                                         bindings: [x,y,...]
 294
 295         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 296                                         bindings: [x,y,...]
 297
 298         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
 299           [NB: result not printed]      bindings: [it]
 300
 301         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
 302           result showable)              bindings: [it]
 303
 304         expr (of non-IO type,
 305           result not showable)  ==>     error
 306
 307
 308 \begin{code}
 309 ---------------------------
 310 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
 311 tcUserStmt (L _ (ExprStmt expr _))
 312   = newUnique           `thenM` \ uniq ->
 313     let
 314         fresh_it = itName uniq
 315         the_bind = noLoc $ FunBind (noLoc fresh_it) False
 316                         [ mkSimpleMatch [] expr placeHolderType ]
 317     in
 318     tryTcLIE_ (do {     -- Try this if the other fails
 319                 traceTc (text "tcs 1b") ;
 320                 tc_stmts [
 321                     nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
 322                     nlExprStmt (nlHsApp (nlHsVar printName)
 323                                               (nlHsVar fresh_it))
 324         ] })
 325           (do {         -- Try this first
 326                 traceTc (text "tcs 1a") ;
 327                 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
 328
 329 tcUserStmt stmt = tc_stmts [stmt]
 330
 331 ---------------------------
 332 tc_stmts stmts
 333  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 334         let {
 335             ret_ty    = mkListTy unitTy ;
 336             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 337
 338             names = map unLoc (collectStmtsBinders stmts) ;
 339
 340             stmt_ctxt = SC { sc_what = DoExpr,
 341                              sc_rhs  = check_rhs,
 342                              sc_body = check_body,
 343                              sc_ty   = ret_ty } ;
 344
 345             check_rhs rhs rhs_ty = tcCheckRho rhs  (mkTyConApp ioTyCon [rhs_ty]) ;
 346             check_body body      = tcCheckRho body io_ret_ty ;
 347
 348                 -- mk_return builds the expression
 349                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 350                 --
 351                 -- Despite the inconvenience of building the type applications etc,
 352                 -- this *has* to be done in type-annotated post-typecheck form
 353                 -- because we are going to return a list of *polymorphic* values
 354                 -- coerced to type (). If we built a *source* stmt
 355                 --      return [coerce x, ..., coerce z]
 356                 -- then the type checker would instantiate x..z, and we wouldn't
 357                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
 358                 -- if they were overloaded, since they aren't applied to anything.)
 359             mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
 360                                            (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
 361             mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
 362                                (nlHsVar id) ;
 363
 364             io_ty = mkTyConApp ioTyCon []
 365          } ;
 366
 367         -- OK, we're ready to typecheck the stmts
 368         traceTc (text "tcs 2") ;
 369         ((ids, tc_expr), lie) <- getLIE $ do {
 370             (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts   $
 371                         do {
 372                             -- Look up the names right in the middle,
 373                             -- where they will all be in scope
 374                             ids <- mappM tcLookupId names ;
 375                             ret_id <- tcLookupId returnIOName ;         -- return @ IO
 376                             return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
 377
 378             io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 379             return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
 380         } ;
 381
 382         -- Simplify the context right here, so that we fail
 383         -- if there aren't enough instances.  Notably, when we see
 384         --              e
 385         -- we use recoverTc_ to try     it <- e
 386         -- and then                     let it = e
 387         -- It's the simplify step that rejects the first.
 388         traceTc (text "tcs 3") ;
 389         const_binds <- tcSimplifyInteractive lie ;
 390
 391         -- Build result expression and zonk it
 392         let { expr = mkHsLet const_binds tc_expr } ;
 393         zonked_expr <- zonkTopLExpr expr ;
 394         zonked_ids  <- zonkTopBndrs ids ;
 395
 396         -- None of the Ids should be of unboxed type, because we
 397         -- cast them all to HValues in the end!
 398         mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 399
 400         return (zonked_ids, zonked_expr)
 401         }
 402   where
 403     combine stmt (ids, stmts) = (ids, stmt:stmts)
 404     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
 405                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 406 \end{code}
 407
 408
 409 tcRnExpr just finds the type of an expression
 410
 411 \begin{code}
 412 tcRnExpr :: HscEnv
 413          -> InteractiveContext
 414          -> LHsExpr RdrName
 415          -> IO (Maybe Type)
 416 tcRnExpr hsc_env ictxt rdr_expr
 417   = initTcPrintErrors hsc_env iNTERACTIVE $
 418     setInteractiveContext ictxt $ do {
 419
 420     (rn_expr, fvs) <- rnLExpr rdr_expr ;
 421     failIfErrsM ;
 422
 423         -- Now typecheck the expression;
 424         -- it might have a rank-2 type (e.g. :t runST)
 425     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 426     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 427     tcSimplifyInteractive lie_top ;
 428
 429     let { all_expr_ty = mkForAllTys qtvs                $
 430                         mkFunTys (map idType dict_ids)  $
 431                         res_ty } ;
 432     zonkTcType all_expr_ty
 433     }
 434   where
 435     smpl_doc = ptext SLIT("main expression")
 436 \end{code}
 437
 438 tcRnExpr just finds the kind of a type
 439
 440 \begin{code}
 441 tcRnType :: HscEnv
 442          -> InteractiveContext
 443          -> LHsType RdrName
 444          -> IO (Maybe Kind)
 445 tcRnType hsc_env ictxt rdr_type
 446   = initTcPrintErrors hsc_env iNTERACTIVE $
 447     setInteractiveContext ictxt $ do {
 448
 449     rn_type <- rnLHsType doc rdr_type ;
 450     failIfErrsM ;
 451
 452         -- Now kind-check the type
 453     (ty', kind) <- kcHsType rn_type ;
 454     return kind
 455     }
 456   where
 457     doc = ptext SLIT("In GHCi input")
 458 \end{code}
 459
 460 \begin{code}
 461 tcRnThing :: HscEnv
 462           -> InteractiveContext
 463           -> RdrName
 464           -> IO (Maybe [(IfaceDecl, Fixity)])
 465 -- Look up a RdrName and return all the TyThings it might be
 466 -- A capitalised RdrName is given to us in the DataName namespace,
 467 -- but we want to treat it as *both* a data constructor
 468 -- *and* as a type or class constructor;
 469 -- hence the call to dataTcOccs, and we return up to two results
 470 tcRnThing hsc_env ictxt rdr_name
 471   = initTcPrintErrors hsc_env iNTERACTIVE $
 472     setInteractiveContext ictxt $ do {
 473
 474         -- If the identifier is a constructor (begins with an
 475         -- upper-case letter), then we need to consider both
 476         -- constructor and type class identifiers.
 477     let { rdr_names = dataTcOccs rdr_name } ;
 478
 479         -- results :: [(Messages, Maybe Name)]
 480     results <- mapM (tryTc . lookupOccRn) rdr_names ;
 481
 482         -- The successful lookups will be (Just name)
 483     let { (warns_s, good_names) = unzip [ (msgs, name)
 484                                         | (msgs, Just name) <- results] ;
 485           errs_s = [msgs | (msgs, Nothing) <- results] } ;
 486
 487         -- Fail if nothing good happened, else add warnings
 488     if null good_names then
 489                 -- No lookup succeeded, so
 490                 -- pick the first error message and report it
 491                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
 492                 --       while the other is "X is not in scope",
 493                 --       we definitely want the former; but we might pick the latter
 494         do { addMessages (head errs_s) ; failM }
 495       else                      -- Add deprecation warnings
 496         mapM_ addMessages warns_s ;
 497
 498         -- And lookup up the entities, avoiding duplicates, which arise
 499         -- because constructors and record selectors are represented by
 500         -- their parent declaration
 501     let { do_one name = do { thing <- tcLookupGlobal name
 502                            ; let decl = toIfaceDecl ictxt thing
 503                            ; fixity <- lookupFixityRn name
 504                            ; return (decl, fixity) } ;
 505           cmp (d1,_) (d2,_) = ifName d1 `compare` ifName d2 } ;
 506     results <- mapM do_one good_names ;
 507     return (fst (removeDups cmp results))
 508     }
 509
 510 toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
 511 toIfaceDecl ictxt thing
 512   = tyThingToIfaceDecl True             -- Discard IdInfo
 513                        emptyNameSet     -- Show data cons
 514                        ext_nm (munge thing)
 515   where
 516     unqual = icPrintUnqual ictxt
 517     ext_nm n | unqual n  = LocalTop (nameOccName n)     -- What a hack
 518              | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
 519
 520         -- munge transforms a thing to it's "parent" thing
 521     munge (ADataCon dc) = ATyCon (dataConTyCon dc)
 522     munge (AnId id) = case globalIdDetails id of
 523                         RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
 524                         ClassOpId cls   -> AClass cls
 525                         other           -> AnId id
 526     munge other_thing = other_thing
 527 \end{code}
 528
 529
 530 \begin{code}
 531 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
 532 setInteractiveContext icxt thing_inside
 533   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 534     (updGblEnv (\env -> env {tcg_rdr_env  = ic_rn_gbl_env icxt,
 535                              tcg_type_env = ic_type_env   icxt}) $
 536      updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt})   $
 537                thing_inside)
 538 #endif /* GHCI */
 539 \end{code}
 540
 541 %************************************************************************
 542 %*                                                                      *
 543         Type-checking external-core modules
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 \begin{code}
 548 tcRnExtCore :: HscEnv
 549             -> HsExtCore RdrName
 550             -> IO (Messages, Maybe ModGuts)
 551         -- Nothing => some error occurred
 552
 553 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 554         -- The decls are IfaceDecls; all names are original names
 555  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 556
 557    initTc hsc_env this_mod $ do {
 558
 559    let { ldecls  = map noLoc decls } ;
 560
 561         -- Deal with the type declarations; first bring their stuff
 562         -- into scope, then rname them, then type check them
 563    (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
 564
 565    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 566                             tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 567                   $ do {
 568
 569    rn_decls <- rnTyClDecls ldecls ;
 570    failIfErrsM ;
 571
 572         -- Dump trace of renaming part
 573    rnDump (ppr rn_decls) ;
 574
 575         -- Typecheck them all together so that
 576         -- any mutually recursive types are done right
 577    tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
 578         -- Make the new type env available to stuff slurped from interface files
 579
 580    setGblEnv tcg_env $ do {
 581
 582         -- Now the core bindings
 583    core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
 584
 585         -- Wrap up
 586    let {
 587         bndrs      = bindersOfBinds core_binds ;
 588         my_exports = mkNameSet (map idName bndrs) ;
 589                 -- ToDo: export the data types also?
 590
 591         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 592
 593         mod_guts = ModGuts {    mg_module   = this_mod,
 594                                 mg_usages   = [],               -- ToDo: compute usage
 595                                 mg_dir_imps = [],               -- ??
 596                                 mg_deps     = noDependencies,   -- ??
 597                                 mg_exports  = my_exports,
 598                                 mg_types    = final_type_env,
 599                                 mg_insts    = tcg_insts tcg_env,
 600                                 mg_rules    = [],
 601                                 mg_binds    = core_binds,
 602
 603                                 -- Stubs
 604                                 mg_rdr_env  = emptyGlobalRdrEnv,
 605                                 mg_fix_env  = emptyFixityEnv,
 606                                 mg_deprecs  = NoDeprecs,
 607                                 mg_foreign  = NoStubs
 608                     } } ;
 609
 610    tcCoreDump mod_guts ;
 611
 612    return mod_guts
 613    }}}}
 614
 615 mkFakeGroup decls -- Rather clumsy; lots of unused fields
 616   = HsGroup {   hs_tyclds = decls,      -- This is the one we want
 617                 hs_valds = [], hs_fords = [],
 618                 hs_instds = [], hs_fixds = [], hs_depds = [],
 619                 hs_ruleds = [], hs_defds = [] }
 620 \end{code}
 621
 622
 623 %************************************************************************
 624 %*                                                                      *
 625         Type-checking the top level of a module
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 631         -- Returns the variables free in the decls
 632         -- Reason: solely to report unused imports and bindings
 633 tcRnSrcDecls decls
 634  = do {         -- Do all the declarations
 635         (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
 636
 637              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 638              -- How could there be ambiguous ones?  They can only arise if a
 639              -- top-level decl falls under the monomorphism
 640              -- restriction, and no subsequent decl instantiates its
 641              -- type.  (Usually, ambiguous type variables are resolved
 642              -- during the generalisation step.)
 643         traceTc (text "Tc8") ;
 644         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
 645                 -- Setting the global env exposes the instances to tcSimplifyTop
 646                 -- Setting the local env exposes the local Ids to tcSimplifyTop,
 647                 -- so that we get better error messages (monomorphism restriction)
 648
 649             -- Backsubstitution.  This must be done last.
 650             -- Even tcSimplifyTop may do some unification.
 651         traceTc (text "Tc9") ;
 652         let { (tcg_env, _) = tc_envs ;
 653               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 654                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 655
 656         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
 657                                                            rules fords ;
 658
 659         let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
 660
 661         -- Make the new type env available to stuff slurped from interface files
 662         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 663
 664         return (tcg_env { tcg_type_env = final_type_env,
 665                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
 666    }
 667
 668 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
 669 -- Loops around dealing with each top level inter-splice group
 670 -- in turn, until it's dealt with the entire module
 671 tc_rn_src_decls ds
 672  = do { let { (first_group, group_tail) = findSplice ds } ;
 673                 -- If ds is [] we get ([], Nothing)
 674
 675         -- Type check the decls up to, but not including, the first splice
 676         tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
 677
 678         -- Bale out if errors; for example, error recovery when checking
 679         -- the RHS of 'main' can mean that 'main' is not in the envt for
 680         -- the subsequent checkMain test
 681         failIfErrsM ;
 682
 683         setEnvs tc_envs $
 684
 685         -- If there is no splice, we're nearly done
 686         case group_tail of {
 687            Nothing -> do {      -- Last thing: check for `main'
 688                            tcg_env <- checkMain ;
 689                            return (tcg_env, tcl_env)
 690                       } ;
 691
 692         -- If there's a splice, we must carry on
 693            Just (SpliceDecl splice_expr, rest_ds) -> do {
 694 #ifndef GHCI
 695         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 696 #else
 697
 698         -- Rename the splice expression, and get its supporting decls
 699         (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
 700         failIfErrsM ;   -- Don't typecheck if renaming failed
 701
 702         -- Execute the splice
 703         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 704
 705         -- Glue them on the front of the remaining decls and loop
 706         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 707         tc_rn_src_decls (spliced_decls ++ rest_ds)
 708 #endif /* GHCI */
 709     }}}
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715         Type-checking the top level of a module
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 tcRnGroup takes a bunch of top-level source-code declarations, and
 720  * renames them
 721  * gets supporting declarations from interface files
 722  * typechecks them
 723  * zonks them
 724  * and augments the TcGblEnv with the results
 725
 726 In Template Haskell it may be called repeatedly for each group of
 727 declarations.  It expects there to be an incoming TcGblEnv in the
 728 monad; it augments it and returns the new TcGblEnv.
 729
 730 \begin{code}
 731 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 732         -- Returns the variables free in the decls, for unused-binding reporting
 733 tcRnGroup decls
 734  = do {         -- Rename the declarations
 735         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 736         setGblEnv tcg_env $ do {
 737
 738                 -- Typecheck the declarations
 739         tcTopSrcDecls rn_decls
 740   }}
 741
 742 ------------------------------------------------
 743 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 744 rnTopSrcDecls group
 745  = do {         -- Bring top level binders into scope
 746         (rdr_env, imports) <- importsFromLocalDecls group ;
 747         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 748                                  tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 749                   $ do {
 750
 751         traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
 752         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 753
 754                 -- Rename the source decls
 755         (tcg_env, rn_decls) <- rnSrcDecls group ;
 756         failIfErrsM ;
 757
 758                 -- Dump trace of renaming part
 759         rnDump (ppr rn_decls) ;
 760
 761         return (tcg_env, rn_decls)
 762    }}
 763
 764 ------------------------------------------------
 765 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 766 tcTopSrcDecls
 767         (HsGroup { hs_tyclds = tycl_decls,
 768                    hs_instds = inst_decls,
 769                    hs_fords  = foreign_decls,
 770                    hs_defds  = default_decls,
 771                    hs_ruleds = rule_decls,
 772                    hs_valds  = val_binds })
 773  = do {         -- Type-check the type and class decls, and all imported decls
 774                 -- The latter come in via tycl_decls
 775         traceTc (text "Tc2") ;
 776
 777         tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
 778         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 779         -- an error we'd better stop now, to avoid a cascade
 780
 781         -- Make these type and class decls available to stuff slurped from interface files
 782         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 783
 784
 785         setGblEnv tcg_env       $ do {
 786                 -- Source-language instances, including derivings,
 787                 -- and import the supporting declarations
 788         traceTc (text "Tc3") ;
 789         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 790         setGblEnv tcg_env       $ do {
 791
 792                 -- Foreign import declarations next.  No zonking necessary
 793                 -- here; we can tuck them straight into the global environment.
 794         traceTc (text "Tc4") ;
 795         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 796         tcExtendGlobalValEnv fi_ids     $ do {
 797
 798                 -- Default declarations
 799         traceTc (text "Tc4a") ;
 800         default_tys <- tcDefaults default_decls ;
 801         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 802
 803                 -- Value declarations next
 804                 -- We also typecheck any extra binds that came out
 805                 -- of the "deriving" process (deriv_binds)
 806         traceTc (text "Tc5") ;
 807         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
 808         setLclTypeEnv lcl_env   $ do {
 809
 810                 -- Second pass over class and instance declarations,
 811         traceTc (text "Tc6") ;
 812         (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
 813         showLIE (text "after instDecls2") ;
 814
 815                 -- Foreign exports
 816                 -- They need to be zonked, so we return them
 817         traceTc (text "Tc7") ;
 818         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 819
 820                 -- Rules
 821         rules <- tcRules rule_decls ;
 822
 823                 -- Wrap up
 824         traceTc (text "Tc7a") ;
 825         tcg_env <- getGblEnv ;
 826         let { all_binds = tc_val_binds   `unionBags`
 827                           inst_binds     `unionBags`
 828                           foe_binds  ;
 829
 830                 -- Extend the GblEnv with the (as yet un-zonked)
 831                 -- bindings, rules, foreign decls
 832               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 833                                     tcg_rules = tcg_rules tcg_env ++ rules,
 834                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 835         return (tcg_env', lcl_env)
 836     }}}}}}
 837 \end{code}
 838
 839
 840 %*********************************************************
 841 %*                                                       *
 842         mkGlobalContext: make up an interactive context
 843
 844         Used for initialising the lexical environment
 845         of the interactive read-eval-print loop
 846 %*                                                       *
 847 %*********************************************************
 848
 849 \begin{code}
 850 #ifdef GHCI
 851 mkExportEnv :: HscEnv -> [ModuleName]   -- Expose these modules' exports only
 852             -> IO GlobalRdrEnv
 853
 854 mkExportEnv hsc_env exports
 855   = do  { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
 856                      mappM getModuleExports exports
 857         ; case mb_envs of
 858              Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
 859              Nothing   -> return emptyGlobalRdrEnv
 860                              -- Some error; initTc will have printed it
 861     }
 862
 863 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 864 getModuleExports mod
 865   = do  { iface <- load_iface mod
 866         ; loadOrphanModules (dep_orphs (mi_deps iface))
 867                         -- Load any orphan-module interfaces,
 868                         -- so their instances are visible
 869         ; avails <- exportsToAvails (mi_exports iface)
 870         ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 871                         | avail <- avails, name <- availNames avail ] }
 872         ; returnM (mkGlobalRdrEnv gres) }
 873
 874 vanillaProv :: ModuleName -> Provenance
 875 -- We're building a GlobalRdrEnv as if the user imported
 876 -- all the specified modules into the global interactive module
 877 vanillaProv mod = Imported [ImportSpec mod mod False
 878                              (srcLocSpan interactiveSrcLoc)] False
 879 \end{code}
 880
 881 \begin{code}
 882 getModuleContents
 883   :: HscEnv
 884   -> InteractiveContext
 885   -> ModuleName                 -- Module to inspect
 886   -> Bool                       -- Grab just the exports, or the whole toplev
 887   -> IO (Maybe [IfaceDecl])
 888
 889 getModuleContents hsc_env ictxt mod exports_only
 890  = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
 891  where
 892    get_mod_contents exports_only
 893       | not exports_only  -- We want the whole top-level type env
 894                           -- so it had better be a home module
 895       = do { hpt <- getHpt
 896            ; case lookupModuleEnvByName hpt mod of
 897                Just mod_info -> return (map (toIfaceDecl ictxt) $
 898                                         filter wantToSee $
 899                                         typeEnvElts $
 900                                         md_types (hm_details mod_info))
 901                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 902                           -- This is a system error; the module should be in the HPT
 903            }
 904
 905       | otherwise               -- Want the exports only
 906       = do { iface <- load_iface mod
 907            ; avails <- exportsToAvails (mi_exports iface)
 908            ; mappM get_decl avails
 909         }
 910
 911    get_decl avail
 912         = do { thing <- tcLookupGlobal (availName avail)
 913              ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
 914
 915 ---------------------
 916 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
 917   = decl { ifSigs = filter (keep_sig occs) sigs }
 918 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
 919   = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
 920 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
 921   | keep_con occs con = decl
 922   | otherwise         = decl {ifCons = IfAbstractTyCon} -- Hmm?
 923 filter_decl occs decl
 924   = decl
 925
 926 keep_sig occs (IfaceClassOp occ _ _)         = occ `elem` occs
 927 keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
 928
 929 availOccs avail = map nameOccName (availNames avail)
 930
 931 wantToSee (AnId id)    = not (isImplicitId id)
 932 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
 933 wantToSee _            = True
 934
 935 ---------------------
 936 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
 937                where
 938                  doc = ptext SLIT("context for compiling statements")
 939
 940 ---------------------
 941 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 942                   <+> quotes (ppr mod)
 943 #endif
 944 \end{code}
 945
 946 %************************************************************************
 947 %*                                                                      *
 948         Checking for 'main'
 949 %*                                                                      *
 950 %************************************************************************
 951
 952 \begin{code}
 953 checkMain
 954   = do { ghci_mode <- getGhciMode ;
 955          tcg_env   <- getGblEnv ;
 956
 957          mb_main_mod <- readMutVar v_MainModIs ;
 958          mb_main_fn  <- readMutVar v_MainFunIs ;
 959          let { main_mod = case mb_main_mod of {
 960                                 Just mod -> mkModuleName mod ;
 961                                 Nothing  -> mAIN_Name } ;
 962                main_fn  = case mb_main_fn of {
 963                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 964                                 Nothing -> main_RDR_Unqual } } ;
 965
 966          check_main ghci_mode tcg_env main_mod main_fn
 967     }
 968
 969
 970 check_main ghci_mode tcg_env main_mod main_fn
 971      -- If we are in module Main, check that 'main' is defined.
 972      -- It may be imported from another module!
 973      --
 974      -- ToDo: We have to return the main_name separately, because it's a
 975      -- bona fide 'use', and should be recorded as such, but the others
 976      -- aren't
 977      --
 978      -- Blimey: a whole page of code to do this...
 979  | mod_name /= main_mod
 980  = return tcg_env
 981
 982  | otherwise
 983  = addErrCtxt mainCtxt                  $
 984    do   { mb_main <- lookupSrcOcc_maybe main_fn
 985                 -- Check that 'main' is in scope
 986                 -- It might be imported from another module!
 987         ; case mb_main of {
 988              Nothing -> do { complain_no_main
 989                            ; return tcg_env } ;
 990              Just main_name -> do
 991         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 992                         -- :Main.main :: IO () = runIO main
 993
 994         ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 995                              tcInferRho rhs
 996
 997         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
 998                 main_bind    = noLoc (VarBind root_main_id main_expr) }
 999
1000         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
1001                                         `snocBag` main_bind,
1002                             tcg_dus   = tcg_dus tcg_env
1003                                         `plusDU` usesOnly (unitFV main_name)
1004                  })
1005     }}}
1006   where
1007     mod_name = moduleName (tcg_mod tcg_env)
1008
1009     complain_no_main | ghci_mode == Interactive = return ()
1010                      | otherwise                = failWithTc noMainMsg
1011         -- In interactive mode, don't worry about the absence of 'main'
1012         -- In other modes, fail altogether, so that we don't go on
1013         -- and complain a second time when processing the export list.
1014
1015     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1016     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1017                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1018 \end{code}
1019
1020
1021 %************************************************************************
1022 %*                                                                      *
1023                 Degugging output
1024 %*                                                                      *
1025 %************************************************************************
1026
1027 \begin{code}
1028 rnDump :: SDoc -> TcRn ()
1029 -- Dump, with a banner, if -ddump-rn
1030 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1031
1032 tcDump :: TcGblEnv -> TcRn ()
1033 tcDump env
1034  = do { dflags <- getDOpts ;
1035
1036         -- Dump short output if -ddump-types or -ddump-tc
1037         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1038             (dumpTcRn short_dump) ;
1039
1040         -- Dump bindings if -ddump-tc
1041         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1042    }
1043   where
1044     short_dump = pprTcGblEnv env
1045     full_dump  = pprLHsBinds (tcg_binds env)
1046         -- NB: foreign x-d's have undefined's in their types;
1047         --     hence can't show the tc_fords
1048
1049 tcCoreDump mod_guts
1050  = do { dflags <- getDOpts ;
1051         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1052             (dumpTcRn (pprModGuts mod_guts)) ;
1053
1054         -- Dump bindings if -ddump-tc
1055         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1056   where
1057     full_dump = pprCoreBindings (mg_binds mod_guts)
1058
1059 -- It's unpleasant having both pprModGuts and pprModDetails here
1060 pprTcGblEnv :: TcGblEnv -> SDoc
1061 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1062                         tcg_insts    = dfun_ids,
1063                         tcg_rules    = rules,
1064                         tcg_imports  = imports })
1065   = vcat [ ppr_types dfun_ids type_env
1066          , ppr_insts dfun_ids
1067          , vcat (map ppr rules)
1068          , ppr_gen_tycons (typeEnvTyCons type_env)
1069          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1070          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1071
1072 pprModGuts :: ModGuts -> SDoc
1073 pprModGuts (ModGuts { mg_types = type_env,
1074                       mg_rules = rules })
1075   = vcat [ ppr_types [] type_env,
1076            ppr_rules rules ]
1077
1078
1079 ppr_types :: [Var] -> TypeEnv -> SDoc
1080 ppr_types dfun_ids type_env
1081   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1082   where
1083     ids = [id | id <- typeEnvIds type_env, want_sig id]
1084     want_sig id | opt_PprStyle_Debug = True
1085                 | otherwise          = isLocalId id &&
1086                                        isExternalName (idName id) &&
1087                                        not (id `elem` dfun_ids)
1088         -- isLocalId ignores data constructors, records selectors etc.
1089         -- The isExternalName ignores local dictionary and method bindings
1090         -- that the type checker has invented.  Top-level user-defined things
1091         -- have External names.
1092
1093 ppr_insts :: [Var] -> SDoc
1094 ppr_insts []       = empty
1095 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1096
1097 ppr_sigs :: [Var] -> SDoc
1098 ppr_sigs ids
1099         -- Print type signatures; sort by OccName
1100   = vcat (map ppr_sig (sortLt lt_sig ids))
1101   where
1102     lt_sig id1 id2 = getOccName id1 < getOccName id2
1103     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1104
1105 ppr_rules :: [IdCoreRule] -> SDoc
1106 ppr_rules [] = empty
1107 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1108                       nest 4 (pprIdRules rs),
1109                       ptext SLIT("#-}")]
1110
1111 ppr_gen_tycons []  = empty
1112 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1113                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1114 \end{code}