core-program 0.2.9.1 → 0.2.12.0

raw patch · 8 files changed

+326/−201 lines, 8 filesdep ~core-datadep ~core-textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: core-data, core-text

API changes (from Hackage documentation)

Files

• core-program.cabal +5/−7
• lib/Core/Program/Arguments.hs +8/−2
• lib/Core/Program/Context.hs +17/−25
• lib/Core/Program/Execute.hs +104/−72
• lib/Core/Program/Logging.hs +188/−93
• lib/Core/Program/Notify.hs +1/−1
• lib/Core/Program/Signal.hs +2/−0
• lib/Core/System/Pretty.hs +1/−1

@@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: 7ef8b1887a1354fbfa0d647d220186bf240e0cacd7b36d144b0682efac37a8cd  name:           core-program-version:        0.2.9.1+version:        0.2.12.0 synopsis:       Opinionated Haskell Interoperability description:    A library to help build command-line programs, both tools and                 longer-running daemons.@@ -27,9 +25,9 @@ copyright:      © 2018-2021 Athae Eredh Siniath and Others license:        MIT license-file:   LICENSE-tested-with:-    GHC == 8.10.6 build-type:     Simple+tested-with:+    GHC == 8.10.7  source-repository head   type: git@@ -59,8 +57,8 @@     , base >=4.11 && <5     , bytestring     , chronologique-    , core-data >=0.2.1.9-    , core-text >=0.3.0+    , core-data >=0.2.1.10+    , core-text >=0.3.4.0     , directory     , exceptions     , filepath

@@ -52,7 +52,7 @@ import qualified Data.List as List import Data.Maybe (fromMaybe) import Data.String (IsString (..))-import Data.Text.Prettyprint.Doc (+import Prettyprinter (     Doc,     Pretty (..),     align,@@ -66,7 +66,7 @@     softline,     (<+>),  )-import Data.Text.Prettyprint.Doc.Util (reflow)+import Prettyprinter.Util (reflow) import System.Environment (getProgName)  import Core.Data.Structures@@ -129,6 +129,8 @@ A completely empty configuration, without the default debugging and logging options. Your program won't process any command-line options or arguments, which would be weird in most cases. Prefer 'simple'.++@since 0.2.9 -} blankConfig :: Config blankConfig = Blank@@ -197,6 +199,8 @@  For information on how to use the multi-line string literals shown here, see 'quote' in "Core.Text.Utilities".++@since 0.2.9 -} simpleConfig :: [Options] -> Config simpleConfig options = Simple (options ++ baselineOptions)@@ -285,6 +289,8 @@  For information on how to use the multi-line string literals shown here, see 'quote' in "Core.Text.Utilities".++@since 0.2.9 -} complexConfig :: [Commands] -> Config complexConfig commands = Complex (commands ++ [Global baselineOptions])

@@ -15,7 +15,6 @@     None (..),     isNone,     configure,-    Message (..),     Verbosity (..),     Program (..),     unProgram,@@ -27,8 +26,8 @@ import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds) import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar) import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)-import qualified Control.Exception.Safe as Safe (catch, throw)-import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM))+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@@ -37,8 +36,8 @@ import Core.System.Base hiding (catch, throw) import Core.Text.Rope import Data.Foldable (foldrM)-import Data.Text.Prettyprint.Doc (LayoutOptions (..), PageWidth (..), layoutPretty)-import Data.Text.Prettyprint.Doc.Render.Text (renderIO)+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)@@ -79,7 +78,7 @@     , terminalWidthFrom :: Int     , verbosityLevelFrom :: MVar Verbosity     , outputChannelFrom :: TQueue Rope-    , loggerChannelFrom :: TQueue Message+    , loggerChannelFrom :: TQueue () -- FIXME     , applicationDataFrom :: MVar τ     } @@ -121,16 +120,20 @@ isNone :: None -> Bool isNone _ = True -data Message = Message TimeStamp Verbosity Rope (Maybe Rope)- {- |-The verbosity level of the logging subsystem. You can override the level-specified on the command-line using 'Core.Program.Execute.setVerbosityLevel'-from within the 'Program' monad.+The verbosity level of the output logging subsystem. You can override the+level specified on the command-line by calling+'Core.Program.Execute.setVerbosityLevel' from within the 'Program' monad. -}-data Verbosity = Output | Event | Debug+data Verbosity+    = Output+    | Event+    | Verbose  -- ^ @since 0.2.12+    | Debug     deriving (Show) +{-# DEPRECATED Event "Use Verbose instead" #-}+ {- | The type of a top-level program. @@ -220,20 +223,9 @@ instance MonadThrow (Program τ) where     throwM = liftIO . Safe.throw -unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)-unHandler = fmap unProgram+deriving instance MonadCatch (Program τ) -instance MonadCatch (Program τ) where-    catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α-    catch program handler =-        let r = unProgram program-            h = unHandler handler-         in do-                context <- ask-                liftIO $ do-                    Safe.catch-                        (runReaderT r context)-                        (\e -> runReaderT (h e) context)+deriving instance MonadMask (Program t)  {- | Initialize the programs's execution context. This takes care of various

@@ -86,6 +86,7 @@     resetTimer,     waitThread,     waitThread_,+    trap_,      -- * Internals     Context,@@ -104,13 +105,13 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (     Async,-    AsyncCancelled,     ExceptionInLinkedThread (..),  ) import qualified Control.Concurrent.Async as Async (     async,     cancel,     link,+    race,     race_,     wait,  )@@ -118,7 +119,7 @@ import Control.Concurrent.STM (atomically, check) import Control.Concurrent.STM.TQueue (TQueue, isEmptyTQueue, readTQueue) import qualified Control.Exception as Base (throwIO)-import qualified Control.Exception.Safe as Safe (catchesAsync, throw)+import qualified Control.Exception.Safe as Safe (catch, catchesAsync, throw) import Control.Monad (forever, void, when) import Control.Monad.Catch (Handler (..)) import Control.Monad.Reader.Class (MonadReader (ask))@@ -138,46 +139,31 @@ import qualified System.Posix.Process as Posix (exitImmediately) import Prelude hiding (log) --- execute actual "main"-executeAction :: Context τ -> Program τ α -> IO ()-executeAction context program =-    let quit = exitSemaphoreFrom context-     in do-            _ <- subProgram context program-            putMVar quit ExitSuccess- ----- If an exception escapes, we'll catch it here. The displayException--- value for some exceptions is really quit unhelpful, so we pattern--- match the wrapping gumpf away for cases as we encounter them. The--- final entry is the catch-all; the first is what we get from the--- terminate action.+-- If an exception escapes, we'll catch it here. The displayException value+-- for some exceptions is really quit unhelpful, so we pattern match the+-- wrapping gumpf away for cases as we encounter them. The final entry is the+-- catch-all. ---escapeHandlers :: Context c -> [Handler IO ()]+-- Note this is called via Safe.catchesAsync because we want to be able to+-- strip out ExceptionInLinkedThread (which is asynchronous and otherwise+-- reasonably special) from the final output message.+--+escapeHandlers :: Context c -> [Handler IO ExitCode] escapeHandlers context =-    [ Handler (\(exit :: ExitCode) -> done exit)-    , Handler (\(_ :: AsyncCancelled) -> pass)+    [ Handler (\(code :: ExitCode) -> pure code)     , Handler (\(ExceptionInLinkedThread _ e) -> bail e)     , Handler (\(e :: SomeException) -> bail e)     ]   where-    quit = exitSemaphoreFrom context--    pass :: IO ()-    pass = return ()--    done :: ExitCode -> IO ()-    done exit = do-        putMVar quit exit--    bail :: Exception e => e -> IO ()+    bail :: Exception e => e -> IO ExitCode     bail e =         let text = intoRope (displayException e)          in do                 subProgram context $ do                     setVerbosityLevel Debug-                    event text-                putMVar quit (ExitFailure 127)+                    critical text+                pure (ExitFailure 127)  -- -- If an exception occurs in one of the output handlers, its failure causes@@ -187,19 +173,45 @@ -- really need the process to go down and we're in an inconsistent state -- where debug or console output is no longer possible. ---collapseHandlers :: [Handler IO ()]-collapseHandlers =-    [ Handler-        ( \(e :: AsyncCancelled) -> do-            Base.throwIO e-        )-    , Handler-        ( \(e :: SomeException) -> do-            putStrLn "error: Output handler collapsed"-            print e-            Posix.exitImmediately (ExitFailure 99)+collapseHandler :: String -> SomeException -> IO ()+collapseHandler problem e = do+    putStr "error: "+    putStrLn problem+    print e+    Posix.exitImmediately (ExitFailure 99)++{- |+Trap any exceptions coming out of the given Program action, and discard them.+The one and only time you want this is inside an endless loop:++@+    forever $ do+        trap_+            ( bracket+                obtainResource+                releaseResource+                useResournce+            )+@++This function really will swollow expcetions, which means that you'd better+have handled any synchronous checked errors already with a 'catch' and/or have+released resources with 'bracket' or 'finally' as shown above.++An info level message will be sent to the log channel indicating that an+uncaught exception was trapped along with a debug level message showing the+exception text, if any.+-}+trap_ :: Program τ α -> Program τ ()+trap_ action =+    Safe.catch+        (void action)+        ( \(e :: SomeException) ->+            let text = intoRope (displayException e)+             in do+                    warn "Trapped uncaught exception"+                    debug "e" text         )-    ]  {- | Embelish a program with useful behaviours. See module header@@ -229,30 +241,42 @@         out = outputChannelFrom context         log = loggerChannelFrom context +    -- set up signal handlers+    _ <-+        Async.async $ do+            setupSignalHandlers quit level+     -- set up standard output-    o <- Async.async $ do-        Safe.catchesAsync-            (processStandardOutput out)-            (collapseHandlers)+    o <-+        Async.async $ do+            processStandardOutput out      -- set up debug logger-    l <- Async.async $ do-        Safe.catchesAsync-            (processDebugMessages log)-            (collapseHandlers)--    -- set up signal handlers-    _ <- Async.async $ do-        setupSignalHandlers quit level+    l <-+        Async.async $ do+            processDebugMessages log -    -- run actual program, ensuring to trap uncaught exceptions-    m <- Async.async $ do+    -- run actual program, ensuring to grab any otherwise uncaught exceptions.+    code <-         Safe.catchesAsync-            (executeAction context program)-            (escapeHandlers context)+            ( do+                result <-+                    Async.race+                        ( do+                            code <- readMVar quit+                            pure code+                        )+                        ( do+                            -- execute actual "main"+                            _ <- subProgram context program+                            pure ()+                        ) -    code <- readMVar quit-    Async.cancel m+                case result of+                    Left code' -> pure code'+                    Right () -> pure ExitSuccess+            )+            (escapeHandlers context)      -- drain message queues. Allow 0.1 seconds, then timeout, in case     -- something has gone wrong and queues don't empty.@@ -282,21 +306,29 @@         else (Base.throwIO code)  processStandardOutput :: TQueue Rope -> IO ()-processStandardOutput out = do-    forever $ do-        text <- atomically (readTQueue out)+processStandardOutput out =+    Safe.catch+        ( do+            forever $ do+                text <- atomically (readTQueue out) -        hWrite stdout text-        B.hPut stdout (C.singleton '\n')+                hWrite stdout text+                B.hPut stdout (C.singleton '\n')+        )+        (collapseHandler "output processing collapsed") -processDebugMessages :: TQueue Message -> IO ()-processDebugMessages log = do-    forever $ do-        -- TODO do sactually do something with log messages-        -- Message now severity text potentialValue <- ...-        _ <- atomically (readTQueue log)+processDebugMessages :: TQueue () -> IO ()+processDebugMessages log =+    Safe.catch+        ( do+            forever $ do+                -- TODO do sactually do something with log messages+                -- Message now severity text potentialValue <- ...+                _ <- atomically (readTQueue log) -        return ()+                return ()+        )+        (collapseHandler "debug processing collapsed")  {- | Safely exit the program with the supplied exit code. Current output and

@@ -3,18 +3,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_HADDOCK prune #-}  {- | Output and Logging from your program. -Broadly speaking, there are two kinds of program: console tools invoked for-a single purpose, and long-running daemons that effectively run forever.+Broadly speaking, there are two kinds of program: console tools invoked for a+single purpose, and long-running daemons that effectively run forever. -Tools tend to be run to either have an effect (in which case they tend not-to a say much of anything) or to report a result. This tends to be written-to \"standard output\"—traditionally abbreviated in code as @stdout@—which-is usually printed to your terminal.+Tools tend to be run to either have an effect (in which case they tend not to+a say much of anything) or to report a result. This tends to be written to+\"standard output\"—traditionally abbreviated in code as @stdout@—which is+usually printed to your terminal.  Daemons, on the other hand, don't write their output to file descriptor 1; rather they tend to respond to requests by writing to files, replying over@@ -24,31 +25,31 @@ While there are many sophisticated logging services around that you can interact with directly, from the point of view of an individual /program/ these tend to have faded away and have become more an aspect of the-Infrastructure- or Platform-as-a-Service you're running on. Over the past-few years containerization mechanisms like __docker__, then more recently+Infrastructure- or Platform-as-a-Service you're running on. Over the past few+years containerization mechanisms like __docker__, then more recently container orchestration layers like __kubernetes__, have generally simply captured programs' standard output /as if it were the program's log output/ and then sent that down external logging channels to whatever log analysis system is available. Even programs running locally under __systemd__ or-similar tend to follow the same pattern; services write to @stdout@ and-that output, as "logs", ends up being fed to the system journal.+similar tend to follow the same pattern; services write to @stdout@ and that+output, as "logs", ends up being fed to the system journal. -So with that in mind, in your program you will either be outputting results-to @stdout@ or not writing there at all, and you will either be describing+So with that in mind, in your program you will either be outputting results to+@stdout@ or not writing there at all, and you will either be describing extensively what your application is up to, or not at all. -There is also a \"standard error\" file descriptor available. We recommend-not using it. At best it is unclear what is written to @stderr@ and what-isn't; at worse it is lost as many environments in the wild discard-@stderr@ entirely. To avoid this most of the time people just combine them-in the invoking shell with @2>&1@, which inevitably results in @stderr@-text appearing in the middle of normal @stdout@ lines corrupting them.+There is also a \"standard error\" file descriptor available. We recommend not+using it. At best it is unclear what is written to @stderr@ and what isn't; at+worse it is lost as many environments in the wild discard @stderr@ entirely.+To avoid this most of the time people just combine them in the invoking shell+with @2>&1@, which inevitably results in @stderr@ text appearing in the middle+of normal @stdout@ lines corrupting them.  The original idea of standard error was to provde a way to report adverse conditions without interrupting normal text output, but as we have just-observed if it happens without context or out of order there isn't much-point. Instead this library offers a mechanism which caters for the-different /kinds/ of output in a unified, safe manner.+observed if it happens without context or out of order there isn't much point.+Instead this library offers a mechanism which caters for the different /kinds/+of output in a unified, safe manner.  == Three kinds of output/logging messages @@ -57,63 +58,68 @@ Your program's normal output to the terminal. This library provides the 'write' (and 'writeS' and 'writeR') functions to send output to @stdout@. -/Events/+/Informational messages/  When running a tool, you sometimes need to know /what it is doing/ as it is-carrying out its steps. The 'event' function allows you to emit descriptive+carrying out its steps. The 'info' function allows you to emit descriptive messages to the log channel tracing the activities of your program.  Ideally you would never need to turn this on in a command-line tool, but-sometimes a user or operations engineer needs to see what an application is-up to. These should be human readable status messages to convey a sense of+sometimes a user or operations engineer needs to see what an application is up+to. These should be human readable status messages to convey a sense of progress. -In the case of long-running daemons, 'event' can be used to describe-high-level lifecycle events, to document individual requests, or even-describing individual transitions in a request handler's state machine, all-depending on the nature of your program.+In the case of long-running daemons, 'info' can be used to describe high-level+lifecycle events, to document individual requests, or even describe individual+transitions in a request handler's state machine, all depending on the nature+of your program.  /Debugging/ -Programmers, on the other hand, often need to see the internal state of-the program when /debugging/.+Programmers, on the other hand, often need to see the internal state of the+program when /debugging/. -You almost always you want to know the value of some variable or parameter,-so the 'debug' (and 'debugS' and 'debugR') utility functions here send-messages to the log channel prefixed with a label that is, by convention,-the name of the value you are examining.+You almost always you want to know the value of some variable or parameter, so+the 'debug' (and 'debugS' and 'debugR') utility functions here send log+messages to the console prefixed with a label that is, by convention, the name+of the value you are examining. -The important distinction here is that such internal values are almost-never useful for someone other than the person or team who wrote the code-emitting it. Operations engineers might be asked by developers to turn on-@--debug@ing and report back the results; but a user of your program is not-going to do that in and of themselves to solve a problem.+The important distinction here is that such internal values are almost never+useful for someone other than the person or team who wrote the code emitting+it. Operations engineers might be asked by developers to turn on @--debug@ing+and report back the results; but a user of your program is not going to do+that in and of themselves to solve a problem.  == Single output channel -It is the easy to make the mistake of having multiple subsystems attempting-to write to @stdout@ and these outputs corrupting each other, especially in-a multithreaded language like Haskell. The output actions described here-send all output to terminal down a single thread-safe channel. Output will-be written in the order it was executed, and (so long as you don't use the+It is the easy to make the mistake of having multiple subsystems attempting to+write to @stdout@ and these outputs corrupting each other, especially in a+multithreaded language like Haskell. The output actions described here send+all output to terminal down a single thread-safe channel. Output will be+written in the order it was executed, and (so long as you don't use the @stdout@ Handle directly yourself) your terminal output will be sound. -Passing @--verbose@ on the command-line of your program will cause 'event'-to write its tracing messages to the terminal. This shares the same output+Passing @--verbose@ on the command-line of your program will cause 'event' to+write its tracing messages to the terminal. This shares the same output channel as the 'write'@*@ functions and will /not/ cause corruption of your program's normal output.  Passing @--debug@ on the command-line of your program will cause the-'debug'@*@ actions to write their debug-level messages to the terminal.-This shares the same output channel as above and again will not cause-corruption of your program's normal output.+'debug'@*@ actions to write their debug-level messages to the terminal. This+shares the same output channel as above and again will not cause corruption of+your program's normal output. -== Logging channel+== Runtime -/Event and debug messages are internally also sent to a "logging channel",/-/as distinct from the "output" one. This would allow us to send them/-/directly to a file, syslog, or network logging service, but this is/-/as-yet unimplemented./+You can change the current logging level from within your program by calling+'Core.Program.Execute.setVerbosityLevel'. You can also toggle between normal+'Output', 'Verbose' output and 'Debug' logging by sending the @SIGUSR1@ signal+to the program using /kill/:++@+\$ kill -USR1 42069+\$+@ -} module Core.Program.Logging (     putMessage,@@ -124,13 +130,18 @@     writeS,     writeR, -    -- * Event tracing-    event,+    -- * Informational+    info,+    warn,+    critical,      -- * Debugging     debug,     debugS,     debugR,++    -- * Internals+    event, ) where  import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)@@ -146,39 +157,42 @@  import Core.Program.Context import Core.System.Base+import Core.Text.Colour import Core.Text.Rope import Core.Text.Utilities -{--class Monad m => MonadLog a m where-    logMessage :: Monoid a => Severity -> a -> m ()--}+data Message = Message TimeStamp Severity Rope (Maybe Rope) +data Severity+    = SeverityNone+    | SeverityCritical+    | SeverityWarn+    | SeverityInfo+    | SeverityDebug+ putMessage :: Context τ -> Message -> IO ()-putMessage context message@(Message now _ text potentialValue) = do+putMessage context (Message now level text possiblelValue) = do     let i = startTimeFrom context     start <- readMVar i     let output = outputChannelFrom context-    let logger = loggerChannelFrom context -    let display = case potentialValue of+    let display = case possiblelValue of             Just value ->                 if containsCharacter '\n' value                     then text <> " =\n" <> value                     else text <> " = " <> value             Nothing -> text -    let result = formatLogMessage start now display+    let result = formatLogMessage start now level display      atomically $ do         writeTQueue output result-        writeTQueue logger message -formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope-formatLogMessage start now message =-    let start' = unTimeStamp start-        now' = unTimeStamp now-        stampZ =+formatLogMessage :: TimeStamp -> TimeStamp -> Severity -> Rope -> Rope+formatLogMessage start now severity message =+    let !start' = unTimeStamp start+        !now' = unTimeStamp now+        !stampZ =             timePrint                 [ Format_Hour                 , Format_Text ':'@@ -191,16 +205,26 @@          -- I hate doing math in Haskell         elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3++        !color = case severity of+            SeverityNone -> emptyRope+            SeverityCritical -> intoEscapes pureRed+            SeverityWarn -> intoEscapes pureYellow+            SeverityInfo -> intoEscapes dullWhite+            SeverityDebug -> intoEscapes pureGrey++        reset = intoEscapes resetColour      in mconcat-            [ intoRope stampZ+            [ intoEscapes dullWhite+            , intoRope stampZ             , " ("             , padWithZeros 6 (show elapsed)             , ") "+            , color             , message+            , reset             ] ---- {- | Utility function to prepend \'0\' characters to a string representing a number.@@ -260,50 +284,123 @@         atomically (writeTQueue out text')  {- |-Note a significant event, state transition, status, or debugging-message. This:+Note a significant event, state transition, status; also used as a heading for+subsequent debugging messages. This:  @-    'event' "Starting..."+    'info' "Starting..." @  will result in  > 13:05:55Z (00.112) Starting... -appearing on stdout /and/ the message being sent down the logging-channel. The output string is current time in UTC, and time elapsed-since startup shown to the nearest millisecond (our timestamps are to-nanosecond precision, but you don't need that kind of resolution in-in ordinary debugging).+appearing on @stdout@. The output string is current time in UTC, and time+elapsed since startup shown to the nearest millisecond (our timestamps are to+nanosecond precision, but you don't need that kind of resolution in in+ordinary debugging). -Messages sent to syslog will be logged at @Info@ level severity.+@since 0.2.12 -}+info :: Rope -> Program τ ()+info text = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isEvent level) $ do+            now <- getCurrentTimeNanoseconds+            putMessage context (Message now SeverityInfo text Nothing)+ event :: Rope -> Program τ ()-event text = do+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+(potentially detrimentally).++@+     warn "You left the lights on again"+@++Warnings are worthy of note if you are looking into the behaviour of the+system, and usually—but not always—indicate a problem. That problem may not+need to be rectified, certainly not immediately.++__DO NOT PAGE OPERATIONS STAFF ON WARNINGS__.++For example, see "Core.Program.Execute"'s 'Core.Program.Execute.trap_'+function, a wrapper action which allows you to restart a loop when combined+with 'Control.Monad.forever'. @trap_@ swollows exceptions /but does not do/+/so silently/, instead using 'warn' to log a warning as an information+message. You don't need to do anything about the warning right away; after all+the point is to allow your program to continue. If it is happening unexpectly+or frequently, however, the issue bears investigation and the warning severity+message will give you a starting point for diagnosis.++@since 0.2.12+-}+warn :: Rope -> Program τ ()+warn text = do     context <- ask     liftIO $ do         level <- readMVar (verbosityLevelFrom context)         when (isEvent level) $ do             now <- getCurrentTimeNanoseconds-            putMessage context (Message now Event text Nothing)+            putMessage context (Message now SeverityWarn text Nothing) +{- |+Report an anomoly or condition critical to the ongoing health of the program.++@+     critical "Unable to do hostname lookups"      -- Yup, it was DNS. It's always DNS.+@++The term \"critical\" generally means the program is now in an unexpected or+invalid state, that further processing is incorrect, and that the program is+likely about to crash. The key is to get the message out to the informational+channel as quickly as possible before it does.++For example, an uncaught exception bubbling to the top the+'Core.Program.Execute.Program' monad will be logged as a 'critical' severity+message and forceibly output to the console before the program exits. Your+program is crashing, but at least you have a chance to find about why before+it does.++You're not going to page your operations staff on these either, but if they're+happening in a production service and it's getting restarted a lot as a result+you're probably going to be hearing about it.++@since 0.2.12+-}+critical :: Rope -> Program τ ()+critical text = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isEvent level) $ do+            now <- getCurrentTimeNanoseconds+            putMessage context (Message now SeverityCritical text Nothing)+ 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  {- | Output a debugging message formed from a label and a value. This is like-'event' above but for the (rather common) case of needing to inspect or-record the value of a variable when debugging code.  This:+'event' above but for the (rather common) case of needing to inspect or record+the value of a variable when debugging code. This:  @     'setProgramName' \"hello\"@@ -315,10 +412,8 @@  > 13:05:58Z (03.141) programName = hello -appearing on stdout /and/ the message being sent down the logging channel,-assuming these actions executed about three seconds after program start.--Messages sent to syslog will be logged at @Debug@ level severity.+appearing on @stdout@, assuming these actions executed about three seconds+after program start. -} debug :: Rope -> Rope -> Program τ () debug label value = do@@ -328,7 +423,7 @@         when (isDebug level) $ do             now <- getCurrentTimeNanoseconds             !value' <- evaluate value-            putMessage context (Message now Debug label (Just value'))+            putMessage context (Message now SeverityDebug label (Just value'))  {- | Convenience for the common case of needing to inspect the value@@ -359,4 +454,4 @@             -- TODO move render to putMessage? putMessageR?             let value = render columns thing             !value' <- evaluate value-            putMessage context (Message now Debug label (Just value'))+            putMessage context (Message now SeverityDebug label (Just value'))

@@ -46,7 +46,7 @@       g :: FilePath -> Set FilePath -> Set FilePath       g path acc = insertElement (dropFileName path) acc    in do-        event "Watching for changes"+        info "Watching for changes"          canonical <- mapM (liftIO . canonicalizePath) files         let paths = foldr f emptySet canonical

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# OPTIONS_GHC -Wno-deprecations #-}  module Core.Program.Signal (     setupSignalHandlers,@@ -53,6 +54,7 @@         ( \level -> case level of             Output -> pure Debug             Event -> pure Debug+            Verbose -> pure Debug             Debug -> pure Output         ) 

@@ -44,4 +44,4 @@     concatWith, ) where -import Data.Text.Prettyprint.Doc+import Prettyprinter