├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── benchmarks └── bench.hs ├── cabal.project ├── oath.cabal ├── src └── Oath.hs └── tests └── test.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | ghc: [ '8.10.7', '9.0.1', '9.2.5', '9.4.4' ] 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: haskell/actions/setup@v1 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | cabal-version: '3.6' 18 | 19 | - name: cabal Cache 20 | uses: actions/cache@v1 21 | env: 22 | cache-name: cache-cabal 23 | with: 24 | path: ~/.cabal 25 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 26 | restore-keys: | 27 | ${{ runner.os }}-build-${{ env.cache-name }}- 28 | ${{ runner.os }}-build- 29 | ${{ runner.os }}- 30 | 31 | - name: Install dependencies 32 | run: | 33 | cabal update 34 | cabal build --only-dependencies --enable-tests --enable-benchmarks all 35 | - name: Build 36 | run: cabal build --enable-tests --enable-benchmarks all 37 | - name: Run tests 38 | run: cabal test --enable-tests --enable-benchmarks all 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .ghc.environment.* 4 | dist-newstyle/ 5 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for oath 2 | 3 | ## 0.1 4 | 5 | * Generalised the type of `hoistOath` 6 | * Added `tryOath` 7 | 8 | ## 0.0 -- YYYY-mm-dd 9 | 10 | * First version. Released on an unsuspecting world. 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Fumiaki Kinoshita (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Fumiaki Kinoshita nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Oath: composable concurrent computation done right 2 | ---- 3 | 4 | Oath is an Applicative structures that makes concurrent actions composable. 5 | 6 | ```haskell 7 | newtype Oath a = Oath { runOath :: forall r. (STM a -> IO r) -> IO r } 8 | ``` 9 | 10 | `Oath` is a continuation-passing IO action which takes a transaction to obtain the final result (`STM a`). 11 | The continuation-passing style makes it easier to release resources in time. 12 | The easiest way to construct `Oath` is `oath`. It runs the supplied IO action in a separate thread as long as the continuation is running. 13 | 14 | ```haskell 15 | oath :: IO a -> Oath a 16 | oath act = Oath $ \cont -> do 17 | v <- newEmptyTMVarIO 18 | tid <- forkFinally act (atomically . putTMVar v) 19 | let await = takeTMVar v >>= either throwSTM pure 20 | cont await `finally` killThread tid 21 | 22 | evalOath :: Oath a -> IO a 23 | evalOath m = runOath m atomically 24 | ``` 25 | 26 | `Oath` is an `Applicative`, so you can combine multiple `Oath`s using `<*>`. `Oath` combined this way kicks off computations without waiting for the results. The following code runs `foo :: IO a` and `bar :: IO b` concurrently, then applies `f` to these results. 27 | 28 | ```haskell 29 | main = evalOath $ f <$> oath foo <*> oath bar 30 | ``` 31 | 32 | It _does not_ provide a Monad instance because it is logically impossible to define one consistent with the Applicative instance. 33 | 34 | Usage 35 | ---- 36 | 37 | `Oath` abstracts a triple of sending a request, waiting for response, and cancelling a request. If you want to send requests in a deterministic order, you can construct `Oath` directly instead of calling `oath`. 38 | 39 | ```haskell 40 | Oath $ \cont -> bracket sendRequest cancelRequest (cont . waitForResponse) 41 | ``` 42 | 43 | Timeout behaviour can be easily added using the `Alternative` instance and `delay :: Int -> Oath ()`. `a <|> b` runs both computations until one of them returns a result, then cancels the other. 44 | 45 | ```haskell 46 | -- | An 'Oath' that finishes once the given number of microseconds elapses 47 | delay :: Int -> Oath () 48 | 49 | oath action <|> delay 100000 50 | ``` 51 | 52 | Comparison to other packages 53 | ---- 54 | 55 | [future](https://hackage.haskell.org/package/future-2.0.0/docs/Control-Concurrent-Future.html), [caf](https://hackage.haskell.org/package/caf-0.0.3/docs/Control-Concurrent-Futures.html) and [async](https://hackage.haskell.org/package/async-2.2.4/docs/Control-Concurrent-Async.html) seem solve the same problem. They define abstractions to asynchronous computations. `async` has an applicative `Concurrently` wrapper. 56 | 57 | [spawn](https://hackage.haskell.org/package/spawn-0.3/docs/Control-Concurrent-Spawn.html) does not define any datatype. Instead it provides an utility function for `IO` (`spawn :: IO a -> IO (IO a)`). It does not offer a way to cancel a computation. 58 | 59 | [promises](https://hackage.haskell.org/package/promises-0.3/docs/Data-Promise.html) provides a monadic interface for pure demand-driven computation. It has nothing to do with concurrency. 60 | 61 | [unsafe-promises](https://hackage.haskell.org/package/unsafe-promises-0.0.1.3/docs/Control-Concurrent-Promise-Unsafe.html) creates an IO action that waits for the result on-demand using `unsafeInterleaveIO`. 62 | 63 | [futures](https://hackage.haskell.org/package/futures-0.1/docs/Futures.html) provides a wrapper of `forkIO`. There is no way to terminate an action and it does not propagate exceptions. 64 | 65 | [promise](https://hackage.haskell.org/package/promise-0.1.0.0/docs/Control-Concurrent-Promise.html) has illegal Applicative and Monad instances; `(<*>)` is not associative and its `ap` is not consistent with `(<*>)`. 66 | 67 | Performance 68 | ---- 69 | 70 | ```haskell 71 | bench "oath 10" $ nfIO $ O.evalOath $ traverse (O.oath . pure) [0 :: Int ..9] 72 | bench "async 10" $ nfIO $ A.runConcurrently $ traverse (A.Concurrently . pure) [0 :: Int ..9] 73 | ``` 74 | 75 | `Oath`'s overhead of `(<*>)` is less than `Concurrently`. Unlike `Concurrently`, `<*>` itself does not fork threads. 76 | 77 | ``` 78 | All 79 | oath 10: OK (1.63s) 80 | 5.78 μs ± 265 ns 81 | async 10: OK (0.21s) 82 | 12.3 μs ± 767 ns 83 | oath 100: OK (0.22s) 84 | 52.6 μs ± 4.4 μs 85 | async 100: OK (0.23s) 86 | 109 μs ± 8.4 μs 87 | ``` 88 | -------------------------------------------------------------------------------- /benchmarks/bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import qualified Oath as O 3 | import qualified Control.Concurrent.Async as A 4 | import Test.Tasty.Bench 5 | import qualified Streamly.Prelude as S 6 | 7 | main :: IO () 8 | main = defaultMain 9 | [ bench "oath 10" $ nfIO $ O.evalOath $ traverse (O.oath . pure) [0 :: Int ..9] 10 | , bench "async 10" $ nfIO $ A.runConcurrently $ traverse (A.Concurrently . pure) [0 :: Int ..9] 11 | , bench "streamly 10" $ nfIO $ S.drain $ S.fromZipAsync $ traverse (S.fromEffect . pure) [0 :: Int ..9] 12 | , bench "oath 100" $ nfIO $ O.evalOath $ traverse (O.oath . pure) [0 :: Int ..99] 13 | , bench "async 100" $ nfIO $ A.runConcurrently $ traverse (A.Concurrently . pure) [0 :: Int ..99] 14 | , bench "streamly 100" $ nfIO $ S.toList $ S.fromZipAsync $ traverse (S.fromEffect . pure) [0 :: Int ..99] 15 | ] 16 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | allow-newer: 3 | promise:base, 4 | promise:async -------------------------------------------------------------------------------- /oath.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: oath 3 | version: 0.1.1 4 | 5 | -- A short (one-line) description of the package. 6 | synopsis: Composable concurrent computation done right 7 | 8 | -- A longer description of the package. 9 | description: See README.md for details 10 | 11 | -- A URL where users can report bugs. 12 | bug-reports: https://github.com/fumieval/oath 13 | 14 | -- The license under which the package is released. 15 | license: BSD-3-Clause 16 | author: Fumiaki Kinoshita 17 | maintainer: fumiexcel@gmail.com 18 | 19 | -- A copyright notice. 20 | copyright: Copyright (c) 2022 Fumiaki Kinoshita 21 | category: Concurrency 22 | extra-source-files: CHANGELOG.md, README.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/fumieval/oath.git 27 | 28 | library 29 | exposed-modules: Oath 30 | -- Modules included in this executable, other than Main. 31 | -- other-modules: 32 | 33 | -- LANGUAGE extensions used by modules in this package. 34 | -- other-extensions: 35 | build-depends: base >=4.14.1.0 && <4.18, stm, stm-delay 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | ghc-options: -Wall -Wcompat 39 | 40 | test-suite test 41 | build-depends: base >=4.14.1.0 42 | , futures 43 | , unsafe-promises 44 | , promise 45 | , oath 46 | , async 47 | , streamly 48 | type: exitcode-stdio-1.0 49 | hs-source-dirs: tests 50 | default-language: Haskell2010 51 | main-is: test.hs 52 | ghc-options: -Wall -Wcompat 53 | 54 | benchmark bench 55 | type: exitcode-stdio-1.0 56 | main-is: bench.hs 57 | hs-source-dirs: benchmarks 58 | build-depends: base, tasty-bench, oath, async, streamly 59 | ghc-options: -Wall -threaded -O2 60 | default-language: Haskell2010 61 | -------------------------------------------------------------------------------- /src/Oath.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | module Oath 5 | ( Oath(..) 6 | , hoistOath 7 | , evalOath 8 | , tryOath 9 | , oath 10 | , delay 11 | , timeout) where 12 | 13 | import Control.Applicative 14 | import Control.Concurrent 15 | import Control.Concurrent.STM 16 | import Control.Concurrent.STM.Delay 17 | import Control.Exception 18 | import Data.Monoid 19 | 20 | -- 'Oath' is an 'Applicative' structure that collects results of one or more computations. 21 | newtype Oath a = Oath { runOath :: forall r. (STM a -> IO r) -> IO r } 22 | deriving Functor 23 | deriving (Semigroup, Monoid) via Ap Oath a 24 | 25 | -- | Apply a function to the inner computation that waits for the result. 26 | hoistOath :: (STM a -> STM b) -> Oath a -> Oath b 27 | hoistOath t (Oath m) = Oath $ \cont -> m $ cont . t 28 | 29 | -- | Run an 'Oath' and wait for the result. 30 | evalOath :: Oath a -> IO a 31 | evalOath m = runOath m atomically 32 | 33 | -- | Catch an exception thrown in the inner computation. 34 | tryOath :: Exception e => Oath a -> Oath (Either e a) 35 | tryOath = hoistOath $ \t -> fmap Right t `catchSTM` (pure . Left) 36 | 37 | -- | ('<*>') initiates both computations, then combines the results once they are done 38 | instance Applicative Oath where 39 | pure a = Oath $ \cont -> cont (pure a) 40 | Oath m <*> Oath n = Oath $ \cont -> m $ \f -> n $ \x -> cont (f <*> x) 41 | 42 | -- | ('<|>') waits for the first result, then cancel the loser 43 | instance Alternative Oath where 44 | empty = Oath $ \cont -> cont empty 45 | Oath m <|> Oath n = Oath $ \cont -> m $ \a -> n $ \b -> cont (a <|> b) 46 | 47 | -- | Lift an IO action into an 'Oath', forking a thread. 48 | -- When the continuation terminates, it kills the thread. 49 | -- Exception thrown in the thread will be propagated to the result. 50 | oath :: IO a -> Oath a 51 | oath act = Oath $ \cont -> do 52 | v <- newEmptyTMVarIO 53 | tid <- forkFinally act (atomically . putTMVar v) 54 | let await = readTMVar v >>= either throwSTM pure 55 | cont await `finally` killThread tid 56 | 57 | -- | An 'Oath' that finishes once the given number of microseconds elapses 58 | delay :: Int -> Oath () 59 | delay dur = Oath $ \cont -> bracket (newDelay dur) cancelDelay (cont . waitDelay) 60 | 61 | -- | Returns nothing if the 'Oath' does not finish within the given number of microseconds. 62 | timeout :: Int -> Oath a -> Oath (Maybe a) 63 | timeout dur m = Just <$> m <|> Nothing <$ delay dur -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | import qualified Oath 2 | import qualified Futures 3 | import qualified Control.Concurrent.Promise.Unsafe as UP 4 | import qualified Control.Concurrent.Promise as Promise 5 | import qualified Control.Concurrent.Async as Async 6 | import Control.Applicative 7 | import Control.Concurrent 8 | import Control.Exception 9 | import Data.Functor.Compose 10 | import qualified Streamly.Prelude as S 11 | 12 | action :: Int -> String -> Double -> IO () 13 | action order name dur = do 14 | -- delay a bit so that "Begin" gets printed in a consistent order 15 | threadDelay $ 1000 * 10 * order 16 | putStrLn $ " Begin " <> name 17 | threadDelay (floor $ 1000000 * dur) 18 | putStrLn $ " End " <> name 19 | `onException` putStrLn (" Killed " <> name) 20 | 21 | tester :: Applicative m => (m () -> IO ()) -> (IO () -> m ()) -> IO () 22 | tester run lift = do 23 | putStrLn " Left:" 24 | run $ (lift (action 0 "foo" 0.1) *> lift (action 1 "bar" 0.3)) *> lift (action 2 "baz" 0.2) 25 | putStrLn " Right:" 26 | run $ lift (action 0 "foo" 0.1) *> (lift (action 1 "bar" 0.3) *> lift (action 2 "baz" 0.2)) 27 | 28 | putStrLn " Left Error:" 29 | try (run $ lift (fail "Fail") *> lift (action 0 "success" 0.1)) >>= print' 30 | putStrLn " Right Error:" 31 | try (run $ lift (action 0 "success" 0.1) *> lift (fail "Fail")) >>= print' 32 | where 33 | print' :: Either SomeException () -> IO () 34 | print' = putStrLn . (" "++) . show 35 | 36 | main :: IO () 37 | main = do 38 | putStrLn "oath timeout:" 39 | Oath.evalOath $ Oath.oath (action 0 "delay" 1.0) <|> Oath.delay 200000 40 | threadDelay 10000 41 | 42 | putStrLn "oath: " 43 | tester Oath.evalOath Oath.oath 44 | putStrLn "async: " 45 | tester Async.runConcurrently Async.Concurrently 46 | putStrLn "futures:" 47 | tester ((>>=Futures.block) . getCompose) (Compose . Futures.fork) 48 | 49 | putStrLn "streamly:" 50 | tester (S.drain . S.fromZipAsync . S.fromAhead) S.fromEffect 51 | 52 | putStrLn "promise:" 53 | tester Promise.runPromise Promise.liftIO 54 | 55 | -- random 56 | putStrLn "unsafe-promises:" 57 | try (tester id UP.promise) >>= (print :: Either SomeException () -> IO ()) 58 | 59 | --------------------------------------------------------------------------------