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