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