packages feed

eve 0.1.1 → 0.1.2

raw patch · 11 files changed

+207/−114 lines, 11 files

Files

eve.cabal view
@@ -1,5 +1,5 @@ name:                eve-version:             0.1.1+version:             0.1.2 synopsis: An extensible event framework description: An extensible event-driven application framework in haskell for building embarassingly modular software. homepage:            https://github.com/ChrisPenner/eve#readme
src/Eve.hs view
@@ -1,34 +1,36 @@ module Eve-  ( eve-  , eveT+  (+  -- * Running your App+  eve +  -- * Working with Actions   , App   , Action   , AppT   , ActionT-  , liftAction-  , AppState+  , liftApp+  , runAction+  , exit -  -- * Events+  -- * Dispatching Events   , dispatchEvent   , dispatchEvent_   , dispatchEventAsync   , dispatchActionAsync +  -- * Event Listeners   , addListener   , addListener_   , removeListener+  , Listener+  , ListenerId -  -- * Working with Async Events/Actions+  -- * Asynchronous Helpers   , asyncActionProvider   , asyncEventProvider   , Dispatcher -  , Listener-  , ListenerId-   -- * Built-in Event Listeners-  , onInit   , afterInit   , beforeEvent   , beforeEvent_@@ -79,9 +81,7 @@   , States   , HasEvents   , stateLens--  , runAction-  , exit+  , AppState   ) where  import Eve.Internal.Run
src/Eve/Internal/Actions.hs view
@@ -6,101 +6,76 @@ {-# language TypeFamilies #-} {-# language UndecidableInstances #-} {-# language ScopedTypeVariables #-}-{-# language TemplateHaskell #-} module Eve.Internal.Actions-  ( ActionF(..)+  ( AppF(..)   , ActionT(..)   , AppT+   , runApp   , evalApp   , execApp -  , liftAction+  , liftApp   , runAction--  , exit-  , isExiting-  , asyncQueue-  , Exiting(..)   ) where -import Eve.Internal.States- import Control.Monad.State import Control.Monad.Trans.Free import Control.Lens-import Data.Default-import Data.Typeable -import Pipes.Concurrent-+-- | An 'App' has the same base and zoomed values. type AppT s m a = ActionT s s m a -newtype ActionF base m next =-  LiftAction (StateT base m next)+-- | A Free Functor for storing lifted App actions.+newtype AppF base m next =+  LiftApp (StateT base m next)   deriving (Functor, Applicative) +-- | Base Action type. Allows paramaterization over application state, zoomed state+-- and underlying monad. newtype ActionT base zoomed m a = ActionT-  { getAction :: FreeT (ActionF base m) (StateT zoomed m) a+  { getAction :: FreeT (AppF base m) (StateT zoomed m) a   } deriving (Functor, Applicative, Monad, MonadIO, MonadState zoomed) -instance Monad n => MonadFree (ActionF base n) (ActionT base zoomed n) where-  wrap (LiftAction act) = join . ActionT . liftF . LiftAction $ act+instance Monad n => MonadFree (AppF base n) (ActionT base zoomed n) where+  wrap (LiftApp act) = join . ActionT . liftF . LiftApp $ act  instance MonadTrans (ActionT base zoomed) where   lift = ActionT . lift . lift -unLift :: Monad m => FreeT (ActionF base m) (StateT base m) a -> StateT base m a+-- | Helper method to run FreeTs.+unLift :: Monad m => FreeT (AppF base m) (StateT base m) a -> StateT base m a unLift m = do   step <- runFreeT m   case step of     Pure a -> return a-    Free (LiftAction next) -> next >>= unLift--liftAction :: Monad m => AppT base m a -> ActionT base zoomed m a-liftAction = liftF .  LiftAction . unLift . getAction--runApp :: Monad m => base -> AppT base m a -> m (a, base)-runApp baseState = flip runStateT baseState . unLift . getAction--evalApp :: Monad m => base -> AppT base m a -> m a-evalApp baseState = fmap fst . runApp baseState--execApp :: Monad m => base -> AppT base m a -> m base-execApp baseState = fmap snd . runApp baseState+    Free (LiftApp next) -> next >>= unLift -type instance Zoomed (ActionT base zoomed m) = Zoomed (FreeT (ActionF base m) (StateT zoomed m))+-- | Allows 'zoom'ing 'Action's.+type instance Zoomed (ActionT base zoomed m) = Zoomed (FreeT (AppF base m) (StateT zoomed m)) instance Monad m => Zoom (ActionT base s m) (ActionT base t m) s t where   zoom l (ActionT action) = ActionT $ zoom l action +-- | Given a 'Lens' or 'Traversal' or something similar from "Control.Lens"+-- which focuses the state (t) of an 'Action' from a base state (s),+-- this will convert @Action t a -> Action s a@.+--+-- Given a lens @HasStates s => Lens' s t@ it can also convert @Action t a -> App a@ runAction :: Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c runAction = zoom -newtype Exiting =-  Exiting Bool-  deriving (Show, Eq)--instance Default Exiting where-  def = Exiting False--exit :: (Monad m, HasStates s) => ActionT s zoomed m ()-exit = liftAction $ stateLens .= Exiting True--isExiting :: (Monad m, HasStates s) => ActionT s zoomed m Bool-isExiting = liftAction $ do-  Exiting b <- use stateLens-  return b--newtype AsyncQueue base m = AsyncQueue-  { _asyncQueue' :: Maybe (Output (AppT base m ()))-  } deriving Typeable-makeLenses ''AsyncQueue+-- | Allows you to run an 'App' or 'AppM' inside of an 'Action' or 'ActionM'+liftApp :: Monad m => AppT base m a -> ActionT base zoomed m a+liftApp = liftF .  LiftApp . unLift . getAction -instance Show (AsyncQueue base m) where-  show _ = "Async Queue"+-- | Runs an application and returns the value and state.+runApp :: Monad m => base -> AppT base m a -> m (a, base)+runApp baseState = flip runStateT baseState . unLift . getAction -instance Default (AsyncQueue base m) where-  def = AsyncQueue Nothing+-- | Runs an application and returns the resulting value.+evalApp :: Monad m => base -> AppT base m a -> m a+evalApp baseState = fmap fst . runApp baseState -asyncQueue :: (HasStates s, Typeable m, Typeable base) => Lens' s (Maybe (Output (AppT base m ())))-asyncQueue = stateLens.asyncQueue'+-- | Runs an application and returns the resulting state.+execApp :: Monad m => base -> AppT base m a -> m base+execApp baseState = fmap snd . runApp baseState
src/Eve/Internal/AppState.hs view
@@ -3,13 +3,23 @@   ( AppState(..)   , App   , Action+  , ActionM+  , AppM++  , exit+  , isExiting++  , asyncQueue   ) where  import Eve.Internal.Actions import Eve.Internal.States import Control.Lens import Data.Default+import Data.Typeable+import Pipes.Concurrent +-- | A basic default state which underlies 'App' Contains only a map of 'States'. data AppState = AppState   { _baseStates :: States   }@@ -23,5 +33,54 @@  instance HasEvents AppState where +newtype AsyncQueue base m = AsyncQueue+  { _asyncQueue' :: Maybe (Output (AppT base m ()))+  } deriving Typeable+makeLenses ''AsyncQueue++instance Show (AsyncQueue base m) where+  show _ = "Async Queue"++instance Default (AsyncQueue base m) where+  def = AsyncQueue Nothing++-- | Accesses a queue for dispatching async actions.+asyncQueue :: (HasStates s, Typeable m, Typeable base) => Lens' s (Maybe (Output (AppT base m ())))+asyncQueue = stateLens.asyncQueue'++newtype Exiting =+  Exiting Bool+  deriving (Show, Eq)++instance Default Exiting where+  def = Exiting False++-- | Tells the application to quit. This triggers 'onExit' listeners+-- following the current event loop.+exit :: (Monad m, HasStates s) => ActionT s zoomed m ()+exit = liftApp $ stateLens .= Exiting True++-- | Checks whether we're in the process of exiting.+isExiting :: (Monad m, HasStates s) => ActionT s zoomed m Bool+isExiting = liftApp $ do+  Exiting b <- use stateLens+  return b+++-- | An App is a base level monad which operates over your main application+-- state. You may call 'runAction' inside an app to run 'Action's over other states.+-- need to specify your own custom base state. type App a = AppT AppState IO a-type Action s a = ActionT AppState s IO a++-- | An Action is a monad over some zoomed in state, they are run inside 'App' using+-- 'runAction'. For example an Action which operates over a String somewhere in your app state+-- would be written as:+--+-- alterString :: Action String ()+type Action state a = ActionT AppState state IO a++-- | A more general version of 'App' which lets you specify the underlying monad.+type AppM m a = AppT AppState m a++-- | A more general version of 'Action' which lets you to specify the underlying monad.+type ActionM s m a = ActionT AppState s m a
src/Eve/Internal/Async.hs view
@@ -9,6 +9,7 @@   ) where  import Eve.Internal.Actions+import Eve.Internal.AppState import Eve.Internal.States  import Control.Monad@@ -19,9 +20,11 @@ import Pipes import Pipes.Concurrent +-- | Dispatch an action which is generated by some IO. Note that state of the application may have changed+-- between calling 'dispatchActionAsync' and running the resulting 'Action' dispatchActionAsync   :: (MonadIO m, HasStates base, Typeable m, Typeable base) => IO (AppT base m ()) -> ActionT base zoomed m ()-dispatchActionAsync asyncAction = liftAction $ do+dispatchActionAsync asyncAction = liftApp $ do   mQueue <- use asyncQueue   case mQueue of     Nothing -> return ()@@ -29,8 +32,18 @@       let effect = (liftIO asyncAction >>= yield) >-> toOutput queue       liftIO . void . forkIO $ runEffect effect >> performGC +-- | This allows long-running IO processes to provide 'Action's to the application asyncronously.+--+-- Don't let the type signature confuse you; it's much simpler than it seems.+--+-- Let's break it down:+--+-- When you call 'asyncActionProvider' you pass it a function which accepts a @dispatch@ function as an argument+-- and then calls it with various 'Action's within the resulting 'IO'.+--+-- Note that this function calls forkIO internally, so there's no need to do that yourself. asyncActionProvider :: (MonadIO m, HasStates base, Typeable m, Typeable base) => ((AppT base m () -> IO ()) -> IO ()) -> ActionT base zoomed m ()-asyncActionProvider provider = liftAction $ do+asyncActionProvider provider = liftApp $ do   mQueue <- use asyncQueue   case mQueue of     Nothing -> return ()
src/Eve/Internal/Listeners.hs view
@@ -14,7 +14,6 @@   , removeListener   , asyncEventProvider -  , onInit   , afterInit   , beforeEvent   , beforeEvent_@@ -40,36 +39,55 @@ import Data.Maybe import qualified Data.Map as M ---- | Registers an action to be performed during the Initialization phase.+-- | Registers an action to be performed directly following the Initialization phase. ----- This phase occurs exactly ONCE when the app starts up.--- Though arbitrary actions may be performed in the configuration block;--- it's recommended to embed such actions in the onInit event listener--- so that all event listeners are registered before any dispatches occur.-onInit :: forall base zoomed m result. (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m result -> ActionT base zoomed m ()-onInit action = void $ addListener (const (void action) :: Init -> ActionT base zoomed m ())-+-- At this point any listeners in the initialization block have run, so you may 'dispatchEvent's here. afterInit :: forall base zoomed m a. (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m a -> ActionT base zoomed m () afterInit action = void $ addListener (const (void action) :: AfterInit -> ActionT base zoomed m ()) --- | Registers an action to be performed BEFORE each event phase.+-- | Registers an action to be performed BEFORE each async event is processed phase. beforeEvent :: forall base zoomed m a. (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m a -> ActionT base zoomed m ListenerId beforeEvent action = addListener (const (void action) :: BeforeEvent -> ActionT base zoomed m ())  beforeEvent_ :: (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m a -> ActionT base zoomed m () beforeEvent_ = void . beforeEvent --- | Registers an action to be performed BEFORE each event phase.+-- | Registers an action to be performed AFTER each event phase. afterEvent :: forall base zoomed m a. (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m a -> ActionT base zoomed m ListenerId afterEvent action = addListener (const (void action) :: AfterEvent -> ActionT base zoomed m ())  afterEvent_ :: (Monad m, HasEvents zoomed, Typeable m, Typeable base) => ActionT base zoomed m a -> ActionT base zoomed m () afterEvent_ = void . afterEvent +-- | Registers an action to be run before shutdown. Any asynchronous combinators used in this block will NOT be run. onExit :: forall base zoomed m a. (HasEvents zoomed, Typeable m, Typeable base, Monad m) => ActionT base zoomed m a -> ActionT base zoomed m () onExit action = void $ addListener (const $ void action :: Exit -> ActionT base zoomed m ()) +-- | Given an Event of any type, this runs any listeners registered for that event type with the provided event.+-- Events may also contain data pertaining to the event and it will be passed to the listeners.+--+-- You can also 'query' listeners and receive a ('Monoid'al) result.+--+-- > data RequestNames = GetFirstName | GetLastName+-- > provideName1, provideName2 :: RequestNames -> App [String]+-- > provideName1 GetFirstNames = return ["Bob"]+-- > provideName1 GetLastNames = return ["Smith"]+-- > provideName2 GetFirstNames = return ["Sally"]+-- > provideName2 GetLastNames = return ["Jenkins"]+-- >+-- > -- Note that if we registered an action of type 'GetFirstName -> ()' it would NOT+-- > -- be run in response to the following 'dispatchEvent', since it's type doesn't match.+-- >+-- > greetNames :: App [String]+-- > greetNames = do+-- >   addListener_ provideName1+-- >   addListener_ provideName2+-- >   firstNames <- dispatchEvent GetFirstName+-- >   lastNames <- dispatchEvent GetLastName+-- >   liftIO $ print firstNames+-- >   -- ["Bob", "Sally"]+-- >   liftIO $ print lastNames+-- >   -- ["Smith", "Jenkins"] dispatchEvent   :: forall result eventType m s.      (MonadState s m@@ -94,7 +112,13 @@   => eventType -> m () dispatchEvent_ = dispatchEvent -+-- | Registers an 'Action' or 'App' to respond to an event.+--+-- For a given use: @addListener myListener@, @myListener@ might have the type @MyEvent -> App a@+-- it will register the function @myListener@ to be run in response to a @dispatchEvent (MyEvent eventInfo)@+-- and will be provided @(MyEvent eventInfo)@ as an argument.+--+-- This returns a 'ListenerId' which corresponds to the registered listener for use with 'removeListener' addListener   :: forall result eventType m s.      (MonadState s m@@ -132,6 +156,7 @@   => (eventType -> m result) -> m () addListener_ = void . addListener +-- | Unregisters a listener referred to by the provided 'ListenerId' removeListener   :: (MonadState s m, HasEvents s)   => ListenerId -> m ()@@ -144,9 +169,9 @@     notMatch idA (Listener _ idB _) = idA /= idB  -- | This function takes an IO which results in some event, it runs the IO--- asynchronously and dispatches the event. Note that any listeners which are--- registered for the resulting event will still be run syncronously, only the--- code which generates the event is asynchronous.+-- asynchronously, THEN dispatches the event. Note that only the+-- code which generates the event is asynchronous, not any responses to the event+-- itself. dispatchEventAsync   :: (Typeable event      ,MonadIO m@@ -216,7 +241,7 @@ type Dispatcher = forall event. Typeable event =>                                 event -> IO () --- | This allows long-running IO processes to provide Events to the ActionT base zoomed m asyncronously.+-- | This allows long-running IO processes to provide Events to the application asyncronously. -- -- Don't let the type signature confuse you; it's much simpler than it seems. --@@ -239,8 +264,8 @@ -- > myTimer :: Dispatcher -> IO () -- > myTimer dispatch = forever $ dispatch Timer >> threadDelay 1000000 -- >--- > myAction :: Action s ()--- > myAction = onInit $ asyncEventProvider myTimer+-- > myInit :: App ()+-- > myInit = asyncEventProvider myTimer asyncEventProvider   :: (HasEvents base, MonadIO m, Typeable m) => (Dispatcher -> IO ()) -> ActionT base zoomed m () asyncEventProvider asyncEventProv = asyncActionProvider $ eventsToActions asyncEventProv
src/Eve/Internal/Run.hs view
@@ -1,13 +1,13 @@ module Eve.Internal.Run   ( eve-  , eveT+  , eve_   ) where  import Eve.Internal.Actions-import Eve.Internal.AppState import Eve.Internal.Listeners import Eve.Internal.Events import Eve.Internal.States()+import Eve.Internal.AppState  import Control.Monad import Control.Monad.State@@ -20,19 +20,41 @@ import Pipes.Concurrent import qualified Pipes.Parse as PP -eve :: App () -> IO ()-eve = void . eveT def--eveT :: (MonadIO m, Typeable m, HasEvents base) => base -> AppT base m () -> m base-eveT startState initialize = do+-- | This runs your application. It accepts an initialization block (which+-- is the same as any other 'App' or 'Action' block, which+-- registers event listeners and event providers. Note that nothing in this+-- block should use 'dispatchEvent' since it is possible that not all listeners+-- have yet been registered. You can use the 'afterInit' trigger to dispatch+-- any events you'd like to run at start-up.+--+-- It is polymorphic in the Monad it operates over, so you may use it with any +-- custom base monad which implements 'MonadIO'.+--+-- If you don't need this functionality; the easiest way to get started is to simply+-- cally it like so:+--+-- > import Eve+-- >+-- > initialize = App ()+-- > initialize = do+-- >   addListener ...+-- >   ...+-- >+-- > startApp :: IO ()+-- > startApp = eve_ initialize+eve :: (MonadIO m, Typeable m) => AppT AppState m () -> m AppState+eve initialize = do   (output, input) <- liftIO $ spawn unbounded-  execApp (startState & asyncQueue .~ Just output) $ do+  execApp (def & asyncQueue .~ Just output) $ do     initialize     dispatchEvent_ Init     dispatchEvent_ AfterInit     eventLoop $ fromInput input     dispatchEvent_ Exit-    get++-- | 'eve' with '()' as its return value.+eve_ :: (MonadIO m, Typeable m) => AppT AppState m () -> m ()+eve_ = void . eve  -- | This is the main event loop, it runs recursively forever until something -- sets the exit status. It runs the pre-event listeners, then checks if any
src/Eve/Internal/States.hs view
@@ -27,8 +27,8 @@ type States = Map TypeRep StateWrapper  -- | Represents a state which can itself store more states.+-- 'states' is a lens which points to a given state's 'States' map. class HasStates s  where--- | This lens points to a given state's 'States' map.   states :: Lens' s States  -- | A typeclass to ensure people don't dispatch events to states which shouldn't
src/Eve/Testing.hs view
@@ -3,7 +3,6 @@   ) where  import Eve.Internal.Actions-import Eve.Internal.Run import Eve.Internal.AppState  import Control.Monad.Identity
test/Eve/Internal/ActionsSpec.hs view
@@ -4,7 +4,7 @@  import Fixtures import Eve-import Eve.Internal.Actions+import Eve.Internal.AppState  import Control.Lens import Control.Monad.State@@ -12,10 +12,10 @@ appendEx  :: Monad m => ActionT AppState String m () appendEx  = modify (++ "!!") -liftActionTest :: Monad m => ActionT AppState String m String-liftActionTest = do+liftAppTest :: Monad m => ActionT AppState String m String+liftAppTest = do   put "new"-  liftAction $ runAction stateLens appendEx+  liftApp $ runAction stateLens appendEx   get  spec :: Spec@@ -34,8 +34,8 @@       let (traversalResult, _) = noIOTest $ runAction stateLens (put $ Just "new") >> runAction (stateLens._Just) (appendEx >> get)        in traversalResult `shouldBe` "new!!" -  describe "liftAction" $ do+  describe "liftApp" $ do     it "runs lifted actions to zoomed monad" $-      let (liftActionResult, _) = noIOTest (runAction stateLens liftActionTest :: AppT AppState Identity String)-       in liftActionResult `shouldBe` "new!!"+      let (liftAppResult, _) = noIOTest (runAction stateLens liftAppTest :: AppT AppState Identity String)+       in liftAppResult `shouldBe` "new!!"
test/Fixtures.hs view
@@ -33,4 +33,4 @@ data CustomEvent = CustomEvent  ioTest :: App () -> SpecM m AppState-ioTest = runIO . eveT def+ioTest = runIO . eve