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