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