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