packages feed

polysemy-process 0.12.1.0 → 0.15.0.0

raw patch · 36 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2020 Torsten Schmits+Copyright (c) 2023 Torsten Schmits  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
changelog.md view
@@ -1,4 +1,10 @@-# Unreleased+# 0.14.0.0++## Breaking++* Move `Interrupt` here from `polysemy-conc`.++# 0.10.0.0  * Add `oneshot` variants of `Process` interpreters that send `Stop` to the individual actions inside the scope, modeling   a process that is expected to terminate.
lib/Polysemy/Process.hs view
@@ -1,4 +1,4 @@--- |Description: Polysemy Effects for System Processes+-- | Description: Polysemy Effects for System Processes module Polysemy.Process (   -- * Introduction   -- $intro@@ -35,6 +35,10 @@   Pty,   withPty, +  -- ** Signal Handling+  -- $signal+  Interrupt,+   -- * Interpreters   -- ** Process   interpretProcess,@@ -92,6 +96,11 @@   -- ** Pty   interpretPty, +  -- ** Signal Handling+  interpretInterrupt,+  interpretInterruptOnce,+  interpretInterruptNull,+   -- * Tools   resolveExecutable, ) where@@ -104,6 +113,7 @@ import Polysemy.Process.Data.ProcessOptions (ProcessOptions (ProcessOptions)) import Polysemy.Process.Data.ProcessOutputParseResult (ProcessOutputParseResult (..)) import Polysemy.Process.Data.SystemProcessError (SystemProcessError, SystemProcessScopeError)+import Polysemy.Process.Effect.Interrupt (Interrupt) import Polysemy.Process.Effect.Process (   Process (..),   recv,@@ -118,6 +128,7 @@ import Polysemy.Process.Effect.Pty (Pty, withPty) import Polysemy.Process.Effect.SystemProcess (SystemProcess, withSystemProcess, withSystemProcess_) import Polysemy.Process.Executable (resolveExecutable)+import Polysemy.Process.Interpreter.Interrupt (interpretInterrupt, interpretInterruptNull, interpretInterruptOnce) import Polysemy.Process.Interpreter.Process (   interpretInputHandle,   interpretInputHandleBuffered,@@ -185,3 +196,6 @@ -- -- The effect 'Pty' abstracts pseudo terminals. -- See "Polysemy.Process.Pty" for its constructors.++-- $signal+-- #signal#
lib/Polysemy/Process/Data/Pid.hs view
@@ -1,7 +1,7 @@--- |Pid data type, Internal+-- | Pid data type, Internal module Polysemy.Process.Data.Pid where --- |A process ID.+-- | A process ID. newtype Pid =   Pid { unPid :: Int }   deriving stock (Eq, Show, Read)
lib/Polysemy/Process/Data/ProcessError.hs view
@@ -1,20 +1,20 @@ {-# options_haddock prune #-} --- |Description: ProcessError, Internal+-- | Description: ProcessError, Internal module Polysemy.Process.Data.ProcessError where  import System.Exit (ExitCode)  import Polysemy.Process.Data.SystemProcessError (SystemProcessScopeError) --- |Signal error for 'Polysemy.Process.Process'.+-- | Signal error for 'Polysemy.Process.Process'. data ProcessError =-  -- |Something broke.+  -- | Something broke.   Unknown Text   |-  -- |The process failed to start.+  -- | The process failed to start.   StartFailed SystemProcessScopeError   |-  -- |The process terminated with exit code.+  -- | The process terminated with exit code.   Exit ExitCode   deriving stock (Eq, Show)
lib/Polysemy/Process/Data/ProcessKill.hs view
@@ -1,16 +1,16 @@--- |Data type indicating whether to kill a process after exiting its scope.+-- | Data type indicating whether to kill a process after exiting its scope. module Polysemy.Process.Data.ProcessKill where  import Polysemy.Time (NanoSeconds) --- |Indicate whether to kill a process after exiting the scope in which it was used, if it hasn't terminated.+-- | Indicate whether to kill a process after exiting the scope in which it was used, if it hasn't terminated. data ProcessKill =-  -- |Wait for the specified interval, then kill.+  -- | Wait for the specified interval, then kill.   KillAfter NanoSeconds   |-  -- |Kill immediately.+  -- | Kill immediately.   KillImmediately   |-  -- |Wait indefinitely for the process to terminate.+  -- | Wait indefinitely for the process to terminate.   KillNever   deriving stock (Eq, Show)
lib/Polysemy/Process/Data/ProcessOptions.hs view
@@ -1,17 +1,17 @@--- |Data type containing options for processes.+-- | Data type containing options for processes. module Polysemy.Process.Data.ProcessOptions where  import qualified Polysemy.Process.Data.ProcessKill as ProcessKill import Polysemy.Process.Data.ProcessKill (ProcessKill) --- |Controls the behaviour of 'Polysemy.Process.Process' interpreters.+-- | Controls the behaviour of 'Polysemy.Process.Process' interpreters. data ProcessOptions =   ProcessOptions {-    -- |Whether to discard output chunks if the queue is full.+    -- | Whether to discard output chunks if the queue is full.     discard :: Bool,-    -- |Maximum number of chunks allowed to be queued for each of the three standard pipes.+    -- | Maximum number of chunks allowed to be queued for each of the three standard pipes.     qsize :: Int,-    -- |What to do if the process hasn't terminated when exiting the scope.+    -- | What to do if the process hasn't terminated when exiting the scope.     kill :: ProcessKill   }   deriving stock (Eq, Show)
lib/Polysemy/Process/Data/ProcessOutputParseResult.hs view
@@ -1,7 +1,7 @@--- |A data type encoding the result of an incremental parser for process output.+-- | A data type encoding the result of an incremental parser for process output. module Polysemy.Process.Data.ProcessOutputParseResult where --- |An incremental parse result, potentially a partial result containing a continuation function.+-- | An incremental parse result, potentially a partial result containing a continuation function. data ProcessOutputParseResult a =   Done { value :: a, leftover :: ByteString }   |
lib/Polysemy/Process/Data/PtyError.hs view
@@ -1,9 +1,9 @@ {-# options_haddock prune #-} --- |PtyError ADT, Internal+-- | PtyError ADT, Internal module Polysemy.Process.Data.PtyError where --- |Internal error used by an interpreter for 'Polysemy.Process.Pty'.+-- | Internal error used by an interpreter for 'Polysemy.Process.Pty'. data PtyError =   PtyError Text   deriving stock (Eq, Show)
lib/Polysemy/Process/Data/PtyResources.hs view
@@ -1,13 +1,13 @@ {-# options_haddock prune #-} --- |Description: PtyResources ADT, Internal+-- | Description: PtyResources ADT, Internal module Polysemy.Process.Data.PtyResources where  import System.IO (Handle) import System.Posix (Fd) import System.Posix.Pty (Pty) --- |The resources used by the default interpreter for 'Polysemy.Process.Pty'.+-- | The resources used by the default interpreter for 'Polysemy.Process.Pty'. data PtyResources =   PtyResources {     primary :: Fd,
lib/Polysemy/Process/Data/SystemProcessError.hs view
@@ -1,19 +1,19 @@ {-# options_haddock prune #-} --- |Description: SystemProcessError, Internal+-- | Description: SystemProcessError, Internal module Polysemy.Process.Data.SystemProcessError where --- |Error for 'Polysemy.Process.SystemProcess'.+-- | Error for 'Polysemy.Process.SystemProcess'. data SystemProcessError =-  -- |The process terminated.+  -- | The process terminated.   Terminated Text   |-  -- |Stdio was requested, but the process was started without pipes.+  -- | Stdio was requested, but the process was started without pipes.   NoPipes   deriving stock (Eq, Show) --- |Error for the scope of 'Polysemy.Process.SystemProcess'.+-- | Error for the scope of 'Polysemy.Process.SystemProcess'. data SystemProcessScopeError =-  -- |The process couldn't start.+  -- | The process couldn't start.   StartFailed Text   deriving stock (Eq, Show)
+ lib/Polysemy/Process/Effect/Interrupt.hs view
@@ -0,0 +1,44 @@+{-# options_haddock prune #-}+-- | Description: Interrupt effect+module Polysemy.Process.Effect.Interrupt where++-- | The interrupt handler effect allows three kinds of interaction for interrupt signals:+--+-- - Execute a callback when a signal is received+-- - Block a thread until a signal is received+-- - Kill a thread when a signal is received+--+-- For documentation on the constructors, see the module "Polysemy.Process.Effect.Interrupt".+--+-- @+-- import qualified Polysemy.Process.Effect.Interrupt as Interrupt+--+-- prog = do+--   Interrupt.register "task 1" (putStrLn "interrupted")+--   Interrupt.killOnQuit $ forever do+--    doSomeWork+-- @+data Interrupt :: Effect where+  -- | Add a computation to be executed on interrupt, using the first argument as a key.+  Register :: Text -> IO () -> Interrupt m ()+  -- | Remove the previously added handler with the given key.+  Unregister :: Text -> Interrupt m ()+  -- | Manually trigger the interrupt.+  Quit :: Interrupt m ()+  -- | Block until an interrupt is triggered.+  WaitQuit :: Interrupt m ()+  -- | Indicate whether an interrupt was triggered.+  Interrupted :: Interrupt m Bool+  -- | Execute a computation, waiting for it to finish, killing its thread on interrupt.+  KillOnQuit :: Text -> m a -> Interrupt m (Maybe a)++makeSem ''Interrupt++-- | Variant of 'killOnQuit' that returns @()@.+killOnQuit_ ::+  Member Interrupt r =>+  Text ->+  Sem r a ->+  Sem r ()+killOnQuit_ desc ma =+  void (killOnQuit desc ma)
lib/Polysemy/Process/Effect/Process.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Process Effect, Internal+-- | Description: Process Effect, Internal module Polysemy.Process.Effect.Process where  import Polysemy.Input (Input (Input))@@ -8,7 +8,7 @@ import Polysemy.Resume (interpretResumable, restop, type (!!)) import Prelude hiding (send) --- |Abstraction of a process with input and output.+-- | Abstraction of a process with input and output. -- -- This effect is intended to be used in a scoped_ manner: --@@ -36,20 +36,20 @@  makeSem_ ''Process --- |Obtain a chunk of output.+-- | Obtain a chunk of output. recv ::   ∀ i o r .   Member (Process i o) r =>   Sem r o --- |Send data to stdin.+-- | Send data to stdin. send ::   ∀ i o r .   Member (Process i o) r =>   i ->   Sem r () --- |Create a scoped_ resource for 'Process'.+-- | Create a scoped_ resource for 'Process'. -- The process configuration may depend on the provided value of type @param@. -- This variant models daemon processes that are expected to run forever, with 'Polysemy.Resume.Stop' being sent to this -- function, if at all.@@ -61,7 +61,7 @@ withProcess =   scoped @param --- |Create a scoped_ resource for 'Process'.+-- | Create a scoped_ resource for 'Process'. -- The process configuration may depend on the provided value of type @param@. -- This variant models processes that are expected to terminate, with 'Polysemy.Resume.Stop' being sent to individual -- actions within the scope.@@ -73,7 +73,7 @@ withProcessOneshot =   scoped @param --- |Create a scoped_ resource for 'Process'.+-- | Create a scoped_ resource for 'Process'. -- The process configuration is provided to the interpreter statically. -- This variant models daemon processes that are expected to run forever, with 'Polysemy.Resume.Stop' being sent to this -- function, if at all.@@ -84,7 +84,7 @@ withProcess_ =   scoped_ --- |Create a scoped_ resource for 'Process'.+-- | Create a scoped_ resource for 'Process'. -- The process configuration is provided to the interpreter statically. -- This variant models processes that are expected to terminate, with 'Polysemy.Resume.Stop' being sent to individual -- actions within the scope.@@ -95,7 +95,7 @@ withProcessOneshot_ =   scoped_ --- |Convert 'Output' and 'Input' to 'Process' for a daemon process.+-- | Convert 'Output' and 'Input' to 'Process' for a daemon process. runProcessIO ::   ∀ i o r .   Member (Process i o) r =>@@ -109,7 +109,7 @@     Output o ->       send @i @o o --- |Convert 'Output' and 'Input' to 'Process' for a oneshot process.+-- | Convert 'Output' and 'Input' to 'Process' for a oneshot process. runProcessOneshotIO ::   ∀ i o err r .   Member (Process i o !! err) r =>
lib/Polysemy/Process/Effect/ProcessInput.hs view
@@ -1,14 +1,14 @@ {-# options_haddock prune #-} --- |Description: ProcessInput effect, Internal.+-- | Description: ProcessInput effect, Internal. module Polysemy.Process.Effect.ProcessInput where --- |This effect is used by the effect 'Polysemy.Process.Process' to encode values for process input.+-- | This effect is used by the effect 'Polysemy.Process.Process' to encode values for process input. -- example using a parser. data ProcessInput a :: Effect where-  -- |Encode a value for enqueueing it to a process' stdin.+  -- | Encode a value for enqueueing it to a process' stdin.   Encode ::-    -- |The value to encode.+    -- | The value to encode.     a ->     ProcessInput a m ByteString
lib/Polysemy/Process/Effect/ProcessOutput.hs view
@@ -1,28 +1,28 @@ {-# options_haddock prune #-} --- |Description: ProcessOutput effect, Internal.+-- | Description: ProcessOutput effect, Internal. module Polysemy.Process.Effect.ProcessOutput where --- |Kind tag for selecting the 'ProcessOutput' handler for stdout/stderr.+-- | Kind tag for selecting the 'ProcessOutput' handler for stdout/stderr. data OutputPipe =-  -- |Tag for stdout.+  -- | Tag for stdout.   Stdout   |-  -- |Tag for stderr.+  -- | Tag for stderr.   Stderr   deriving stock (Eq, Show) --- |This effect is used by the effect 'Polysemy.Process.Process' to accumulate and decode chunks of 'ByteString's, for+-- | This effect is used by the effect 'Polysemy.Process.Process' to accumulate and decode chunks of 'ByteString's, for -- example using a parser. -- The interpreter may be stateful or stateless, since the constructor 'Chunk' is expected to be called with both the -- accumulated unprocessed output as well as the new chunk. data ProcessOutput (p :: OutputPipe) a :: Effect where-  -- |Add a chunk of output to the accumulator, returning any number of successfully parsed values and the leftover+  -- | Add a chunk of output to the accumulator, returning any number of successfully parsed values and the leftover   -- output.   Chunk ::-    -- |The accumulation of the previous leftovers.+    -- | The accumulation of the previous leftovers.     ByteString ->-    -- |The new chunk read from the process.+    -- | The new chunk read from the process.     ByteString ->     ProcessOutput p a m ([a], ByteString)
lib/Polysemy/Process/Effect/Pty.hs view
@@ -1,34 +1,34 @@ {-# options_haddock prune #-} --- |Description: Pty Effect, Internal+-- | Description: Pty Effect, Internal module Polysemy.Process.Effect.Pty where  import System.IO (Handle) --- |Horizontal size of a pseudo terminal in characters.+-- | Horizontal size of a pseudo terminal in characters. newtype Rows =   Rows { unRows :: Int }   deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord) --- |Vertical size of a pseudo terminal in characters.+-- | Vertical size of a pseudo terminal in characters. newtype Cols =   Cols { unCols :: Int }   deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord) --- |A pseudo terminal, to be scoped with 'withPty'.+-- | A pseudo terminal, to be scoped with 'withPty'. data Pty :: Effect where-  -- |The file descriptor that can be connected to stdio of a process.+  -- | The file descriptor that can be connected to stdio of a process.   Handle :: Pty m Handle-  -- |Set the size of the terminal.+  -- | Set the size of the terminal.   Resize :: Rows -> Cols -> Pty m ()-  -- |Get the size of the terminal.+  -- | Get the size of the terminal.   Size :: Pty m (Rows, Cols)  makeSem ''Pty --- |Bracket an action with the creation and destruction of a pseudo terminal.+-- | Bracket an action with the creation and destruction of a pseudo terminal. withPty ::   Member (Scoped_ Pty) r =>   InterpreterFor Pty r
lib/Polysemy/Process/Effect/SystemProcess.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: SystemProcess Effect, Internal+-- | Description: SystemProcess Effect, Internal module Polysemy.Process.Effect.SystemProcess where  import Polysemy.Resume (type (!!))@@ -10,25 +10,25 @@  import Polysemy.Process.Data.Pid (Pid) --- |Low-level interface for a process, operating on raw chunks of bytes.+-- | Low-level interface for a process, operating on raw chunks of bytes. -- Interface is modeled after "System.Process". data SystemProcess :: Effect where-  -- |Read a chunk from stdout.+  -- | Read a chunk from stdout.   ReadStdout :: SystemProcess m ByteString-  -- |Read a chunk from stderr.+  -- | Read a chunk from stderr.   ReadStderr :: SystemProcess m ByteString-  -- |Write a 'ByteString' to stdin.+  -- | Write a 'ByteString' to stdin.   WriteStdin :: ByteString -> SystemProcess m ()-  -- |Obtain the process ID.+  -- | Obtain the process ID.   Pid :: SystemProcess m Pid-  -- |Send a 'System.Posix.Signal' to the process.+  -- | Send a 'System.Posix.Signal' to the process.   Signal :: Signal -> SystemProcess m ()-  -- |Wait for the process to terminate, returning its exit code.+  -- | Wait for the process to terminate, returning its exit code.   Wait :: SystemProcess m ExitCode  makeSem ''SystemProcess --- |Create a scoped resource for 'SystemProcess'.+-- | Create a scoped resource for 'SystemProcess'. -- The process configuration may depend on the provided value of type @param@. withSystemProcess ::   ∀ param err r .@@ -38,7 +38,7 @@ withSystemProcess =   scoped @param --- |Create a scoped resource for 'SystemProcess'.+-- | Create a scoped resource for 'SystemProcess'. -- The process configuration is provided to the interpreter statically. withSystemProcess_ ::   ∀ err r .@@ -47,21 +47,21 @@ withSystemProcess_ =   scoped_ --- |Send signal INT(2) to the process.+-- | Send signal INT(2) to the process. interrupt ::   Member SystemProcess r =>   Sem r () interrupt =   signal Signal.sigINT --- |Send signal TERM(15) to the process.+-- | Send signal TERM(15) to the process. term ::   Member SystemProcess r =>   Sem r () term =   signal Signal.sigTERM --- |Send signal KILL(9) to the process.+-- | Send signal KILL(9) to the process. kill ::   Member SystemProcess r =>   Sem r ()
lib/Polysemy/Process/Executable.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Executable helpers, Internal+-- | Description: Executable helpers, Internal module Polysemy.Process.Executable where  import Path (Abs, File, Path, Rel, toFilePath)@@ -26,12 +26,12 @@     pathText =       toText (toFilePath path) --- |Find a file in @$PATH@, verifying that it is executable by this process.+-- | Find a file in @$PATH@, verifying that it is executable by this process. resolveExecutable ::   Member (Embed IO) r =>-  -- |Executable name, for @$PATH@ lookup and error messages+  -- | Executable name, for @$PATH@ lookup and error messages   Path Rel File ->-  -- |Explicit override to be checked for adequate permissions+  -- | Explicit override to be checked for adequate permissions   Maybe (Path Abs File) ->   Sem r (Either Text (Path Abs File)) resolveExecutable exe = \case
+ lib/Polysemy/Process/Interpreter/Interrupt.hs view
@@ -0,0 +1,279 @@+{-# options_haddock prune #-}+{-# language FieldSelectors #-}++-- | Description: Interrupt interpreters+module Polysemy.Process.Interpreter.Interrupt where++import qualified Control.Concurrent.Async as A+import Control.Concurrent.Async (AsyncCancelled)+import Control.Concurrent.STM (TVar, newTVarIO)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text.IO as Text+import qualified Polysemy.Conc.Effect.Critical as Critical+import Polysemy.Conc.Effect.Critical (Critical)+import Polysemy.Conc.Effect.Race (Race)+import qualified Polysemy.Conc.Effect.Sync as Sync+import Polysemy.Conc.Interpreter.Sync (interpretSync)+import Polysemy.Conc.Race (race_)+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Time (Seconds (Seconds))+import System.IO (stderr)+import System.Posix.Signals (+  Handler (Catch, CatchInfo, CatchInfoOnce, CatchOnce),+  SignalInfo,+  installHandler,+  keyboardSignal,+  )++import Polysemy.Process.Effect.Interrupt (Interrupt (..))++putErr ::+  Member (Embed IO) r =>+  Bool ->+  Text ->+  Sem r ()+putErr = \case+  True -> embed . Text.hPutStrLn stderr+  False -> const unit++data InterruptState =+  InterruptState {+    quit :: !(MVar ()),+    finished :: !(MVar ()),+    listeners :: !(Set Text),+    original :: !(SignalInfo -> IO ()),+    handlers :: !(Map Text (IO ()))+  }++modListeners :: (Set Text -> Set Text) -> InterruptState -> InterruptState+modListeners f s@InterruptState {listeners} =+  s {listeners = f listeners}++modHandlers :: (Map Text (IO ()) -> Map Text (IO ())) -> InterruptState -> InterruptState+modHandlers f s@InterruptState {handlers} =+  s {handlers = f handlers}++waitQuit ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Sem r ()+waitQuit = do+  mv <- atomicGets quit+  embed (readMVar mv)++checkListeners ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Sem r ()+checkListeners =+  whenM (atomicGets (Set.null . listeners)) do+    fin <- atomicGets finished+    void (embed (tryPutMVar fin ()))++onQuit ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Text ->+  Sem r a ->+  Sem r a+onQuit name ma = do+  atomicModify' (modListeners (Set.insert name))+  waitQuit+  a <- ma+  atomicModify' (modListeners (Set.delete name))+  checkListeners+  pure a++processHandler ::+  Member (Embed IO) r =>+  Bool ->+  Text ->+  IO () ->+  Sem r ()+processHandler verbose name thunk = do+  putErr verbose ("processing interrupt handler: " <> name)+  embed thunk++execInterrupt ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Bool ->+  Sem r (SignalInfo -> Sem r ())+execInterrupt verbose = do+  InterruptState quitSignal finishSignal _ orig _ <- atomicGet+  whenM (embed (tryPutMVar quitSignal ())) do+    traverse_ (uncurry (processHandler verbose)) . Map.toList =<< atomicGets handlers+    checkListeners+    embed (takeMVar finishSignal)+  embed . orig <$ putErr verbose "interrupt handlers finished"++registerHandler ::+  Member (AtomicState InterruptState) r =>+  Text ->+  IO () ->+  Sem r ()+registerHandler name handler =+  atomicModify' (modHandlers (Map.insert name handler))++awaitOrKill ::+  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>+  Bool ->+  Text ->+  A.Async (Maybe a) ->+  Sem r (Maybe a)+awaitOrKill verbose desc handle = do+  interpretSync @() do+    race_ (catchCritical (await handle)) kill+  where+    catchCritical =+      maybe waitKill (pure . Just) <=< Critical.catchAs @AsyncCancelled Nothing+    waitKill =+      Nothing <$ Sync.wait @() (Seconds 1)+    kill = do+      onQuit desc do+        putErr verbose ("killing " <> desc)+        cancel handle+        putErr verbose ("killed " <> desc)+        Sync.putBlock ()+        pure Nothing++interpretInterruptState ::+  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>+  Bool ->+  InterpreterFor Interrupt r+interpretInterruptState verbose =+  interpretH \case+    Register name handler ->+      liftT (registerHandler name handler)+    Unregister name ->+      liftT $ atomicModify' \ s@InterruptState {handlers} -> s {handlers = Map.delete name handlers}+    WaitQuit ->+      liftT waitQuit+    Quit ->+      liftT do+        putErr verbose "manual interrupt"+        void (execInterrupt verbose)+    Interrupted ->+      liftT . fmap isJust . embed . tryReadMVar =<< atomicGets quit+    KillOnQuit desc ma -> do+      maT <- runT ma+      ins <- getInspectorT+      handle <- raise (interpretInterruptState verbose (async maT))+      result <- liftT (awaitOrKill verbose desc handle)+      pure (join . fmap (inspect ins) <$> result)+{-# inline interpretInterruptState #-}++broadcastInterrupt ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Bool ->+  SignalInfo ->+  Sem r ()+broadcastInterrupt verbose sig = do+  putErr verbose "caught interrupt signal"+  orig <- execInterrupt verbose+  orig sig++-- The original handler is either the default handler that kills all threads or a handler installed by an environment+-- like ghcid.+-- In the latter case, not calling it results in ghcid misbehaving.+-- To distinguish the two cases, the constructor used by the default is 'Catch', while a custom handler should usually+-- use 'CatchOnce', since you don't want to catch repeated occurences of SIGINT, as it will surely cause problems.+originalHandler :: Handler -> (SignalInfo -> IO ())+originalHandler (CatchOnce thunk) =+  (const thunk)+originalHandler (CatchInfoOnce thunk) =+  thunk+originalHandler (Catch thunk) =+  (const thunk)+originalHandler (CatchInfo thunk) =+  thunk+originalHandler _ =+  const unit+{-# inline originalHandler #-}++installSignalHandler ::+  Bool ->+  TVar InterruptState ->+  ((SignalInfo -> IO ()) -> Handler) ->+  IO Handler+installSignalHandler verbose state consHandler =+  installHandler keyboardSignal (consHandler handler) Nothing+  where+    handler sig =+      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt verbose sig)++-- | Interpret 'Interrupt' by installing a signal handler.+--+-- Takes a constructor for 'Handler'.+interpretInterruptWith' ::+  Members [Critical, Race, Async, Embed IO] r =>+  Bool ->+  ((SignalInfo -> IO ()) -> Handler) ->+  InterpreterFor Interrupt r+interpretInterruptWith' verbose consHandler sem = do+  quitMVar <- embed newEmptyMVar+  finishMVar <- embed newEmptyMVar+  state <- embed (newTVarIO (InterruptState quitMVar finishMVar Set.empty (const unit) Map.empty))+  orig <- embed $ installSignalHandler verbose state consHandler+  runAtomicStateTVar state do+    atomicModify' \ s -> s {original = originalHandler orig}+    interpretInterruptState verbose $ raiseUnder sem++interpretInterruptWith ::+  Members [Critical, Race, Async, Embed IO] r =>+  ((SignalInfo -> IO ()) -> Handler) ->+  InterpreterFor Interrupt r+interpretInterruptWith = interpretInterruptWith' True++-- | Interpret 'Interrupt' by installing a signal handler.+--+-- Catches repeat invocations of SIGINT.+interpretInterrupt' ::+  Members [Critical, Race, Async, Embed IO] r =>+  Bool ->+  InterpreterFor Interrupt r+interpretInterrupt' verbose =+  interpretInterruptWith' verbose CatchInfo++-- | Interpret 'Interrupt' by installing a signal handler.+--+-- Catches repeat invocations of SIGINT.+interpretInterrupt ::+  Members [Critical, Race, Async, Embed IO] r =>+  InterpreterFor Interrupt r+interpretInterrupt =+  interpretInterrupt' True++-- | Interpret 'Interrupt' by installing a signal handler.+--+-- Catches only the first invocation of SIGINT.+interpretInterruptOnce' ::+  Members [Critical, Race, Async, Embed IO] r =>+  Bool ->+  InterpreterFor Interrupt r+interpretInterruptOnce' verbose =+  interpretInterruptWith' verbose CatchInfoOnce++-- | Interpret 'Interrupt' by installing a signal handler.+--+-- Catches only the first invocation of SIGINT.+interpretInterruptOnce ::+  Members [Critical, Race, Async, Embed IO] r =>+  InterpreterFor Interrupt r+interpretInterruptOnce =+  interpretInterruptOnce' True++-- | Eliminate 'Interrupt' without interpreting.+interpretInterruptNull ::+  InterpreterFor Interrupt r+interpretInterruptNull =+  interpretH \case+    Register _ _ ->+      pureT ()+    Unregister _ ->+      pureT ()+    WaitQuit ->+      pureT ()+    Quit ->+      pureT ()+    Interrupted ->+      pureT False+    KillOnQuit _ _ ->+      pureT Nothing
lib/Polysemy/Process/Interpreter/Process.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Process Interpreters, Internal+-- | Description: Process Interpreters, Internal module Polysemy.Process.Interpreter.Process where  import Control.Concurrent.STM.TBMQueue (TBMQueue)@@ -132,7 +132,7 @@ withQueues qSize action =   withSTMResources qSize \ qs -> interpretQueues qs action --- |Call a chunk reading action repeatedly, pass the bytes to 'ProcessOutput' and enqueue its results.+-- | Call a chunk reading action repeatedly, pass the bytes to 'ProcessOutput' and enqueue its results. -- As soon as an empty chunk is encountered, the queue is closed if the gating action returns 'False'. -- The conditional closing is for the purpose of keeping the queue alive until the last producer has written all -- received chunks – this is important when both stdout and stderr are written to the same queue.@@ -242,7 +242,7 @@     raiseUnder $     queues @err options sem --- |Interpret 'Process' with a system process resource whose file descriptors are connected to three 'TBMQueue's,+-- | Interpret 'Process' with a system process resource whose file descriptors are connected to three 'TBMQueue's, -- deferring decoding of stdout and stderr to the interpreters of two 'ProcessOutput' effects. -- This variant: -- - Models a daemon process that is not expected to terminate, causing 'Stop' to be sent to the scope callsite instead@@ -270,7 +270,7 @@       mapStop ProcessError.StartFailed do         pscope @SystemProcessScopeError options (raise . raiseUnder . proc) p (insertAt @4 sem) --- |Interpret 'Process' with a system process resource whose file descriptors are connected to three 'TBMQueue's,+-- | Interpret 'Process' with a system process resource whose file descriptors are connected to three 'TBMQueue's, -- deferring decoding of stdout and stderr to the interpreters of two 'ProcessOutput' effects. -- This variant: -- - Models a daemon process that is not expected to terminate, causing 'Stop' to be sent to the scope callsite instead@@ -293,7 +293,7 @@       mapStop ProcessError.StartFailed do         scope @SystemProcessScopeError options (insertAt @4 sem) --- |Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'.+-- | Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'. -- This variant: -- - Models a daemon process that is not expected to terminate, causing 'Stop' to be sent to the scope callsite instead --   of individual 'Process' actions.@@ -312,7 +312,7 @@   interpretProcess options (insertAt @0 . proc) .   raiseUnder --- |Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'.+-- | Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'. -- This variant: -- - Models a daemon process that is not expected to terminate, causing 'Stop' to be sent to the scope callsite instead --   of individual 'Process' actions.@@ -329,7 +329,7 @@   interpretProcess_ options .   raiseUnder --- |Reinterpret 'Input' and 'Output' as 'Process'.+-- | Reinterpret 'Input' and 'Output' as 'Process'. interpretInputOutputProcess ::   ∀ i o r .   Member (Process i o) r =>@@ -338,7 +338,7 @@   runOutputSem (Process.send @i @o) .   runInputSem (Process.recv @i @o) --- |Interpret 'Input ByteString' by polling a 'Handle' and stopping with 'ProcessError' when it fails.+-- | Interpret 'Input ByteString' by polling a 'Handle' and stopping with 'ProcessError' when it fails. interpretInputHandleBuffered ::   Member (Embed IO) r =>   Handle ->@@ -348,7 +348,7 @@     Input ->       stopNote (Unknown "handle closed") =<< tryMaybe (hGetSome handle 4096) --- |Interpret 'Input ByteString' by polling a 'Handle' and stopping with 'ProcessError' when it fails.+-- | Interpret 'Input ByteString' by polling a 'Handle' and stopping with 'ProcessError' when it fails. -- This variant deactivates buffering for the 'Handle'. interpretInputHandle ::   Member (Embed IO) r =>@@ -358,7 +358,7 @@   tryAny_ (hSetBuffering handle NoBuffering)   interpretInputHandleBuffered handle sem --- |Interpret 'Output ByteString' by writing to a 'Handle' and stopping with 'ProcessError' when it fails.+-- | Interpret 'Output ByteString' by writing to a 'Handle' and stopping with 'ProcessError' when it fails. interpretOutputHandleBuffered ::   Member (Embed IO) r =>   Handle ->@@ -368,7 +368,7 @@     Output o ->       stopNote (Unknown "handle closed") =<< tryMaybe (hPut handle o) --- |Interpret 'Output ByteString' by writing to a 'Handle' and stopping with 'ProcessError' when it fails.+-- | Interpret 'Output ByteString' by writing to a 'Handle' and stopping with 'ProcessError' when it fails. -- This variant deactivates buffering for the 'Handle'. interpretOutputHandle ::   Member (Embed IO) r =>@@ -378,7 +378,7 @@   tryAny_ (hSetBuffering handle NoBuffering)   interpretOutputHandleBuffered handle sem --- |Interpret 'Process' in terms of 'Input' and 'Output'.+-- | Interpret 'Process' in terms of 'Input' and 'Output'. -- Since the @i@ and @o@ parameters correspond to the abstraction of stdio fds of an external system process, @i@ is -- written by 'Output' and @o@ is read from 'Input'. -- This is useful to abstract the current process's stdio as an external process, with input and output swapped.@@ -395,7 +395,7 @@   interpretResumable (handleProcessWithQueues (stop . Unknown)) .   raiseUnder2 --- |Interpret 'Process' in terms of two 'Handle's.+-- | Interpret 'Process' in terms of two 'Handle's. -- This is useful to abstract the current process's stdio as an external process, with input and output swapped. -- The first 'Handle' argument corresponds to the @o@ parameter, the second one to @i@, despite the first one usually -- being the current process's stdin.@@ -414,7 +414,7 @@   interpretProcessIO @i @o @ProcessError @ProcessError options .   raiseUnder2 --- |Interpret 'Process' using the current process's stdin and stdout.+-- | Interpret 'Process' using the current process's stdin and stdout. -- This mirrors the usual abstraction of an external process, to whose stdin would be /written/, while the current one's -- is /read/. interpretProcessCurrent ::
lib/Polysemy/Process/Interpreter/ProcessIO.hs view
@@ -1,4 +1,4 @@--- |Interpreters for 'ProcessOutput' and 'ProcessInput', Internal+-- | Interpreters for 'ProcessOutput' and 'ProcessInput', Internal module Polysemy.Process.Interpreter.ProcessIO where  import Polysemy.Process.Effect.ProcessInput (ProcessInput)@@ -12,7 +12,7 @@   interpretProcessOutputTextLines,   ) --- |The effects used by 'Polysemy.Process.Process' to send and receive chunks of bytes to and from a process.+-- | The effects used by 'Polysemy.Process.Process' to send and receive chunks of bytes to and from a process. type ProcessIO i o =   [     ProcessInput i,@@ -20,7 +20,7 @@     ProcessOutput 'Stderr o   ] --- |Interpret 'ProcessIO' with plain 'ByteString's without chunking.+-- | Interpret 'ProcessIO' with plain 'ByteString's without chunking. -- Silently discards stderr. interpretProcessByteString ::   InterpretersFor (ProcessIO ByteString ByteString) r@@ -29,7 +29,7 @@   interpretProcessOutputId @'Stdout .   interpretProcessInputId --- |Interpret 'ProcessIO' with 'ByteString's chunked as lines.+-- | Interpret 'ProcessIO' with 'ByteString's chunked as lines. -- Silently discards stderr. interpretProcessByteStringLines ::   InterpretersFor (ProcessIO ByteString ByteString) r@@ -38,7 +38,7 @@   interpretProcessOutputLines @'Stdout .   interpretProcessInputId --- |Interpret 'ProcessIO' with plain 'Text's without chunking.+-- | Interpret 'ProcessIO' with plain 'Text's without chunking. -- Silently discards stderr. interpretProcessText ::   InterpretersFor (ProcessIO Text Text) r@@ -47,7 +47,7 @@   interpretProcessOutputText @'Stdout .   interpretProcessInputText --- |Interpret 'ProcessIO' with 'Text's chunked as lines.+-- | Interpret 'ProcessIO' with 'Text's chunked as lines. -- Silently discards stderr. interpretProcessTextLines ::   InterpretersFor (ProcessIO Text Text) r
lib/Polysemy/Process/Interpreter/ProcessInput.hs view
@@ -1,11 +1,11 @@ {-# options_haddock prune #-} --- |Description: ProcessInput Interpreters, Internal+-- | Description: ProcessInput Interpreters, Internal module Polysemy.Process.Interpreter.ProcessInput where  import Polysemy.Process.Effect.ProcessInput (ProcessInput (Encode)) --- |Interpret 'ProcessInput' by passing 'ByteString' through.+-- | Interpret 'ProcessInput' by passing 'ByteString' through. interpretProcessInputId :: InterpreterFor (ProcessInput ByteString) r interpretProcessInputId =   interpret \case@@ -13,7 +13,7 @@       pure value {-# inline interpretProcessInputId #-} --- |Interpret 'ProcessInput' by UTF-8-encoding 'Text'.+-- | Interpret 'ProcessInput' by UTF-8-encoding 'Text'. interpretProcessInputText :: InterpreterFor (ProcessInput Text) r interpretProcessInputText =   interpret \case
lib/Polysemy/Process/Interpreter/ProcessOneshot.hs view
@@ -1,4 +1,4 @@--- |Description: Process Interpreters, Internal+-- | Description: Process Interpreters, Internal module Polysemy.Process.Interpreter.ProcessOneshot where  import Polysemy.Conc.Effect.Race (Race)@@ -13,7 +13,7 @@ import Polysemy.Process.Interpreter.ProcessIO (ProcessIO) import Polysemy.Process.Interpreter.SystemProcess (SysProcConf, interpretSystemProcessNative) --- |Interpret 'Process' with a system process resource whose file descriptors are connected to three+-- | Interpret 'Process' with a system process resource whose file descriptors are connected to three -- 'Control.Concurrent.STM.TBMQueue.TBMQueue's, deferring decoding of stdout and stderr to the interpreters of two -- 'Polysemy.Process.ProcessOutput' effects. -- Unlike 'Polysemy.Process.interpretProcess', this variant sends errors inside the scope to the individual 'Process'@@ -34,7 +34,7 @@   (\ p -> pscope @SystemProcessScopeError options (raiseUnder . proc) p)   (handleProcessWithQueues terminated) --- |Variant of 'interpretProcessOneshot' that takes a static 'SysProcConf'.+-- | Variant of 'interpretProcessOneshot' that takes a static 'SysProcConf'. interpretProcessOneshot_ ::   ∀ proc i o r .   Members (ProcessIO i o) r =>@@ -46,7 +46,7 @@ interpretProcessOneshot_ options proc =   interpretProcessOneshot options (const (pure proc)) --- |Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'.+-- | Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'. -- This variant is for parameterized scopes, meaning that a value of arbitrary type may be passed to -- 'Polysemy.Process.withProcessOneshotParam' which is then passed to the supplied function to produce a 'SysProcConf' -- for the native process.@@ -62,7 +62,7 @@   interpretProcessOneshot options (insertAt @0 . proc) .   raiseUnder --- |Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'.+-- | Interpret 'Process' as a native 'Polysemy.Process.SystemProcess'. -- This variant takes a static 'SysProcConf'. interpretProcessOneshotNative_ ::   ∀ i o r .
lib/Polysemy/Process/Interpreter/ProcessOutput.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: ProcessOutput Interpreters, Internal+-- | Description: ProcessOutput Interpreters, Internal module Polysemy.Process.Interpreter.ProcessOutput where  import qualified Data.ByteString as ByteString@@ -9,7 +9,7 @@ import Polysemy.Process.Effect.ProcessOutput (ProcessOutput (Chunk)) import qualified Polysemy.Process.Effect.ProcessOutput as ProcessOutput --- |Interpret 'ProcessOutput' by discarding any output.+-- | Interpret 'ProcessOutput' by discarding any output. interpretProcessOutputIgnore ::   ∀ p a r .   InterpreterFor (ProcessOutput p a) r@@ -19,7 +19,7 @@       pure ([], "") {-# inline interpretProcessOutputIgnore #-} --- |Interpret 'ProcessOutput' by immediately emitting raw 'ByteString's without accumulation.+-- | Interpret 'ProcessOutput' by immediately emitting raw 'ByteString's without accumulation. interpretProcessOutputId ::   ∀ p r .   InterpreterFor (ProcessOutput p ByteString) r@@ -29,7 +29,7 @@       pure ([buffer <> new], "") {-# inline interpretProcessOutputId #-} --- |Transformer for 'ProcessOutput' that lifts results into 'Left', creating 'ProcessOutput p (Either a b)' from+-- | Transformer for 'ProcessOutput' that lifts results into 'Left', creating 'ProcessOutput p (Either a b)' from -- 'ProcessOutput p a'. interpretProcessOutputLeft ::   ∀ p a b r .@@ -40,7 +40,7 @@     Chunk buf new ->       first (fmap Left) <$> ProcessOutput.chunk @p buf new --- |Transformer for 'ProcessOutput' that lifts results into 'Right', creating 'ProcessOutput p (Either a b)' from+-- | Transformer for 'ProcessOutput' that lifts results into 'Right', creating 'ProcessOutput p (Either a b)' from -- 'ProcessOutput p b'. interpretProcessOutputRight ::   ∀ p a b r .@@ -62,7 +62,7 @@     folder a (z, Just r) =       (a : z, Just r) --- |Interpret 'ProcessOutput' by emitting individual 'ByteString' lines of output.+-- | Interpret 'ProcessOutput' by emitting individual 'ByteString' lines of output. interpretProcessOutputLines ::   ∀ p r .   InterpreterFor (ProcessOutput p ByteString) r@@ -72,7 +72,7 @@       pure (splitLines buffer new) {-# inline interpretProcessOutputLines #-} --- |Interpret 'ProcessOutput' by immediately emitting 'Text' without accumulation.+-- | Interpret 'ProcessOutput' by immediately emitting 'Text' without accumulation. interpretProcessOutputText ::   ∀ p r .   InterpreterFor (ProcessOutput p Text) r@@ -82,7 +82,7 @@       pure ([decodeUtf8 (buffer <> new)], "") {-# inline interpretProcessOutputText #-} --- |Interpret 'ProcessOutput' by emitting individual 'Text' lines of output.+-- | Interpret 'ProcessOutput' by emitting individual 'Text' lines of output. interpretProcessOutputTextLines ::   ∀ p r .   InterpreterFor (ProcessOutput p Text) r@@ -95,7 +95,7 @@ type Parser a =   ByteString -> ProcessOutputParseResult a --- |Internal helper for 'interpretProcessOutputIncremental' that repeatedly parses elements from a chunk until the+-- | Internal helper for 'interpretProcessOutputIncremental' that repeatedly parses elements from a chunk until the -- parser returns a failure or a partial result. parseMany ::   Parser a ->@@ -117,7 +117,7 @@           Done a rest ->             spin (cons . (Right a :)) Nothing rest --- |Whenever a chunk of output arrives, call the supplied incremental parser whose result must be converted to+-- | Whenever a chunk of output arrives, call the supplied incremental parser whose result must be converted to -- 'ProcessOutputParseResult'. -- If a partial parse result is produced, it is stored in the state and resumed when the next chunk is available. -- If parsing an @a@ succeeds, the parser recurses until it fails.
lib/Polysemy/Process/Interpreter/Pty.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Pty Interpreters, Internal+-- | Description: Pty Interpreters, Internal module Polysemy.Process.Interpreter.Pty where  import Polysemy.Resume (Stop, interpretScopedResumable, stopEitherWith, stopNote, type (!!))@@ -42,7 +42,7 @@ withPty =   bracket acquirePty releasePty --- |Interpret Pty as a 'System.Posix.Pty'.+-- | Interpret Pty as a 'System.Posix.Pty'. interpretPty ::   Members [Resource, Embed IO] r =>   InterpreterFor (Scoped_ Pty !! PtyError) r
lib/Polysemy/Process/Interpreter/SystemProcess.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: SystemProcess Interpreters, Internal+-- | Description: SystemProcess Interpreters, Internal module Polysemy.Process.Interpreter.SystemProcess where  import Data.ByteString (hGetSome, hPut)@@ -30,11 +30,11 @@ import qualified Polysemy.Process.Effect.SystemProcess as SystemProcess import Polysemy.Process.Effect.SystemProcess (SystemProcess) --- |Convenience alias for a vanilla 'ProcessConfig', which will usually be transformed by interpreters to use 'Handle's.+-- | Convenience alias for a vanilla 'ProcessConfig', which will usually be transformed by interpreters to use 'Handle's. type SysProcConf =   ProcessConfig () () () --- |Convenience alias for the 'Process' type used by native interpreters.+-- | Convenience alias for the 'Process' type used by native interpreters. type PipesProcess =   Process Handle Handle Handle @@ -109,7 +109,7 @@   b ->     pure b --- |Handle 'SystemProcess' with a concrete 'System.Process' with connected pipes.+-- | Handle 'SystemProcess' with a concrete 'System.Process' with connected pipes. handleSystemProcessWithProcess ::   ∀ r r0 a .   Members [Stop SystemProcessError, Embed IO] r =>@@ -131,7 +131,7 @@   SystemProcess.Wait ->     tryStop "wait failed" (waitExitCode process) --- |Interpret 'SystemProcess' with a concrete 'System.Process' with connected pipes.+-- | Interpret 'SystemProcess' with a concrete 'System.Process' with connected pipes. interpretSystemProcessWithProcess ::   ∀ r .   Member (Embed IO) r =>@@ -140,7 +140,7 @@ interpretSystemProcessWithProcess process =   interpretResumable (handleSystemProcessWithProcess process) --- |Interpret 'SystemProcess' as a single global 'System.Process' that's started immediately.+-- | Interpret 'SystemProcess' as a single global 'System.Process' that's started immediately. interpretSystemProcessNativeSingle ::   ∀ r .   Members [Stop SystemProcessScopeError, Resource, Embed IO] r =>@@ -162,7 +162,7 @@     stop (StartFailed err) {-# inline withProcConf #-} --- |Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess'+-- | Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess' -- is called and terminated when the wrapped action finishes. -- This variant is for parameterized scopes, allowing the consumer to supply a value of type @param@ to create the -- process config.@@ -174,7 +174,7 @@ interpretSystemProcessNative config =   interpretScopedR (\ p u -> raise (raise (config p)) >>= withProcConf u) handleSystemProcessWithProcess --- |Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess'+-- | Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess' -- is called and terminated when the wrapped action finishes. -- This variant takes a static 'SysProcConf'. interpretSystemProcessNative_ ::@@ -185,7 +185,7 @@ interpretSystemProcessNative_ config =   interpretScopedR (const (withProcess config)) handleSystemProcessWithProcess --- |Interpret 'SystemProcess' with a concrete 'System.Process' with no connection to stdio.+-- | Interpret 'SystemProcess' with a concrete 'System.Process' with no connection to stdio. interpretSystemProcessWithProcessOpaque ::   ∀ i o e r .   Member (Embed IO) r =>@@ -207,7 +207,7 @@     SystemProcess.Wait ->       tryStop "wait failed" (waitExitCode process) --- |Interpret 'SystemProcess' as a single global 'System.Process' that's started immediately.+-- | Interpret 'SystemProcess' as a single global 'System.Process' that's started immediately. interpretSystemProcessNativeOpaqueSingle ::   ∀ i o e r .   Members [Resource, Embed IO] r =>@@ -217,7 +217,7 @@   withProcessOpaque config \ process ->     interpretSystemProcessWithProcessOpaque process sem --- |Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess'+-- | Interpret 'SystemProcess' as a scoped 'System.Process' that's started wherever 'Polysemy.Process.withSystemProcess' -- is called and terminated when the wrapped action finishes. interpretSystemProcessNativeOpaque ::   ∀ i o e r .
lib/Polysemy/Process/ProcessOutput.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |The utility effect 'ProcessOutput' takes care of decoding process output, getting called by the+-- | The utility effect 'ProcessOutput' takes care of decoding process output, getting called by the -- 'Polysemy.Process.Process' interpreters whenever a chunk was read, while accumulating chunks until they were decoded -- successfully. module Polysemy.Process.ProcessOutput (
lib/Polysemy/Process/Pty.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |The effect 'Pty' abstracts pseudo terminals.+-- | The effect 'Pty' abstracts pseudo terminals. module Polysemy.Process.Pty (   module Polysemy.Process.Effect.Pty,   module Polysemy.Process.Interpreter.Pty,
lib/Polysemy/Process/SysProcConf.hs view
@@ -1,4 +1,4 @@--- |Constructors for 'SysProcConf', Internal+-- | Constructors for 'SysProcConf', Internal module Polysemy.Process.SysProcConf where  import Path (Abs, File, Path, Rel, toFilePath)@@ -7,19 +7,19 @@  import Polysemy.Process.Interpreter.SystemProcess (SysProcConf) --- |Create a 'SysProcConf' from an executable path and a list of arguments.+-- | Create a 'SysProcConf' from an executable path and a list of arguments. processConfig :: Path Abs File -> [Text] -> SysProcConf processConfig exe args =   proc (toFilePath exe) (toString <$> args) {-# inline processConfig #-} --- |Create a 'SysProcConf' from an shell command line.+-- | Create a 'SysProcConf' from an shell command line. shellConfig :: Text -> SysProcConf shellConfig cmd =   shell (toString cmd) {-# inline shellConfig #-} --- |Create a 'SysProcConf' by looking up an executable in the path, and using the supplied arguments.+-- | Create a 'SysProcConf' by looking up an executable in the path, and using the supplied arguments. which ::   Member (Embed IO) r =>   Path Rel File ->
lib/Polysemy/Process/SystemProcess.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |The effect 'SystemProcess' is a low-level abstraction of a native system process.+-- | The effect 'SystemProcess' is a low-level abstraction of a native system process. module Polysemy.Process.SystemProcess (   module Polysemy.Process.Effect.SystemProcess,   module Polysemy.Process.Interpreter.SystemProcess,@@ -30,7 +30,7 @@   ) import Polysemy.Process.SysProcConf --- |Obtain the current process's 'Pid'.+-- | Obtain the current process's 'Pid'. currentPid ::   Member (Embed IO) r =>   Sem r Pid
polysemy-process.cabal view
@@ -1,29 +1,29 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack  name:           polysemy-process-version:        0.12.1.0+version:        0.15.0.0 synopsis:       Polysemy effects for system processes description:    See https://hackage.haskell.org/package/polysemy-process/docs/Polysemy-Process.html-category:       Concurrency-homepage:       https://git.tryp.io/tek/polysemy-conc+category:       Process+homepage:       https://github.com/tek/polysemy-conc#readme bug-reports:    https://github.com/tek/polysemy-conc/issues author:         Torsten Schmits maintainer:     hackage@tryp.io-copyright:      2022 Torsten Schmits+copyright:      2025 Torsten Schmits license:        BSD-2-Clause-Patent license-file:   LICENSE build-type:     Simple extra-source-files:-    changelog.md     readme.md+    changelog.md  source-repository head   type: git-  location: https://git.tryp.io/tek/polysemy-conc+  location: https://github.com/tek/polysemy-conc  library   exposed-modules:@@ -36,12 +36,14 @@       Polysemy.Process.Data.PtyError       Polysemy.Process.Data.PtyResources       Polysemy.Process.Data.SystemProcessError+      Polysemy.Process.Effect.Interrupt       Polysemy.Process.Effect.Process       Polysemy.Process.Effect.ProcessInput       Polysemy.Process.Effect.ProcessOutput       Polysemy.Process.Effect.Pty       Polysemy.Process.Effect.SystemProcess       Polysemy.Process.Executable+      Polysemy.Process.Interpreter.Interrupt       Polysemy.Process.Interpreter.Process       Polysemy.Process.Interpreter.ProcessInput       Polysemy.Process.Interpreter.ProcessIO@@ -58,171 +60,126 @@   default-extensions:       AllowAmbiguousTypes       ApplicativeDo-      BangPatterns-      BinaryLiterals       BlockArguments-      ConstraintKinds       DataKinds       DefaultSignatures       DeriveAnyClass-      DeriveDataTypeable-      DeriveFoldable-      DeriveFunctor-      DeriveGeneric-      DeriveLift-      DeriveTraversable       DerivingStrategies       DerivingVia       DisambiguateRecordFields-      DoAndIfThenElse       DuplicateRecordFields-      EmptyCase-      EmptyDataDecls-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase       LiberalTypeSynonyms-      MultiParamTypeClasses+      MonadComprehensions       MultiWayIf-      NamedFieldPuns+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures-      PatternGuards       PatternSynonyms-      PolyKinds       QuantifiedConstraints       QuasiQuotes-      RankNTypes       RecordWildCards       RecursiveDo       RoleAnnotations-      ScopedTypeVariables-      StandaloneDeriving       TemplateHaskell-      TupleSections-      TypeApplications       TypeFamilies       TypeFamilyDependencies-      TypeOperators-      TypeSynonymInstances       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages+  ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      base >=4.12 && <5-    , incipit-core >=0.4.1-    , path ==0.9.*-    , path-io ==1.7.*-    , polysemy ==1.9.*-    , polysemy-conc ==0.12.*-    , polysemy-resume ==0.7.*-    , polysemy-time ==0.6.*-    , posix-pty >=0.2-    , process-    , stm-chans >=3 && <3.1-    , typed-process >=0.2.6 && <0.3-    , unix+      async >=2.2.4 && <2.3+    , base >=4.17.2.1 && <4.22+    , incipit-core >=0.4.1.0 && <0.8+    , path >=0.9.1 && <0.10+    , path-io >=1.6.3 && <1.9+    , polysemy >=1.9.0.0 && <1.10+    , polysemy-conc >=0.12.1.0 && <0.16+    , polysemy-resume >=0.7.0.0 && <0.10+    , polysemy-time >=0.6.0.0 && <0.8+    , posix-pty >=0.2.2 && <0.3+    , process >=1.6.18.0 && <1.7+    , stm-chans >=3.0.0 && <3.1+    , typed-process >=0.2.4.1 && <0.3+    , unix >=2.7.3 && <2.9   mixins:       base hiding (Prelude)     , incipit-core (IncipitCore as Prelude)     , incipit-core hiding (IncipitCore)-  default-language: Haskell2010+  default-language: GHC2021 -test-suite polysemy-process-unit+test-suite polysemy-process-test   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      Polysemy.Process.Test.InterruptTest       Polysemy.Process.Test.ProcessTest+      Polysemy.Process.Test.Run   hs-source-dirs:       test   default-extensions:       AllowAmbiguousTypes       ApplicativeDo-      BangPatterns-      BinaryLiterals       BlockArguments-      ConstraintKinds       DataKinds       DefaultSignatures       DeriveAnyClass-      DeriveDataTypeable-      DeriveFoldable-      DeriveFunctor-      DeriveGeneric-      DeriveLift-      DeriveTraversable       DerivingStrategies       DerivingVia       DisambiguateRecordFields-      DoAndIfThenElse       DuplicateRecordFields-      EmptyCase-      EmptyDataDecls-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase       LiberalTypeSynonyms-      MultiParamTypeClasses+      MonadComprehensions       MultiWayIf-      NamedFieldPuns+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures-      PatternGuards       PatternSynonyms-      PolyKinds       QuantifiedConstraints       QuasiQuotes-      RankNTypes       RecordWildCards       RecursiveDo       RoleAnnotations-      ScopedTypeVariables-      StandaloneDeriving       TemplateHaskell-      TupleSections-      TypeApplications       TypeFamilies       TypeFamilyDependencies-      TypeOperators-      TypeSynonymInstances       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      base >=4.12 && <5-    , incipit-core >=0.4.1-    , polysemy-    , polysemy-conc-    , polysemy-plugin-    , polysemy-process-    , polysemy-resume-    , polysemy-test >=0.6-    , polysemy-time-    , tasty-    , tasty-expected-failure-    , typed-process+      async >=2.2.4 && <2.3+    , base >=4.17.2.1 && <4.22+    , hedgehog >=1.4 && <1.8+    , incipit-core >=0.4.1.0 && <0.8+    , polysemy >=1.9.0.0 && <1.10+    , polysemy-conc >=0.12.1.0 && <0.16+    , polysemy-plugin >=0.4.4.0 && <0.5+    , polysemy-process <0.16+    , polysemy-resume >=0.7.0.0 && <0.10+    , polysemy-test >=0.6.0.0 && <0.12+    , polysemy-time >=0.6.0.0 && <0.8+    , tasty >=1.5.2 && <1.6+    , tasty-expected-failure >=0.11.1.2 && <0.13+    , tasty-hedgehog >=1.4.0.2 && <1.5+    , typed-process >=0.2.4.1 && <0.3+    , unix >=2.7.3 && <2.9   mixins:       base hiding (Prelude)     , incipit-core (IncipitCore as Prelude)     , incipit-core hiding (IncipitCore)-  default-language: Haskell2010+  default-language: GHC2021
readme.md view
@@ -1,6 +1,6 @@ # About -This library provides [Polysemy] effects for system processes and pseudo terminals.+This library provides [Polysemy] effects for system processes, signal handling and pseudo terminals.  Please visit [Hackage] for documentation.
test/Main.hs view
@@ -1,12 +1,17 @@ module Main where +import Polysemy.Process.Test.InterruptTest (test_interrupt) import Polysemy.Process.Test.ProcessTest (test_processAll)+import Polysemy.Process.Test.Run (unitTestTimes) import Test.Tasty (TestTree, defaultMain, testGroup)  tests :: TestTree tests =   testGroup "main" [-    test_processAll+    test_processAll,+    testGroup "interrupt" [+      unitTestTimes 100 "interrupt" test_interrupt+    ]   ]  main :: IO ()
+ test/Polysemy/Process/Test/InterruptTest.hs view
@@ -0,0 +1,31 @@+module Polysemy.Process.Test.InterruptTest where++import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVarIO)+import Polysemy.Conc.Interpreter.Critical (interpretCritical)+import Polysemy.Conc.Interpreter.Race (interpretRace)+import Polysemy.Test (UnitTest, assertEq, runTestAuto)+import System.Posix (Handler (CatchInfoOnce), SignalInfo, installHandler, keyboardSignal, raiseSignal)++import qualified Polysemy.Process.Effect.Interrupt as Interrupt+import Polysemy.Process.Interpreter.Interrupt (interpretInterrupt')++handler :: MVar () -> TVar Int -> SignalInfo -> IO ()+handler mv tv _ = do+  atomically (modifyTVar tv (5 +))+  putMVar mv ()++test_interrupt :: UnitTest+test_interrupt = do+  runTestAuto do+    tv <- embed (newTVarIO 0)+    mv <- embed newEmptyMVar+    embed (installHandler keyboardSignal (CatchInfoOnce (handler mv tv)) Nothing)+    asyncToIOFinal $ interpretCritical $ interpretRace $ interpretInterrupt' False do+      Interrupt.register "test 1" do+        atomically (modifyTVar tv (3 +))+      Interrupt.register "test 2" do+        atomically (modifyTVar tv (9 +))+      embed (raiseSignal keyboardSignal)+    embed (takeMVar mv)+    result <- embed (readTVarIO tv)+    assertEq @_ @IO 17 result
test/Polysemy/Process/Test/ProcessTest.hs view
@@ -31,6 +31,7 @@ import Polysemy.Process.Interpreter.ProcessOneshot (interpretProcessOneshotNative) import Polysemy.Process.Interpreter.ProcessOutput (parseMany) import Polysemy.Process.Interpreter.SystemProcess (SysProcConf, interpretSystemProcessNative_)+import Polysemy.Process.Test.Run (unitTestTimes)  config :: ProcessConfig () () () config =@@ -47,25 +48,25 @@ test_process :: UnitTest test_process =   runTestAuto $ interpretRace $ asyncToIOFinal $ interpretProcessByteString $ interpretProcessNative_ def config do-    response <- resumeHoistError @ProcessError @(Scoped _ _) show do+    response <- resumeHoistError @ProcessError @(Scoped _ _) (TestError . show) do       withProcess_ do         Process.send (encodeUtf8 message)-        Race.timeout_ (throw "timed out") (Seconds 5) Process.recv+        Race.timeout_ (throw (TestError "timed out")) (Seconds 5) Process.recv     message === decodeUtf8 response  test_processLines :: UnitTest test_processLines =   runTestAuto $ interpretRace $ asyncToIOFinal $ interpretProcessTextLines $ interpretProcessNative_ def config do-    response <- resumeHoistError @ProcessError @(Scoped _ _) show do+    response <- resumeHoistError @ProcessError @(Scoped _ _) (TestError . show) do       withProcess_ do         Process.send message-        Race.timeout_ (throw "timed out") (Seconds 5) (replicateM 4 Process.recv)+        Race.timeout_ (throw (TestError "timed out")) (Seconds 5) (replicateM 4 Process.recv)     messageLines === response  test_processKillNever :: UnitTest test_processKillNever =   runTestAuto $ interpretRace $ asyncToIOFinal $ interpretProcessTextLines $ interpretProcessNative_ def { kill = KillNever } config do-    result <- resumeHoistError @ProcessError @(Scoped _ _) show do+    result <- resumeHoistError @ProcessError @(Scoped _ _) (TestError . show) do       Conc.timeout unit (MilliSeconds 100) do         withProcess_ do           Process.send message@@ -110,7 +111,7 @@ test_processOneshot =   runTestAuto $ interpretRace $ asyncToIOFinal $ interpretOneshot conf do     num <- runStop @Int $ withProcessOneshot message do-      Race.timeout_ (throw "timed out") (Seconds 5) do+      Race.timeout_ (throw (TestError "timed out")) (Seconds 5) do         for_ @[] [1..5] \ i ->           resumeHoistAs i Process.recv         unit@@ -147,10 +148,10 @@ test_processAll :: TestTree test_processAll =   testGroup "process" [-    unitTest "read raw chunks" test_process,-    unitTest "read lines" test_processLines,+    unitTestTimes 100 "read raw chunks" test_process,+    unitTestTimes 100 "read lines" test_processLines,     ignoreTest (unitTest "don't kill the process at the end of the scope" test_processKillNever),-    unitTest "expect termination" test_processOneshot,-    unitTest "daemon exit code" test_exit,-    unitTest "system process start error" test_startFailed+    unitTestTimes 100 "expect termination" test_processOneshot,+    unitTestTimes 100 "daemon exit code" test_exit,+    unitTestTimes 100 "system process start error" test_startFailed   ]
+ test/Polysemy/Process/Test/Run.hs view
@@ -0,0 +1,14 @@+module Polysemy.Process.Test.Run where++import Hedgehog (TestLimit, property, test, withTests)+import Polysemy.Test (UnitTest)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++unitTestTimes ::+  TestLimit ->+  TestName ->+  UnitTest ->+  TestTree+unitTestTimes n desc =+  testProperty desc . withTests n . property . test