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.

Author: istathar

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.

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

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

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

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

core-telemetry/lib/Core/Telemetry/Console.hs

@@ -81,6 +81,7 @@ processConsoleOutput out datums = do
                 formatLogMessage
                     start
                     now
+                    True
                     SeverityInternal
                     text
         atomically $ do

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:

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