compiler/typecheck/TcRnDriver.lhs

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