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
{ initialize :: forall m. MonadIO m => m s
, liftEvent :: Vty.Event -> e
, handleEvent :: forall m. MonadIO m => e -> Environment -> s -> Next (VgrepT s m Redraw)
, render :: forall m. Monad m => VgrepT s m Vty.Picture
}
runApp_ :: App e s -> Config -> Producer e IO () -> IO ()
runApp_ app conf externalEvents = void (runApp app conf externalEvents)
runApp :: App e s -> Config -> Producer e IO () -> IO s
runApp app conf externalEvents = withSpawn $ \(evSink, evSource) -> do
initialViewport <- viewportHack
let userEventSink = contramap (User,) evSink
systemEventSink = contramap (System,) evSink
externalEventThread <- (async . runEffect) (externalEvents >-> toOutput systemEventSink)
initialState <- initialize app
(_, finalState) <- runVgrepT (appEventLoop app evSource userEventSink)
initialState
(Env conf initialViewport)
cancel externalEventThread
pure finalState
contramap :: (b -> a) -> Output a -> Output b
contramap f (Output a) = Output (a . f)
appEventLoop :: forall e s. App e s -> Input e -> Output e -> VgrepT s IO ()
appEventLoop app evSource evSink = eventLoop
where
eventLoop :: VgrepT s IO ()
eventLoop = startEventLoop >>= suspendAndResume
startEventLoop :: VgrepT s IO Interrupt
startEventLoop = withVgrepVty $ \vty -> withEvThread vtyEventSink vty $ do
refresh vty
runEffect ((fromInput evSource >> pure Halt) >-> eventHandler vty)
suspendAndResume :: Interrupt -> VgrepT s IO ()
suspendAndResume = \case
Halt -> pure ()
Suspend outsideAction -> do env <- ask
outsideAction env
eventLoop
eventHandler :: Vty -> Consumer e (VgrepT s IO) Interrupt
eventHandler vty = go
where
go = do
event <- await
currentState <- get
env <- ask
case handleAppEvent event env currentState of
Skip -> go
Continue action -> lift action >>= \case
Unchanged -> go
Redraw -> lift (refresh vty) >> go
Interrupt int -> pure int
refresh :: Vty -> VgrepT s IO ()
refresh vty = render app >>= lift . Vty.update vty
vtyEventSink = P.map (liftEvent app) >-> toOutput evSink
handleAppEvent = handleEvent app