ghc/compiler/typecheck/TcRnDriver.lhs

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