From acc784b55045fe43b2d92efc992a4b888d96c682 Mon Sep 17 00:00:00 2001 From: sof Date: Fri, 5 Apr 2002 15:18:27 +0000 Subject: [PATCH] [project @ 2002-04-05 15:18:25 by sof] Cleaned up the way the External Core front-end was integrated with the rest of the compiler; guided by detailed and helpful feedback from Simon PJ. Input files ending in ".hcr" are now assumed to contain external core -- still working on getting the renamer to slurp in interface files (implicitly) referred to in the Core source. --- ghc/compiler/deSugar/Desugar.lhs | 34 ++++++-- ghc/compiler/main/DriverPhases.hs | 8 +- ghc/compiler/main/HscMain.lhs | 146 +++++++++++++++++++++----------- ghc/compiler/parser/LexCore.hs | 1 - ghc/compiler/parser/ParserCore.y | 12 +-- ghc/compiler/parser/ParserCoreUtils.hs | 1 - ghc/compiler/rename/Rename.lhs | 71 ++++++++++++++-- ghc/compiler/rename/RnSource.lhs | 6 +- ghc/compiler/typecheck/TcHsSyn.lhs | 7 +- ghc/compiler/typecheck/TcModule.lhs | 57 +++++++++++-- 10 files changed, 257 insertions(+), 86 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 07f8f32..8e2a33c 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -4,15 +4,17 @@ \section[Desugar]{@deSugar@: the main function} \begin{code} -module Desugar ( deSugar, deSugarExpr ) where +module Desugar ( deSugar, deSugarExpr, + deSugarCore ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) -import HscTypes ( ModDetails(..) ) +import HscTypes ( ModDetails(..), TypeEnv ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) +import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr, + TypecheckedCoreBind ) import TcModule ( TcResults(..) ) import Id ( Id ) import CoreSyn @@ -58,7 +60,7 @@ deSugar dflags pcs hst mod_name unqual tc_binds = all_binds, tc_insts = insts, tc_rules = rules, - tc_cbinds = core_binds, +-- tc_cbinds = core_binds, tc_fords = fo_decls}) = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' @@ -69,15 +71,16 @@ deSugar dflags pcs hst mod_name unqual (ds_binds, ds_rules, foreign_stuff) = ds_result +{- addCoreBinds ls = case core_binds of [] -> ls cs -> (Rec cs) : ls - +-} mod_details = ModDetails { md_types = type_env, md_insts = insts, md_rules = ds_rules, - md_binds = addCoreBinds ds_binds } + md_binds = ds_binds } -- Display any warnings ; doIfSet (not (isEmptyBag ds_warns)) @@ -159,6 +162,25 @@ ppr_ds_rules rules pprIdRules rules \end{code} +Simplest thing in the world, desugaring External Core: + +\begin{code} +deSugarCore :: TypeEnv -> [TypecheckedCoreBind] + -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr])) +deSugarCore type_env cs = do + let + mod_details + = ModDetails { md_types = type_env + , md_insts = [] + , md_rules = [] + , md_binds = [Rec (map (\ (lhs,_,rhs) -> (lhs,rhs)) cs)] + } + + no_foreign_stuff = (empty,empty,[],[]) + return (mod_details, no_foreign_stuff) + +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 53746e9..9d48a36 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.17 2002/03/29 21:39:37 sof Exp $ +-- $Id: DriverPhases.hs,v 1.18 2002/04/05 15:18:26 sof Exp $ -- -- GHC Driver -- @@ -18,7 +18,8 @@ module DriverPhases ( haskellish_src_file, haskellish_src_suffix, hsbootish_file, hsbootish_suffix, objish_file, objish_suffix, - cish_file, cish_suffix + cish_file, cish_suffix, + isExtCore_file ) where import DriverUtil @@ -102,6 +103,7 @@ haskellish_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "ra haskellish_src_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr"]) cish_suffix = (`elem` [ "c", "cpp", "C", "cc", "cxx", "s", "S" ]) hsbootish_suffix = (`elem` [ "hs-boot" ]) +extcoreish_suffix = (`elem` [ "hcr" ]) #if mingw32_TARGET_OS || cygwin32_TARGET_OS objish_suffix = (`elem` [ "o", "O", "obj", "OBJ" ]) @@ -114,3 +116,5 @@ haskellish_src_file = haskellish_src_suffix . getFileSuffix cish_file = cish_suffix . getFileSuffix objish_file = objish_suffix . getFileSuffix hsbootish_file = hsbootish_suffix . getFileSuffix + +isExtCore_file = extcoreish_suffix . getFileSuffix diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index af0d944..5739163 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -18,7 +18,7 @@ import Interpreter import ByteCodeGen ( byteCodeGen ) import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import Rename ( renameStmt, renameRdrName, slurpIface ) +import Rename ( renameStmt, renameRdrName, slurpIface ) import RdrName ( rdrNameOcc, setRdrNameOcc ) import RdrHsSyn ( RdrNameStmt ) import OccName ( dataName, tcClsName, @@ -47,7 +47,8 @@ import Parser import Lex ( ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) import Finder ( findModule ) -import Rename ( checkOldIface, renameModule, closeIfaceDecls ) +import Rename ( checkOldIface, renameModule, renameExtCore, + closeIfaceDecls, RnResult(..) ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelRules ( builtinRules ) @@ -70,6 +71,7 @@ import CodeOutput ( codeOutput, outputForeignStubs ) import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import DriverState ( v_HCHeader ) +import DriverPhases ( isExtCore_file ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) @@ -204,50 +206,23 @@ hscRecomp ghci_mode dflags have_object mod location maybe_checked_iface hst hit pcs_ch = do { -- what target are we shooting for? - ; let toInterp = dopt_HscLang dflags == HscInterpreted + ; let toInterp = dopt_HscLang dflags == HscInterpreted ; let toNothing = dopt_HscLang dflags == HscNothing + ; let toCore = isJust (ml_hs_file location) && + isExtCore_file (fromJust (ml_hs_file location)) ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ showModMsg (not toInterp) mod location); - - ------------------- - -- PARSE - ------------------- - ; maybe_parsed <- myParseModule dflags - (unJust "hscRecomp:hspp" (ml_hspp_file location)) - ; case maybe_parsed of { - Nothing -> return (HscFail pcs_ch); - Just rdr_module -> do { - ; let this_mod = mkHomeModule (hsModuleName rdr_module) - - ------------------- - -- RENAME - ------------------- - ; (pcs_rn, print_unqual, maybe_rn_result) - <- _scc_ "Rename" - renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module - ; case maybe_rn_result of { - Nothing -> return (HscFail pcs_ch); - Just (dont_discard, new_iface, rn_result) -> do { - - ------------------- - -- TYPECHECK - ------------------- - ; maybe_tc_result - <- _scc_ "TypeCheck" - typecheckModule dflags pcs_rn hst print_unqual rn_result - ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_ch); - Just (pcs_tc, tc_result) -> do { - - ------------------- - -- DESUGAR - ------------------- - ; (ds_details, foreign_stuff) - <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqual tc_result - + + ; front_res <- + (if toCore then hscCoreFrontEnd else hscFrontEnd) + ghci_mode dflags location hst hit pcs_ch + ; case front_res of + Left flure -> return flure; + Right (this_mod, rdr_module, + Just (dont_discard, new_iface, rn_result), + pcs_tc, ds_details, foreign_stuff) -> do { ------------------- -- FLATTENING ------------------- @@ -421,19 +396,92 @@ hscRecomp ghci_mode dflags have_object final_iface stub_h_exists stub_c_exists maybe_bcos) - }}}}}}} + }} + +hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do { + ------------------- + -- PARSE + ------------------- + ; inp <- readFile (unJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) + ; case parseCore inp 1 of + FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); + OkP rdr_module -> do { + ; let this_mod = mkHomeModule (hsModuleName rdr_module) + + ------------------- + -- RENAME + ------------------- + ; (pcs_rn, print_unqual, maybe_rn_result) + <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module + ; case maybe_rn_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (dont_discard, new_iface, rn_result) -> do { + + ------------------- + -- TYPECHECK + ------------------- + ; maybe_tc_result + <- _scc_ "TypeCheck" + typecheckCoreModule dflags pcs_rn hst new_iface (rr_decls rn_result) + ; case maybe_tc_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (pcs_tc, ty_env, core_binds) -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (ds_details, foreign_stuff) <- deSugarCore ty_env core_binds + ; return (Right (this_mod, rdr_module, maybe_rn_result, + pcs_tc, ds_details, foreign_stuff)) + }}}}}} + + +hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do { + ------------------- + -- PARSE + ------------------- + ; maybe_parsed <- myParseModule dflags + (unJust "hscRecomp:hspp" (ml_hspp_file location)) + ; case maybe_parsed of { + Nothing -> return (Left (HscFail pcs_ch)); + Just rdr_module -> do { + ; let this_mod = mkHomeModule (hsModuleName rdr_module) + + ------------------- + -- RENAME + ------------------- + ; (pcs_rn, print_unqual, maybe_rn_result) + <- _scc_ "Rename" + renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module + ; case maybe_rn_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (dont_discard, new_iface, rn_result) -> do { + + ------------------- + -- TYPECHECK + ------------------- + ; maybe_tc_result + <- _scc_ "TypeCheck" + typecheckModule dflags pcs_rn hst print_unqual rn_result + ; case maybe_tc_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (pcs_tc, tc_result) -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (ds_details, foreign_stuff) + <- _scc_ "DeSugar" + deSugar dflags pcs_tc hst this_mod print_unqual tc_result + ; return (Right (this_mod, rdr_module, maybe_rn_result, + pcs_tc, ds_details, foreign_stuff)) + }}}}}}} + myParseModule dflags src_filename = do -------------------------- Parser ---------------- showPass dflags "Parser" _scc_ "Parser" do - if dopt_HscLang dflags == HscCore - then do - inp <- readFile src_filename - case parseCore inp 1 of - OkP m -> return (Just m) - FailP s -> hPutStrLn stderr s >> return Nothing - else do buf <- hGetStringBuffer src_filename let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, diff --git a/ghc/compiler/parser/LexCore.hs b/ghc/compiler/parser/LexCore.hs index 2a91683..b76892d 100644 --- a/ghc/compiler/parser/LexCore.hs +++ b/ghc/compiler/parser/LexCore.hs @@ -75,7 +75,6 @@ lexName cont cstr cs = cont (cstr name) rest lexKeyword cont cs = case span isKeywordChar cs of ("module",rest) -> cont TKmodule rest - ("import",rest) -> cont TKimport rest ("data",rest) -> cont TKdata rest ("newtype",rest) -> cont TKnewtype rest ("forall",rest) -> cont TKforall rest diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index e4700ff..1039f8b 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -25,7 +25,6 @@ import SrcLoc %token '%module' { TKmodule } - '%import' { TKimport } '%data' { TKdata } '%newtype' { TKnewtype } '%forall' { TKforall } @@ -65,15 +64,8 @@ import SrcLoc %% module :: { RdrNameHsModule } - : '%module' modid imports tdefs vdefgs - { HsModule $2 Nothing Nothing $3 ($4 ++ concat $5) Nothing noSrcLoc} - -imports :: { [ImportDecl RdrName] } - : {- empty -} { [] } - | imp ';' imports { $1 : $3 } - -imp :: { ImportDecl RdrName } - : '%import' modid { ImportDecl $2 ImportByUser True{-qual-} Nothing Nothing noSrcLoc } + : '%module' modid tdefs vdefgs + { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc} tdefs :: { [RdrNameHsDecl] } : {- empty -} {[]} diff --git a/ghc/compiler/parser/ParserCoreUtils.hs b/ghc/compiler/parser/ParserCoreUtils.hs index 0d7907a..c9c91a2 100644 --- a/ghc/compiler/parser/ParserCoreUtils.hs +++ b/ghc/compiler/parser/ParserCoreUtils.hs @@ -17,7 +17,6 @@ failP s s' _ = FailP (s ++ ":" ++ s') data Token = TKmodule - | TKimport | TKdata | TKnewtype | TKforall diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index d9a4dcb..0122c0e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,10 +4,17 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( - renameModule, RnResult(..), renameStmt, renameRdrName, mkGlobalContext, - closeIfaceDecls, checkOldIface, slurpIface - ) where +module Rename + ( renameModule + , RnResult(..) + , renameStmt + , renameRdrName + , renameExtCore + , mkGlobalContext + , closeIfaceDecls + , checkOldIface + , slurpIface + ) where #include "HsVersions.h" @@ -49,7 +56,7 @@ import Module ( Module, ModuleName, WhereFrom(..), import Name ( Name, nameModule, isExternalName ) import NameEnv import NameSet -import RdrName ( foldRdrEnv, isQual ) +import RdrName ( foldRdrEnv, isQual, emptyRdrEnv ) import PrelNames ( iNTERACTIVE, pRELUDE_Name ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printErrorsAndWarnings, errorsFound ) @@ -195,6 +202,58 @@ renameRdrName dflags hit hst pcs ic rdr_names = vcat (map ppr decls)])) \end{code} +\begin{code} +renameExtCore :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module + -> RdrNameHsModule + -> IO (PersistentCompilerState, PrintUnqualified, + Maybe (IsExported, ModIface, RnResult)) + + -- Nothing => some error occurred in the renamer +renameExtCore dflags hit hst pcs this_module + rdr_module@(HsModule _ _ exports imports local_decls mod_deprec loc) + -- Rename the (Core) module + = renameSource dflags hit hst pcs this_module $ + pushSrcLocRn loc $ + -- RENAME THE SOURCE + rnSourceDecls emptyRdrEnv emptyAvailEnv + emptyLocalFixityEnv + InterfaceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) -> + closeDecls rn_local_decls source_fvs `thenRn` \ final_decls -> + -- print everything qualified. + let print_unqualified = const False in + -- Bail out if we fail + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + returnRn (print_unqualified, Nothing) + else + let + mod_iface = ModIface { mi_module = this_module, + mi_package = opt_InPackage, + mi_version = initialVersionInfo, + mi_usages = [], + mi_boot = False, + mi_orphan = panic "is_orphan", + mi_exports = [], + mi_globals = Nothing, + mi_fixities = mkNameEnv [], + mi_deprecs = NoDeprecs, + mi_decls = panic "mi_decls" + } + + rn_result = RnResult { rr_mod = this_module, + rr_fixities = mkNameEnv [], + rr_decls = final_decls, + rr_main = Nothing } + + is_exported _ = True + in + returnRn (print_unqualified, Just (is_exported, mod_iface, rn_result)) +\end{code} + + %********************************************************* %* * \subsection{Make up an interactive context} @@ -363,7 +422,7 @@ rename ghci_mode this_module -- RENAME THE SOURCE rnSourceDecls gbl_env global_avail_env - local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) -> + local_fixity_env SourceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) -> -- GET ANY IMPLICIT FREE VARIALBES getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index adb0c37..a5339e6 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -72,13 +72,13 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* \begin{code} -rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv +rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> RnMode -> [RdrNameHsDecl] -> RnMG ([RenamedHsDecl], FreeVars) -- The decls get reversed, but that's ok -rnSourceDecls gbl_env avails local_fixity_env decls - = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) +rnSourceDecls gbl_env avails local_fixity_env mode decls + = initRnMS gbl_env avails emptyRdrEnv local_fixity_env mode (go emptyFVs [] decls) where -- Fixity and deprecations have been dealt with already; ignore them go fvs ds' [] = returnRn (ds', fvs) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 05cd88c..bd04f92 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -106,7 +106,7 @@ type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat type TypecheckedHsModule = HsModule Id TypecheckedPat type TypecheckedForeignDecl = ForeignDecl Id type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat -type TypecheckedCoreBind = (Id, CoreExpr) +type TypecheckedCoreBind = (Id, Type, CoreExpr) \end{code} \begin{code} @@ -792,13 +792,14 @@ zonkRule (IfaceRuleOut fun rule) \end{code} \begin{code} -zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)] +zonkCoreBinds :: [TypecheckedCoreBind] -> NF_TcM [TypecheckedCoreBind] zonkCoreBinds ls = mapNF_Tc zonkOne ls where zonkOne (i, t, e) = zonkIdOcc i `thenNF_Tc` \ i' -> + zonkTcTypeToType t `thenNF_Tc` \ t' -> zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (i',e') + returnNF_Tc (i',t',e') -- needed? zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index f5c5c44..3ebce12 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -6,7 +6,7 @@ \begin{code} module TcModule ( typecheckModule, typecheckIface, typecheckStmt, typecheckExpr, - typecheckExtraDecls, + typecheckExtraDecls, typecheckCoreModule, TcResults(..) ) where @@ -353,7 +353,6 @@ data TcResults tc_insts :: [DFunId], -- Instances tc_rules :: [TypecheckedRuleDecl], -- Transformation rules tc_binds :: TypecheckedMonoBinds, -- Bindings - tc_cbinds :: [TypecheckedCoreBind], -- (external)Core value decls/bindings. tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports. } @@ -405,7 +404,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod, traceTc (text "Tc5") `thenNF_Tc_` tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) -> - tcCoreBinds core_binds `thenTc` \ core_binds' -> -- Second pass over class and instance declarations, -- plus rules and foreign exports, to generate bindings tcSetEnv env2 $ @@ -461,7 +459,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod, in traceTc (text "Tc7") `thenNF_Tc_` zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) -> - zonkCoreBinds core_binds' `thenNF_Tc` \ core_binds' -> tcSetEnv final_env $ -- zonkTopBinds puts all the top-level Ids into the tcGEnv traceTc (text "Tc8") `thenNF_Tc_` @@ -480,7 +477,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod, tc_insts = map iDFunId inst_info, tc_binds = all_binds', tc_fords = foi_decls ++ foe_decls', - tc_cbinds = core_binds', tc_rules = src_rules' } ) @@ -679,6 +675,57 @@ addIfaceRules rule_base rules add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule) \end{code} +\begin{code} +typecheckCoreModule + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> ModIface -- Iface for this module (just module & fixities) + -> [RenamedHsDecl] + -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedCoreBind])) +typecheckCoreModule dflags pcs hst mod_iface decls + = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $ + (tcCoreDecls this_mod decls `thenTc` \ (env,bs) -> + zonkCoreBinds bs `thenNF_Tc` \ bs' -> + returnTc (env, bs')) + +-- ; printIfaceDump dflags maybe_tc_stuff + + -- Q: Is it OK not to extend PCS here? + -- (in the event that it needs to be, I'm returning the PCS passed in.) + ; case maybe_tc_stuff of + Nothing -> return Nothing + Just (e,bs) -> return (Just (pcs, e, bs)) } + where + this_mod = mi_module mod_iface + core_decls = [d | (TyClD d) <- decls, isCoreDecl d] + +tcCoreDecls :: Module + -> [RenamedHsDecl] -- All interface-file decls + -> TcM (TypeEnv, [TypecheckedCoreBind]) +tcCoreDecls this_mod decls +-- The decls are all TyClD declarations coming from External Core input. + = let + tycl_decls = [d | TyClD d <- decls] + core_decls = filter isCoreDecl tycl_decls + in + fixTc (\ ~(unf_env, _) -> + -- This fixTc follows the same general plan as tcImports, + -- which is better commented. + -- [ Q: do we need to tie a knot for External Core? ] + tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things -> + tcExtendGlobalEnv tycl_things $ + tcCoreBinds tycl_decls `thenTc` \ core_binds -> + tcGetEnv `thenTc` \ env -> + returnTc (env, core_binds) + ) `thenTc` \ ~(final_env,bs) -> + let + src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env)) + in + returnTc (mkTypeEnv src_things, bs) + +\end{code} + %************************************************************************ %* * -- 1.7.10.4