feather (empty) → 0.1.0.0

raw patch · 6 files changed

+322/−0 lines, 6 filesdep +basedep +containersdep +feathersetup-changed

Dependencies added: base, containers, feather, microlens-platform, mtl

Files

LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
feather.cabal +56/−0
src/Feather.hs +229/−0
test/Spec.hs +2/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2019++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 Author name here 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.

+ README.md view

@@ -0,0 +1,3 @@+# Feather++A minimalistic and performant events dispatcher.

+ Setup.hs view

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

+ feather.cabal view

@@ -0,0 +1,56 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 60873e1927a56e90e872036135557569b68946e9a94545d335cc404f821e2113++name:           feather+version:        0.1.0.0+description:    A minimalistic and performant events dispatcher.+homepage:       https://github.com/libscott/feather#readme+bug-reports:    https://github.com/libscott/feather/issues+author:         Scott Sadler+maintainer:     scott@scottsadler.de+copyright:      2019 Scott Sadler+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/libscott/feather++library+  exposed-modules:+      Feather+  other-modules:+      Paths_feather+  hs-source-dirs:+      src+  default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeSynonymInstances ViewPatterns+  build-depends:+      base >=4.7 && <5+    , containers+    , microlens-platform+    , mtl+  default-language: Haskell2010++test-suite feather-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_feather+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , feather+    , microlens-platform+    , mtl+  default-language: Haskell2010

+ src/Feather.hs view

@@ -0,0 +1,229 @@+{-# LANGUAGE TemplateHaskell #-}++module Feather+  ( EventHandler(..)+  , EventState+  , EventInput+  , HasEvents(..)+  , Complex(..)+  , Complex2+  , Complex3+  , emptyEventState+  , addHandler+  , runEvent+  , getHandler+  , testEvents+  ) where++import Control.Monad.State+import Control.Monad.State.Class+import Control.Concurrent+import Data.List+import Data.Map (Map)+import Data.Maybe+import Data.Typeable+import Lens.Micro.Platform+import Unsafe.Coerce++--+-- | Types+--++class HasEvents s where+  lensEvents :: Lens' s EventState++newtype HandlerId = HandlerId Int deriving (Eq, Ord, Num, Show)++type Updater m = m ()+type Dispatcher i m = i -> m ()+type Builder i m = m (Dispatcher i m)+type InputSpec m = (TypeRep, OpaqueBuilder, m ())++-- Constraint aliases+type T a = Typeable a+type SM s m = (HasEvents s, MonadState s m)+type SIM s i m = (SM s m, T i)++data OpaqueBuilder where+  OpaqueBuilder :: SIM s i m => Builder i m -> OpaqueBuilder++data OpaqueDispatcher where+  OpaqueDispatcher :: SIM s i m => Dispatcher i m -> OpaqueDispatcher++data OpaqueUpdater where+  OpaqueUpdater :: SM s m => Updater m -> OpaqueUpdater++type EventHandler i o m = Dispatcher o m -> Dispatcher i m++emptyEventState :: EventState+emptyEventState = EventState 0 mempty mempty mempty mempty []++data EventState =+  EventState+    { eId'         :: HandlerId+    , eListeners'  :: Map TypeRep [(HandlerId, OpaqueBuilder)]+    , eHandlers'   :: Map HandlerId TypeRep+    , eEmitters'   :: Map TypeRep [(HandlerId, OpaqueUpdater)]+    , eDispatcher' :: Map TypeRep OpaqueDispatcher+    , eSeen'       :: [HandlerId]+    }++makeLensesWith abbreviatedFields ''EventState++-- | An event handler may listen for many different types+class SIM s i m => EventInput s i m where+  getInputs :: T o => EventHandler i o m -> m [InputSpec m]++instance {-# OVERLAPPABLE #-} SIM s i m => EventInput s i m where+  getInputs = pure . makeInput (id :: i -> i)++--+-- Add listener+--++addHandler :: forall s i m o. (SIM s i m, EventInput s i m, T o, T m)+           => EventHandler i o m -> m ()+addHandler h = do++  hid <- lensEvents . id' <<%= (+1)+  inputs <- getInputs h+  let update = forM_ inputs (^._3)++  -- Register handler+  lensEvents . handlers' . at hid ?= typeOf h++  -- Register inputs+  forM_ inputs $+    \(t, b, _) -> do+      lensEvents . listeners t %= ((hid, b):)++  -- Register output+  let oType = typeRep (Proxy :: Proxy o)+  lensEvents . emitters oType %= ((hid, OpaqueUpdater update):)++  -- Trigger update+  lensEvents . seen' .= [] >> update++-- | Build a dispatcher for a given type+buildDispatcher :: forall s i m. SIM s i m => m (i -> m ())+buildDispatcher = do+  let t = typeRep (Proxy :: Proxy i)+      toHandler (_, OpaqueBuilder b) = unsafeCoerce b+      runHandlers hs i = forM_ hs ($ i)+  fwds <- use $ lensEvents . listeners t+  runHandlers <$> forM fwds toHandler++-- | Get an event handler from the cache+getHandler :: forall s i m. SIM s i m => m (i -> m ())+getHandler = do+  let t = typeRep (Proxy :: Proxy i)+      f (OpaqueDispatcher h) = unsafeCoerce h+      n _ = pure ()+      l = lensEvents . dispatcher' . at t+  maybe n f <$> use l++-- | Update dispatchers from a given input type recursing upstream+updateDispatchers :: forall s i m. SIM s i m => i -> m ()+updateDispatchers i = do+  let t = typeOf i+  dispatch <- buildDispatcher :: m (i -> m ())+  lensEvents . dispatcher' . at t ?= OpaqueDispatcher dispatch+  -- Recurse+  es <- use $ lensEvents . emitters t+  forM_ es $+    \(hid, OpaqueUpdater u) -> do+      checkLoop hid >> unsafeCoerce u+  where+    -- Chances are this will not suffice+    checkLoop t = do+      seen <- lensEvents . seen' <<%= (t:)+      let e l = error $ "Cycle in events graph: " ++ show l+      maybe (pure ()) (\n -> e $ t : take (n+1) seen) $ elemIndex t seen++-- | Make a specification of an input closing over it's type+makeInput :: forall s i o m a. (SIM s i m, T a, T o)+          => (a -> i) -> EventHandler i o m -> [InputSpec m]+makeInput w f =+  let a = undefined :: a+      t = typeOf a+      h y = f y . w+      builder = h <$> getHandler+      r = (t, OpaqueBuilder builder, updateDispatchers a)+   in if t == typeOf () then [] else [r]++runEvent :: SIM s i m => i -> m ()+runEvent i = getHandler >>= ($ i)++--+-- | Complex events+--++data Complex a b c = C1 a | C2 b | C3 c+  deriving (Eq, Ord, Show)++type Complex2 a b = Complex a b ()+type Complex3 a b c = Complex a b c++instance (SM s m, T a, T b, T c) => EventInput s (Complex a b c) m where+  getInputs h = pure $ concat [w C1, w C2, w C3]+    where+      w :: T i => (i -> Complex a b c) -> [InputSpec m]+      w c = makeInput c h++--+-- | Lenses+--++instance HasEvents EventState where+  lensEvents = id++nonl :: Lens' (Maybe [a]) [a]+nonl afb s = f <$> afb (fromMaybe [] s)+  where f y = if null y then Nothing else Just y++listeners :: TypeRep -> Lens' (EventState) [(HandlerId, OpaqueBuilder)]+listeners t = listeners' . at t . nonl++emitters :: TypeRep -> Lens' (EventState) [(HandlerId, OpaqueUpdater)]+emitters t = emitters' . at t . nonl+++type TestM = StateT EventState IO+type TestHandler i o = EventHandler i o TestM++data A = A+data B = B+data C = C+data Done = Done++handler1 :: a -> ((o -> TestM ()) -> a -> i -> TestM a) -> TestM (TestHandler i o)+handler1 empty f = f' <$> liftIO (newMVar empty)+  where+    f' mvar y i = do+      a <- liftIO $ takeMVar mvar+      f y a i >>= liftIO . putMVar mvar++collector :: TestM (TestHandler (Complex2 C Done) ())+collector = handler1 0 f+  where+    f y a (C1 C) = pure $ a + 1+    f y a (C2 Done) = liftIO (print a) >> pure 0++makeTestHandler :: a -> b -> Int -> TestHandler a b+makeTestHandler a b i = f+  where f y a = replicateM_ i (y b)++testEvents :: IO ()+testEvents = do+  _ <- runStateT act emptyEventState+  pure ()+  where+    act :: StateT EventState IO ()+    act = do+      addHandler $ makeTestHandler A B 10+      addHandler $ makeTestHandler B C 10+      addHandler $ makeTestHandler C A 10+      addHandler =<< collector+      runEvent A+      runEvent Done+

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"