diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Penner (c) 2017 + +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 Chris Penner 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,94 @@ +Eve +=== + +[![Join the chat at https://gitter.im/eve-framework/Lobby](https://badges.gitter.im/eve-framework/Lobby.svg)](https://gitter.im/eve-framework/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Hackage](https://img.shields.io/badge/hackage-latest-green.svg)](https://hackage.haskell.org/package/eve) + +An extensible event-driven application framework in haskell for building embarassingly modular software. + +Documentation +------------- +You can find hackage documentation for eve [HERE](https://hackage.haskell.org/package/eve) + +Getting started +--------------- +### [Building an App in Eve](https://github.com/ChrisPenner/eve/blob/master/docs/Building-An-App.md) + +\^ That guide will bring you through the process of making your first app! + +If you have any issues (and I'm sure there'll be a few; it's a new project!) +please report them [here](https://github.com/ChrisPenner/rasa/issues). + +Core Principles +--------------- + +Eve's core principle is making it easy to build programs in a modular way. +There are two key concepts in Eve which you should be aware of: + +- Events +- State + +Eve provides many useful combinators for dispatching events and adding +listeners to events, events are a broad concept in Eve and can be triggered by +user-interaction, file-changes, even network sockets! Anything you can think of +really! Each time an event is fired, your app 'reacts' by running any +associated listeners on the given event. This is quite similar to other event +systems so far; however Eve does a few things differently. This is where the +'State' concept comes in. When writing an App, or an extension for an App, in +Eve, you can specify a state object which you'd like Eve to keep track of for +you, you can run monadic actions over this state and do whatever you want with +it. You can even expose your state-changing combinators to other extensions to +allow them to change the state too! Another nifty thing is that events can be +dispatched on different levels; so for instance in the Rasa text editor which +is built using Eve, there's the notion of 'Global Events' and 'Buffer Events'. +A 'Buffer' is a State object they've defined, and they added the `HasEvents` +typeclass to it, which now allows them to register listeners and dispatch +events to a specific instance of a buffer! Trackable states (and therefore +state-level event listeners) can be nested several levels deep without issue. +Unlike most event systems, Eve also allows Monoidal return values from event +listeners, so you can collect 'responses' from each event you fire if you wish. + +When designing applications in Eve; it's crucial to think about how the +state of you application will be stored, and how different components interact. +Eve works best when components are separated and communicate with each-other through +events. This is because it allows those who will eventually write extensions to your +application to 'hook' into those events to add functionality. + +There are some definite Pros and Cons to Eve's approach: + +### Pros + +- Implementing most core functionality as extensions ensures a powerful and + elegant extension interface. +- Flexibility & Adaptability; applications can be written in such a way that + users can replace entire components with alternate versions. + +### Cons + +- Module cross-dependencies makes the community infrastructure more fragile, +- This architecture takes some getting used-to. + + +Contributing +============ + +Installation +------------ + +Eve uses Stack for reproducible builds. + +1. Install [stack](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) +3. Clone this repo and `cd` into the directory +4. Run `stack build` + +Running Tests +------------- + +- `stack test` + +Contributions +------------- + +Chatting about features is a key part of Eve's development; come join us in +the [Chat Room](https://gitter.im/eve-framework/Lobby) to discuss features or +improvements! 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/eve.cabal b/eve.cabal new file mode 100644 --- /dev/null +++ b/eve.cabal @@ -0,0 +1,61 @@ +name: eve +version: 0.1.0 +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 +license: BSD3 +license-file: LICENSE +author: Chris Penner +maintainer: christopher.penner@gmail.com +copyright: 2017 Chris Penner +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Eve + , Eve.Internal.Testing + , Eve.Internal.Actions + , Eve.Internal.Async + , Eve.Internal.Events + , Eve.Internal.Extensions + , Eve.Internal.Listeners + , Eve.Internal.Run + build-depends: base >= 4.7 && < 5 + , mtl + , lens + , free + , pipes + , pipes-parse + , pipes-concurrency + , data-default + , containers + default-language: Haskell2010 + +test-suite eve-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Fixtures + , EveSpec + , Eve.Internal.AsyncSpec + , Eve.Internal.ActionsSpec + , Eve.Internal.ExtensionsSpec + , Eve.Internal.EventsSpec + , Eve.Internal.ListenersSpec + , Eve.Internal.RunSpec + build-depends: base + , eve + , hspec + , hspec-core + , lens + , mtl + , data-default + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/ChrisPenner/eve diff --git a/src/Eve.hs b/src/Eve.hs new file mode 100644 --- /dev/null +++ b/src/Eve.hs @@ -0,0 +1,44 @@ +module Eve + ( eve + + , App + , Action + , liftAction + + , dispatchEvent + , dispatchEvent_ + , dispatchEventAsync + , dispatchActionAsync + + , addListener + , addListener_ + , removeListener + + , onInit + , afterInit + , beforeEvent + , beforeEvent_ + , afterEvent + , afterEvent_ + , onExit + + , asyncActionProvider + , asyncEventProvider + + , Listener + , ListenerId + + , HasExts(..) + , Exts + , HasEvents + , ext + + , runAction + , exit + ) where + +import Eve.Internal.Run +import Eve.Internal.Actions +import Eve.Internal.Listeners +import Eve.Internal.Async +import Eve.Internal.Extensions diff --git a/src/Eve/Internal/Actions.hs b/src/Eve/Internal/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Actions.hs @@ -0,0 +1,89 @@ +{-# language GeneralizedNewtypeDeriving #-} +{-# language DeriveFunctor #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language TemplateHaskell #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-# language ScopedTypeVariables #-} +module Eve.Internal.Actions + ( Action(..) + , ActionF(..) + , App + , execApp + + , AppState(..) + , asyncQueue + + , liftAction + , runAction + + , exit + , isExiting + , Exiting(..) + ) where + +import Eve.Internal.Extensions +import Data.Default + +import Control.Monad.State +import Control.Monad.Trans.Free +import Control.Lens + +import Pipes.Concurrent + +type App a = Action AppState a +data AppState = AppState + { _baseExts :: Exts + , _asyncQueue :: Output (App ()) + } + +newtype ActionF next = + LiftAction (StateT AppState IO next) + deriving (Functor, Applicative) + +newtype Action zoomed a = Action + { getAction :: FreeT ActionF (StateT zoomed IO) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadState zoomed, MonadFree ActionF) +makeLenses ''AppState + +instance HasExts AppState where + exts = baseExts + +instance HasEvents AppState where + +unLift :: FreeT ActionF (StateT AppState IO) a -> StateT AppState IO a +unLift m = do + step <- runFreeT m + case step of + Pure a -> return a + Free (LiftAction next) -> next >>= unLift + +liftAction :: Action AppState a -> Action zoomed a +liftAction = liftF . LiftAction . unLift . getAction + +execApp :: AppState -> Action AppState a -> IO a +execApp appState = flip evalStateT appState . unLift . getAction + +type instance Zoomed (Action s) = Zoomed (FreeT ActionF (StateT s IO)) +instance Zoom (Action s) (Action t) s t where + zoom l (Action action) = Action $ zoom l action + +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 :: App () +exit = ext .= Exiting True + +isExiting :: App Bool +isExiting = do + Exiting b <- use ext + return b diff --git a/src/Eve/Internal/Async.hs b/src/Eve/Internal/Async.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Async.hs @@ -0,0 +1,33 @@ +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language ExistentialQuantification #-} +{-# language ScopedTypeVariables #-} + +module Eve.Internal.Async + ( dispatchActionAsync + , asyncActionProvider + ) where + +import Eve.Internal.Actions + +import Control.Monad +import Control.Monad.State +import Control.Lens + +import Pipes +import Pipes.Concurrent + +dispatchActionAsync + :: IO (App ()) -> App () +dispatchActionAsync asyncAction = do + queue <- use asyncQueue + let effect = (liftIO asyncAction >>= yield) >-> toOutput queue + liftIO . void . forkIO $ runEffect effect >> performGC + +asyncActionProvider :: ((App () -> IO ()) -> IO ()) -> App () +asyncActionProvider provider = do + queue <- use asyncQueue + let dispatcher action = + let effect = yield action >-> toOutput queue + in void . forkIO $ runEffect effect >> performGC + liftIO . void . forkIO $ provider dispatcher diff --git a/src/Eve/Internal/Events.hs b/src/Eve/Internal/Events.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Events.hs @@ -0,0 +1,13 @@ +module Eve.Internal.Events + ( Init(..) + , AfterInit(..) + , BeforeEvent(..) + , AfterEvent(..) + , Exit(..) + ) where + +data Init = Init +data AfterInit = AfterInit +data BeforeEvent = BeforeEvent +data AfterEvent = AfterEvent +data Exit = Exit diff --git a/src/Eve/Internal/Extensions.hs b/src/Eve/Internal/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Extensions.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Eve.Internal.Extensions + ( Exts + , HasExts(..) + , HasEvents + , ext + ) where + +import Control.Lens +import Data.Map +import Unsafe.Coerce +import Data.Maybe +import Data.Typeable +import Data.Default + +-- | A wrapper to allow storing differing extensions in the same place. +data Ext = + forall ext. (Typeable ext, Show ext) => + Ext ext + +instance Show Ext where + show (Ext a) = show a + +-- | A map of extension types to their current value. +type Exts = Map TypeRep Ext + +-- | Represents a state which can be extended. +-- 'exts' is a 'Lens'' which points to the state's 'Exts' +class HasExts s where + exts :: Lens' s Exts + +-- | A typeclass to ensure people don't dispatch events to states which shouldn't +-- accept them. +-- +-- To allow dispatching events in an action over your state simply define the +-- empty instance: +-- +-- > instance HasEvents MyState where +-- -- Don't need anything here. +class (Typeable s, HasExts s) => + HasEvents s + +-- | A polymorphic lens which accesses extensions in the extension state. +-- It returns the default value ('def') if a state has not yet been set. +ext + :: forall a e. + (Show a, Typeable a, Default a, HasExts e) + => Lens' e a +ext = lens getter setter + where + getter s = + fromMaybe def $ s ^. exts . at (typeRep (Proxy :: Proxy a)) . mapping coerce + setter s new = + set (exts . at (typeRep (Proxy :: Proxy a)) . mapping coerce) (Just new) s + coerce = iso (\(Ext x) -> unsafeCoerce x) Ext diff --git a/src/Eve/Internal/Listeners.hs b/src/Eve/Internal/Listeners.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Listeners.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module Eve.Internal.Listeners + ( HasEvents + , dispatchEvent + , dispatchEvent_ + , dispatchEventAsync + + , addListener + , addListener_ + , removeListener + , asyncEventProvider + + , onInit + , afterInit + , beforeEvent + , beforeEvent_ + , afterEvent + , afterEvent_ + , onExit + + , Listener + , ListenerId + ) where + +import Eve.Internal.Extensions +import Eve.Internal.Async +import Eve.Internal.Actions +import Eve.Internal.Events + +import Control.Monad.State +import Control.Lens + +import Data.Default +import Data.Typeable +import Data.Maybe +import qualified Data.Map as M + + +-- | Registers an action to be performed during 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 :: App result -> App () +onInit action = void $ addListener (const (void action) :: Init -> App ()) + +afterInit :: App a -> App () +afterInit action = void $ addListener (const (void action) :: AfterInit -> App ()) + +-- | Registers an action to be performed BEFORE each event phase. +beforeEvent :: App a -> App ListenerId +beforeEvent action = addListener (const (void action) :: BeforeEvent -> App ()) + +beforeEvent_ :: App a -> App () +beforeEvent_ = void . beforeEvent + +-- | Registers an action to be performed BEFORE each event phase. +afterEvent :: App a -> App ListenerId +afterEvent action = addListener (const (void action) :: AfterEvent -> App ()) + +afterEvent_ :: App a -> App () +afterEvent_ = void . afterEvent + +onExit :: App a -> App () +onExit action = void $ addListener (const $ void action :: Exit -> App ()) + +dispatchEvent + :: forall result eventType m s. + (MonadState s m + ,HasEvents s + ,Monoid result + ,Typeable m + ,Typeable eventType + ,Typeable result) + => eventType -> m result +dispatchEvent evt = do + LocalListeners _ listeners <- use localListeners + results <- + traverse ($ evt) (matchingListeners listeners :: [eventType -> m result]) + return (mconcat results :: result) + +dispatchEvent_ + :: forall eventType m s. + (MonadState s m + ,HasEvents s + ,Typeable m + ,Typeable eventType) + => eventType -> m () +dispatchEvent_ = dispatchEvent + + +addListener + :: forall result eventType m s. + (MonadState s m + ,HasEvents s + ,Typeable m + ,Typeable eventType + ,Typeable result + ,Monoid result) + => (eventType -> m result) -> m ListenerId +addListener lFunc = do + LocalListeners nextListenerId listeners <- use localListeners + let (listener, listenerId, eventType) = mkListener nextListenerId lFunc + newListeners = M.insertWith mappend eventType [listener] listeners + localListeners .= LocalListeners (nextListenerId + 1) newListeners + return listenerId + where + mkListener + :: forall event r. + (Typeable event, Typeable r, Monoid r) + => Int -> (event -> m r) -> (Listener, ListenerId, TypeRep) + mkListener n listenerFunc = + let list = Listener (typeOf listenerFunc) listId listenerFunc + listId = ListenerId n (typeRep (Proxy :: Proxy event)) + prox = typeRep (Proxy :: Proxy event) + in (list, listId, prox) + +addListener_ + :: forall result eventType m s. + (MonadState s m + ,HasEvents s + ,Typeable m + ,Typeable eventType + ,Typeable result + ,Monoid result) + => (eventType -> m result) -> m () +addListener_ = void . addListener + +removeListener + :: (MonadState s m, HasEvents s) + => ListenerId -> m () +removeListener listenerId@(ListenerId _ eventType) = localListeners %= remover + where + remover (LocalListeners nextListenerId listeners) = + let newListeners = + listeners & at eventType . _Just %~ filter (notMatch listenerId) + in LocalListeners nextListenerId newListeners + 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. +dispatchEventAsync + :: (Typeable event) + => IO event -> App () +dispatchEventAsync ioEvent = dispatchActionAsync $ dispatchEvent <$> ioEvent + +-- | A wrapper around event listeners so they can be stored in 'Listeners'. +data Listener where + Listener :: + (MonadState s m, Typeable m, Typeable eventType, Typeable result, + Monoid result, HasExts s) => + TypeRep -> ListenerId -> (eventType -> m result) -> Listener + +instance Show Listener where + show (Listener rep (ListenerId n _) _) = + "" + +-- | An opaque reverence to a specific registered event-listener. +-- A ListenerId is used only to remove listeners later with 'removeListener'. +data ListenerId = + ListenerId Int + TypeRep + deriving (Show) + +instance Eq ListenerId where + ListenerId a _ == ListenerId b _ = a == b + +-- | A map of event types to a list of listeners for that event +type Listeners = M.Map TypeRep [Listener] + +-- | Store the listeners in extensions +data LocalListeners = + LocalListeners Int + Listeners + deriving (Show) + +instance Default LocalListeners where + def = LocalListeners 0 M.empty + +localListeners + :: HasExts s + => Lens' s LocalListeners +localListeners = ext + +-- | This extracts all event listeners from a map of listeners which match the type of the provided event. +matchingListeners + :: forall m eventType result. + (Typeable m + ,Typeable eventType + ,Typeable result) + => Listeners -> [eventType -> m result] +matchingListeners listeners = + catMaybes $ (getListener :: Listener -> Maybe (eventType -> m result)) <$> + (listeners ^. at (typeRep (Proxy :: Proxy eventType)) . _Just) + +-- | Extract the listener function from eventType listener +getListener + :: Typeable expected + => Listener -> Maybe expected +getListener (Listener _ _ x) = cast x + +-- | This is a type alias to make defining your functions for use with 'asyncEventProvider' easier; +-- It represents the function your event provider function will be passed to allow dispatching +-- events. Using this type requires the @RankNTypes@ language pragma. +type Dispatcher = forall event. Typeable event => + event -> IO () + +-- | This allows long-running IO processes to provide Events to the App asyncronously. +-- +-- Don't let the type signature confuse you; it's much simpler than it seems. +-- +-- Let's break it down: +-- +-- Using the 'Dispatcher' type with asyncEventProvider requires the @RankNTypes@ language pragma. +-- +-- This type as a whole represents a function which accepts a 'Dispatcher' and returns an 'IO'; +-- the dispatcher itself accepts data of ANY 'Typeable' type and emits it as an event. +-- +-- When you call 'asyncEventProvider' you pass it a function which accepts a @dispatch@ function as an argument +-- and then calls it with various events within the resulting 'IO'. +-- +-- Note that this function calls forkIO internally, so there's no need to do that yourself. +-- +-- Here's an example which fires a @Timer@ event every second. +-- +-- > {-# language RankNTypes #-} +-- > data Timer = Timer +-- > myTimer :: Dispatcher -> IO () +-- > myTimer dispatch = forever $ dispatch Timer >> threadDelay 1000000 +-- > +-- > myAction :: Action s () +-- > myAction = onInit $ asyncEventProvider myTimer +asyncEventProvider + :: (Dispatcher -> IO ()) -> App () +asyncEventProvider asyncEventProv = asyncActionProvider $ eventsToActions asyncEventProv + where + eventsToActions :: (Dispatcher -> IO ()) -> (App () -> IO ()) -> IO () + eventsToActions aEventProv dispatcher = + aEventProv (dispatcher . dispatchEvent) diff --git a/src/Eve/Internal/Run.hs b/src/Eve/Internal/Run.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Run.hs @@ -0,0 +1,37 @@ +module Eve.Internal.Run + ( eve + ) where + +import Eve.Internal.Actions +import Eve.Internal.Listeners +import Eve.Internal.Events + +import Control.Monad.State +import Data.Maybe + +import Pipes +import Pipes.Concurrent +import qualified Pipes.Parse as PP + +eve :: App () -> IO AppState +eve initialize = do + (output, input) <- spawn unbounded + execApp (AppState mempty output) $ do + initialize + dispatchEvent_ Init + dispatchEvent_ AfterInit + eventLoop $ fromInput input + dispatchEvent_ Exit + get + +-- | 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 +-- async events have finished, then runs the post event listeners and repeats. +eventLoop :: Producer (App ()) IO () -> App () +eventLoop producer = do + dispatchEvent_ BeforeEvent + (mAction, nextProducer) <- liftIO $ PP.runStateT PP.draw producer + fromMaybe (return ()) mAction + dispatchEvent_ AfterEvent + shouldExit <- isExiting + unless shouldExit $ eventLoop nextProducer diff --git a/src/Eve/Internal/Testing.hs b/src/Eve/Internal/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Eve/Internal/Testing.hs @@ -0,0 +1,15 @@ +module Eve.Internal.Testing + ( AppState(..) + , Exiting(..) + , noEventTest + ) where + +import Eve +import Eve.Internal.Actions +import Eve.Internal.Events +import Pipes.Concurrent + +noEventTest :: App a -> IO a +noEventTest test = do + (output, input) <- spawn unbounded + execApp (AppState mempty output) $ test diff --git a/test/Eve/Internal/ActionsSpec.hs b/test/Eve/Internal/ActionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/ActionsSpec.hs @@ -0,0 +1,39 @@ +module Eve.Internal.ActionsSpec where + +import Test.Hspec + +import Fixtures +import Eve +import Eve.Internal.Testing +import Eve.Internal.Actions + +import Control.Lens +import Control.Monad.State + +appendEx :: Action String () +appendEx = modify (++ "!!") + +spec :: Spec +spec = do + describe "Exiting" $ do + exiting <- runIO . noEventTest $ exit >> isExiting + it "Exits" $ + exiting `shouldBe` True + + describe "runAction " $ do + runActionResult <- runIO . noEventTest $ runAction ext (put "new" >> appendEx) >> runAction ext get + it "runs lifted actions to zoomed monad" $ + runActionResult `shouldBe` "new!!" + + traversalResult <- runIO . noEventTest $ runAction ext (put $ Just "new") >> runAction (ext._Just) (appendEx >> get) + it "runs over traversals" $ + traversalResult `shouldBe` "new!!" + + describe "liftAction" $ do + liftActionResult <- runIO . noEventTest . runAction ext $ do + put "new" + liftAction $ runAction ext appendEx + get + it "runs lifted actions to zoomed monad" $ + liftActionResult `shouldBe` "new!!" + diff --git a/test/Eve/Internal/AsyncSpec.hs b/test/Eve/Internal/AsyncSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/AsyncSpec.hs @@ -0,0 +1,25 @@ +module Eve.Internal.AsyncSpec where + +import Test.Hspec + +import Fixtures +import Control.Lens +import Eve + +asyncActionsTest :: App () +asyncActionsTest = do + addListener (const exit :: CustomEvent -> App ()) + asyncActionProvider (\d -> d exit) + store .= "new" + +spec :: Spec +spec = do + describe "asyncActionProvider" $ do + asyncState <- runIO $ eve (asyncActionProvider (\d -> d (store .= "new" >> exit))) + it "Eventually Runs Provided Actions" $ + (asyncState ^. store) `shouldBe` "new" + describe "dispatchActionAsync" $ do + asyncState <- runIO $ eve (asyncActionProvider (\d -> d (store .= "new" >> exit))) + asyncActionsResult <- runIO $ eve asyncActionsTest + it "Eventually Runs Provided Actions" $ + (asyncActionsResult ^. store) `shouldBe` "new" diff --git a/test/Eve/Internal/EventsSpec.hs b/test/Eve/Internal/EventsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/EventsSpec.hs @@ -0,0 +1,6 @@ +module Eve.Internal.EventsSpec where + +import Test.Hspec + +spec :: Spec +spec = return () diff --git a/test/Eve/Internal/ExtensionsSpec.hs b/test/Eve/Internal/ExtensionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/ExtensionsSpec.hs @@ -0,0 +1,6 @@ +module Eve.Internal.ExtensionsSpec where + +import Test.Hspec + +spec :: Spec +spec = return () diff --git a/test/Eve/Internal/ListenersSpec.hs b/test/Eve/Internal/ListenersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/ListenersSpec.hs @@ -0,0 +1,58 @@ +{-# language ScopedTypeVariables #-} +module Eve.Internal.ListenersSpec where + +import Test.Hspec + +import Fixtures +import Eve + +import Control.Monad.State +import Control.Lens + +testAction :: State ExtState () -> ExtState +testAction = flip execState emptyExts + +basicAction :: State ExtState () +basicAction = do + addListener (const (store .= "new") :: CustomEvent -> State ExtState ()) + dispatchEvent_ CustomEvent + +delayedExit :: App () +delayedExit = do + addListener (const exit :: CustomEvent -> App ()) + dispatchEventAsync (return CustomEvent) + store .= "new" + +removeListenersTest :: State ExtState () +removeListenersTest = do + listId <- addListener (const (store .= "new") :: CustomEvent -> State ExtState ()) + removeListener listId + dispatchEvent_ CustomEvent + +asyncEventsTest :: App () +asyncEventsTest = do + addListener (const exit :: CustomEvent -> App ()) + asyncEventProvider (\d -> d CustomEvent) + store .= "new" + +data OtherEvent = OtherEvent +multiAsyncEventsTest :: App () +multiAsyncEventsTest = do + addListener (const exit :: CustomEvent -> App ()) + addListener (const (store .= "new") :: OtherEvent -> App ()) + asyncEventProvider (\d -> d CustomEvent >> d OtherEvent) + +spec :: Spec +spec = do + describe "dispatchEvent/addListener" $ + it "Triggers Listeners" $ (testAction basicAction ^. store) `shouldBe` "new" + describe "dispatchEventAsync" $ do + delayedExitState <- runIO $ eve delayedExit + it "Triggers Listeners Eventually" $ (delayedExitState ^. store) `shouldBe` "new" + describe "removeListener" $ + it "Removes Listeners" $ (testAction removeListenersTest ^. store) `shouldBe` "default" + describe "asyncEventProvider" $ do + asyncEventsResult <- runIO $ eve asyncEventsTest + it "Provides events eventually" $ (asyncEventsResult ^. store) `shouldBe` "new" + multiAsyncEventsResult <- runIO $ eve multiAsyncEventsTest + it "Can provide different event types" $ (multiAsyncEventsResult ^. store) `shouldBe` "new" diff --git a/test/Eve/Internal/RunSpec.hs b/test/Eve/Internal/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/Eve/Internal/RunSpec.hs @@ -0,0 +1,25 @@ +module Eve.Internal.RunSpec where + +import Test.Hspec.Core.Spec (SpecM) +import Test.Hspec +import Fixtures +import Eve +import Eve.Internal.Testing +import Control.Lens + +exiter :: (App () -> IO ()) -> IO () +exiter dispatch = dispatch exit + +runWithInit :: App () -> SpecM a AppState +runWithInit next = runIO $ eve (next >> asyncActionProvider exiter) + +spec :: Spec +spec = do + describe "Running App" $ do + initializeState <- runWithInit (store .= "new") + it "Initializes" $ + (initializeState ^. store) `shouldBe` "new" + + asyncState <- runIO $ eve (asyncActionProvider (\d -> d (store .= "new" >> exit))) + it "Collects Async Actions" $ + (asyncState ^. store) `shouldBe` "new" diff --git a/test/EveSpec.hs b/test/EveSpec.hs new file mode 100644 --- /dev/null +++ b/test/EveSpec.hs @@ -0,0 +1,9 @@ +module EveSpec where + +import Test.Hspec + +spec :: Spec +spec = do + describe "Eve" $ do + it "runs tests" $ + True `shouldBe` True diff --git a/test/Fixtures.hs b/test/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Fixtures.hs @@ -0,0 +1,39 @@ +{-# language TemplateHaskell #-} +module Fixtures + ( ExtState(..) + , store + , CustomEvent(..) + , emptyExts + ) where + +import Eve.Internal.Extensions +import Eve.Internal.Listeners + +import Control.Lens +import Data.Default + +data ExtState = ExtState + { _testExts :: Exts + } + +makeLenses ''ExtState + +instance HasExts ExtState where + exts = testExts + +instance HasEvents ExtState + +emptyExts = ExtState mempty + +data Store = Store + {_payload :: String + } deriving (Show, Eq) +makeLenses ''Store + +store :: HasExts s => Lens' s String +store = ext.payload + +instance Default Store where + def = Store "default" + +data CustomEvent = CustomEvent diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}