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