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, nameSrcLoc )
  60 import NameSet
  61 import TyCon            ( tyConHasGenerics )
  62 import SrcLoc           ( 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, SrcLoc)])
 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, getSrcLoc thing) } ;
 505                 -- For the SrcLoc, the 'thing' has better info than
 506                 -- the 'name' because getting the former forced the
 507                 -- declaration to be loaded into the cache
 508           cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ;
 509     results <- mapM do_one good_names ;
 510     return (fst (removeDups cmp results))
 511     }
 512
 513 toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
 514 toIfaceDecl ictxt thing
 515   = tyThingToIfaceDecl True             -- Discard IdInfo
 516                        emptyNameSet     -- Show data cons
 517                        ext_nm (munge thing)
 518   where
 519     unqual = icPrintUnqual ictxt
 520     ext_nm n | unqual n  = LocalTop (nameOccName n)     -- What a hack
 521              | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
 522
 523         -- munge transforms a thing to it's "parent" thing
 524     munge (ADataCon dc) = ATyCon (dataConTyCon dc)
 525     munge (AnId id) = case globalIdDetails id of
 526                         RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
 527                         ClassOpId cls   -> AClass cls
 528                         other           -> AnId id
 529     munge other_thing = other_thing
 530 \end{code}
 531
 532
 533 \begin{code}
 534 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
 535 setInteractiveContext icxt thing_inside
 536   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 537     (updGblEnv (\env -> env {tcg_rdr_env  = ic_rn_gbl_env icxt,
 538                              tcg_type_env = ic_type_env   icxt}) $
 539      updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt})   $
 540                thing_inside)
 541 #endif /* GHCI */
 542 \end{code}
 543
 544 %************************************************************************
 545 %*                                                                      *
 546         Type-checking external-core modules
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 \begin{code}
 551 tcRnExtCore :: HscEnv
 552             -> HsExtCore RdrName
 553             -> IO (Messages, Maybe ModGuts)
 554         -- Nothing => some error occurred
 555
 556 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 557         -- The decls are IfaceDecls; all names are original names
 558  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 559
 560    initTc hsc_env this_mod $ do {
 561
 562    let { ldecls  = map noLoc decls } ;
 563
 564         -- Deal with the type declarations; first bring their stuff
 565         -- into scope, then rname them, then type check them
 566    (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
 567
 568    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 569                             tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 570                   $ do {
 571
 572    rn_decls <- rnTyClDecls ldecls ;
 573    failIfErrsM ;
 574
 575         -- Dump trace of renaming part
 576    rnDump (ppr rn_decls) ;
 577
 578         -- Typecheck them all together so that
 579         -- any mutually recursive types are done right
 580    tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
 581         -- Make the new type env available to stuff slurped from interface files
 582
 583    setGblEnv tcg_env $ do {
 584
 585         -- Now the core bindings
 586    core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
 587
 588         -- Wrap up
 589    let {
 590         bndrs      = bindersOfBinds core_binds ;
 591         my_exports = mkNameSet (map idName bndrs) ;
 592                 -- ToDo: export the data types also?
 593
 594         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 595
 596         mod_guts = ModGuts {    mg_module   = this_mod,
 597                                 mg_usages   = [],               -- ToDo: compute usage
 598                                 mg_dir_imps = [],               -- ??
 599                                 mg_deps     = noDependencies,   -- ??
 600                                 mg_exports  = my_exports,
 601                                 mg_types    = final_type_env,
 602                                 mg_insts    = tcg_insts tcg_env,
 603                                 mg_rules    = [],
 604                                 mg_binds    = core_binds,
 605
 606                                 -- Stubs
 607                                 mg_rdr_env  = emptyGlobalRdrEnv,
 608                                 mg_fix_env  = emptyFixityEnv,
 609                                 mg_deprecs  = NoDeprecs,
 610                                 mg_foreign  = NoStubs
 611                     } } ;
 612
 613    tcCoreDump mod_guts ;
 614
 615    return mod_guts
 616    }}}}
 617
 618 mkFakeGroup decls -- Rather clumsy; lots of unused fields
 619   = HsGroup {   hs_tyclds = decls,      -- This is the one we want
 620                 hs_valds = [], hs_fords = [],
 621                 hs_instds = [], hs_fixds = [], hs_depds = [],
 622                 hs_ruleds = [], hs_defds = [] }
 623 \end{code}
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628         Type-checking the top level of a module
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 \begin{code}
 633 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 634         -- Returns the variables free in the decls
 635         -- Reason: solely to report unused imports and bindings
 636 tcRnSrcDecls decls
 637  = do {         -- Do all the declarations
 638         (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
 639
 640              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 641              -- How could there be ambiguous ones?  They can only arise if a
 642              -- top-level decl falls under the monomorphism
 643              -- restriction, and no subsequent decl instantiates its
 644              -- type.  (Usually, ambiguous type variables are resolved
 645              -- during the generalisation step.)
 646         traceTc (text "Tc8") ;
 647         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
 648                 -- Setting the global env exposes the instances to tcSimplifyTop
 649                 -- Setting the local env exposes the local Ids to tcSimplifyTop,
 650                 -- so that we get better error messages (monomorphism restriction)
 651
 652             -- Backsubstitution.  This must be done last.
 653             -- Even tcSimplifyTop may do some unification.
 654         traceTc (text "Tc9") ;
 655         let { (tcg_env, _) = tc_envs ;
 656               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 657                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 658
 659         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
 660                                                            rules fords ;
 661
 662         let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
 663
 664         -- Make the new type env available to stuff slurped from interface files
 665         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 666
 667         return (tcg_env { tcg_type_env = final_type_env,
 668                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
 669    }
 670
 671 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
 672 -- Loops around dealing with each top level inter-splice group
 673 -- in turn, until it's dealt with the entire module
 674 tc_rn_src_decls ds
 675  = do { let { (first_group, group_tail) = findSplice ds } ;
 676                 -- If ds is [] we get ([], Nothing)
 677
 678         -- Type check the decls up to, but not including, the first splice
 679         tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
 680
 681         -- Bale out if errors; for example, error recovery when checking
 682         -- the RHS of 'main' can mean that 'main' is not in the envt for
 683         -- the subsequent checkMain test
 684         failIfErrsM ;
 685
 686         setEnvs tc_envs $
 687
 688         -- If there is no splice, we're nearly done
 689         case group_tail of {
 690            Nothing -> do {      -- Last thing: check for `main'
 691                            tcg_env <- checkMain ;
 692                            return (tcg_env, tcl_env)
 693                       } ;
 694
 695         -- If there's a splice, we must carry on
 696            Just (SpliceDecl splice_expr, rest_ds) -> do {
 697 #ifndef GHCI
 698         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 699 #else
 700
 701         -- Rename the splice expression, and get its supporting decls
 702         (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
 703         failIfErrsM ;   -- Don't typecheck if renaming failed
 704
 705         -- Execute the splice
 706         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 707
 708         -- Glue them on the front of the remaining decls and loop
 709         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 710         tc_rn_src_decls (spliced_decls ++ rest_ds)
 711 #endif /* GHCI */
 712     }}}
 713 \end{code}
 714
 715
 716 %************************************************************************
 717 %*                                                                      *
 718         Type-checking the top level of a module
 719 %*                                                                      *
 720 %************************************************************************
 721
 722 tcRnGroup takes a bunch of top-level source-code declarations, and
 723  * renames them
 724  * gets supporting declarations from interface files
 725  * typechecks them
 726  * zonks them
 727  * and augments the TcGblEnv with the results
 728
 729 In Template Haskell it may be called repeatedly for each group of
 730 declarations.  It expects there to be an incoming TcGblEnv in the
 731 monad; it augments it and returns the new TcGblEnv.
 732
 733 \begin{code}
 734 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 735         -- Returns the variables free in the decls, for unused-binding reporting
 736 tcRnGroup decls
 737  = do {         -- Rename the declarations
 738         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 739         setGblEnv tcg_env $ do {
 740
 741                 -- Typecheck the declarations
 742         tcTopSrcDecls rn_decls
 743   }}
 744
 745 ------------------------------------------------
 746 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 747 rnTopSrcDecls group
 748  = do {         -- Bring top level binders into scope
 749         (rdr_env, imports) <- importsFromLocalDecls group ;
 750         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 751                                  tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 752                   $ do {
 753
 754         traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
 755         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 756
 757                 -- Rename the source decls
 758         (tcg_env, rn_decls) <- rnSrcDecls group ;
 759         failIfErrsM ;
 760
 761                 -- Dump trace of renaming part
 762         rnDump (ppr rn_decls) ;
 763
 764         return (tcg_env, rn_decls)
 765    }}
 766
 767 ------------------------------------------------
 768 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 769 tcTopSrcDecls
 770         (HsGroup { hs_tyclds = tycl_decls,
 771                    hs_instds = inst_decls,
 772                    hs_fords  = foreign_decls,
 773                    hs_defds  = default_decls,
 774                    hs_ruleds = rule_decls,
 775                    hs_valds  = val_binds })
 776  = do {         -- Type-check the type and class decls, and all imported decls
 777                 -- The latter come in via tycl_decls
 778         traceTc (text "Tc2") ;
 779
 780         tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
 781         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 782         -- an error we'd better stop now, to avoid a cascade
 783
 784         -- Make these type and class decls available to stuff slurped from interface files
 785         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 786
 787
 788         setGblEnv tcg_env       $ do {
 789                 -- Source-language instances, including derivings,
 790                 -- and import the supporting declarations
 791         traceTc (text "Tc3") ;
 792         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 793         setGblEnv tcg_env       $ do {
 794
 795                 -- Foreign import declarations next.  No zonking necessary
 796                 -- here; we can tuck them straight into the global environment.
 797         traceTc (text "Tc4") ;
 798         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 799         tcExtendGlobalValEnv fi_ids     $ do {
 800
 801                 -- Default declarations
 802         traceTc (text "Tc4a") ;
 803         default_tys <- tcDefaults default_decls ;
 804         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 805
 806                 -- Value declarations next
 807                 -- We also typecheck any extra binds that came out
 808                 -- of the "deriving" process (deriv_binds)
 809         traceTc (text "Tc5") ;
 810         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
 811         setLclTypeEnv lcl_env   $ do {
 812
 813                 -- Second pass over class and instance declarations,
 814         traceTc (text "Tc6") ;
 815         (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
 816         showLIE (text "after instDecls2") ;
 817
 818                 -- Foreign exports
 819                 -- They need to be zonked, so we return them
 820         traceTc (text "Tc7") ;
 821         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 822
 823                 -- Rules
 824         rules <- tcRules rule_decls ;
 825
 826                 -- Wrap up
 827         traceTc (text "Tc7a") ;
 828         tcg_env <- getGblEnv ;
 829         let { all_binds = tc_val_binds   `unionBags`
 830                           inst_binds     `unionBags`
 831                           foe_binds  ;
 832
 833                 -- Extend the GblEnv with the (as yet un-zonked)
 834                 -- bindings, rules, foreign decls
 835               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 836                                     tcg_rules = tcg_rules tcg_env ++ rules,
 837                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 838         return (tcg_env', lcl_env)
 839     }}}}}}
 840 \end{code}
 841
 842
 843 %*********************************************************
 844 %*                                                       *
 845         mkGlobalContext: make up an interactive context
 846
 847         Used for initialising the lexical environment
 848         of the interactive read-eval-print loop
 849 %*                                                       *
 850 %*********************************************************
 851
 852 \begin{code}
 853 #ifdef GHCI
 854 mkExportEnv :: HscEnv -> [ModuleName]   -- Expose these modules' exports only
 855             -> IO GlobalRdrEnv
 856
 857 mkExportEnv hsc_env exports
 858   = do  { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
 859                      mappM getModuleExports exports
 860         ; case mb_envs of
 861              Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
 862              Nothing   -> return emptyGlobalRdrEnv
 863                              -- Some error; initTc will have printed it
 864     }
 865
 866 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 867 getModuleExports mod
 868   = do  { iface <- load_iface mod
 869         ; loadOrphanModules (dep_orphs (mi_deps iface))
 870                         -- Load any orphan-module interfaces,
 871                         -- so their instances are visible
 872         ; avails <- exportsToAvails (mi_exports iface)
 873         ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 874                         | avail <- avails, name <- availNames avail ] }
 875         ; returnM (mkGlobalRdrEnv gres) }
 876
 877 vanillaProv :: ModuleName -> Provenance
 878 -- We're building a GlobalRdrEnv as if the user imported
 879 -- all the specified modules into the global interactive module
 880 vanillaProv mod = Imported [ImportSpec mod mod False
 881                              (srcLocSpan interactiveSrcLoc)] False
 882 \end{code}
 883
 884 \begin{code}
 885 getModuleContents
 886   :: HscEnv
 887   -> InteractiveContext
 888   -> ModuleName                 -- Module to inspect
 889   -> Bool                       -- Grab just the exports, or the whole toplev
 890   -> IO (Maybe [IfaceDecl])
 891
 892 getModuleContents hsc_env ictxt mod exports_only
 893  = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
 894  where
 895    get_mod_contents exports_only
 896       | not exports_only  -- We want the whole top-level type env
 897                           -- so it had better be a home module
 898       = do { hpt <- getHpt
 899            ; case lookupModuleEnvByName hpt mod of
 900                Just mod_info -> return (map (toIfaceDecl ictxt) $
 901                                         filter wantToSee $
 902                                         typeEnvElts $
 903                                         md_types (hm_details mod_info))
 904                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 905                           -- This is a system error; the module should be in the HPT
 906            }
 907
 908       | otherwise               -- Want the exports only
 909       = do { iface <- load_iface mod
 910            ; avails <- exportsToAvails (mi_exports iface)
 911            ; mappM get_decl avails
 912         }
 913
 914    get_decl avail
 915         = do { thing <- tcLookupGlobal (availName avail)
 916              ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
 917
 918 ---------------------
 919 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
 920   = decl { ifSigs = filter (keep_sig occs) sigs }
 921 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
 922   = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
 923 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
 924   | keep_con occs con = decl
 925   | otherwise         = decl {ifCons = IfAbstractTyCon} -- Hmm?
 926 filter_decl occs decl
 927   = decl
 928
 929 keep_sig occs (IfaceClassOp occ _ _)         = occ `elem` occs
 930 keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
 931
 932 availOccs avail = map nameOccName (availNames avail)
 933
 934 wantToSee (AnId id)    = not (isImplicitId id)
 935 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
 936 wantToSee _            = True
 937
 938 ---------------------
 939 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
 940                where
 941                  doc = ptext SLIT("context for compiling statements")
 942
 943 ---------------------
 944 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 945                   <+> quotes (ppr mod)
 946 #endif
 947 \end{code}
 948
 949 %************************************************************************
 950 %*                                                                      *
 951         Checking for 'main'
 952 %*                                                                      *
 953 %************************************************************************
 954
 955 \begin{code}
 956 checkMain
 957   = do { ghci_mode <- getGhciMode ;
 958          tcg_env   <- getGblEnv ;
 959
 960          mb_main_mod <- readMutVar v_MainModIs ;
 961          mb_main_fn  <- readMutVar v_MainFunIs ;
 962          let { main_mod = case mb_main_mod of {
 963                                 Just mod -> mkModuleName mod ;
 964                                 Nothing  -> mAIN_Name } ;
 965                main_fn  = case mb_main_fn of {
 966                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 967                                 Nothing -> main_RDR_Unqual } } ;
 968
 969          check_main ghci_mode tcg_env main_mod main_fn
 970     }
 971
 972
 973 check_main ghci_mode tcg_env main_mod main_fn
 974      -- If we are in module Main, check that 'main' is defined.
 975      -- It may be imported from another module!
 976      --
 977      -- ToDo: We have to return the main_name separately, because it's a
 978      -- bona fide 'use', and should be recorded as such, but the others
 979      -- aren't
 980      --
 981      -- Blimey: a whole page of code to do this...
 982  | mod_name /= main_mod
 983  = return tcg_env
 984
 985  | otherwise
 986  = addErrCtxt mainCtxt                  $
 987    do   { mb_main <- lookupSrcOcc_maybe main_fn
 988                 -- Check that 'main' is in scope
 989                 -- It might be imported from another module!
 990         ; case mb_main of {
 991              Nothing -> do { complain_no_main
 992                            ; return tcg_env } ;
 993              Just main_name -> do
 994         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 995                         -- :Main.main :: IO () = runIO main
 996
 997         ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 998                              tcInferRho rhs
 999
1000         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
1001                 main_bind    = noLoc (VarBind root_main_id main_expr) }
1002
1003         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
1004                                         `snocBag` main_bind,
1005                             tcg_dus   = tcg_dus tcg_env
1006                                         `plusDU` usesOnly (unitFV main_name)
1007                  })
1008     }}}
1009   where
1010     mod_name = moduleName (tcg_mod tcg_env)
1011
1012     complain_no_main | ghci_mode == Interactive = return ()
1013                      | otherwise                = failWithTc noMainMsg
1014         -- In interactive mode, don't worry about the absence of 'main'
1015         -- In other modes, fail altogether, so that we don't go on
1016         -- and complain a second time when processing the export list.
1017
1018     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1019     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1020                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1021 \end{code}
1022
1023
1024 %************************************************************************
1025 %*                                                                      *
1026                 Degugging output
1027 %*                                                                      *
1028 %************************************************************************
1029
1030 \begin{code}
1031 rnDump :: SDoc -> TcRn ()
1032 -- Dump, with a banner, if -ddump-rn
1033 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1034
1035 tcDump :: TcGblEnv -> TcRn ()
1036 tcDump env
1037  = do { dflags <- getDOpts ;
1038
1039         -- Dump short output if -ddump-types or -ddump-tc
1040         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1041             (dumpTcRn short_dump) ;
1042
1043         -- Dump bindings if -ddump-tc
1044         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1045    }
1046   where
1047     short_dump = pprTcGblEnv env
1048     full_dump  = pprLHsBinds (tcg_binds env)
1049         -- NB: foreign x-d's have undefined's in their types;
1050         --     hence can't show the tc_fords
1051
1052 tcCoreDump mod_guts
1053  = do { dflags <- getDOpts ;
1054         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1055             (dumpTcRn (pprModGuts mod_guts)) ;
1056
1057         -- Dump bindings if -ddump-tc
1058         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1059   where
1060     full_dump = pprCoreBindings (mg_binds mod_guts)
1061
1062 -- It's unpleasant having both pprModGuts and pprModDetails here
1063 pprTcGblEnv :: TcGblEnv -> SDoc
1064 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1065                         tcg_insts    = dfun_ids,
1066                         tcg_rules    = rules,
1067                         tcg_imports  = imports })
1068   = vcat [ ppr_types dfun_ids type_env
1069          , ppr_insts dfun_ids
1070          , vcat (map ppr rules)
1071          , ppr_gen_tycons (typeEnvTyCons type_env)
1072          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1073          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1074
1075 pprModGuts :: ModGuts -> SDoc
1076 pprModGuts (ModGuts { mg_types = type_env,
1077                       mg_rules = rules })
1078   = vcat [ ppr_types [] type_env,
1079            ppr_rules rules ]
1080
1081
1082 ppr_types :: [Var] -> TypeEnv -> SDoc
1083 ppr_types dfun_ids type_env
1084   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1085   where
1086     ids = [id | id <- typeEnvIds type_env, want_sig id]
1087     want_sig id | opt_PprStyle_Debug = True
1088                 | otherwise          = isLocalId id &&
1089                                        isExternalName (idName id) &&
1090                                        not (id `elem` dfun_ids)
1091         -- isLocalId ignores data constructors, records selectors etc.
1092         -- The isExternalName ignores local dictionary and method bindings
1093         -- that the type checker has invented.  Top-level user-defined things
1094         -- have External names.
1095
1096 ppr_insts :: [Var] -> SDoc
1097 ppr_insts []       = empty
1098 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1099
1100 ppr_sigs :: [Var] -> SDoc
1101 ppr_sigs ids
1102         -- Print type signatures; sort by OccName
1103   = vcat (map ppr_sig (sortLt lt_sig ids))
1104   where
1105     lt_sig id1 id2 = getOccName id1 < getOccName id2
1106     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1107
1108 ppr_rules :: [IdCoreRule] -> SDoc
1109 ppr_rules [] = empty
1110 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1111                       nest 4 (pprIdRules rs),
1112                       ptext SLIT("#-}")]
1113
1114 ppr_gen_tycons []  = empty
1115 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1116                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1117 \end{code}