From: Thomas Schilling Date: Fri, 28 Nov 2008 10:36:28 +0000 (+0000) Subject: Use a per-session data structure for callbacks. Make 'WarnErrLogger' X-Git-Tag: 2009-03-13~385 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9a4607c35c107bca78f08f7e57896044c66118be Use a per-session data structure for callbacks. Make 'WarnErrLogger' part of it. Part of the GHC API essentially represents a compilation framework. The difference of a *framework* as opposed to a *library* is that the overall structure of the functionality is pre-defined but certain details can be customised via callbacks. (Also known as the Hollywood Principle: "Don't call us, we'll call you.") This patch introduces a per-session data structure that contains all the callbacks instead of adding lots of small function arguments whenever we want to give the user more control over certain parts of the API. This should also help with future changes: Adding a new callback doesn't break old code since code that doesn't know about the new callback will use the (hopefully sane) default implementation. Overall, however, we should try and keep the number of callbacks small and well-defined (and provide useful defaults) and use simple library routines for the rest. --- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8ac38ae..df415b6 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -17,7 +17,7 @@ module GHC ( gcatch, gbracket, gfinally, clearWarnings, getWarnings, hasWarnings, printExceptionAndWarnings, printWarnings, - handleSourceError, + handleSourceError, defaultCallbacks, GhcApiCallbacks(..), -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, @@ -467,10 +467,17 @@ initGhcMonad mb_top_dir = do dflags0 <- liftIO $ initDynFlags defaultDynFlags dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv dflags + env <- liftIO $ newHscEnv defaultCallbacks dflags setSession env clearWarnings +defaultCallbacks :: GhcApiCallbacks +defaultCallbacks = + GhcApiCallbacks { + reportModuleCompilationResult = + \_ mb_err -> defaultWarnErrLogger mb_err + } + -- ----------------------------------------------------------------------------- -- Flags & settings @@ -664,8 +671,9 @@ data LoadHowMuch -- the actual compilation starts (e.g., during dependency analysis). -- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = - loadWithLogger defaultWarnErrLogger how_much +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () @@ -691,12 +699,13 @@ loadWithLogger logger how_much = do -- even if we don't get a fully successful upsweep, the full module -- graph is still retained in the Session. We can tell which modules -- were successfully loaded by inspecting the Session's HPT. - mod_graph <- depanal [] False - load2 how_much mod_graph logger + withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = + \_ -> logger }) $ + load how_much -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> m SuccessFlag -load2 how_much mod_graph logger = do +load2 how_much mod_graph = do guessOutputFile hsc_env <- getSession @@ -823,8 +832,7 @@ load2 how_much mod_graph logger = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep logger - (hsc_env { hsc_HPT = emptyHomePackageTable }) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now @@ -1433,8 +1441,7 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: GhcMonad m => - WarnErrLogger -- ^ Called to print warnings and errors. - -> HscEnv -- ^ Includes initially-empty HPT + HscEnv -- ^ Includes initially-empty HPT -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> IO () -- ^ How to clean up unwanted tmp files @@ -1443,7 +1450,7 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do +upsweep hsc_env old_hpt stable_mods cleanup sccs = do (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) return (res, hsc_env, reverse done) where @@ -1462,13 +1469,14 @@ upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger = reportModuleCompilationResult (hsc_callbacks hsc_env) mb_mod_info <- handleSourceError - (\err -> do logger (Just err); return Nothing) $ do + (\err -> do logger mod (Just err); return Nothing) $ do mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod mod_index nmods - logger Nothing -- log warnings + logger mod Nothing -- log warnings return (Just mod_info) liftIO cleanup -- Remove unwanted tmp files between compilations diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 6aeaea2..dca1fef 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -125,8 +125,8 @@ import Data.IORef %************************************************************************ \begin{code} -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags +newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv +newHscEnv callbacks dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) @@ -134,6 +134,7 @@ newHscEnv dflags ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, + hsc_callbacks = callbacks, hsc_targets = [], hsc_mod_graph = [], hsc_IC = emptyInteractiveContext, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1d3f4dc..c187932 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -23,6 +23,8 @@ module HscTypes ( FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, + -- ** Callbacks + GhcApiCallbacks(..), withLocalCallbacks, -- * Information about modules ModDetails(..), emptyModDetails, @@ -442,7 +444,49 @@ mkFlagWarning (L loc warn) \end{code} \begin{code} --- | HscEnv is like 'Session', except that some of the fields are immutable. +-- | These functions are called in various places of the GHC API. +-- +-- API clients can override any of these callbacks to change GHC's default +-- behaviour. +data GhcApiCallbacks + = GhcApiCallbacks { + + -- | Called by 'load' after the compilating of each module. + -- + -- The default implementation simply prints all warnings and errors to + -- @stderr@. Don't forget to call 'clearWarnings' when implementing your + -- own call. + -- + -- The first argument is the module that was compiled. + -- + -- The second argument is @Nothing@ if no errors occured, but there may + -- have been warnings. If it is @Just err@ at least one error has + -- occured. If 'srcErrorMessages' is empty, compilation failed due to + -- @-Werror@. + reportModuleCompilationResult :: GhcMonad m => + ModSummary -> Maybe SourceError + -> m () + } + +-- | Temporarily modify the callbacks. After the action is executed all +-- callbacks are reset (not, however, any other modifications to the session +-- state.) +withLocalCallbacks :: GhcMonad m => + (GhcApiCallbacks -> GhcApiCallbacks) + -> m a -> m a +withLocalCallbacks f m = do + hsc_env <- getSession + let cb0 = hsc_callbacks hsc_env + let cb' = f cb0 + setSession (hsc_env { hsc_callbacks = cb' `seq` cb' }) + r <- m + setSession (hsc_env { hsc_callbacks = cb0 }) + return r + +\end{code} + +\begin{code} +-- | Hscenv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. Things like -- the module graph don't change during a single compilation. @@ -457,6 +501,9 @@ data HscEnv hsc_dflags :: DynFlags, -- ^ The dynamic flag settings + hsc_callbacks :: GhcApiCallbacks, + -- ^ Callbacks for the GHC API. + hsc_targets :: [Target], -- ^ The targets (or roots) of the current session diff --git a/ghc/Main.hs b/ghc/Main.hs index 06a5ceb..df90857 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -16,7 +16,8 @@ module Main (main) where import qualified GHC import GHC ( DynFlags(..), HscTarget(..), GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) + LoadHowMuch(..), dopt, DynFlag(..), + defaultCallbacks ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -515,7 +516,7 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv dflags + hsc_env <- newHscEnv defaultCallbacks dflags showIface hsc_env file -- ---------------------------------------------------------------------------