%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
-import StaticFlags ( opt_PprStyle_Debug )
-import Packages ( checkForPackageConflicts, mkHomeModules )
-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, mkTyVarTys, substTyWith )
-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 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 DataCon ( dataConWrapId )
-import ErrUtils ( Messages, mkDumpDoc, showPass )
-import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
-import Var ( Var )
-import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
-import OccName ( mkVarOccFS )
-import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
- mkExternalName, isInternalName )
+import TcType
+import Inst
+import FamInst
+import InstEnv
+import FamInstEnv
+import TcBinds
+import TcDefaults
+import TcEnv
+import TcRules
+import TcForeign
+import TcInstDcls
+import TcIface
+import MkIface
+import IfaceSyn
+import TcSimplify
+import TcTyClsDecls
+import LoadIface
+import RnNames
+import RnEnv
+import RnSource
+import RnHsDoc
+import PprCore
+import CoreSyn
+import ErrUtils
+import Id
+import Var
+import Module
+import UniqFM
+import Name
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
-import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import DriverPhases ( HscSource(..), isHsBoot )
-import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
- HscEnv(..), ExternalPackageState(..),
- IsBootInterface, noDependencies,
- Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv, hptInstances,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
- emptyFixityEnv
- )
+import NameEnv
+import TyCon
+import SrcLoc
+import HscTypes
import Outputable
#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 RnTypes ( rnLHsType )
-import Inst ( tcGetInstEnvs )
-import InstEnv ( classInstances, instEnvElts )
-import RnExpr ( rnStmts, rnLExpr )
-import LoadIface ( loadSrcInterface, loadSysInterface )
-import IfaceEnv ( ifaceExportNames )
-import Module ( moduleSetElts, mkModuleSet )
-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 ( nameOccName, nameModule, isBuiltInSyntax )
-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 TcHsType
+import TcMType
+import TcMatches
+import TcGadt
+import RnTypes
+import RnExpr
+import IfaceEnv
+import MkId
+import TysWiredIn
+import IdInfo
+import {- Kind parts of -} Type
+import BasicTypes
+import Data.Maybe
#endif
-import FastString ( mkFastString )
-import Maybes ( MaybeErr(..) )
-import Util ( sortLe )
-import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+import FastString
+import Util
+import Bag
-import Maybe ( isJust )
+import Control.Monad ( unless )
+import Data.Maybe ( isJust )
\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_mod = case maybe_mod of
- Nothing -> mAIN -- 'module M where' is omitted
- Just (L _ mod) -> mod } ; -- The normal case
+ let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
+ this_mod = case maybe_mod of
+ Nothing -> mAIN -- 'module M where' is omitted
+ Just (L _ mod) -> mkModule this_pkg mod } ;
+ -- The normal case
initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
-- Deal with imports;
- rn_imports <- rnImports import_decls ;
- (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
+ (rn_imports, rdr_env, imports) <- rnImports import_decls ;
- let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ 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 :: Module -> Bool
- ; want_instances mod = mod `elemModuleEnv` dep_mods
- && mod /= this_mod
+ ; want_instances :: ModuleName -> Bool
+ ; want_instances mod = mod `elemUFM` dep_mods
+ && mod /= moduleName this_mod
; home_insts = hptInstances hsc_env want_instances
} ;
-- and any other incrementally-performed imports
updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
- checkConflicts imports this_mod $ do {
-
-- Update the gbl env
updGblEnv ( \ gbl ->
- gbl { tcg_rdr_env = rdr_env,
+ 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
-- 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 interfaces, so that
- -- their rules and instance decls will be found
- loadOrphanModules (imp_orphs imports) ;
+ -- 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 ;
+
+ let { directlyImpMods = map (\(mod, _, _) -> mod)
+ . moduleEnvElts
+ . imp_mods
+ $ imports } ;
+ checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
traceRn (text "rn1a") ;
-- Rename and type check the declarations
-- 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 tcg_env ;
+ reportDeprecations (hsc_dflags hsc_env) 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) ;
+ (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
+
+ traceRn (text "rn4") ;
+
+ -- Rename the Haddock documentation header
+ rn_module_doc <- rnMbHsDoc maybe_doc ;
+
+ -- Rename the Haddock module info
+ rn_description <- rnMbHsDoc (hmi_description module_info) ;
+ let { rn_module_info = module_info { hmi_description = rn_description } } ;
-- Check whether the entire module is deprecated
-- This happens only once per module
tcg_rn_exports = if save_rn_syntax then
rn_exports
else Nothing,
- tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
+ tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports),
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
- mod_deprecs }
+ mod_deprecs,
+ tcg_doc = rn_module_doc,
+ tcg_hmi = rn_module_info
+ }
-- A module deprecation over-rides the earlier ones
} ;
-- Dump output and return
tcDump final_env ;
return final_env
- }}}}}
-
-
--- The program is not allowed to contain two modules with the same
--- name, and we check for that here. It could happen if the home package
--- contains a module that is also present in an external package, for example.
-checkConflicts imports this_mod and_then = do
- dflags <- getDOpts
- let
- dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports))
- -- don't forget to include the current module!
-
- mb_dep_pkgs = checkForPackageConflicts
- dflags dep_mods (imp_dep_pkgs imports)
- --
- case mb_dep_pkgs of
- Failed msg ->
- do addErr msg; failM
- Succeeded _ ->
- updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods })
- and_then
+ }}}}
\end{code}
-- 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_home_mods = mkHomeModules [], -- ?? wrong!!
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
+ 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_fam_insts = tcg_fam_insts 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_deprecs = NoDeprecs,
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo
} } ;
tcCoreDump mod_guts ;
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
- tcDump tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
failIfErrsM ; -- Don't typecheck if renaming failed
+ rnDump (ppr rn_splice_expr) ;
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Typecheck instance decls
; traceTc (text "Tc3")
- ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; (tcg_env, inst_infos, _binds)
+ <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; gbl_env <- getGblEnv
-- Make the final type-env
- -- Include the dfun_ids so that their type sigs get
+ -- Include the dfun_ids so that their type sigs
-- are written into the interface file
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
-- 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 { mapM_ check_one (typeEnvElts boot_type_env)
+ (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
+ tcg_type_env = local_type_env })
+ (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_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
+ ; 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...
; return (unionManyBags dfun_binds) }
where
check_one boot_thing
- | no_check name
- = return ()
- | otherwise
- = case lookupTypeEnv local_type_env name of
- Nothing -> addErrTc (missingBootThing boot_thing)
- Just real_thing -> check_thing boot_thing real_thing
+ | isImplicitTyThing boot_thing = return ()
+ | 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)
+ | Just real_thing <- lookupTypeEnv local_type_env name
+ = do { let boot_decl = tyThingToIfaceDecl boot_thing
+ real_decl = tyThingToIfaceDecl 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
+ | otherwise
+ = addErrTc (missingBootThing boot_thing)
where
name = getName boot_thing
- 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
dfun_names = map getName boot_insts
check_inst boot_inst
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
- local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
-
-----------------
-check_thing (ATyCon boot_tc) (ATyCon real_tc)
- | isSynTyCon boot_tc && isSynTyCon real_tc,
- defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
- = return ()
-
- | tyConKind boot_tc == tyConKind real_tc
- = return ()
- where
- (tvs1, defn1) = synTyConDefn boot_tc
- (tvs2, defn2) = synTyConDefn boot_tc
-
-check_thing (AnId boot_id) (AnId real_id)
- | idType boot_id `tcEqType` idType real_id
- = return ()
-
-check_thing (ADataCon dc1) (ADataCon dc2)
- | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
- = return ()
-
- -- Can't declare a class in a hi-boot file
-
-check_thing boot_thing real_thing -- Default case; failure
- = addErrAt (srcLocSpan (getSrcLoc real_thing))
- (bootMisMatch real_thing)
+ local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
----------------
missingBootThing thing
= ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
-bootMisMatch thing
- = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+bootMisMatch thing boot_decl real_decl
+ = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"),
+ ptext SLIT("Decl") <+> 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"))
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_ruleds = rule_decls,
-- 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
; 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
+ (getSrcLoc main_name)
+ ; root_main_id = Id.mkExportedLocalId root_main_name ty
; main_bind = noLoc (VarBind root_main_id main_expr) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
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
+{- ---------------------------------------------
+ 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
+
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 ;
+-------------------------------------------------- -}
+ new_type_env = extendTypeEnvWithIds type_env global_ids ;
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
} ;
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
-- Give the Id a Global Name, and tidy its type
- = setIdType (globaliseId VanillaGlobal id) tidy_type
+ = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
where
tidy_type = tidyTopType (idType id)
\end{code}
| [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)
+ ; ifM (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]
io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts
+ (emptyRefinement, 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 ;
+ ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- 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 :: Module -> TcM [AvailInfo]
tcGetModuleExports mod = do
- iface <- load_iface mod
- loadOrphanModules (dep_orphs (mi_deps iface))
+ let doc = ptext SLIT("context for compiling statements")
+ iface <- initIfaceTcRn $ loadSysInterface doc mod
+ loadOrphanModules (dep_orphs (mi_deps iface)) False
-- Load any orphan-module interfaces,
-- so their instances are visible
+ loadOrphanModules (dep_finsts (mi_deps iface)) True
+ -- Load any family instance-module interfaces,
+ -- so all family instances are visible
ifaceExportNames (mi_exports iface)
-load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
- where
- doc = ptext SLIT("context for compiling statements")
-
-
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
= all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
where
ok name | isBuiltInSyntax name = True
- | isExternalName name = print_unqual (nameModule name) (nameOccName name)
+ | isExternalName name =
+ isNothing $ fst print_unqual (nameModule name)
+ (nameOccName name)
| otherwise = True
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- 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 (moduleEnvElts (imp_dep_mods imports))
+ , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
, ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
pprModGuts :: ModGuts -> SDoc
= 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"),
projects / ghc-hetmet.git / blobdiff