content: {-# 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
      { initialize  :: forall m. MonadIO m => m s
      -- ^ Creates the initial state for the app.
  
      , liftEvent   :: Vty.Event -> e
      -- ^ How to convert an external 'Vty.Event' to the App's event
  
      , 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.
      -- @
  
      , 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 conf externalEvents = void (runApp app conf 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 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
  
  -- | Monomorphic version of 'Data.Functor.Contravariant.contramap', to
  -- avoid having to update pipes-concurrency.
  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
  