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