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