compiler/typecheck/TcRnDriver.lhs

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