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