module Ribosome.Menu.Prompt.Nvim where

import Conduit (ConduitT, yield)
import Control.Exception.Lifted (bracket_)
import qualified Data.Text as Text (singleton, splitAt, uncons)

import Ribosome.Api.Atomic (atomic)
import Ribosome.Api.Function (defineFunction)
import Ribosome.Api.Variable (setVar)
import Ribosome.Api.Window (redraw)
import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)
import Ribosome.Data.Text (escapeQuotes)
import Ribosome.Menu.Prompt.Data.Codes (decodeInputChar, decodeInputNum)
import Ribosome.Menu.Prompt.Data.InputEvent (InputEvent)
import qualified Ribosome.Menu.Prompt.Data.InputEvent as InputEvent (InputEvent(..))
import Ribosome.Menu.Prompt.Data.Prompt (Prompt(Prompt))
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 Ribosome.Msgpack.Encode (toMsgpack)
import Ribosome.Msgpack.Error (DecodeError)
import qualified Ribosome.Nvim.Api.Data as ApiData (vimCommand)
import Ribosome.Nvim.Api.IO (vimCallFunction, vimCommand, vimCommandOutput, vimGetOption, vimSetOption)
import Ribosome.Nvim.Api.RpcCall (RpcError, syncRpcCall)
import Ribosome.System.Time (sleep)

quitChar :: Char
quitChar :: Char
quitChar =
  Char
'†'

quitCharOrd :: Int
quitCharOrd :: Int
quitCharOrd =
  Char -> Int
ord Char
quitChar

getChar ::
  NvimE e m =>
  MonadBaseControl IO m =>
  m InputEvent
getChar :: m InputEvent
getChar =
  InputEvent -> m InputEvent -> m InputEvent
forall e' e (m :: * -> *) a.
MonadDeepError e e' m =>
a -> m a -> m a
catchAs @RpcError InputEvent
InputEvent.Interrupt m InputEvent
request
  where
    request :: m InputEvent
request =
      m Bool -> m InputEvent -> m InputEvent -> m InputEvent
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
peek m InputEvent
consume (InputEvent -> m InputEvent
forall (m :: * -> *) a. Monad m => a -> m a
return InputEvent
InputEvent.NoInput)
    peek :: m Bool
peek =
      (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int)) (Int -> Bool) -> m Int -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> m Int
forall (m :: * -> *) e a a.
(Nvim m, MonadError e m, DeepPrisms e RpcError, MsgpackDecode a,
 MsgpackEncode a) =>
a -> m a
getchar Bool
True
    consume :: m InputEvent
consume =
      Either Int Text -> m InputEvent
forall (m :: * -> *).
MonadBaseControl IO m =>
Either Int Text -> m InputEvent
event (Either Int Text -> m InputEvent)
-> m (Either Int Text) -> m InputEvent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> m (Either Int Text)
forall (m :: * -> *) e a a.
(Nvim m, MonadError e m, DeepPrisms e RpcError, MsgpackDecode a,
 MsgpackEncode a) =>
a -> m a
getchar Bool
False
    getchar :: a -> m a
getchar a
peek' =
      Text -> [Object] -> m a
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"getchar" [a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack a
peek']
    event :: Either Int Text -> m InputEvent
event (Right Text
c) =
      InputEvent -> m InputEvent
forall (m :: * -> *) a. Monad m => a -> m a
return (InputEvent -> m InputEvent) -> InputEvent -> m InputEvent
forall a b. (a -> b) -> a -> b
$ Text -> InputEvent
InputEvent.Character (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
c (Text -> Maybe Text
decodeInputChar Text
c))
    event (Left Int
0) =
      InputEvent -> m InputEvent
forall (m :: * -> *) a. Monad m => a -> m a
return InputEvent
InputEvent.NoInput
    event (Left Int
num) | Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
quitCharOrd =
      InputEvent -> m InputEvent
forall (m :: * -> *) a. Monad m => a -> m a
return InputEvent
InputEvent.Interrupt
    event (Left Int
num) =
      InputEvent -> (Text -> InputEvent) -> Maybe Text -> InputEvent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> InputEvent
InputEvent.Unexpected Int
num) Text -> InputEvent
InputEvent.Character (Maybe Text -> InputEvent) -> m (Maybe Text) -> m InputEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (Maybe Text)
forall (m :: * -> *).
MonadBaseControl IO m =>
Int -> m (Maybe Text)
decodeInputNum Int
num

getCharC ::
  NvimE e m =>
  MonadRibo m =>
  MonadBaseControl IO m =>
  Double ->
  ConduitT () PromptEvent m ()
getCharC :: Double -> ConduitT () PromptEvent m ()
getCharC Double
interval =
  ConduitT () PromptEvent m ()
recurse
  where
    recurse :: ConduitT () PromptEvent m ()
recurse =
      InputEvent -> ConduitT () PromptEvent m ()
translate (InputEvent -> ConduitT () PromptEvent m ())
-> ConduitT () PromptEvent m InputEvent
-> ConduitT () PromptEvent m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m InputEvent -> ConduitT () PromptEvent m InputEvent
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m InputEvent
forall e (m :: * -> *).
(NvimE e m, MonadBaseControl IO m) =>
m InputEvent
getChar
    translate :: InputEvent -> ConduitT () PromptEvent m ()
translate (InputEvent.Character Text
a) =
      PromptEvent -> ConduitT () PromptEvent m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> PromptEvent
PromptEvent.Character Text
a) ConduitT () PromptEvent m ()
-> ConduitT () PromptEvent m () -> ConduitT () PromptEvent m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ConduitT () PromptEvent m ()
recurse
    translate InputEvent
InputEvent.Interrupt =
      PromptEvent -> ConduitT () PromptEvent m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield PromptEvent
PromptEvent.Interrupt
    translate (InputEvent.Error Text
e) =
      PromptEvent -> ConduitT () PromptEvent m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> PromptEvent
PromptEvent.Error Text
e)
    translate InputEvent
InputEvent.NoInput =
      Double -> ConduitT () PromptEvent m ()
forall (m :: * -> *). MonadIO m => Double -> m ()
sleep Double
interval ConduitT () PromptEvent m ()
-> ConduitT () PromptEvent m () -> ConduitT () PromptEvent m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ConduitT () PromptEvent m ()
recurse
    translate (InputEvent.Unexpected Int
_) =
      ConduitT () PromptEvent m ()
recurse

promptFragment :: Text -> Text -> [Text]
promptFragment :: Text -> Text -> [Text]
promptFragment Text
hl Text
text =
  [Text
"echohl " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hl, Text
"echon '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeQuotes Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"]

nvimRenderPrompt ::
  Monad m =>
  NvimE e m =>
  MonadDeepError e DecodeError m =>
  Prompt ->
  m ()
nvimRenderPrompt :: Prompt -> m ()
nvimRenderPrompt (Prompt Int
cursor PromptState
_ Text
text) =
  m [Object] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [Object] -> m ()) -> m [Object] -> m ()
forall a b. (a -> b) -> a -> b
$ [RpcCall] -> m [Object]
forall e (m :: * -> *).
(MonadDeepError e DecodeError m, NvimE e m) =>
[RpcCall] -> m [Object]
atomic [RpcCall]
calls
  where
    calls :: [RpcCall]
calls = SyncRpcCall -> RpcCall
syncRpcCall (SyncRpcCall -> RpcCall)
-> (Text -> SyncRpcCall) -> Text -> RpcCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SyncRpcCall
ApiData.vimCommand (Text -> RpcCall) -> [Text] -> [RpcCall]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text
"silent! redraw!" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ([(Text, Text)]
fragments [(Text, Text)] -> ((Text, Text) -> [Text]) -> [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Text -> [Text]) -> (Text, Text) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> [Text]
promptFragment))
    fragments :: [(Text, Text)]
fragments =
      [
        (Text
"RibosomePromptSign", Text
sign),
        (Text
"None", Text
pre),
        (Text
"RibosomePromptCaret", Char -> Text
Text.singleton Char
cursorChar),
        (Text
"None", Text
post)
        ]
    (Text
pre, Text
rest) =
      Int -> Text -> (Text, Text)
Text.splitAt Int
cursor Text
text
    (Char
cursorChar, Text
post) =
      (Char, Text) -> Maybe (Char, Text) -> (Char, Text)
forall a. a -> Maybe a -> a
fromMaybe (Char
' ', Text
"") (Text -> Maybe (Char, Text)
Text.uncons Text
rest)
    sign :: Text
sign =
      Text
"% "

loopFunctionName :: Text
loopFunctionName :: Text
loopFunctionName =
  Text
"RibosomeMenuLoop"

loopVarName :: Text
loopVarName :: Text
loopVarName =
  Text
"ribosome_menu_looping"

defineLoopFunction ::
  NvimE e m =>
  m ()
defineLoopFunction :: m ()
defineLoopFunction =
  Text -> [Text] -> [Text] -> m ()
forall e (m :: * -> *).
NvimE e m =>
Text -> [Text] -> [Text] -> m ()
defineFunction Text
loopFunctionName [] [Text]
lns
  where
    lns :: [Text]
lns =
      [
        Item [Text]
"echo ''",
        Text
"while g:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loopVarName,
        Item [Text]
"try",
        Item [Text]
"sleep 5m",
        Item [Text]
"catch /^Vim:Interrupt$/",
        Text
"silent! call feedkeys('" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
quitChar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"')",
        Item [Text]
"endtry",
        Item [Text]
"endwhile"
        ]

startLoop ::
  NvimE e m =>
  m ()
startLoop :: m ()
startLoop = do
  m ()
forall e (m :: * -> *). NvimE e m => m ()
defineLoopFunction
  Text -> Bool -> m ()
forall e (m :: * -> *) a.
(NvimE e m, MsgpackEncode a) =>
Text -> a -> m ()
setVar Text
loopVarName Bool
True
  Text -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> m ()
vimCommand (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"call feedkeys(\":call " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loopFunctionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"()\\<cr>\")"

-- FIXME need to wait for the loop to stop before deleting the function
killLoop ::
  NvimE e m =>
  m ()
killLoop :: m ()
killLoop = do
  Text -> Bool -> m ()
forall e (m :: * -> *) a.
(NvimE e m, MsgpackEncode a) =>
Text -> a -> m ()
setVar Text
loopVarName Bool
False
  forall e' e (m :: * -> *). MonadDeepError e e' m => m () -> m ()
forall e (m :: * -> *). MonadDeepError e RpcError m => m () -> m ()
ignoreError @RpcError (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> m ()
vimCommand (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"delfunction! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loopFunctionName

promptBlocker ::
  NvimE e m =>
  MonadBaseControl IO m =>
  m a ->
  m a
promptBlocker :: m a -> m a
promptBlocker =
  m () -> m () -> m a -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_ m ()
forall e (m :: * -> *). NvimE e m => m ()
startLoop m ()
forall e (m :: * -> *). NvimE e m => m ()
killLoop

newtype NvimPromptResources =
  NvimPromptResources {
    NvimPromptResources -> Text
_guicursor :: Text
  }
  deriving (NvimPromptResources -> NvimPromptResources -> Bool
(NvimPromptResources -> NvimPromptResources -> Bool)
-> (NvimPromptResources -> NvimPromptResources -> Bool)
-> Eq NvimPromptResources
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NvimPromptResources -> NvimPromptResources -> Bool
$c/= :: NvimPromptResources -> NvimPromptResources -> Bool
== :: NvimPromptResources -> NvimPromptResources -> Bool
$c== :: NvimPromptResources -> NvimPromptResources -> Bool
Eq, Int -> NvimPromptResources -> ShowS
[NvimPromptResources] -> ShowS
NvimPromptResources -> String
(Int -> NvimPromptResources -> ShowS)
-> (NvimPromptResources -> String)
-> ([NvimPromptResources] -> ShowS)
-> Show NvimPromptResources
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NvimPromptResources] -> ShowS
$cshowList :: [NvimPromptResources] -> ShowS
show :: NvimPromptResources -> String
$cshow :: NvimPromptResources -> String
showsPrec :: Int -> NvimPromptResources -> ShowS
$cshowsPrec :: Int -> NvimPromptResources -> ShowS
Show)

nvimAcquire ::
  NvimE e m =>
  m NvimPromptResources
nvimAcquire :: m NvimPromptResources
nvimAcquire = do
  Bool
highlightSet <- Bool -> m Bool -> m Bool
forall e' e (m :: * -> *) a.
MonadDeepError e e' m =>
a -> m a -> m a
catchAs @RpcError Bool
False (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool
True Bool -> m Text -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> m Text
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> m Text
vimCommandOutput Text
"highlight RibosomePromptCaret"
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
highlightSet (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> m ()
vimCommand Text
"highlight link RibosomePromptCaret TermCursor"
  NvimPromptResources
res <- Text -> NvimPromptResources
NvimPromptResources (Text -> NvimPromptResources) -> m Text -> m NvimPromptResources
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m Text
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> m a
vimGetOption Text
"guicursor"
  Text -> Object -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> Object -> m ()
vimSetOption Text
"guicursor" (Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Text
"a:hor20" :: Text))
  () <- Text -> [Object] -> m ()
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"inputsave" []
  m ()
forall e (m :: * -> *). NvimE e m => m ()
startLoop
  return NvimPromptResources
res

nvimRelease ::
  NvimE e m =>
  NvimPromptResources ->
  m ()
nvimRelease :: NvimPromptResources -> m ()
nvimRelease (NvimPromptResources Text
gc) = do
  Text -> Object -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> Object -> m ()
vimSetOption Text
"guicursor" (Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack Text
gc)
  m ()
forall e (m :: * -> *). NvimE e m => m ()
redraw
  Text -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Text -> m ()
vimCommand Text
"echon ''"
  () <- Text -> [Object] -> m ()
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"inputrestore" []
  m ()
forall e (m :: * -> *). NvimE e m => m ()
killLoop

nvimPromptRenderer ::
  NvimE e m =>
  MonadDeepError e DecodeError m =>
  PromptRenderer m
nvimPromptRenderer :: PromptRenderer m
nvimPromptRenderer =
  m NvimPromptResources
-> (NvimPromptResources -> m ())
-> (Prompt -> m ())
-> PromptRenderer m
forall (m :: * -> *) a.
m a -> (a -> m ()) -> (Prompt -> m ()) -> PromptRenderer m
PromptRenderer m NvimPromptResources
forall e (m :: * -> *). NvimE e m => m NvimPromptResources
nvimAcquire NvimPromptResources -> m ()
forall e (m :: * -> *). NvimE e m => NvimPromptResources -> m ()
nvimRelease Prompt -> m ()
forall (m :: * -> *) e.
(Monad m, NvimE e m, MonadDeepError e DecodeError m) =>
Prompt -> m ()
nvimRenderPrompt