+data HscChecked
+ = HscChecked
+ -- parsed
+ (Located (HsModule RdrName))
+ -- renamed
+ (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
+ -- typechecked
+ (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
+
+
+-- Status of a compilation to hard-code or nothing.
+data HscStatus
+ = HscNoRecomp
+ | HscRecomp Bool -- Has stub files.
+ -- This is a hack. We can't compile C files here
+ -- since it's done in DriverPipeline. For now we
+ -- just return True if we want the caller to compile
+ -- it for us.
+
+-- Status of a compilation to byte-code.
+data InteractiveStatus
+ = InteractiveNoRecomp
+ | InteractiveRecomp Bool -- Same as HscStatus
+ CompiledByteCode
+
+
+-- I want Control.Monad.State! --Lemmih 03/07/2006
+newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)}
+
+instance Monad Comp where
+ g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s'
+ return a = Comp $ \s -> return (a,s)
+ fail = error
+
+evalComp :: Comp a -> CompState -> IO a
+evalComp comp st = do (val,_st') <- runComp comp st
+ return val
+
+data CompState
+ = CompState
+ { compHscEnv :: HscEnv
+ , compModSummary :: ModSummary
+ , compOldIface :: Maybe ModIface
+ }
+
+get :: Comp CompState
+get = Comp $ \s -> return (s,s)
+
+gets :: (CompState -> a) -> Comp a
+gets getter = do st <- get
+ return (getter st)
+
+liftIO :: IO a -> Comp a
+liftIO ioA = Comp $ \s -> do a <- ioA
+ return (a,s)
+
+type NoRecomp result = ModIface -> Comp result
+type FrontEnd core = Comp (Maybe core)
+
+-- FIXME: The old interface and module index are only using in 'batch' and
+-- 'interactive' mode. They should be removed from 'oneshot' mode.
+type Compiler result = HscEnv
+ -> ModSummary
+ -> Bool -- True <=> source unchanged
+ -> Maybe ModIface -- Old interface, if available
+ -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
+ -> IO (Maybe result)
+
+
+-- This functions checks if recompilation is necessary and
+-- then combines the FrontEnd and BackEnd to a working compiler.
+hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required.
+ -> (Maybe (Int,Int) -> Bool -> Comp ())
+ -> FrontEnd core
+ -> (core -> Comp result) -- Backend.
+ -> Compiler result
+hscMkCompiler norecomp messenger frontend backend
+ hsc_env mod_summary source_unchanged
+ mbOldIface mbModIndex
+ = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
+ do (recomp_reqd, mbCheckedIface)
+ <- {-# SCC "checkOldIface" #-}
+ liftIO $ checkOldIface hsc_env mod_summary
+ source_unchanged mbOldIface
+ case mbCheckedIface of
+ Just iface | not recomp_reqd
+ -> do messenger mbModIndex False
+ result <- norecomp iface
+ return (Just result)
+ _otherwise
+ -> do messenger mbModIndex True
+ mbCore <- frontend
+ case mbCore of
+ Nothing
+ -> return Nothing
+ Just core
+ -> do result <- backend core
+ return (Just result)
+
+--------------------------------------------------------------
+-- Compilers
+--------------------------------------------------------------
+
+-- 1 2 3 4 5 6 7 8 9
+-- Compile Haskell, boot and extCore in OneShot mode.
+hscCompileOneShot :: Compiler HscStatus
+hscCompileOneShot hsc_env mod_summary =
+ compiler hsc_env mod_summary
+ where mkComp = hscMkCompiler (norecompOneShot HscNoRecomp) oneShotMsg
+ -- How to compile nonBoot files.
+ nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
+ hscWriteIface >>= hscOneShot
+ -- How to compile boot files.
+ bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False)
+ compiler
+ = case ms_hsc_src mod_summary of
+ ExtCoreFile
+ -> mkComp hscCoreFrontEnd nonBootComp
+ HsSrcFile
+ -> mkComp hscFileFrontEnd nonBootComp
+ HsBootFile
+ -> mkComp hscFileFrontEnd bootComp
+
+-- Compile Haskell, boot and extCore in batch mode.
+hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
+hscCompileBatch hsc_env mod_summary
+ = compiler hsc_env mod_summary
+ where mkComp = hscMkCompiler norecompBatch (batchMsg False)
+ nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
+ hscWriteIface >>= hscBatch
+ bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
+ compiler
+ = case ms_hsc_src mod_summary of
+ ExtCoreFile
+ -> mkComp hscCoreFrontEnd nonBootComp
+ HsSrcFile
+ -> mkComp hscFileFrontEnd nonBootComp
+ HsBootFile
+ -> mkComp hscFileFrontEnd bootComp
+
+-- Type-check Haskell, boot and extCore.
+hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
+hscCompileNothing hsc_env mod_summary
+ = compiler hsc_env mod_summary
+ where mkComp = hscMkCompiler norecompBatch (batchMsg False)
+ pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing
+ compiler
+ = case ms_hsc_src mod_summary of
+ ExtCoreFile
+ -> mkComp hscCoreFrontEnd pipeline
+ HsSrcFile
+ -> mkComp hscFileFrontEnd pipeline
+ HsBootFile
+ -> mkComp hscFileFrontEnd pipeline
+
+-- Compile Haskell, extCore to bytecode.
+hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
+hscCompileInteractive hsc_env mod_summary =
+ hscMkCompiler norecompInteractive (batchMsg True)
+ frontend backend
+ hsc_env mod_summary
+ where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
+ frontend = case ms_hsc_src mod_summary of
+ ExtCoreFile -> hscCoreFrontEnd
+ HsSrcFile -> hscFileFrontEnd
+ HsBootFile -> panic bootErrorMsg
+ bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
+ "Use 'hscCompileBatch' instead."
+
+--------------------------------------------------------------
+-- NoRecomp handlers
+--------------------------------------------------------------
+
+norecompOneShot :: a -> NoRecomp a
+norecompOneShot a old_iface
+ = do hsc_env <- gets compHscEnv
+ liftIO $ do
+ dumpIfaceStats hsc_env
+ return a
+
+norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
+norecompBatch = norecompWorker HscNoRecomp False
+
+norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
+norecompInteractive = norecompWorker InteractiveNoRecomp True
+
+norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
+norecompWorker a isInterp old_iface
+ = do hsc_env <- gets compHscEnv
+ mod_summary <- gets compModSummary
+ liftIO $ do
+ new_details <- {-# SCC "tcRnIface" #-}
+ initIfaceCheck hsc_env $
+ typecheckIface old_iface
+ dumpIfaceStats hsc_env
+ return (a, old_iface, new_details)
+
+--------------------------------------------------------------
+-- 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!