core-program 0.4.6.4 → 0.5.0.1
raw patch · 10 files changed
+400/−142 lines, 10 filesdep −chronologiquedep ~core-datadep ~core-textPVP ok
version bump matches the API change (PVP)
Dependencies removed: chronologique
Dependency ranges changed: core-data, core-text
API changes (from Hackage documentation)
- Core.Program: Boom :: Boom
- Core.Program: data Boom
- Core.Program.Execute: catchesAsync :: (MonadCatch m, MonadThrow m) => m a -> [Handler m a] -> m a
- Core.Program.Execute: tryAsync :: (MonadCatch m, Exception e) => m a -> m (Either e a)
- Core.System.Base: bracket :: MonadMask m => m a -> (a -> m b) -> (a -> m c) -> m c
- Core.System.Base: catch :: (MonadCatch m, Exception e) => m a -> (e -> m a) -> m a
- Core.System.Base: finally :: MonadMask m => m a -> m b -> m a
- Core.System.Base: impureThrow :: Exception e => e -> a
- Core.System.Base: throw :: (MonadThrow m, Exception e) => e -> m a
- Core.System.External: TimeStamp :: Int64 -> TimeStamp
- Core.System.External: [unTimeStamp] :: TimeStamp -> Int64
- Core.System.External: getCurrentTimeNanoseconds :: IO TimeStamp
- Core.System.External: newtype TimeStamp
+ Core.Program.Exceptions: Boom :: Boom
+ Core.Program.Exceptions: bracket :: Program τ ρ -> (ρ -> Program τ γ) -> (ρ -> Program τ α) -> Program τ α
+ Core.Program.Exceptions: catch :: Exception ε => Program τ α -> (ε -> Program τ α) -> Program τ α
+ Core.Program.Exceptions: data Boom
+ Core.Program.Exceptions: finally :: Program τ α -> Program τ γ -> Program τ α
+ Core.Program.Exceptions: instance GHC.Exception.Type.Exception Core.Program.Exceptions.Boom
+ Core.Program.Exceptions: instance GHC.Show.Show Core.Program.Exceptions.Boom
+ Core.Program.Exceptions: onException :: Program τ α -> Program τ γ -> Program τ α
+ Core.Program.Exceptions: throw :: Exception ε => ε -> Program τ α
+ Core.Program.Exceptions: try :: Exception ε => Program τ α -> Program τ (Either ε α)
- Core.Program: Context :: MVar Rope -> Int -> Bool -> Version -> Config -> [Exporter] -> Parameters -> MVar ExitCode -> MVar TimeStamp -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> Maybe Forwarder -> MVar Datum -> MVar τ -> Context τ
+ Core.Program: Context :: MVar Rope -> Int -> Bool -> Version -> Config -> [Exporter] -> Parameters -> MVar ExitCode -> MVar Time -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> Maybe Forwarder -> MVar Datum -> MVar τ -> Context τ
- Core.Program: Datum :: Maybe Span -> Rope -> Maybe Rope -> TimeStamp -> Maybe Trace -> Maybe Span -> Maybe Int64 -> Map JsonKey JsonValue -> Datum
+ Core.Program: Datum :: Maybe Span -> Rope -> Maybe Rope -> Time -> Maybe Trace -> Maybe Span -> Maybe Int64 -> Map JsonKey JsonValue -> Datum
- Core.Program: [$sel:spanTimeFrom:Datum] :: Datum -> TimeStamp
+ Core.Program: [$sel:spanTimeFrom:Datum] :: Datum -> Time
- Core.Program: [$sel:startTimeFrom:Context] :: Context τ -> MVar TimeStamp
+ Core.Program: [$sel:startTimeFrom:Context] :: Context τ -> MVar Time
- Core.Program.Execute: catch :: (MonadCatch m, Exception e) => m a -> (e -> m a) -> m a
+ Core.Program.Execute: catch :: Exception ε => Program τ α -> (ε -> Program τ α) -> Program τ α
- Core.Program.Execute: throw :: (MonadThrow m, Exception e) => e -> m a
+ Core.Program.Execute: throw :: Exception ε => ε -> Program τ α
- Core.Program.Execute: try :: (MonadCatch m, Exception e) => m a -> m (Either e a)
+ Core.Program.Execute: try :: Exception ε => Program τ α -> Program τ (Either ε α)
Files
- core-program.cabal +5/−5
- lib/Core/Program.hs +3/−1
- lib/Core/Program/Context.hs +17/−44
- lib/Core/Program/Exceptions.hs +289/−0
- lib/Core/Program/Execute.hs +32/−20
- lib/Core/Program/Logging.hs +19/−18
- lib/Core/Program/Threads.hs +13/−12
- lib/Core/System.hs +20/−18
- lib/Core/System/Base.hs +1/−14
- lib/Core/System/External.hs +1/−10
core-program.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: core-program-version: 0.4.6.4+version: 0.5.0.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons.@@ -27,7 +27,7 @@ license-file: LICENSE build-type: Simple tested-with:- GHC == 8.10.7+ GHC == 8.10.7, GHC == 9.2.2 source-repository head type: git@@ -39,6 +39,7 @@ Core.Program.Arguments Core.Program.Context Core.Program.Execute+ Core.Program.Exceptions Core.Program.Logging Core.Program.Metadata Core.Program.Notify@@ -57,9 +58,8 @@ async , base >=4.11 && <5 , bytestring- , chronologique- , core-data >=0.3.2.2- , core-text >=0.3.7.0+ , core-data >=0.3.3+ , core-text >=0.3.7 , directory , exceptions , filepath
lib/Core/Program.hs view
@@ -24,6 +24,7 @@ module Core.Program.Threads, module Core.Program.Unlift, module Core.Program.Metadata,+ module Core.Program.Exceptions, -- * Command-line argument parsing @@ -48,9 +49,10 @@ where import Core.Program.Arguments+import Core.Program.Context+import Core.Program.Exceptions import Core.Program.Execute import Core.Program.Logging-import Core.Program.Context import Core.Program.Metadata import Core.Program.Notify import Core.Program.Threads
lib/Core/Program/Context.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -34,32 +35,31 @@ getContext, fmapContext, subProgram,- Boom (..), ) where -import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds) 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.Exception.Safe qualified 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.Clock 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.System.Base 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) import Prettyprinter.Render.Text (renderIO)-import qualified System.Console.Terminal.Size as Terminal (Window (..), size)+import System.Console.Terminal.Size qualified as Terminal (Window (..), size) import System.Environment (getArgs, getProgName, lookupEnv) import System.Exit (ExitCode (..), exitWith)-import qualified System.Posix.Process as Posix (exitImmediately)+import System.IO (hIsTerminalDevice)+import System.Posix.Process qualified as Posix (exitImmediately) import Prelude hiding (log) {- |@@ -75,7 +75,7 @@ { spanIdentifierFrom :: Maybe Span , spanNameFrom :: Rope , serviceNameFrom :: Maybe Rope- , spanTimeFrom :: TimeStamp+ , spanTimeFrom :: Time , traceIdentifierFrom :: Maybe Trace , parentIdentifierFrom :: Maybe Span , durationFrom :: Maybe Int64@@ -89,7 +89,7 @@ { spanIdentifierFrom = Nothing , spanNameFrom = emptyRope , serviceNameFrom = Nothing- , spanTimeFrom = 0+ , spanTimeFrom = epochTime , traceIdentifierFrom = Nothing , parentIdentifierFrom = Nothing , durationFrom = Nothing@@ -162,25 +162,19 @@ -- that field name as a local variable name. -- data Context τ = Context- { -- runtime properties- programNameFrom :: MVar Rope+ { programNameFrom :: MVar Rope , terminalWidthFrom :: Int , terminalColouredFrom :: Bool , versionFrom :: Version- , -- only used during initial setup- initialConfigFrom :: Config+ , initialConfigFrom :: Config -- only used during initial setup , initialExportersFrom :: [Exporter]- , -- derived at startup- commandLineFrom :: Parameters- , -- operational state- exitSemaphoreFrom :: MVar ExitCode- , startTimeFrom :: MVar TimeStamp+ , commandLineFrom :: Parameters -- derived at startup+ , exitSemaphoreFrom :: MVar ExitCode+ , startTimeFrom :: MVar Time , verbosityLevelFrom :: MVar Verbosity- , -- communication channels- outputChannelFrom :: TQueue (Maybe Rope)- , telemetryChannelFrom :: TQueue (Maybe Datum)- , -- machinery for telemetry- telemetryForwarderFrom :: Maybe Forwarder+ , outputChannelFrom :: TQueue (Maybe Rope) -- communication channels+ , telemetryChannelFrom :: TQueue (Maybe Datum) -- machinery for telemetry+ , telemetryForwarderFrom :: Maybe Forwarder , currentDatumFrom :: MVar Datum , applicationDataFrom :: MVar τ }@@ -398,13 +392,11 @@ 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 encountered or a [mandatory] argument is missing, then the program will@@ -536,22 +528,3 @@ case target == codenameFrom exporter of False -> lookupExporter target exporters True -> Just exporter--{- |-A utility exception for those occasions when you just need to go "boom".--@- case 'Core.Data.Structures.containsKey' \"James Bond\" agents of- False -> do- evilPlan- True -> do- 'Core.Program.Logging.write' \"No Mr Bond, I expect you to die!\"- 'Core.System.Base.throw' 'Boom'-@--@since 0.3.2--}-data Boom = Boom- deriving (Show)--instance Exception Boom
+ lib/Core/Program/Exceptions.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE ImportQualifiedPost #-}++{- |+Facilities for handling exceptions.++The Haskell language itself doesn't treat exceptions specially, but the+Haskell /runtime/ does. Any I/O action can result in exceptions being thrown+and frequently do. Developers can define exceptions too, and use them to+signal anomolies.++In order to catch an exception you need to know the /type/ of that exception.+The way this is typically done is with the @ScopedTypeVariables@ extension+turned on and then adding a type annotation around the @e@ variable in the+lambda passed to 'catch'.++@+ 'catch'+ (do+ performSong \"This is my party and I\'ll cry if I want to\"+ )+ (\\(e :: FirstWorldProblem) -> do+ 'Core.Program.Logging.critical' \"Someone is crying\"+ 'Core.Program.Logging.debug' "e" ('Control.Exception.displayException' e)+ 'Core.Program.Execute.terminate' 1+ )+@++which would work on the assumption that somewhere you have defined:++@+data FirstWorldProblem+ = PersonCrying+ | MyToastIsBurnt+ | SomeoneWrongOnInternet 'Core.Text.Rope'+ deriving 'Show'++instance 'Control.Exception.Exception' FirstWorldProblem+@++and that the @performSong@ function at some point does something like:++@+performSong :: Lyrics -> 'Program' 'Core.Program.Execute.None' ()+performSong lyrics = do+ ...+ 'throw' PersonCrying+@++Keep in mind that exceptions are really for signalling failure and aren't+generally that recoverable. Their utility is that they unwind the call stack+from the point that failure occurs and get you back to somewhere you can+handle it, but in Haskell \"handling it\" really just means that you log the+problem and either go on to processing the next request or then outright+terminate the program.++Thus a good pattern for using exceptions effectively is to use small blocks of+pure code which can fail in the type 'Either' 'Core.Text.Rope' @a@, then+pattern matching on what you get back: if you get a 'Left' back then you+'throw' an exception, otherwise you return the value with 'pure' and continue:++@+ result <- case calculateInterestingThing inputs of+ 'Left' problem -> 'throw' (SomeoneWrongOnInternet problem)+ 'Right' value -> 'pure' value+ ...+@++this works rather nicely especially when you're doing lots of parsing; small+things that can fail but it's all pure code. In conjunction with the 'Either'+monad you can quickly work through getting the values you need knowing it will+fail fast if something goes wrong and you can get an appropriate error message+back to the surface (in our case the 'Program' @τ@ monad) and you can 'throw'+from there.+-}+module Core.Program.Exceptions (+ catch,+ try,+ throw,+ bracket,+ finally,+ onException,+ Boom (..),+) where++import Control.Exception qualified as Base (+ Exception,+ )+import Control.Exception.Safe qualified as Safe (+ bracket,+ catch,+ finally,+ onException,+ throw,+ try,+ )+import Core.Program.Context (+ Program,+ )++{- |+Catch an exception.++Some care must be taken. Remember that even though it is constrained by the+'Control.Exception.Exception' typeclass, @ε@ does /not/ stand for \"any\"+exception type; is has a concrete type when it gets to being used in your+code. Things are fairly straight-forward if you know exactly the exception you+are looking for:++@+ 'catch'+ action+ (\\(e :: FirstWorldProblem) -> do+ ...+ )+@++but more awkward when you don't.++If you just need to catch all exceptions, the pattern for that is as follows:++@+ 'catch'+ action+ (\\(e :: 'Control.Exception.SomeException') -> do+ ...+ )+@++The 'Control.Exception.SomeException' type is the root type of all exceptions;+or rather, all types that have an instance of 'Control.Exception.Exception'+can be converted into this root type. Thus you /can/ catch all synchronous+exceptions but you can't tell which type of exception it was originally; you+rely on the 'Show' instance (which is the default that+'Control.Exception.displayException' falls back to) to display a message which+will hopefully be of enough utility to figure out what the problem is. In+fairness it usually is. (This all seems a bit of a deficiency in the+underlying exception machinery but it's what we have)++This 'catch' function will /not/ catch asynchonous exceptions. If you need to+do that, see the more comprehensive exception handling facilities offered by+__safe-exceptions__, which in turn builds on __exceptions__ and __base__).+Note that 'Program' implements 'Control.Monad.Catch.MonadCatch' so you can use+the full power available there if required.++@since 0.5.0+-}+catch :: Base.Exception ε => Program τ α -> (ε -> Program τ α) -> Program τ α+catch = Safe.catch++{- |+Catch an exception. Instead of handling an exception in a supplied function,+however, return from executing the sub-program with the outcome in an+'Either', with the exception being on the 'Left' side if one is thrown. If the+sub-program completes normally its result is in the 'Right' side.++(this is a wrapper around calling __safe-exceptions__\'s+'Control.Exceptions.Safe.try' function, which in turn wraps __exceptions__\'s+'Control.Exceptions.try', which...)++@since 0.5.0+-}+try :: Base.Exception ε => Program τ α -> Program τ (Either ε α)+try = Safe.try++{- |+Throw an exception.++This will be thrown as a normal synchronous exception that can be caught with+'catch' or 'try' above.++Don't try and use this from pure code! A common temptation is to be in the+middle of a computation, hit a problem, and think \"oh, that's bad. I guess+I'll throw an exception!\". You /can\'t/. Surface the problem back to the I/O+level code that 'Program' @τ@ monad provides, and /then/ you can throw an+exception if appropriate.++When you /do/ throw an exception, we recommend you go to some trouble to make+sure that the string or otherwise descriptive message is unique in your+codebase. If you do so then when the problem arises you will be able to+quickly search for that string and find the place where the exception arose+from, even without the benefit of stack traces. For example,++@+ 'throw' (SomeoneWrongOnInternet \"Ashley thinks there are more than three Star Wars movies\")+@++which will get you a nice crash message as your world falls down around you:++@+22:54:39Z (00.002) SomeoneWrongOnInternet \"Ashley thinks there are more than three Star Wars movies\"+$+@++but if you're in a hurry and don't want to define a local exception type to+use,++@+ 'throw' 'Boom'+@++will work.++(experienced users will note that 'Program' implements+'Control.Monad.Catch.MonadThrow' and as such this is just a wrapper around+calling __safe-exceptions__'s 'Control.Exceptions.Safe.throw' function)++@since 0.5.0+-}+throw :: Base.Exception ε => ε -> Program τ α+throw = Safe.throw++{- |+Acquire a resource, use it, then release it back.++The bracket pattern is common in Haskell for getting a resource @ρ@ needed for+a computation, preforming that computation, then returning the resource back+to the system. Common examples are when making database connections and doing+file or network operations, where you need to make sure you "close" the+connection afterward before continuing the program so that scare resources+like file handles are released.++Typically you have an open and close action that return and take a resource+respectively, so you can use those directly, and use a lambda in the third+action to actally get at the resource and do something with it when you need+it:++@+ 'bracket'+ (openConnection)+ (closeConnection)+ (\c -> do+ this+ thatAndNow+ theOtherThingThatNeeds c+ )+@++Note that 'bracket' does /not/ catch the exception if one is thrown! The+finalizer will run, but then the exception will continue to propogate its way+out of your program's call stack. Note also that the result of the cleanup+action @γ@ is ignored (it can be @()@ or anythign else; it will be discarded).++@since 0.5.0+-}+bracket :: Program τ ρ -> (ρ -> Program τ γ) -> (ρ -> Program τ α) -> Program τ α+bracket = Safe.bracket++{- |+Run an action and then, run a finalizer afterwards. The second action will run+whether or not an exception was raised by the first one. This is like+'bracket' above, but can be used when you know you have cleanup steps to take+after your computation which /do/ have to be run even if (especially if!) an+exception is thrown but that that cleanup doesn't depend on the result of that+computation or the resources used to do it. The return value @γ@ of the+subsequent action is ignored.++@since 0.5.0+-}+finally :: Program τ α -> Program τ γ -> Program τ α+finally = Safe.finally++{- |+Run an action and then, if an exception was raised (and only if an exception+was raised), run the second action. The return value @γ@ of the subsequent+action is is ignored.++@since 0.5.0+-}+onException :: Program τ α -> Program τ γ -> Program τ α+onException = Safe.onException++{- |+A utility exception for those occasions when you just need to go "boom".++@+ case 'Core.Data.Structures.containsKey' \"James Bond\" agents of+ 'False' -> do+ evilPlan+ 'True' -> do+ 'Core.Program.Logging.write' \"No Mr Bond, I expect you to die!\"+ 'throw' 'Boom'+@++@since 0.3.2+-}+data Boom = Boom+ deriving (Show)++instance Base.Exception Boom
lib/Core/Program/Execute.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -83,12 +84,10 @@ resetTimer, trap_, - -- * Re-exports from safe-exports- Safe.catch,- Safe.catchesAsync,- Safe.throw,- Safe.try,- Safe.tryAsync,+ -- * Exception handling+ catch,+ throw,+ try, -- * Internals Context,@@ -104,12 +103,11 @@ lookupEnvironmentValue, ) where -import Chrono.TimeStamp (getCurrentTimeNanoseconds) import Control.Concurrent (threadDelay) import Control.Concurrent.Async ( ExceptionInLinkedThread (..), )-import qualified Control.Concurrent.Async as Async (+import Control.Concurrent.Async qualified as Async ( async, cancel, race,@@ -132,32 +130,46 @@ unGetTQueue, writeTQueue, )-import qualified Control.Exception as Base (throwIO)-import qualified Control.Exception.Safe as Safe (catch, catchesAsync, throw, try, tryAsync)+import Control.Exception qualified as Base (throwIO)+import Control.Exception.Safe qualified as Safe (+ catch,+ catchesAsync,+ throw,+ ) import Control.Monad ( void, when, ) import Control.Monad.Catch (Handler (..)) import Control.Monad.Reader.Class (MonadReader (ask))+import Core.Data.Clock import Core.Data.Structures import Core.Program.Arguments import Core.Program.Context+import Core.Program.Exceptions import Core.Program.Logging import Core.Program.Signal-import Core.System.Base+import Core.System.Base (+ Exception,+ Handle,+ SomeException,+ displayException,+ hFlush,+ liftIO,+ stdout,+ ) import Core.Text.Bytes import Core.Text.Rope-import qualified Data.ByteString as B (hPut)-import qualified Data.ByteString.Char8 as C (singleton)-import qualified Data.List as List (intersperse)+import Data.ByteString qualified as B (hPut)+import Data.ByteString.Char8 qualified as C (singleton)+import Data.List qualified as List (intersperse) import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities) import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Directory ( findExecutable, ) import System.Exit (ExitCode (..))-import qualified System.Posix.Process as Posix (exitImmediately)+import System.Posix.Process qualified as Posix (exitImmediately) import System.Process.Typed (closed, proc, readProcess, setStdin) import Prelude hiding (log) @@ -397,7 +409,7 @@ -- handle it and loop Just items -> do start <- getCurrentTimeNanoseconds- catch+ Safe.catch ( do action (reverse items) reportStatus start (length items)@@ -550,7 +562,7 @@ 'setApplicationState'. @- state <- getApplicationState+ settings <- 'getApplicationState' @ -} getApplicationState :: Program τ τ@@ -564,8 +576,8 @@ Update the user supplied top-level application state. @- let state' = state { answer = 42 }- setApplicationState state'+ let settings' = settings { answer = 42 }+ 'setApplicationState' settings' @ -} setApplicationState :: τ -> Program τ ()@@ -648,7 +660,7 @@ findExecutable cmd' case probe of Nothing -> do- throw (CommandNotFound cmd)+ Safe.throw (CommandNotFound cmd) Just _ -> do (exit, out, err) <- liftIO $ do readProcess task1
lib/Core/Program/Logging.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK prune #-}@@ -147,7 +148,6 @@ isInternal, ) where -import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds) import Control.Concurrent.MVar (readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (writeTQueue)@@ -155,16 +155,17 @@ import Control.Monad (when) import Control.Monad.Reader.Class (MonadReader (ask)) import Data.Fixed-import Data.Hourglass (TimeFormatElem (..), timePrint)-import qualified Data.Text.Short as S (replicate)+import Data.Hourglass qualified as H (ElapsedP, TimeFormatElem (..), timePrint)+import Data.Text.Short qualified as S (replicate) +import Core.Data.Clock import Core.Program.Context import Core.System.Base import Core.Text.Colour import Core.Text.Rope import Core.Text.Utilities -data Message = Message TimeStamp Severity Rope (Maybe Rope)+data Message = Message Time Severity Rope (Maybe Rope) data Severity = SeverityNone@@ -193,20 +194,20 @@ atomically $ do writeTQueue output (Just result) -formatLogMessage :: TimeStamp -> TimeStamp -> Bool -> Severity -> Rope -> Rope+formatLogMessage :: Time -> Time -> Bool -> Severity -> Rope -> Rope formatLogMessage start now coloured severity message =- let !start' = unTimeStamp start- !now' = unTimeStamp now+ let !start' = unTime start+ !now' = unTime now !stampZ =- timePrint- [ Format_Hour- , Format_Text ':'- , Format_Minute- , Format_Text ':'- , Format_Second- , Format_Text 'Z'+ H.timePrint+ [ H.Format_Hour+ , H.Format_Text ':'+ , H.Format_Minute+ , H.Format_Text ':'+ , H.Format_Second+ , H.Format_Text 'Z' ]- now+ (fromTime now :: H.ElapsedP) -- I hate doing math in Haskell !elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3@@ -334,7 +335,7 @@ (potentially detrimentally). @- warn "You left the lights on again"+ 'warn' "You left the lights on again" @ Warnings are worthy of note if you are looking into the behaviour of the@@ -367,7 +368,7 @@ 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.+ '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@@ -470,7 +471,7 @@ let columns = terminalWidthFrom context - -- TODO take into account 22 width already consumed by timestamp+ -- TODO take into account 22 width already consumed by Time -- TODO move render to putMessage? putMessageR? let value = render columns thing !value' <- evaluate value
lib/Core/Program/Threads.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -43,8 +44,8 @@ unThread, ) where -import Control.Concurrent.Async (Async, AsyncCancelled, cancel)-import qualified Control.Concurrent.Async as Async (+import Control.Concurrent.Async (Async, AsyncCancelled)+import Control.Concurrent.Async qualified as Async ( async, cancel, concurrently,@@ -59,7 +60,7 @@ newMVar, readMVar, )-import qualified Control.Exception.Safe as Safe (catch, catchAsync)+import Control.Exception.Safe qualified as Safe (catch, catchAsync, throw) import Control.Monad ( void, )@@ -139,7 +140,7 @@ subProgram context' $ do warn "Uncaught exception in thread" debug "e" text- throw e+ Safe.throw e ) return (Thread a)@@ -167,8 +168,8 @@ Safe.catchAsync (Async.wait a) ( \(e :: AsyncCancelled) -> do- cancel a- throw e+ Async.cancel a+ Safe.throw e ) {- |@@ -219,8 +220,8 @@ pure result ) ( \(e :: AsyncCancelled) -> do- cancel a- throw e+ Async.cancel a+ Safe.throw e ) {- |@@ -273,8 +274,8 @@ pure results ) ( \(e :: AsyncCancelled) -> do- mapM_ cancel as- throw e+ mapM_ Async.cancel as+ Safe.throw e ) {- |@@ -364,9 +365,9 @@ @ result <- 'raceThreads' one two case result of- Left a -> do+ 'Left' a -> do -- one finished first- Right b -> do+ 'Right' b -> do -- two finished first @
lib/Core/System.hs view
@@ -1,22 +1,25 @@+{-# OPTIONS_GHC -Wno-dodgy-exports #-}+{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_HADDOCK not-home #-} --- |--- Common elements from the rest of the Haskell ecosystem. This is mostly--- about re-exports. There are numerous types and functions that are more or--- less assumed to be in scope when you're doing much of anything in Haskell;--- this module is a convenience to pull in the ones we rely on for the rest of--- this library.------ You can just import this directly:------ @--- import "Core.System"--- @------ as there's no particular benefit to cherry-picking the various sub-modules.-module Core.System- ( -- * Base libraries+{- |+Common elements from the rest of the Haskell ecosystem. This is mostly about+re-exports. There are numerous types and functions that are more or less+assumed to be in scope when you're doing much of anything in Haskell; this+module is a convenience to pull in the ones we rely on for the rest of this+library. +You can just import this directly:++@+import "Core.System"+@++as there's no particular benefit to cherry-picking the various sub-modules.+-}+module Core.System (+ -- * Base libraries+ -- | -- Re-exports from foundational libraries supplied by the compiler runtime, -- or from re-implementations of those areas.@@ -39,8 +42,7 @@ -- pretty printed. There are a large family of combinators used when doing -- this. For convenience they are exposed here. module Core.System.Pretty,- )-where+) where import Core.System.Base import Core.System.External
lib/Core/System/Base.hs view
@@ -28,26 +28,13 @@ -- * Exception handling - -- ** from Control.Exception.Safe-- -- | Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: Exception (..), SomeException,- throw,- impureThrow,- bracket,- catch,- finally, ) where -import Control.Exception.Safe (+import Control.Exception ( Exception (..), SomeException,- bracket,- catch,- finally,- impureThrow,- throw, ) import Control.Monad.IO.Class (MonadIO, liftIO) import System.IO (Handle, IOMode (..), hFlush, stderr, stdin, stdout, withFile)
lib/Core/System/External.hs view
@@ -4,13 +4,4 @@ Re-exports of dependencies from various external libraries. -} module Core.System.External (- -- * Time-- -- ** from Chrono.TimeStamp-- -- | Re-exported from "Chrono.TimeStamp" in __chronologique__:- TimeStamp (..),- getCurrentTimeNanoseconds,-) where--import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)+ ) where