core-program 0.4.0.0 → 0.4.2.0
raw patch · 4 files changed
+98/−6 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Core.Program.Threads: linkThread :: Thread α -> Program τ ()
Files
- core-program.cabal +1/−1
- lib/Core/Program/Context.hs +10/−1
- lib/Core/Program/Execute.hs +16/−1
- lib/Core/Program/Threads.hs +71/−3
core-program.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: core-program-version: 0.4.0.0+version: 0.4.2.0 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons.
lib/Core/Program/Context.hs view
@@ -288,7 +288,14 @@ unlifting back to Program; see "Core.Program.Unlift". -} newtype Program τ α = Program (ReaderT (Context τ) IO α)- deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadReader (Context τ)+ , MonadFail+ ) unProgram :: Program τ α -> ReaderT (Context τ) IO α unProgram (Program r) = r@@ -520,6 +527,8 @@ {- | A utility exception for those occasions when you just need to go "boom".++@since 0.3.2 -} data Boom = Boom deriving (Show)
lib/Core/Program/Execute.hs view
@@ -216,6 +216,8 @@ 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.++@since 0.2.11 -} trap_ :: Program τ α -> Program τ () trap_ action =@@ -644,7 +646,6 @@ pure (exit, intoRope out, intoRope err) - {- | 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@@ -663,6 +664,8 @@ then times output in the log messages will be relative to that call to 'resetTimer', not the program start.++@since 0.2.7 -} resetTimer :: Program τ () resetTimer = do@@ -734,6 +737,8 @@ file <- 'queryArgument' \"filename\" ... @++@since 0.2.7 -} queryArgument :: LongName -> Program τ Rope queryArgument name = do@@ -763,6 +768,8 @@ files \<- 'queryRemaining' ... @++@since 0.3.5 -} queryRemaining :: Program τ [Rope] queryRemaining = do@@ -783,6 +790,8 @@ 'Just' value -> 'pure' value ... @++@since 0.3.5 -} queryOptionValue :: LongName -> Program τ (Maybe Rope) queryOptionValue name = do@@ -811,6 +820,8 @@ overwrite \<- 'queryOptionValue' \"overwrite\" ... @++@since 0.3.5 -} queryOptionFlag :: LongName -> Program τ Bool queryOptionFlag name = do@@ -831,6 +842,8 @@ {- | Look to see if the user supplied the named environment variable and if so, return what its value was.++@since 0.3.5 -} queryEnvironmentValue :: LongName -> Program τ (Maybe Rope) queryEnvironmentValue name = do@@ -858,6 +871,8 @@ @ mode <- queryCommandName @++@since 0.3.5 -} queryCommandName :: Program τ Rope queryCommandName = do
lib/Core/Program/Threads.hs view
@@ -27,6 +27,7 @@ forkThread, waitThread, waitThread_,+ linkThread, -- * Helper functions concurrentThreads,@@ -53,12 +54,15 @@ newMVar, readMVar, )+import qualified Control.Exception.Safe as Safe (catch) import Control.Monad ( void, ) import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Program.Context+import Core.Program.Logging import Core.System.Base+import Core.Text.Rope {- | A thread for concurrent computation.@@ -74,23 +78,61 @@ Fork a thread. The child thread will run in the same @Context@ as the calling @Program@, including sharing the user-defined application state value. +If the code in the child thread throws an exception that is /not/ caught+within that thread, the exception will kill the thread. Threads dying without+telling anyone is a bit of an anti-pattern, so this library logs a+warning-level log message if this happens. If you additionally want the+exception to propegate back to the parent thread (say, for example, you want+your whole program to die if any of its worker threads fail), then call+'linkThread' after forking.+ (this wraps __async__\'s 'Control.Concurrent.Async.async' which in turn wraps __base__'s 'Control.Concurrent.forkIO')++@since 0.2.7 -} forkThread :: Program τ α -> Program τ (Thread α) forkThread program = do context <- ask let i = startTimeFrom context+ let v = currentDatumFrom context liftIO $ do+ -- if someone calls resetTimer in the thread it should just be that+ -- thread's local duration that is affected, not the parent. We simply+ -- make a new MVar and copy the current start time into it.+ start <- readMVar i i' <- newMVar start - let context' = context{startTimeFrom = i'}+ -- we also need to fork the current Datum, in the same way that we do+ -- when we create a nested span. We do this simply by creating a new+ -- MVar so that when the new thread updates the attached metadata+ -- it'll be evolving a different object. + datum <- readMVar v+ v' <- newMVar datum++ let context' =+ context+ { startTimeFrom = i'+ , currentDatumFrom = v'+ }++ -- fork, and run nested program+ a <- Async.async $ do- subProgram context' program- Async.link a+ Safe.catch+ (subProgram context' program)+ ( \(e :: SomeException) ->+ let text = intoRope (displayException e)+ in do+ subProgram context' $ do+ warn "Uncaught exception in thread"+ debug "e" text+ throw e+ )+ return (Thread a) {- |@@ -98,6 +140,8 @@ operation. (this wraps __async__\'s 'wait')++@since 0.2.7 -} waitThread :: Thread α -> Program τ α waitThread (Thread a) = liftIO $ Async.wait a@@ -123,11 +167,27 @@ convetion as found in "Control.Monad", which has 'Control.Monad.mapM_' which does the same as 'Control.Monad.mapM' but which likewise discards the return value.++@since 0.2.7 -} waitThread_ :: Thread α -> Program τ () waitThread_ = void . waitThread {- |+Ordinarily if an exception is thrown in a forked thread that exception is+silently swollowed. If you instead need the exception to propegate back to the+parent thread, you can \"link\" the two together using this function.++(this wraps __async__\'s 'link')++@since 0.4.2+-}+linkThread :: Thread α -> Program τ ()+linkThread (Thread a) = do+ liftIO $ do+ Async.link a++{- | Fork two threads and wait for both to finish. The return value is the pair of each action's return types. @@ -145,6 +205,8 @@ 'concurrentThreads_' below. (this wraps __async__\'s 'Control.Concurrent.Async.concurrently')++@since 0.4.0 -} concurrentThreads :: Program τ α -> Program τ β -> Program τ (α, β) concurrentThreads one two = do@@ -162,6 +224,8 @@ running will be cancelled and the original exception is then re-thrown. (this wraps __async__\'s 'Control.Concurrent.Async.concurrently_')++@since 0.4.0 -} concurrentThreads_ :: Program τ α -> Program τ β -> Program τ () concurrentThreads_ one two = do@@ -191,6 +255,8 @@ 'raceThreads_' below. (this wraps __async__\'s 'Control.Concurrent.Async.race')++@since 0.4.0 -} raceThreads :: Program τ α -> Program τ β -> Program τ (Either α β) raceThreads one two = do@@ -215,6 +281,8 @@ @ (this wraps __async__\'s 'Control.Concurrent.Async.race_')++@since 0.4.0 -} raceThreads_ :: Program τ α -> Program τ β -> Program τ () raceThreads_ one two = do