Refactoring of logging code + #2727

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

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,40 +43,40 @@ 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
 
 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

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

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)

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

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,45 +39,42 @@ 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
 
 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})