Run.hs

module Ribosome.Menu.Run where

import Conduit (ConduitT, MonadResource, await, awaitForever, mapC, runConduit, yield, (.|))
import Control.Concurrent.STM.TMChan (TMChan, writeTMChan)
import Control.Exception.Lifted (bracket)
import Control.Lens (over, set, view)
import Data.Conduit.Combinators (iterM)
import qualified Data.Conduit.Combinators as Conduit (last)
import Data.Conduit.Lift (evalStateC)
import qualified Data.Text as Text

import Ribosome.Api.Window (closeWindow)
import Ribosome.Config.Setting (settingOr)
import qualified Ribosome.Config.Settings as Settings
import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)
import Ribosome.Data.Conduit (mergeSources)
import Ribosome.Data.Scratch (scratchWindow)
import Ribosome.Data.ScratchOptions (ScratchOptions)
import qualified Ribosome.Data.ScratchOptions as ScratchOptions (size, syntax)
import Ribosome.Data.WindowConfig (WindowConfig(WindowConfig))
import Ribosome.Log (showDebug)
import Ribosome.Menu.Data.Menu (Menu)
import qualified Ribosome.Menu.Data.Menu as Menu (maxItems)
import Ribosome.Menu.Data.MenuAction (MenuAction)
import qualified Ribosome.Menu.Data.MenuAction as MenuAction (MenuAction(..))
import Ribosome.Menu.Data.MenuConfig (MenuConfig(MenuConfig))
import qualified Ribosome.Menu.Data.MenuConfig as MenuConfig (prompt)
import Ribosome.Menu.Data.MenuConsumer (MenuConsumer(MenuConsumer))
import Ribosome.Menu.Data.MenuEvent (MenuEvent, QuitReason)
import qualified Ribosome.Menu.Data.MenuEvent as MenuEvent (MenuEvent(..))
import qualified Ribosome.Menu.Data.MenuEvent as QuitReason (QuitReason(..))
import Ribosome.Menu.Data.MenuItem (MenuItem)
import qualified Ribosome.Menu.Data.MenuItem as MenuItem (MenuItem(_text))
import Ribosome.Menu.Data.MenuRenderEvent (MenuRenderEvent)
import qualified Ribosome.Menu.Data.MenuRenderEvent as MenuRenderEvent (MenuRenderEvent(..))
import Ribosome.Menu.Data.MenuResult (MenuResult)
import qualified Ribosome.Menu.Data.MenuResult as MenuResult (MenuResult(..))
import Ribosome.Menu.Data.MenuUpdate (MenuUpdate(MenuUpdate))
import Ribosome.Menu.Nvim (menuSyntax, renderNvimMenu)
import Ribosome.Menu.Prompt.Data.Prompt (Prompt(Prompt))
import Ribosome.Menu.Prompt.Data.PromptConfig (PromptConfig)
import qualified Ribosome.Menu.Prompt.Data.PromptConfig as PromptConfig (render)
import Ribosome.Menu.Prompt.Data.PromptConsumed (PromptConsumed)
import qualified Ribosome.Menu.Prompt.Data.PromptConsumed as PromptConsumed (PromptConsumed(..))
import Ribosome.Menu.Prompt.Data.PromptConsumerUpdate (PromptConsumerUpdate(PromptConsumerUpdate))
import Ribosome.Menu.Prompt.Data.PromptEvent (PromptEvent)
import qualified Ribosome.Menu.Prompt.Data.PromptEvent as PromptEvent (PromptEvent(..))
import Ribosome.Menu.Prompt.Data.PromptRenderer (PromptRenderer(PromptRenderer))
import qualified Ribosome.Menu.Prompt.Data.PromptState as PromptState (PromptState(..))
import Ribosome.Menu.Prompt.Run (promptC)
import Ribosome.Msgpack.Decode (fromMsgpack)
import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))
import Ribosome.Msgpack.Error (DecodeError)
import Ribosome.Nvim.Api.Data (Window)
import Ribosome.Nvim.Api.IO (nvimWinGetConfig, vimCallFunction, vimGetWindows, windowSetOption)
import Ribosome.Scratch (showInScratch)

promptEvent ::
  PromptEvent ->
  Prompt ->
  PromptConsumed ->
  MenuEvent m a i
promptEvent _ (Prompt _ PromptState.Quit _) _ =
  MenuEvent.Quit QuitReason.Aborted
promptEvent (PromptEvent.Character a) prompt PromptConsumed.No =
  MenuEvent.Mapping a prompt
promptEvent (PromptEvent.Character _) prompt@(Prompt _ PromptState.Insert _) _ =
  MenuEvent.PromptChange prompt
promptEvent (PromptEvent.Character _) prompt PromptConsumed.Yes =
  MenuEvent.PromptChange prompt
promptEvent (PromptEvent.Set _) prompt _ =
  MenuEvent.PromptChange prompt
promptEvent PromptEvent.Init prompt _ =
  MenuEvent.Init prompt
promptEvent (PromptEvent.Unexpected code) _ _ =
  MenuEvent.Quit . QuitReason.PromptError $ "unexpected input character code: " <> show code
promptEvent PromptEvent.Interrupt _ _ =
  MenuEvent.Quit QuitReason.Aborted
promptEvent (PromptEvent.Error e) _ _ =
  MenuEvent.Quit (QuitReason.PromptError e)

menuEvent ::
  Either PromptConsumerUpdate [MenuItem i] ->
  MenuEvent m a i
menuEvent =
  either promptUpdate MenuEvent.NewItems
  where
    promptUpdate (PromptConsumerUpdate event prompt consumed) =
      promptEvent event prompt consumed

updateMenu ::
  MonadRibo m =>
  TMChan PromptEvent ->
  MenuConsumer m a i ->
  Either PromptConsumerUpdate [MenuItem i] ->
  ConduitT (Either PromptConsumerUpdate [MenuItem i]) (MenuRenderEvent m a i) (StateT (Menu i) m) ()
updateMenu backchannel (MenuConsumer consumer) input = do
  showDebug "menu update:" (MenuItem._text <$$> input)
  action <- lift . stateM $ lift . consumer . MenuUpdate (menuEvent input)
  showDebug "menu action:" action
  emit action
  where
    emit MenuAction.Continue =
      return ()
    emit (MenuAction.Execute thunk) =
      lift $ lift thunk
    emit (MenuAction.Render changed) =
      yield . MenuRenderEvent.Render changed =<< get
    emit (MenuAction.UpdatePrompt prompt) =
      atomically $ writeTMChan backchannel (PromptEvent.Set prompt)
    emit (MenuAction.Quit reason) =
      yield (MenuRenderEvent.Quit reason)

menuTerminator ::
  Monad m =>
  ConduitT (MenuRenderEvent m a i) (QuitReason m a) m ()
menuTerminator =
  traverse_ check =<< await
  where
    check (MenuRenderEvent.Quit reason) =
      yield reason
    check _ =
      menuTerminator

menuResult ::
  Monad m =>
  QuitReason m a ->
  m (MenuResult a)
menuResult (QuitReason.Return a) =
  return (MenuResult.Return a)
menuResult (QuitReason.Execute ma) =
  MenuResult.Return <$> ma
menuResult (QuitReason.PromptError err) =
  return (MenuResult.Error err)
menuResult QuitReason.NoOutput =
  return MenuResult.NoOutput
menuResult QuitReason.Aborted =
  return MenuResult.Aborted

menuC ::
  MonadRibo m =>
  MonadResource m =>
  MonadBaseControl IO m =>
  MenuConfig m a i ->
  ConduitT () (QuitReason m a) m ()
menuC (MenuConfig items handle render promptConfig maxItems) = do
  (backchannel, source) <- lift $ promptC promptConfig
  mergeSources 64 [source .| mapC Left, items .| mapC Right] .| consumer backchannel
  where
    consumer backchannel =
      evalStateC initial (menuHandler backchannel) .| iterM render .| menuTerminator
    initial =
      set Menu.maxItems maxItems def
    menuHandler backchannel =
      awaitForever . updateMenu backchannel $ handle

isFloat ::
  NvimE e m =>
  Window ->
  m Bool
isFloat =
  fmap (check . fromMsgpack . toMsgpack) . nvimWinGetConfig
  where
    check (Right (WindowConfig relative _ _)) =
      not (Text.null relative)
    check _ =
      False

closeFloats ::
  NvimE e m =>
  m ()
closeFloats = do
  traverse_ closeWindow =<< filterM isFloat =<< vimGetWindows

runMenu ::
  MonadRibo m =>
  MonadResource m =>
  MonadBaseControl IO m =>
  MenuConfig m a i ->
  m (MenuResult a)
runMenu config =
  bracketPrompt (view (MenuConfig.prompt . PromptConfig.render) config)
  where
    bracketPrompt (PromptRenderer acquire release _) =
      bracket acquire release (const runForResult)
    runForResult =
      menuResult =<< quitReason <$> run
    run =
      runConduit (menuC config .| Conduit.last)
    quitReason =
      fromMaybe QuitReason.NoOutput

nvimMenu ::
  NvimE e m =>
  MonadRibo m =>
  MonadResource m =>
  MonadBaseControl IO m =>
  MonadDeepError e DecodeError m =>
  ScratchOptions ->
  ConduitT () [MenuItem i] m () ->
  (MenuUpdate m a i -> m (MenuAction m a, Menu i)) ->
  PromptConfig m ->
  Maybe Int ->
  m (MenuResult a)
nvimMenu options items handle promptConfig maxItems = do
  _ :: Int <- vimCallFunction "inputsave" []
  whenM (settingOr True Settings.menuCloseFloats) closeFloats
  run =<< showInScratch @[] [] (withSyntax (ensureSize options))
  where
    run scratch = do
      windowSetOption (scratchWindow scratch) "cursorline" (toMsgpack True)
      runMenu $ MenuConfig items (MenuConsumer handle) (render scratch) promptConfig maxItems
    render =
      renderNvimMenu options
    ensureSize =
      over ScratchOptions.size (<|> Just 1)
    withSyntax =
      over ScratchOptions.syntax (++ [menuSyntax])

strictNvimMenu ::
  NvimE e m =>
  MonadRibo m =>
  MonadResource m =>
  MonadBaseControl IO m =>
  MonadDeepError e DecodeError m =>
  ScratchOptions ->
  [MenuItem i] ->
  (MenuUpdate m a i -> m (MenuAction m a, Menu i)) ->
  PromptConfig m ->
  Maybe Int ->
  m (MenuResult a)
strictNvimMenu options items =
  nvimMenu (ensureSize options) (yield items)
  where
    ensureSize =
      over ScratchOptions.size (<|> Just (length items))