{-# LANGUAGE ExistentialQuantification #-}
module MVC.Updates (
Updatable(..)
, on
, listen
, runUpdatable
, updates
, module Control.Foldl
) where
import Control.Applicative (Applicative(pure, (<*>)), (<*), liftA2)
import Control.Category (id)
import Control.Concurrent.Async (withAsync)
import Control.Foldl (FoldM(..), Fold(..))
import qualified Control.Foldl as L
import Data.IORef (newIORef, readIORef, writeIORef)
import MVC
import Prelude hiding (id)
data Updatable a = forall e . Updatable (Managed (Controller e, FoldM IO e a))
instance Functor Updatable where
fmap :: forall a b. (a -> b) -> Updatable a -> Updatable b
fmap a -> b
f (Updatable Managed (Controller e, FoldM IO e a)
m) = Managed (Controller e, FoldM IO e b) -> Updatable b
forall a e. Managed (Controller e, FoldM IO e a) -> Updatable a
Updatable (((Controller e, FoldM IO e a) -> (Controller e, FoldM IO e b))
-> Managed (Controller e, FoldM IO e a)
-> Managed (Controller e, FoldM IO e b)
forall a b. (a -> b) -> Managed a -> Managed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FoldM IO e a -> FoldM IO e b)
-> (Controller e, FoldM IO e a) -> (Controller e, FoldM IO e b)
forall a b. (a -> b) -> (Controller e, a) -> (Controller e, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> FoldM IO e a -> FoldM IO e b
forall a b. (a -> b) -> FoldM IO e a -> FoldM IO e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) Managed (Controller e, FoldM IO e a)
m)
_Left :: Applicative f => (a -> f a) -> (Either a b -> f (Either a b))
_Left :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f a) -> Either a b -> f (Either a b)
_Left a -> f a
k Either a b
e = case Either a b
e of
Left a
a -> (a -> Either a b) -> f a -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left (a -> f a
k a
a)
Right b
b -> Either a b -> f (Either a b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either a b
forall a b. b -> Either a b
Right b
b)
_Right :: Applicative f => (b -> f b) -> (Either a b -> f (Either a b))
_Right :: forall (f :: * -> *) b a.
Applicative f =>
(b -> f b) -> Either a b -> f (Either a b)
_Right b -> f b
k Either a b
e = case Either a b
e of
Left a
a -> Either a b -> f (Either a b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a b
forall a b. a -> Either a b
Left a
a)
Right b
b -> (b -> Either a b) -> f b -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right (b -> f b
k b
b)
instance Applicative Updatable where
pure :: forall a. a -> Updatable a
pure a
a = Managed (Controller Any, FoldM IO Any a) -> Updatable a
forall a e. Managed (Controller e, FoldM IO e a) -> Updatable a
Updatable ((Controller Any, FoldM IO Any a)
-> Managed (Controller Any, FoldM IO Any a)
forall a. a -> Managed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FoldM IO Any a -> (Controller Any, FoldM IO Any a)
forall a. a -> (Controller Any, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> FoldM IO Any a
forall a. a -> FoldM IO Any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)))
Updatable Managed (Controller e, FoldM IO e (a -> b))
mL <*> :: forall a b. Updatable (a -> b) -> Updatable a -> Updatable b
<*> Updatable Managed (Controller e, FoldM IO e a)
mR = Managed (Controller (Either e e), FoldM IO (Either e e) b)
-> Updatable b
forall a e. Managed (Controller e, FoldM IO e a) -> Updatable a
Updatable (((Controller e, FoldM IO e (a -> b))
-> (Controller e, FoldM IO e a)
-> (Controller (Either e e), FoldM IO (Either e e) b))
-> Managed (Controller e, FoldM IO e (a -> b))
-> Managed (Controller e, FoldM IO e a)
-> Managed (Controller (Either e e), FoldM IO (Either e e) b)
forall a b c. (a -> b -> c) -> Managed a -> Managed b -> Managed c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Controller e, FoldM IO e (a -> b))
-> (Controller e, FoldM IO e a)
-> (Controller (Either e e), FoldM IO (Either e e) b)
forall {f :: * -> *} {a} {b} {m :: * -> *} {b} {a} {b} {b}.
(Semigroup (f (Either a b)), Monad m, Functor f) =>
(f a, FoldM m b (a -> b))
-> (f b, FoldM m b a) -> (f (Either a b), FoldM m (Either b b) b)
f Managed (Controller e, FoldM IO e (a -> b))
mL Managed (Controller e, FoldM IO e a)
mR)
where
f :: (f a, FoldM m b (a -> b))
-> (f b, FoldM m b a) -> (f (Either a b), FoldM m (Either b b) b)
f (f a
controllerL, FoldM m b (a -> b)
foldL) (f b
controllerR, FoldM m b a
foldR) = (f (Either a b)
controllerT, FoldM m (Either b b) b
foldT)
where
foldT :: FoldM m (Either b b) b
foldT = HandlerM m (Either b b) b
-> FoldM m b (a -> b) -> FoldM m (Either b b) (a -> b)
forall (m :: * -> *) a b r.
HandlerM m a b -> FoldM m b r -> FoldM m a r
L.handlesM (b -> Const (Dual (EndoM m x)) b)
-> Either b b -> Const (Dual (EndoM m x)) (Either b b)
HandlerM m (Either b b) b
forall (f :: * -> *) a b.
Applicative f =>
(a -> f a) -> Either a b -> f (Either a b)
_Left FoldM m b (a -> b)
foldL FoldM m (Either b b) (a -> b)
-> FoldM m (Either b b) a -> FoldM m (Either b b) b
forall a b.
FoldM m (Either b b) (a -> b)
-> FoldM m (Either b b) a -> FoldM m (Either b b) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HandlerM m (Either b b) b -> FoldM m b a -> FoldM m (Either b b) a
forall (m :: * -> *) a b r.
HandlerM m a b -> FoldM m b r -> FoldM m a r
L.handlesM (b -> Const (Dual (EndoM m x)) b)
-> Either b b -> Const (Dual (EndoM m x)) (Either b b)
HandlerM m (Either b b) b
forall (f :: * -> *) b a.
Applicative f =>
(b -> f b) -> Either a b -> f (Either a b)
_Right FoldM m b a
foldR
controllerT :: f (Either a b)
controllerT = (a -> Either a b) -> f a -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left f a
controllerL f (Either a b) -> f (Either a b) -> f (Either a b)
forall a. Semigroup a => a -> a -> a
<> (b -> Either a b) -> f b -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right f b
controllerR
on :: Fold e a -> Managed (Controller e) -> Updatable a
on :: forall e a. Fold e a -> Managed (Controller e) -> Updatable a
on Fold e a
fold Managed (Controller e)
m = Managed (Controller e, FoldM IO e a) -> Updatable a
forall a e. Managed (Controller e, FoldM IO e a) -> Updatable a
Updatable ((Controller e -> (Controller e, FoldM IO e a))
-> Managed (Controller e) -> Managed (Controller e, FoldM IO e a)
forall a b. (a -> b) -> Managed a -> Managed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Controller e
controller -> (Controller e
controller, Fold e a -> FoldM IO e a
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
L.generalize Fold e a
fold)) Managed (Controller e)
m)
{-# INLINABLE on #-}
listen :: (a -> IO ()) -> Updatable a -> Updatable a
listen :: forall a. (a -> IO ()) -> Updatable a -> Updatable a
listen a -> IO ()
handler (Updatable Managed (Controller e, FoldM IO e a)
m) = Managed (Controller e, FoldM IO e a) -> Updatable a
forall a e. Managed (Controller e, FoldM IO e a) -> Updatable a
Updatable (((Controller e, FoldM IO e a) -> (Controller e, FoldM IO e a))
-> Managed (Controller e, FoldM IO e a)
-> Managed (Controller e, FoldM IO e a)
forall a b. (a -> b) -> Managed a -> Managed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Controller e, FoldM IO e a) -> (Controller e, FoldM IO e a)
forall {a} {a}. (a, FoldM IO a a) -> (a, FoldM IO a a)
f Managed (Controller e, FoldM IO e a)
m)
where
f :: (a, FoldM IO a a) -> (a, FoldM IO a a)
f (a
controller, FoldM x -> a -> IO x
step IO x
begin x -> IO a
done) =
(a
controller, (x -> a -> IO x) -> IO x -> (x -> IO a) -> FoldM IO a a
forall (m :: * -> *) a b x.
(x -> a -> m x) -> m x -> (x -> m b) -> FoldM m a b
FoldM x -> a -> IO x
step' IO x
begin' x -> IO a
done)
where
begin' :: IO x
begin' = do
x
x <- IO x
begin
a
b <- x -> IO a
done x
x
a -> IO ()
handler a
b
x -> IO x
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return x
x
step' :: x -> a -> IO x
step' x
x a
a = do
x
x' <- x -> a -> IO x
step x
x a
a
a
b <- x -> IO a
done x
x'
a -> IO ()
handler a
b
x -> IO x
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return x
x'
{-# INLINABLE listen #-}
runUpdatable :: Updatable a -> IO ()
runUpdatable :: forall a. Updatable a -> IO ()
runUpdatable (Updatable Managed (Controller e, FoldM IO e a)
m) = () -> Model () e e -> Managed (View e, Controller e) -> IO ()
forall s a b.
s -> Model s a b -> Managed (View b, Controller a) -> IO s
runMVC () Model () e e
forall a. ModelM Identity () a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Managed (View e, Controller e) -> IO ())
-> Managed (View e, Controller e) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(Controller e
controller, FoldM x -> e -> IO x
step IO x
begin x -> IO a
done) <- Managed (Controller e, FoldM IO e a)
m
IORef x
ioref <- IO (IORef x) -> Managed (IORef x)
forall a. IO a -> Managed a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef x) -> Managed (IORef x))
-> IO (IORef x) -> Managed (IORef x)
forall a b. (a -> b) -> a -> b
$ do
x
x <- IO x
begin
a
_ <- x -> IO a
done x
x
x -> IO (IORef x)
forall a. a -> IO (IORef a)
newIORef x
x
let view :: View e
view = (e -> IO ()) -> View e
forall a. (a -> IO ()) -> View a
asSink ((e -> IO ()) -> View e) -> (e -> IO ()) -> View e
forall a b. (a -> b) -> a -> b
$ \e
e -> do
x
x <- IORef x -> IO x
forall a. IORef a -> IO a
readIORef IORef x
ioref
x
x' <- x -> e -> IO x
step x
x e
e
a
_ <- x -> IO a
done x
x'
IORef x -> x -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef x
ioref x
x'
(View e, Controller e) -> Managed (View e, Controller e)
forall a. a -> Managed a
forall (m :: * -> *) a. Monad m => a -> m a
return (View e
view, Controller e
controller)
{-# INLINABLE runUpdatable #-}
updates :: Buffer a -> Updatable a -> Managed (Controller a)
updates :: forall a. Buffer a -> Updatable a -> Managed (Controller a)
updates Buffer a
buffer (Updatable Managed (Controller e, FoldM IO e a)
m) = do
(Controller e
controller, FoldM x -> e -> IO x
step IO x
begin x -> IO a
done) <- Managed (Controller e, FoldM IO e a)
m
(forall r. (Controller a -> IO r) -> IO r)
-> Managed (Controller a)
forall (m :: * -> *) a.
MonadManaged m =>
(forall r. (a -> IO r) -> IO r) -> m a
managed ((forall r. (Controller a -> IO r) -> IO r)
-> Managed (Controller a))
-> (forall r. (Controller a -> IO r) -> IO r)
-> Managed (Controller a)
forall a b. (a -> b) -> a -> b
$ \Controller a -> IO r
k -> do
(Output a
o, Input a
i, STM ()
seal) <- Buffer a -> IO (Output a, Input a, STM ())
forall a. Buffer a -> IO (Output a, Input a, STM ())
spawn' Buffer a
buffer
IORef x
ioref <- IO (IORef x) -> IO (IORef x)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef x) -> IO (IORef x)) -> IO (IORef x) -> IO (IORef x)
forall a b. (a -> b) -> a -> b
$ do
x
x <- IO x
begin
a
a <- x -> IO a
done x
x
Bool
_ <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Output a -> a -> STM Bool
forall a. Output a -> a -> STM Bool
send Output a
o a
a
x -> IO (IORef x)
forall a. a -> IO (IORef a)
newIORef x
x
let view :: View e
view = (e -> IO ()) -> View e
forall a. (a -> IO ()) -> View a
asSink ((e -> IO ()) -> View e) -> (e -> IO ()) -> View e
forall a b. (a -> b) -> a -> b
$ \e
e -> do
x
x <- IORef x -> IO x
forall a. IORef a -> IO a
readIORef IORef x
ioref
x
x' <- x -> e -> IO x
step x
x e
e
a
a <- x -> IO a
done x
x'
Bool
_ <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Output a -> a -> STM Bool
forall a. Output a -> a -> STM Bool
send Output a
o a
a
IORef x -> x -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef x
ioref x
x'
let io :: IO ()
io = do
IO x
_ <- IO x
-> Model (IO x) e e -> Managed (View e, Controller e) -> IO (IO x)
forall s a b.
s -> Model s a b -> Managed (View b, Controller a) -> IO s
runMVC IO x
begin Model (IO x) e e
forall a. ModelM Identity (IO x) a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id ((View e, Controller e) -> Managed (View e, Controller e)
forall a. a -> Managed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View e
view, Controller e
controller))
STM () -> IO ()
forall a. STM a -> IO a
atomically STM ()
seal
IO () -> (Async () -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
io ((Async () -> IO r) -> IO r) -> (Async () -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> Controller a -> IO r
k (Input a -> Controller a
forall a. Input a -> Controller a
asInput Input a
i) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* STM () -> IO ()
forall a. STM a -> IO a
atomically STM ()
seal