module Ribosome.Api.Syntax where

import qualified Data.Map.Strict as Map (toList)
import Data.MessagePack (Object)
import Neovim.Plugin.Classes (FunctionName(F))

import Ribosome.Api.Atomic (atomic)
import Ribosome.Control.Monad.Ribo (NvimE)
import Ribosome.Data.Syntax (
  HiLink(HiLink),
  Highlight(Highlight),
  Syntax(Syntax),
  SyntaxItem(SyntaxItem),
  SyntaxItemDetail(Keyword, Match, Region, Verbatim),
  )
import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))
import Ribosome.Msgpack.Error (DecodeError)
import Ribosome.Nvim.Api.Data (Window)
import Ribosome.Nvim.Api.IO (nvimWinGetNumber, vimCallFunction, vimGetCurrentWindow, vimSetCurrentWindow)
import Ribosome.Nvim.Api.RpcCall (RpcCall(RpcCall))

joinEquals :: Map Text Text -> Text
joinEquals :: Map Text Text -> Text
joinEquals =
  [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords ([Text] -> Text)
-> (Map Text Text -> [Text]) -> Map Text Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Text
forall a. (Semigroup a, IsString a) => (a, a) -> a
equals ((Text, Text) -> Text)
-> (Map Text Text -> [(Text, Text)]) -> Map Text Text -> [Text]
forall (f0 :: * -> *) (f1 :: * -> *) a b.
(Functor f0, Functor f1) =>
(a -> b) -> f1 (f0 a) -> f1 (f0 b)
<$$> Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList)
  where
    equals :: (a, a) -> a
equals (a
a, a
b) = a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b

rpcCommand :: [Text] -> RpcCall
rpcCommand :: [Text] -> RpcCall
rpcCommand [Text]
cmd =
  FunctionName -> [Object] -> RpcCall
RpcCall (ByteString -> FunctionName
F ByteString
"nvim_command") [Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Text -> Object) -> Text -> Object
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords [Text]
cmd]

synPattern :: Text -> Text
synPattern :: Text -> Text
synPattern Text
text =
  Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"

namedPattern :: Text -> Text -> Text -> Text
namedPattern :: Text -> Text -> Text -> Text
namedPattern Text
param Text
text Text
offset =
  Text
param Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
synPattern Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
offset

syntaxItemDetailCmd :: SyntaxItemDetail -> [Text]
syntaxItemDetailCmd :: SyntaxItemDetail -> [Text]
syntaxItemDetailCmd (Keyword Text
group' Text
keyword [Text]
keywords) =
  [Item [Text]
"syntax", Item [Text]
"keyword", Text
Item [Text]
group', Text
Item [Text]
keyword, [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords [Text]
keywords]
syntaxItemDetailCmd (Match Text
group' Text
pat) =
  [Item [Text]
"syntax", Item [Text]
"match", Text
Item [Text]
group', Text -> Text
synPattern Text
pat]
syntaxItemDetailCmd (Region Text
group' Text
start Text
end Maybe Text
skip Text
ms Text
me) =
  [Item [Text]
"syntax", Item [Text]
"region", Text
Item [Text]
group', Text -> Text -> Text -> Text
namedPattern Text
"start" Text
start Text
ms] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text]) -> Maybe Text -> [Text]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> [Text]
forall l. (IsList l, Item l ~ Text) => Text -> l
skipArg Maybe Text
skip [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Text -> Text -> Text
namedPattern Text
"end" Text
end Text
me]
  where
    skipArg :: Text -> l
skipArg Text
a = [Text -> Text -> Text -> Text
namedPattern Text
"skip" Text
a Text
""]
syntaxItemDetailCmd (Verbatim Text
cmd) =
  [Text
Item [Text]
cmd]

syntaxItemCmd :: SyntaxItem -> [Text]
syntaxItemCmd :: SyntaxItem -> [Text]
syntaxItemCmd (SyntaxItem SyntaxItemDetail
detail [Text]
options Map Text Text
params) =
  SyntaxItemDetail -> [Text]
syntaxItemDetailCmd SyntaxItemDetail
detail [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords [Text]
options, Map Text Text -> Text
joinEquals Map Text Text
params]

highlightCmd :: Highlight -> [Text]
highlightCmd :: Highlight -> [Text]
highlightCmd (Highlight Text
group' Map Text Text
values) =
  [Item [Text]
"highlight", Text
Item [Text]
group', Map Text Text -> Text
joinEquals Map Text Text
values]

hilinkCmd :: HiLink -> [Text]
hilinkCmd :: HiLink -> [Text]
hilinkCmd (HiLink Text
group' Text
target) =
  [Item [Text]
"highlight", Item [Text]
"link", Text
Item [Text]
group', Text
Item [Text]
target]

syntaxCmds :: Syntax -> [[Text]]
syntaxCmds :: Syntax -> [[Text]]
syntaxCmds (Syntax [SyntaxItem]
items [Highlight]
highlights [HiLink]
hilinks) =
  (SyntaxItem -> [Text]
syntaxItemCmd (SyntaxItem -> [Text]) -> [SyntaxItem] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SyntaxItem]
items) [[Text]] -> [[Text]] -> [[Text]]
forall a. Semigroup a => a -> a -> a
<> (Highlight -> [Text]
highlightCmd (Highlight -> [Text]) -> [Highlight] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Highlight]
highlights) [[Text]] -> [[Text]] -> [[Text]]
forall a. Semigroup a => a -> a -> a
<> (HiLink -> [Text]
hilinkCmd (HiLink -> [Text]) -> [HiLink] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HiLink]
hilinks)

executeSyntax ::
  MonadDeepError e DecodeError m =>
  NvimE e m =>
  Syntax ->
  m [Object]
executeSyntax :: Syntax -> m [Object]
executeSyntax =
  [RpcCall] -> m [Object]
forall e (m :: * -> *).
(MonadDeepError e DecodeError m, NvimE e m) =>
[RpcCall] -> m [Object]
atomic ([RpcCall] -> m [Object])
-> (Syntax -> [RpcCall]) -> Syntax -> m [Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> RpcCall
rpcCommand ([Text] -> RpcCall) -> (Syntax -> [[Text]]) -> Syntax -> [RpcCall]
forall (f0 :: * -> *) (f1 :: * -> *) a b.
(Functor f0, Functor f1) =>
(a -> b) -> f1 (f0 a) -> f1 (f0 b)
<$$> Syntax -> [[Text]]
syntaxCmds)

executeCurrentWindowSyntax ::
  MonadDeepError e DecodeError m =>
  NvimE e m =>
  Syntax ->
  m [Object]
executeCurrentWindowSyntax :: Syntax -> m [Object]
executeCurrentWindowSyntax Syntax
syntax =
  [RpcCall] -> m [Object]
forall e (m :: * -> *).
(MonadDeepError e DecodeError m, NvimE e m) =>
[RpcCall] -> m [Object]
atomic ([RpcCall] -> m [Object]) -> [RpcCall] -> m [Object]
forall a b. (a -> b) -> a -> b
$ [Text] -> RpcCall
rpcCommand ([Text] -> RpcCall) -> [[Text]] -> [RpcCall]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Syntax -> [[Text]]
syntaxCmds Syntax
syntax

executeWindowSyntax ::
  MonadDeepError e DecodeError m =>
  NvimE e m =>
  Window ->
  Syntax ->
  m [Object]
executeWindowSyntax :: Window -> Syntax -> m [Object]
executeWindowSyntax Window
win Syntax
syntax = do
  Window
previous <- m Window
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
m Window
vimGetCurrentWindow
  Int
number <- Window -> m Int
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Window -> m Int
nvimWinGetNumber Window
win
  Int -> m [Object]
exec Int
number m [Object] -> m () -> m [Object]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Window -> m ()
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
Window -> m ()
vimSetCurrentWindow Window
previous
  where
    exec :: Int -> m [Object]
exec Int
number =
      [RpcCall] -> m [Object]
forall e (m :: * -> *).
(MonadDeepError e DecodeError m, NvimE e m) =>
[RpcCall] -> m [Object]
atomic ([RpcCall] -> m [Object]) -> [RpcCall] -> m [Object]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> RpcCall
wrapCmd (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
number Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"windo") ([Text] -> RpcCall) -> [[Text]] -> [RpcCall]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Syntax -> [[Text]]
syntaxCmds Syntax
syntax
    wrapCmd :: Text -> [Text] -> RpcCall
wrapCmd Text
wrap [Text]
cmd =
      [Text] -> RpcCall
rpcCommand (Text
wrap Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cmd)

syntaxName ::
  NvimE e m =>
  Int ->
  Int ->
  m (Text, Text)
syntaxName :: Int -> Int -> m (Text, Text)
syntaxName Int
l Int
c = do
  Object
synId <- Text -> [Object] -> m Object
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"synID" (Int -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Int -> Object) -> [Int] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
Item [Int]
l, Int
Item [Int]
c, Item [Int]
0])
  m Text -> m Text -> m (Text, Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
tuple (Text -> [Object] -> m Text
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"getline" [Int -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack Int
l]) (Text -> [Object] -> m Text
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"synIDattr" [Item [Object]
Object
synId, Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Text
"name" :: Text)])