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         mkGlobalContext, getModuleContents,
  10 #endif
  11         tcRnModule, checkOldIface, importSupportingDecls,
  12         tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
  18 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  19                           Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
  20                           mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
  21                           isSrcRule, collectStmtsBinders
  22                         )
  23 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
  24
  25 import PrelNames        ( iNTERACTIVE, ioTyConName, printName,
  26                           returnIOName, bindIOName, failIOName, thenIOName, runIOName,
  27                           dollarMainName, itName, mAIN_Name
  28                         )
  29 import MkId             ( unsafeCoerceId )
  30 import RdrName          ( RdrName, getRdrName, mkUnqual, mkRdrUnqual,
  31                           lookupRdrEnv, elemRdrEnv )
  32
  33 import RnHsSyn          ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl,
  34                           ruleDeclFVs, instDeclFVs, tyClDeclFVs )
  35 import TcHsSyn          ( TypecheckedHsExpr, TypecheckedRuleDecl,
  36                           zonkTopBinds, zonkTopDecls, mkHsLet,
  37                           zonkTopExpr, zonkTopBndrs
  38                         )
  39
  40 import TcExpr           ( tcExpr_id )
  41 import TcRnMonad
  42 import TcMType          ( newTyVarTy, zonkTcType )
  43 import TcType           ( Type, liftedTypeKind,
  44                           tyVarsOfType, tcFunResultTy,
  45                           mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
  46                         )
  47 import TcMatches        ( tcStmtsAndThen )
  48 import Inst             ( showLIE )
  49 import TcBinds          ( tcTopBinds )
  50 import TcClassDcl       ( tcClassDecls2 )
  51 import TcDefaults       ( tcDefaults )
  52 import TcEnv            ( RecTcGblEnv,
  53                           tcExtendGlobalValEnv,
  54                           tcExtendGlobalEnv,
  55                           tcExtendInstEnv, tcExtendRules,
  56                           tcLookupTyCon, tcLookupGlobal,
  57                           tcLookupId
  58                         )
  59 import TcRules          ( tcRules )
  60 import TcForeign        ( tcForeignImports, tcForeignExports )
  61 import TcIfaceSig       ( tcInterfaceSigs, tcCoreBinds )
  62 import TcInstDcls       ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
  63 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
  64 import TcTyClsDecls     ( tcTyAndClassDecls )
  65
  66 import RnNames          ( rnImports, exportsFromAvail, reportUnusedNames )
  67 import RnIfaces         ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
  68 import RnHiFiles        ( readIface, loadOldIface )
  69 import RnEnv            ( lookupSrcName, lookupOccRn,
  70                           ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
  71 import RnExpr           ( rnStmts, rnExpr )
  72 import RnSource         ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats )
  73
  74 import OccName          ( varName )
  75 import CoreUnfold       ( unfoldingTemplate )
  76 import CoreSyn          ( IdCoreRule, Bind(..) )
  77 import PprCore          ( pprIdRules, pprCoreBindings )
  78 import TysWiredIn       ( mkListTy, unitTy )
  79 import ErrUtils         ( mkDumpDoc, showPass )
  80 import Id               ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
  81 import IdInfo           ( GlobalIdDetails(..) )
  82 import Var              ( Var, setGlobalIdDetails )
  83 import Module           ( Module, moduleName, moduleUserString )
  84 import Name             ( Name, isExternalName, getSrcLoc, nameOccName )
  85 import NameEnv          ( delListFromNameEnv )
  86 import NameSet
  87 import TyCon            ( tyConGenInfo )
  88 import BasicTypes       ( EP(..), RecFlag(..) )
  89 import SrcLoc           ( noSrcLoc )
  90 import Outputable
  91 import HscTypes         ( PersistentCompilerState(..), InteractiveContext(..),
  92                           ModIface, ModDetails(..), ModGuts(..),
  93                           HscEnv(..),
  94                           ModIface(..), ModDetails(..), IfaceDecls(..),
  95                           GhciMode(..),
  96                           Deprecations(..), plusDeprecs,
  97                           emptyGlobalRdrEnv,
  98                           GenAvailInfo(Avail), availsToNameSet,
  99                           ForeignStubs(..),
 100                           TypeEnv, TyThing, typeEnvTyCons,
 101                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
 102                           extendLocalRdrEnv, emptyFixityEnv
 103                         )
 104 #ifdef GHCI
 105 import RdrName          ( rdrEnvElts )
 106 import RnHiFiles        ( loadInterface )
 107 import RnEnv            ( mkGlobalRdrEnv, plusGlobalRdrEnv )
 108 import HscTypes         ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
 109                           isLocalGRE )
 110 #endif
 111
 112 import Maybe            ( catMaybes )
 113 import Panic            ( showException )
 114 import List             ( partition )
 115 import Util             ( sortLt )
 116 \end{code}
 117
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122         Typecheck and rename a module
 123 %*                                                                      *
 124 %************************************************************************
 125
 126
 127 \begin{code}
 128 tcRnModule :: HscEnv -> PersistentCompilerState
 129            -> RdrNameHsModule
 130            -> IO (PersistentCompilerState, Maybe TcGblEnv)
 131
 132 tcRnModule hsc_env pcs
 133            (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
 134  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 135
 136    initTc hsc_env pcs this_mod $ addSrcLoc loc $
 137    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
 138         (rdr_env, imports) <- rnImports import_decls ;
 139         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
 140                                    tcg_imports = imports })
 141                      $ do {
 142         traceRn (text "rn1") ;
 143                 -- Fail if there are any errors so far
 144                 -- The error printing (if needed) takes advantage
 145                 -- of the tcg_env we have now set
 146         failIfErrsM ;
 147
 148         traceRn (text "rn1a") ;
 149                 -- Rename and type check the declarations
 150         (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
 151         setGblEnv tcg_env               $ do {
 152         traceRn (text "rn2") ;
 153
 154                 -- Check for 'main'
 155         (tcg_env, main_fvs) <- checkMain ;
 156         setGblEnv tcg_env               $ do {
 157
 158         traceRn (text "rn3") ;
 159                 -- Check whether the entire module is deprecated
 160                 -- This happens only once per module
 161                 -- Returns the full new deprecations; a module deprecation
 162                 --      over-rides the earlier ones
 163         let { mod_deprecs = checkModDeprec mod_deprec } ;
 164         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
 165                   $ do {
 166
 167         traceRn (text "rn4") ;
 168                 -- Process the export list
 169         export_avails <- exportsFromAvail exports ;
 170         updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
 171                   $  do {
 172
 173                 -- Get the supporting decls for the exports
 174                 -- This is important *only* to gether usage information
 175                 --      (see comments with MkIface.mkImportInfo for why)
 176                 -- For OneShot compilation we could just throw away the decls
 177                 -- but for Batch or Interactive we must put them in the type
 178                 -- envt because they've been removed from the holding pen
 179         let { export_fvs = availsToNameSet export_avails } ;
 180         tcg_env <- importSupportingDecls export_fvs ;
 181         setGblEnv tcg_env $ do {
 182
 183                 -- Report unused names
 184         let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
 185         reportUnusedNames tcg_env used_fvs ;
 186
 187                 -- Dump output and return
 188         tcDump tcg_env ;
 189         return tcg_env
 190     }}}}}}}}
 191 \end{code}
 192
 193
 194 %*********************************************************
 195 %*                                                       *
 196 \subsection{Closing up the interface decls}
 197 %*                                                       *
 198 %*********************************************************
 199
 200 Suppose we discover we don't need to recompile.   Then we start from the
 201 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
 202
 203 \begin{code}
 204 tcRnIface :: HscEnv
 205           -> PersistentCompilerState
 206           -> ModIface   -- Get the decls from here
 207           -> IO (PersistentCompilerState, Maybe ModDetails)
 208                                 -- Nothing <=> errors happened
 209 tcRnIface hsc_env pcs
 210             (ModIface {mi_module = mod, mi_decls = iface_decls})
 211   = initTc hsc_env pcs mod $ do {
 212
 213         -- Get the supporting decls, and typecheck them all together
 214         -- so that any mutually recursive types are done right
 215     extra_decls <- slurpImpDecls needed ;
 216     env <- typecheckIfaceDecls (decls ++ extra_decls) ;
 217
 218     returnM (ModDetails { md_types = tcg_type_env env,
 219                           md_insts = tcg_insts env,
 220                           md_rules = hsCoreRules (tcg_rules env)
 221                   -- All the rules from an interface are of the IfaceRuleOut form
 222                  }) }
 223   where
 224         rule_decls = dcl_rules iface_decls
 225         inst_decls = dcl_insts iface_decls
 226         tycl_decls = dcl_tycl  iface_decls
 227         decls = map RuleD rule_decls ++
 228                 map InstD inst_decls ++
 229                 map TyClD tycl_decls
 230         needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
 231                  unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
 232                  unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
 233                  ubiquitousNames
 234                         -- Data type decls with record selectors,
 235                         -- which may appear in the decls, need unpackCString
 236                         -- and friends. It's easier to just grab them right now.
 237
 238 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
 239 -- All post-typechecking Iface rules have the form IfaceRuleOut
 240 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
 241 \end{code}
 242
 243
 244 %************************************************************************
 245 %*                                                                      *
 246                 The interactive interface
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 \begin{code}
 251 tcRnStmt :: HscEnv -> PersistentCompilerState
 252          -> InteractiveContext
 253          -> RdrNameStmt
 254          -> IO (PersistentCompilerState,
 255                 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
 256                 -- The returned [Id] is the same as the input except for
 257                 -- ExprStmt, in which case the returned [Name] is [itName]
 258
 259 tcRnStmt hsc_env pcs ictxt rdr_stmt
 260   = initTc hsc_env pcs iNTERACTIVE $
 261     setInteractiveContext ictxt $ do {
 262
 263     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 264     ([rn_stmt], fvs) <- initRnInteractive ictxt
 265                                         (rnStmts DoExpr [rdr_stmt]) ;
 266     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 267     failIfErrsM ;
 268
 269     -- Suck in the supporting declarations and typecheck them
 270     tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
 271         -- NB: an earlier version deleted (rdrEnvElts local_env) from
 272         --     the fvs.  But (a) that isn't necessary, because previously
 273         --     bound things in the local_env will be in the TypeEnv, and
 274         --     the renamer doesn't re-slurp such things, and
 275         -- (b) it's WRONG to delete them. Consider in GHCi:
 276         --        Mod> let x = e :: T
 277         --        Mod> let y = x + 3
 278         --     We need to pass 'x' among the fvs to slurpImpDecls, so that
 279         --     the latter can see that T is a gate, and hence import the Num T
 280         --     instance decl.  (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
 281     setGblEnv tcg_env $ do {
 282
 283     -- The real work is done here
 284     ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
 285
 286     traceTc (text "tcs 1") ;
 287     let {       -- Make all the bound ids "global" ids, now that
 288                 -- they're notionally top-level bindings.  This is
 289                 -- important: otherwise when we come to compile an expression
 290                 -- using these ids later, the byte code generator will consider
 291                 -- the occurrences to be free rather than global.
 292         global_ids     = map globaliseId bound_ids ;
 293         globaliseId id = setGlobalIdDetails id VanillaGlobal ;
 294
 295                 -- Update the interactive context
 296         rn_env   = ic_rn_local_env ictxt ;
 297         type_env = ic_type_env ictxt ;
 298
 299         bound_names = map idName global_ids ;
 300         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 301
 302                 -- Remove any shadowed bindings from the type_env;
 303                 -- they are inaccessible but might, I suppose, cause
 304                 -- a space leak if we leave them there
 305         shadowed = [ n | name <- bound_names,
 306                          let rdr_name = mkRdrUnqual (nameOccName name),
 307                          Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
 308
 309         filtered_type_env = delListFromNameEnv type_env shadowed ;
 310         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 311
 312         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 313                          ic_type_env     = new_type_env }
 314     } ;
 315
 316     dumpOptTcRn Opt_D_dump_tc
 317         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 318                text "Typechecked expr" <+> ppr tc_expr]) ;
 319
 320     returnM (new_ic, bound_names, tc_expr)
 321     }}
 322 \end{code}
 323
 324
 325 Here is the grand plan, implemented in tcUserStmt
 326
 327         What you type                   The IO [HValue] that hscStmt returns
 328         -------------                   ------------------------------------
 329         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 330                                         bindings: [x,y,...]
 331
 332         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 333                                         bindings: [x,y,...]
 334
 335         expr (of IO type)       ==>     expr >>= \ v -> return [coerce HVal v]
 336           [NB: result not printed]      bindings: [it]
 337
 338         expr (of non-IO type,   ==>     let v = expr in print v >> return [coerce HVal v]
 339           result showable)              bindings: [it]
 340
 341         expr (of non-IO type,
 342           result not showable)  ==>     error
 343
 344
 345 \begin{code}
 346 ---------------------------
 347 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
 348 tcUserStmt (ExprStmt expr _ loc)
 349   = newUnique           `thenM` \ uniq ->
 350     let
 351         fresh_it = itName uniq
 352         the_bind = FunMonoBind fresh_it False
 353                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
 354     in
 355     tryTc_ (do {        -- Try this if the other fails
 356                 traceTc (text "tcs 1b") ;
 357                 tc_stmts [
 358                     LetStmt (MonoBind the_bind [] NonRecursive),
 359                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
 360                              placeHolderType loc] })
 361           (do {         -- Try this first
 362                 traceTc (text "tcs 1a") ;
 363                 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
 364
 365 tcUserStmt stmt = tc_stmts [stmt]
 366
 367 ---------------------------
 368 tc_stmts stmts
 369  = do { io_ids <- mappM tcLookupId
 370                         [returnIOName, failIOName, bindIOName, thenIOName] ;
 371         ioTyCon <- tcLookupTyCon ioTyConName ;
 372         res_ty  <- newTyVarTy liftedTypeKind ;
 373         let {
 374             names      = collectStmtsBinders stmts ;
 375             return_id  = head io_ids ;  -- Rather gruesome
 376
 377             io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
 378
 379                 -- mk_return builds the expression
 380                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 381             mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
 382                                   (ExplicitList unitTy (map mk_item ids)) ;
 383
 384             mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
 385                                (HsVar id) } ;
 386
 387         -- OK, we're ready to typecheck the stmts
 388         traceTc (text "tcs 2") ;
 389         ((ids, tc_stmts), lie) <-
 390                 getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
 391                 do {
 392                     -- Look up the names right in the middle,
 393                     -- where they will all be in scope
 394                     ids <- mappM tcLookupId names ;
 395                     return (ids, [ResultStmt (mk_return ids) noSrcLoc])
 396                 } ;
 397
 398         -- Simplify the context right here, so that we fail
 399         -- if there aren't enough instances.  Notably, when we see
 400         --              e
 401         -- we use tryTc_ to try         it <- e
 402         -- and then                     let it = e
 403         -- It's the simplify step that rejects the first.
 404         traceTc (text "tcs 3") ;
 405         const_binds <- tcSimplifyTop lie ;
 406
 407         -- Build result expression and zonk it
 408         let { expr = mkHsLet const_binds $
 409                      HsDo DoExpr tc_stmts io_ids
 410                           (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
 411         zonked_expr <- zonkTopExpr expr ;
 412         zonked_ids  <- zonkTopBndrs ids ;
 413
 414         return (zonked_ids, zonked_expr)
 415         }
 416   where
 417     combine stmt (ids, stmts) = (ids, stmt:stmts)
 418 \end{code}
 419
 420
 421 tcRnExpr just finds the type of an expression
 422
 423 \begin{code}
 424 tcRnExpr :: HscEnv -> PersistentCompilerState
 425          -> InteractiveContext
 426          -> RdrNameHsExpr
 427          -> IO (PersistentCompilerState, Maybe Type)
 428 tcRnExpr hsc_env pcs ictxt rdr_expr
 429   = initTc hsc_env pcs iNTERACTIVE $
 430     setInteractiveContext ictxt $ do {
 431
 432     (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
 433     failIfErrsM ;
 434
 435         -- Suck in the supporting declarations and typecheck them
 436     tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
 437     setGblEnv tcg_env $ do {
 438
 439         -- Now typecheck the expression;
 440         -- it might have a rank-2 type (e.g. :t runST)
 441         -- Hence the hole type (c.f. TcExpr.tcExpr_id)
 442     ((tc_expr, res_ty), lie)       <- getLIE (tcExpr_id rn_expr) ;
 443     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 444     tcSimplifyTop lie_top ;
 445
 446     let { all_expr_ty = mkForAllTys qtvs                $
 447                         mkFunTys (map idType dict_ids)  $
 448                         res_ty } ;
 449     zonkTcType all_expr_ty
 450     }}
 451   where
 452     smpl_doc = ptext SLIT("main expression")
 453 \end{code}
 454
 455
 456 \begin{code}
 457 tcRnThing :: HscEnv -> PersistentCompilerState
 458           -> InteractiveContext
 459           -> RdrName
 460           -> IO (PersistentCompilerState, Maybe [TyThing])
 461 -- Look up a RdrName and return all the TyThings it might be
 462 -- We treat a capitalised RdrName as both a data constructor
 463 -- and as a type or class constructor; hence we return up to two results
 464 tcRnThing hsc_env pcs ictxt rdr_name
 465   = initTc hsc_env pcs iNTERACTIVE $
 466     setInteractiveContext ictxt $ do {
 467
 468         -- If the identifier is a constructor (begins with an
 469         -- upper-case letter), then we need to consider both
 470         -- constructor and type class identifiers.
 471     let { rdr_names = dataTcOccs rdr_name } ;
 472
 473     (msgs_s, mb_names) <- initRnInteractive ictxt
 474                             (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
 475     let { names = catMaybes mb_names } ;
 476
 477     if null names then
 478         do { addMessages (head msgs_s) ; failM }
 479     else do {
 480
 481     mapM_ addMessages msgs_s ;  -- Add deprecation warnings
 482     mapM tcLookupGlobal names   -- and lookup up the entities
 483     }}
 484 \end{code}
 485
 486
 487 \begin{code}
 488 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
 489 setInteractiveContext icxt thing_inside
 490   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 491     updGblEnv (\ env -> env { tcg_rdr_env  = ic_rn_gbl_env icxt,
 492                               tcg_type_env = ic_type_env   icxt })
 493               thing_inside
 494
 495 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
 496 -- Set the local RdrEnv from the interactive context
 497 initRnInteractive ictxt rn_thing
 498   = initRn CmdLineMode $
 499     setLocalRdrEnv (ic_rn_local_env ictxt) $
 500     rn_thing
 501 \end{code}
 502
 503 %************************************************************************
 504 %*                                                                      *
 505         Type-checking external-core modules
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 \begin{code}
 510 tcRnExtCore :: HscEnv -> PersistentCompilerState
 511             -> RdrNameHsModule
 512             -> IO (PersistentCompilerState, Maybe ModGuts)
 513         -- Nothing => some error occurred
 514
 515 tcRnExtCore hsc_env pcs
 516             (HsModule this_mod _ _ _ local_decls _ loc)
 517         -- Rename the (Core) module.  It's a bit like an interface
 518         -- file: all names are original names
 519  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 520
 521    initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
 522
 523         -- Rename the source, only in interface mode.
 524         -- rnSrcDecls handles fixity decls etc too, which won't occur
 525         -- but that doesn't matter
 526    (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
 527                                    (rnExtCoreDecls local_decls) ;
 528    failIfErrsM ;
 529
 530         -- Get the supporting decls, and typecheck them all together
 531         -- so that any mutually recursive types are done right
 532    extra_decls <- slurpImpDecls fvs ;
 533    tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
 534    setGblEnv tcg_env $ do {
 535
 536         -- Now the core bindings
 537    core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
 538    tcExtendGlobalValEnv (map fst core_prs) $ do {
 539
 540         -- Wrap up
 541    let {
 542         bndrs      = map fst core_prs ;
 543         my_exports = map (Avail . idName) bndrs ;
 544                 -- ToDo: export the data types also?
 545
 546         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 547
 548         mod_guts = ModGuts {    mg_module   = this_mod,
 549                                 mg_usages   = [],       -- ToDo: compute usage
 550                                 mg_dir_imps = [],       -- ??
 551                                 mg_exports  = my_exports,
 552                                 mg_types    = final_type_env,
 553                                 mg_insts    = tcg_insts tcg_env,
 554                                 mg_rules    = hsCoreRules (tcg_rules tcg_env),
 555                                 mg_binds    = [Rec core_prs],
 556
 557                                 -- Stubs
 558                                 mg_rdr_env  = emptyGlobalRdrEnv,
 559                                 mg_fix_env  = emptyFixityEnv,
 560                                 mg_deprecs  = NoDeprecs,
 561                                 mg_foreign  = NoStubs
 562                     } } ;
 563
 564    tcCoreDump mod_guts ;
 565
 566    return mod_guts
 567    }}}}
 568 \end{code}
 569
 570
 571 %************************************************************************
 572 %*                                                                      *
 573         Type-checking the top level of a module
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
 578         -- Returns the variables free in the decls
 579 tcRnSrcDecls [] = getGblEnv
 580 tcRnSrcDecls ds
 581  = do { let { (first_group, group_tail) = findSplice ds } ;
 582
 583         tcg_env <- tcRnGroup first_group ;
 584
 585         case group_tail of
 586            Nothing -> return gbl_env
 587            Just (splice_expr, rest_ds) -> do {
 588
 589         setGblEnv tcg_env $ do {
 590
 591         -- Rename the splice expression, and get its supporting decls
 592         (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
 593         tcg_env <- importSupportingDecls fvs ;
 594         setGblEnv tcg_env $ do {
 595
 596         -- Execute the splice
 597         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 598
 599         -- Glue them on the front of the remaining decls and loop
 600         tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
 601     }}}}
 602
 603 findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
 604 findSplice []               = ([], Nothing)
 605 findSplice (SpliceD e : ds) = ([], Just (e, ds))
 606 findSplice (d : ds)         = (d:gs, rest)
 607                             where
 608                               (gs, rest) = findSplice ds
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613         Type-checking the top level of a module
 614 %*                                                                      *
 615 %************************************************************************
 616
 617 tcRnSrcDecls takes a bunch of top-level source-code declarations, and
 618  * renames them
 619  * gets supporting declarations from interface files
 620  * typechecks them
 621  * zonks them
 622  * and augments the TcGblEnv with the results
 623
 624 In Template Haskell it may be called repeatedly for each group of
 625 declarations.  It expects there to be an incoming TcGblEnv in the
 626 monad; it augments it and returns the new TcGblEnv.
 627
 628 \begin{code}
 629 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
 630         -- Returns the variables free in the decls
 631 tcRnSrcDecls decls
 632  = do {         -- Rename the declarations
 633         (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
 634         setGblEnv tcg_env $ do {
 635
 636                 -- Typecheck the declarations
 637         tcg_env <- tcTopSrcDecls rn_decls ;
 638         return (tcg_env, src_fvs)
 639   }}
 640
 641 ------------------------------------------------
 642 rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
 643 rnTopSrcDecls decls
 644  = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
 645         setGblEnv tcg_env $ do {
 646
 647         failIfErrsM ;
 648
 649                 -- Import consquential imports
 650         rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
 651         let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
 652
 653                 -- Dump trace of renaming part
 654         rnDump (vcat (map ppr rn_decls)) ;
 655         rnStats rn_imp_decls ;
 656
 657         return (tcg_env, rn_decls, src_fvs)
 658   }}
 659
 660 ------------------------------------------------
 661 tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv
 662 tcTopSrcDecls rn_decls
 663  = fixM (\ unf_env -> do {
 664         -- Loop back the final environment, including the fully zonked
 665         -- versions of bindings from this module.  In the presence of mutual
 666         -- recursion, interface type signatures may mention variables defined
 667         -- in this module, which is why the knot is so big
 668
 669                         -- Do the main work
 670         ((tcg_env, binds, rules, fords), lie) <- getLIE (
 671                 tc_src_decls unf_env rn_decls
 672             ) ;
 673
 674              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 675              -- How could there be ambiguous ones?  They can only arise if a
 676              -- top-level decl falls under the monomorphism
 677              -- restriction, and no subsequent decl instantiates its
 678              -- type.  (Usually, ambiguous type variables are resolved
 679              -- during the generalisation step.)
 680         traceTc (text "Tc8") ;
 681         inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
 682                 -- The setGblEnv exposes the instances to tcSimplifyTop
 683
 684             -- Backsubstitution.  This must be done last.
 685             -- Even tcSimplifyTop may do some unification.
 686         traceTc (text "Tc9") ;
 687         (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
 688                                                       rules fords ;
 689
 690         let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
 691                                    tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
 692                                    tcg_rules = tcg_rules tcg_env ++ rules',
 693                                    tcg_fords = tcg_fords tcg_env ++ fords' } } ;
 694
 695         return tcg_env'
 696     })
 697
 698 tc_src_decls unf_env decls
 699  = do {         -- Type-check the type and class decls, and all imported decls
 700         traceTc (text "Tc2") ;
 701         tcg_env <- tcTyClDecls unf_env tycl_decls ;
 702         setGblEnv tcg_env       $ do {
 703
 704                 -- Source-language instances, including derivings,
 705                 -- and import the supporting declarations
 706         traceTc (text "Tc3") ;
 707         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
 708         setGblEnv tcg_env       $ do {
 709         tcg_env <- importSupportingDecls fvs ;
 710         setGblEnv tcg_env       $ do {
 711
 712                 -- Foreign import declarations next.  No zonking necessary
 713                 -- here; we can tuck them straight into the global environment.
 714         traceTc (text "Tc4") ;
 715         (fi_ids, fi_decls) <- tcForeignImports decls ;
 716         tcExtendGlobalValEnv fi_ids                  $
 717         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
 718                   $ do {
 719
 720                 -- Default declarations
 721         traceTc (text "Tc4a") ;
 722         default_tys <- tcDefaults decls ;
 723         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 724
 725                 -- Value declarations next
 726                 -- We also typecheck any extra binds that came out
 727                 -- of the "deriving" process
 728         traceTc (text "Tc5") ;
 729         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
 730         setLclTypeEnv lcl_env   $ do {
 731
 732                 -- Second pass over class and instance declarations,
 733                 -- plus rules and foreign exports, to generate bindings
 734         traceTc (text "Tc6") ;
 735         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
 736         tcExtendGlobalValEnv dm_ids     $ do {
 737         inst_binds <- tcInstDecls2 inst_infos ;
 738         showLIE "after instDecls2" ;
 739
 740                 -- Foreign exports
 741                 -- They need to be zonked, so we return them
 742         traceTc (text "Tc7") ;
 743         (foe_binds, foe_decls) <- tcForeignExports decls ;
 744
 745                 -- Rules
 746                 -- Need to partition them because the source rules
 747                 -- must be zonked before adding them to tcg_rules
 748                 -- NB: built-in rules come in as IfaceRuleOut's, and
 749                 --     get added to tcg_rules right here by tcExtendRules
 750         rules <- tcRules rule_decls ;
 751         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
 752         tcExtendRules iface_rules $ do {
 753
 754                 -- Wrap up
 755         tcg_env <- getGblEnv ;
 756         let { all_binds = tc_val_binds   `AndMonoBinds`
 757                           inst_binds     `AndMonoBinds`
 758                           cls_dm_binds   `AndMonoBinds`
 759                           foe_binds } ;
 760
 761         return (tcg_env, all_binds, src_rules, foe_decls)
 762      }}}}}}}}}
 763   where
 764     tycl_decls = [d | TyClD d <- decls]
 765     rule_decls = [d | RuleD d <- decls]
 766     inst_decls = [d | InstD d <- decls]
 767     val_decls  = [d | ValD d  <- decls]
 768     val_binds  = foldr ThenBinds EmptyBinds val_decls
 769 \end{code}
 770
 771 \begin{code}
 772 tcTyClDecls :: RecTcGblEnv
 773             -> [RenamedTyClDecl]
 774             -> TcM TcGblEnv
 775
 776 -- tcTyClDecls deals with
 777 --      type and class decls (some source, some imported)
 778 --      interface signatures (checked lazily)
 779 --
 780 -- It returns the TcGblEnv for this module, and side-effects the
 781 -- persistent compiler state to reflect the things imported from
 782 -- other modules
 783
 784 tcTyClDecls unf_env tycl_decls
 785   -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
 786   -- which is done lazily [ie failure just drops the pragma
 787   -- without having any global-failure effect].
 788
 789   = checkNoErrs $
 790         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 791         -- an error we'd better stop now, to avoid a cascade
 792
 793     traceTc (text "TyCl1")              `thenM_`
 794     tcTyAndClassDecls tycl_decls        `thenM` \ tycl_things ->
 795     tcExtendGlobalEnv tycl_things       $
 796
 797         -- Interface type signatures
 798         -- We tie a knot so that the Ids read out of interfaces are in scope
 799         --   when we read their pragmas.
 800         -- What we rely on is that pragmas are typechecked lazily; if
 801         --   any type errors are found (ie there's an inconsistency)
 802         --   we silently discard the pragma
 803     traceTc (text "TyCl2")                      `thenM_`
 804     tcInterfaceSigs unf_env tycl_decls          `thenM` \ sig_ids ->
 805     tcExtendGlobalValEnv sig_ids                $
 806
 807     getGblEnv           -- Return the TcLocals environment
 808 \end{code}
 809
 810
 811
 812 %************************************************************************
 813 %*                                                                      *
 814         Load the old interface file for this module (unless
 815         we have it aleady), and check whether it is up to date
 816
 817 %*                                                                      *
 818 %************************************************************************
 819
 820 \begin{code}
 821 checkOldIface :: HscEnv
 822               -> PersistentCompilerState
 823               -> Module
 824               -> FilePath               -- Where the interface file is
 825               -> Bool                   -- Source unchanged
 826               -> Maybe ModIface         -- Old interface from compilation manager, if any
 827               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
 828                                 -- Nothing <=> errors happened
 829
 830 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
 831   = do { showPass (hsc_dflags hsc_env)
 832                   ("Checking old interface for " ++ moduleUserString mod) ;
 833
 834          initTc hsc_env pcs mod
 835                 (check_old_iface iface_path source_unchanged maybe_iface)
 836      }
 837
 838 check_old_iface iface_path source_unchanged maybe_iface
 839  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
 840     ifM (not source_unchanged)
 841         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 842                                                 `thenM_`
 843
 844      -- If the source has changed and we're in interactive mode, avoid reading
 845      -- an interface; just return the one we might have been supplied with.
 846     getGhciMode                                 `thenM` \ ghci_mode ->
 847     if (ghci_mode == Interactive) && not source_unchanged then
 848          returnM (outOfDate, maybe_iface)
 849     else
 850
 851     case maybe_iface of
 852        Just old_iface -> -- Use the one we already have
 853                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
 854                          returnM (recomp, Just old_iface)
 855
 856        Nothing          -- Try and read it from a file
 857           -> getModule                                  `thenM` \ this_mod ->
 858              readIface this_mod iface_path False        `thenM` \ read_result ->
 859              case read_result of
 860                Left err -> -- Old interface file not found, or garbled; give up
 861                            traceHiDiffs (
 862                                 text "Cannot read old interface file:"
 863                                    $$ nest 4 (text (showException err))) `thenM_`
 864                            returnM (outOfDate, Nothing)
 865
 866                Right parsed_iface ->
 867                          initRn (InterfaceMode this_mod)
 868                                 (loadOldIface parsed_iface)     `thenM` \ m_iface ->
 869                          checkVersions source_unchanged m_iface `thenM` \ recomp ->
 870                          returnM (recomp, Just m_iface)
 871 \end{code}
 872
 873
 874 %************************************************************************
 875 %*                                                                      *
 876         Type-check and rename supporting declarations
 877         This is used to deal with the free vars of a splice,
 878         or derived code: slurp in the necessary declarations,
 879         typecheck them, and add them to the EPS
 880 %*                                                                      *
 881 %************************************************************************
 882
 883 \begin{code}
 884 importSupportingDecls :: FreeVars -> TcM TcGblEnv
 885 -- Completely deal with the supporting imports needed
 886 -- by the specified free-var set
 887 importSupportingDecls fvs
 888  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
 889         decls <- slurpImpDecls fvs ;
 890         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
 891         typecheckIfaceDecls decls }
 892
 893 typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
 894   -- The decls are all interface-file declarations
 895   -- Usually they are all from other modules, but when we are reading
 896   -- this module's interface from a file, it's possible that some of
 897   -- them are for the module being compiled.
 898   -- That is why the tcExtendX functions need to do partitioning.
 899   --
 900   -- If all the decls are from other modules, the returned TcGblEnv
 901   -- will have an empty tc_genv, but its tc_inst_env and tc_ist
 902   -- caches may have been augmented.
 903 typecheckIfaceDecls decls
 904  = do { let { tycl_decls = [d | TyClD d <- decls] ;
 905               inst_decls = [d | InstD d <- decls] ;
 906               rule_decls = [d | RuleD d <- decls] } ;
 907
 908                 -- Typecheck the type, class, and interface-sig decls
 909         tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
 910         setGblEnv tcg_env               $ do {
 911
 912         -- Typecheck the instance decls, and rules
 913         -- Note that imported dictionary functions are already
 914         -- in scope from the preceding tcTyClDecls
 915         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
 916         tcExtendInstEnv dfuns           $
 917         tcRules rule_decls              `thenM` \ rules ->
 918         tcExtendRules rules             $
 919
 920         getGblEnv               -- Return the environment
 921    }}
 922 \end{code}
 923
 924
 925
 926 %*********************************************************
 927 %*                                                       *
 928         mkGlobalContext: make up an interactive context
 929
 930         Used for initialising the lexical environment
 931         of the interactive read-eval-print loop
 932 %*                                                       *
 933 %*********************************************************
 934
 935 \begin{code}
 936 #ifdef GHCI
 937 mkGlobalContext
 938         :: HscEnv -> PersistentCompilerState
 939         -> [Module]     -- Expose these modules' top-level scope
 940         -> [Module]     -- Expose these modules' exports only
 941         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
 942
 943 mkGlobalContext hsc_env pcs toplevs exports
 944   = initTc hsc_env pcs iNTERACTIVE $ do {
 945
 946     toplev_envs <- mappM getTopLevScope   toplevs ;
 947     export_envs <- mappM getModuleExports exports ;
 948     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
 949                    (toplev_envs ++ export_envs))
 950     }
 951
 952 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
 953 getTopLevScope mod
 954   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 955          case mi_globals iface of
 956                 Nothing  -> panic "getTopLevScope"
 957                 Just env -> returnM env }
 958
 959 getModuleExports :: Module -> TcRn m GlobalRdrEnv
 960 getModuleExports mod
 961   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 962          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
 963   where
 964     prov_fn n = NonLocalDef ImplicitImport
 965     add env (mod,avails)
 966         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
 967
 968 contextDoc = text "context for compiling statements"
 969 \end{code}
 970
 971 \begin{code}
 972 getModuleContents
 973   :: HscEnv
 974   -> PersistentCompilerState    -- IN: persistent compiler state
 975   -> Module                     -- module to inspect
 976   -> Bool                       -- grab just the exports, or the whole toplev
 977   -> IO (PersistentCompilerState, Maybe [TyThing])
 978
 979 getModuleContents hsc_env pcs mod exports_only
 980  = initTc hsc_env pcs iNTERACTIVE $ do {
 981
 982         -- Load the interface if necessary (a home module will certainly
 983         -- alraedy be loaded, but a package module might not be)
 984         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 985
 986         let { export_names = availsToNameSet export_avails ;
 987               export_avails = [ avail | (mn, avails) <- mi_exports iface,
 988                                         avail <- avails ] } ;
 989
 990         all_names <- if exports_only then
 991                         return export_names
 992                      else case mi_globals iface of {
 993                            Just rdr_env ->
 994                                 return (get_locals rdr_env) ;
 995
 996                            Nothing -> do { addErr (noRdrEnvErr mod) ;
 997                                            return export_names } } ;
 998                                 -- Invariant; we only have (not exports_only)
 999                                 -- for a home module so it must already be in the HIT
1000                                 -- So the Nothing case is a bug
1001
1002         env <- importSupportingDecls all_names ;
1003         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1004     }
1005   where
1006         -- Grab all the things from the global env that are locally def'd
1007     get_locals rdr_env = mkNameSet [ gre_name gre
1008                                    | elts <- rdrEnvElts rdr_env,
1009                                      gre <- elts,
1010                                      isLocalGRE gre ]
1011         -- Make a set because a name is often in the envt in
1012         -- both qualified and unqualified forms
1013
1014 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1015                   <+> quotes (ppr mod)
1016 #endif
1017 \end{code}
1018
1019 %************************************************************************
1020 %*                                                                      *
1021         Checking for 'main'
1022 %*                                                                      *
1023 %************************************************************************
1024
1025 \begin{code}
1026 checkMain
1027   = do { ghci_mode <- getGhciMode ;
1028          tcg_env   <- getGblEnv ;
1029          check_main ghci_mode tcg_env
1030     }
1031
1032 check_main ghci_mode tcg_env
1033      -- If we are in module Main, check that 'main' is defined.
1034      -- It may be imported from another module, in which case
1035      -- we have to drag in its.
1036      --
1037      -- Also form the definition
1038      --         $main = runIO main
1039      -- so we need to slurp in runIO too.
1040      --
1041      -- ToDo: We have to return the main_name separately, because it's a
1042      -- bona fide 'use', and should be recorded as such, but the others
1043      -- aren't
1044      --
1045      -- Blimey: a whole page of code to do this...
1046
1047  | mod_name /= mAIN_Name
1048  = return (tcg_env, emptyFVs)
1049
1050  | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1051  = do { complain_no_main; return (tcg_env, emptyFVs) }
1052
1053  | otherwise
1054  = do {         -- Check that 'main' is in scope
1055                 -- It might be imported from another module!
1056         main_name <- lookupSrcName main_RDR_Unqual ;
1057         failIfErrsM ;
1058
1059         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1060         setGblEnv tcg_env $ do {
1061
1062         -- $main :: IO () = runIO main
1063         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1064
1065         (main_bind, top_lie) <- getLIE (
1066                 addSrcLoc (getSrcLoc main_name) $
1067                 addErrCtxt mainCtxt             $ do {
1068                 (main_expr, ty) <- tcExpr_id rhs ;
1069                 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1070                 return (VarMonoBind dollar_main_id main_expr)
1071             }) ;
1072
1073         inst_binds <- tcSimplifyTop top_lie ;
1074
1075         (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1076
1077         let { tcg_env' = tcg_env {
1078                 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1079                 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1080
1081         return (tcg_env', unitFV main_name)
1082     }}
1083   where
1084     mod_name = moduleName (tcg_mod tcg_env)
1085     rdr_env  = tcg_rdr_env tcg_env
1086
1087     main_RDR_Unqual :: RdrName
1088     main_RDR_Unqual = mkUnqual varName FSLIT("main")
1089         -- Don't get a RdrName from PrelNames.mainName, because
1090         -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
1091         -- An Unqual one will do just fine
1092
1093     complain_no_main | ghci_mode == Interactive = return ()
1094                      | otherwise                = addErr noMainMsg
1095         -- In interactive mode, don't worry about the absence of 'main'
1096
1097     mainCtxt  = ptext SLIT("When checking the type of 'main'")
1098     noMainMsg = ptext SLIT("No 'main' defined in module Main")
1099 \end{code}
1100
1101
1102 %************************************************************************
1103 %*                                                                      *
1104                 Degugging output
1105 %*                                                                      *
1106 %************************************************************************
1107
1108 \begin{code}
1109 rnDump :: SDoc -> TcRn m ()
1110 -- Dump, with a banner, if -ddump-rn
1111 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1112
1113 tcDump :: TcGblEnv -> TcRn m ()
1114 tcDump env
1115  = do { dflags <- getDOpts ;
1116
1117         -- Dump short output if -ddump-types or -ddump-tc
1118         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1119             (dumpTcRn short_dump) ;
1120
1121         -- Dump bindings if -ddump-tc
1122         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1123    }
1124   where
1125     short_dump = pprTcGblEnv env
1126     full_dump  = ppr (tcg_binds env)
1127         -- NB: foreign x-d's have undefined's in their types;
1128         --     hence can't show the tc_fords
1129
1130 tcCoreDump mod_guts
1131  = do { dflags <- getDOpts ;
1132         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1133             (dumpTcRn (pprModGuts mod_guts)) ;
1134
1135         -- Dump bindings if -ddump-tc
1136         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1137   where
1138     full_dump = pprCoreBindings (mg_binds mod_guts)
1139
1140 -- It's unpleasant having both pprModGuts and pprModDetails here
1141 pprTcGblEnv :: TcGblEnv -> SDoc
1142 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1143                         tcg_insts    = dfun_ids,
1144                         tcg_rules    = rules })
1145   = vcat [ ppr_types dfun_ids type_env
1146          , ppr_insts dfun_ids
1147          , vcat (map ppr rules)
1148          , ppr_gen_tycons (typeEnvTyCons type_env)]
1149
1150 pprModGuts :: ModGuts -> SDoc
1151 pprModGuts (ModGuts { mg_types = type_env,
1152                       mg_rules = rules })
1153   = vcat [ ppr_types [] type_env,
1154            ppr_rules rules ]
1155
1156
1157 ppr_types :: [Var] -> TypeEnv -> SDoc
1158 ppr_types dfun_ids type_env
1159   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1160   where
1161     ids = [id | id <- typeEnvIds type_env, want_sig id]
1162     want_sig id | opt_PprStyle_Debug = True
1163                 | otherwise          = isLocalId id &&
1164                                        isExternalName (idName id) &&
1165                                        not (id `elem` dfun_ids)
1166         -- isLocalId ignores data constructors, records selectors etc.
1167         -- The isExternalName ignores local dictionary and method bindings
1168         -- that the type checker has invented.  Top-level user-defined things
1169         -- have External names.
1170
1171 ppr_insts :: [Var] -> SDoc
1172 ppr_insts []       = empty
1173 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1174
1175 ppr_sigs :: [Var] -> SDoc
1176 ppr_sigs ids
1177         -- Print type signatures
1178         -- Convert to HsType so that we get source-language style printing
1179         -- And sort by RdrName
1180   = vcat $ map ppr_sig $ sortLt lt_sig $
1181     [ (getRdrName id, toHsType (idType id))
1182     | id <- ids ]
1183   where
1184     lt_sig (n1,_) (n2,_) = n1 < n2
1185     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1186
1187
1188 ppr_rules :: [IdCoreRule] -> SDoc
1189 ppr_rules [] = empty
1190 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1191                       nest 4 (pprIdRules rs),
1192                       ptext SLIT("#-}")]
1193
1194 ppr_gen_tycons []  = empty
1195 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1196                            vcat (map ppr_gen_tycon tcs),
1197                            ptext SLIT("#-}")
1198                      ]
1199
1200 -- x&y are now Id's, not CoreExpr's
1201 ppr_gen_tycon tycon
1202   | Just ep <- tyConGenInfo tycon
1203   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1204
1205   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1206
1207 ppr_ep (EP from to)
1208   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1209            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1210            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1211     ]
1212   where
1213     (_,from_tau) = tcSplitForAllTys (idType from)
1214 \end{code}