import HsSyn
import StringBuffer ( hGetStringBuffer )
-import Parser ( parse )
+import Parser
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelNames ( knownKeyNames )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
- writeIface )
+ writeIface, pprIface )
import TcModule ( TcResults(..), typecheckModule )
import InstEnv ( emptyInstEnv )
import Desugar ( deSugar )
import Name ( emptyNameEnv )
import Module ( Module, lookupModuleEnvByName )
+import Monad ( when )
\end{code}
hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
= do {
- putStrLn "CHECKING OLD IFACE";
+ putStrLn ("CHECKING OLD IFACE for hs = " ++ show (ml_hs_file location)
+ ++ ", hspp = " ++ show (ml_hspp_file location));
+
(pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
<- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain")
source_unchanged maybe_old_iface;
let old_iface = case maybe_checked_iface of
Just old_if -> old_if
Nothing -> panic "hscNoRecomp:old_iface"
- this_mod = mi_module old_iface
;
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
else do {
-- TYPECHECK
- maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst
+ maybe_tc_result <- typecheckModule dflags pcs_cl hst
old_iface alwaysQualify cl_hs_decls;
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
- Just tc_result -> do {
+ Just (pcs_tc, tc_result) -> do {
- let pcs_tc = tc_pcs tc_result
- env_tc = tc_env tc_result
+ let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
<- renameModule dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
Nothing -> return (HscFail pcs_rn);
- Just (print_unqualified, new_iface, rn_hs_decls) -> do {
+ Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
-------------------
-- TYPECHECK
-------------------
- ; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface
+ ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface
print_unqualified rn_hs_decls
; case maybe_tc_result of {
- Nothing -> do { hPutStrLn stderr "Typechecked failed"
+ Nothing -> do { hPutStrLn stderr "Typecheck failed"
; return (HscFail pcs_rn) } ;
- Just tc_result -> do {
+ Just (pcs_tc, tc_result) -> do {
- ; let pcs_tc = tc_pcs tc_result
- env_tc = tc_env tc_result
+ ; let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
-------------------
-- We grab the the unfoldings at this point.
- ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod
- print_unqualified tc_result hst
+ ; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod
+ print_unqualified is_exported tc_result
; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-------------------
mkFinalIface dflags location maybe_old_iface new_iface new_details
= case completeIface maybe_old_iface new_iface new_details of
(new_iface, Nothing) -- no change in the interfacfe
- -> do if dopt Opt_D_dump_hi_diffs dflags then
- printDump (text "INTERFACE UNCHANGED")
- else return ()
+ -> do when (dopt Opt_D_dump_hi_diffs dflags)
+ (printDump (text "INTERFACE UNCHANGED"))
+ dumpIfSet_dyn dflags Opt_D_dump_hi
+ "UNCHANGED FINAL INTERFACE" (pprIface new_iface)
return new_iface
- (new_iface, Just sdoc)
- -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "NEW INTERFACE" sdoc
+ (new_iface, Just sdoc_diffs)
+ -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs
+ dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface)
-- Write the interface file
writeIface (unJust (ml_hi_file location) "hscRecomp:hi") new_iface
return new_iface
PFailed err -> do { hPutStrLn stderr (showSDoc err);
return Nothing };
- POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
+
+ POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do {
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
(ppr nm)
-dsThenSimplThenTidy dflags rule_base this_mod print_unqual tc_result hst
+dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
= do -------------------------- Desugaring ----------------
-- _scc_ "DeSugar"
(desugared, rules, h_code, c_code, fe_binders)
- <- deSugar dflags this_mod print_unqual hst tc_result
+ <- deSugar dflags pcs hst this_mod print_unqual tc_result
-------------------------- Main Core-language transformations ----------------
-- _scc_ "Core2Core"
(simplified, orphan_rules)
- <- core2core dflags rule_base hst desugared rules
+ <- core2core dflags pcs hst is_exported desugared rules
-- Do the final tidy-up
(tidy_binds, tidy_orphan_rules)
%************************************************************************
%* *
+\subsection{Compiling an expression}
+%* *
+%************************************************************************
+
+hscExpr
+ :: DynFlags
+ -> HomeSymbolTable
+ -> HomeIfaceTable
+ -> PersistentCompilerState -- IN: persistent compiler state
+ -> Module -- Context for compiling
+ -> String -- The expression
+ -> IO HscResult
+
+hscExpr dflags hst hit pcs this_module expr
+ = do { -- Parse it
+ let unqual = unQualInScope
+ ; maybe_parsed <- myParseExpr dflags expr
+ ; case maybe_parsed of {
+ Nothing -> return (HscFail pcs_ch);
+ Just parsed_expr -> do {
+
+ -- Rename it
+ (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
+ ; case maybe_renamed_expr of {
+ Nothing -> FAIL
+ Just (print_unqual, rn_expr) ->
+
+ -- Typecheck it
+ maybe_tc_expr <- typecheckExpr dflags pcs hst print_unqual rn_expr
+ ; case maybe_tc_expr of
+ Nothing -> FAIL
+ Just tc_expr ->
+
+ -- Desugar it
+ ; ds_expr <- deSugarExpr dflags pcs hst this_module print_unqual tc_expr
+
+ -- Simplify it
+ ; simpl_expr <- simplifyExpr dflags pcs hst ds_expr
+
+ ; return I'M NOT SURE
+ }
+
+
+
+
+%************************************************************************
+%* *
\subsection{Initial persistent state}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff