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), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
  20                           mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
  21                           isSrcRule
  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     ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt
 265                                                 (rnStmts [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 bound_names 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 :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
 348 tcUserStmt names (ExprStmt expr _ loc)
 349   = ASSERT( null names )
 350     newUnique           `thenM` \ uniq ->
 351     let
 352         fresh_it = itName uniq
 353         the_bind = FunMonoBind fresh_it False
 354                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
 355     in
 356     tryTc_ (do {        -- Try this if the other fails
 357                 traceTc (text "tcs 1b") ;
 358                 tc_stmts [fresh_it] [
 359                     LetStmt (MonoBind the_bind [] NonRecursive),
 360                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
 361                              placeHolderType loc] })
 362           (do {         -- Try this first
 363                 traceTc (text "tcs 1a") ;
 364                 tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] })
 365
 366 tcUserStmt names stmt
 367   = tc_stmts names [stmt]
 368
 369 ---------------------------
 370 tc_stmts names stmts
 371  = do { io_ids <- mappM tcLookupId
 372                         [returnIOName, failIOName, bindIOName, thenIOName] ;
 373         ioTyCon <- tcLookupTyCon ioTyConName ;
 374         res_ty  <- newTyVarTy liftedTypeKind ;
 375         let {
 376             return_id  = head io_ids ;  -- Rather gruesome
 377
 378             io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
 379
 380                 -- mk_return builds the expression
 381                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 382             mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
 383                                   (ExplicitList unitTy (map mk_item ids)) ;
 384
 385             mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
 386                                (HsVar id) } ;
 387
 388         -- OK, we're ready to typecheck the stmts
 389         traceTc (text "tcs 2") ;
 390         ((ids, tc_stmts), lie) <-
 391                 getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $
 392                 do {
 393                     -- Look up the names right in the middle,
 394                     -- where they will all be in scope
 395                     ids <- mappM tcLookupId names ;
 396                     return (ids, [ResultStmt (mk_return ids) noSrcLoc])
 397                 } ;
 398
 399         -- Simplify the context right here, so that we fail
 400         -- if there aren't enough instances.  Notably, when we see
 401         --              e
 402         -- we use tryTc_ to try         it <- e
 403         -- and then                     let it = e
 404         -- It's the simplify step that rejects the first.
 405         traceTc (text "tcs 3") ;
 406         const_binds <- tcSimplifyTop lie ;
 407
 408         -- Build result expression and zonk it
 409         let { expr = mkHsLet const_binds $
 410                      HsDo DoExpr tc_stmts io_ids
 411                           (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
 412         zonked_expr <- zonkTopExpr expr ;
 413         zonked_ids  <- zonkTopBndrs ids ;
 414
 415         return (zonked_ids, zonked_expr)
 416         }
 417   where
 418     combine stmt (ids, stmts) = (ids, stmt:stmts)
 419 \end{code}
 420
 421
 422 tcRnExpr just finds the type of an expression
 423
 424 \begin{code}
 425 tcRnExpr :: HscEnv -> PersistentCompilerState
 426          -> InteractiveContext
 427          -> RdrNameHsExpr
 428          -> IO (PersistentCompilerState, Maybe Type)
 429 tcRnExpr hsc_env pcs ictxt rdr_expr
 430   = initTc hsc_env pcs iNTERACTIVE $
 431     setInteractiveContext ictxt $ do {
 432
 433     (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
 434     failIfErrsM ;
 435
 436         -- Suck in the supporting declarations and typecheck them
 437     tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
 438     setGblEnv tcg_env $ do {
 439
 440         -- Now typecheck the expression;
 441         -- it might have a rank-2 type (e.g. :t runST)
 442         -- Hence the hole type (c.f. TcExpr.tcExpr_id)
 443     ((tc_expr, res_ty), lie)       <- getLIE (tcExpr_id rn_expr) ;
 444     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 445     tcSimplifyTop lie_top ;
 446
 447     let { all_expr_ty = mkForAllTys qtvs                $
 448                         mkFunTys (map idType dict_ids)  $
 449                         res_ty } ;
 450     zonkTcType all_expr_ty
 451     }}
 452   where
 453     smpl_doc = ptext SLIT("main expression")
 454 \end{code}
 455
 456
 457 \begin{code}
 458 tcRnThing :: HscEnv -> PersistentCompilerState
 459           -> InteractiveContext
 460           -> RdrName
 461           -> IO (PersistentCompilerState, Maybe [TyThing])
 462 -- Look up a RdrName and return all the TyThings it might be
 463 -- We treat a capitalised RdrName as both a data constructor
 464 -- and as a type or class constructor; hence we return up to two results
 465 tcRnThing hsc_env pcs ictxt rdr_name
 466   = initTc hsc_env pcs iNTERACTIVE $
 467     setInteractiveContext ictxt $ do {
 468
 469         -- If the identifier is a constructor (begins with an
 470         -- upper-case letter), then we need to consider both
 471         -- constructor and type class identifiers.
 472     let { rdr_names = dataTcOccs rdr_name } ;
 473
 474     (msgs_s, mb_names) <- initRnInteractive ictxt
 475                             (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
 476     let { names = catMaybes mb_names } ;
 477
 478     if null names then
 479         do { addMessages (head msgs_s) ; failM }
 480     else do {
 481
 482     mapM_ addMessages msgs_s ;  -- Add deprecation warnings
 483     mapM tcLookupGlobal names   -- and lookup up the entities
 484     }}
 485 \end{code}
 486
 487
 488 \begin{code}
 489 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
 490 setInteractiveContext icxt thing_inside
 491   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 492     updGblEnv (\ env -> env { tcg_rdr_env  = ic_rn_gbl_env icxt,
 493                               tcg_type_env = ic_type_env   icxt })
 494               thing_inside
 495
 496 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
 497 -- Set the local RdrEnv from the interactive context
 498 initRnInteractive ictxt rn_thing
 499   = initRn CmdLineMode $
 500     setLocalRdrEnv (ic_rn_local_env ictxt) $
 501     rn_thing
 502 \end{code}
 503
 504 %************************************************************************
 505 %*                                                                      *
 506         Type-checking external-core modules
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 tcRnExtCore :: HscEnv -> PersistentCompilerState
 512             -> RdrNameHsModule
 513             -> IO (PersistentCompilerState, Maybe ModGuts)
 514         -- Nothing => some error occurred
 515
 516 tcRnExtCore hsc_env pcs
 517             (HsModule this_mod _ _ _ local_decls _ loc)
 518         -- Rename the (Core) module.  It's a bit like an interface
 519         -- file: all names are original names
 520  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 521
 522    initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
 523
 524         -- Rename the source, only in interface mode.
 525         -- rnSrcDecls handles fixity decls etc too, which won't occur
 526         -- but that doesn't matter
 527    (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
 528                                    (rnExtCoreDecls local_decls) ;
 529    failIfErrsM ;
 530
 531         -- Get the supporting decls, and typecheck them all together
 532         -- so that any mutually recursive types are done right
 533    extra_decls <- slurpImpDecls fvs ;
 534    tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
 535    setGblEnv tcg_env $ do {
 536
 537         -- Now the core bindings
 538    core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
 539    tcExtendGlobalValEnv (map fst core_prs) $ do {
 540
 541         -- Wrap up
 542    let {
 543         bndrs      = map fst core_prs ;
 544         my_exports = map (Avail . idName) bndrs ;
 545                 -- ToDo: export the data types also?
 546
 547         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 548
 549         mod_guts = ModGuts {    mg_module   = this_mod,
 550                                 mg_usages   = [],       -- ToDo: compute usage
 551                                 mg_dir_imps = [],       -- ??
 552                                 mg_exports  = my_exports,
 553                                 mg_types    = final_type_env,
 554                                 mg_insts    = tcg_insts tcg_env,
 555                                 mg_rules    = hsCoreRules (tcg_rules tcg_env),
 556                                 mg_binds    = [Rec core_prs],
 557
 558                                 -- Stubs
 559                                 mg_rdr_env  = emptyGlobalRdrEnv,
 560                                 mg_fix_env  = emptyFixityEnv,
 561                                 mg_deprecs  = NoDeprecs,
 562                                 mg_foreign  = NoStubs
 563                     } } ;
 564
 565    tcCoreDump mod_guts ;
 566
 567    return mod_guts
 568    }}}}
 569 \end{code}
 570
 571
 572 %************************************************************************
 573 %*                                                                      *
 574         Type-checking the top level of a module
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
 579         -- Returns the variables free in the decls
 580 tcRnSrcDecls [] = getGblEnv
 581 tcRnSrcDecls ds
 582  = do { let { (first_group, group_tail) = findSplice ds } ;
 583
 584         tcg_env <- tcRnGroup first_group ;
 585
 586         case group_tail of
 587            Nothing -> return gbl_env
 588            Just (splice_expr, rest_ds) -> do {
 589
 590         setGblEnv tcg_env $ do {
 591
 592         -- Rename the splice expression, and get its supporting decls
 593         (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
 594         tcg_env <- importSupportingDecls fvs ;
 595         setGblEnv tcg_env $ do {
 596
 597         -- Execute the splice
 598         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 599
 600         -- Glue them on the front of the remaining decls and loop
 601         tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
 602     }}}}
 603
 604 findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
 605 findSplice []               = ([], Nothing)
 606 findSplice (SpliceD e : ds) = ([], Just (e, ds))
 607 findSplice (d : ds)         = (d:gs, rest)
 608                             where
 609                               (gs, rest) = findSplice ds
 610
 611
 612 %************************************************************************
 613 %*                                                                      *
 614         Type-checking the top level of a module
 615 %*                                                                      *
 616 %************************************************************************
 617
 618 tcRnSrcDecls takes a bunch of top-level source-code declarations, and
 619  * renames them
 620  * gets supporting declarations from interface files
 621  * typechecks them
 622  * zonks them
 623  * and augments the TcGblEnv with the results
 624
 625 In Template Haskell it may be called repeatedly for each group of
 626 declarations.  It expects there to be an incoming TcGblEnv in the
 627 monad; it augments it and returns the new TcGblEnv.
 628
 629 \begin{code}
 630 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
 631         -- Returns the variables free in the decls
 632 tcRnSrcDecls decls
 633  = do {         -- Rename the declarations
 634         (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
 635         setGblEnv tcg_env $ do {
 636
 637                 -- Typecheck the declarations
 638         tcg_env <- tcTopSrcDecls rn_decls ;
 639         return (tcg_env, src_fvs)
 640   }}
 641
 642 ------------------------------------------------
 643 rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
 644 rnTopSrcDecls decls
 645  = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
 646         setGblEnv tcg_env $ do {
 647
 648         failIfErrsM ;
 649
 650                 -- Import consquential imports
 651         rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
 652         let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
 653
 654                 -- Dump trace of renaming part
 655         rnDump (vcat (map ppr rn_decls)) ;
 656         rnStats rn_imp_decls ;
 657
 658         return (tcg_env, rn_decls, src_fvs)
 659   }}
 660
 661 ------------------------------------------------
 662 tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv
 663 tcTopSrcDecls rn_decls
 664  = fixM (\ unf_env -> do {
 665         -- Loop back the final environment, including the fully zonked
 666         -- versions of bindings from this module.  In the presence of mutual
 667         -- recursion, interface type signatures may mention variables defined
 668         -- in this module, which is why the knot is so big
 669
 670                         -- Do the main work
 671         ((tcg_env, binds, rules, fords), lie) <- getLIE (
 672                 tc_src_decls unf_env rn_decls
 673             ) ;
 674
 675              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 676              -- How could there be ambiguous ones?  They can only arise if a
 677              -- top-level decl falls under the monomorphism
 678              -- restriction, and no subsequent decl instantiates its
 679              -- type.  (Usually, ambiguous type variables are resolved
 680              -- during the generalisation step.)
 681         traceTc (text "Tc8") ;
 682         inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
 683                 -- The setGblEnv exposes the instances to tcSimplifyTop
 684
 685             -- Backsubstitution.  This must be done last.
 686             -- Even tcSimplifyTop may do some unification.
 687         traceTc (text "Tc9") ;
 688         (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
 689                                                       rules fords ;
 690
 691         let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
 692                                    tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
 693                                    tcg_rules = tcg_rules tcg_env ++ rules',
 694                                    tcg_fords = tcg_fords tcg_env ++ fords' } } ;
 695
 696         return tcg_env'
 697     })
 698
 699 tc_src_decls unf_env decls
 700  = do {         -- Type-check the type and class decls, and all imported decls
 701         traceTc (text "Tc2") ;
 702         tcg_env <- tcTyClDecls unf_env tycl_decls ;
 703         setGblEnv tcg_env       $ do {
 704
 705                 -- Source-language instances, including derivings,
 706                 -- and import the supporting declarations
 707         traceTc (text "Tc3") ;
 708         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
 709         setGblEnv tcg_env       $ do {
 710         tcg_env <- importSupportingDecls fvs ;
 711         setGblEnv tcg_env       $ do {
 712
 713                 -- Foreign import declarations next.  No zonking necessary
 714                 -- here; we can tuck them straight into the global environment.
 715         traceTc (text "Tc4") ;
 716         (fi_ids, fi_decls) <- tcForeignImports decls ;
 717         tcExtendGlobalValEnv fi_ids                  $
 718         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
 719                   $ do {
 720
 721                 -- Default declarations
 722         traceTc (text "Tc4a") ;
 723         default_tys <- tcDefaults decls ;
 724         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 725
 726                 -- Value declarations next
 727                 -- We also typecheck any extra binds that came out
 728                 -- of the "deriving" process
 729         traceTc (text "Tc5") ;
 730         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
 731         setLclTypeEnv lcl_env   $ do {
 732
 733                 -- Second pass over class and instance declarations,
 734                 -- plus rules and foreign exports, to generate bindings
 735         traceTc (text "Tc6") ;
 736         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
 737         tcExtendGlobalValEnv dm_ids     $ do {
 738         inst_binds <- tcInstDecls2 inst_infos ;
 739         showLIE "after instDecls2" ;
 740
 741                 -- Foreign exports
 742                 -- They need to be zonked, so we return them
 743         traceTc (text "Tc7") ;
 744         (foe_binds, foe_decls) <- tcForeignExports decls ;
 745
 746                 -- Rules
 747                 -- Need to partition them because the source rules
 748                 -- must be zonked before adding them to tcg_rules
 749                 -- NB: built-in rules come in as IfaceRuleOut's, and
 750                 --     get added to tcg_rules right here by tcExtendRules
 751         rules <- tcRules rule_decls ;
 752         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
 753         tcExtendRules iface_rules $ do {
 754
 755                 -- Wrap up
 756         tcg_env <- getGblEnv ;
 757         let { all_binds = tc_val_binds   `AndMonoBinds`
 758                           inst_binds     `AndMonoBinds`
 759                           cls_dm_binds   `AndMonoBinds`
 760                           foe_binds } ;
 761
 762         return (tcg_env, all_binds, src_rules, foe_decls)
 763      }}}}}}}}}
 764   where
 765     tycl_decls = [d | TyClD d <- decls]
 766     rule_decls = [d | RuleD d <- decls]
 767     inst_decls = [d | InstD d <- decls]
 768     val_decls  = [d | ValD d  <- decls]
 769     val_binds  = foldr ThenBinds EmptyBinds val_decls
 770 \end{code}
 771
 772 \begin{code}
 773 tcTyClDecls :: RecTcGblEnv
 774             -> [RenamedTyClDecl]
 775             -> TcM TcGblEnv
 776
 777 -- tcTyClDecls deals with
 778 --      type and class decls (some source, some imported)
 779 --      interface signatures (checked lazily)
 780 --
 781 -- It returns the TcGblEnv for this module, and side-effects the
 782 -- persistent compiler state to reflect the things imported from
 783 -- other modules
 784
 785 tcTyClDecls unf_env tycl_decls
 786   -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
 787   -- which is done lazily [ie failure just drops the pragma
 788   -- without having any global-failure effect].
 789
 790   = checkNoErrs $
 791         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 792         -- an error we'd better stop now, to avoid a cascade
 793
 794     traceTc (text "TyCl1")              `thenM_`
 795     tcTyAndClassDecls tycl_decls        `thenM` \ tycl_things ->
 796     tcExtendGlobalEnv tycl_things       $
 797
 798         -- Interface type signatures
 799         -- We tie a knot so that the Ids read out of interfaces are in scope
 800         --   when we read their pragmas.
 801         -- What we rely on is that pragmas are typechecked lazily; if
 802         --   any type errors are found (ie there's an inconsistency)
 803         --   we silently discard the pragma
 804     traceTc (text "TyCl2")                      `thenM_`
 805     tcInterfaceSigs unf_env tycl_decls          `thenM` \ sig_ids ->
 806     tcExtendGlobalValEnv sig_ids                $
 807
 808     getGblEnv           -- Return the TcLocals environment
 809 \end{code}
 810
 811
 812
 813 %************************************************************************
 814 %*                                                                      *
 815         Load the old interface file for this module (unless
 816         we have it aleady), and check whether it is up to date
 817
 818 %*                                                                      *
 819 %************************************************************************
 820
 821 \begin{code}
 822 checkOldIface :: HscEnv
 823               -> PersistentCompilerState
 824               -> Module
 825               -> FilePath               -- Where the interface file is
 826               -> Bool                   -- Source unchanged
 827               -> Maybe ModIface         -- Old interface from compilation manager, if any
 828               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
 829                                 -- Nothing <=> errors happened
 830
 831 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
 832   = do { showPass (hsc_dflags hsc_env)
 833                   ("Checking old interface for " ++ moduleUserString mod) ;
 834
 835          initTc hsc_env pcs mod
 836                 (check_old_iface iface_path source_unchanged maybe_iface)
 837      }
 838
 839 check_old_iface iface_path source_unchanged maybe_iface
 840  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
 841     ifM (not source_unchanged)
 842         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 843                                                 `thenM_`
 844
 845      -- If the source has changed and we're in interactive mode, avoid reading
 846      -- an interface; just return the one we might have been supplied with.
 847     getGhciMode                                 `thenM` \ ghci_mode ->
 848     if (ghci_mode == Interactive) && not source_unchanged then
 849          returnM (outOfDate, maybe_iface)
 850     else
 851
 852     case maybe_iface of
 853        Just old_iface -> -- Use the one we already have
 854                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
 855                          returnM (recomp, Just old_iface)
 856
 857        Nothing          -- Try and read it from a file
 858           -> getModule                                  `thenM` \ this_mod ->
 859              readIface this_mod iface_path False        `thenM` \ read_result ->
 860              case read_result of
 861                Left err -> -- Old interface file not found, or garbled; give up
 862                            traceHiDiffs (
 863                                 text "Cannot read old interface file:"
 864                                    $$ nest 4 (text (showException err))) `thenM_`
 865                            returnM (outOfDate, Nothing)
 866
 867                Right parsed_iface ->
 868                          initRn (InterfaceMode this_mod)
 869                                 (loadOldIface parsed_iface)     `thenM` \ m_iface ->
 870                          checkVersions source_unchanged m_iface `thenM` \ recomp ->
 871                          returnM (recomp, Just m_iface)
 872 \end{code}
 873
 874
 875 %************************************************************************
 876 %*                                                                      *
 877         Type-check and rename supporting declarations
 878         This is used to deal with the free vars of a splice,
 879         or derived code: slurp in the necessary declarations,
 880         typecheck them, and add them to the EPS
 881 %*                                                                      *
 882 %************************************************************************
 883
 884 \begin{code}
 885 importSupportingDecls :: FreeVars -> TcM TcGblEnv
 886 -- Completely deal with the supporting imports needed
 887 -- by the specified free-var set
 888 importSupportingDecls fvs
 889  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
 890         decls <- slurpImpDecls fvs ;
 891         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
 892         typecheckIfaceDecls decls }
 893
 894 typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
 895   -- The decls are all interface-file declarations
 896   -- Usually they are all from other modules, but when we are reading
 897   -- this module's interface from a file, it's possible that some of
 898   -- them are for the module being compiled.
 899   -- That is why the tcExtendX functions need to do partitioning.
 900   --
 901   -- If all the decls are from other modules, the returned TcGblEnv
 902   -- will have an empty tc_genv, but its tc_inst_env and tc_ist
 903   -- caches may have been augmented.
 904 typecheckIfaceDecls decls
 905  = do { let { tycl_decls = [d | TyClD d <- decls] ;
 906               inst_decls = [d | InstD d <- decls] ;
 907               rule_decls = [d | RuleD d <- decls] } ;
 908
 909                 -- Typecheck the type, class, and interface-sig decls
 910         tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
 911         setGblEnv tcg_env               $ do {
 912
 913         -- Typecheck the instance decls, and rules
 914         -- Note that imported dictionary functions are already
 915         -- in scope from the preceding tcTyClDecls
 916         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
 917         tcExtendInstEnv dfuns           $
 918         tcRules rule_decls              `thenM` \ rules ->
 919         tcExtendRules rules             $
 920
 921         getGblEnv               -- Return the environment
 922    }}
 923 \end{code}
 924
 925
 926
 927 %*********************************************************
 928 %*                                                       *
 929         mkGlobalContext: make up an interactive context
 930
 931         Used for initialising the lexical environment
 932         of the interactive read-eval-print loop
 933 %*                                                       *
 934 %*********************************************************
 935
 936 \begin{code}
 937 #ifdef GHCI
 938 mkGlobalContext
 939         :: HscEnv -> PersistentCompilerState
 940         -> [Module]     -- Expose these modules' top-level scope
 941         -> [Module]     -- Expose these modules' exports only
 942         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
 943
 944 mkGlobalContext hsc_env pcs toplevs exports
 945   = initTc hsc_env pcs iNTERACTIVE $ do {
 946
 947     toplev_envs <- mappM getTopLevScope   toplevs ;
 948     export_envs <- mappM getModuleExports exports ;
 949     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
 950                    (toplev_envs ++ export_envs))
 951     }
 952
 953 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
 954 getTopLevScope mod
 955   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 956          case mi_globals iface of
 957                 Nothing  -> panic "getTopLevScope"
 958                 Just env -> returnM env }
 959
 960 getModuleExports :: Module -> TcRn m GlobalRdrEnv
 961 getModuleExports mod
 962   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 963          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
 964   where
 965     prov_fn n = NonLocalDef ImplicitImport
 966     add env (mod,avails)
 967         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
 968
 969 contextDoc = text "context for compiling statements"
 970 \end{code}
 971
 972 \begin{code}
 973 getModuleContents
 974   :: HscEnv
 975   -> PersistentCompilerState    -- IN: persistent compiler state
 976   -> Module                     -- module to inspect
 977   -> Bool                       -- grab just the exports, or the whole toplev
 978   -> IO (PersistentCompilerState, Maybe [TyThing])
 979
 980 getModuleContents hsc_env pcs mod exports_only
 981  = initTc hsc_env pcs iNTERACTIVE $ do {
 982
 983         -- Load the interface if necessary (a home module will certainly
 984         -- alraedy be loaded, but a package module might not be)
 985         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 986
 987         let { export_names = availsToNameSet export_avails ;
 988               export_avails = [ avail | (mn, avails) <- mi_exports iface,
 989                                         avail <- avails ] } ;
 990
 991         all_names <- if exports_only then
 992                         return export_names
 993                      else case mi_globals iface of {
 994                            Just rdr_env ->
 995                                 return (get_locals rdr_env) ;
 996
 997                            Nothing -> do { addErr (noRdrEnvErr mod) ;
 998                                            return export_names } } ;
 999                                 -- Invariant; we only have (not exports_only)
1000                                 -- for a home module so it must already be in the HIT
1001                                 -- So the Nothing case is a bug
1002
1003         env <- importSupportingDecls all_names ;
1004         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1005     }
1006   where
1007         -- Grab all the things from the global env that are locally def'd
1008     get_locals rdr_env = mkNameSet [ gre_name gre
1009                                    | elts <- rdrEnvElts rdr_env,
1010                                      gre <- elts,
1011                                      isLocalGRE gre ]
1012         -- Make a set because a name is often in the envt in
1013         -- both qualified and unqualified forms
1014
1015 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1016                   <+> quotes (ppr mod)
1017 #endif
1018 \end{code}
1019
1020 %************************************************************************
1021 %*                                                                      *
1022         Checking for 'main'
1023 %*                                                                      *
1024 %************************************************************************
1025
1026 \begin{code}
1027 checkMain
1028   = do { ghci_mode <- getGhciMode ;
1029          tcg_env   <- getGblEnv ;
1030          check_main ghci_mode tcg_env
1031     }
1032
1033 check_main ghci_mode tcg_env
1034      -- If we are in module Main, check that 'main' is defined.
1035      -- It may be imported from another module, in which case
1036      -- we have to drag in its.
1037      --
1038      -- Also form the definition
1039      --         $main = runIO main
1040      -- so we need to slurp in runIO too.
1041      --
1042      -- ToDo: We have to return the main_name separately, because it's a
1043      -- bona fide 'use', and should be recorded as such, but the others
1044      -- aren't
1045      --
1046      -- Blimey: a whole page of code to do this...
1047
1048  | mod_name /= mAIN_Name
1049  = return (tcg_env, emptyFVs)
1050
1051  | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1052  = do { complain_no_main; return (tcg_env, emptyFVs) }
1053
1054  | otherwise
1055  = do {         -- Check that 'main' is in scope
1056                 -- It might be imported from another module!
1057         main_name <- lookupSrcName main_RDR_Unqual ;
1058         failIfErrsM ;
1059
1060         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1061         setGblEnv tcg_env $ do {
1062
1063         -- $main :: IO () = runIO main
1064         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1065
1066         (main_bind, top_lie) <- getLIE (
1067                 addSrcLoc (getSrcLoc main_name) $
1068                 addErrCtxt mainCtxt             $ do {
1069                 (main_expr, ty) <- tcExpr_id rhs ;
1070                 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1071                 return (VarMonoBind dollar_main_id main_expr)
1072             }) ;
1073
1074         inst_binds <- tcSimplifyTop top_lie ;
1075
1076         (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1077
1078         let { tcg_env' = tcg_env {
1079                 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1080                 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1081
1082         return (tcg_env', unitFV main_name)
1083     }}
1084   where
1085     mod_name = moduleName (tcg_mod tcg_env)
1086     rdr_env  = tcg_rdr_env tcg_env
1087
1088     main_RDR_Unqual :: RdrName
1089     main_RDR_Unqual = mkUnqual varName FSLIT("main")
1090         -- Don't get a RdrName from PrelNames.mainName, because
1091         -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
1092         -- An Unqual one will do just fine
1093
1094     complain_no_main | ghci_mode == Interactive = return ()
1095                      | otherwise                = addErr noMainMsg
1096         -- In interactive mode, don't worry about the absence of 'main'
1097
1098     mainCtxt  = ptext SLIT("When checking the type of 'main'")
1099     noMainMsg = ptext SLIT("No 'main' defined in module Main")
1100 \end{code}
1101
1102
1103 %************************************************************************
1104 %*                                                                      *
1105                 Degugging output
1106 %*                                                                      *
1107 %************************************************************************
1108
1109 \begin{code}
1110 rnDump :: SDoc -> TcRn m ()
1111 -- Dump, with a banner, if -ddump-rn
1112 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1113
1114 tcDump :: TcGblEnv -> TcRn m ()
1115 tcDump env
1116  = do { dflags <- getDOpts ;
1117
1118         -- Dump short output if -ddump-types or -ddump-tc
1119         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1120             (dumpTcRn short_dump) ;
1121
1122         -- Dump bindings if -ddump-tc
1123         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1124    }
1125   where
1126     short_dump = pprTcGblEnv env
1127     full_dump  = ppr (tcg_binds env)
1128         -- NB: foreign x-d's have undefined's in their types;
1129         --     hence can't show the tc_fords
1130
1131 tcCoreDump mod_guts
1132  = do { dflags <- getDOpts ;
1133         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1134             (dumpTcRn (pprModGuts mod_guts)) ;
1135
1136         -- Dump bindings if -ddump-tc
1137         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1138   where
1139     full_dump = pprCoreBindings (mg_binds mod_guts)
1140
1141 -- It's unpleasant having both pprModGuts and pprModDetails here
1142 pprTcGblEnv :: TcGblEnv -> SDoc
1143 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1144                         tcg_insts    = dfun_ids,
1145                         tcg_rules    = rules })
1146   = vcat [ ppr_types dfun_ids type_env
1147          , ppr_insts dfun_ids
1148          , vcat (map ppr rules)
1149          , ppr_gen_tycons (typeEnvTyCons type_env)]
1150
1151 pprModGuts :: ModGuts -> SDoc
1152 pprModGuts (ModGuts { mg_types = type_env,
1153                       mg_rules = rules })
1154   = vcat [ ppr_types [] type_env,
1155            ppr_rules rules ]
1156
1157
1158 ppr_types :: [Var] -> TypeEnv -> SDoc
1159 ppr_types dfun_ids type_env
1160   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1161   where
1162     ids = [id | id <- typeEnvIds type_env, want_sig id]
1163     want_sig id | opt_PprStyle_Debug = True
1164                 | otherwise          = isLocalId id &&
1165                                        isExternalName (idName id) &&
1166                                        not (id `elem` dfun_ids)
1167         -- isLocalId ignores data constructors, records selectors etc.
1168         -- The isExternalName ignores local dictionary and method bindings
1169         -- that the type checker has invented.  Top-level user-defined things
1170         -- have External names.
1171
1172 ppr_insts :: [Var] -> SDoc
1173 ppr_insts []       = empty
1174 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1175
1176 ppr_sigs :: [Var] -> SDoc
1177 ppr_sigs ids
1178         -- Print type signatures
1179         -- Convert to HsType so that we get source-language style printing
1180         -- And sort by RdrName
1181   = vcat $ map ppr_sig $ sortLt lt_sig $
1182     [ (getRdrName id, toHsType (idType id))
1183     | id <- ids ]
1184   where
1185     lt_sig (n1,_) (n2,_) = n1 < n2
1186     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1187
1188
1189 ppr_rules :: [IdCoreRule] -> SDoc
1190 ppr_rules [] = empty
1191 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1192                       nest 4 (pprIdRules rs),
1193                       ptext SLIT("#-}")]
1194
1195 ppr_gen_tycons []  = empty
1196 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1197                            vcat (map ppr_gen_tycon tcs),
1198                            ptext SLIT("#-}")
1199                      ]
1200
1201 -- x&y are now Id's, not CoreExpr's
1202 ppr_gen_tycon tycon
1203   | Just ep <- tyConGenInfo tycon
1204   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1205
1206   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1207
1208 ppr_ep (EP from to)
1209   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1210            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1211            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1212     ]
1213   where
1214     (_,from_tau) = tcSplitForAllTys (idType from)
1215 \end{code}