diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,20 @@ ## [Unreleased] +## [0.2.0.0] - 2021-02-20 + +### Added + +- Added more efficient `spawn_` and `run_` functions for spawning actors that +don't receive messages +- Re-exported common functions and types, such as `MonadIO` and `forever`, via +`Drama.Reexports` module + +### Changed + +- Added `Message` constraint to functions dealing with an actor's `Address` and +`Mailbox` (`send`, `receive`, `spawn`, etc.) + ## [0.1.0.3] - 2021-02-20 ### Added @@ -46,7 +60,8 @@ Initial release -[Unreleased]: https://github.com/evanrelf/drama/compare/v0.1.0.3...HEAD +[Unreleased]: https://github.com/evanrelf/drama/compare/v0.2.0.0...HEAD +[0.2.0.0]: https://github.com/evanrelf/drama/releases/tag/v0.2.0.0 [0.1.0.3]: https://github.com/evanrelf/drama/releases/tag/v0.1.0.3 [0.1.0.2]: 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,4 +3,4 @@ [![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 +:woman_dancing: 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.3 +version: 0.2.0.0 synopsis: Simple actor library for Haskell description: Simple actor library for Haskell category: Concurrency @@ -60,6 +60,7 @@ exposed-modules: , Drama , Drama.Internal + , Drama.Reexports benchmark bench diff --git a/examples/shared-resource.hs b/examples/shared-resource.hs --- a/examples/shared-resource.hs +++ b/examples/shared-resource.hs @@ -5,22 +5,20 @@ module Main (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 +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) + spawn_ (fizzBuzz loggerAddress) + spawn_ (navi loggerAddress) -- Block `main` thread forever. wait @@ -36,7 +34,7 @@ -- | Silly example actor which wants to print to the console -fizzBuzz :: Address String -> Actor () () +fizzBuzz :: Address String -> Actor Void () fizzBuzz loggerAddress = do let log = send loggerAddress @@ -53,7 +51,7 @@ -- | Silly example actor which wants to print to the console -navi :: Address String -> Actor () () +navi :: Address String -> Actor Void () navi loggerAddress = do let log = send loggerAddress diff --git a/examples/workers.hs b/examples/workers.hs --- a/examples/workers.hs +++ b/examples/workers.hs @@ -3,7 +3,6 @@ module Main (main) where import Control.Monad (replicateM, when) -import Control.Monad.IO.Class (MonadIO (..)) import Data.Function ((&)) import Drama @@ -36,12 +35,12 @@ fib = do (responseAddress, n) <- receive when (n >= 0) do - _ <- spawn (fibWorker responseAddress n) + spawn_ (fibWorker responseAddress n) fib -- | "Worker" actor responsible for doing the real, time-consuming work. -fibWorker :: Address (Int, Integer) -> Int -> Actor () () +fibWorker :: Address (Int, Integer) -> Int -> Actor Void () fibWorker responseAddress n = send responseAddress (n, fibs !! n) diff --git a/src/Drama.hs b/src/Drama.hs --- a/src/Drama.hs +++ b/src/Drama.hs @@ -7,72 +7,13 @@ -- -- Simple actor library for Haskell -- --- ==== __Example__ --- --- Fizz buzz, using three actors: @main@, @logger@, and @fizzBuzz@: --- --- > {-# LANGUAGE BlockArguments #-} --- > {-# LANGUAGE MultiWayIf #-} --- > {-# LANGUAGE NumericUnderscores #-} --- > --- > module Main (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 --- > 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 (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) --- > --- > liftIO $ threadDelay 500_000 --- > --- > continue (n + 1) --- --- Output: --- --- > λ> main --- > 1 --- > 2 --- > Fizz --- > 4 --- > Buzz --- > Fizz --- > 7 --- > 8 --- > Fizz --- > Buzz --- > 11 --- > Fizz --- > 13 --- > 14 --- > FizzBuzz --- > ... module Drama ( Actor -- * Spawning actors , spawn + , spawn_ , wait -- * Messages @@ -95,7 +36,12 @@ -- * Running your program , run + , run_ + + -- * Re-exports + , module Drama.Reexports ) where import Drama.Internal +import Drama.Reexports diff --git a/src/Drama/Internal.hs b/src/Drama/Internal.hs --- a/src/Drama/Internal.hs +++ b/src/Drama/Internal.hs @@ -1,10 +1,17 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- For `Message msg` +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + {-# OPTIONS_HADDOCK not-home #-} -- | @@ -21,6 +28,9 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Reader (ReaderT (..), asks) +import Data.Kind (Constraint) +import Data.Void (Void) +import GHC.TypeLits (ErrorMessage (..), TypeError) import qualified Control.Concurrent.Chan.Unagi as Unagi import qualified Ki @@ -34,6 +44,19 @@ #endif +-- | Forbid use of functions which use the underlying `Unagi.Chan` when an +-- actor's message type is `()` or `Void`. +-- +-- Forces users to use the more efficient `spawn_` and `run_` functions, and +-- prevents runtime exceptions. +-- +-- @since 0.2.0.0 +type family Message msg :: Constraint where + Message Void = TypeError ('Text "Actors with 'msg ~ Void' cannot receive messages") + Message () = TypeError ('Text "Use 'msg ~ Void' instead of 'msg ~ ()' for actors which do not receive messages") + Message msg = () + + -- | The `Actor` monad, where you can `spawn` other actors, and `send` and -- `receive` messages. -- @@ -94,7 +117,7 @@ -- > printerAddress <- spawn printer -- -- @since 0.1.0.0 -spawn :: Actor childMsg () -> Actor msg (Address childMsg) +spawn :: Message childMsg => Actor childMsg () -> Actor msg (Address childMsg) spawn actor = do (inChan, outChan) <- liftIO Unagi.newChan let address = Address inChan @@ -109,6 +132,22 @@ pure address +-- | More efficient version of `spawn`, for actors which receive no messages +-- (`msg ~ Void`). See docs for `spawn` for more information. +-- +-- @since 0.2.0.0 +spawn_ :: Actor Void () -> Actor msg () +spawn_ actor = do + let address = Address (error "unreachable") + let mailbox = Mailbox (error "unreachable") + + Scope kiScope <- Actor $ asks scope + liftIO $ Ki.fork_ kiScope $ Ki.scoped \childKiScope -> + let childScope = Scope childKiScope + childEnv = ActorEnv{address, mailbox, scope = childScope} + in runActor childEnv actor + + -- | Wait for all actors spawned by the current actor to terminate. -- -- Example: @@ -128,7 +167,7 @@ -- other actors, or for sending yourself a message. -- -- @since 0.1.0.0 -here :: Actor msg (Address msg) +here :: Message msg => Actor msg (Address msg) here = Actor $ asks address @@ -139,7 +178,11 @@ -- > send printerAddress "Hello, world!" -- -- @since 0.1.0.0 -send :: Address recipientMsg -> recipientMsg -> Actor msg () +send + :: Message recipientMsg + => Address recipientMsg + -> recipientMsg + -> Actor msg () send (Address inChan) msg = liftIO $ Unagi.writeChan inChan msg @@ -154,7 +197,7 @@ -- > liftIO $ putStrLn string -- -- @since 0.1.0.0 -receive :: Actor msg msg +receive :: Message msg => Actor msg msg receive = do Mailbox outChan <- Actor $ asks mailbox liftIO $ Unagi.readChan outChan @@ -172,7 +215,7 @@ -- > Nothing -> ... -- -- @since 0.1.0.0 -tryReceive :: Actor msg (Maybe msg) +tryReceive :: Message msg => Actor msg (Maybe msg) tryReceive = do Mailbox outChan <- Actor $ asks mailbox (element, _) <- liftIO $ Unagi.tryReadChan outChan @@ -183,11 +226,25 @@ -- program. -- -- @since 0.1.0.0 -run :: MonadIO m => Actor msg a -> m a +run :: (Message msg, MonadIO m) => Actor msg a -> m a run actor = do (inChan, outChan) <- liftIO Unagi.newChan let address = Address inChan let mailbox = Mailbox outChan + + liftIO $ Ki.scoped \kiScope -> do + let scope = Scope kiScope + runActor ActorEnv{address, mailbox, scope} actor + + +-- | More efficient version of `run`, for actors which receive no messages +-- (`msg ~ Void`). See docs for `run` for more information. +-- +-- @since 0.2.0.0 +run_ :: MonadIO m => Actor Void a -> m a +run_ actor = do + let address = Address (error "unreachable") + let mailbox = Mailbox (error "unreachable") liftIO $ Ki.scoped \kiScope -> do let scope = Scope kiScope diff --git a/src/Drama/Reexports.hs b/src/Drama/Reexports.hs new file mode 100644 --- /dev/null +++ b/src/Drama/Reexports.hs @@ -0,0 +1,5 @@ +module Drama.Reexports (module X) where + +import Control.Monad as X (forever) +import Control.Monad.IO.Class as X (MonadIO (..)) +import Data.Void as X (Void)