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