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