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
 432         -- Execute the splice
 433         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 434
 435         -- Glue them on the front of the remaining decls and loop
 436         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 437         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
 438 #endif /* GHCI */
 439     }}}
 440 \end{code}
 441
 442 %************************************************************************
 443 %*                                                                      *
 444         Compiling hs-boot source files, and
 445         comparing the hi-boot interface with the real thing
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 451 tcRnHsBootDecls decls
 452    = do { let { (first_group, group_tail) = findSplice decls }
 453
 454         ; case group_tail of
 455              Just stuff -> spliceInHsBootErr stuff
 456              Nothing    -> return ()
 457
 458                 -- Rename the declarations
 459         ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
 460         ; setGblEnv tcg_env $ do {
 461
 462         -- Todo: check no foreign decls, no rules, no default decls
 463
 464                 -- Typecheck type/class decls
 465         ; traceTc (text "Tc2")
 466         ; let tycl_decls = hs_tyclds rn_group
 467         ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
 468         ; setGblEnv tcg_env     $ do {
 469
 470                 -- Typecheck instance decls
 471         ; traceTc (text "Tc3")
 472         ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
 473         ; setGblEnv tcg_env     $ do {
 474
 475                 -- Typecheck value declarations
 476         ; traceTc (text "Tc5")
 477         ; val_ids <- tcHsBootSigs (hs_valds rn_group)
 478
 479                 -- Wrap up
 480                 -- No simplification or zonking to do
 481         ; traceTc (text "Tc7a")
 482         ; gbl_env <- getGblEnv
 483
 484                 -- Make the final type-env
 485                 -- Include the dfun_ids so that their type sigs get
 486                 -- are written into the interface file
 487         ; let { type_env0 = tcg_type_env gbl_env
 488               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
 489               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
 490               ; dfun_ids = map iDFunId inst_infos }
 491         ; return (gbl_env { tcg_type_env = type_env2 })
 492    }}}}
 493
 494 spliceInHsBootErr (SpliceDecl (L loc _), _)
 495   = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
 496 \end{code}
 497
 498 Once we've typechecked the body of the module, we want to compare what
 499 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
 500
 501 \begin{code}
 502 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
 503 -- Compare the hi-boot file for this module (if there is one)
 504 -- with the type environment we've just come up with
 505 -- In the common case where there is no hi-boot file, the list
 506 -- of boot_names is empty.
 507 --
 508 -- The bindings we return give bindings for the dfuns defined in the
 509 -- hs-boot file, such as        $fbEqT = $fEqT
 510
 511 checkHiBootIface
 512         (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
 513         (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
 514   = do  { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
 515         ; mapM_ check_one (typeEnvElts boot_type_env)
 516         ; dfun_binds <- mapM check_inst boot_insts
 517         ; return (unionManyBags dfun_binds) }
 518   where
 519     check_one boot_thing
 520       | no_check name
 521       = return ()
 522       | Just real_thing <- lookupTypeEnv local_type_env name
 523       = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing
 524                  real_decl = tyThingToIfaceDecl ext_nm real_thing
 525            ; checkTc (checkBootDecl boot_decl real_decl)
 526                      (bootMisMatch boot_thing boot_decl real_decl) }
 527                 -- The easiest way to check compatibility is to convert to
 528                 -- iface syntax, where we already have good comparison functions
 529       | otherwise
 530       = addErrTc (missingBootThing boot_thing)
 531       where
 532         name = getName boot_thing
 533
 534     ext_nm name = ExtPkg (nameModule name) (nameOccName name)
 535         -- Just enough to compare; no versions etc needed
 536
 537     no_check name = isWiredInName name  -- No checking for wired-in names.  In particular,
 538                                         -- 'error' is handled by a rather gross hack
 539                                         -- (see comments in GHC.Err.hs-boot)
 540                   || name `elem` dfun_names
 541                   || isImplicitName name        -- Has a parent, which we'll check
 542
 543     dfun_names = map getName boot_insts
 544
 545     check_inst boot_inst
 546         = case [dfun | inst <- local_insts,
 547                        let dfun = instanceDFunId inst,
 548                        idType dfun `tcEqType` boot_inst_ty ] of
 549             [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
 550             (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
 551         where
 552           boot_dfun = instanceDFunId boot_inst
 553           boot_inst_ty = idType boot_dfun
 554           local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
 555
 556 ----------------
 557 missingBootThing thing
 558   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
 559 bootMisMatch thing boot_decl real_decl
 560   = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
 561 instMisMatch inst
 562   = hang (ppr inst)
 563        2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
 564 \end{code}
 565
 566
 567 %************************************************************************
 568 %*                                                                      *
 569         Type-checking the top level of a module
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 tcRnGroup takes a bunch of top-level source-code declarations, and
 574  * renames them
 575  * gets supporting declarations from interface files
 576  * typechecks them
 577  * zonks them
 578  * and augments the TcGblEnv with the results
 579
 580 In Template Haskell it may be called repeatedly for each group of
 581 declarations.  It expects there to be an incoming TcGblEnv in the
 582 monad; it augments it and returns the new TcGblEnv.
 583
 584 \begin{code}
 585 tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 586         -- Returns the variables free in the decls, for unused-binding reporting
 587 tcRnGroup boot_details decls
 588  = do {         -- Rename the declarations
 589         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 590         setGblEnv tcg_env $ do {
 591
 592                 -- Typecheck the declarations
 593         tcTopSrcDecls boot_details rn_decls
 594   }}
 595
 596 ------------------------------------------------
 597 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 598 rnTopSrcDecls group
 599  = do {         -- Bring top level binders into scope
 600         tcg_env <- importsFromLocalDecls group ;
 601         setGblEnv tcg_env $ do {
 602
 603         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 604
 605                 -- Rename the source decls
 606         (tcg_env, rn_decls) <- rnSrcDecls group ;
 607         failIfErrsM ;
 608
 609                 -- save the renamed syntax, if we want it
 610         let { tcg_env'
 611                 | Just grp <- tcg_rn_decls tcg_env
 612                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
 613                 | otherwise
 614                    = tcg_env };
 615
 616                 -- Dump trace of renaming part
 617         rnDump (ppr rn_decls) ;
 618
 619         return (tcg_env', rn_decls)
 620    }}
 621
 622 ------------------------------------------------
 623 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 624 tcTopSrcDecls boot_details
 625         (HsGroup { hs_tyclds = tycl_decls,
 626                    hs_instds = inst_decls,
 627                    hs_fords  = foreign_decls,
 628                    hs_defds  = default_decls,
 629                    hs_ruleds = rule_decls,
 630                    hs_valds  = val_binds })
 631  = do {         -- Type-check the type and class decls, and all imported decls
 632                 -- The latter come in via tycl_decls
 633         traceTc (text "Tc2") ;
 634
 635         tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
 636         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 637         -- an error we'd better stop now, to avoid a cascade
 638
 639         -- Make these type and class decls available to stuff slurped from interface files
 640         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 641
 642
 643         setGblEnv tcg_env       $ do {
 644                 -- Source-language instances, including derivings,
 645                 -- and import the supporting declarations
 646         traceTc (text "Tc3") ;
 647         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 648         setGblEnv tcg_env       $ do {
 649
 650                 -- Foreign import declarations next.  No zonking necessary
 651                 -- here; we can tuck them straight into the global environment.
 652         traceTc (text "Tc4") ;
 653         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 654         tcExtendGlobalValEnv fi_ids     $ do {
 655
 656                 -- Default declarations
 657         traceTc (text "Tc4a") ;
 658         default_tys <- tcDefaults default_decls ;
 659         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 660
 661                 -- Value declarations next
 662                 -- We also typecheck any extra binds that came out
 663                 -- of the "deriving" process (deriv_binds)
 664         traceTc (text "Tc5") ;
 665         (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
 666         setLclTypeEnv tcl_env   $ do {
 667
 668                 -- Second pass over class and instance declarations,
 669         traceTc (text "Tc6") ;
 670         (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
 671         showLIE (text "after instDecls2") ;
 672
 673                 -- Foreign exports
 674                 -- They need to be zonked, so we return them
 675         traceTc (text "Tc7") ;
 676         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 677
 678                 -- Rules
 679         rules <- tcRules rule_decls ;
 680
 681                 -- Wrap up
 682         traceTc (text "Tc7a") ;
 683         tcg_env <- getGblEnv ;
 684         let { all_binds = tc_val_binds   `unionBags`
 685                           inst_binds     `unionBags`
 686                           foe_binds  ;
 687
 688                 -- Extend the GblEnv with the (as yet un-zonked)
 689                 -- bindings, rules, foreign decls
 690               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 691                                     tcg_rules = tcg_rules tcg_env ++ rules,
 692                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 693         return (tcg_env', tcl_env)
 694     }}}}}}
 695 \end{code}
 696
 697
 698 %************************************************************************
 699 %*                                                                      *
 700         Checking for 'main'
 701 %*                                                                      *
 702 %************************************************************************
 703
 704 \begin{code}
 705 checkMain :: TcM TcGblEnv
 706 -- If we are in module Main, check that 'main' is defined.
 707 checkMain
 708   = do { ghc_mode <- getGhcMode ;
 709          tcg_env   <- getGblEnv ;
 710          dflags    <- getDOpts ;
 711          let { main_mod = mainModIs dflags ;
 712                main_fn  = case mainFunIs dflags of {
 713                                 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
 714                                 Nothing -> main_RDR_Unqual } } ;
 715
 716          check_main ghc_mode tcg_env main_mod main_fn
 717     }
 718
 719
 720 check_main ghc_mode tcg_env main_mod main_fn
 721  | mod /= main_mod
 722  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
 723    return tcg_env
 724
 725  | otherwise
 726  = addErrCtxt mainCtxt                  $
 727    do   { mb_main <- lookupSrcOcc_maybe main_fn
 728                 -- Check that 'main' is in scope
 729                 -- It might be imported from another module!
 730         ; case mb_main of {
 731              Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
 732                            ; complain_no_main
 733                            ; return tcg_env } ;
 734              Just main_name -> do
 735         { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
 736         ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
 737                         -- :Main.main :: IO () = runMainIO main
 738
 739         ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 740                              tcInferRho rhs
 741
 742         -- The function that the RTS invokes is always :Main.main,
 743         -- which we call root_main_id.
 744         -- (Because GHC allows the user to have a module not called
 745         -- Main as the main module, we can't rely on the main function
 746         -- being called "Main.main".  That's why root_main_id has a fixed
 747         -- module ":Main".)
 748         -- We also make root_main_id an implicit Id, by making main_name
 749         -- its parent (hence (Just main_name)).  That has the effect
 750         -- of preventing its type and unfolding from getting out into
 751         -- the interface file. Otherwise we can end up with two defns
 752         -- for 'main' in the interface file!
 753
 754         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
 755                                    (mkVarOccFS FSLIT("main"))
 756                                    (Just main_name) (getSrcLoc main_name)
 757               ; root_main_id = mkExportedLocalId root_main_name ty
 758               ; main_bind    = noLoc (VarBind root_main_id main_expr) }
 759
 760         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 761                                         `snocBag` main_bind,
 762                             tcg_dus   = tcg_dus tcg_env
 763                                         `plusDU` usesOnly (unitFV main_name)
 764                         -- Record the use of 'main', so that we don't
 765                         -- complain about it being defined but not used
 766                  })
 767     }}}
 768   where
 769     mod = tcg_mod tcg_env
 770
 771     complain_no_main | ghc_mode == Interactive = return ()
 772                      | otherwise                = failWithTc noMainMsg
 773         -- In interactive mode, don't worry about the absence of 'main'
 774         -- In other modes, fail altogether, so that we don't go on
 775         -- and complain a second time when processing the export list.
 776
 777     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 778     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 779                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 780 \end{code}
 781
 782 %*********************************************************
 783 %*                                                       *
 784                 GHCi stuff
 785 %*                                                       *
 786 %*********************************************************
 787
 788 \begin{code}
 789 #ifdef GHCI
 790 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
 791 setInteractiveContext hsc_env icxt thing_inside
 792   = let
 793         -- Initialise the tcg_inst_env with instances
 794         -- from all home modules.  This mimics the more selective
 795         -- call to hptInstances in tcRnModule
 796         dfuns = hptInstances hsc_env (\mod -> True)
 797     in
 798     updGblEnv (\env -> env {
 799         tcg_rdr_env  = ic_rn_gbl_env icxt,
 800         tcg_type_env = ic_type_env   icxt,
 801         tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
 802
 803     updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt })  $
 804
 805     do  { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
 806         ; thing_inside }
 807 \end{code}
 808
 809
 810 \begin{code}
 811 tcRnStmt :: HscEnv
 812          -> InteractiveContext
 813          -> LStmt RdrName
 814          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 815                 -- The returned [Name] is the same as the input except for
 816                 -- ExprStmt, in which case the returned [Name] is [itName]
 817                 --
 818                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 819                 -- a list of the bound values, coerced to ().
 820
 821 tcRnStmt hsc_env ictxt rdr_stmt
 822   = initTcPrintErrors hsc_env iNTERACTIVE $
 823     setInteractiveContext hsc_env ictxt $ do {
 824
 825     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 826     (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
 827     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 828     failIfErrsM ;
 829
 830     -- The real work is done here
 831     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
 832     zonked_expr <- zonkTopLExpr tc_expr ;
 833     zonked_ids  <- zonkTopBndrs bound_ids ;
 834
 835         -- None of the Ids should be of unboxed type, because we
 836         -- cast them all to HValues in the end!
 837     mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 838
 839     traceTc (text "tcs 1") ;
 840     let {       -- (a) Make all the bound ids "global" ids, now that
 841                 --     they're notionally top-level bindings.  This is
 842                 --     important: otherwise when we come to compile an expression
 843                 --     using these ids later, the byte code generator will consider
 844                 --     the occurrences to be free rather than global.
 845                 --
 846                 -- (b) Tidy their types; this is important, because :info may
 847                 --     ask to look at them, and :info expects the things it looks
 848                 --     up to have tidy types
 849         global_ids = map globaliseAndTidy zonked_ids ;
 850
 851                 -- Update the interactive context
 852         rn_env   = ic_rn_local_env ictxt ;
 853         type_env = ic_type_env ictxt ;
 854
 855         bound_names = map idName global_ids ;
 856         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 857
 858                 -- Remove any shadowed bindings from the type_env;
 859                 -- they are inaccessible but might, I suppose, cause
 860                 -- a space leak if we leave them there
 861         shadowed = [ n | name <- bound_names,
 862                          let rdr_name = mkRdrUnqual (nameOccName name),
 863                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 864
 865         filtered_type_env = delListFromNameEnv type_env shadowed ;
 866         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 867
 868         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 869                          ic_type_env     = new_type_env }
 870     } ;
 871
 872     dumpOptTcRn Opt_D_dump_tc
 873         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 874                text "Typechecked expr" <+> ppr zonked_expr]) ;
 875
 876     returnM (new_ic, bound_names, zonked_expr)
 877     }
 878   where
 879     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
 880                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 881
 882 globaliseAndTidy :: Id -> Id
 883 globaliseAndTidy id
 884 -- Give the Id a Global Name, and tidy its type
 885   = setIdType (globaliseId VanillaGlobal id) tidy_type
 886   where
 887     tidy_type = tidyTopType (idType id)
 888 \end{code}
 889
 890 Here is the grand plan, implemented in tcUserStmt
 891
 892         What you type                   The IO [HValue] that hscStmt returns
 893         -------------                   ------------------------------------
 894         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 895                                         bindings: [x,y,...]
 896
 897         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 898                                         bindings: [x,y,...]
 899
 900         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
 901           [NB: result not printed]      bindings: [it]
 902
 903         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
 904           result showable)              bindings: [it]
 905
 906         expr (of non-IO type,
 907           result not showable)  ==>     error
 908
 909
 910 \begin{code}
 911 ---------------------------
 912 type PlanResult = ([Id], LHsExpr Id)
 913 type Plan = TcM PlanResult
 914
 915 runPlans :: [Plan] -> TcM PlanResult
 916 -- Try the plans in order.  If one fails (by raising an exn), try the next.
 917 -- If one succeeds, take it.
 918 runPlans []     = panic "runPlans"
 919 runPlans [p]    = p
 920 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
 921
 922 --------------------
 923 mkPlan :: LStmt Name -> TcM PlanResult
 924 mkPlan (L loc (ExprStmt expr _ _))      -- An expression typed at the prompt
 925   = do  { uniq <- newUnique             -- is treated very specially
 926         ; let fresh_it  = itName uniq
 927               the_bind  = L loc $ mkFunBind (L loc fresh_it) matches
 928               matches   = [mkMatch [] expr emptyLocalBinds]
 929               let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
 930               bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
 931                                            (HsVar bindIOName) noSyntaxExpr
 932               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
 933                                            (HsVar thenIOName) placeHolderType
 934
 935         -- The plans are:
 936         --      [it <- e; print it]     but not if it::()
 937         --      [it <- e]
 938         --      [let it = e; print it]
 939         ; runPlans [    -- Plan A
 940                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
 941                        ; it_ty <- zonkTcType (idType it_id)
 942                        ; ifM (isUnitTy it_ty) failM
 943                        ; return stuff },
 944
 945                         -- Plan B; a naked bind statment
 946                     tcGhciStmts [bind_stmt],
 947
 948                         -- Plan C; check that the let-binding is typeable all by itself.
 949                         -- If not, fail; if so, try to print it.
 950                         -- The two-step process avoids getting two errors: one from
 951                         -- the expression itself, and one from the 'print it' part
 952                         -- This two-step story is very clunky, alas
 953                     do { checkNoErrs (tcGhciStmts [let_stmt])
 954                                 --- checkNoErrs defeats the error recovery of let-bindings
 955                        ; tcGhciStmts [let_stmt, print_it] }
 956           ]}
 957
 958 mkPlan stmt@(L loc (BindStmt {}))
 959   | [L _ v] <- collectLStmtBinders stmt         -- One binder, for a bind stmt
 960   = do  { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
 961                                            (HsVar thenIOName) placeHolderType
 962         -- The plans are:
 963         --      [stmt; print v]         but not if v::()
 964         --      [stmt]
 965         ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
 966                        ; v_ty <- zonkTcType (idType v_id)
 967                        ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
 968                        ; return stuff },
 969                     tcGhciStmts [stmt]
 970           ]}
 971
 972 mkPlan stmt
 973   = tcGhciStmts [stmt]
 974
 975 ---------------------------
 976 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
 977 tcGhciStmts stmts
 978  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 979         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
 980         let {
 981             io_ty     = mkTyConApp ioTyCon [] ;
 982             ret_ty    = mkListTy unitTy ;
 983             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 984
 985             names = map unLoc (collectLStmtsBinders stmts) ;
 986
 987                 -- mk_return builds the expression
 988                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 989                 --
 990                 -- Despite the inconvenience of building the type applications etc,
 991                 -- this *has* to be done in type-annotated post-typecheck form
 992                 -- because we are going to return a list of *polymorphic* values
 993                 -- coerced to type (). If we built a *source* stmt
 994                 --      return [coerce x, ..., coerce z]
 995                 -- then the type checker would instantiate x..z, and we wouldn't
 996                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
 997                 -- if they were overloaded, since they aren't applied to anything.)
 998             mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
 999                                     (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1000             mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
1001                                  (nlHsVar id)
1002          } ;
1003
1004         -- OK, we're ready to typecheck the stmts
1005         traceTc (text "tcs 2") ;
1006         ((tc_stmts, ids), lie) <- getLIE $
1007                                   tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
1008                                   mappM tcLookupId names ;
1009                                         -- Look up the names right in the middle,
1010                                         -- where they will all be in scope
1011
1012         -- Simplify the context
1013         const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
1014                 -- checkNoErrs ensures that the plan fails if context redn fails
1015
1016         return (ids, mkHsDictLet const_binds $
1017                      noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
1018     }
1019 \end{code}
1020
1021
1022 tcRnExpr just finds the type of an expression
1023
1024 \begin{code}
1025 tcRnExpr :: HscEnv
1026          -> InteractiveContext
1027          -> LHsExpr RdrName
1028          -> IO (Maybe Type)
1029 tcRnExpr hsc_env ictxt rdr_expr
1030   = initTcPrintErrors hsc_env iNTERACTIVE $
1031     setInteractiveContext hsc_env ictxt $ do {
1032
1033     (rn_expr, fvs) <- rnLExpr rdr_expr ;
1034     failIfErrsM ;
1035
1036         -- Now typecheck the expression;
1037         -- it might have a rank-2 type (e.g. :t runST)
1038     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
1039     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
1040     tcSimplifyInteractive lie_top ;
1041     qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1042
1043     let { all_expr_ty = mkForAllTys qtvs' $
1044                         mkFunTys (map idType dict_ids)  $
1045                         res_ty } ;
1046     zonkTcType all_expr_ty
1047     }
1048   where
1049     smpl_doc = ptext SLIT("main expression")
1050 \end{code}
1051
1052 tcRnType just finds the kind of a type
1053
1054 \begin{code}
1055 tcRnType :: HscEnv
1056          -> InteractiveContext
1057          -> LHsType RdrName
1058          -> IO (Maybe Kind)
1059 tcRnType hsc_env ictxt rdr_type
1060   = initTcPrintErrors hsc_env iNTERACTIVE $
1061     setInteractiveContext hsc_env ictxt $ do {
1062
1063     rn_type <- rnLHsType doc rdr_type ;
1064     failIfErrsM ;
1065
1066         -- Now kind-check the type
1067     (ty', kind) <- kcHsType rn_type ;
1068     return kind
1069     }
1070   where
1071     doc = ptext SLIT("In GHCi input")
1072
1073 #endif /* GHCi */
1074 \end{code}
1075
1076
1077 %************************************************************************
1078 %*                                                                      *
1079         More GHCi stuff, to do with browsing and getting info
1080 %*                                                                      *
1081 %************************************************************************
1082
1083 \begin{code}
1084 #ifdef GHCI
1085 -- ASSUMES that the module is either in the HomePackageTable or is
1086 -- a package module with an interface on disk.  If neither of these is
1087 -- true, then the result will be an error indicating the interface
1088 -- could not be found.
1089 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
1090 getModuleExports hsc_env mod
1091   = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
1092
1093 tcGetModuleExports :: Module -> TcM NameSet
1094 tcGetModuleExports mod = do
1095   let doc = ptext SLIT("context for compiling statements")
1096   iface <- initIfaceTcRn $ loadSysInterface doc mod
1097   loadOrphanModules (dep_orphs (mi_deps iface))
1098                 -- Load any orphan-module interfaces,
1099                 -- so their instances are visible
1100   ifaceExportNames (mi_exports iface)
1101
1102 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
1103 tcRnLookupRdrName hsc_env rdr_name
1104   = initTcPrintErrors hsc_env iNTERACTIVE $
1105     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1106     lookup_rdr_name rdr_name
1107
1108 lookup_rdr_name rdr_name = do {
1109         -- If the identifier is a constructor (begins with an
1110         -- upper-case letter), then we need to consider both
1111         -- constructor and type class identifiers.
1112     let { rdr_names = dataTcOccs rdr_name } ;
1113
1114         -- results :: [Either Messages Name]
1115     results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
1116
1117     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1118         -- The successful lookups will be (Just name)
1119     let { (warns_s, good_names) = unzip [ (msgs, name)
1120                                         | (msgs, Just name) <- results] ;
1121           errs_s = [msgs | (msgs, Nothing) <- results] } ;
1122
1123         -- Fail if nothing good happened, else add warnings
1124     if null good_names then
1125                 -- No lookup succeeded, so
1126                 -- pick the first error message and report it
1127                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1128                 --       while the other is "X is not in scope",
1129                 --       we definitely want the former; but we might pick the latter
1130         do { addMessages (head errs_s) ; failM }
1131       else                      -- Add deprecation warnings
1132         mapM_ addMessages warns_s ;
1133
1134     return good_names
1135  }
1136
1137
1138 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
1139 tcRnLookupName hsc_env name
1140   = initTcPrintErrors hsc_env iNTERACTIVE $
1141     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1142     tcLookupGlobal name
1143
1144
1145 tcRnGetInfo :: HscEnv
1146             -> Name
1147             -> IO (Maybe (TyThing, Fixity, [Instance]))
1148
1149 -- Used to implemnent :info in GHCi
1150 --
1151 -- Look up a RdrName and return all the TyThings it might be
1152 -- A capitalised RdrName is given to us in the DataName namespace,
1153 -- but we want to treat it as *both* a data constructor
1154 --  *and* as a type or class constructor;
1155 -- hence the call to dataTcOccs, and we return up to two results
1156 tcRnGetInfo hsc_env name
1157   = initTcPrintErrors hsc_env iNTERACTIVE $
1158     let ictxt = hsc_IC hsc_env in
1159     setInteractiveContext hsc_env ictxt $ do
1160
1161         -- Load the interface for all unqualified types and classes
1162         -- That way we will find all the instance declarations
1163         -- (Packages have not orphan modules, and we assume that
1164         --  in the home package all relevant modules are loaded.)
1165     loadUnqualIfaces ictxt
1166
1167     thing  <- tcLookupGlobal name
1168     fixity <- lookupFixityRn name
1169     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
1170     return (thing, fixity, ispecs)
1171
1172
1173 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
1174 -- Filter the instances by the ones whose tycons (or clases resp)
1175 -- are in scope unqualified.  Otherwise we list a whole lot too many!
1176 lookupInsts print_unqual (AClass cls)
1177   = do  { inst_envs <- tcGetInstEnvs
1178         ; return [ ispec
1179                  | ispec <- classInstances inst_envs cls
1180                  , plausibleDFun print_unqual (instanceDFunId ispec) ] }
1181
1182 lookupInsts print_unqual (ATyCon tc)
1183   = do  { eps <- getEps -- Load all instances for all classes that are
1184                         -- in the type environment (which are all the ones
1185                         -- we've seen in any interface file so far)
1186         ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
1187         ; return [ ispec
1188                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1189                  , let dfun = instanceDFunId ispec
1190                  , relevant dfun
1191                  , plausibleDFun print_unqual dfun ] }
1192   where
1193     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1194     tc_name     = tyConName tc
1195
1196 lookupInsts print_unqual other = return []
1197
1198 plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
1199   = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
1200   where
1201     ok name | isBuiltInSyntax name = True
1202             | isExternalName name  =
1203                 isNothing $ fst print_unqual (nameModule name)
1204                                              (nameOccName name)
1205             | otherwise            = True
1206
1207 loadUnqualIfaces :: InteractiveContext -> TcM ()
1208 -- Load the home module for everything that is in scope unqualified
1209 -- This is so that we can accurately report the instances for
1210 -- something
1211 loadUnqualIfaces ictxt
1212   = initIfaceTcRn $
1213     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1214   where
1215     unqual_mods = [ nameModule name
1216                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1217                     let name = gre_name gre,
1218                     not (isInternalName name),
1219                     isTcOcc (nameOccName name),  -- Types and classes only
1220                     unQualOK gre ]               -- In scope unqualified
1221     doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
1222 #endif /* GHCI */
1223 \end{code}
1224
1225 %************************************************************************
1226 %*                                                                      *
1227                 Degugging output
1228 %*                                                                      *
1229 %************************************************************************
1230
1231 \begin{code}
1232 rnDump :: SDoc -> TcRn ()
1233 -- Dump, with a banner, if -ddump-rn
1234 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1235
1236 tcDump :: TcGblEnv -> TcRn ()
1237 tcDump env
1238  = do { dflags <- getDOpts ;
1239
1240         -- Dump short output if -ddump-types or -ddump-tc
1241         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1242             (dumpTcRn short_dump) ;
1243
1244         -- Dump bindings if -ddump-tc
1245         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1246    }
1247   where
1248     short_dump = pprTcGblEnv env
1249     full_dump  = pprLHsBinds (tcg_binds env)
1250         -- NB: foreign x-d's have undefined's in their types;
1251         --     hence can't show the tc_fords
1252
1253 tcCoreDump mod_guts
1254  = do { dflags <- getDOpts ;
1255         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1256             (dumpTcRn (pprModGuts mod_guts)) ;
1257
1258         -- Dump bindings if -ddump-tc
1259         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1260   where
1261     full_dump = pprCoreBindings (mg_binds mod_guts)
1262
1263 -- It's unpleasant having both pprModGuts and pprModDetails here
1264 pprTcGblEnv :: TcGblEnv -> SDoc
1265 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1266                         tcg_insts    = dfun_ids,
1267                         tcg_rules    = rules,
1268                         tcg_imports  = imports })
1269   = vcat [ ppr_types dfun_ids type_env
1270          , ppr_insts dfun_ids
1271          , vcat (map ppr rules)
1272          , ppr_gen_tycons (typeEnvTyCons type_env)
1273          , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
1274          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1275
1276 pprModGuts :: ModGuts -> SDoc
1277 pprModGuts (ModGuts { mg_types = type_env,
1278                       mg_rules = rules })
1279   = vcat [ ppr_types [] type_env,
1280            ppr_rules rules ]
1281
1282
1283 ppr_types :: [Instance] -> TypeEnv -> SDoc
1284 ppr_types ispecs type_env
1285   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1286   where
1287     dfun_ids = map instanceDFunId ispecs
1288     ids = [id | id <- typeEnvIds type_env, want_sig id]
1289     want_sig id | opt_PprStyle_Debug = True
1290                 | otherwise          = isLocalId id &&
1291                                        isExternalName (idName id) &&
1292                                        not (id `elem` dfun_ids)
1293         -- isLocalId ignores data constructors, records selectors etc.
1294         -- The isExternalName ignores local dictionary and method bindings
1295         -- that the type checker has invented.  Top-level user-defined things
1296         -- have External names.
1297
1298 ppr_insts :: [Instance] -> SDoc
1299 ppr_insts []     = empty
1300 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1301
1302 ppr_sigs :: [Var] -> SDoc
1303 ppr_sigs ids
1304         -- Print type signatures; sort by OccName
1305   = vcat (map ppr_sig (sortLe le_sig ids))
1306   where
1307     le_sig id1 id2 = getOccName id1 <= getOccName id2
1308     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1309
1310 ppr_rules :: [CoreRule] -> SDoc
1311 ppr_rules [] = empty
1312 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1313                       nest 4 (pprRules rs),
1314                       ptext SLIT("#-}")]
1315
1316 ppr_gen_tycons []  = empty
1317 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1318                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1319 \end{code}