{-# 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
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 ())
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
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)
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)
lensEvents . handlers' . at hid ?= typeOf h
forM_ inputs $
\(t, b, _) -> do
lensEvents . listeners t %= ((hid, b):)
let oType = typeRep (Proxy :: Proxy o)
lensEvents . emitters oType %= ((hid, OpaqueUpdater update):)
lensEvents . seen' .= [] >> update
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
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
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
es <- use $ lensEvents . emitters t
forM_ es $
\(hid, OpaqueUpdater u) -> do
checkLoop hid >> unsafeCoerce u
where
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
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)
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
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