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