From 09c2096f1f74c3a37ad2fca6700d7c4a73fcb1f3 Mon Sep 17 00:00:00 2001 From: Andrew Cowie Date: Thu, 7 Apr 2022 11:08:11 +1000 Subject: [PATCH] Only colour log output if attached to a terminal Detect whether stdout is terminal; if it isn't then supress ANSI escape codes in log messages. --- core-program/core-program.cabal | 2 +- core-program/lib/Core/Program/Context.hs | 11 +++++- core-program/lib/Core/Program/Execute.hs | 2 ++ core-program/lib/Core/Program/Logging.hs | 37 +++++++++++++------- core-program/package.yaml | 2 +- core-telemetry/lib/Core/Telemetry/Console.hs | 1 + package.yaml | 13 +++++++ unbeliever.cabal | 19 ++++++++++ 8 files changed, 71 insertions(+), 16 deletions(-) diff --git a/core-program/core-program.cabal b/core-program/core-program.cabal index b1771540..89ed7b45 100644 --- a/core-program/core-program.cabal +++ b/core-program/core-program.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: core-program -version: 0.4.5.0 +version: 0.4.5.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. diff --git a/core-program/lib/Core/Program/Context.hs b/core-program/lib/Core/Program/Context.hs index 1e53aa4c..8bc8a1de 100644 --- a/core-program/lib/Core/Program/Context.hs +++ b/core-program/lib/Core/Program/Context.hs @@ -51,6 +51,7 @@ import Core.Program.Metadata import Core.System.Base hiding (catch, throw) import Core.Text.Rope import Data.Foldable (foldrM) +import System.IO (hIsTerminalDevice) import Data.Int (Int64) import Data.String (IsString) import Prettyprinter (LayoutOptions (..), PageWidth (..), layoutPretty) @@ -164,6 +165,7 @@ data Context τ = Context { -- runtime properties programNameFrom :: MVar Rope , terminalWidthFrom :: Int + , terminalColouredFrom :: Bool , versionFrom :: Version , -- only used during initial setup initialConfigFrom :: Config @@ -353,6 +355,7 @@ configure version t config = do q <- newEmptyMVar i <- newMVar start columns <- getConsoleWidth + coloured <- getConsoleColoured level <- newEmptyMVar out <- newTQueueIO tel <- newTQueueIO @@ -364,6 +367,7 @@ configure version t config = do $! Context { programNameFrom = n , terminalWidthFrom = columns + , terminalColouredFrom = coloured , versionFrom = version , initialConfigFrom = config , initialExportersFrom = [] @@ -392,7 +396,12 @@ getConsoleWidth = do Nothing -> 80 return columns --- + +getConsoleColoured :: IO Bool +getConsoleColoured = do + terminal <- hIsTerminalDevice stdout + pure terminal + {- | Process the command line options and arguments. If an invalid option is diff --git a/core-program/lib/Core/Program/Execute.hs b/core-program/lib/Core/Program/Execute.hs index 8bb0e2a7..a20bdb3f 100644 --- a/core-program/lib/Core/Program/Execute.hs +++ b/core-program/lib/Core/Program/Execute.hs @@ -447,6 +447,7 @@ loopForever action v out queue = do formatLogMessage start now + True SeverityInternal ("telemetry: sent " <> desc) atomically $ do @@ -460,6 +461,7 @@ loopForever action v out queue = do formatLogMessage start now + True SeverityWarn ("sending telemetry failed (Exception: " <> intoRope (show e) <> "); Restarting exporter.") atomically $ do diff --git a/core-program/lib/Core/Program/Logging.hs b/core-program/lib/Core/Program/Logging.hs index 691b1d67..9620c588 100644 --- a/core-program/lib/Core/Program/Logging.hs +++ b/core-program/lib/Core/Program/Logging.hs @@ -179,6 +179,7 @@ putMessage context (Message now level text possiblelValue) = do let i = startTimeFrom context start <- readMVar i let output = outputChannelFrom context + coloured = terminalColouredFrom context let display = case possiblelValue of Just value -> @@ -187,13 +188,13 @@ putMessage context (Message now level text possiblelValue) = do else text <> " = " <> value Nothing -> text - let !result = formatLogMessage start now level display + let !result = formatLogMessage start now coloured level display atomically $ do writeTQueue output (Just result) -formatLogMessage :: TimeStamp -> TimeStamp -> Severity -> Rope -> Rope -formatLogMessage start now severity message = +formatLogMessage :: TimeStamp -> TimeStamp -> Bool -> Severity -> Rope -> Rope +formatLogMessage start now coloured severity message = let !start' = unTimeStamp start !now' = unTimeStamp now !stampZ = @@ -219,16 +220,26 @@ formatLogMessage start now severity message = SeverityInternal -> intoEscapes dullBlue !reset = intoEscapes resetColour - in mconcat - [ intoEscapes dullWhite - , intoRope stampZ - , " (" - , padWithZeros 6 (show elapsed) - , ") " - , colour - , message - , reset - ] + in case coloured of + True -> + mconcat + [ intoEscapes dullWhite + , intoRope stampZ + , " (" + , padWithZeros 6 (show elapsed) + , ") " + , colour + , message + , reset + ] + False -> + mconcat + [ intoRope stampZ + , " (" + , padWithZeros 6 (show elapsed) + , ") " + , message + ] {- | Utility function to prepend \'0\' characters to a string representing a diff --git a/core-program/package.yaml b/core-program/package.yaml index f5204b98..db7eae53 100644 --- a/core-program/package.yaml +++ b/core-program/package.yaml @@ -1,5 +1,5 @@ name: core-program -version: 0.4.5.0 +version: 0.4.5.1 synopsis: Opinionated Haskell Interoperability description: | A library to help build command-line programs, both tools and diff --git a/core-telemetry/lib/Core/Telemetry/Console.hs b/core-telemetry/lib/Core/Telemetry/Console.hs index dda859e3..4e7524d9 100644 --- a/core-telemetry/lib/Core/Telemetry/Console.hs +++ b/core-telemetry/lib/Core/Telemetry/Console.hs @@ -81,6 +81,7 @@ processConsoleOutput out datums = do formatLogMessage start now + True SeverityInternal text atomically $ do diff --git a/package.yaml b/package.yaml index 6e2c627e..5d7aa7ec 100644 --- a/package.yaml +++ b/package.yaml @@ -55,6 +55,7 @@ dependencies: executables: snippet: + buildable: false dependencies: - core-webserver-warp - http-types @@ -67,6 +68,18 @@ executables: main: WarpSnippet.hs other-modules: [] + experiment: + dependencies: + - bytestring + - prettyprinter + - unordered-containers + ghc-options: + - -threaded + source-dirs: + - tests + main: SimpleExperiment.hs + other-modules: [] + tests: check: dependencies: diff --git a/unbeliever.cabal b/unbeliever.cabal index 6a8904af..7a2f540c 100644 --- a/unbeliever.cabal +++ b/unbeliever.cabal @@ -54,6 +54,24 @@ source-repository head type: git location: https://github.com/aesiniath/unbeliever +executable experiment + main-is: SimpleExperiment.hs + hs-source-dirs: + tests + ghc-options: -Wall -Wwarn -fwarn-tabs -threaded + build-depends: + base >=4.11 && <5 + , bytestring + , core-data >=0.3.0.2 + , core-program >=0.4.0.0 + , core-telemetry >=0.1.7.3 + , core-text >=0.3.4.0 + , core-webserver-servant >=0.0.1.0 + , core-webserver-warp >=0.1.0.0 + , prettyprinter + , unordered-containers + default-language: Haskell2010 + executable snippet main-is: WarpSnippet.hs hs-source-dirs: @@ -70,6 +88,7 @@ executable snippet , http-types , wai , warp + buildable: False default-language: Haskell2010 test-suite check