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