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