diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.1 + +- Initial revision. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Dimitri Sabadie + +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 Dimitri Sabadie nor the names of other + 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 THE COPYRIGHT +OWNER OR CONTRIBUTORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/event.cabal b/event.cabal new file mode 100644 --- /dev/null +++ b/event.cabal @@ -0,0 +1,36 @@ +name: event +version: 0.1 +synopsis: Monoidal, monadic and first-class events +description: This package can be used to represent events as + first-class objects instead of deepening callbacks and + nesting callbacks. Useful to wrap over __C__ callback-based + libraries. +license: BSD3 +license-file: LICENSE +author: Dimitri Sabadie +maintainer: Dimitri Sabadie +copyright: Dimitri Sabadie +category: Concurrency +extra-source-files: CHANGELOG.md +bug-reports: https://github.com/phaazon/event/issues + +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/phaazon/event.git + +library + ghc-options: -W -Wall + + exposed-modules: Control.Concurrent.Event + + build-depends: base >= 4.8 && < 4.9 + , transformers >= 0.4 && < 0.5 + , containers >= 0.5 && < 0.6 + , semigroups >= 0.16 && < 0.17 + + hs-source-dirs: src + + default-language: Haskell2010 diff --git a/src/Control/Concurrent/Event.hs b/src/Control/Concurrent/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Event.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +-- +-- An @'Event' a@ is an object representing an event of type 'a'. You can +-- register actions through it – see the 'on' function – and detach them later +-- on. +-- +-- An 'Event' has many purposes. The one in mind when writing that package was +-- to interface over __C__ callback-based reactive system. Consider the +-- following __Haskell__ wrapper function, which is based on imperative style: +-- +-- @ +-- -- Create a new button and register an action to launch when the button’s +-- -- state changes. +-- createButton :: (ButtonState -> IO ()) -> IO Button +-- createButton callback = do +-- -- create the button +-- button <- ... +-- forkIO . forever $ do +-- -- launch a thread in which we can test whether the state has changed +-- when stateHasChanged $ callback newState +-- pure button +-- @ +-- +-- We can enhance that by representing the action of registering to the event +-- and detaching from it by immediately returning a value: +-- +-- @ +-- createButton :: IO (Button,Event ButtonState) +-- createButton = do +-- -- create the button +-- button <- ... +-- -- create an 'Event' +-- (ev,t) <- newEvent +-- forkIO . forever $ +-- -- check the new state +-- when stateHasChanged $ trigger t newState +-- pure (button,ev) +-- @ +-- +-- The 'Trigger' can also be returned to manually invoke the 'Event'. +---------------------------------------------------------------------------- + +module Control.Concurrent.Event ( + -- * Events + Event + , newEvent + -- * Triggering events + , Trigger + , trigger + ) where + +import Control.Monad ( ap ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Foldable ( traverse_ ) +import Data.IntMap as M +import Data.IORef +import Data.Semigroup ( Semigroup(..) ) + +-- |An @'Event' a@ is a value of type 'a' with no direct representation. It lives +-- /in the future/. It’s possible to register actions with 'on' to execute +-- when data becomes available, and to detach those actions with the +-- resulting 'Detach' object by calling 'detach' on it. +-- +-- 'Event's can be triggered with the 'trigger' function and the associated +-- type 'Trigger'. +newtype Event a = Event { on :: (a -> IO ()) -> IO Detach } + +instance Applicative Event where + pure x = Event $ \k -> k x >> pure mempty + (<*>) = ap + +instance Functor Event where + fmap f e = Event $ \k -> on e $ k . f + +instance Monad Event where + return = pure + x >>= f = Event $ \k -> do + dref <- newIORef mempty + dx <- on x $ \x' -> do + dfx <- on (f x') k + modifyIORef dref (<> dfx) + modifyIORef dref (<> dx) + pure . Detach $ readIORef dref >>= detach + +instance Monoid (Event a) where + mempty = Event . const $ pure mempty + mappend = (<>) + +instance Semigroup (Event a) where + a <> b = Event $ \k -> (<>) <$> on a k <*> on b k + +-- |'Detach' is used to detach an action from an 'Event'. +newtype Detach = Detach { detach :: IO () } + +instance Monoid Detach where + mempty = Detach $ pure () + mappend = (<>) + +instance Semigroup Detach where + a <> b = Detach $ detach a >> detach b + +-- |@'Trigger' a@ is used to 'trigger' an @'Event' a@. +newtype Trigger a = Trigger (a -> IO ()) + +-- |Use a 'Trigger'. +trigger :: (MonadIO m) => Trigger a -> a -> m () +trigger (Trigger f) = liftIO . f + +-- |Create a new @'Event' a@ along with a @'Trigger' a@. +newEvent :: (MonadIO m) => m (Event a,Trigger a) +newEvent = liftIO $ do + callbacksRef <- newIORef M.empty + hRef <- newIORef 0 + pure (fut callbacksRef hRef,register callbacksRef) + where + fut callbacksRef hRef = Event $ \cb -> do + h <- succ <$> readIORef hRef + modifyIORef callbacksRef $ insert h cb + writeIORef hRef (succ h) + pure . Detach . modifyIORef callbacksRef $ delete h + register ref = Trigger $ \a -> liftIO $ readIORef ref >>= traverse_ ($ a)