packages feed

core-program 0.2.12.0 → 0.3.0.7

raw patch · 7 files changed

+344/−140 lines, 7 files

Files

core-program.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           core-program-version:        0.2.12.0+version:        0.3.0.7 synopsis:       Opinionated Haskell Interoperability description:    A library to help build command-line programs, both tools and                 longer-running daemons.@@ -37,6 +37,7 @@   exposed-modules:       Core.Program       Core.Program.Arguments+      Core.Program.Context       Core.Program.Execute       Core.Program.Logging       Core.Program.Metadata@@ -47,7 +48,6 @@       Core.System.External       Core.System.Pretty   other-modules:-      Core.Program.Context       Core.Program.Signal   hs-source-dirs:       lib
lib/Core/Program.hs view
@@ -19,6 +19,7 @@     -- |     -- A top-level Program type giving you unified access to logging, concurrency,     -- and more.+    module Core.Program.Context,     module Core.Program.Execute,     module Core.Program.Unlift,     module Core.Program.Metadata,@@ -36,6 +37,7 @@     -- |     -- Facilities for noting events through your program and doing debugging.     module Core.Program.Logging,+     -- |     -- There are a few common use cases which require a bit of wrapping to use     -- effectively. Watching files for changes and taking action in the event of a@@ -47,6 +49,7 @@ import Core.Program.Arguments import Core.Program.Execute import Core.Program.Logging+import Core.Program.Context import Core.Program.Metadata import Core.Program.Notify import Core.Program.Unlift
lib/Core/Program/Arguments.hs view
@@ -36,6 +36,7 @@      -- * Programs with Commands     Commands (..),+    appendOption,      -- * Internals     parseCommandLine,@@ -43,9 +44,7 @@     InvalidCommandLine (..),     buildUsage,     buildVersion,-    blank,-    simple,-    complex,+    emptyParameters, ) where  import Data.Hashable (Hashable)@@ -135,10 +134,6 @@ blankConfig :: Config blankConfig = Blank -blank :: Config-blank = blankConfig-{-# DEPRECATED blank "use blankConfig instead" #-}- {- | Declare a simple (as in normal) configuration for a program with any number of optional parameters and mandatory arguments. For example:@@ -187,7 +182,7 @@                  Perform a trial run at the specified time but don't                  actually do anything.   -q, --quiet    Supress normal output.-  -v, --verbose  Turn on event tracing. By default the logging stream will go+  -v, --verbose  Turn on informational messages. The logging stream will go                  to standard output on your terminal.       --debug    Turn on debug level logging. Implies --verbose. @@ -205,10 +200,6 @@ simpleConfig :: [Options] -> Config simpleConfig options = Simple (options ++ baselineOptions) -simple :: [Options] -> Config-simple = simpleConfig-{-# DEPRECATED simple "Use simpleConfig instead" #-}- {- | Declare a complex configuration (implying a larger tool with various "[sub]commands" or "modes"} for a program. You can specify global options@@ -295,10 +286,6 @@ complexConfig :: [Commands] -> Config complexConfig commands = Complex (commands ++ [Global baselineOptions]) -complex :: [Commands] -> Config-complex = complexConfig-{-# DEPRECATED complex "Use complexConfig instead" #-}- {- | Description of the command-line structure of a program which has \"commands\" (sometimes referred to as \"subcommands\") representing@@ -353,6 +340,18 @@     | Argument LongName Description     | Variable LongName Description +appendOption :: Options -> Config -> Config+appendOption option config =+    case config of+        Blank -> Blank+        Simple options -> Simple (List.reverse (option : options))+        Complex commands -> Complex (List.foldl' f [] commands)+  where+    f :: [Commands] -> Commands -> [Commands]+    f acc command = case command of+        Global options -> Global (List.reverse (option : options)) : acc+        c@(Command _ _ _) -> c : acc+ {- | Individual parameters read in off the command-line can either have a value (in the case of arguments and options taking a value) or be empty (in the@@ -411,6 +410,14 @@     }     deriving (Show, Eq) +emptyParameters :: Parameters+emptyParameters =+    Parameters+        { commandNameFrom = Nothing+        , parameterValuesFrom = emptyMap+        , environmentValuesFrom = emptyMap+        }+ baselineOptions :: [Options] baselineOptions =     [ Option@@ -418,15 +425,15 @@         (Just 'v')         Empty         [quote|-        Turn on event tracing. By default the logging stream will go to-        standard output on your terminal.+        Turn on informational messages. The logging stream will go+        to standard output in your terminal.     |]     , Option         "debug"         Nothing         Empty         [quote|-        Turn on debug level logging. Implies --verbose.+        Turn on debug output. Implies --verbose.     |]     ]
lib/Core/Program/Context.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -11,7 +13,19 @@  -- This is an Internal module, hidden from Haddock module Core.Program.Context (+    Datum (..),+    emptyDatum,+    Trace (..),+    unTrace,+    Span (..),+    unSpan,     Context (..),+    handleCommandLine,+    handleVerbosityLevel,+    handleTelemetryChoice,+    Exporter (..),+    Forwarder (..),+    emptyForwarder,     None (..),     isNone,     configure,@@ -24,26 +38,108 @@ ) where  import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)-import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar)+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar) import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO) import qualified Control.Exception.Safe as Safe (throw) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM)) import Control.Monad.Reader.Class (MonadReader (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import Core.Data.Structures+import Core.Encoding.Json import Core.Program.Arguments import Core.Program.Metadata import Core.System.Base hiding (catch, throw) import Core.Text.Rope import Data.Foldable (foldrM)+import Data.Int (Int64)+import Data.String (IsString) import Prettyprinter (LayoutOptions (..), PageWidth (..), layoutPretty) import Prettyprinter.Render.Text (renderIO) import qualified System.Console.Terminal.Size as Terminal (Window (..), size) import System.Environment (getArgs, getProgName, lookupEnv) import System.Exit (ExitCode (..), exitWith)+import qualified System.Posix.Process as Posix (exitImmediately) import Prelude hiding (log)  {- |+Carrier for spans and events while their data is being accumulated, and later+sent down the telemetry channel. There is one of these in the Program monad's+Context.+-}++-- `spanIdentifierFrom` is a Maybe because at startup there is not yet a+-- current span. When the first (root) span is formed in `encloseSpan` it uses+-- this as the parent value - in this case, no parent, which is what we want.+data Datum = Datum+    { spanIdentifierFrom :: Maybe Span+    , spanNameFrom :: Rope+    , serviceNameFrom :: Maybe Rope+    , spanTimeFrom :: TimeStamp+    , traceIdentifierFrom :: Maybe Trace+    , parentIdentifierFrom :: Maybe Span+    , durationFrom :: Maybe Int64+    , attachedMetadataFrom :: Map JsonKey JsonValue+    }+    deriving (Show)++emptyDatum :: Datum+emptyDatum =+    Datum+        { spanIdentifierFrom = Nothing+        , spanNameFrom = emptyRope+        , serviceNameFrom = Nothing+        , spanTimeFrom = 0+        , traceIdentifierFrom = Nothing+        , parentIdentifierFrom = Nothing+        , durationFrom = Nothing+        , attachedMetadataFrom = emptyMap+        }++{- |+Unique identifier for a span. This will be generated by+'Core.Telemetry.Observability.encloseSpan' but for the case where you are+continuing an inherited trace and passed the identifier of the parent span you+can specify it using this constructor.+-}+newtype Span = Span Rope+    deriving (Show, IsString)++unSpan :: Span -> Rope+unSpan (Span text) = text++{- |+Unique identifier for a trace. If your program is the top of an service stack+then you can use 'beginTrace' to generate a new idenfifier for this request or+iteration. More commonly, however, you will inherit the trace identifier from+the application or service which invokes this program or request handler, and+you can specify it by using 'usingTrace'.+-}+newtype Trace = Trace Rope+    deriving (Show, IsString)++unTrace :: Trace -> Rope+unTrace (Trace text) = text++data Exporter = Exporter+    { codenameFrom :: Rope+    , setupConfigFrom :: Config -> Config+    , setupActionFrom :: forall τ. Context τ -> IO Forwarder+    }++{- |+Implementation of a forwarder for structured logging of the telemetry channel.+-}+data Forwarder = Forwarder+    { telemetryHandlerFrom :: [Datum] -> IO ()+    }++emptyForwarder :: Forwarder+emptyForwarder =+    Forwarder+        { telemetryHandlerFrom = \_ -> pure ()+        }++{- | Internal context for a running program. You access this via actions in the 'Program' monad. The principal item here is the user-supplied top-level application data of type @τ@ which can be retrieved with@@ -70,15 +166,25 @@ -- that field name as a local variable name. -- data Context τ = Context-    { programNameFrom :: MVar Rope+    { -- runtime properties+      programNameFrom :: MVar Rope+    , terminalWidthFrom :: Int     , versionFrom :: Version-    , commandLineFrom :: Parameters-    , exitSemaphoreFrom :: MVar ExitCode+    , -- only used during initial setup+      initialConfigFrom :: Config+    , initialExportersFrom :: [Exporter]+    , -- derived at startup+      commandLineFrom :: Parameters+    , -- operational state+      exitSemaphoreFrom :: MVar ExitCode     , startTimeFrom :: MVar TimeStamp-    , terminalWidthFrom :: Int     , verbosityLevelFrom :: MVar Verbosity-    , outputChannelFrom :: TQueue Rope-    , loggerChannelFrom :: TQueue () -- FIXME+    , -- communication channels+      outputChannelFrom :: TQueue (Maybe Rope)+    , telemetryChannelFrom :: TQueue (Maybe Datum)+    , -- machinery for telemetry+      telemetryForwarderFrom :: Forwarder+    , currentDatumFrom :: MVar Datum     , applicationDataFrom :: MVar τ     } @@ -127,13 +233,11 @@ -} data Verbosity     = Output-    | Event-    | Verbose  -- ^ @since 0.2.12+    | -- | @since 0.2.12+      Verbose     | Debug     deriving (Show) -{-# DEPRECATED Event "Use Verbose instead" #-}- {- | The type of a top-level program. @@ -244,27 +348,31 @@      arg0 <- getProgName     n <- newMVar (intoRope arg0)-    p <- handleCommandLine version config     q <- newEmptyMVar     i <- newMVar start     columns <- getConsoleWidth+    level <- newEmptyMVar     out <- newTQueueIO-    log <- newTQueueIO-    u <- newMVar t+    tel <- newTQueueIO -    l <- handleVerbosityLevel p+    v <- newMVar (emptyDatum)+    u <- newMVar t      return         $! Context             { programNameFrom = n+            , terminalWidthFrom = columns             , versionFrom = version-            , commandLineFrom = p+            , initialConfigFrom = config+            , initialExportersFrom = []+            , commandLineFrom = emptyParameters -- will be filled in handleCommandLine             , exitSemaphoreFrom = q             , startTimeFrom = i-            , terminalWidthFrom = columns-            , verbosityLevelFrom = l+            , verbosityLevelFrom = level -- will be filled in handleVerbosityLevel             , outputChannelFrom = out-            , loggerChannelFrom = log+            , telemetryChannelFrom = tel+            , telemetryForwarderFrom = emptyForwarder+            , currentDatumFrom = v             , applicationDataFrom = u             } @@ -296,14 +404,27 @@     called that in Core.Program.Arguments). And, returning here lets us set     up the layout width to match (one off the) actual width of console. -}-handleCommandLine :: Version -> Config -> IO Parameters-handleCommandLine version config = do+handleCommandLine :: Context τ -> IO (Context τ)+handleCommandLine context = do     argv <- getArgs-    let result = parseCommandLine config argv++    let config = initialConfigFrom context+        version = versionFrom context+        result = parseCommandLine config argv+     case result of         Right parameters -> do             pairs <- lookupEnvironmentVariables config parameters-            return parameters{environmentValuesFrom = pairs}+            let params =+                    parameters+                        { environmentValuesFrom = pairs+                        }+            -- update the result of all this and return in+            let context' =+                    context+                        { commandLineFrom = params+                        }+            pure context'         Left e -> case e of             HelpRequest mode -> do                 render (buildUsage config mode)@@ -338,16 +459,19 @@             Just value -> insertKeyValue name (Value value) acc             Nothing -> acc -handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)-handleVerbosityLevel params = do-    let result = queryVerbosityLevel params+handleVerbosityLevel :: Context τ -> IO (MVar Verbosity)+handleVerbosityLevel context = do+    let params = commandLineFrom context+        level = verbosityLevelFrom context+        result = queryVerbosityLevel params     case result of-        Right level -> do-            newMVar level         Left exit -> do-            putStrLn "error: To set logging level use --verbose or --debug; neither take values."+            putStrLn "error: To set logging level use --verbose or --debug; neither take a value."             hFlush stdout             exitWith exit+        Right verbosity -> do+            putMVar level verbosity+            pure level  queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity queryVerbosityLevel params =@@ -359,6 +483,42 @@                 Value _ -> Left (ExitFailure 2)             Nothing -> case verbose of                 Just value -> case value of-                    Empty -> Right Event+                    Empty -> Right Verbose                     Value _ -> Left (ExitFailure 2)                 Nothing -> Right Output++handleTelemetryChoice :: Context τ -> IO (Context τ)+handleTelemetryChoice context = do+    let params = commandLineFrom context+        options = parameterValuesFrom params+        exporters = initialExportersFrom context++    case lookupKeyValue "telemetry" options of+        Nothing -> pure context+        Just Empty -> do+            putStrLn "error: Need to supply a value when specifiying --telemetry."+            Posix.exitImmediately (ExitFailure 99)+            undefined+        Just (Value value) -> case lookupExporter (intoRope value) exporters of+            Nothing -> do+                putStrLn ("error: supplied value \"" ++ value ++ "\" not a valid telemetry exporter.")+                Posix.exitImmediately (ExitFailure 99)+                undefined+            Just exporter -> do+                let setupAction = setupActionFrom exporter++                -- run the IO action to setup the Forwareder+                forwarder <- setupAction context++                -- and return it+                pure+                    context+                        { telemetryForwarderFrom = forwarder+                        }+  where+    lookupExporter :: Rope -> [Exporter] -> Maybe Exporter+    lookupExporter _ [] = Nothing+    lookupExporter target (exporter : exporters) =+        case target == codenameFrom exporter of+            False -> lookupExporter target exporters+            True -> Just exporter
lib/Core/Program/Execute.hs view
@@ -80,9 +80,7 @@     -- * Concurrency     Thread,     forkThread,-    fork,     sleepThread,-    sleep,     resetTimer,     waitThread,     waitThread_,@@ -95,10 +93,7 @@     unProgram,     unThread,     invalid,-    retrieve,-    update,-    output,-    input,+    loopForever, ) where  import Chrono.TimeStamp (getCurrentTimeNanoseconds)@@ -115,12 +110,28 @@     race_,     wait,  )-import Control.Concurrent.MVar (modifyMVar_, newMVar, putMVar, readMVar)-import Control.Concurrent.STM (atomically, check)-import Control.Concurrent.STM.TQueue (TQueue, isEmptyTQueue, readTQueue)+import Control.Concurrent.MVar (+    modifyMVar_,+    newMVar,+    putMVar,+    readMVar,+ )+import Control.Concurrent.STM (+    atomically,+ )+import Control.Concurrent.STM.TQueue (+    TQueue,+    readTQueue,+    tryReadTQueue,+    unGetTQueue,+    writeTQueue,+ ) import qualified Control.Exception as Base (throwIO) import qualified Control.Exception.Safe as Safe (catch, catchesAsync, throw)-import Control.Monad (forever, void, when)+import Control.Monad (+    void,+    when,+ ) import Control.Monad.Catch (Handler (..)) import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Data.Structures@@ -190,7 +201,7 @@             ( bracket                 obtainResource                 releaseResource-                useResournce+                useResource             ) @ @@ -221,7 +232,7 @@ execute :: Program None α -> IO () execute program = do     context <- configure "" None (simpleConfig [])-    executeWith context program+    executeActual context program  {- | Embelish a program with useful behaviours, supplying a configuration@@ -229,17 +240,25 @@ the top-level application state, if appropriate. -} executeWith :: Context τ -> Program τ α -> IO ()-executeWith context program = do+executeWith = executeActual++executeActual :: Context τ -> Program τ α -> IO ()+executeActual context0 program = do     -- command line +RTS -Nn -RTS value     when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities)      -- force UTF-8 working around bad VMs     setLocaleEncoding utf8 +    context1 <- handleCommandLine context0+    context <- handleTelemetryChoice context1++    level <- handleVerbosityLevel context+     let quit = exitSemaphoreFrom context-        level = verbosityLevelFrom context         out = outputChannelFrom context-        log = loggerChannelFrom context+        tel = telemetryChannelFrom context+        forwarder = telemetryForwarderFrom context      -- set up signal handlers     _ <-@@ -254,7 +273,7 @@     -- set up debug logger     l <-         Async.async $ do-            processDebugMessages log+            processTelemetryMessages forwarder tel      -- run actual program, ensuring to grab any otherwise uncaught exceptions.     code <-@@ -278,58 +297,108 @@             )             (escapeHandlers context) -    -- drain message queues. Allow 0.1 seconds, then timeout, in case-    -- something has gone wrong and queues don't empty.+    -- instruct handlers to finish, and wait for the message queues to drain.+    -- Allow 0.1 seconds, then timeout, in case something has gone wrong and+    -- queues don't empty.     Async.race_         ( do             atomically $ do-                done2 <- isEmptyTQueue log-                check done2+                writeTQueue tel Nothing+                writeTQueue out Nothing -                done1 <- isEmptyTQueue out-                check done1+            Async.wait l+            Async.wait o         )         ( do-            threadDelay 100000+            threadDelay 10000000++            Async.cancel l+            Async.cancel o             putStrLn "error: Timeout"         ) -    threadDelay 100 -- instead of yield     hFlush stdout -    Async.cancel l-    Async.cancel o-     -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi     if code == ExitSuccess         then return ()         else (Base.throwIO code) -processStandardOutput :: TQueue Rope -> IO ()+processStandardOutput :: TQueue (Maybe Rope) -> IO () processStandardOutput out =     Safe.catch-        ( do-            forever $ do-                text <- atomically (readTQueue out)+        (loop)+        (collapseHandler "output processing collapsed")+  where+    loop :: IO ()+    loop = do+        probable <- atomically $ do+            readTQueue out +        case probable of+            Nothing -> pure ()+            Just text -> do                 hWrite stdout text                 B.hPut stdout (C.singleton '\n')-        )-        (collapseHandler "output processing collapsed")+                loop -processDebugMessages :: TQueue () -> IO ()-processDebugMessages log =+--+-- I'm embarrased how long it took to get here. At one point we were firing+-- off an Async.race of two threads for every item coming down the queue. And+-- you know what? That didn't work either. After all of that, realized that+-- the technique used   by **io-streams** to just pass along a stream of Maybes,+-- with Nothing signalling end-of-stream is exactly good enough for our needs.+--+processTelemetryMessages :: Forwarder -> TQueue (Maybe Datum) -> IO ()+processTelemetryMessages processor tel = do     Safe.catch-        ( do-            forever $ do-                -- TODO do sactually do something with log messages-                -- Message now severity text potentialValue <- ...-                _ <- atomically (readTQueue log)+        (loopForever action tel)+        (collapseHandler "telemetry processing collapsed")+  where+    action = telemetryHandlerFrom processor -                return ()-        )-        (collapseHandler "debug processing collapsed")+loopForever :: ([a] -> IO ()) -> TQueue (Maybe a) -> IO ()+loopForever action queue = do+    -- block waiting for an item+    possibleItems <- atomically $ do+        cycleOverQueue [] +    -- handle it and loop, unless we're done+    case possibleItems of+        Nothing -> pure ()+        Just items -> do+            action (reverse items)+            loopForever action queue+  where+    cycleOverQueue items =+        case items of+            [] -> do+                possibleItem <- readTQueue queue -- blocks+                case possibleItem of+                    -- we're finished! time to shutdown+                    Nothing -> pure Nothing+                    -- otherwise start accumulating+                    Just item -> do+                        cycleOverQueue (item : [])+            _ -> do+                pending <- tryReadTQueue queue -- doesn't block+                case pending of+                    -- nothing left in the queue+                    Nothing -> pure (Just items)+                    -- otherwise we get one of our Maybe Datum, and consider it+                    Just possibleItem -> do+                        case possibleItem of+                            -- oh, time to stop! We put the Nothing back into+                            -- the queue, then let the accumulated items get+                            -- processed. The next loop will read the+                            -- Nothing and shutdown.+                            Nothing -> do+                                unGetTQueue queue Nothing+                                pure (Just items)+                            -- continue accumulating!+                            Just item -> do+                                cycleOverQueue (item : items)+ {- | Safely exit the program with the supplied exit code. Current output and debug queues will be flushed, and then the process will terminate.@@ -438,16 +507,6 @@         let v = applicationDataFrom context         modifyMVar_ v (\_ -> pure user) --- |-{-# DEPRECATED retrieve "Use getApplicationState instead" #-}-retrieve :: Program τ τ-retrieve = getApplicationState---- |-{-# DEPRECATED update "Use setApplicationState instead" #-}-update :: τ -> Program τ ()-update = setApplicationState- {- | Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to 'write' we don't output a trailing newline.@@ -470,22 +529,12 @@ outputEntire :: Handle -> Bytes -> Program τ () outputEntire handle contents = liftIO (hOutput handle contents) --- |-{-# DEPRECATED output "Use outputEntire instead" #-}-output :: Handle -> Bytes -> Program τ ()-output = outputEntire- {- |  Read the (entire) contents of the specified @Handle@. -} inputEntire :: Handle -> Program τ Bytes inputEntire handle = liftIO (hInput handle) --- |-{-# DEPRECATED input "Use inputEntire instead" #-}-input :: Handle -> Program τ Bytes-input = inputEntire- {- | A thread for concurrent computation. Haskell uses green threads: small lines of work that are scheduled down onto actual execution contexts, set by default@@ -523,10 +572,6 @@         Async.link a         return (Thread a) -fork :: Program τ α -> Program τ (Thread α)-fork = forkThread-{-# DEPRECATED fork "Use forkThread instead" #-}- {- | Reset the start time (used to calculate durations shown in event- and debug-level logging) held in the @Context@ to zero. This is useful if you want@@ -573,10 +618,6 @@ sleepThread seconds =     let us = floor (toRational (seconds * 1e6))      in liftIO $ threadDelay us--sleep :: Rational -> Program τ ()-sleep = sleepThread-{-# DEPRECATED sleep "Use sleepThread instead" #-}  {- | Wait for the completion of a thread, returning the result. This is a blocking
lib/Core/Program/Logging.hs view
@@ -123,6 +123,8 @@ -} module Core.Program.Logging (     putMessage,+    formatLogMessage,+    Severity (..),     Verbosity (..),      -- * Normal output@@ -139,9 +141,6 @@     debug,     debugS,     debugR,--    -- * Internals-    event, ) where  import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)@@ -183,10 +182,10 @@                     else text <> " = " <> value             Nothing -> text -    let result = formatLogMessage start now level display+    let !result = formatLogMessage start now level display      atomically $ do-        writeTQueue output result+        writeTQueue output (Just result)  formatLogMessage :: TimeStamp -> TimeStamp -> Severity -> Rope -> Rope formatLogMessage start now severity message =@@ -204,7 +203,7 @@                 now          -- I hate doing math in Haskell-        elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3+        !elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3          !color = case severity of             SeverityNone -> emptyRope@@ -213,7 +212,7 @@             SeverityInfo -> intoEscapes dullWhite             SeverityDebug -> intoEscapes pureGrey -        reset = intoEscapes resetColour+        !reset = intoEscapes resetColour      in mconcat             [ intoEscapes dullWhite             , intoRope stampZ@@ -237,8 +236,8 @@ padWithZeros digits str =     intoRope pad <> intoRope str   where-    pad = S.replicate len "0"-    len = digits - length str+    !pad = S.replicate len "0"+    !len = digits - length str  {- | Write the supplied text to @stdout@.@@ -256,7 +255,8 @@         let out = outputChannelFrom context          !text' <- evaluate text-        atomically (writeTQueue out text')+        atomically $ do+            writeTQueue out (Just text')  {- | Call 'show' on the supplied argument and write the resultant text to@@ -281,7 +281,7 @@          let text = render columns thing         !text' <- evaluate text-        atomically (writeTQueue out text')+        atomically (writeTQueue out (Just text'))  {- | Note a significant event, state transition, status; also used as a heading for@@ -311,10 +311,6 @@             now <- getCurrentTimeNanoseconds             putMessage context (Message now SeverityInfo text Nothing) -event :: Rope -> Program τ ()-event = info-{-# DEPRECATED event "Use info instead" #-}- {- | Emit a diagnostic message warning of an off-nominal condition. They are best used for unexpected conditions or places where defaults are being applied@@ -386,14 +382,12 @@ isEvent :: Verbosity -> Bool isEvent level = case level of     Output -> False-    Event -> True     Verbose -> True     Debug -> True  isDebug :: Verbosity -> Bool isDebug level = case level of     Output -> False-    Event -> False     Verbose -> False     Debug -> True
lib/Core/Program/Signal.hs view
@@ -53,7 +53,6 @@         v         ( \level -> case level of             Output -> pure Debug-            Event -> pure Debug             Verbose -> pure Debug             Debug -> pure Output         )