compiler/typecheck/TcRnDriver.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcModule]{Typechecking a whole module}
   6
   7 \begin{code}
   8 module TcRnDriver (
   9 #ifdef GHCI
  10         tcRnStmt, tcRnExpr, tcRnType,
  11         tcRnLookupRdrName,
  12         tcRnLookupName,
  13         tcRnGetInfo,
  14         getModuleExports,
  15         tcRnRecoverDataCon,
  16 #endif
  17         tcRnModule,
  18         tcTopSrcDecls,
  19         tcRnExtCore
  20     ) where
  21
  22 #include "HsVersions.h"
  23
  24 import IO
  25 #ifdef GHCI
  26 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
  27 #endif
  28
  29 import DynFlags
  30 import StaticFlags
  31 import HsSyn
  32 import RdrHsSyn
  33
  34 import PrelNames
  35 import RdrName
  36 import TcHsSyn
  37 import TcExpr
  38 import TcRnMonad
  39 import TcType
  40 import Inst
  41 import FamInst
  42 import InstEnv
  43 import FamInstEnv
  44 import TcBinds
  45 import TcDefaults
  46 import TcEnv
  47 import TcRules
  48 import TcForeign
  49 import TcInstDcls
  50 import TcIface
  51 import MkIface
  52 import IfaceSyn
  53 import TcSimplify
  54 import TcTyClsDecls
  55 import LoadIface
  56 import RnNames
  57 import RnEnv
  58 import RnSource
  59 import RnHsDoc
  60 import PprCore
  61 import CoreSyn
  62 import ErrUtils
  63 import Id
  64 import Var
  65 import Module
  66 import UniqFM
  67 import Name
  68 import NameSet
  69 import TyCon
  70 import SrcLoc
  71 import HscTypes
  72 import DsBreakpoint
  73 import Outputable
  74
  75 #ifdef GHCI
  76 import Linker
  77 import DataCon
  78 import TcHsType
  79 import TcMType
  80 import TcMatches
  81 import TcGadt
  82 import RnTypes
  83 import RnExpr
  84 import IfaceEnv
  85 import MkId
  86 import TysWiredIn
  87 import IdInfo
  88 import {- Kind parts of -} Type
  89 import BasicTypes
  90 import Data.Maybe
  91 #endif
  92
  93 import FastString
  94 import Util
  95 import Bag
  96
  97 import Control.Monad    ( unless )
  98 import Data.Maybe       ( isJust )
  99 \end{code}
 100
 101
 102
 103 %************************************************************************
 104 %*                                                                      *
 105         Typecheck and rename a module
 106 %*                                                                      *
 107 %************************************************************************
 108
 109
 110 \begin{code}
 111 tcRnModule :: HscEnv
 112            -> HscSource
 113            -> Bool              -- True <=> save renamed syntax
 114            -> Located (HsModule RdrName)
 115            -> IO (Messages, Maybe TcGblEnv)
 116
 117 tcRnModule hsc_env hsc_src save_rn_syntax
 118          (L loc (HsModule maybe_mod export_ies
 119                           import_decls local_decls mod_deprec _ module_info maybe_doc))
 120  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 121
 122    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
 123          this_mod = case maybe_mod of
 124                         Nothing  -> mAIN        -- 'module M where' is omitted
 125                         Just (L _ mod) -> mkModule this_pkg mod } ;
 126                                                 -- The normal case
 127
 128    initTc hsc_env hsc_src this_mod $
 129    setSrcSpan loc $
 130    do {
 131                 -- Deal with imports;
 132         (rn_imports, rdr_env, imports) <- rnImports import_decls ;
 133
 134         let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
 135             ; dep_mods = imp_dep_mods imports
 136
 137                 -- We want instance declarations from all home-package
 138                 -- modules below this one, including boot modules, except
 139                 -- ourselves.  The 'except ourselves' is so that we don't
 140                 -- get the instances from this module's hs-boot file
 141             ; want_instances :: ModuleName -> Bool
 142             ; want_instances mod = mod `elemUFM` dep_mods
 143                                    && mod /= moduleName this_mod
 144             ; home_insts = hptInstances hsc_env want_instances
 145             } ;
 146
 147                 -- Record boot-file info in the EPS, so that it's
 148                 -- visible to loadHiBootInterface in tcRnSrcDecls,
 149                 -- and any other incrementally-performed imports
 150         updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
 151
 152                 -- Update the gbl env
 153         updGblEnv ( \ gbl ->
 154                 gbl { tcg_rdr_env  = plusOccEnv (tcg_rdr_env gbl) rdr_env,
 155                       tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
 156                       tcg_imports  = tcg_imports gbl `plusImportAvails` imports,
 157                       tcg_rn_imports = if save_rn_syntax then
 158                                          Just rn_imports
 159                                        else
 160                                          Nothing,
 161                       tcg_rn_decls = if save_rn_syntax then
 162                                         Just emptyRnGroup
 163                                      else
 164                                         Nothing })
 165                 $ do {
 166
 167         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
 168                 -- Fail if there are any errors so far
 169                 -- The error printing (if needed) takes advantage
 170                 -- of the tcg_env we have now set
 171         traceIf (text "rdr_env: " <+> ppr rdr_env) ;
 172         failIfErrsM ;
 173
 174                 -- Load any orphan-module and family instance-module
 175                 -- interfaces, so that their rules and instance decls will be
 176                 -- found.
 177         loadOrphanModules (imp_orphs  imports) False ;
 178         loadOrphanModules (imp_finsts imports) True  ;
 179
 180         traceRn (text "rn1: checking family instance consistency") ;
 181         let { directlyImpMods =   map (\(mod, _, _) -> mod)
 182                                 . moduleEnvElts
 183                                 . imp_mods
 184                                 $ imports } ;
 185         checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
 186
 187         traceRn (text "rn1a") ;
 188                 -- Rename and type check the declarations
 189         tcg_env <- if isHsBoot hsc_src then
 190                         tcRnHsBootDecls local_decls
 191                    else
 192                         tcRnSrcDecls local_decls ;
 193         setGblEnv tcg_env               $ do {
 194
 195         failIfErrsM ;   -- reportDeprecations crashes sometimes
 196                         -- as a result of typechecker repairs (e.g. unboundNames)
 197         traceRn (text "rn3") ;
 198
 199                 -- Report the use of any deprecated things
 200                 -- We do this before processsing the export list so
 201                 -- that we don't bleat about re-exporting a deprecated
 202                 -- thing (especially via 'module Foo' export item)
 203                 -- Only uses in the body of the module are complained about
 204         reportDeprecations (hsc_dflags hsc_env) tcg_env ;
 205
 206                 -- Process the export list
 207         (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
 208
 209         traceRn (text "rn4") ;
 210
 211                 -- Rename the Haddock documentation header
 212         rn_module_doc <- rnMbHsDoc maybe_doc ;
 213
 214                 -- Rename the Haddock module info
 215         rn_description <- rnMbHsDoc (hmi_description module_info) ;
 216         let { rn_module_info = module_info { hmi_description = rn_description } } ;
 217
 218                 -- Check whether the entire module is deprecated
 219                 -- This happens only once per module
 220         let { mod_deprecs = checkModDeprec mod_deprec } ;
 221
 222                 -- Add exports and deprecations to envt
 223         let { final_env  = tcg_env { tcg_exports = exports,
 224                                      tcg_rn_exports = if save_rn_syntax then
 225                                                          rn_exports
 226                                                       else Nothing,
 227                                      tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports),
 228                                      tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
 229                                                    mod_deprecs,
 230                                      tcg_doc = rn_module_doc,
 231                                      tcg_hmi = rn_module_info
 232                                   }
 233                 -- A module deprecation over-rides the earlier ones
 234              } ;
 235
 236                 -- Report unused names
 237         reportUnusedNames export_ies final_env ;
 238
 239                 -- Dump output and return
 240         tcDump final_env ;
 241         return final_env
 242     }}}}
 243 \end{code}
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248         Type-checking external-core modules
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 \begin{code}
 253 tcRnExtCore :: HscEnv
 254             -> HsExtCore RdrName
 255             -> IO (Messages, Maybe ModGuts)
 256         -- Nothing => some error occurred
 257
 258 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 259         -- The decls are IfaceDecls; all names are original names
 260  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 261
 262    initTc hsc_env ExtCoreFile this_mod $ do {
 263
 264    let { ldecls  = map noLoc decls } ;
 265
 266         -- Deal with the type declarations; first bring their stuff
 267         -- into scope, then rname them, then type check them
 268    tcg_env  <- importsFromLocalDecls (mkFakeGroup ldecls) ;
 269
 270    setGblEnv tcg_env $ do {
 271
 272    rn_decls <- rnTyClDecls ldecls ;
 273    failIfErrsM ;
 274
 275         -- Dump trace of renaming part
 276    rnDump (ppr rn_decls) ;
 277
 278         -- Typecheck them all together so that
 279         -- any mutually recursive types are done right
 280    tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
 281         -- Make the new type env available to stuff slurped from interface files
 282
 283    setGblEnv tcg_env $ do {
 284
 285         -- Now the core bindings
 286    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
 287
 288         -- Wrap up
 289    let {
 290         bndrs      = bindersOfBinds core_binds ;
 291         my_exports = map (Avail . idName) bndrs ;
 292                 -- ToDo: export the data types also?
 293
 294         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 295
 296         mod_guts = ModGuts {    mg_module    = this_mod,
 297                                 mg_boot      = False,
 298                                 mg_usages    = [],              -- ToDo: compute usage
 299                                 mg_dir_imps  = [],              -- ??
 300                                 mg_deps      = noDependencies,  -- ??
 301                                 mg_exports   = my_exports,
 302                                 mg_types     = final_type_env,
 303                                 mg_insts     = tcg_insts tcg_env,
 304                                 mg_fam_insts = tcg_fam_insts tcg_env,
 305                                 mg_rules     = [],
 306                                 mg_binds     = core_binds,
 307
 308                                 -- Stubs
 309                                 mg_rdr_env   = emptyGlobalRdrEnv,
 310                                 mg_fix_env   = emptyFixityEnv,
 311                                 mg_deprecs   = NoDeprecs,
 312                                 mg_foreign   = NoStubs,
 313                                 mg_hpc_info  = noHpcInfo,
 314                                 mg_dbg_sites = noDbgSites
 315                     } } ;
 316
 317    tcCoreDump mod_guts ;
 318
 319    return mod_guts
 320    }}}}
 321
 322 mkFakeGroup decls -- Rather clumsy; lots of unused fields
 323   = emptyRdrGroup { hs_tyclds = decls }
 324 \end{code}
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329         Type-checking the top level of a module
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 335         -- Returns the variables free in the decls
 336         -- Reason: solely to report unused imports and bindings
 337 tcRnSrcDecls decls
 338  = do {         -- Load the hi-boot interface for this module, if any
 339                 -- We do this now so that the boot_names can be passed
 340                 -- to tcTyAndClassDecls, because the boot_names are
 341                 -- automatically considered to be loop breakers
 342         mod <- getModule ;
 343         boot_iface <- tcHiBootIface mod ;
 344
 345                 -- Do all the declarations
 346         (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
 347
 348              --         Finish simplifying class constraints
 349              --
 350              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 351              -- How could there be ambiguous ones?  They can only arise if a
 352              -- top-level decl falls under the monomorphism restriction
 353              -- and no subsequent decl instantiates its type.
 354              --
 355              -- We do this after checkMain, so that we use the type info
 356              -- thaat checkMain adds
 357              --
 358              -- We do it with both global and local env in scope:
 359              --  * the global env exposes the instances to tcSimplifyTop
 360              --  * the local env exposes the local Ids to tcSimplifyTop,
 361              --    so that we get better error messages (monomorphism restriction)
 362         traceTc (text "Tc8") ;
 363         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
 364
 365             -- Backsubstitution.  This must be done last.
 366             -- Even tcSimplifyTop may do some unification.
 367         traceTc (text "Tc9") ;
 368         let { (tcg_env, _) = tc_envs
 369             ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 370                          tcg_rules = rules, tcg_fords = fords } = tcg_env
 371             ; all_binds = binds `unionBags` inst_binds } ;
 372
 373         (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
 374
 375         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
 376             ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
 377                                    tcg_binds = binds',
 378                                    tcg_rules = rules',
 379                                    tcg_fords = fords' } } ;
 380
 381         -- Make the new type env available to stuff slurped from interface files
 382         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 383
 384         -- Compare the hi-boot iface (if any) with the real thing
 385         dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
 386
 387         return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
 388    }
 389
 390 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
 391 -- Loops around dealing with each top level inter-splice group
 392 -- in turn, until it's dealt with the entire module
 393 tc_rn_src_decls boot_details ds
 394  = do { let { (first_group, group_tail) = findSplice ds } ;
 395                 -- If ds is [] we get ([], Nothing)
 396
 397         -- Deal with decls up to, but not including, the first splice
 398         (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
 399                 -- checkNoErrs: don't typecheck if renaming failed
 400         tc_envs <- setGblEnv tcg_env $
 401                    tcTopSrcDecls boot_details rn_decls ;
 402
 403         -- If there is no splice, we're nearly done
 404         setEnvs tc_envs $
 405         case group_tail of {
 406            Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
 407                            return (tcg_env, snd tc_envs)
 408                       } ;
 409
 410         -- If there's a splice, we must carry on
 411            Just (SpliceDecl splice_expr, rest_ds) -> do {
 412 #ifndef GHCI
 413         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 414 #else
 415
 416         -- Rename the splice expression, and get its supporting decls
 417         (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
 418                 -- checkNoErrs: don't typecheck if renaming failed
 419         rnDump (ppr rn_splice_expr) ;
 420
 421         -- Execute the splice
 422         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 423
 424         -- Glue them on the front of the remaining decls and loop
 425         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 426         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
 427 #endif /* GHCI */
 428     } } }
 429 \end{code}
 430
 431 %************************************************************************
 432 %*                                                                      *
 433         Compiling hs-boot source files, and
 434         comparing the hi-boot interface with the real thing
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 440 tcRnHsBootDecls decls
 441    = do { let { (first_group, group_tail) = findSplice decls }
 442
 443         ; case group_tail of
 444              Just stuff -> spliceInHsBootErr stuff
 445              Nothing    -> return ()
 446
 447                 -- Rename the declarations
 448         ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
 449         ; setGblEnv tcg_env $ do {
 450
 451         -- Todo: check no foreign decls, no rules, no default decls
 452
 453                 -- Typecheck type/class decls
 454         ; traceTc (text "Tc2")
 455         ; let tycl_decls = hs_tyclds rn_group
 456         ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
 457         ; setGblEnv tcg_env     $ do {
 458
 459                 -- Typecheck instance decls
 460         ; traceTc (text "Tc3")
 461         ; (tcg_env, inst_infos, _binds)
 462             <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
 463         ; setGblEnv tcg_env     $ do {
 464
 465                 -- Typecheck value declarations
 466         ; traceTc (text "Tc5")
 467         ; val_ids <- tcHsBootSigs (hs_valds rn_group)
 468
 469                 -- Wrap up
 470                 -- No simplification or zonking to do
 471         ; traceTc (text "Tc7a")
 472         ; gbl_env <- getGblEnv
 473
 474                 -- Make the final type-env
 475                 -- Include the dfun_ids so that their type sigs
 476                 -- are written into the interface file
 477         ; let { type_env0 = tcg_type_env gbl_env
 478               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
 479               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
 480               ; dfun_ids = map iDFunId inst_infos }
 481         ; return (gbl_env { tcg_type_env = type_env2 })
 482    }}}}
 483
 484 spliceInHsBootErr (SpliceDecl (L loc _), _)
 485   = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
 486 \end{code}
 487
 488 Once we've typechecked the body of the module, we want to compare what
 489 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
 490
 491 \begin{code}
 492 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
 493 -- Compare the hi-boot file for this module (if there is one)
 494 -- with the type environment we've just come up with
 495 -- In the common case where there is no hi-boot file, the list
 496 -- of boot_names is empty.
 497 --
 498 -- The bindings we return give bindings for the dfuns defined in the
 499 -- hs-boot file, such as        $fbEqT = $fEqT
 500
 501 checkHiBootIface
 502         (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
 503                     tcg_type_env = local_type_env })
 504         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
 505                       md_types = boot_type_env })
 506   = do  { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
 507         ; mapM_ check_one (typeEnvElts boot_type_env)
 508         ; dfun_binds <- mapM check_inst boot_insts
 509         ; unless (null boot_fam_insts) $
 510             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
 511                    "instances in boot files yet...")
 512             -- FIXME: Why?  The actual comparison is not hard, but what would
 513             --        be the equivalent to the dfun bindings returned for class
 514             --        instances?  We can't easily equate tycons...
 515         ; return (unionManyBags dfun_binds) }
 516   where
 517     check_one boot_thing
 518       | isImplicitTyThing boot_thing = return ()
 519       | name `elem` dfun_names       = return ()
 520       | isWiredInName name           = return ()        -- No checking for wired-in names.  In particular,
 521                                                         -- 'error' is handled by a rather gross hack
 522                                                         -- (see comments in GHC.Err.hs-boot)
 523       | Just real_thing <- lookupTypeEnv local_type_env name
 524       = do { let boot_decl = tyThingToIfaceDecl boot_thing
 525                  real_decl = tyThingToIfaceDecl real_thing
 526            ; checkTc (checkBootDecl boot_decl real_decl)
 527                      (bootMisMatch boot_thing boot_decl real_decl) }
 528                 -- The easiest way to check compatibility is to convert to
 529                 -- iface syntax, where we already have good comparison functions
 530       | otherwise
 531       = addErrTc (missingBootThing boot_thing)
 532       where
 533         name = getName boot_thing
 534
 535     dfun_names = map getName boot_insts
 536
 537     check_inst boot_inst
 538         = case [dfun | inst <- local_insts,
 539                        let dfun = instanceDFunId inst,
 540                        idType dfun `tcEqType` boot_inst_ty ] of
 541             [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
 542             (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
 543         where
 544           boot_dfun = instanceDFunId boot_inst
 545           boot_inst_ty = idType boot_dfun
 546           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
 547
 548 ----------------
 549 missingBootThing thing
 550   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
 551 bootMisMatch thing boot_decl real_decl
 552   = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"),
 553           ptext SLIT("Decl") <+> ppr real_decl,
 554           ptext SLIT("Boot file:") <+> ppr boot_decl]
 555 instMisMatch inst
 556   = hang (ppr inst)
 557        2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
 558 \end{code}
 559
 560
 561 %************************************************************************
 562 %*                                                                      *
 563         Type-checking the top level of a module
 564 %*                                                                      *
 565 %************************************************************************
 566
 567 tcRnGroup takes a bunch of top-level source-code declarations, and
 568  * renames them
 569  * gets supporting declarations from interface files
 570  * typechecks them
 571  * zonks them
 572  * and augments the TcGblEnv with the results
 573
 574 In Template Haskell it may be called repeatedly for each group of
 575 declarations.  It expects there to be an incoming TcGblEnv in the
 576 monad; it augments it and returns the new TcGblEnv.
 577
 578 \begin{code}
 579 ------------------------------------------------
 580 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 581 rnTopSrcDecls group
 582  = do {         -- Bring top level binders into scope
 583         tcg_env <- importsFromLocalDecls group ;
 584         setGblEnv tcg_env $ do {
 585
 586         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 587
 588                 -- Rename the source decls
 589         (tcg_env, rn_decls) <- rnSrcDecls group ;
 590         failIfErrsM ;
 591
 592                 -- save the renamed syntax, if we want it
 593         let { tcg_env'
 594                 | Just grp <- tcg_rn_decls tcg_env
 595                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
 596                 | otherwise
 597                    = tcg_env };
 598
 599                 -- Dump trace of renaming part
 600         rnDump (ppr rn_decls) ;
 601
 602         return (tcg_env', rn_decls)
 603    }}
 604
 605 ------------------------------------------------
 606 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 607 tcTopSrcDecls boot_details
 608         (HsGroup { hs_tyclds = tycl_decls,
 609                    hs_instds = inst_decls,
 610                    hs_derivds = deriv_decls,
 611                    hs_fords  = foreign_decls,
 612                    hs_defds  = default_decls,
 613                    hs_ruleds = rule_decls,
 614                    hs_valds  = val_binds })
 615  = do {         -- Type-check the type and class decls, and all imported decls
 616                 -- The latter come in via tycl_decls
 617         traceTc (text "Tc2") ;
 618
 619         tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
 620         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 621         -- an error we'd better stop now, to avoid a cascade
 622
 623         -- Make these type and class decls available to stuff slurped from interface files
 624         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 625
 626
 627         setGblEnv tcg_env       $ do {
 628                 -- Source-language instances, including derivings,
 629                 -- and import the supporting declarations
 630         traceTc (text "Tc3") ;
 631         (tcg_env, inst_infos, deriv_binds)
 632             <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
 633         setGblEnv tcg_env       $ do {
 634
 635                 -- Foreign import declarations next.  No zonking necessary
 636                 -- here; we can tuck them straight into the global environment.
 637         traceTc (text "Tc4") ;
 638         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 639         tcExtendGlobalValEnv fi_ids     $ do {
 640
 641                 -- Default declarations
 642         traceTc (text "Tc4a") ;
 643         default_tys <- tcDefaults default_decls ;
 644         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 645
 646                 -- Value declarations next
 647                 -- We also typecheck any extra binds that came out
 648                 -- of the "deriving" process (deriv_binds)
 649         traceTc (text "Tc5") ;
 650         (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
 651         setLclTypeEnv tcl_env   $ do {
 652
 653                 -- Second pass over class and instance declarations,
 654         traceTc (text "Tc6") ;
 655         (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
 656         showLIE (text "after instDecls2") ;
 657
 658                 -- Foreign exports
 659                 -- They need to be zonked, so we return them
 660         traceTc (text "Tc7") ;
 661         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 662
 663                 -- Rules
 664         rules <- tcRules rule_decls ;
 665
 666                 -- Wrap up
 667         traceTc (text "Tc7a") ;
 668         tcg_env <- getGblEnv ;
 669         let { all_binds = tc_val_binds   `unionBags`
 670                           inst_binds     `unionBags`
 671                           foe_binds  ;
 672
 673                 -- Extend the GblEnv with the (as yet un-zonked)
 674                 -- bindings, rules, foreign decls
 675               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 676                                     tcg_rules = tcg_rules tcg_env ++ rules,
 677                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 678         return (tcg_env', tcl_env)
 679     }}}}}}
 680 \end{code}
 681
 682
 683 %************************************************************************
 684 %*                                                                      *
 685         Checking for 'main'
 686 %*                                                                      *
 687 %************************************************************************
 688
 689 \begin{code}
 690 checkMain :: TcM TcGblEnv
 691 -- If we are in module Main, check that 'main' is defined.
 692 checkMain
 693   = do { ghc_mode <- getGhcMode ;
 694          tcg_env   <- getGblEnv ;
 695          dflags    <- getDOpts ;
 696          let { main_mod = mainModIs dflags ;
 697                main_fn  = case mainFunIs dflags of {
 698                                 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
 699                                 Nothing -> main_RDR_Unqual } } ;
 700
 701          check_main ghc_mode tcg_env main_mod main_fn
 702     }
 703
 704
 705 check_main ghc_mode tcg_env main_mod main_fn
 706  | mod /= main_mod
 707  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
 708    return tcg_env
 709
 710  | otherwise
 711  = addErrCtxt mainCtxt                  $
 712    do   { mb_main <- lookupSrcOcc_maybe main_fn
 713                 -- Check that 'main' is in scope
 714                 -- It might be imported from another module!
 715         ; case mb_main of {
 716              Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
 717                            ; complain_no_main
 718                            ; return tcg_env } ;
 719              Just main_name -> do
 720         { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
 721         ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
 722                         -- :Main.main :: IO () = runMainIO main
 723
 724         ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 725                              tcInferRho rhs
 726
 727         -- The function that the RTS invokes is always :Main.main,
 728         -- which we call root_main_id.
 729         -- (Because GHC allows the user to have a module not called
 730         -- Main as the main module, we can't rely on the main function
 731         -- being called "Main.main".  That's why root_main_id has a fixed
 732         -- module ":Main".)
 733         -- We also make root_main_id an implicit Id, by making main_name
 734         -- its parent (hence (Just main_name)).  That has the effect
 735         -- of preventing its type and unfolding from getting out into
 736         -- the interface file. Otherwise we can end up with two defns
 737         -- for 'main' in the interface file!
 738
 739         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
 740                                    (mkVarOccFS FSLIT("main"))
 741                                    (getSrcLoc main_name)
 742               ; root_main_id = Id.mkExportedLocalId root_main_name ty
 743               ; main_bind    = noLoc (VarBind root_main_id main_expr) }
 744
 745         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 746                                         `snocBag` main_bind,
 747                             tcg_dus   = tcg_dus tcg_env
 748                                         `plusDU` usesOnly (unitFV main_name)
 749                         -- Record the use of 'main', so that we don't
 750                         -- complain about it being defined but not used
 751                  })
 752     }}}
 753   where
 754     mod = tcg_mod tcg_env
 755
 756     complain_no_main | ghc_mode == Interactive = return ()
 757                      | otherwise                = failWithTc noMainMsg
 758         -- In interactive mode, don't worry about the absence of 'main'
 759         -- In other modes, fail altogether, so that we don't go on
 760         -- and complain a second time when processing the export list.
 761
 762     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 763     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 764                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 765 \end{code}
 766
 767 %*********************************************************
 768 %*                                                       *
 769                 GHCi stuff
 770 %*                                                       *
 771 %*********************************************************
 772
 773 \begin{code}
 774 #ifdef GHCI
 775 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
 776 setInteractiveContext hsc_env icxt thing_inside
 777   = let
 778         -- Initialise the tcg_inst_env with instances
 779         -- from all home modules.  This mimics the more selective
 780         -- call to hptInstances in tcRnModule
 781         dfuns = hptInstances hsc_env (\mod -> True)
 782     in
 783     updGblEnv (\env -> env {
 784         tcg_rdr_env  = ic_rn_gbl_env icxt,
 785         tcg_type_env = ic_type_env   icxt,
 786         tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
 787
 788     updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt })  $
 789
 790     do  { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
 791         ; thing_inside }
 792 \end{code}
 793
 794
 795 \begin{code}
 796 tcRnStmt :: HscEnv
 797          -> InteractiveContext
 798          -> LStmt RdrName
 799          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 800                 -- The returned [Name] is the same as the input except for
 801                 -- ExprStmt, in which case the returned [Name] is [itName]
 802                 --
 803                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 804                 -- a list of the bound values, coerced to ().
 805
 806 tcRnStmt hsc_env ictxt rdr_stmt
 807   = initTcPrintErrors hsc_env iNTERACTIVE $
 808     setInteractiveContext hsc_env ictxt $ do {
 809
 810     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 811     (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
 812     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 813     failIfErrsM ;
 814
 815     -- The real work is done here
 816     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
 817     zonked_expr <- zonkTopLExpr tc_expr ;
 818     zonked_ids  <- zonkTopBndrs bound_ids ;
 819
 820         -- None of the Ids should be of unboxed type, because we
 821         -- cast them all to HValues in the end!
 822     mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 823
 824     traceTc (text "tcs 1") ;
 825     let {       -- (a) Make all the bound ids "global" ids, now that
 826                 --     they're notionally top-level bindings.  This is
 827                 --     important: otherwise when we come to compile an expression
 828                 --     using these ids later, the byte code generator will consider
 829                 --     the occurrences to be free rather than global.
 830                 --
 831                 -- (b) Tidy their types; this is important, because :info may
 832                 --     ask to look at them, and :info expects the things it looks
 833                 --     up to have tidy types
 834         global_ids = map globaliseAndTidy zonked_ids ;
 835
 836                 -- Update the interactive context
 837         rn_env   = ic_rn_local_env ictxt ;
 838         type_env = ic_type_env ictxt ;
 839
 840         bound_names = map idName global_ids ;
 841         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 842
 843 {- ---------------------------------------------
 844    At one stage I removed any shadowed bindings from the type_env;
 845    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
 846    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
 847    GHCi session
 848          Prelude> let f n = n * 2 :: Int
 849          Prelude> fName <- runQ [| f |]
 850          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
 851          14
 852          Prelude> let f n = n * 3 :: Int
 853          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
 854    In the last line we use 'fName', which resolves to the *first* 'f'
 855    in scope. If we delete it from the type env, GHCi crashes because
 856    it doesn't expect that.
 857
 858    Hence this code is commented out
 859
 860         shadowed = [ n | name <- bound_names,
 861                          let rdr_name = mkRdrUnqual (nameOccName name),
 862                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 863         filtered_type_env = delListFromNameEnv type_env shadowed ;
 864 -------------------------------------------------- -}
 865
 866         new_type_env = extendTypeEnvWithIds type_env global_ids ;
 867         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 868                          ic_type_env     = new_type_env }
 869     } ;
 870
 871     dumpOptTcRn Opt_D_dump_tc
 872         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 873                text "Typechecked expr" <+> ppr zonked_expr]) ;
 874
 875     returnM (new_ic, bound_names, zonked_expr)
 876     }
 877   where
 878     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
 879                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 880
 881 globaliseAndTidy :: Id -> Id
 882 globaliseAndTidy id
 883 -- Give the Id a Global Name, and tidy its type
 884   = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
 885   where
 886     tidy_type = tidyTopType (idType id)
 887 \end{code}
 888
 889 Here is the grand plan, implemented in tcUserStmt
 890
 891         What you type                   The IO [HValue] that hscStmt returns
 892         -------------                   ------------------------------------
 893         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 894                                         bindings: [x,y,...]
 895
 896         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 897                                         bindings: [x,y,...]
 898
 899         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
 900           [NB: result not printed]      bindings: [it]
 901
 902         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
 903           result showable)              bindings: [it]
 904
 905         expr (of non-IO type,
 906           result not showable)  ==>     error
 907
 908
 909 \begin{code}
 910 ---------------------------
 911 type PlanResult = ([Id], LHsExpr Id)
 912 type Plan = TcM PlanResult
 913
 914 runPlans :: [Plan] -> TcM PlanResult
 915 -- Try the plans in order.  If one fails (by raising an exn), try the next.
 916 -- If one succeeds, take it.
 917 runPlans []     = panic "runPlans"
 918 runPlans [p]    = p
 919 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
 920
 921 --------------------
 922 mkPlan :: LStmt Name -> TcM PlanResult
 923 mkPlan (L loc (ExprStmt expr _ _))      -- An expression typed at the prompt
 924   = do  { uniq <- newUnique             -- is treated very specially
 925         ; let fresh_it  = itName uniq
 926               the_bind  = L loc $ mkFunBind (L loc fresh_it) matches
 927               matches   = [mkMatch [] expr emptyLocalBinds]
 928               let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
 929               bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
 930                                            (HsVar bindIOName) noSyntaxExpr
 931               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
 932                                            (HsVar thenIOName) placeHolderType
 933
 934         -- The plans are:
 935         --      [it <- e; print it]     but not if it::()
 936         --      [it <- e]
 937         --      [let it = e; print it]
 938         ; runPlans [    -- Plan A
 939                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
 940                        ; it_ty <- zonkTcType (idType it_id)
 941                        ; ifM (isUnitTy it_ty) failM
 942                        ; return stuff },
 943
 944                         -- Plan B; a naked bind statment
 945                     tcGhciStmts [bind_stmt],
 946
 947                         -- Plan C; check that the let-binding is typeable all by itself.
 948                         -- If not, fail; if so, try to print it.
 949                         -- The two-step process avoids getting two errors: one from
 950                         -- the expression itself, and one from the 'print it' part
 951                         -- This two-step story is very clunky, alas
 952                     do { checkNoErrs (tcGhciStmts [let_stmt])
 953                                 --- checkNoErrs defeats the error recovery of let-bindings
 954                        ; tcGhciStmts [let_stmt, print_it] }
 955           ]}
 956
 957 mkPlan stmt@(L loc (BindStmt {}))
 958   | [L _ v] <- collectLStmtBinders stmt         -- One binder, for a bind stmt
 959   = do  { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
 960                                            (HsVar thenIOName) placeHolderType
 961
 962         ; print_bind_result <- doptM Opt_PrintBindResult
 963         ; let print_plan = do
 964                   { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
 965                   ; v_ty <- zonkTcType (idType v_id)
 966                   ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
 967                   ; return stuff }
 968
 969         -- The plans are:
 970         --      [stmt; print v]         but not if v::()
 971         --      [stmt]
 972         ; runPlans ((if print_bind_result then [print_plan] else []) ++
 973                     [tcGhciStmts [stmt]])
 974         }
 975
 976 mkPlan stmt
 977   = tcGhciStmts [stmt]
 978
 979 ---------------------------
 980 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
 981 tcGhciStmts stmts
 982  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 983         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
 984         let {
 985             io_ty     = mkTyConApp ioTyCon [] ;
 986             ret_ty    = mkListTy unitTy ;
 987             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 988             tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts
 989                                         (emptyRefinement, io_ret_ty) ;
 990
 991             names = map unLoc (collectLStmtsBinders stmts) ;
 992
 993                 -- mk_return builds the expression
 994                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 995                 --
 996                 -- Despite the inconvenience of building the type applications etc,
 997                 -- this *has* to be done in type-annotated post-typecheck form
 998                 -- because we are going to return a list of *polymorphic* values
 999                 -- coerced to type (). If we built a *source* stmt
1000                 --      return [coerce x, ..., coerce z]
1001                 -- then the type checker would instantiate x..z, and we wouldn't
1002                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1003                 -- if they were overloaded, since they aren't applied to anything.)
1004             mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
1005                                     (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1006             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1007                                  (nlHsVar id)
1008          } ;
1009
1010         -- OK, we're ready to typecheck the stmts
1011         traceTc (text "tcs 2") ;
1012         ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
1013                                            mappM tcLookupId names ;
1014                                         -- Look up the names right in the middle,
1015                                         -- where they will all be in scope
1016
1017         -- Simplify the context
1018         const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
1019                 -- checkNoErrs ensures that the plan fails if context redn fails
1020
1021         return (ids, mkHsDictLet const_binds $
1022                      noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
1023     }
1024 \end{code}
1025
1026
1027 tcRnExpr just finds the type of an expression
1028
1029 \begin{code}
1030 tcRnExpr :: HscEnv
1031          -> InteractiveContext
1032          -> LHsExpr RdrName
1033          -> IO (Maybe Type)
1034 tcRnExpr hsc_env ictxt rdr_expr
1035   = initTcPrintErrors hsc_env iNTERACTIVE $
1036     setInteractiveContext hsc_env ictxt $ do {
1037
1038     (rn_expr, fvs) <- rnLExpr rdr_expr ;
1039     failIfErrsM ;
1040
1041         -- Now typecheck the expression;
1042         -- it might have a rank-2 type (e.g. :t runST)
1043     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
1044     ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
1045     tcSimplifyInteractive lie_top ;
1046
1047     let { all_expr_ty = mkForAllTys qtvs $
1048                         mkFunTys (map (idType . instToId) dict_insts)   $
1049                         res_ty } ;
1050     zonkTcType all_expr_ty
1051     }
1052   where
1053     smpl_doc = ptext SLIT("main expression")
1054 \end{code}
1055
1056 tcRnType just finds the kind of a type
1057
1058 \begin{code}
1059 tcRnType :: HscEnv
1060          -> InteractiveContext
1061          -> LHsType RdrName
1062          -> IO (Maybe Kind)
1063 tcRnType hsc_env ictxt rdr_type
1064   = initTcPrintErrors hsc_env iNTERACTIVE $
1065     setInteractiveContext hsc_env ictxt $ do {
1066
1067     rn_type <- rnLHsType doc rdr_type ;
1068     failIfErrsM ;
1069
1070         -- Now kind-check the type
1071     (ty', kind) <- kcHsType rn_type ;
1072     return kind
1073     }
1074   where
1075     doc = ptext SLIT("In GHCi input")
1076
1077 #endif /* GHCi */
1078 \end{code}
1079
1080
1081 %************************************************************************
1082 %*                                                                      *
1083         More GHCi stuff, to do with browsing and getting info
1084 %*                                                                      *
1085 %************************************************************************
1086
1087 \begin{code}
1088 #ifdef GHCI
1089 -- ASSUMES that the module is either in the HomePackageTable or is
1090 -- a package module with an interface on disk.  If neither of these is
1091 -- true, then the result will be an error indicating the interface
1092 -- could not be found.
1093 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
1094 getModuleExports hsc_env mod
1095   = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
1096
1097 tcGetModuleExports :: Module -> TcM [AvailInfo]
1098 tcGetModuleExports mod = do
1099   let doc = ptext SLIT("context for compiling statements")
1100   iface <- initIfaceTcRn $ loadSysInterface doc mod
1101   loadOrphanModules (dep_orphs (mi_deps iface)) False
1102                 -- Load any orphan-module interfaces,
1103                 -- so their instances are visible
1104   loadOrphanModules (dep_finsts (mi_deps iface)) True
1105                 -- Load any family instance-module interfaces,
1106                 -- so all family instances are visible
1107   ifaceExportNames (mi_exports iface)
1108
1109 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
1110 tcRnLookupRdrName hsc_env rdr_name
1111   = initTcPrintErrors hsc_env iNTERACTIVE $
1112     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1113     lookup_rdr_name rdr_name
1114
1115 lookup_rdr_name rdr_name = do {
1116         -- If the identifier is a constructor (begins with an
1117         -- upper-case letter), then we need to consider both
1118         -- constructor and type class identifiers.
1119     let { rdr_names = dataTcOccs rdr_name } ;
1120
1121         -- results :: [Either Messages Name]
1122     results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
1123
1124     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1125         -- The successful lookups will be (Just name)
1126     let { (warns_s, good_names) = unzip [ (msgs, name)
1127                                         | (msgs, Just name) <- results] ;
1128           errs_s = [msgs | (msgs, Nothing) <- results] } ;
1129
1130         -- Fail if nothing good happened, else add warnings
1131     if null good_names then
1132                 -- No lookup succeeded, so
1133                 -- pick the first error message and report it
1134                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1135                 --       while the other is "X is not in scope",
1136                 --       we definitely want the former; but we might pick the latter
1137         do { addMessages (head errs_s) ; failM }
1138       else                      -- Add deprecation warnings
1139         mapM_ addMessages warns_s ;
1140
1141     return good_names
1142  }
1143
1144 tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
1145 tcRnRecoverDataCon hsc_env a
1146   = initTcPrintErrors hsc_env iNTERACTIVE $
1147     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1148      do name    <- recoverDataCon a
1149         tcLookupDataCon name
1150
1151 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
1152 tcRnLookupName hsc_env name
1153   = initTcPrintErrors hsc_env iNTERACTIVE $
1154     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1155     tcLookupGlobal name
1156
1157
1158 tcRnGetInfo :: HscEnv
1159             -> Name
1160             -> IO (Maybe (TyThing, Fixity, [Instance]))
1161
1162 -- Used to implemnent :info in GHCi
1163 --
1164 -- Look up a RdrName and return all the TyThings it might be
1165 -- A capitalised RdrName is given to us in the DataName namespace,
1166 -- but we want to treat it as *both* a data constructor
1167 --  *and* as a type or class constructor;
1168 -- hence the call to dataTcOccs, and we return up to two results
1169 tcRnGetInfo hsc_env name
1170   = initTcPrintErrors hsc_env iNTERACTIVE $
1171     let ictxt = hsc_IC hsc_env in
1172     setInteractiveContext hsc_env ictxt $ do
1173
1174         -- Load the interface for all unqualified types and classes
1175         -- That way we will find all the instance declarations
1176         -- (Packages have not orphan modules, and we assume that
1177         --  in the home package all relevant modules are loaded.)
1178     loadUnqualIfaces ictxt
1179
1180     thing  <- tcLookupGlobal name
1181     fixity <- lookupFixityRn name
1182     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
1183     return (thing, fixity, ispecs)
1184
1185 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
1186 -- Filter the instances by the ones whose tycons (or clases resp)
1187 -- are in scope unqualified.  Otherwise we list a whole lot too many!
1188 lookupInsts print_unqual (AClass cls)
1189   = do  { inst_envs <- tcGetInstEnvs
1190         ; return [ ispec
1191                  | ispec <- classInstances inst_envs cls
1192                  , plausibleDFun print_unqual (instanceDFunId ispec) ] }
1193
1194 lookupInsts print_unqual (ATyCon tc)
1195   = do  { eps <- getEps -- Load all instances for all classes that are
1196                         -- in the type environment (which are all the ones
1197                         -- we've seen in any interface file so far)
1198         ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
1199         ; return [ ispec
1200                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1201                  , let dfun = instanceDFunId ispec
1202                  , relevant dfun
1203                  , plausibleDFun print_unqual dfun ] }
1204   where
1205     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1206     tc_name     = tyConName tc
1207
1208 lookupInsts print_unqual other = return []
1209
1210 plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
1211   = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
1212   where
1213     ok name | isBuiltInSyntax name = True
1214             | isExternalName name  =
1215                 isNothing $ fst print_unqual (nameModule name)
1216                                              (nameOccName name)
1217             | otherwise            = True
1218
1219 loadUnqualIfaces :: InteractiveContext -> TcM ()
1220 -- Load the home module for everything that is in scope unqualified
1221 -- This is so that we can accurately report the instances for
1222 -- something
1223 loadUnqualIfaces ictxt
1224   = initIfaceTcRn $
1225     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1226   where
1227     unqual_mods = [ nameModule name
1228                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1229                     let name = gre_name gre,
1230                     not (isInternalName name),
1231                     isTcOcc (nameOccName name),  -- Types and classes only
1232                     unQualOK gre ]               -- In scope unqualified
1233     doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
1234 #endif /* GHCI */
1235 \end{code}
1236
1237 %************************************************************************
1238 %*                                                                      *
1239                 Degugging output
1240 %*                                                                      *
1241 %************************************************************************
1242
1243 \begin{code}
1244 rnDump :: SDoc -> TcRn ()
1245 -- Dump, with a banner, if -ddump-rn
1246 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1247
1248 tcDump :: TcGblEnv -> TcRn ()
1249 tcDump env
1250  = do { dflags <- getDOpts ;
1251
1252         -- Dump short output if -ddump-types or -ddump-tc
1253         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1254             (dumpTcRn short_dump) ;
1255
1256         -- Dump bindings if -ddump-tc
1257         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1258    }
1259   where
1260     short_dump = pprTcGblEnv env
1261     full_dump  = pprLHsBinds (tcg_binds env)
1262         -- NB: foreign x-d's have undefined's in their types;
1263         --     hence can't show the tc_fords
1264
1265 tcCoreDump mod_guts
1266  = do { dflags <- getDOpts ;
1267         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1268             (dumpTcRn (pprModGuts mod_guts)) ;
1269
1270         -- Dump bindings if -ddump-tc
1271         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1272   where
1273     full_dump = pprCoreBindings (mg_binds mod_guts)
1274
1275 -- It's unpleasant having both pprModGuts and pprModDetails here
1276 pprTcGblEnv :: TcGblEnv -> SDoc
1277 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
1278                         tcg_insts     = insts,
1279                         tcg_fam_insts = fam_insts,
1280                         tcg_rules     = rules,
1281                         tcg_imports   = imports })
1282   = vcat [ ppr_types insts type_env
1283          , ppr_tycons fam_insts type_env
1284          , ppr_insts insts
1285          , ppr_fam_insts fam_insts
1286          , vcat (map ppr rules)
1287          , ppr_gen_tycons (typeEnvTyCons type_env)
1288          , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
1289          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1290
1291 pprModGuts :: ModGuts -> SDoc
1292 pprModGuts (ModGuts { mg_types = type_env,
1293                       mg_rules = rules })
1294   = vcat [ ppr_types [] type_env,
1295            ppr_rules rules ]
1296
1297 ppr_types :: [Instance] -> TypeEnv -> SDoc
1298 ppr_types insts type_env
1299   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1300   where
1301     dfun_ids = map instanceDFunId insts
1302     ids = [id | id <- typeEnvIds type_env, want_sig id]
1303     want_sig id | opt_PprStyle_Debug = True
1304                 | otherwise          = isLocalId id &&
1305                                        isExternalName (idName id) &&
1306                                        not (id `elem` dfun_ids)
1307         -- isLocalId ignores data constructors, records selectors etc.
1308         -- The isExternalName ignores local dictionary and method bindings
1309         -- that the type checker has invented.  Top-level user-defined things
1310         -- have External names.
1311
1312 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1313 ppr_tycons fam_insts type_env
1314   = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
1315   where
1316     fi_tycons = map famInstTyCon fam_insts
1317     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1318     want_tycon tycon | opt_PprStyle_Debug = True
1319                      | otherwise          = not (isImplicitTyCon tycon) &&
1320                                             isExternalName (tyConName tycon) &&
1321                                             not (tycon `elem` fi_tycons)
1322
1323 ppr_insts :: [Instance] -> SDoc
1324 ppr_insts []     = empty
1325 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1326
1327 ppr_fam_insts :: [FamInst] -> SDoc
1328 ppr_fam_insts []        = empty
1329 ppr_fam_insts fam_insts =
1330   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1331
1332 ppr_sigs :: [Var] -> SDoc
1333 ppr_sigs ids
1334         -- Print type signatures; sort by OccName
1335   = vcat (map ppr_sig (sortLe le_sig ids))
1336   where
1337     le_sig id1 id2 = getOccName id1 <= getOccName id2
1338     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1339
1340 ppr_tydecls :: [TyCon] -> SDoc
1341 ppr_tydecls tycons
1342         -- Print type constructor info; sort by OccName
1343   = vcat (map ppr_tycon (sortLe le_sig tycons))
1344   where
1345     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
1346     ppr_tycon tycon
1347       | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
1348       | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
1349
1350 ppr_rules :: [CoreRule] -> SDoc
1351 ppr_rules [] = empty
1352 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1353                       nest 4 (pprRules rs),
1354                       ptext SLIT("#-}")]
1355
1356 ppr_gen_tycons []  = empty
1357 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1358                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1359 \end{code}