%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnExtCore
) where
-#include "HsVersions.h"
-
import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
-import StaticFlags ( opt_PprStyle_Debug )
-import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
- SpliceDecl(..), HsBind(..), LHsBinds,
- emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
- nlHsApp, nlHsVar, pprLHsBinds )
-import RdrHsSyn ( findSplice )
-
-import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
- main_RDR_Unqual )
-import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
-import TcHsSyn ( zonkTopDecls )
-import TcExpr ( tcInferRho )
+import DynFlags
+import StaticFlags
+import HsSyn
+import RdrHsSyn
+import PrelNames
+import RdrName
+import TcHsSyn
+import TcExpr
import TcRnMonad
-import TcType ( tidyTopType, tcEqType )
-import Inst ( showLIE )
-import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
-import TcBinds ( tcTopBinds, tcHsBootSigs )
-import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv, iDFunId )
-import TcRules ( tcRules )
-import TcForeign ( tcForeignImports, tcForeignExports )
-import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings, tcHiBootIface )
-import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) )
-import TcSimplify ( tcSimplifyTop )
-import TcTyClsDecls ( tcTyAndClassDecls )
-import LoadIface ( loadOrphanModules )
-import RnNames ( importsFromLocalDecls, rnImports, rnExports,
- mkRdrEnvAndImports, mkExportNameSet,
- reportUnusedNames, reportDeprecations )
-import RnEnv ( lookupSrcOcc_maybe )
-import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
-import PprCore ( pprRules, pprCoreBindings )
-import CoreSyn ( CoreRule, bindersOfBinds )
-import ErrUtils ( Messages, mkDumpDoc, showPass )
-import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
-import Var ( Var )
+import TcType
+import Inst
+import FamInst
+import InstEnv
+import FamInstEnv
+import TcAnnotations
+import TcBinds
+import TcDefaults
+import TcEnv
+import TcRules
+import TcForeign
+import TcInstDcls
+import TcIface
+import MkIface
+import IfaceSyn
+import TcSimplify
+import TcTyClsDecls
+import TcUnify ( withBox )
+import LoadIface
+import RnNames
+import RnEnv
+import RnSource
+import RnHsDoc
+import PprCore
+import CoreSyn
+import ErrUtils
+import Id
+import VarEnv
+import Var
import Module
-import UniqFM ( elemUFM, eltsUFM )
-import OccName ( mkVarOccFS, plusOccEnv )
-import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
- nameModule, nameOccName, isImplicitName, mkExternalName )
+import LazyUniqFM
+import Name
+import NameEnv
import NameSet
-import TyCon ( tyConHasGenerics )
-import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import DriverPhases ( HscSource(..), isHsBoot )
-import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
- HscEnv(..), ExternalPackageState(..),
- IsBootInterface, noDependencies,
- Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs),
- TypeEnv, lookupTypeEnv, hptInstances,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
- emptyFixityEnv
- )
+import TyCon
+import TysWiredIn
+import SrcLoc
+import HscTypes
+import ListSetOps
import Outputable
+import DataCon
+import Type
+import Class
+import Data.List ( sortBy )
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
- HsLocalBinds(..), HsValBinds(..),
- LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
- collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- mkFunBind, placeHolderType, noSyntaxExpr )
-import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
- unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
-import RnSource ( addTcgDUs )
-import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs )
-import TcHsType ( kcHsType )
-import TcMType ( zonkTcType, zonkQuantifiedTyVar )
-import TcMatches ( tcStmts, tcDoStmt )
-import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
- isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
-import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
-import TypeRep ( TyThing(..) )
-import RnTypes ( rnLHsType )
-import Inst ( tcGetInstEnvs )
-import InstEnv ( classInstances, instEnvElts )
-import RnExpr ( rnStmts, rnLExpr )
-import LoadIface ( loadSysInterface )
-import IfaceEnv ( ifaceExportNames )
-import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( setIdType )
-import MkId ( unsafeCoerceId )
-import TyCon ( tyConName )
-import TysWiredIn ( mkListTy, unitTy )
-import IdInfo ( GlobalIdDetails(..) )
-import Kind ( Kind )
-import Var ( globaliseId )
-import Name ( isBuiltInSyntax, isInternalName )
-import OccName ( isTcOcc )
-import NameEnv ( delListFromNameEnv )
-import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
- bindIOName, thenIOName, returnIOName )
-import HscTypes ( InteractiveContext(..),
- ModIface(..), icPrintUnqual,
- Dependencies(..) )
-import BasicTypes ( Fixity, RecFlag(..) )
-import SrcLoc ( unLoc )
-import Data.Maybe ( isNothing )
+import Linker
+import TcHsType
+import TcMType
+import TcMatches
+import RnTypes
+import RnExpr
+import IfaceEnv
+import MkId
+import IdInfo
+import {- Kind parts of -} Type
+import BasicTypes
+import Foreign.Ptr( Ptr )
+import TidyPgm ( globaliseAndTidyId )
#endif
-import FastString ( mkFastString )
-import Util ( sortLe )
-import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+import FastString
+import Maybes
+import Util
+import Bag
+import Control.Monad
import Data.Maybe ( isJust )
+
+#include "HsVersions.h"
\end{code}
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
- import_decls local_decls mod_deprec))
+ import_decls local_decls mod_deprec
+ module_info maybe_doc))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
Just (L _ mod) -> mkModule this_pkg mod } ;
-- The normal case
- initTc hsc_env hsc_src this_mod $
+ initTc hsc_env hsc_src save_rn_syntax this_mod $
setSrcSpan loc $
- do {
- -- Deal with imports;
- rn_imports <- rnImports import_decls ;
- (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
-
- let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
- ; dep_mods = imp_dep_mods imports
-
- -- We want instance declarations from all home-package
- -- modules below this one, including boot modules, except
- -- ourselves. The 'except ourselves' is so that we don't
- -- get the instances from this module's hs-boot file
- ; want_instances :: ModuleName -> Bool
- ; want_instances mod = mod `elemUFM` dep_mods
- && mod /= moduleName this_mod
- ; home_insts = hptInstances hsc_env want_instances
- } ;
-
- -- Record boot-file info in the EPS, so that it's
- -- visible to loadHiBootInterface in tcRnSrcDecls,
- -- and any other incrementally-performed imports
- updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
-
- -- Update the gbl env
- updGblEnv ( \ gbl ->
- gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
- tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
- tcg_imports = tcg_imports gbl `plusImportAvails` imports,
- tcg_rn_imports = if save_rn_syntax then
- Just rn_imports
- else
- Nothing,
- tcg_rn_decls = if save_rn_syntax then
- Just emptyRnGroup
- else
- Nothing })
- $ do {
-
- traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
- -- Fail if there are any errors so far
- -- The error printing (if needed) takes advantage
- -- of the tcg_env we have now set
- failIfErrsM ;
+ do { -- Deal with imports;
+ tcg_env <- tcRnImports hsc_env this_mod import_decls ;
+ setGblEnv tcg_env $ do {
- -- Load any orphan-module interfaces, so that
- -- their rules and instance decls will be found
- loadOrphanModules (imp_orphs imports) ;
+ -- Load the hi-boot interface for this module, if any
+ -- We do this now so that the boot_names can be passed
+ -- to tcTyAndClassDecls, because the boot_names are
+ -- automatically considered to be loop breakers
+ --
+ -- Do this *after* tcRnImports, so that we know whether
+ -- a module that we import imports us; and hence whether to
+ -- look for a hi-boot file
+ boot_iface <- tcHiBootIface hsc_src this_mod ;
- traceRn (text "rn1a") ;
-- Rename and type check the declarations
+ traceRn (text "rn1a") ;
tcg_env <- if isHsBoot hsc_src then
tcRnHsBootDecls local_decls
else
- tcRnSrcDecls local_decls ;
+ tcRnSrcDecls boot_iface local_decls ;
setGblEnv tcg_env $ do {
- traceRn (text "rn3") ;
-
-- Report the use of any deprecated things
- -- We do this before processsing the export list so
+ -- We do this *before* processsing the export list so
-- that we don't bleat about re-exporting a deprecated
-- thing (especially via 'module Foo' export item)
- -- Only uses in the body of the module are complained about
- reportDeprecations (hsc_dflags hsc_env) tcg_env ;
+ -- That is, only uses in the *body* of the module are complained about
+ traceRn (text "rn3") ;
+ failIfErrsM ; -- finishWarnings crashes sometimes
+ -- as a result of typechecker repairs (e.g. unboundNames)
+ tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
-- Process the export list
- rn_exports <- rnExports export_ies ;
- let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
- exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
-
- -- Check whether the entire module is deprecated
- -- This happens only once per module
- let { mod_deprecs = checkModDeprec mod_deprec } ;
-
- -- Add exports and deprecations to envt
- let { final_env = tcg_env { tcg_exports = exports,
- tcg_rn_exports = if save_rn_syntax then
- rn_exports
- else Nothing,
- tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
- tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
- mod_deprecs }
- -- A module deprecation over-rides the earlier ones
- } ;
+ traceRn (text "rn4a: before exports");
+ tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
+ traceRn (text "rn4b: after exportss") ;
+
+ -- Compare the hi-boot iface (if any) with the real thing
+ -- Must be done after processing the exports
+ tcg_env <- checkHiBootIface tcg_env boot_iface ;
+
+ -- The new type env is already available to stuff slurped from
+ -- interface files, via TcEnv.updateGlobalTypeEnv
+ -- It's important that this includes the stuff in checkHiBootIface,
+ -- because the latter might add new bindings for boot_dfuns,
+ -- which may be mentioned in imported unfoldings
+
+ -- Rename the Haddock documentation
+ tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
-- Report unused names
- reportUnusedNames export_ies final_env ;
+ reportUnusedNames export_ies tcg_env ;
-- Dump output and return
- tcDump final_env ;
- return final_env
+ tcDump tcg_env ;
+ return tcg_env
}}}}
\end{code}
%************************************************************************
%* *
+ Import declarations
+%* *
+%************************************************************************
+
+\begin{code}
+tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
+tcRnImports hsc_env this_mod import_decls
+ = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
+
+ ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports
+
+ -- We want instance declarations from all home-package
+ -- modules below this one, including boot modules, except
+ -- ourselves. The 'except ourselves' is so that we don't
+ -- get the instances from this module's hs-boot file
+ ; want_instances :: ModuleName -> Bool
+ ; want_instances mod = mod `elemUFM` dep_mods
+ && mod /= moduleName this_mod
+ ; (home_insts, home_fam_insts) = hptInstances hsc_env
+ want_instances
+ } ;
+
+ -- Record boot-file info in the EPS, so that it's
+ -- visible to loadHiBootInterface in tcRnSrcDecls,
+ -- and any other incrementally-performed imports
+ ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
+
+ -- Update the gbl env
+ ; updGblEnv ( \ gbl ->
+ gbl {
+ tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
+ tcg_imports = tcg_imports gbl `plusImportAvails` imports,
+ tcg_rn_imports = rn_imports,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
+ tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
+ home_fam_insts,
+ tcg_hpc = hpc_info
+ }) $ do {
+
+ ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
+ -- Fail if there are any errors so far
+ -- The error printing (if needed) takes advantage
+ -- of the tcg_env we have now set
+-- ; traceIf (text "rdr_env: " <+> ppr rdr_env)
+ ; failIfErrsM
+
+ -- Load any orphan-module and family instance-module
+ -- interfaces, so that their rules and instance decls will be
+ -- found.
+ ; loadOrphanModules (imp_orphs imports) False
+ ; loadOrphanModules (imp_finsts imports) True
+
+ -- Check type-familily consistency
+ ; traceRn (text "rn1: checking family instance consistency")
+ ; let { dir_imp_mods = moduleEnvKeys
+ . imp_mods
+ $ imports }
+ ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
+
+ ; getGblEnv } }
+\end{code}
+
+
+%************************************************************************
+%* *
Type-checking external-core modules
%* *
%************************************************************************
-- The decls are IfaceDecls; all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- initTc hsc_env ExtCoreFile this_mod $ do {
+ initTc hsc_env ExtCoreFile False this_mod $ do {
let { ldecls = map noLoc decls } ;
- -- Deal with the type declarations; first bring their stuff
- -- into scope, then rname them, then type check them
- tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+ -- bring the type and class decls into scope
+ -- ToDo: check that this doesn't need to extract the val binds.
+ -- It seems that only the type and class decls need to be in scope below because
+ -- (a) tcTyAndClassDecls doesn't need the val binds, and
+ -- (b) tcExtCoreBindings doesn't need anything
+ -- (in fact, it might not even need to be in the scope of
+ -- this tcg_env at all)
+ avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
+ tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ;
- setGblEnv tcg_env $ do {
+ setEnvs tc_envs $ do {
- rn_decls <- rnTyClDecls ldecls ;
- failIfErrsM ;
+ rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
- -- Make the new type env available to stuff slurped from interface files
+ -- Just discard the auxiliary bindings; they are generated
+ -- only for Haskell source code, and should already be in Core
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
+ -- Make the new type env available to stuff slurped from interface files
-- Now the core bindings
core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
-- Wrap up
let {
bndrs = bindersOfBinds core_binds ;
- my_exports = mkNameSet (map idName bndrs) ;
+ my_exports = map (Avail . idName) bndrs ;
-- ToDo: export the data types also?
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
-
- mod_guts = ModGuts { mg_module = this_mod,
- mg_boot = False,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
+ final_type_env =
+ extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
+ mg_used_names = emptyNameSet, -- ToDo: compute usage
+ mg_dir_imps = emptyModuleEnv, -- ??
+ mg_deps = noDependencies, -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_inst_env = tcg_inst_env tcg_env,
+ mg_fam_inst_env = tcg_fam_inst_env tcg_env,
+ mg_rules = [],
+ mg_binds = core_binds,
-- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_warns = NoWarnings,
+ mg_foreign = NoStubs,
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo
} } ;
tcCoreDump mod_guts ;
%************************************************************************
\begin{code}
-tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
+tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
-tcRnSrcDecls decls
- = do { -- Load the hi-boot interface for this module, if any
- -- We do this now so that the boot_names can be passed
- -- to tcTyAndClassDecls, because the boot_names are
- -- automatically considered to be loop breakers
- mod <- getModule ;
- boot_iface <- tcHiBootIface mod ;
-
- -- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
+tcRnSrcDecls boot_iface decls
+ = do { -- Do all the declarations
+ (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+ -- Finish simplifying class constraints
+ --
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
+ -- top-level decl falls under the monomorphism restriction
+ -- and no subsequent decl instantiates its type.
+ --
+ -- We do this after checkMain, so that we use the type info
+ -- thaat checkMain adds
+ --
+ -- We do it with both global and local env in scope:
+ -- * the global env exposes the instances to tcSimplifyTop
+ -- * the local env exposes the local Ids to tcSimplifyTop,
+ -- so that we get better error messages (monomorphism restriction)
traceTc (text "Tc8") ;
inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
- -- Setting the global env exposes the instances to tcSimplifyTop
- -- Setting the local env exposes the local Ids to tcSimplifyTop,
- -- so that we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
- let { (tcg_env, _) = tc_envs ;
- TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ let { (tcg_env, _) = tc_envs
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_rules = rules,
+ tcg_fords = fords } = tcg_env
+ ; all_binds = binds `unionBags` inst_binds } ;
- tcDump tcg_env ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ failIfErrsM ; -- Don't zonk if there have been errors
+ -- It's a waste of time; and we may get debug warnings
+ -- about strangely-typed TyCons!
+
+ (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
+
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
- ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds',
+ ; tcg_env' = tcg_env { tcg_binds = binds',
tcg_rules = rules',
tcg_fords = fords' } } ;
- -- Make the new type env available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
-
- -- Compare the hi-boot iface (if any) with the real thing
- dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
-
- return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
+ setGlobalTypeEnv tcg_env' final_type_env
}
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
- -- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-
- -- Bale out if errors; for example, error recovery when checking
- -- the RHS of 'main' can mean that 'main' is not in the envt for
- -- the subsequent checkMain test
- failIfErrsM ;
+ -- Deal with decls up to, but not including, the first splice
+ (tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
+ -- rnTopSrcDecls fails if there are any errors
- setEnvs tc_envs $
+ (tcg_env, tcl_env) <- setGblEnv tcg_env $
+ tcTopSrcDecls boot_details rn_decls ;
-- If there is no splice, we're nearly done
+ setEnvs (tcg_env, tcl_env) $
case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
+ Nothing -> do { tcg_env <- checkMain ; -- Check for `main'
return (tcg_env, tcl_env)
} ;
#else
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
- failIfErrsM ; -- Don't typecheck if renaming failed
+ (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
+ -- checkNoErrs: don't typecheck if renaming failed
rnDump (ppr rn_splice_expr) ;
-- Execute the splice
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
- }}}
+ } } }
\end{code}
%************************************************************************
Nothing -> return ()
-- Rename the declarations
- ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; (tcg_env, HsGroup {
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fords = _,
+ hs_defds = _, -- Todo: check no foreign decls, no rules,
+ hs_ruleds = _, -- no default decls and no annotation decls
+ hs_annds = _,
+ hs_valds = val_binds }) <- rnTopSrcDecls first_group
; setGblEnv tcg_env $ do {
- -- Todo: check no foreign decls, no rules, no default decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
- ; let tycl_decls = hs_tyclds rn_group
- ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
+ ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
; traceTc (text "Tc3")
- ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; (tcg_env, inst_infos, _deriv_binds)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; traceTc (text "Tc5")
- ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+ ; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
; gbl_env <- getGblEnv
-- Make the final type-env
- -- Include the dfun_ids so that their type sigs get
- -- are written into the interface file
+ -- Include the dfun_ids so that their type sigs
+ -- are written into the interface file.
+ -- And similarly the aux_ids from aux_binds
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
- ; dfun_ids = map iDFunId inst_infos }
- ; return (gbl_env { tcg_type_env = type_env2 })
+ ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids
+ ; dfun_ids = map iDFunId inst_infos
+ ; aux_ids = case aux_binds of
+ ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
+ _ -> panic "tcRnHsBoodDecls"
+ }
+
+ ; setGlobalTypeEnv gbl_env type_env2
}}}}
spliceInHsBootErr (SpliceDecl (L loc _), _)
- = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
+ = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files"))
\end{code}
Once we've typechecked the body of the module, we want to compare what
we've found (gathered in a TypeEnv) with the hi-boot details (if any).
\begin{code}
-checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
+checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
-- In the common case where there is no hi-boot file, the list
-- hs-boot file, such as $fbEqT = $fEqT
checkHiBootIface
- (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
- (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
- = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
- ; mapM_ check_one (typeEnvElts boot_type_env)
- ; dfun_binds <- mapM check_inst boot_insts
- ; return (unionManyBags dfun_binds) }
+ tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
+ tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
+ tcg_type_env = local_type_env, tcg_exports = local_exports })
+ (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
+ md_types = boot_type_env, md_exports = boot_exports })
+ | isHsBoot hs_src -- Current module is already a hs-boot file!
+ = return tcg_env
+
+ | otherwise
+ = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$
+ ppr boot_exports)) ;
+
+ -- Check the exports of the boot module, one by one
+ ; mapM_ check_export boot_exports
+
+ -- Check for no family instances
+ ; unless (null boot_fam_insts) $
+ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
+ "instances in boot files yet...")
+ -- FIXME: Why? The actual comparison is not hard, but what would
+ -- be the equivalent to the dfun bindings returned for class
+ -- instances? We can't easily equate tycons...
+
+ -- Check instance declarations
+ ; mb_dfun_prs <- mapM check_inst boot_insts
+ ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+ final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
+ dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+
+ ; failIfErrsM
+ ; setGlobalTypeEnv tcg_env' final_type_env }
where
- check_one boot_thing
- | no_check name
- = return ()
- | Just real_thing <- lookupTypeEnv local_type_env name
- = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing
- real_decl = tyThingToIfaceDecl ext_nm real_thing
- ; checkTc (checkBootDecl boot_decl real_decl)
- (bootMisMatch boot_thing boot_decl real_decl) }
- -- The easiest way to check compatibility is to convert to
- -- iface syntax, where we already have good comparison functions
+ check_export boot_avail -- boot_avail is exported by the boot iface
+ | name `elem` dfun_names = return ()
+ | isWiredInName name = return () -- No checking for wired-in names. In particular,
+ -- 'error' is handled by a rather gross hack
+ -- (see comments in GHC.Err.hs-boot)
+
+ -- Check that the actual module exports the same thing
+ | not (null missing_names)
+ = addErrAt (nameSrcSpan (head missing_names))
+ (missingBootThing (head missing_names) "exported by")
+
+ -- If the boot module does not *define* the thing, we are done
+ -- (it simply re-exports it, and names match, so nothing further to do)
+ | isNothing mb_boot_thing = return ()
+
+ -- Check that the actual module also defines the thing, and
+ -- then compare the definitions
+ | Just real_thing <- lookupTypeEnv local_type_env name,
+ Just boot_thing <- mb_boot_thing
+ = when (not (checkBootDecl boot_thing real_thing))
+ $ addErrAt (nameSrcSpan (getName boot_thing))
+ (let boot_decl = tyThingToIfaceDecl
+ (fromJust mb_boot_thing)
+ real_decl = tyThingToIfaceDecl real_thing
+ in bootMisMatch real_thing boot_decl real_decl)
+
| otherwise
- = addErrTc (missingBootThing boot_thing)
+ = addErrTc (missingBootThing name "defined in")
where
- name = getName boot_thing
-
- ext_nm name = ExtPkg (nameModule name) (nameOccName name)
- -- Just enough to compare; no versions etc needed
-
- no_check name = isWiredInName name -- No checking for wired-in names. In particular,
- -- 'error' is handled by a rather gross hack
- -- (see comments in GHC.Err.hs-boot)
- || name `elem` dfun_names
- || isImplicitName name -- Has a parent, which we'll check
-
+ name = availName boot_avail
+ mb_boot_thing = lookupTypeEnv boot_type_env name
+ missing_names = case lookupNameEnv local_export_env name of
+ Nothing -> [name]
+ Just avail -> availNames boot_avail `minusList` availNames avail
+
dfun_names = map getName boot_insts
+ local_export_env :: NameEnv AvailInfo
+ local_export_env = availsToNameEnv local_exports
+
+ check_inst :: Instance -> TcM (Maybe (Id, Id))
+ -- Returns a pair of the boot dfun in terms of the equivalent real dfun
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
- [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
- (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
+ [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+ (dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
- local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
+ local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
+
+
+-- This has to compare the TyThing from the .hi-boot file to the TyThing
+-- in the current source file. We must be careful to allow alpha-renaming
+-- where appropriate, and also the boot declaration is allowed to omit
+-- constructors and class methods.
+--
+-- See rnfail055 for a good test of this stuff.
+
+checkBootDecl :: TyThing -> TyThing -> Bool
+
+checkBootDecl (AnId id1) (AnId id2)
+ = ASSERT(id1 == id2)
+ (idType id1 `tcEqType` idType id2)
+
+checkBootDecl (ATyCon tc1) (ATyCon tc2)
+ | isSynTyCon tc1 && isSynTyCon tc2
+ = ASSERT(tc1 == tc2)
+ let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
+ env = rnBndrs2 env0 tvs1 tvs2
+
+ eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _)
+ = tcEqTypeX env k1 k2
+ eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
+ = tcEqTypeX env t1 t2
+ in
+ equalLength tvs1 tvs2 &&
+ eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
+
+ | isAlgTyCon tc1 && isAlgTyCon tc2
+ = ASSERT(tc1 == tc2)
+ eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2)
+ && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+
+ | isForeignTyCon tc1 && isForeignTyCon tc2
+ = tyConExtName tc1 == tyConExtName tc2
+ where
+ env0 = mkRnEnv2 emptyInScopeSet
+
+ eqAlgRhs AbstractTyCon _ = True
+ eqAlgRhs OpenTyCon{} OpenTyCon{} = True
+ eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
+ eqListBy eqCon (data_cons tc1) (data_cons tc2)
+ eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+ eqCon (data_con tc1) (data_con tc2)
+ eqAlgRhs _ _ = False
+
+ eqCon c1 c2
+ = dataConName c1 == dataConName c2
+ && dataConIsInfix c1 == dataConIsInfix c2
+ && dataConStrictMarks c1 == dataConStrictMarks c2
+ && dataConFieldLabels c1 == dataConFieldLabels c2
+ && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
+ tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
+ env = rnBndrs2 env0 tvs1 tvs2
+ in
+ equalLength tvs1 tvs2 &&
+ eqListBy (tcEqPredX env)
+ (dataConEqTheta c1 ++ dataConDictTheta c1)
+ (dataConEqTheta c2 ++ dataConDictTheta c2) &&
+ eqListBy (tcEqTypeX env)
+ (dataConOrigArgTys c1)
+ (dataConOrigArgTys c2)
+
+checkBootDecl (AClass c1) (AClass c2)
+ = let
+ (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1)
+ = classExtraBigSig c1
+ (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2)
+ = classExtraBigSig c2
+
+ env0 = mkRnEnv2 emptyInScopeSet
+ env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
+
+ eqSig (id1, def_meth1) (id2, def_meth2)
+ = idName id1 == idName id2 &&
+ tcEqTypeX env op_ty1 op_ty2
+ where
+ (_, rho_ty1) = splitForAllTys (idType id1)
+ op_ty1 = funResultTy rho_ty1
+ (_, rho_ty2) = splitForAllTys (idType id2)
+ op_ty2 = funResultTy rho_ty2
+
+ eqFD (as1,bs1) (as2,bs2) =
+ eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+ eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+ in
+ equalLength clas_tyvars1 clas_tyvars2 &&
+ eqListBy eqFD clas_fds1 clas_fds2 &&
+ (null sc_theta1 && null op_stuff1
+ ||
+ eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+ eqListBy eqSig op_stuff1 op_stuff2)
+
+checkBootDecl (ADataCon dc1) (ADataCon dc2)
+ = pprPanic "checkBootDecl" (ppr dc1)
+
+checkBootDecl _ _ = False -- probably shouldn't happen
----------------
-missingBootThing thing
- = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
+missingBootThing thing what
+ = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not")
+ <+> text what <+> ptext (sLit "the module")
+
bootMisMatch thing boot_decl real_decl
- = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+ = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
+ ptext (sLit "Main module:") <+> ppr real_decl,
+ ptext (sLit "Boot file: ") <+> ppr boot_decl]
+
instMisMatch inst
= hang (ppr inst)
- 2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
+ 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
\end{code}
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
- -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_details decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
- setGblEnv tcg_env $ do {
-
- -- Typecheck the declarations
- tcTopSrcDecls boot_details rn_decls
- }}
-
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+-- Fails if there are any errors
rnTopSrcDecls group
- = do { -- Bring top level binders into scope
- tcg_env <- importsFromLocalDecls group ;
- setGblEnv tcg_env $ do {
-
- failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-
- -- Rename the source decls
- (tcg_env, rn_decls) <- rnSrcDecls group ;
- failIfErrsM ;
+ = do { -- Rename the source decls
+ (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
- -- save the renamed syntax, if we want it
+ -- save the renamed syntax, if we want it
let { tcg_env'
| Just grp <- tcg_rn_decls tcg_env
= tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
rnDump (ppr rn_decls) ;
return (tcg_env', rn_decls)
- }}
+ }
------------------------------------------------
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
+ hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
- -- tcTyAndClassDecls recovers internally, but if anything gave rise to
- -- an error we'd better stop now, to avoid a cascade
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
+ -- If there are any errors, tcTyAndClassDecls fails here
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
-
-
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+ (tcg_env, inst_infos, deriv_binds)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
setGblEnv tcg_env $ do {
- -- Foreign import declarations next. No zonking necessary
- -- here; we can tuck them straight into the global environment.
+ -- Foreign import declarations next.
traceTc (text "Tc4") ;
(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+ -- Now GHC-generated derived bindings, generics, and selectors
+ -- Do not generate warnings from compiler-generated code;
+ -- hence the use of discardWarnings
+ (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
+ (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ discardWarnings (tcTopBinds deriv_binds) ;
+
-- Value declarations next
- -- We also typecheck any extra binds that came out
- -- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
- setLclTypeEnv tcl_env $ do {
+ (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ tcTopBinds val_binds;
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
- (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
+ (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
+
+ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Foreign exports
- -- They need to be zonked, so we return them
traceTc (text "Tc7") ;
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Annotations
+ annotations <- tcAnnotations annotation_decls ;
+
-- Rules
rules <- tcRules rule_decls ;
traceTc (text "Tc7a") ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
+ tc_deriv_binds `unionBags`
+ tc_aux_binds `unionBags`
inst_binds `unionBags`
- foe_binds ;
+ foe_binds;
-- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
tcg_rules = tcg_rules tcg_env ++ rules,
+ tcg_anns = tcg_anns tcg_env ++ annotations,
tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
checkMain
- = do { ghc_mode <- getGhcMode ;
- tcg_env <- getGblEnv ;
+ = do { tcg_env <- getGblEnv ;
dflags <- getDOpts ;
- let { main_mod = mainModIs dflags ;
- main_fn = case mainFunIs dflags of {
- Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
- Nothing -> main_RDR_Unqual } } ;
-
- check_main ghc_mode tcg_env main_mod main_fn
+ check_main dflags tcg_env
}
-
-check_main ghc_mode tcg_env main_mod main_fn
+check_main dflags tcg_env
| mod /= main_mod
= traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
return tcg_env
| otherwise
- = addErrCtxt mainCtxt $
- do { mb_main <- lookupSrcOcc_maybe main_fn
+ = do { mb_main <- lookupGlobalOccRn_maybe main_fn
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
; complain_no_main
; return tcg_env } ;
Just main_name -> do
- { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
- ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
- -- :Main.main :: IO () = runMainIO main
-
- ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
- tcInferRho rhs
-
- -- The function that the RTS invokes is always :Main.main,
- -- which we call root_main_id.
- -- (Because GHC allows the user to have a module not called
- -- Main as the main module, we can't rely on the main function
- -- being called "Main.main". That's why root_main_id has a fixed
- -- module ":Main".)
- -- We also make root_main_id an implicit Id, by making main_name
- -- its parent (hence (Just main_name)). That has the effect
- -- of preventing its type and unfolding from getting out into
- -- the interface file. Otherwise we can end up with two defns
- -- for 'main' in the interface file!
+ { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+ ; let loc = srcLocSpan (getSrcLoc main_name)
+ ; ioTyCon <- tcLookupTyCon ioTyConName
+ ; (main_expr, res_ty)
+ <- addErrCtxt mainCtxt $
+ withBox liftedTypeKind $ \res_ty ->
+ tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
+
+ -- See Note [Root-main Id]
+ -- Construct the binding
+ -- :Main.main :: IO res_ty = runMainIO res_ty main
+ ; run_main_id <- tcLookupId runMainIOName
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
- (mkVarOccFS FSLIT("main"))
- (Just main_name) (getSrcLoc main_name)
- ; root_main_id = mkExportedLocalId root_main_name ty
- ; main_bind = noLoc (VarBind root_main_id main_expr) }
+ (mkVarOccFS (fsLit "main"))
+ (getSrcSpan main_name)
+ ; root_main_id = Id.mkExportedLocalId root_main_name
+ (mkTyConApp ioTyCon [res_ty])
+ ; co = mkWpTyApps [res_ty]
+ ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
+ ; main_bind = noLoc (VarBind root_main_id rhs) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
})
}}}
where
- mod = tcg_mod tcg_env
-
- complain_no_main | ghc_mode == Interactive = return ()
- | otherwise = failWithTc noMainMsg
+ mod = tcg_mod tcg_env
+ main_mod = mainModIs dflags
+ main_fn = getMainFun dflags
+
+ complain_no_main | ghcLink dflags == LinkInMemory = return ()
+ | otherwise = failWithTc noMainMsg
-- In interactive mode, don't worry about the absence of 'main'
-- In other modes, fail altogether, so that we don't go on
-- and complain a second time when processing the export list.
- mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
- noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
- <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
+ mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
+ noMainMsg = ptext (sLit "The") <+> pp_main_fn
+ <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
+ pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn)
+ | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn)
+
+-- | Get the unqualified name of the function to use as the \"main\" for the main module.
+-- Either returns the default name or the one configured on the command line with -main-is
+getMainFun :: DynFlags -> RdrName
+getMainFun dflags = case (mainFunIs dflags) of
+ Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
+ Nothing -> main_RDR_Unqual
\end{code}
+Note [Root-main Id]
+~~~~~~~~~~~~~~~~~~~
+The function that the RTS invokes is always :Main.main, which we call
+root_main_id. (Because GHC allows the user to have a module not
+called Main as the main module, we can't rely on the main function
+being called "Main.main". That's why root_main_id has a fixed module
+":Main".)
+
+This is unusual: it's a LocalId whose Name has a Module from another
+module. Tiresomely, we must filter it out again in MkIface, les we
+get two defns for 'main' in the interface file!
+
+
%*********************************************************
%* *
GHCi stuff
#ifdef GHCI
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
- = let
- -- Initialise the tcg_inst_env with instances
- -- from all home modules. This mimics the more selective
- -- call to hptInstances in tcRnModule
- dfuns = hptInstances hsc_env (\mod -> True)
+ = let -- Initialise the tcg_inst_env with instances from all home modules.
+ -- This mimics the more selective call to hptInstances in tcRnModule.
+ (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
in
updGblEnv (\env -> env {
- tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_type_env = ic_type_env icxt,
- tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
-
- updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
-
- do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
+ tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
+ home_fam_insts
+ }) $
+
+ tcExtendGhciEnv (ic_tmp_ids icxt) $
+ -- tcExtendGhciEnv does lots:
+ -- - it extends the local type env (tcl_env) with the given Ids,
+ -- - it extends the local rdr env (tcl_rdr) with the Names from
+ -- the given Ids
+ -- - it adds the free tyvars of the Ids to the tcl_tyvars
+ -- set.
+ --
+ -- later ids in ic_tmp_ids must shadow earlier ones with the same
+ -- OccName, and tcExtendIdEnv implements this behaviour.
+
+ do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
; thing_inside }
\end{code}
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
- -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
- -- The returned [Name] is the same as the input except for
- -- ExprStmt, in which case the returned [Name] is [itName]
+ -> IO (Messages, Maybe ([Id], LHsExpr Id))
+ -- The returned [Id] is the list of new Ids bound by
+ -- this statement. It can be used to extend the
+ -- InteractiveContext via extendInteractiveContext.
--
-- The returned TypecheckedHsExpr is of type IO [ () ],
-- a list of the bound values, coerced to ().
(([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
+ rnDump (ppr rn_stmt) ;
-- The real work is done here
(bound_ids, tc_expr) <- mkPlan rn_stmt ;
-- None of the Ids should be of unboxed type, because we
-- cast them all to HValues in the end!
- mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+ mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
traceTc (text "tcs 1") ;
- let { -- (a) Make all the bound ids "global" ids, now that
- -- they're notionally top-level bindings. This is
- -- important: otherwise when we come to compile an expression
- -- using these ids later, the byte code generator will consider
- -- the occurrences to be free rather than global.
- --
- -- (b) Tidy their types; this is important, because :info may
- -- ask to look at them, and :info expects the things it looks
- -- up to have tidy types
- global_ids = map globaliseAndTidy zonked_ids ;
-
- -- Update the interactive context
- rn_env = ic_rn_local_env ictxt ;
- type_env = ic_type_env ictxt ;
-
- bound_names = map idName global_ids ;
- new_rn_env = extendLocalRdrEnv rn_env bound_names ;
-
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
-
- filtered_type_env = delListFromNameEnv type_env shadowed ;
- new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+ let { global_ids = map globaliseAndTidyId zonked_ids } ;
+ -- Note [Interactively-bound Ids in GHCi]
+
+{- ---------------------------------------------
+ At one stage I removed any shadowed bindings from the type_env;
+ they are inaccessible but might, I suppose, cause a space leak if we leave them there.
+ However, with Template Haskell they aren't necessarily inaccessible. Consider this
+ GHCi session
+ Prelude> let f n = n * 2 :: Int
+ Prelude> fName <- runQ [| f |]
+ Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+ 14
+ Prelude> let f n = n * 3 :: Int
+ Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+ In the last line we use 'fName', which resolves to the *first* 'f'
+ in scope. If we delete it from the type env, GHCi crashes because
+ it doesn't expect that.
+
+ Hence this code is commented out
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- } ;
+-------------------------------------------------- -}
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr zonked_expr]) ;
- returnM (new_ic, bound_names, zonked_expr)
+ return (global_ids, zonked_expr)
}
where
- bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+ bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
-
-globaliseAndTidy :: Id -> Id
-globaliseAndTidy id
--- Give the Id a Global Name, and tidy its type
- = setIdType (globaliseId VanillaGlobal id) tidy_type
- where
- tidy_type = tidyTopType (idType id)
\end{code}
+Note [Interactively-bound Ids in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The Ids bound by previous Stmts in Template Haskell are currently
+ a) GlobalIds
+ b) with an Internal Name (not External)
+ c) and a tidied type
+
+ (a) They must be GlobalIds (not LocalIds) otherwise when we come to
+ compile an expression using these ids later, the byte code
+ generator will consider the occurrences to be free rather than
+ global.
+
+ (b) They retain their Internal names becuase we don't have a suitable
+ Module to name them with. We could revisit this choice.
+
+ (c) Their types are tidied. This is important, because :info may ask
+ to look at them, and :info expects the things it looks up to have
+ tidy types
+
+
+--------------------------------------------------------------------------
+ Typechecking Stmts in GHCi
+
Here is the grand plan, implemented in tcUserStmt
What you type The IO [HValue] that hscStmt returns
; runPlans [ -- Plan A
do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
- ; ifM (isUnitTy it_ty) failM
+ ; when (isUnitTy it_ty) failM
; return stuff },
-- Plan B; a naked bind statment
| [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) placeHolderType
+
+ ; print_bind_result <- doptM Opt_PrintBindResult
+ ; let print_plan = do
+ { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ ; v_ty <- zonkTcType (idType v_id)
+ ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
+ ; return stuff }
+
-- The plans are:
-- [stmt; print v] but not if v::()
-- [stmt]
- ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
- ; v_ty <- zonkTcType (idType v_id)
- ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
- ; return stuff },
- tcGhciStmts [stmt]
- ]}
+ ; runPlans ((if print_bind_result then [print_plan] else []) ++
+ [tcGhciStmts [stmt]])
+ }
mkPlan stmt
= tcGhciStmts [stmt]
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
ret_id <- tcLookupId returnIOName ; -- return @ IO
let {
- io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ;
names = map unLoc (collectLStmtsBinders stmts) ;
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
- mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
(nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
- traceTc (text "tcs 2") ;
- ((tc_stmts, ids), lie) <- getLIE $
- tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
- mappM tcLookupId names ;
+ traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
+ ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context
+ traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ;
const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
+ traceTc (text "TcRnDriver.tcGhciStmts: done") ;
return (ids, mkHsDictLet const_binds $
noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
}
tcRnExpr :: HscEnv
-> InteractiveContext
-> LHsExpr RdrName
- -> IO (Maybe Type)
+ -> IO (Messages, Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
tcSimplifyInteractive lie_top ;
- qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
- let { all_expr_ty = mkForAllTys qtvs' $
- mkFunTys (map idType dict_ids) $
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map (idType . instToId) dict_insts) $
res_ty } ;
zonkTcType all_expr_ty
}
where
- smpl_doc = ptext SLIT("main expression")
+ smpl_doc = ptext (sLit "main expression")
\end{code}
tcRnType just finds the kind of a type
tcRnType :: HscEnv
-> InteractiveContext
-> LHsType RdrName
- -> IO (Maybe Kind)
+ -> IO (Messages, Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
failIfErrsM ;
-- Now kind-check the type
- (ty', kind) <- kcHsType rn_type ;
+ (ty', kind) <- kcLHsType rn_type ;
return kind
}
where
- doc = ptext SLIT("In GHCi input")
+ doc = ptext (sLit "In GHCi input")
#endif /* GHCi */
\end{code}
\begin{code}
#ifdef GHCI
--- ASSUMES that the module is either in the HomePackageTable or is
+-- | ASSUMES that the module is either in the 'HomePackageTable' or is
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
-getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
- = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
-
-tcGetModuleExports :: Module -> TcM NameSet
-tcGetModuleExports mod = do
- let doc = ptext SLIT("context for compiling statements")
- iface <- initIfaceTcRn $ loadSysInterface doc mod
- loadOrphanModules (dep_orphs (mi_deps iface))
- -- Load any orphan-module interfaces,
- -- so their instances are visible
- ifaceExportNames (mi_exports iface)
-
-tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+ = let
+ ic = hsc_IC hsc_env
+ checkMods = ic_toplev_scope ic ++ ic_exports ic
+ in
+ initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
+
+-- Get the export avail info and also load all orphan and family-instance
+-- modules. Finally, check that the family instances of all modules in the
+-- interactive context are consistent (these modules are in the second
+-- argument).
+tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
+tcGetModuleExports mod directlyImpMods
+ = do { let doc = ptext (sLit "context for compiling statements")
+ ; iface <- initIfaceTcRn $ loadSysInterface doc mod
+
+ -- Load any orphan-module and family instance-module
+ -- interfaces, so their instances are visible.
+ ; loadOrphanModules (dep_orphs (mi_deps iface)) False
+ ; loadOrphanModules (dep_finsts (mi_deps iface)) True
+
+ -- Check that the family instances of all directly loaded
+ -- modules are consistent.
+ ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
+
+ ; ifaceExportNames (mi_exports iface)
+ }
+
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
return good_names
}
-
-tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
- tcLookupGlobal name
+ tcRnLookupName' name
+-- To look up a name we have to look in the local environment (tcl_lcl)
+-- as well as the global environment, which is what tcLookup does.
+-- But we also want a TyThing, so we have to convert:
+
+tcRnLookupName' :: Name -> TcRn TyThing
+tcRnLookupName' name = do
+ tcthing <- tcLookup name
+ case tcthing of
+ AGlobal thing -> return thing
+ ATcId{tct_id=id} -> return (AnId id)
+ _ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
-> Name
- -> IO (Maybe (TyThing, Fixity, [Instance]))
+ -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
-- Used to implemnent :info in GHCi
--
-- in the home package all relevant modules are loaded.)
loadUnqualIfaces ictxt
- thing <- tcLookupGlobal name
+ thing <- tcRnLookupName' name
fixity <- lookupFixityRn name
- ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+ ispecs <- lookupInsts thing
return (thing, fixity, ispecs)
-
-lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
--- Filter the instances by the ones whose tycons (or clases resp)
--- are in scope unqualified. Otherwise we list a whole lot too many!
-lookupInsts print_unqual (AClass cls)
+lookupInsts :: TyThing -> TcM [Instance]
+lookupInsts (AClass cls)
= do { inst_envs <- tcGetInstEnvs
- ; return [ ispec
- | ispec <- classInstances inst_envs cls
- , plausibleDFun print_unqual (instanceDFunId ispec) ] }
+ ; return (classInstances inst_envs cls) }
-lookupInsts print_unqual (ATyCon tc)
+lookupInsts (ATyCon tc)
= do { eps <- getEps -- Load all instances for all classes that are
-- in the type environment (which are all the ones
-- we've seen in any interface file so far)
; return [ ispec
| ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
, let dfun = instanceDFunId ispec
- , relevant dfun
- , plausibleDFun print_unqual dfun ] }
+ , relevant dfun ] }
where
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
tc_name = tyConName tc
-lookupInsts print_unqual other = return []
-
-plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
- = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
- where
- ok name | isBuiltInSyntax name = True
- | isExternalName name =
- isNothing $ fst print_unqual (nameModule name)
- (nameOccName name)
- | otherwise = True
+lookupInsts other = return []
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
not (isInternalName name),
isTcOcc (nameOccName name), -- Types and classes only
unQualOK gre ] -- In scope unqualified
- doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
+ doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
#endif /* GHCI */
\end{code}
= do { dflags <- getDOpts ;
-- Dump short output if -ddump-types or -ddump-tc
- ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
- (dumpTcRn short_dump) ;
+ when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+ (dumpTcRn short_dump) ;
-- Dump bindings if -ddump-tc
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
tcCoreDump mod_guts
= do { dflags <- getDOpts ;
- ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
- (dumpTcRn (pprModGuts mod_guts)) ;
+ when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+ (dumpTcRn (pprModGuts mod_guts)) ;
-- Dump bindings if -ddump-tc
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
-pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
- tcg_insts = dfun_ids,
- tcg_rules = rules,
- tcg_imports = imports })
- = vcat [ ppr_types dfun_ids type_env
- , ppr_insts dfun_ids
+pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_rules = rules,
+ tcg_imports = imports })
+ = vcat [ ppr_types insts type_env
+ , ppr_tycons fam_insts type_env
+ , ppr_insts insts
+ , ppr_fam_insts fam_insts
, vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env)
- , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
- , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
+ , ptext (sLit "Dependent modules:") <+>
+ ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+ , ptext (sLit "Dependent packages:") <+>
+ ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
+ where -- The two uses of sortBy are just to reduce unnecessary
+ -- wobbling in testsuite output
+ cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
+ = (mod_name1 `stableModuleNameCmp` mod_name2)
+ `thenCmp`
+ (is_boot1 `compare` is_boot2)
pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env,
= vcat [ ppr_types [] type_env,
ppr_rules rules ]
-
ppr_types :: [Instance] -> TypeEnv -> SDoc
-ppr_types ispecs type_env
+ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
- dfun_ids = map instanceDFunId ispecs
+ dfun_ids = map instanceDFunId insts
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
-- that the type checker has invented. Top-level user-defined things
-- have External names.
+ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons fam_insts type_env
+ = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+ where
+ fi_tycons = map famInstTyCon fam_insts
+ tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
+ want_tycon tycon | opt_PprStyle_Debug = True
+ | otherwise = not (isImplicitTyCon tycon) &&
+ isExternalName (tyConName tycon) &&
+ not (tycon `elem` fi_tycons)
+
ppr_insts :: [Instance] -> SDoc
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
+ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts [] = empty
+ppr_fam_insts fam_insts =
+ text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
+
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName
le_sig id1 id2 = getOccName id1 <= getOccName id2
ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
+ppr_tydecls :: [TyCon] -> SDoc
+ppr_tydecls tycons
+ -- Print type constructor info; sort by OccName
+ = vcat (map ppr_tycon (sortLe le_sig tycons))
+ where
+ le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
+ ppr_tycon tycon
+ | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon
+ | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
+
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
-ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
+ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
nest 4 (pprRules rs),
- ptext SLIT("#-}")]
+ ptext (sLit "#-}")]
ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
+ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}
projects / ghc-hetmet.git / blobdiff