{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Vgrep.App
( App(..)
, runApp, runApp_
) where
import Control.Concurrent.Async
import Graphics.Vty (Vty)
import qualified Graphics.Vty as Vty
import Pipes
import Pipes.Concurrent.PQueue
import Pipes.Prelude as P
import Vgrep.App.Internal
import Vgrep.Environment
import Vgrep.Event
import Vgrep.Type
data App e s = App
{ App e s -> forall (m :: * -> *). MonadIO m => m s
initialize :: forall m. MonadIO m => m s
, App e s -> Event -> e
liftEvent :: Vty.Event -> e
, App e s
-> forall (m :: * -> *).
MonadIO m =>
e -> Environment -> s -> Next (VgrepT s m Redraw)
handleEvent :: forall m. MonadIO m => e -> Environment -> s -> Next (VgrepT s m Redraw)
, App e s -> forall (m :: * -> *). Monad m => VgrepT s m Picture
render :: forall m. Monad m => VgrepT s m Vty.Picture
}
runApp_ :: App e s -> Config -> Producer e IO () -> IO ()
runApp_ :: App e s -> Config -> Producer e IO () -> IO ()
runApp_ App e s
app Config
conf Producer e IO ()
externalEvents = IO s -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App e s -> Config -> Producer e IO () -> IO s
forall e s. App e s -> Config -> Producer e IO () -> IO s
runApp App e s
app Config
conf Producer e IO ()
externalEvents)
runApp :: App e s -> Config -> Producer e IO () -> IO s
runApp :: App e s -> Config -> Producer e IO () -> IO s
runApp App e s
app Config
conf Producer e IO ()
externalEvents = ((Output (EventPriority, e), Input e) -> IO s) -> IO s
forall p a r. Ord p => ((Output (p, a), Input a) -> IO r) -> IO r
withSpawn (((Output (EventPriority, e), Input e) -> IO s) -> IO s)
-> ((Output (EventPriority, e), Input e) -> IO s) -> IO s
forall a b. (a -> b) -> a -> b
$ \(Output (EventPriority, e)
evSink, Input e
evSource) -> do
Viewport
initialViewport <- IO Viewport
viewportHack
let userEventSink :: Output e
userEventSink = (e -> (EventPriority, e)) -> Output (EventPriority, e) -> Output e
forall b a. (b -> a) -> Output a -> Output b
contramap (EventPriority
User,) Output (EventPriority, e)
evSink
systemEventSink :: Output e
systemEventSink = (e -> (EventPriority, e)) -> Output (EventPriority, e) -> Output e
forall b a. (b -> a) -> Output a -> Output b
contramap (EventPriority
System,) Output (EventPriority, e)
evSink
Async ()
externalEventThread <- (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ()))
-> (Effect IO () -> IO ()) -> Effect IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect IO () -> IO ()
forall (m :: * -> *) r. Monad m => Effect m r -> m r
runEffect) (Producer e IO ()
externalEvents Producer e IO () -> Proxy () e () X IO () -> Effect IO ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Output e -> Consumer' e IO ()
forall (m :: * -> *) a. MonadIO m => Output a -> Consumer' a m ()
toOutput Output e
systemEventSink)
s
initialState <- App e s -> forall (m :: * -> *). MonadIO m => m s
forall e s. App e s -> forall (m :: * -> *). MonadIO m => m s
initialize App e s
app
(()
_, s
finalState) <- VgrepT s IO () -> s -> Environment -> IO ((), s)
forall (m :: * -> *) s a.
Monad m =>
VgrepT s m a -> s -> Environment -> m (a, s)
runVgrepT (App e s -> Input e -> Output e -> VgrepT s IO ()
forall e s. App e s -> Input e -> Output e -> VgrepT s IO ()
appEventLoop App e s
app Input e
evSource Output e
userEventSink)
s
initialState
(Config -> Viewport -> Environment
Env Config
conf Viewport
initialViewport)
Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
externalEventThread
s -> IO s
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
finalState
contramap :: (b -> a) -> Output a -> Output b
contramap :: (b -> a) -> Output a -> Output b
contramap b -> a
f (Output a -> STM Bool
a) = (b -> STM Bool) -> Output b
forall a. (a -> STM Bool) -> Output a
Output (a -> STM Bool
a (a -> STM Bool) -> (b -> a) -> b -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f)
appEventLoop :: forall e s. App e s -> Input e -> Output e -> VgrepT s IO ()
appEventLoop :: App e s -> Input e -> Output e -> VgrepT s IO ()
appEventLoop App e s
app Input e
evSource Output e
evSink = VgrepT s IO ()
eventLoop
where
eventLoop :: VgrepT s IO ()
eventLoop :: VgrepT s IO ()
eventLoop = VgrepT s IO Interrupt
startEventLoop VgrepT s IO Interrupt
-> (Interrupt -> VgrepT s IO ()) -> VgrepT s IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Interrupt -> VgrepT s IO ()
suspendAndResume
startEventLoop :: VgrepT s IO Interrupt
startEventLoop :: VgrepT s IO Interrupt
startEventLoop = (Vty -> VgrepT s IO Interrupt) -> VgrepT s IO Interrupt
forall s a. (Vty -> VgrepT s IO a) -> VgrepT s IO a
withVgrepVty ((Vty -> VgrepT s IO Interrupt) -> VgrepT s IO Interrupt)
-> (Vty -> VgrepT s IO Interrupt) -> VgrepT s IO Interrupt
forall a b. (a -> b) -> a -> b
$ \Vty
vty -> Consumer Event IO ()
-> Vty -> VgrepT s IO Interrupt -> VgrepT s IO Interrupt
forall s a.
Consumer Event IO () -> Vty -> VgrepT s IO a -> VgrepT s IO a
withEvThread Consumer Event IO ()
forall c' c. Proxy () Event c' c IO ()
vtyEventSink Vty
vty (VgrepT s IO Interrupt -> VgrepT s IO Interrupt)
-> VgrepT s IO Interrupt -> VgrepT s IO Interrupt
forall a b. (a -> b) -> a -> b
$ do
Vty -> VgrepT s IO ()
refresh Vty
vty
Effect (VgrepT s IO) Interrupt -> VgrepT s IO Interrupt
forall (m :: * -> *) r. Monad m => Effect m r -> m r
runEffect ((Input e -> Producer' e (VgrepT s IO) ()
forall (m :: * -> *) a. MonadIO m => Input a -> Producer' a m ()
fromInput Input e
evSource Proxy X () () e (VgrepT s IO) ()
-> Proxy X () () e (VgrepT s IO) Interrupt
-> Proxy X () () e (VgrepT s IO) Interrupt
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interrupt -> Proxy X () () e (VgrepT s IO) Interrupt
forall (f :: * -> *) a. Applicative f => a -> f a
pure Interrupt
Halt) Proxy X () () e (VgrepT s IO) Interrupt
-> Proxy () e () X (VgrepT s IO) Interrupt
-> Effect (VgrepT s IO) Interrupt
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Vty -> Proxy () e () X (VgrepT s IO) Interrupt
eventHandler Vty
vty)
suspendAndResume :: Interrupt -> VgrepT s IO ()
suspendAndResume :: Interrupt -> VgrepT s IO ()
suspendAndResume = \case
Interrupt
Halt -> () -> VgrepT s IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Suspend forall (m :: * -> *). MonadIO m => Environment -> m ()
outsideAction -> do Environment
env <- VgrepT s IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
Environment -> VgrepT s IO ()
forall (m :: * -> *). MonadIO m => Environment -> m ()
outsideAction Environment
env
VgrepT s IO ()
eventLoop
eventHandler :: Vty -> Consumer e (VgrepT s IO) Interrupt
eventHandler :: Vty -> Proxy () e () X (VgrepT s IO) Interrupt
eventHandler Vty
vty = Proxy () e () X (VgrepT s IO) Interrupt
forall y' y. Proxy () e y' y (VgrepT s IO) Interrupt
go
where
go :: Proxy () e y' y (VgrepT s IO) Interrupt
go = do
e
event <- Proxy () e y' y (VgrepT s IO) e
forall (m :: * -> *) a. Functor m => Consumer' a m a
await
s
currentState <- Proxy () e y' y (VgrepT s IO) s
forall s (m :: * -> *). MonadState s m => m s
get
Environment
env <- Proxy () e y' y (VgrepT s IO) Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
case e -> Environment -> s -> Next (VgrepT s IO Redraw)
handleAppEvent e
event Environment
env s
currentState of
Next (VgrepT s IO Redraw)
Skip -> Proxy () e y' y (VgrepT s IO) Interrupt
go
Continue VgrepT s IO Redraw
action -> VgrepT s IO Redraw -> Proxy () e y' y (VgrepT s IO) Redraw
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift VgrepT s IO Redraw
action Proxy () e y' y (VgrepT s IO) Redraw
-> (Redraw -> Proxy () e y' y (VgrepT s IO) Interrupt)
-> Proxy () e y' y (VgrepT s IO) Interrupt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Redraw
Unchanged -> Proxy () e y' y (VgrepT s IO) Interrupt
go
Redraw
Redraw -> VgrepT s IO () -> Proxy () e y' y (VgrepT s IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Vty -> VgrepT s IO ()
refresh Vty
vty) Proxy () e y' y (VgrepT s IO) ()
-> Proxy () e y' y (VgrepT s IO) Interrupt
-> Proxy () e y' y (VgrepT s IO) Interrupt
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Proxy () e y' y (VgrepT s IO) Interrupt
go
Interrupt Interrupt
int -> Interrupt -> Proxy () e y' y (VgrepT s IO) Interrupt
forall (f :: * -> *) a. Applicative f => a -> f a
pure Interrupt
int
refresh :: Vty -> VgrepT s IO ()
refresh :: Vty -> VgrepT s IO ()
refresh Vty
vty = App e s -> forall (m :: * -> *). Monad m => VgrepT s m Picture
forall e s.
App e s -> forall (m :: * -> *). Monad m => VgrepT s m Picture
render App e s
app VgrepT s IO Picture
-> (Picture -> VgrepT s IO ()) -> VgrepT s IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> VgrepT s IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> VgrepT s IO ())
-> (Picture -> IO ()) -> Picture -> VgrepT s IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vty -> Picture -> IO ()
Vty.update Vty
vty
vtyEventSink :: Proxy () Event c' c IO ()
vtyEventSink = (Event -> e) -> Pipe Event e IO ()
forall (m :: * -> *) a b r. Functor m => (a -> b) -> Pipe a b m r
P.map (App e s -> Event -> e
forall e s. App e s -> Event -> e
liftEvent App e s
app) Pipe Event e IO ()
-> Proxy () e c' c IO () -> Proxy () Event c' c IO ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Output e -> Consumer' e IO ()
forall (m :: * -> *) a. MonadIO m => Output a -> Consumer' a m ()
toOutput Output e
evSink
handleAppEvent :: e -> Environment -> s -> Next (VgrepT s IO Redraw)
handleAppEvent = App e s
-> forall (m :: * -> *).
MonadIO m =>
e -> Environment -> s -> Next (VgrepT s m Redraw)
forall e s.
App e s
-> forall (m :: * -> *).
MonadIO m =>
e -> Environment -> s -> Next (VgrepT s m Redraw)
handleEvent App e s
app