{-# 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


-- | The 'App' type is parameterized over the type 'e' of events it handles
-- and the type 's' of its state.
data App e s = App
    { App e s -> forall (m :: * -> *). MonadIO m => m s
initialize  :: forall m. MonadIO m => m s
    -- ^ Creates the initial state for the app.

    , App e s -> Event -> e
liftEvent   :: Vty.Event -> e
    -- ^ How to convert an external 'Vty.Event' to the App's event

    , 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)
    -- ^ Handles an event, possibly modifying the App's state.
    --
    -- @
    -- handleEvent e s = case e of
    --     'Vty.EvKey' 'Vty.KEnter' [] -> 'Continue' ('pure' 'Unchanged')
    --     -- Handles the @Enter@ key, but does nothing.
    --
    --     'Vty.EvKey' 'Vty.KUp' [] -> 'Continue' ('pure' 'Redraw')
    --     -- Handles the @Up@ key and triggers a redraw.
    --
    --     _otherwise          -> 'Skip'
    --     -- Does not handle the event, so other handlers may be invoked.
    -- @

    , App e s -> forall (m :: * -> *). Monad m => VgrepT s m Picture
render      :: forall m. Monad m => VgrepT s m Vty.Picture
    -- ^ Creates a 'Vty.Picture' to be displayed. May modify the App's
    -- state (e. g. for resizing).
    }


-- | Like 'runApp', but does not return the final state.
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)

-- | Runs runs the event loop until an @'Interrupt' 'Halt'@ is encountered.
-- Events handled with @'Interrupt' ('Suspend' action)@ will shut down
-- 'Vty.Vty', run the action (e. g. invoking an external editor), and start
-- 'Vty.Vty' again.
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

-- | Monomorphic version of 'Data.Functor.Contravariant.contramap', to
-- avoid having to update pipes-concurrency.
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