polysemy-process 0.14.0.0 → 0.14.1.0

raw patch · 6 files changed

+93/−40 lines, 6 filesdep +hedgehogdep +tasty-hedgehogdep ~path-iodep ~polysemy-concdep ~polysemy-testPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hedgehog, tasty-hedgehog

Dependency ranges changed: path-io, polysemy-conc, polysemy-test

API changes (from Hackage documentation)

Files

• lib/Polysemy/Process/Interpreter/Interrupt.hs +61/−26
• polysemy-process.cabal +8/−5
• test/Main.hs +2/−2
• test/Polysemy/Process/Test/InterruptTest.hs +2/−2
• test/Polysemy/Process/Test/ProcessTest.hs +6/−5
• test/Polysemy/Process/Test/Run.hs +14/−0

@@ -30,10 +30,12 @@  putErr ::   Member (Embed IO) r =>+  Bool ->   Text ->   Sem r ()-putErr =-  embed . Text.hPutStrLn stderr+putErr = \case+  True -> embed . Text.hPutStrLn stderr+  False -> const unit  data InterruptState =   InterruptState {@@ -82,23 +84,25 @@  processHandler ::   Member (Embed IO) r =>+  Bool ->   Text ->   IO () ->   Sem r ()-processHandler name thunk = do-  putErr ("processing interrupt handler: " <> name)+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 = do+execInterrupt verbose = do   InterruptState quitSignal finishSignal _ orig _ <- atomicGet   whenM (embed (tryPutMVar quitSignal ())) do-    traverse_ (uncurry processHandler) . Map.toList =<< atomicGets handlers+    traverse_ (uncurry (processHandler verbose)) . Map.toList =<< atomicGets handlers     checkListeners     embed (takeMVar finishSignal)-  embed . orig <$ putErr "interrupt handlers finished"+  embed . orig <$ putErr verbose "interrupt handlers finished"  registerHandler ::   Member (AtomicState InterruptState) r =>@@ -110,10 +114,11 @@  awaitOrKill ::   Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>+  Bool ->   Text ->   A.Async (Maybe a) ->   Sem r (Maybe a)-awaitOrKill desc handle = do+awaitOrKill verbose desc handle = do   interpretSync @() do     race_ (catchCritical (await handle)) kill   where@@ -123,16 +128,17 @@       Nothing <$ Sync.wait @() (Seconds 1)     kill = do       onQuit desc do-        putErr ("killing " <> desc)+        putErr verbose ("killing " <> desc)         cancel handle-        putErr ("killed " <> desc)+        putErr verbose ("killed " <> desc)         Sync.putBlock ()         pure Nothing  interpretInterruptState ::   Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>+  Bool ->   InterpreterFor Interrupt r-interpretInterruptState =+interpretInterruptState verbose =   interpretH \case     Register name handler ->       liftT (registerHandler name handler)@@ -142,25 +148,26 @@       liftT waitQuit     Quit ->       liftT do-        putErr "manual interrupt"-        void execInterrupt+        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 (async maT))-      result <- liftT (awaitOrKill desc handle)+      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 sig = do-  putErr "caught interrupt signal"-  orig <- execInterrupt+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@@ -182,48 +189,76 @@ {-# inline originalHandler #-}  installSignalHandler ::+  Bool ->   TVar InterruptState ->   ((SignalInfo -> IO ()) -> Handler) ->   IO Handler-installSignalHandler state consHandler =+installSignalHandler verbose state consHandler =   installHandler keyboardSignal (consHandler handler) Nothing   where     handler sig =-      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt sig)+      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt verbose sig)  -- | Interpret 'Interrupt' by installing a signal handler. -- -- Takes a constructor for 'Handler'.-interpretInterruptWith ::+interpretInterruptWith' ::   Members [Critical, Race, Async, Embed IO] r =>+  Bool ->   ((SignalInfo -> IO ()) -> Handler) ->   InterpreterFor Interrupt r-interpretInterruptWith consHandler sem = do+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 state consHandler+  orig <- embed $ installSignalHandler verbose state consHandler   runAtomicStateTVar state do     atomicModify' \ s -> s {original = originalHandler orig}-    interpretInterruptState $ raiseUnder sem+    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 =-  interpretInterruptWith CatchInfo+  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 =-  interpretInterruptWith CatchInfoOnce+  interpretInterruptOnce' True  -- | Eliminate 'Interrupt' without interpreting. interpretInterruptNull ::

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-process-version:        0.14.0.0+version:        0.14.1.0 synopsis:       Polysemy effects for system processes description:    See https://hackage.haskell.org/package/polysemy-process/docs/Polysemy-Process.html category:       Process@@ -99,9 +99,9 @@     , base >=4.17.2.1 && <4.20     , incipit-core >=0.4.1.0 && <0.7     , path >=0.9.1 && <0.10-    , path-io >=0.2.0 && <1.9+    , path-io >=1.6.3 && <1.9     , polysemy >=1.9.0.0 && <1.10-    , polysemy-conc >=0.14.0.0 && <0.15+    , polysemy-conc >=0.14.1.0 && <0.15     , polysemy-resume >=0.7.0.0 && <0.10     , polysemy-time >=0.5.1.0 && <0.8     , posix-pty >=0.2.2 && <0.3@@ -121,6 +121,7 @@   other-modules:       Polysemy.Process.Test.InterruptTest       Polysemy.Process.Test.ProcessTest+      Polysemy.Process.Test.Run   hs-source-dirs:       test   default-extensions:@@ -163,16 +164,18 @@   build-depends:       async >=2.2.5 && <2.3     , base >=4.17.2.1 && <4.20+    , hedgehog >=1.1.2     , incipit-core >=0.4.1.0 && <0.7     , polysemy >=1.9.0.0 && <1.10-    , polysemy-conc >=0.14.0.0 && <0.15+    , polysemy-conc >=0.14.1.0 && <0.15     , polysemy-plugin >=0.4.4.0 && <0.5     , polysemy-process     , polysemy-resume >=0.7.0.0 && <0.10-    , polysemy-test >=0.3.1.6 && <0.11+    , polysemy-test >=0.7.0.0 && <0.11     , polysemy-time >=0.5.1.0 && <0.8     , tasty >=1.4.2 && <1.5     , tasty-expected-failure >=0.11.1.2 && <0.13+    , tasty-hedgehog >=1.3.0.0     , typed-process >=0.2.4.1 && <0.3     , unix >=2.7.3 && <2.9   mixins:

@@ -2,7 +2,7 @@  import Polysemy.Process.Test.InterruptTest (test_interrupt) import Polysemy.Process.Test.ProcessTest (test_processAll)-import Polysemy.Test (unitTest)+import Polysemy.Process.Test.Run (unitTestTimes) import Test.Tasty (TestTree, defaultMain, testGroup)  tests :: TestTree@@ -10,7 +10,7 @@   testGroup "main" [     test_processAll,     testGroup "interrupt" [-      unitTest "interrupt" test_interrupt+      unitTestTimes 100 "interrupt" test_interrupt     ]   ] 

@@ -7,7 +7,7 @@ import System.Posix (Handler (CatchInfoOnce), SignalInfo, installHandler, keyboardSignal, raiseSignal)  import qualified Polysemy.Process.Effect.Interrupt as Interrupt-import Polysemy.Process.Interpreter.Interrupt (interpretInterrupt)+import Polysemy.Process.Interpreter.Interrupt (interpretInterrupt')  handler :: MVar () -> TVar Int -> SignalInfo -> IO () handler mv tv _ = do@@ -20,7 +20,7 @@     tv <- embed (newTVarIO 0)     mv <- embed newEmptyMVar     embed (installHandler keyboardSignal (CatchInfoOnce (handler mv tv)) Nothing)-    asyncToIOFinal $ interpretCritical $ interpretRace $ interpretInterrupt do+    asyncToIOFinal $ interpretCritical $ interpretRace $ interpretInterrupt' False do       Interrupt.register "test 1" do         atomically (modifyTVar tv (3 +))       Interrupt.register "test 2" do

@@ -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 =@@ -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   ]

@@ -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