+--------------------------------------------------------------
+-- Progress displayers.
+--------------------------------------------------------------
+
+oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp ()
+oneShotMsg _mb_mod_index recomp
+ = do hsc_env <- gets compHscEnv
+ liftIO $ do
+ if recomp
+ then return ()
+ else compilationProgressMsg (hsc_dflags hsc_env) $
+ "compilation IS NOT required"
+
+batchMsg :: Bool -> Maybe (Int,Int) -> Bool -> Comp ()
+batchMsg toInterp mb_mod_index recomp
+ = do hsc_env <- gets compHscEnv
+ mod_summary <- gets compModSummary
+ let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
+ (showModuleIndex mb_mod_index ++
+ msg ++ showModMsg (not toInterp) mod_summary)
+ liftIO $ do
+ if recomp
+ then showMsg "Compiling "
+ else showMsg "Skipping "
+
+
+
+--------------------------------------------------------------
+-- FrontEnds
+--------------------------------------------------------------
+
+hscCoreFrontEnd :: FrontEnd ModGuts
+hscCoreFrontEnd =
+ do hsc_env <- gets compHscEnv
+ mod_summary <- gets compModSummary
+ liftIO $ do
+ -------------------
+ -- PARSE
+ -------------------
+ inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
+ case parseCore inp 1 of
+ FailP s
+ -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
+ return Nothing
+ OkP rdr_module
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
+ tcRnExtCore hsc_env rdr_module
+ printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
+ case maybe_tc_result of
+ Nothing -> return Nothing
+ Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
+
+
+hscFileFrontEnd :: FrontEnd ModGuts
+hscFileFrontEnd =
+ do hsc_env <- gets compHscEnv
+ mod_summary <- gets compModSummary
+ liftIO $ do
+ -------------------
+ -- PARSE
+ -------------------
+ let dflags = hsc_dflags hsc_env
+ hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+ hspp_buf = ms_hspp_buf mod_summary
+ maybe_parsed <- myParseModule dflags hspp_file hspp_buf
+ case maybe_parsed of
+ Left err
+ -> do printBagOfErrors dflags (unitBag err)
+ return Nothing
+ Right rdr_module
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ -> do (tc_msgs, maybe_tc_result)
+ <- {-# SCC "Typecheck-Rename" #-}
+ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
+ printErrorsAndWarnings dflags tc_msgs
+ case maybe_tc_result of
+ Nothing
+ -> return Nothing
+ Just tc_result
+ -------------------
+ -- DESUGAR
+ -------------------
+ -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
+ deSugar hsc_env tc_result
+ printBagOfWarnings dflags warns
+ return maybe_ds_result
+
+--------------------------------------------------------------
+-- Simplifiers
+--------------------------------------------------------------
+
+hscSimplify :: ModGuts -> Comp ModGuts
+hscSimplify ds_result
+ = do hsc_env <- gets compHscEnv
+ liftIO $ do
+ flat_result <- {-# SCC "Flattening" #-}
+ flatten hsc_env ds_result
+ -------------------
+ -- SIMPLIFY
+ -------------------
+ simpl_result <- {-# SCC "Core2Core" #-}
+ core2core hsc_env flat_result
+ return simpl_result
+
+--------------------------------------------------------------
+-- Interface generators
+--------------------------------------------------------------
+
+-- HACK: we return ModGuts even though we know it's not gonna be used.
+-- We do this because the type signature needs to be identical
+-- in structure to the type of 'hscNormalIface'.
+hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
+hscSimpleIface ds_result
+ = do hsc_env <- gets compHscEnv
+ mod_summary <- gets compModSummary
+ maybe_old_iface <- gets compOldIface
+ liftIO $ do
+ details <- mkBootModDetails hsc_env ds_result