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