compiler/typecheck/TcRnDriver.lhs

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