From c8ac9561bc2bef1d92940b3a6aa2078c9c4716d4 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Sun, 23 Oct 2016 18:49:54 -0700 Subject: [PATCH] Refactoring of logging code + #2727 --- src/Stack/Options/GlobalParser.hs | 5 + src/Stack/PrettyPrint.hs | 20 ++-- src/Stack/Runners.hs | 14 +-- src/Stack/Setup.hs | 2 +- src/Stack/Types/Config.hs | 8 +- src/Stack/Types/Internal.hs | 44 ++++---- src/Stack/Types/StackT.hs | 171 ++++++++---------------------- src/main/Main.hs | 2 +- 8 files changed, 93 insertions(+), 173 deletions(-) diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs index 58491184d2..a9a94a3629 100644 --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -22,6 +22,10 @@ globalOptsParser kind defLogLevel = optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> (First <$> logLevelOptsParser hide0 defLogLevel) <*> + firstBoolFlags + "time-in-log" + "inclusion of timings in logs, for the purposes of using diff with logs" + hide <*> configOptsParser kind <*> optionalFirst (abstractResolverOptsParser hide0) <*> optionalFirst (compilerOptsParser hide0) <*> @@ -46,6 +50,7 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts { globalReExecVersion = getFirst globalMonoidReExecVersion , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel + , globalTimeInLog = fromFirst True globalMonoidTimeInLog , globalConfigMonoid = globalMonoidConfigMonoid , globalResolver = getFirst globalMonoidResolver , globalCompiler = getFirst globalMonoidCompiler diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index ab7e2ddafe..110deaeaee 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -7,7 +7,7 @@ module Stack.PrettyPrint ( -- * Pretty printing functions - displayPlain, displayAnsiIfPossible + displayPlain, displayWithColor -- * Logging based on pretty-print typeclass , prettyDebug, prettyInfo, prettyWarn, prettyError , debugBracket @@ -43,11 +43,11 @@ import Stack.Types.Version import qualified System.Clock as Clock import Text.PrettyPrint.Leijen.Extended -displayAnsiIfPossible - :: (HasTerminal env, MonadReader env m, Display a, HasAnsiAnn (Ann a)) +displayWithColor + :: (HasLogOptions env, MonadReader env m, Display a, HasAnsiAnn (Ann a)) => a -> m T.Text -displayAnsiIfPossible x = do - useAnsi <- asks getAnsiTerminal +displayWithColor x = do + useAnsi <- asks (logUseColor . getLogOptions) return $ if useAnsi then displayAnsi x else displayPlain x -- TODO: switch to using implicit callstacks once 7.8 support is dropped @@ -55,28 +55,28 @@ displayAnsiIfPossible x = do prettyDebug :: Q Exp prettyDebug = do loc <- location - [e| monadLoggerLog loc "" LevelDebug <=< displayAnsiIfPossible |] + [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor |] prettyInfo :: Q Exp prettyInfo = do loc <- location - [e| monadLoggerLog loc "" LevelInfo <=< displayAnsiIfPossible |] + [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor |] prettyWarn :: Q Exp prettyWarn = do loc <- location - [e| monadLoggerLog loc "" LevelWarn <=< displayAnsiIfPossible . (line <>) . (warningYellow "Warning:" <+>) |] + [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningYellow "Warning:" <+>) |] prettyError :: Q Exp prettyError = do loc <- location - [e| monadLoggerLog loc "" LevelError <=< displayAnsiIfPossible . (line <>) . (errorRed "Error:" <+>) |] + [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorRed "Error:" <+>) |] debugBracket :: Q Exp debugBracket = do loc <- location [e| \msg f -> do - let output = monadLoggerLog loc "" LevelDebug <=< displayAnsiIfPossible + let output = monadLoggerLog loc "" LevelDebug <=< displayWithColor output $ "Start: " <> msg start <- liftIO $ Clock.getTime Clock.Monotonic x <- f `catch` \ex -> do diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index f14cc11cbb..e7c88b0273 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -41,10 +41,10 @@ import System.FileLock loadCompilerVersion :: Manager -> GlobalOpts - -> LoadConfig (StackLoggingT IO) + -> LoadConfig (StackT () IO) -> IO CompilerVersion loadCompilerVersion manager go lc = do - bconfig <- runStackLoggingTGlobal manager go $ + bconfig <- runStackTGlobal manager () go $ lcLoadBuildConfig lc (globalCompiler go) return $ bcWantedCompiler bconfig @@ -111,7 +111,7 @@ withGlobalConfigAndLock -> IO () withGlobalConfigAndLock go@GlobalOpts{..} inner = do manager <- getGlobalManager - lc <- runStackLoggingTGlobal manager go $ + lc <- runStackTGlobal manager () go $ loadConfigMaybeProject globalConfigMonoid Nothing Nothing withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> runStackTGlobal manager (lcConfig lc) go inner @@ -168,7 +168,7 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do inner lk2 let inner'' lk = do - bconfig <- runStackLoggingTGlobal manager go $ + bconfig <- runStackTGlobal manager () go $ lcLoadBuildConfig lc globalCompiler envConfig <- runStackTGlobal @@ -194,11 +194,11 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do -- | Load the configuration with a manager. Convenience function used -- throughout this module. -loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO)) +loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackT () IO)) loadConfigWithOpts go@GlobalOpts{..} = do manager <- getGlobalManager mstackYaml <- forM globalStackYaml resolveFile' - lc <- runStackLoggingTGlobal manager go $ do + lc <- runStackTGlobal manager () go $ do lc <- loadConfig globalConfigMonoid globalResolver mstackYaml -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must @@ -215,7 +215,7 @@ withMiniConfigAndLock -> IO () withMiniConfigAndLock go@GlobalOpts{..} inner = do manager <- getGlobalManager - miniConfig <- runStackLoggingTGlobal manager go $ do + miniConfig <- runStackTGlobal manager () go $ do lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing loadMiniConfig manager (lcConfig lc) runStackTGlobal manager miniConfig go inner diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index f60f76aa0d..0f0f0ec8aa 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1216,7 +1216,7 @@ bootGhcjs ghcjsVersion stackYaml destDir = do loadGhcjsEnvConfig :: StackM env m => Path Abs File -> Path b t -> m EnvConfig -loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do +loadGhcjsEnvConfig stackYaml binPath = runInnerStackT () $ do lc <- loadConfig (mempty { configMonoidInstallGHC = First (Just True) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 79bc9c5bf5..d97e9ab460 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -206,23 +206,23 @@ import qualified Options.Applicative.Types as OA import Path import qualified Paths_stack as Meta import Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash) -import Stack.Types.Urls import Stack.Types.Compiler import Stack.Types.Docker -import Stack.Types.Nix import Stack.Types.FlagName import Stack.Types.Image +import Stack.Types.Nix import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.TemplateName +import Stack.Types.Urls import Stack.Types.Version import System.FilePath (takeBaseName) import System.PosixCompat.Types (UserID, GroupID, FileMode) import System.Process.Read (EnvOverride, findExecutable) -- Re-exports -import Stack.Types.Config.Build as X +import Stack.Types.Config.Build as X #ifdef mingw32_HOST_OS import qualified Crypto.Hash.SHA1 as SHA1 @@ -427,6 +427,7 @@ data GlobalOpts = GlobalOpts , globalDockerEntrypoint :: !(Maybe DockerEntrypoint) -- ^ Data used when stack is acting as a Docker entrypoint (internal use only) , globalLogLevel :: !LogLevel -- ^ Log level + , globalTimeInLog :: !Bool -- ^ Whether to include timings in logs. , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override , globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override @@ -440,6 +441,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidDockerEntrypoint :: !(First DockerEntrypoint) -- ^ Data used when stack is acting as a Docker entrypoint (internal use only) , globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level + , globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs. , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override , globalMonoidCompiler :: !(First CompilerVersion) -- ^ Compiler override diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index 07a581d48a..90443c1bd9 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -15,13 +15,12 @@ import Stack.Types.Config -- | Monadic environment. data Env config = Env {envConfig :: !config - ,envLogLevel :: !LogLevel - ,envTerminal :: !Bool - ,envAnsiTerminal :: !Bool ,envReExec :: !Bool ,envManager :: !Manager + ,envLogOptions :: !LogOptions + ,envTerminal :: !Bool ,envSticky :: !Sticky - ,envSupportsUnicode :: !Bool} + } instance HasStackRoot config => HasStackRoot (Env config) where getStackRoot = getStackRoot . envConfig @@ -40,22 +39,11 @@ instance HasEnvConfig config => HasEnvConfig (Env config) where instance HasHttpManager (Env config) where getHttpManager = envManager -class HasLogLevel r where - getLogLevel :: r -> LogLevel - -instance HasLogLevel (Env config) where - getLogLevel = envLogLevel - -instance HasLogLevel LogLevel where - getLogLevel = id - class HasTerminal r where getTerminal :: r -> Bool - getAnsiTerminal :: r -> Bool instance HasTerminal (Env config) where getTerminal = envTerminal - getAnsiTerminal = envAnsiTerminal class HasReExec r where getReExec :: r -> Bool @@ -63,22 +51,30 @@ class HasReExec r where instance HasReExec (Env config) where getReExec = envReExec -class HasSupportsUnicode r where - getSupportsUnicode :: r -> Bool - -instance HasSupportsUnicode (Env config) where - getSupportsUnicode = envSupportsUnicode - newtype Sticky = Sticky - { unSticky :: Maybe (MVar (Maybe Text)) - } + { unSticky :: Maybe (MVar (Maybe Text)) + } class HasSticky r where - getSticky :: r -> Sticky + getSticky :: r -> Sticky instance HasSticky (Env config) where getSticky = envSticky +data LogOptions = LogOptions + { logUseColor :: Bool + , logUseUnicode :: Bool + , logUseTime :: Bool + , logMinLevel :: LogLevel + , logVerboseFormat :: Bool + } + +class HasLogOptions r where + getLogOptions :: r -> LogOptions + +instance HasLogOptions (Env config) where + getLogOptions = envLogOptions + envEnvConfig :: Lens' (Env EnvConfig) EnvConfig envEnvConfig = lens envConfig (\s t -> s {envConfig = t}) diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs index bc848ecfdb..bc9536e501 100644 --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -16,15 +16,11 @@ module Stack.Types.StackT (StackT - ,StackLoggingT ,HasEnv ,StackM ,runStackT ,runStackTGlobal - ,runStackLoggingT - ,runStackLoggingTGlobal ,runInnerStackT - ,runInnerStackLoggingT ,logSticky ,logStickyDone) where @@ -69,8 +65,8 @@ import System.Log.FastLogger import System.Locale #endif -type HasEnv r = (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r - , HasSticky r, HasSupportsUnicode r) +-- | Constraint synonym for all of the common environment instances +type HasEnv r = (HasHttpManager r, HasLogOptions r, HasTerminal r, HasReExec r, HasSticky r) -- | Constraint synonym for constraints commonly satisifed by monads used in stack. type StackM r m = @@ -107,20 +103,27 @@ instance MonadIO m => MonadLoggerIO (StackT config m) where runStackTGlobal :: (MonadIO m) => Manager -> config -> GlobalOpts -> StackT config m a -> m a runStackTGlobal manager config GlobalOpts{..} = - runStackT manager globalLogLevel config globalTerminal (isJust globalReExecVersion) + runStackT manager config globalLogLevel globalTimeInLog globalTerminal (isJust globalReExecVersion) --- | Run a Stack action. runStackT :: (MonadIO m) - => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a -runStackT manager logLevel config terminal reExec m = do + => Manager -> config -> LogLevel -> Bool -> Bool -> Bool -> StackT config m a -> m a +runStackT manager config logLevel useTime terminal reExec m = do ansiTerminal <- liftIO $ hSupportsANSI stderr canUseUnicode <- liftIO getCanUseUnicode - withSticky - terminal - (\sticky -> - runReaderT - (unStackT m) - (Env config logLevel terminal ansiTerminal reExec manager sticky canUseUnicode)) + withSticky terminal $ \sticky -> runReaderT (unStackT m) Env + { envConfig = config + , envReExec = reExec + , envManager = manager + , envLogOptions = LogOptions + { logUseColor = ansiTerminal + , logUseUnicode = canUseUnicode + , logUseTime = useTime + , logMinLevel = logLevel + , logVerboseFormat = logLevel <= LevelDebug + } + , envTerminal = terminal + , envSticky = sticky + } -- | Taken from GHC: determine if we should use Unicode syntax getCanUseUnicode :: IO Bool @@ -132,105 +135,22 @@ getCanUseUnicode = do return (str == str') test `catchIOError` \_ -> return False --------------------------------------------------------------------------------- --- Logging only StackLoggingT monad transformer - --- | Monadic environment for 'StackLoggingT'. -data LoggingEnv = LoggingEnv - { lenvLogLevel :: !LogLevel - , lenvTerminal :: !Bool - , lenvAnsiTerminal :: !Bool - , lenvReExec :: !Bool - , lenvManager :: !Manager - , lenvSticky :: !Sticky - , lenvSupportsUnicode :: !Bool - } - --- | The monad used for logging in the executable @stack@ before --- anything has been initialized. -newtype StackLoggingT m a = StackLoggingT - { unStackLoggingT :: ReaderT LoggingEnv m a - } deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader LoggingEnv,MonadCatch,MonadMask,MonadTrans) - -deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m) - -instance MonadBaseControl b m => MonadBaseControl b (StackLoggingT m) where - type StM (StackLoggingT m) a = ComposeSt StackLoggingT m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance MonadTransControl StackLoggingT where - type StT StackLoggingT a = StT (ReaderT LoggingEnv) a - liftWith = defaultLiftWith StackLoggingT unStackLoggingT - restoreT = defaultRestoreT StackLoggingT - --- | Takes the configured log level into account. -instance (MonadIO m) => MonadLogger (StackLoggingT m) where - monadLoggerLog = stickyLoggerFunc - -instance HasSticky LoggingEnv where - getSticky = lenvSticky - -instance HasLogLevel LoggingEnv where - getLogLevel = lenvLogLevel - -instance HasHttpManager LoggingEnv where - getHttpManager = lenvManager - -instance HasTerminal LoggingEnv where - getTerminal = lenvTerminal - getAnsiTerminal = lenvAnsiTerminal - -instance HasReExec LoggingEnv where - getReExec = lenvReExec - -instance HasSupportsUnicode LoggingEnv where - getSupportsUnicode = lenvSupportsUnicode - runInnerStackT :: (HasEnv r, MonadReader r m, MonadIO m) => config -> StackT config IO a -> m a runInnerStackT config inner = do - manager <- asks getHttpManager - logLevel <- asks getLogLevel - terminal <- asks getTerminal reExec <- asks getReExec - liftIO $ runStackT manager logLevel config terminal reExec inner - -runInnerStackLoggingT :: (HasEnv r, MonadReader r m, MonadIO m) - => StackLoggingT IO a -> m a -runInnerStackLoggingT inner = do manager <- asks getHttpManager - logLevel <- asks getLogLevel + logOptions <- asks getLogOptions terminal <- asks getTerminal - reExec <- asks getReExec - liftIO $ runStackLoggingT manager logLevel terminal reExec inner - --- | Run the logging monad, using global options. -runStackLoggingTGlobal :: MonadIO m - => Manager -> GlobalOpts -> StackLoggingT m a -> m a -runStackLoggingTGlobal manager GlobalOpts{..} = - runStackLoggingT manager globalLogLevel globalTerminal (isJust globalReExecVersion) - --- | Run the logging monad. -runStackLoggingT :: MonadIO m - => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a -runStackLoggingT manager logLevel terminal reExec m = do - ansiTerminal <- liftIO $ hSupportsANSI stderr - canUseUnicode <- liftIO getCanUseUnicode - withSticky - terminal - (\sticky -> - runReaderT - (unStackLoggingT m) - LoggingEnv - { lenvLogLevel = logLevel - , lenvManager = manager - , lenvSticky = sticky - , lenvTerminal = terminal - , lenvAnsiTerminal = ansiTerminal - , lenvReExec = reExec - , lenvSupportsUnicode = canUseUnicode - }) + sticky <- asks getSticky + liftIO $ runReaderT (unStackT inner) Env + { envConfig = config + , envReExec = reExec + , envManager = manager + , envLogOptions = logOptions + , envTerminal = terminal + , envSticky = sticky + } -------------------------------------------------------------------------------- -- Logging functionality @@ -246,21 +166,18 @@ getStickyLoggerFunc => m (Loc -> LogSource -> LogLevel -> msg -> IO ()) getStickyLoggerFunc = do sticky <- asks getSticky - logLevel <- asks getLogLevel - supportsUnicode <- asks getSupportsUnicode - supportsAnsi <- asks getAnsiTerminal - return $ stickyLoggerFuncImpl sticky logLevel supportsUnicode supportsAnsi + lo <- asks getLogOptions + return $ stickyLoggerFuncImpl sticky lo stickyLoggerFuncImpl :: ToLogStr msg - => Sticky -> LogLevel -> Bool -> Bool + => Sticky -> LogOptions -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) -stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode supportsAnsi loc src level msg = +stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = case mref of Nothing -> loggerFunc - supportsAnsi - maxLogLevel + lo out loc src @@ -280,7 +197,7 @@ stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode supportsAnsi loc -- Convert some GHC-generated Unicode characters as necessary let msgText - | supportsUnicode = msgTextRaw + | logUseUnicode lo = msgTextRaw | otherwise = T.map replaceUnicode msgTextRaw newState <- @@ -296,9 +213,9 @@ stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode supportsAnsi loc hFlush out return (Just msgText) _ - | level >= maxLogLevel -> do + | level >= logMinLevel lo -> do clear - loggerFunc supportsAnsi maxLogLevel out loc src level $ toLogStr msgText + loggerFunc lo out loc src level $ toLogStr msgText case sticky of Nothing -> return Nothing @@ -321,9 +238,9 @@ replaceUnicode c = c -- | Logging function takes the log level into account. loggerFunc :: ToLogStr msg - => Bool -> LogLevel -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () -loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg = - when (level >= maxLogLevel) + => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () +loggerFunc lo outputChannel loc _src level msg = + when (level >= logMinLevel lo) (liftIO (do out <- getOutput T.hPutStrLn outputChannel out)) where @@ -340,10 +257,10 @@ loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg = , T.pack (ansi [Reset]) ] where - ansi xs | supportsAnsi = setSGRCode xs + ansi xs | logUseColor lo = setSGRCode xs | otherwise = "" getTimestamp - | maxLogLevel <= LevelDebug = + | logVerboseFormat lo && logUseTime lo = do now <- getZonedTime return $ ansi [SetColor Foreground Vivid Black] @@ -353,7 +270,7 @@ loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg = formatTime' = take timestampLength . formatTime defaultTimeLocale "%F %T.%q" getLevel - | maxLogLevel <= LevelDebug = + | logVerboseFormat lo = return ((case level of LevelDebug -> ansi [SetColor Foreground Dull Green] LevelInfo -> ansi [SetColor Foreground Dull Blue] @@ -365,7 +282,7 @@ loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg = "] ") | otherwise = return "" getLoc - | maxLogLevel <= LevelDebug = + | logVerboseFormat lo = return $ ansi [SetColor Foreground Vivid Black] ++ "\n@(" ++ fileLocStr ++ ")" diff --git a/src/main/Main.hs b/src/main/Main.hs index f30afed552..6530b42d8f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -578,7 +578,7 @@ setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do Nothing (runStackTGlobal manager (lcConfig lc) go $ Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $ - runStackLoggingTGlobal manager go $ do + runStackTGlobal manager () go $ do (wantedCompiler, compilerCheck, mstack) <- case scoCompilerVersion of Just v -> return (v, MatchMinor, Nothing)