diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,45 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog][changelog], and this project adheres +to the [Haskell Package Versioning Policy][pvp]. + +## [Unreleased] + +## [0.1.0.2] - 2021-02-20 + +### Added + +- Added examples (only compiled when `examples` flag is enabled) +- Added `CHANGELOG.md`, `LICENSE`, and `README.md` to `extra-source-files` + +### Changed + +- Applied suggestions from HLint + +### Removed + +- Removed `Drama.Demo` module + +## [0.1.0.1] - 2021-02-19 + +### Fixed + +- Fixed build failing on GHC 8.6.5 due to missing `MonadFail` type class + +### Changed + +- Relaxed upper bound on `transformers` library + +## [0.1.0.0] - 2021-02-19 + +Initial release + +[Unreleased]: https://github.com/evanrelf/drama/compare/v0.1.0.2...HEAD +[0.1.0.1]: https://github.com/evanrelf/drama/releases/tag/v0.1.0.2 +[0.1.0.1]: https://github.com/evanrelf/drama/releases/tag/v0.1.0.1 +[0.1.0.0]: https://github.com/evanrelf/drama/releases/tag/v0.1.0.0 + +[changelog]: https://keepachangelog.com/en/1.0.0/ +[pvp]: https://pvp.haskell.org/ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2021, Evan Relf +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF +THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# drama + +[![Hackage](https://img.shields.io/hackage/v/drama.svg?logo=haskell&label=drama)](https://hackage.haskell.org/package/drama) +[![CI](https://github.com/evanrelf/drama/actions/workflows/ci.yml/badge.svg)](https://github.com/evanrelf/drama/actions/workflows/ci.yml) + +💃 Simple actor library for Haskell diff --git a/drama.cabal b/drama.cabal --- a/drama.cabal +++ b/drama.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: drama -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Simple actor library for Haskell description: Simple actor library for Haskell category: Concurrency @@ -12,7 +12,13 @@ copyright: 2021 Evan Relf tested-with: GHC == 8.6.5, GHC == 8.10.3 +license-file: LICENSE +extra-source-files: + CHANGELOG.md + LICENSE + README.md + common common build-depends: base >= 4.12 && < 5.0 default-language: Haskell2010 @@ -29,8 +35,21 @@ -fshow-warning-groups +common stan + if impl(ghc >= 8.8) + ghc-options: + -fwrite-ide-info + -hiedir=.hie + + +flag examples + description: Build examples + default: False + manual: True + + library - import: common + import: common, stan hs-source-dirs: src build-depends: , ki ^>= 0.2.0.1 @@ -39,12 +58,15 @@ exposed-modules: , Drama , Drama.Internal - other-modules: - , Drama.Demo + if flag(examples) + hs-source-dirs: examples + exposed-modules: + , SharedResource + , Workers benchmark bench - import: common + import: common, stan type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Main.hs diff --git a/examples/SharedResource.hs b/examples/SharedResource.hs new file mode 100644 --- /dev/null +++ b/examples/SharedResource.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} + +module SharedResource (main) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO (..)) +import Drama +import Prelude hiding (log) + + +main :: IO () +main = run do + -- Spawn `logger` actor, which starts waiting for requests. + loggerAddress <- spawn logger + + -- Spawn two noisy actors, `fizzBuzz` and `navi`, which want to constantly + -- print to the console. Instead of running `putStrLn`, they will send + -- messages to `logger`. + _ <- spawn (fizzBuzz loggerAddress) + _ <- spawn (navi loggerAddress) + + -- Block `main` thread forever. + wait + + +-- | Actor which encapsulates access to the console (a shared resource). By +-- sending log messages to `logger`, instead of running `putStrLn` directly, we +-- can avoid interleaving logs from actors running in parallel. +logger :: Actor String () +logger = forever do + string <- receive + liftIO $ putStrLn string + + +-- | Silly example actor which wants to print to the console +fizzBuzz :: Address String -> Actor () () +fizzBuzz loggerAddress = do + let log = send loggerAddress + + loop (0 :: Int) \n -> do + if | n `mod` 15 == 0 -> log "FizzBuzz" + | n `mod` 3 == 0 -> log "Fizz" + | n `mod` 5 == 0 -> log "Buzz" + | otherwise -> log (show n) + + -- Delay included for nicer (slow) output + liftIO $ threadDelay 500_000 + + continue (n + 1) + + +-- | Silly example actor which wants to print to the console +navi :: Address String -> Actor () () +navi loggerAddress = do + let log = send loggerAddress + + forever do + log "Hey, listen!" + + -- Delay included for nicer (slow) output + liftIO $ threadDelay 1_000_000 diff --git a/examples/Workers.hs b/examples/Workers.hs new file mode 100644 --- /dev/null +++ b/examples/Workers.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BlockArguments #-} + +module Workers (main) where + +import Control.Monad (replicateM, when) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Function ((&)) +import Drama + + +main :: IO () +main = run do + -- Spawn `fib` actor, which starts waiting for requests. + fibAddress <- spawn fib + + -- Request fibonacci numbers from `fib`. `fib` will spawn three `fibWorker`s + -- to do all the work in the background, and then send `main` their results + -- once they finish. + myAddress <- here + [200, 400, 600] & mapM_ \n -> send fibAddress (myAddress, n) + + -- Receive results sent back from the `fibWorker`s, and print them to the + -- console. + replicateM 3 receive >>= mapM_ \(n, f) -> + liftIO $ putStrLn ("Fibonacci number " <> show n <> " is " <> show f) + + -- Tell `fib` to stop. + send fibAddress (myAddress, -1) + + -- Wait for `fib` to stop before exiting. + wait + + +-- | Actor which immediately spawns and delegates to "worker" actors. +fib :: Actor (Address (Int, Integer), Int) () +fib = do + (responseAddress, n) <- receive + when (n >= 0) do + _ <- spawn (fibWorker responseAddress n) + fib + + +-- | "Worker" actor responsible for doing the real, time-consuming work. +fibWorker :: Address (Int, Integer) -> Int -> Actor () () +fibWorker responseAddress n = send responseAddress (n, fibs !! n) + + +-- | Infinite list of fibonacci numbers. +fibs :: [Integer] +fibs = 0 : 1 : zipWith (+) fibs (tail fibs) diff --git a/src/Drama/Demo.hs b/src/Drama/Demo.hs deleted file mode 100644 --- a/src/Drama/Demo.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} - -module Drama.Demo where - -import Control.Concurrent (threadDelay) -import Control.Monad (forever) -import Control.Monad.IO.Class (MonadIO (..)) -import Drama -import Prelude hiding (log) - - -main2 :: IO () -main2 = run do - loggerAddress <- spawn logger - _ <- spawn (fizzBuzz loggerAddress) - wait - - -logger :: Actor String () -logger = forever do - string <- receive - liftIO $ putStrLn string - - -fizzBuzz :: Address String -> Actor () () -fizzBuzz loggerAddress = do - let log = send loggerAddress - - loop (1 :: Int) \n -> do - if | n `mod` 15 == 0 -> log "FizzBuzz" - | n `mod` 3 == 0 -> log "Fizz" - | n `mod` 5 == 0 -> log "Buzz" - | otherwise -> log (show n) - - liftIO $ threadDelay 500_000 - - continue (n + 1) - - -counter :: Actor msg Int -counter = loop 10 \count -> do - liftIO $ print count - if count > 0 - then continue (count - 1) - else exit count - - -echo :: (forall msg. String -> Actor msg ()) -> Actor () () -echo log = forever do - line <- liftIO getLine - if line == "ping" then - log "pong" - else - log line - - -add1 :: (forall msg. String -> Actor msg ()) -> Actor (Address Int, Int) () -add1 log = forever do - log "[add1] Waiting for request" - (returnAddress, number) <- receive - log "[add1] Received request" - log "[add1] Spawning worker" - spawn (add1Worker log number returnAddress) - - -add1Worker :: (forall msg. String -> Actor msg ()) -> Int -> Address Int -> Actor () () -add1Worker log number returnAddress = do - log "[add1Worker] Started" - send returnAddress (number + 1) - log "[add1Worker] Replied" - - -program :: Actor Int () -program = do - liftIO $ putStrLn "[main] START" - - liftIO $ putStrLn "[main] Spawning logger" - loggerAddress <- spawn logger - - let log = send loggerAddress - - liftIO $ putStrLn "[main] Spawning echo" - _ <- spawn (echo log) - - log "[main] Spawning add1" - add1Address <- spawn (add1 log) - - log "[main] Sending number to add1" - address <- here - send add1Address (address, 1) - two <- receive - log ("[main] Received response from add1: " <> show two) - - log "[main] FINISH" - wait - - -main :: IO () -main = run program diff --git a/src/Drama/Internal.hs b/src/Drama/Internal.hs --- a/src/Drama/Internal.hs +++ b/src/Drama/Internal.hs @@ -84,7 +84,7 @@ -- | @since 0.1.0.0 -newtype Scope = Scope (Ki.Scope) +newtype Scope = Scope Ki.Scope -- | Spawn a new actor. Returns the spawned actor's address. @@ -96,7 +96,7 @@ -- @since 0.1.0.0 spawn :: Actor childMsg () -> Actor msg (Address childMsg) spawn actor = do - (inChan, outChan) <- liftIO $ Unagi.newChan + (inChan, outChan) <- liftIO Unagi.newChan let address = Address inChan let mailbox = Mailbox outChan @@ -185,7 +185,7 @@ -- @since 0.1.0.0 run :: MonadIO m => Actor msg a -> m a run actor = do - (inChan, outChan) <- liftIO $ Unagi.newChan + (inChan, outChan) <- liftIO Unagi.newChan let address = Address inChan let mailbox = Mailbox outChan