event (empty) → 0.1

raw patch · 5 files changed

+199/−0 lines, 5 filesdep +basedep +containersdep +semigroupssetup-changed

Dependencies added: base, containers, semigroups, transformers

Files

CHANGELOG.md +3/−0
LICENSE +30/−0
Setup.hs +2/−0
event.cabal +36/−0
src/Control/Concurrent/Event.hs +128/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+## 0.1++- Initial revision.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2015, Dimitri Sabadie <dimitri.sabadie@gmail.com>++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 <dimitri.sabadie@gmail.com> 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ event.cabal view

@@ -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 <dimitri.sabadie@gmail.com>+maintainer:          Dimitri Sabadie <dimitri.sabadie@gmail.com>+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

+ src/Control/Concurrent/Event.hs view

@@ -0,0 +1,128 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   : (C) 2015 Dimitri Sabadie+-- License     : BSD3+--+-- Maintainer  : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- 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)