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>\")"
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