packages feed

ribosome 0.2.2.0 → 0.3.0.0

raw patch · 121 files changed

+5363/−1723 lines, 121 filesdep +base-nopreludedep +cerealdep +cereal-conduitdep −HTFdep −basedep −ribosomedep ~nvim-hs

Dependencies added: base-noprelude, cereal, cereal-conduit, chiasma, composition, composition-extra, conduit, conduit-extra, cornea, exceptions, free, lifted-async, lifted-base, monad-control, monad-loops, path, path-io, relude, stm-chans, stm-conduit, template-haskell, th-abstraction, transformers-base

Dependencies removed: HTF, base, ribosome

Dependency ranges changed: nvim-hs

Files

LICENSE view
@@ -1,21 +1,55 @@-The MIT License (MIT)+# Blue Oak Model License -Copyright (c) 2018 Torsten Schmits+Version 1.0.0 -Permission is hereby granted, free of charge, to any person obtaining a copy of-this software and associated documentation files (the "Software"), to deal in-the Software without restriction, including without limitation the rights to-use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies-of the Software, and to permit persons to whom the Software is furnished to do-so, subject to the following conditions:+## Purpose -The above copyright notice and this permission notice shall be included in all-copies or substantial portions of the Software.+This license gives everyone as much permission to work with+this software as possible, while protecting contributors+from liability. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-SOFTWARE.+## Acceptance++In order to receive this license, you must agree to its+rules.  The rules of this license are both obligations+under that agreement and conditions to your license.+You must not do anything with this software that triggers+a rule that you cannot or will not follow.++## Copyright++Each contributor licenses you to do everything with this+software that would otherwise infringe that contributor's+copyright in it.++## Notices++You must ensure that everyone who gets a copy of+any part of this software from you, with or without+changes, also gets the text of this license or a link to+<https://blueoakcouncil.org/license/1.0.0>.++## Excuse++If anyone notifies you in writing that you have not+complied with [Notices](#notices), you can keep your+license by taking all practical steps to comply within 30+days after the notice.  If you do not do so, your license+ends immediately.++## Patent++Each contributor licenses you to do everything with this+software that would otherwise infringe any patent claims+they can license or become able to license.++## Reliability++No contributor can revoke this license.++## No Liability++***As far as the law allows, this software comes as is,+without any warranty or condition, and no contributor+will be liable to anyone for any damages related to this+software or this license, under any kind of legal claim.***
+ lib/Prelude.hs view
@@ -0,0 +1,5 @@+module Prelude (+  module Ribosome.Prelude+) where++import Ribosome.Prelude
+ lib/Ribosome/Api/Atomic.hs view
@@ -0,0 +1,60 @@+module Ribosome.Api.Atomic where++import Data.MessagePack (Object(ObjectNil, ObjectArray, ObjectString))+import Neovim.Plugin.Classes (FunctionName(F))+import qualified Ribosome.Nvim.Api.RpcCall as RpcError (RpcError(Atomic))++import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Msgpack.Decode (MsgpackDecode(..), fromMsgpack')+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Msgpack.Error (DecodeError)+import qualified Ribosome.Msgpack.Util as Util (illegalType)+import Ribosome.Nvim.Api.IO (nvimCallAtomic)+import Ribosome.Nvim.Api.RpcCall (RpcCall(RpcCall))++data AtomicStatus =+  Failure Text+  |+  Success+  deriving (Eq, Show)++instance MsgpackDecode AtomicStatus where+  fromMsgpack ObjectNil =+    Right Success+  fromMsgpack (ObjectArray [_, _, ObjectString msg]) =+    Right (Failure (decodeUtf8 msg))+  fromMsgpack o =+    Util.illegalType "AtomicStatus" o++-- |Bundle a list of 'RpcCall's into a single call to nvim_call_atomic.+-- The result is checked for an error message, and if it is present, the call will fail.+atomic ::+  MonadDeepError e DecodeError m =>+  NvimE e m =>+  [RpcCall] ->+  m [Object]+atomic calls = do+  (results, statusObject) <- unpack =<< nvimCallAtomic (call <$> calls)+  status <- fromMsgpack' statusObject+  check results status+  where+    call (RpcCall (F name) args) =+      toMsgpack [toMsgpack name, toMsgpack args]+    unpack [ObjectArray results, status] =+      return (results, status)+    unpack o =+      throwHoist (RpcError.Atomic ("unexpected result structure: " <> show o))+    check _ (Failure err) =+      throwHoist (RpcError.Atomic err)+    check results Success =+      return results++-- |Bundle calls into one and decode all results to the same type.+atomicAs ::+  MonadDeepError e DecodeError m =>+  MsgpackDecode a =>+  NvimE e m =>+  [RpcCall] ->+  m [a]+atomicAs =+  traverse fromMsgpack' <=< atomic
+ lib/Ribosome/Api/Autocmd.hs view
@@ -0,0 +1,11 @@+module Ribosome.Api.Autocmd where++import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.IO (vimCommand)++doautocmd ::+  NvimE e m =>+  Text ->+  m ()+doautocmd name =+  vimCommand $ "doautocmd " <> name
lib/Ribosome/Api/Buffer.hs view
@@ -1,53 +1,104 @@-module Ribosome.Api.Buffer(-  edit,-  buflisted,-  setBufferContent,-  bufferContent,-  currentBufferContent,-  setCurrentBufferContent,-) where+module Ribosome.Api.Buffer where -import Neovim (-  Neovim,-  Buffer,-  NvimObject(..),-  Object,-  toObject,-  vim_command',-  vim_call_function',-  buffer_get_number',-  buffer_get_lines',-  buffer_set_lines',-  vim_get_current_buffer',+import Control.Monad (when)+import Data.Bifunctor (second)+import Data.MessagePack (Object)+import System.FilePath ((</>))++import Ribosome.Api.Atomic (atomicAs)+import Ribosome.Api.Path (nvimCwd)+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Msgpack.Encode (toMsgpack)+import Ribosome.Msgpack.Error (DecodeError)+import Ribosome.Nvim.Api.Data (Buffer, bufferGetName)+import Ribosome.Nvim.Api.IO (+  bufferGetLines,+  bufferGetNumber,+  bufferIsValid,+  bufferSetLines,+  vimCallFunction,+  vimCommand,+  vimGetBuffers,+  vimGetCurrentBuffer,   )-import Ribosome.Control.Ribo (Ribo)+import Ribosome.Nvim.Api.RpcCall (syncRpcCall) -edit :: FilePath -> Ribo e ()-edit path = vim_command' $ "silent! edit " ++ path+edit :: NvimE e m => FilePath -> m ()+edit path = vimCommand $ "silent! edit " <> toText path -nvimCallBool :: String -> [Object] -> Neovim e Bool-nvimCallBool fun args =-  vim_call_function' fun args >>= fromObject'+nvimCallBool :: NvimE e m => Text -> [Object] -> m Bool+nvimCallBool =+  vimCallFunction -buflisted :: Buffer -> Neovim e Bool+buflisted :: NvimE e m => Buffer -> m Bool buflisted buf = do-  num <- buffer_get_number' buf-  nvimCallBool "buflisted" [toObject num]+  num <- bufferGetNumber buf+  nvimCallBool "buflisted" [toMsgpack num] -bufferContent :: Buffer -> Neovim e [String]+bufferContent :: NvimE e m => Buffer -> m [Text] bufferContent buffer =-  buffer_get_lines' buffer 0 (-1) False+  bufferGetLines buffer 0 (-1) False -currentBufferContent :: Neovim e [String]-currentBufferContent = do-  buffer <- vim_get_current_buffer'-  bufferContent buffer+currentBufferContent :: NvimE e m => m [Text]+currentBufferContent =+  bufferContent =<< vimGetCurrentBuffer -setBufferContent :: Buffer -> [String] -> Neovim e ()+setBufferContent :: NvimE e m => Buffer -> [Text] -> m () setBufferContent buffer =-  buffer_set_lines' buffer 0 (-1) False+  bufferSetLines buffer 0 (-1) False -setCurrentBufferContent :: [String] -> Neovim e ()+setCurrentBufferContent ::+  NvimE e m =>+  [Text] ->+  m () setCurrentBufferContent content = do-  buffer <- vim_get_current_buffer'+  buffer <- vimGetCurrentBuffer   setBufferContent buffer content++closeBuffer ::+  NvimE e m =>+  Buffer ->+  m ()+closeBuffer buffer = do+  valid <- bufferIsValid buffer+  when valid $ do+    number <- bufferGetNumber buffer+    vimCommand ("silent! bdelete! " <> show number)++wipeBuffer ::+  NvimE e m =>+  Buffer ->+  m ()+wipeBuffer buffer = do+  valid <- bufferIsValid buffer+  when valid $ do+    number <- bufferGetNumber buffer+    vimCommand ("silent! bwipeout! " <> show number)++buffersAndNames ::+  MonadIO m =>+  MonadDeepError e DecodeError m =>+  NvimE e m =>+  m [(Buffer, Text)]+buffersAndNames = do+  buffers <- vimGetBuffers+  names <- atomicAs (syncRpcCall . bufferGetName <$> buffers)+  return (zip buffers names)++bufferForFile ::+  MonadIO m =>+  MonadDeepError e DecodeError m =>+  NvimE e m =>+  Text ->+  m (Maybe Buffer)+bufferForFile target = do+  cwd <- nvimCwd+  fmap fst . find sameBuffer . fmap (second (toText . absolute cwd . toString)) <$> buffersAndNames+  where+    sameBuffer (_, name) = name == target+    absolute dir ('.' : '/' : rest) =+      dir </> rest+    absolute _ p@('/' : _) =+      p+    absolute dir path =+      dir </> path
lib/Ribosome/Api/Echo.hs view
@@ -1,20 +1,46 @@-module Ribosome.Api.Echo(-  echom,-  echomS,-) where+module Ribosome.Api.Echo where -import Neovim (vim_command')-import Ribosome.Control.Ribo (Ribo)-import qualified Ribosome.Control.Ribo as Ribo (name)+import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginName)+import Ribosome.Data.Text (escapeQuotes)+import Ribosome.Nvim.Api.IO (vimCommand) -escapeQuotes :: Char -> String-escapeQuotes '\'' = "''"-escapeQuotes a = [a]+echoWith :: NvimE e m => Text -> Text -> m ()+echoWith cmd msg =+  vimCommand $ cmd <> " '" <> escapeQuotes msg <> "'" -echom :: String -> Ribo e ()-echom msg = do-  name <- Ribo.name-  vim_command' $ "echom '" ++ name ++ ": " ++ concatMap escapeQuotes msg ++ "'"+echoWithName :: MonadRibo m => NvimE e m => Text -> Text -> m ()+echoWithName cmd msg = do+  name <- pluginName+  echoWith cmd $ name <> ": " <> msg -echomS :: Show a => a -> Ribo e ()+echo' :: NvimE e m => Text -> m ()+echo' =+  echoWith "echo"++echo :: MonadRibo m => NvimE e m => Text -> m ()+echo =+  echoWithName "echo"++echom' :: NvimE e m => Text -> m ()+echom' =+  echoWith "echom"++echom :: MonadRibo m => NvimE e m => Text -> m ()+echom =+  echoWithName "echom"++echomS ::+  MonadRibo m =>+  NvimE e m =>+  Show a =>+  a ->+  m () echomS = echom . show++echon :: MonadRibo m => NvimE e m => Text -> m ()+echon =+  echoWithName "echom"++echohl :: MonadRibo m => NvimE e m => Text -> m ()+echohl =+  vimCommand . ("echohl " <>)
lib/Ribosome/Api/Exists.hs view
@@ -1,26 +1,21 @@-module Ribosome.Api.Exists(-  retry,-  waitForFunction,-  vimDoesExist,-  function,-) where+module Ribosome.Api.Exists where  import Control.Monad.IO.Class (MonadIO) import Data.Default (Default(def)) import Data.Either (isRight)-import Data.Text.Prettyprint.Doc ((<+>), viaShow, prettyList)+import Data.Text.Prettyprint.Doc (viaShow, (<+>)) import Neovim (-  Neovim,+  AnsiStyle,+  Doc,   NvimObject,   Object(ObjectInt),-  Doc,-  AnsiStyle,-  toObject,-  fromObject,-  vim_call_function',   ) -import Ribosome.Data.Time (epochSeconds, sleep)+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Msgpack.Decode (MsgpackDecode, fromMsgpack)+import Ribosome.Msgpack.Encode (toMsgpack)+import Ribosome.Nvim.Api.IO (vimCallFunction)+import Ribosome.System.Time (epochSeconds, sleep)  data Retry =   Retry Int Double@@ -29,7 +24,12 @@ instance Default Retry where   def = Retry 3 0.1 -retry :: MonadIO f => f a -> (a -> f (Either c b)) -> Retry -> f (Either c b)+retry ::+  MonadIO f =>+  f a ->+  (a -> f (Either c b)) ->+  Retry ->+  f (Either c b) retry thunk check (Retry timeout interval) = do   start <- epochSeconds   step start@@ -47,37 +47,78 @@         step start       else return $ Left e -waitFor :: NvimObject b =>-  Neovim e Object ->-  (Object -> Neovim e (Either (Doc AnsiStyle) b)) ->+waitFor ::+  NvimE e m =>+  MonadIO m =>+  NvimObject b =>+  m Object ->+  (Object -> m (Either (Doc AnsiStyle) b)) ->   Retry ->-  Neovim e (Either (Doc AnsiStyle) b)+  m (Either (Doc AnsiStyle) b) waitFor thunk check' =   retry thunk check   where     check result =-      case fromObject result of+      case fromMsgpack result of         Right a -> check' a         Left e -> return $ Left e  existsResult :: Object -> Either (Doc AnsiStyle) () existsResult (ObjectInt 1) = Right ()-existsResult a = Left $ prettyList "weird return type " <+> viaShow a+existsResult a =+  Left $ "weird return type " <+> viaShow a -vimExists :: String -> Neovim e Object+vimExists ::+  NvimE e m =>+  Text ->+  m Object vimExists entity =-  vim_call_function' "exists" [toObject entity]+  vimCallFunction "exists" [toMsgpack entity] -vimDoesExist :: String -> Neovim e Bool+vimDoesExist ::+  NvimE e m =>+  Text ->+  m Bool vimDoesExist entity =   fmap (isRight . existsResult) (vimExists entity) -function :: String -> Neovim e Bool+function ::+  NvimE e m =>+  Text ->+  m Bool function name =-  vimDoesExist ("*" ++ name)+  vimDoesExist ("*" <> name) -waitForFunction :: String -> Retry -> Neovim e (Either (Doc AnsiStyle) ())+waitForFunction ::+  NvimE e m =>+  MonadIO m =>+  Text ->+  Retry ->+  m (Either (Doc AnsiStyle) ()) waitForFunction name =   waitFor thunk (return . existsResult)   where-    thunk = vimExists ("*" ++ name)+    thunk = vimExists ("*" <> name)++waitForFunctionResult ::+  NvimE e m =>+  MonadIO m =>+  Eq a =>+  Show a =>+  MsgpackDecode a =>+  Text ->+  a ->+  Retry ->+  m (Either (Doc AnsiStyle) ())+waitForFunctionResult name a retry' =+  waitForFunction name retry' >>= \case+    Right _ -> waitFor thunk (return . check . fromMsgpack) retry'+    Left e -> return (Left e)+  where+    thunk = vimCallFunction name []+    check (Right a') | a == a' =+      Right ()+    check (Right a') =+      Left $ "results differ:" <+> show a <+> "/" <+> show a'+    check (Left e) =+      Left $ "weird return type: " <+> e
lib/Ribosome/Api/Function.hs view
@@ -1,8 +1,18 @@-module Ribosome.Api.Function(-  callFunction,-) where+module Ribosome.Api.Function where -import Neovim (Neovim, fromObject', NvimObject, Object, vim_call_function')+import qualified Data.Text as Text (intercalate) -callFunction :: NvimObject a => String -> [Object] -> Neovim e a-callFunction name args = vim_call_function' name args >>= fromObject'+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.IO (vimCommand)++defineFunction ::+  NvimE e m =>+  Text ->+  [Text] ->+  [Text] ->+  m ()+defineFunction name params body =+  vimCommand $ unlines $ sig : body ++ ["endfunction"]+  where+    sig =+      "function! " <> name <> "(" <> Text.intercalate ", " params <> ")"
+ lib/Ribosome/Api/Input.hs view
@@ -0,0 +1,17 @@+module Ribosome.Api.Input where++import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.IO (vimInput)+import Ribosome.System.Time (sleep)++syntheticInput ::+  MonadIO m =>+  NvimE e m =>+  Maybe Double ->+  [Text] ->+  m ()+syntheticInput interval =+  traverse_ send+  where+    send c =+      traverse_ sleep interval *> vimInput c
lib/Ribosome/Api/Option.hs view
@@ -1,30 +1,22 @@-module Ribosome.Api.Option(-  optionCat,-  rtpCat,-  optionList,-  option,-  optionString,-) where+module Ribosome.Api.Option where -import Control.Monad ((>=>))-import Data.List.Split (splitOn)-import Neovim (Neovim, vim_get_option', fromObject', vim_set_option', toObject, NvimObject)+import Data.Text (splitOn)+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Msgpack.Encode (toMsgpack)+import Ribosome.Nvim.Api.IO (vimGetOption, vimSetOption) -optionCat :: String -> String -> Neovim e ()+optionCat :: NvimE e m => Text -> Text -> m () optionCat name extra = do-  current <- vim_get_option' name >>= fromObject'-  vim_set_option' name $ toObject $ current ++ "," ++ extra+  current <- vimGetOption name+  vimSetOption name $ toMsgpack $ current <> "," <> extra -rtpCat :: String -> Neovim e ()+rtpCat :: NvimE e m => Text -> m () rtpCat = optionCat "runtimepath" -option :: NvimObject a => String -> Neovim e a-option = vim_get_option' >=> fromObject'--optionString :: String -> Neovim e String-optionString = option+optionString :: NvimE e m => Text -> m Text+optionString = vimGetOption -optionList :: String -> Neovim e [String]+optionList :: NvimE e m => Text -> m [Text] optionList name = do-  s <- option name+  s <- vimGetOption name   return $ splitOn "," s
lib/Ribosome/Api/Path.hs view
@@ -1,8 +1,7 @@-module Ribosome.Api.Path(-  nvimCwd,-) where+module Ribosome.Api.Path where -import Neovim (Neovim, vim_call_function', fromObject')+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.IO (vimCallFunction) -nvimCwd :: Neovim e FilePath-nvimCwd = vim_call_function' "getcwd" [] >>= fromObject'+nvimCwd :: NvimE e m => m FilePath+nvimCwd = vimCallFunction "getcwd" []
+ lib/Ribosome/Api/Process.hs view
@@ -0,0 +1,11 @@+module Ribosome.Api.Process where++import Control.Monad.DeepError (MonadDeepError)++import Ribosome.Control.Monad.Ribo (Nvim)+import Ribosome.Nvim.Api.IO (vimCallFunction)+import Ribosome.Nvim.Api.RpcCall (RpcError)++vimPid :: (MonadDeepError e RpcError m, Nvim m) => m Int+vimPid =+  vimCallFunction "getpid" []
lib/Ribosome/Api/Response.hs view
@@ -6,20 +6,19 @@ ) where -import Data.ByteString.UTF8 import Neovim  nvimFatal :: Either NeovimException a -> Neovim env a nvimFatal (Right a) = return a nvimFatal (Left e) = (liftIO . fail . show) e -nvimResponseString :: Object -> Neovim env String-nvimResponseString (ObjectString a) = return $ toString a-nvimResponseString a = liftIO . fail $ "invalid nvim type for String: " ++ show a+nvimResponseString :: Object -> Neovim env Text+nvimResponseString (ObjectString a) = return $ decodeUtf8 a+nvimResponseString a = liftIO . fail $ "invalid nvim type for Text: " <> show a -nvimResponseStringArray :: Object -> Neovim env [String]+nvimResponseStringArray :: Object -> Neovim env [Text] nvimResponseStringArray (ObjectArray a) = traverse nvimResponseString a-nvimResponseStringArray a = liftIO . fail $ "invalid nvim type for Array: " ++ show a+nvimResponseStringArray a = liftIO . fail $ "invalid nvim type for Array: " <> show a  nvimValidateFatal :: (Object -> Neovim env a) -> Either NeovimException Object -> Neovim env a nvimValidateFatal validate response = do
lib/Ribosome/Api/Sleep.hs view
@@ -1,12 +1,18 @@-module Ribosome.Api.Sleep(-  nvimSleep,-  nvimMSleep,-) where+module Ribosome.Api.Sleep where -import Neovim (Neovim, vim_command')+import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.IO (vimCommand) -nvimSleep :: Int -> Neovim e ()-nvimSleep interval = vim_command' $ "sleep " ++ show interval+nvimSleep ::+  NvimE e m =>+  Int ->+  m ()+nvimSleep interval =+  vimCommand $ "sleep " <> show interval -nvimMSleep :: Int -> Neovim e ()-nvimMSleep interval = vim_command' $ "sleep " ++ show interval ++ "m"+nvimMSleep ::+  NvimE e m =>+  Int ->+  m ()+nvimMSleep interval =+  vimCommand $ "sleep " <> show interval <> "m"
+ lib/Ribosome/Api/Syntax.hs view
@@ -0,0 +1,89 @@+module Ribosome.Api.Syntax where++import Data.Functor.Syntax ((<$$>))+import Data.Map (Map)+import qualified Data.Map 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)+import Ribosome.Nvim.Api.RpcCall (RpcCall(RpcCall))++joinEquals :: Map Text Text -> Text+joinEquals =+  unwords . (equals <$$> Map.toList)+  where+    equals (a, b) = a <> "=" <> b++rpcCommand :: [Text] -> RpcCall+rpcCommand cmd =+  RpcCall (F "nvim_command") [toMsgpack $ unwords cmd]++synPattern :: Text -> Text+synPattern text =+  "/" <> text <> "/"++namedPattern :: Text -> Text -> Text -> Text+namedPattern param text offset =+  param <> "=" <> synPattern text <> offset++syntaxItemDetailCmd :: SyntaxItemDetail -> [Text]+syntaxItemDetailCmd (Keyword group' keyword keywords) =+  ["syntax", "keyword", group', keyword, unwords keywords]+syntaxItemDetailCmd (Match group' pat) =+  ["syntax", "match", group', synPattern pat]+syntaxItemDetailCmd (Region group' start end skip ms me) =+  ["syntax", "region", group', namedPattern "start" start ms] <> foldMap skipArg skip <> [namedPattern "end" end me]+  where+    skipArg a = [namedPattern "skip" a ""]+syntaxItemDetailCmd (Verbatim cmd) =+  [cmd]++syntaxItemCmd :: SyntaxItem -> [Text]+syntaxItemCmd (SyntaxItem detail options params) =+  syntaxItemDetailCmd detail <> [unwords options, joinEquals params]++highlightCmd :: Highlight -> [Text]+highlightCmd (Highlight group' values) =+  ["highlight", group', joinEquals values]++hilinkCmd :: HiLink -> [Text]+hilinkCmd (HiLink group' target) =+  ["highlight", "link", group', target]++syntaxCmds :: Syntax -> [[Text]]+syntaxCmds (Syntax items highlights hilinks) =+  (syntaxItemCmd <$> items) <> (highlightCmd <$> highlights) <> (hilinkCmd <$> hilinks)++executeSyntax ::+  MonadDeepError e DecodeError m =>+  NvimE e m =>+  Syntax ->+  m [Object]+executeSyntax =+  atomic . (rpcCommand <$$> syntaxCmds)++executeWindowSyntax ::+  MonadDeepError e DecodeError m =>+  NvimE e m =>+  Window ->+  Syntax ->+  m [Object]+executeWindowSyntax win syntax = do+  number <- nvimWinGetNumber win+  atomic $ wrapCmd (show number <> "windo") <$> syntaxCmds syntax+  where+    wrapCmd wrap cmd =+      rpcCommand (wrap : cmd)
+ lib/Ribosome/Api/Tabpage.hs view
@@ -0,0 +1,17 @@+module Ribosome.Api.Tabpage where++import Control.Monad (when)++import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.Data (Tabpage)+import Ribosome.Nvim.Api.IO (nvimTabpageGetNumber, tabpageIsValid, vimCommand)++closeTabpage ::+  NvimE e m =>+  Tabpage ->+  m ()+closeTabpage tabpage = do+  valid <- tabpageIsValid tabpage+  when valid $ do+    number <- nvimTabpageGetNumber tabpage+    vimCommand ("silent! tabclose! " <> show number)
+ lib/Ribosome/Api/Variable.hs view
@@ -0,0 +1,25 @@+module Ribosome.Api.Variable where++import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginName)+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Nvim.Api.IO (vimSetVar)++setVar ::+  NvimE e m =>+  MsgpackEncode a =>+  Text ->+  a ->+  m ()+setVar name =+  vimSetVar name . toMsgpack++setPVar ::+  MonadRibo m =>+  NvimE e m =>+  MsgpackEncode a =>+  Text ->+  a ->+  m ()+setPVar name a = do+  pn <- pluginName+  setVar (pn <> "_" <> name) a
lib/Ribosome/Api/Window.hs view
@@ -1,3 +1,80 @@-module Ribosome.Api.Window(-) where+module Ribosome.Api.Window where +import Control.Monad (when)++import Ribosome.Control.Monad.Ribo (NvimE)+import Ribosome.Nvim.Api.Data (Window)+import Ribosome.Nvim.Api.IO (+  nvimGetCurrentWin,+  nvimWinClose,+  nvimWinGetCursor,+  nvimWinSetCursor,+  vimCommand,+  windowIsValid,+  )++closeWindow ::+  NvimE e m =>+  Window ->+  m ()+closeWindow window = do+  valid <- windowIsValid window+  when valid $ nvimWinClose window True++cursor ::+  NvimE e m =>+  Window ->+  m (Int, Int)+cursor window = do+  (line, col) <- nvimWinGetCursor window+  return (fromIntegral line - 1, fromIntegral col)++currentCursor ::+  NvimE e m =>+  m (Int, Int)+currentCursor =+  cursor =<< nvimGetCurrentWin++windowLine ::+  NvimE e m =>+  Window ->+  m Int+windowLine window =+  fst <$> cursor window++currentLine ::+  NvimE e m =>+  m Int+currentLine =+  windowLine =<< nvimGetCurrentWin++setCursor ::+  NvimE e m =>+  Window ->+  Int ->+  Int ->+  m ()+setCursor window line col =+  nvimWinSetCursor window (line + 1, col)++setLine ::+  NvimE e m =>+  Window ->+  Int ->+  m ()+setLine window line =+  setCursor window line 0++setCurrentLine ::+  NvimE e m =>+  Int ->+  m ()+setCurrentLine line = do+  window <- nvimGetCurrentWin+  setLine window line++redraw ::+  NvimE e m =>+  m ()+redraw =+  vimCommand "silent! redraw!"
lib/Ribosome/Config/Setting.hs view
@@ -1,101 +1,80 @@-module Ribosome.Config.Setting(-  Setting (..),-  setting,-  settingE,-  updateSetting,-  settingVariableName,-  settingOr,-  settingMaybe,-  settingR,-  SettingError(..),-  updateSettingR,-) where--import Data.Either (fromRight)-import Data.Text.Prettyprint.Doc (Doc)-import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)-import Neovim-import System.Log (Priority(NOTICE))--import Ribosome.Control.Monad.RiboE (RiboE, liftRibo, riboE, mapE)-import Ribosome.Control.Ribo (Ribo)-import qualified Ribosome.Control.Ribosome as R (name)-import Ribosome.Data.ErrorReport (ErrorReport(..))-import Ribosome.Error.Report (ReportError(..))-import Ribosome.Msgpack.Decode (MsgpackDecode(fromMsgpack))-import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+{-# LANGUAGE TemplateHaskell #-} -data SettingError =-  Other String String-  |-  Decode String (Doc AnsiStyle)-  |-  Unset String-  deriving Show+module Ribosome.Config.Setting where -instance ReportError SettingError where-  errorReport (Other name message) =-    ErrorReport ("weird setting: " ++ name) ["failed to read setting `" ++ name ++ "`", message] NOTICE-  errorReport (Decode name message) =-    ErrorReport ("invalid setting: " ++ name) ["failed to decode setting `" ++ name ++ "`", show message] NOTICE-  errorReport (Unset name) =-    ErrorReport ("required setting unset: " ++ name) ["unset setting: `" ++ name ++ "`"] NOTICE+import Control.Monad.DeepError (MonadDeepError(throwHoist), catchAt)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Except (runExceptT)+import Data.DeepPrisms (deepPrisms) -data Setting a =-  Setting {-    name :: String,-    prefix :: Bool,-    fallback :: Maybe a-  }+import Ribosome.Control.Monad.Ribo (MonadRibo, Nvim, NvimE, pluginName)+import Ribosome.Data.Setting (Setting(Setting))+import Ribosome.Data.SettingError (SettingError)+import qualified Ribosome.Data.SettingError as SettingError (SettingError(..))+import Ribosome.Msgpack.Decode (MsgpackDecode)+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Nvim.Api.IO+import Ribosome.Nvim.Api.RpcCall (RpcError)+import qualified Ribosome.Nvim.Api.RpcCall as RpcError (RpcError(..)) -settingVariableName :: Setting a -> Ribo e String-settingVariableName (Setting n False _) = return n-settingVariableName (Setting n True _) = do-  pluginName <- R.name <$> ask-  return $ pluginName ++ "_" ++ n+settingVariableName ::+  (MonadRibo m) =>+  Setting a ->+  m Text+settingVariableName (Setting settingName False _) =+  return settingName+settingVariableName (Setting settingName True _) = do+  name <- pluginName+  return $ name <> "_" <> settingName -settingE :: NvimObject a => Setting a -> Ribo e (Either String a)-settingE s@(Setting _ _ fallback') = do-  varName <- settingVariableName s-  raw <- vim_get_var varName-  case raw of-    Right o -> fromObject' o-    Left a -> return $ case fallback' of-      Just fb -> Right fb-      Nothing -> Left $ show a+settingRaw :: (MonadRibo m, Nvim m, MsgpackDecode a, MonadDeepError e RpcError m) => Setting a -> m a+settingRaw s =+  vimGetVar =<< settingVariableName s -setting :: NvimObject a => Setting a -> Ribo e a-setting s = do-  raw <- settingE s-  either fail return raw+setting ::+  ∀ e m a.+  NvimE e m =>+  MonadRibo m =>+  MonadDeepError e SettingError m =>+  MsgpackDecode a =>+  Setting a ->+  m a+setting s@(Setting n _ fallback') =+  catchAt handleError $ settingRaw s+  where+    handleError (RpcError.Nvim _ _) =+      case fallback' of+        (Just fb) -> return fb+        Nothing -> throwHoist $ SettingError.Unset n+    handleError a =+      throwHoist a -settingOr :: NvimObject a => a -> Setting a -> Ribo e a-settingOr a s = do-  raw <- settingE s-  return $ fromRight a raw+data SettingOrError =+  Sett SettingError+  |+  Rpc RpcError -settingMaybe :: NvimObject a => Setting a -> Ribo e (Maybe a)-settingMaybe s = do-  raw <- settingE s-  return $ either (const Nothing) Just raw+deepPrisms ''SettingOrError -updateSetting :: NvimObject a => Setting a -> a -> Ribo e ()-updateSetting s a = do-  varName <- settingVariableName s-  _ <- vim_set_var' varName (toObject a)-  return ()+settingOr ::+  (MonadIO m, Nvim m, MonadRibo m, MsgpackDecode a) =>+  a ->+  Setting a ->+  m a+settingOr a =+  (fromRight a <$>) . runExceptT . setting @SettingOrError -settingR :: MsgpackDecode a => Setting a -> RiboE s SettingError a-settingR s@(Setting n _ fallback') = do-  varName <- liftRibo $ settingVariableName s-  raw <- liftRibo $ vim_get_var varName-  case raw of-    Right o -> mapE (Decode n) $ riboE $ pure $ fromMsgpack o-    Left _ -> riboE $ return $ case fallback' of-      Just fb -> Right fb-      Nothing -> Left $ Unset n+settingMaybe ::+  (MonadIO m, Nvim m, MonadRibo m, MsgpackDecode a) =>+  Setting a ->+  m (Maybe a)+settingMaybe =+  (rightToMaybe <$>) . runExceptT . setting @SettingOrError -updateSettingR :: MsgpackEncode a => Setting a -> a -> Ribo e ()-updateSettingR s a = do-  varName <- settingVariableName s-  void $ vim_set_var' varName (toMsgpack a)+updateSetting ::+  (MonadRibo m, MonadIO m, Nvim m, MonadDeepError e RpcError m, MsgpackEncode a) =>+  Setting a ->+  a ->+  m ()+updateSetting s a =+  (`vimSetVar` toMsgpack a) =<< settingVariableName s
lib/Ribosome/Config/Settings.hs view
@@ -1,8 +1,9 @@-module Ribosome.Config.Settings(-  persistenceDir,-) where+module Ribosome.Config.Settings where -import Ribosome.Config.Setting (Setting(Setting))+import Ribosome.Data.Setting (Setting(Setting))  persistenceDir :: Setting FilePath persistenceDir = Setting "ribosome_persistence_dir" False Nothing++tmuxSocket :: Setting FilePath+tmuxSocket = Setting "tmux_socket" True Nothing
+ lib/Ribosome/Control/Concurrent/Wait.hs view
@@ -0,0 +1,103 @@+module Ribosome.Control.Concurrent.Wait where++import Control.Exception.Lifted (Exception, SomeException(..), try)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Default (Default(def))+import Data.Functor ((<&>))+import qualified Text.Show++import Ribosome.System.Time (sleep)++-- |Specifies the maximum number of retries and the interval in seconds for 'waitIO'.+data Retry =+  Retry Int Double+  deriving Show++instance Default Retry where+  def = Retry 30 0.1++-- |Error description for 'waitIO'+data WaitError =+  NotStarted+  |+  ConditionUnmet Text+  |+  ∀ e. Exception e => Thrown e++instance Text.Show.Show WaitError where+  show NotStarted =+    "NotStarted"+  show (ConditionUnmet reason) =+    toString $ "ConditionUnmet(" <> reason <> ")"+  show (Thrown _) =+    "Thrown"++-- |Execute an IO thunk repeatedly until either the supplied condition produces a 'Right' or the maximum number of+-- retries specified in the `Retry` parameter has been reached.+-- Returns the value produced by the condition.+waitIO ::+  MonadIO m =>+  MonadBaseControl IO m =>+  Retry ->+  m a ->+  (a -> m (Either Text b)) ->+  m (Either WaitError b)+waitIO (Retry maxRetry interval) thunk cond =+  wait maxRetry (Left NotStarted)+  where+    wait 0 reason = return reason+    wait count _ = do+      ea <- try thunk+      result <- try $ check ea+      case result of+        Right (Right a) ->+          return $ Right a+        Right (Left reason) ->+          recurse reason count+        Left (SomeException e) ->+          recurse (Thrown e) count+    recurse reason count = do+      sleep interval+      wait (count - 1) (Left reason)+    check (Right a) =+      cond a <&> \case+        Right b -> Right b+        Left reason -> Left (ConditionUnmet reason)+    check (Left (SomeException e)) =+      return $ Left (Thrown e)++-- |Calls 'waitIO' with the default configuration of 30 retries every 100ms.+waitIODef ::+  MonadIO m =>+  MonadBaseControl IO m =>+  m a ->+  (a -> m (Either Text b)) ->+  m (Either WaitError b)+waitIODef =+  waitIO def++-- |Same as 'waitIO', but the condition returns 'Bool' and the result is the result of the thunk.+waitIOPred ::+  MonadIO m =>+  MonadBaseControl IO m =>+  Retry ->+  m a ->+  (a -> m Bool) ->+  m (Either WaitError a)+waitIOPred retry thunk pred' =+  waitIO retry thunk cond+  where+    cond a = pred' a <&> \case+      True -> Right a+      False -> Left "predicate returned False"++-- |Calls 'waitIOPred' with the default configuration of 30 retries every 100ms.+waitIOPredDef ::+  MonadIO m =>+  MonadBaseControl IO m =>+  m a ->+  (a -> m Bool) ->+  m (Either WaitError a)+waitIOPredDef =+  waitIOPred def
+ lib/Ribosome/Control/Exception.hs view
@@ -0,0 +1,18 @@+module Ribosome.Control.Exception where++import Control.Exception.Lifted (IOException, try)+import Control.Monad.Trans.Control (MonadBaseControl)++tryIO ::+  MonadBaseControl IO m =>+  m a ->+  m (Either IOException a)+tryIO =+  try++tryAny ::+  MonadBaseControl IO m =>+  m a ->+  m (Either SomeException a)+tryAny =+  try
lib/Ribosome/Control/Lock.hs view
@@ -1,32 +1,29 @@-module Ribosome.Control.Lock(-  getOrCreateLock,-  lockOrSkip,-) where+module Ribosome.Control.Lock where -import qualified Control.Lens as Lens (view, over, at)-import qualified Data.Map.Strict as Map (insert)-import Neovim (ask)-import UnliftIO (finally)-import UnliftIO.STM (TMVar, atomically, newTMVarIO, tryTakeTMVar, tryPutTMVar, modifyTVar)+import Control.Exception.Lifted (finally)+import qualified Control.Lens as Lens (at, view)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Map as Map (insert)+import UnliftIO.STM (TMVar, newTMVarIO, tryPutTMVar, tryTakeTMVar) -import Ribosome.Control.Ribo (Ribo, riboInternal)-import Ribosome.Control.Ribosome (Ribosome(Ribosome), Locks)-import qualified Ribosome.Control.Ribosome as Ribosome (_locks, locks)-import qualified Ribosome.Log as Log (debugR)+import Ribosome.Control.Monad.Ribo (MonadRibo, pluginInternalL, pluginInternalModifyL)+import Ribosome.Control.Ribosome (Locks)+import qualified Ribosome.Control.Ribosome as Ribosome (locks)+import qualified Ribosome.Log as Log (debug) -getLocks :: Ribo e Locks+getLocks :: (MonadRibo m, MonadIO m) => m Locks getLocks =-  Ribosome.locks <$> riboInternal+  pluginInternalL Ribosome.locks -inspectLocks :: (Locks -> a) -> Ribo e a-inspectLocks f = fmap f getLocks+inspectLocks :: (MonadRibo m, MonadIO m) => (Locks -> a) -> m a+inspectLocks = (<$> getLocks) -modifyLocks :: (Locks -> Locks) -> Ribo e ()-modifyLocks f = do-  Ribosome _ intTv _ <- ask-  atomically $ modifyTVar intTv $ Lens.over Ribosome._locks f+modifyLocks :: MonadRibo m => (Locks -> Locks) -> m ()+modifyLocks =+  pluginInternalModifyL Ribosome.locks -getOrCreateLock :: String -> Ribo e (TMVar ())+getOrCreateLock :: (MonadRibo m, MonadIO m) => Text -> m (TMVar ()) getOrCreateLock key = do   currentLock <- inspectLocks $ Lens.view $ Lens.at key   case currentLock of@@ -36,13 +33,19 @@       modifyLocks $ Map.insert key tv       getOrCreateLock key -lockOrSkip :: String -> Ribo e () -> Ribo e ()+lockOrSkip ::+  MonadRibo m =>+  MonadIO m =>+  MonadBaseControl IO m =>+  Text ->+  m () ->+  m () lockOrSkip key thunk = do   currentLock <- getOrCreateLock key   currentState <- atomically $ tryTakeTMVar currentLock   case currentState of     Just _ -> do-      Log.debugR $ "locking MVar `" ++ key ++ "`"+      Log.debug $ "locking MVar `" <> key <> "`"       finally thunk $ atomically $ tryPutTMVar currentLock ()-      Log.debugR $ "unlocking MVar `" ++ key ++ "`"+      Log.debug $ "unlocking MVar `" <> key <> "`"     Nothing -> return ()
+ lib/Ribosome/Control/Monad/Error.hs view
@@ -0,0 +1,12 @@+module Ribosome.Control.Monad.Error(+  recoverAs,+  recoveryFor,+) where++import Control.Monad.Error.Class (MonadError(catchError))++recoveryFor :: MonadError e m => m a -> m a -> m a+recoveryFor = flip catchError . const++recoverAs :: MonadError e m => m a -> m a -> m a+recoverAs = flip recoveryFor
lib/Ribosome/Control/Monad/Ribo.hs view
@@ -1,80 +1,230 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FunctionalDependencies #-} -module Ribosome.Control.Monad.Ribo(-  Ribo,-  RiboT(..),-  MonadRibo(..),-  MonadRiboError(..),-  unsafeToNeovim,-) where+module Ribosome.Control.Monad.Ribo where -import Control.Concurrent.STM.TVar (swapTVar)+import Control.Concurrent.STM.TMVar (putTMVar, readTMVar, takeTMVar)+import Control.Exception.Lifted (onException)+import Control.Lens (Lens')+import qualified Control.Lens as Lens (mapMOf, over, view)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT)-import qualified Control.Monad.Trans.Except as Except (catchE)-import Data.Bifunctor (Bifunctor(..))-import Data.Either.Combinators (mapLeft)-import Data.Functor (void)-import UnliftIO.Exception (throwString)-import UnliftIO.STM (TVar, atomically, readTVarIO)-import Neovim (ask)-import Neovim.Context.Internal (Neovim(Neovim))-import Ribosome.Control.Ribosome (Ribosome)-import qualified Ribosome.Control.Ribosome as Ribosome (env)+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader.Class (MonadReader, asks)+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)+import Control.Monad.Trans.Free (FreeT)+import Control.Monad.Trans.Reader (ReaderT(ReaderT), runReaderT)+import Control.Monad.Trans.Resource (runResourceT)+import qualified Control.Monad.Trans.State.Strict as StateT (gets, modify)+import Data.DeepLenses (DeepLenses(deepLens))+import Data.DeepPrisms (DeepPrisms)+import Neovim.Context.Internal (Neovim(..))+import Ribosome.Plugin.RpcHandler (RpcHandler(..))+import UnliftIO.STM (TMVar) -type Ribo e = Neovim (Ribosome e)+import Ribosome.Control.Ribosome (Ribosome, RibosomeInternal, RibosomeState)+import qualified Ribosome.Control.Ribosome as Ribosome (_errors, errors, name, state)+import qualified Ribosome.Control.Ribosome as RibosomeState (internal, public)+import Ribosome.Control.StrictRibosome (StrictRibosome)+import qualified Ribosome.Control.StrictRibosome as StrictRibosome (name, state)+import Ribosome.Data.Errors (Errors)+import Ribosome.Nvim.Api.RpcCall (Rpc, RpcError)+import qualified Ribosome.Nvim.Api.RpcCall as Rpc (Rpc(..))+import Ribosome.Orphans () -newtype RiboT s e a =-  RiboT { unRiboT :: ExceptT e (Neovim (Ribosome (TVar s))) a }-  deriving (Functor, Applicative, Monad)+type RNeovim s = Neovim (Ribosome s) -instance Bifunctor (RiboT s) where-  first f (RiboT r) =-    RiboT $ mapExceptT (fmap $ mapLeft f) r+instance MonadBase IO (Neovim e) where+  liftBase = liftIO -  second = fmap+instance MonadBaseControl IO (Neovim e) where+  type StM (Neovim e) a = a+  liftBaseWith f =+    Neovim (lift $ ReaderT $ \r -> f (peel r))+    where+      peel r ma =+        runReaderT (runResourceT (unNeovim ma)) r+  restoreM = return -class MonadRibo s e m | m -> s, m -> e where-  nvim :: Neovim (Ribosome (TVar s)) a -> m a-  asNeovim :: m a -> Neovim (Ribosome (TVar s)) (Either e a)+newtype Ribo s e a =+  Ribo { unRibo :: ExceptT e (RNeovim s) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadFail, MonadBase IO) -class Monad (t e) => MonadRiboError e t where-  liftEither :: Either e a -> t e a-  mapE :: (e -> e') -> t e a -> t e' a-  catchE :: (e -> t e' a) -> t e a -> t e' a+deriving instance MonadError e (Ribo s e) -instance MonadRibo s e (RiboT s e) where-  nvim = RiboT . ExceptT . fmap Right-  asNeovim = runExceptT . unRiboT+modifyTMVar ::+  MonadIO m =>+  MonadBaseControl IO m =>+  (a -> a) ->+  TMVar a ->+  m a+modifyTMVar f tmvar = do+  a <- f <$> atomically (takeTMVar tmvar)+  atomically $ putTMVar tmvar a+  return a -instance MonadRiboError e (RiboT s) where-  liftEither = RiboT . ExceptT . return-  mapE f = RiboT . mapExceptT (fmap $ mapLeft f) . unRiboT-  catchE f = RiboT . flip Except.catchE (unRiboT . f) . unRiboT+safeModifyTMVarM ::+  MonadIO m =>+  MonadBaseControl IO m =>+  (a -> m a) ->+  TMVar a ->+  m a+safeModifyTMVarM f tmvar =+  process =<< atomically (takeTMVar tmvar)+  where+    process a =+      onException (restore =<< f a) (restore a)+    restore a =+      a <$ (atomically . putTMVar tmvar $ a) -instance MonadError e (RiboT s e) where-  throwError = liftEither . Left-  catchError = flip catchE+deriving instance MonadReader (Ribosome s) (Ribo s e) -stateTVar :: (Functor m, MonadRibo s e m) => m (TVar s)-stateTVar =-  Ribosome.env <$> nvim ask+riboStateVar ::+  MonadReader (Ribosome s) m =>+  m (TMVar (RibosomeState s))+riboStateVar =+  asks (Lens.view Ribosome.state) -instance MonadState s (RiboT s e) where-  get = do-    t <- stateTVar-    nvim $ readTVarIO t-  put newState = do-    t <- stateTVar-    void $ nvim $ atomically $ swapTVar t newState+public ::+  DeepLenses s s' =>+  Lens' (RibosomeState s) s'+public =+  RibosomeState.public . deepLens -unsafeToNeovim :: (MonadRibo s e m, Show e) => m a -> Neovim (Ribosome (TVar s)) a-unsafeToNeovim ra = do-  r <- asNeovim ra-  either (throwString . show) return r+instance DeepLenses s s' => MonadDeepState s s' (Ribo s e) where+  get =+    Lens.view public <$> (atomically . readTMVar =<< riboStateVar)++  modifyM' f =+    Lens.view public <$> (safeModifyTMVarM trans =<< riboStateVar)+    where+      trans = Lens.mapMOf public f++  put =+    modify . const++class Monad m => Nvim m where+  call :: Rpc c a => c -> m (Either RpcError a)++instance Nvim (Neovim e) where+  call = Rpc.call++instance (MonadTrans t, Monad (t m), Nvim m) => Nvim (t m) where+  call = lift . call++instance Nvim (Ribo s e) where+  call = Ribo . call++class (Nvim m, MonadDeepError e RpcError m) => NvimE e m where++instance DeepPrisms e RpcError => NvimE e (Ribo s e) where++instance (DeepPrisms e RpcError, Nvim m, Monad m) => NvimE e (ExceptT e m) where++instance (Functor f, MonadDeepError e RpcError m, Nvim m, Monad m) => NvimE e (FreeT f m) where++instance MonadBaseControl IO (Ribo s e) where+    type StM (Ribo s e) a = Either e a++    liftBaseWith f =+      Ribo $ liftBaseWith $ \ q -> f (q . unRibo)++    restoreM =+      Ribo . restoreM++    {-# INLINABLE liftBaseWith #-}+    {-# INLINABLE restoreM #-}++instance RpcHandler e (Ribosome s) (Ribo s e) where+  native = runRiboE++acall :: (Monad m, Nvim m, Rpc c ()) => c -> m ()+acall c = fromRight () <$> call c++readTv :: Lens' (RibosomeState s) s' -> TMVar (RibosomeState s) -> IO s'+readTv l t = Lens.view l <$> atomically (readTMVar t)++runRibo :: Ribo s e a -> RNeovim s (Either e a)+runRibo =+  runExceptT . unRibo++runRiboE :: Ribo s e a -> ExceptT e (RNeovim s) a+runRiboE =+  unRibo++class MonadIO m => MonadRibo m where+  pluginName :: m Text+  pluginInternal :: m RibosomeInternal+  pluginInternalModify :: (RibosomeInternal -> RibosomeInternal) -> m ()++pluginInternals :: MonadRibo m => (RibosomeInternal -> a) -> m a+pluginInternals = (<$> pluginInternal)++pluginInternalL :: MonadRibo m => Lens' RibosomeInternal a -> m a+pluginInternalL = pluginInternals . Lens.view++pluginInternalPut' :: MonadRibo m => RibosomeInternal -> m ()+pluginInternalPut' s =+  pluginInternalModify (const s)++pluginInternalModifyL :: MonadRibo m => Lens' RibosomeInternal a -> (a -> a) -> m ()+pluginInternalModifyL l f =+  pluginInternalModify $ Lens.over l f++instance MonadRibo (RNeovim s) where+  pluginName =+    asks (Lens.view Ribosome.name)++  pluginInternal =+    Lens.view RibosomeState.internal <$$> atomically . readTMVar =<< asks (Lens.view Ribosome.state)++  pluginInternalModify f =+    void . modifyTMVar (Lens.over RibosomeState.internal f) =<< riboStateVar++instance MonadRibo (Ribo s e) where+  pluginName = Ribo pluginName+  pluginInternal = Ribo pluginInternal+  pluginInternalModify = Ribo . pluginInternalModify++instance {-# OVERLAPPABLE #-} (MonadTrans t, MonadIO (t m), MonadRibo m) => MonadRibo (t m) where+  pluginName = lift pluginName+  pluginInternal = lift pluginInternal+  pluginInternalModify = lift . pluginInternalModify++instance {-# OVERLAPPING #-} MonadIO m => MonadRibo (StateT (StrictRibosome s) m) where+  pluginName =+    StateT.gets (Lens.view StrictRibosome.name)+  pluginInternal =+    StateT.gets (Lens.view $ StrictRibosome.state . RibosomeState.internal)+  pluginInternalModify =+    StateT.modify . Lens.over (StrictRibosome.state . RibosomeState.internal)++getErrors :: MonadRibo m => m Errors+getErrors =+  pluginInternals Ribosome._errors++inspectErrors :: MonadRibo m => (Errors -> a) -> m a+inspectErrors = (<$> getErrors)++modifyErrors :: MonadRibo m => (Errors -> Errors) -> m ()+modifyErrors =+  pluginInternalModifyL Ribosome.errors++prepend :: ∀s' s m a. MonadDeepState s s' m => Lens' s' [a] -> a -> m ()+prepend lens a =+  modify $ Lens.over lens (a:)++inspectHeadE ::+  ∀ s' s e e' m a .+  (MonadDeepState s s' m, MonadDeepError e e' m) =>+  e' ->+  Lens' s' [a] ->+  m a+inspectHeadE err lens = do+  as <- gets $ Lens.view lens+  case as of+    (a : _) -> return a+    _ -> throwHoist err
− lib/Ribosome/Control/Monad/RiboE.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--module Ribosome.Control.Monad.RiboE(-  Ribo,-  RiboE(..),-  riboE,-  liftRibo,-  runRiboE,-  mapE,-  anaE,-  cataE,-  runRiboReport,-) where--import Control.Monad (join)-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except (ExceptT(ExceptT), mapExceptT, runExceptT)-import Data.Either.Combinators (mapLeft)-import Neovim.Context.Internal (Neovim)-import UnliftIO.STM (TVar)--import Ribosome.Control.Ribosome (Ribosome)-import Ribosome.Error.Report (ReportError, reportError)--type Ribo e = Neovim (Ribosome (TVar e))--newtype RiboE s e a =-  RiboE { unRiboE :: ExceptT e (Ribo s) a }-  deriving (Functor, Applicative, Monad, MonadIO)--riboE :: (Ribo s) (Either e a) -> RiboE s e a-riboE = RiboE . ExceptT--liftRibo :: Ribo s a -> RiboE s e a-liftRibo = RiboE . lift--runRiboE :: RiboE s e a -> Ribo s (Either e a)-runRiboE = runExceptT . unRiboE--runRiboReport :: ReportError e => String -> RiboE s e () -> Ribo s ()-runRiboReport componentName ma = do-  result <- runRiboE ma-  case result of-    Right _ -> return ()-    Left e -> reportError componentName e--mapE :: (e -> e') -> RiboE s e a -> RiboE s e' a-mapE f =-  RiboE . trans . unRiboE-  where-    trans = mapExceptT (fmap $ mapLeft f)--anaE :: (e -> e') -> RiboE s e (Either e' a) -> RiboE s e' a-anaE f =-  riboE . fmap (join . mapLeft f) . runRiboE--cataE :: (e' -> e) -> RiboE s e (Either e' a) -> RiboE s e a-cataE f =-  riboE . fmap join . runRiboE . fmap (mapLeft f)--instance MonadError e (RiboE s e) where-  throwError =-    RiboE . throwError-  catchError ma f =-    RiboE $ catchError (unRiboE ma) (unRiboE . f)
− lib/Ribosome/Control/Monad/State.hs 
@@ -1,91 +0,0 @@-module Ribosome.Control.Monad.State(-  riboStateLocalT,-  riboStateT,-  riboStateLocal,-  riboState,-  modifyL,-  prepend,-  riboStateLocalE,-  riboStateE,-  runRiboStateE,-) where--import Control.Lens (Lens')-import qualified Control.Lens as Lens (over, view, set)-import Control.Monad.State.Class (MonadState, modify)-import Control.Monad.Trans.Class (MonadTrans(lift))-import Control.Monad.Trans.Except (ExceptT)-import Control.Monad.Trans.State (StateT, runStateT)-import Ribosome.Control.Monad.RiboE (Ribo, RiboE(..), runRiboE)-import qualified Ribosome.Control.Ribo as Ribo (inspect, modify)--riboStateLocalT ::-  (Monad (t (Ribo s)), MonadTrans t) =>-  Lens' s s' ->-  StateT s' (ExceptT e (t (Ribo s))) a ->-  ExceptT e (t (Ribo s)) a-riboStateLocalT zoom ma = do-  state <- lift $ lift $ Ribo.inspect $ Lens.view zoom-  (output, newState) <- runStateT ma state-  lift $ lift $ Ribo.modify $ Lens.set zoom newState-  return output--riboStateT ::-  (Monad (t (Ribo s)), MonadTrans t) =>-  StateT s (ExceptT e (t (Ribo s))) a ->-  ExceptT e (t (Ribo s)) a-riboStateT =-  riboStateLocalT id--riboStateLocalE ::-  Lens' s s' ->-  StateT s' (ExceptT e (Ribo s)) a ->-  RiboE s e a-riboStateLocalE zoom ma = RiboE $ do-  state <- lift $ Ribo.inspect $ Lens.view zoom-  (output, newState) <- runStateT ma state-  lift $ Ribo.modify $ Lens.set zoom newState-  return output--riboStateE ::-  StateT s (ExceptT e (Ribo s)) a ->-  RiboE s e a-riboStateE =-  riboStateLocalE id--runRiboStateE ::-  StateT s (ExceptT e (Ribo s)) a ->-  Ribo s (Either e a)-runRiboStateE = runRiboE . riboStateE--riboStateLocal ::-  Lens' s s' ->-  StateT s' (Ribo s) a ->-  Ribo s a-riboStateLocal zoom ma = do-  state <- Ribo.inspect $ Lens.view zoom-  (output, newState) <- runStateT ma state-  Ribo.modify $ Lens.set zoom newState-  return output--riboState ::-  StateT s (Ribo s) a ->-  Ribo s a-riboState =-  riboStateLocal id--modifyL ::-  (MonadState s m) =>-  Lens' s a ->-  (a -> a) ->-  m ()-modifyL lens f =-  modify $ Lens.over lens f--prepend ::-  (MonadState s m) =>-  Lens' s [a] ->-  a ->-  m ()-prepend lens a =-  modifyL lens (a :)
− lib/Ribosome/Control/Monad/Trans/Ribo.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}--module Ribosome.Control.Monad.Trans.Ribo where--import Control.Concurrent.STM.TVar (swapTVar)-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT)-import Control.Monad.Trans.Class-import Control.Monad.IO.Class (MonadIO)-import qualified Control.Monad.Trans.Except as Except (catchE)-import Data.Bifunctor (Bifunctor(..))-import Data.Either.Combinators (mapLeft)-import Data.Functor (void)-import UnliftIO.Exception (throwString)-import UnliftIO.STM (TVar, atomically, readTVarIO)-import Neovim (ask)-import Neovim.Context.Internal (Neovim)-import Ribosome.Control.Ribosome (Ribosome)-import qualified Ribosome.Control.Ribosome as Ribosome (env)--type Ribo e = Neovim (Ribosome (TVar e))--newtype RiboT t s e a =-  RiboT { unRiboT :: ExceptT e (t (Ribo s)) a }--deriving instance Functor (t (Ribo s)) => Functor (RiboT t s e)-deriving instance Monad (t (Ribo s)) => Applicative (RiboT t s e)-deriving instance Monad (t (Ribo s)) => Monad (RiboT t s e)-deriving instance MonadIO (t (Ribo s)) => MonadIO (RiboT t s e)-deriving instance Monad (t (Ribo s)) => MonadError e (RiboT t s e)--nvim :: MonadTrans t => Neovim (Ribosome (TVar s)) a -> RiboT t s e a-nvim = RiboT . ExceptT . lift . fmap Right--asNeovim :: RiboT t s e a -> t (Ribo s) (Either e a)-asNeovim = runExceptT . unRiboT--asNeovimWith :: (∀ b. t (Ribo s) b -> Ribo s b) -> RiboT t s e a -> Ribo s (Either e a)-asNeovimWith run = run . runExceptT . unRiboT--mapE :: (Functor (t (Ribo s))) => (e -> e') -> RiboT t s e a -> RiboT t s e' a-mapE f =-  RiboT . trans . unRiboT-  where-    trans = mapExceptT (fmap $ mapLeft f)--liftEither :: (Monad (t (Ribo s))) => Either e a -> RiboT t s e a-liftEither = RiboT . ExceptT . return--catchE :: (Monad (t (Ribo s))) => (e -> RiboT t s e' a) -> RiboT t s e a -> RiboT t s e' a-catchE f = RiboT . flip Except.catchE (unRiboT . f) . unRiboT--stateTVar :: (MonadTrans t, Functor (t (Ribo s))) => RiboT t s e (TVar s)-stateTVar =-  Ribosome.env <$> nvim ask--toException :: Show e => Ribo s (Either e a) -> Ribo s a-toException ma = ma >>= either (throwString . show) return--unsafeToNeovim :: (MonadTrans t, Monad (t (Ribo s)), Show e) => RiboT t s e a -> t (Ribo s) a-unsafeToNeovim ra = do-  r <- asNeovim ra-  lift $ either (throwString . show) return r--unsafeToNeovimWith :: Show e => (∀ b. t (Ribo s) b -> Ribo s b) -> RiboT t s e a -> Ribo s a-unsafeToNeovimWith run =-  toException . run . asNeovim--instance (MonadTrans t, Monad (t (Ribo s))) => MonadState s (RiboT t s e) where-  get = do-    t <- stateTVar-    nvim $ readTVarIO t-  put newState = do-    t <- stateTVar-    void $ nvim $ atomically $ swapTVar t newState--instance (Functor (t (Ribo s))) => Bifunctor (RiboT t s) where-  first = mapE-  second = fmap
− lib/Ribosome/Control/Monad/Trans/Unlift.hs 
@@ -1,15 +0,0 @@-module Ribosome.Control.Monad.Trans.Unlift(-  MonadUnlift(..),-) where--import Control.Monad.Trans.Except (ExceptT, mapExceptT)--class MonadUnlift t where-  unlift :: Monad m => (m a -> m b) -> t m a -> t m b--instance MonadUnlift (ExceptT e) where-  unlift f =-    mapExceptT (>>= trans)-    where-      trans (Left e) = return $ Left e-      trans (Right a) = Right <$> f (return a)
− lib/Ribosome/Control/Ribo.hs 
@@ -1,79 +0,0 @@-module Ribosome.Control.Ribo(-  Ribo,-  state,-  swap,-  put,-  inspect,-  modify,-  name,-  prepend,-  modifyL,-  riboInternal,-  getErrors,-  inspectErrors,-  modifyErrors,-) where--import Control.Concurrent.STM.TVar (modifyTVar, swapTVar)-import Control.Lens (Lens')-import qualified Control.Lens as Lens (over)-import Data.Functor (void)-import Neovim (Neovim, ask)-import UnliftIO.STM (TVar, atomically, readTVarIO)--import Ribosome.Control.Ribosome (Ribosome(Ribosome), RibosomeInternal)-import qualified Ribosome.Control.Ribosome as Ribosome (errors, _errors)-import Ribosome.Data.Errors (Errors)--type Ribo e = Neovim (Ribosome e)--state :: Ribo (TVar e) e-state = do-  Ribosome _ _ t <- ask-  readTVarIO t--swap :: e -> Ribo (TVar e) e-swap newState = do-  Ribosome _ _ t <- ask-  atomically $ swapTVar t newState--put :: e -> Ribo (TVar e) ()-put = void . swap--inspect :: (e -> a) -> Ribo (TVar e) a-inspect f = fmap f state--modify :: (e -> e) -> Ribo (TVar e) ()-modify f = do-  Ribosome _ _ t <- ask-  atomically $ modifyTVar t f--modifyL :: Lens' s a -> (a -> a) -> Ribo (TVar s) ()-modifyL lens f =-  modify $ Lens.over lens f--prepend :: Lens' s [a] -> a -> Ribo (TVar s) ()-prepend lens a =-  modifyL lens (a :)--name :: Ribo e String-name = do-  Ribosome n _ _ <- ask-  return n--riboInternal :: Ribo d RibosomeInternal-riboInternal = do-  Ribosome _ intTv _ <- ask-  readTVarIO intTv--getErrors :: Ribo e Errors-getErrors =-  Ribosome.errors <$> riboInternal--inspectErrors :: (Errors -> a) -> Ribo e a-inspectErrors f = fmap f getErrors--modifyErrors :: (Errors -> Errors) -> Ribo e ()-modifyErrors f = do-  Ribosome _ intTv _ <- ask-  atomically $ modifyTVar intTv $ Lens.over Ribosome._errors f
lib/Ribosome/Control/Ribosome.hs view
@@ -1,50 +1,56 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveAnyClass #-} -module Ribosome.Control.Ribosome(-  Ribosome (..),-  RibosomeInternal (..),-  Locks,-  newRibosome,-  _locks,-  _errors,-  newInternalTVar,-  _internal,-) where+module Ribosome.Control.Ribosome where -import Control.Lens (makeClassy_)+import Control.Lens (makeClassy) import Control.Monad.IO.Class (MonadIO)-import Data.Default (def)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map (empty)-import UnliftIO.STM (TVar, newTVarIO, TMVar)+import Data.Default (Default(def))+import Data.Functor.Syntax ((<$$>))+import Data.Map (Map)+import Data.MessagePack (Object)+import GHC.Generics (Generic)+import UnliftIO.STM (TMVar, TMVar, newTMVarIO) +import Path (Abs, Dir, Path) import Ribosome.Data.Errors (Errors)+import Ribosome.Data.Scratch (Scratch) -type Locks = Map String (TMVar ())+type Locks = Map Text (TMVar ())  data RibosomeInternal =   RibosomeInternal {-    locks :: Locks,-    errors :: Errors+    _locks :: Locks,+    _errors :: Errors,+    _scratch :: Map Text Scratch,+    _watchedVariables :: Map Text Object,+    _projectDir :: Maybe (Path Abs Dir)   }-makeClassy_ ''RibosomeInternal+  deriving (Generic, Default) -data Ribosome e =+makeClassy ''RibosomeInternal++data RibosomeState s =+  RibosomeState {+    _internal :: RibosomeInternal,+    _public :: s+  }+  deriving (Generic, Default)++makeClassy ''RibosomeState++data Ribosome s =   Ribosome {-    name :: String,-    internal :: TVar RibosomeInternal,-    env :: e+    _name :: Text,+    _state :: TMVar (RibosomeState s)   }-makeClassy_ ''Ribosome -newInternalTVar :: MonadIO m => m (TVar RibosomeInternal)-newInternalTVar = newTVarIO (RibosomeInternal Map.empty def)+makeClassy ''Ribosome -newRibosome :: MonadIO m => String -> e -> m (Ribosome (TVar e))-newRibosome name' env' = do-  envTv <- newTVarIO env'-  intTv <- newInternalTVar-  return $ Ribosome name' intTv envTv+newRibosomeTMVar :: MonadIO m => s -> m (TMVar (RibosomeState s))+newRibosomeTMVar s =+  newTMVarIO (RibosomeState def s)++newRibosome :: MonadIO m => Text -> s -> m (Ribosome s)+newRibosome name' =+  Ribosome name' <$$> newRibosomeTMVar
+ lib/Ribosome/Control/StrictRibosome.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Control.StrictRibosome where++import Control.Lens (makeClassy)++import Ribosome.Control.Ribosome (RibosomeState)++data StrictRibosome s =+  StrictRibosome {+    _name :: Text,+    _state :: RibosomeState s+    }++makeClassy ''StrictRibosome++instance Default s => Default (StrictRibosome s) where+  def = StrictRibosome "default" def
+ lib/Ribosome/Data/Conduit.hs view
@@ -0,0 +1,105 @@+module Ribosome.Data.Conduit where++import Conduit (ConduitT, runConduit, yield, (.|))+import Control.Concurrent.Lifted (fork, killThread)+import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan, newTBMChan, readTBMChan, writeTBMChan)+import Control.Concurrent.STM.TMVar (TMVar, newTMVar)+import Control.Exception.Lifted (bracket, finally)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Conduit.Combinators as Conduit (mapM_)++import Ribosome.Control.Monad.Ribo (modifyTMVar)++withTBMChan ::+  MonadIO m =>+  MonadBaseControl IO m =>+  Int ->+  (TBMChan a -> m b) ->+  m b+withTBMChan bound =+  bracket acquire release+  where+    acquire =+      atomically (newTBMChan bound)+    release =+      atomically . closeTBMChan++sourceChan ::+  MonadIO m =>+  TBMChan a ->+  ConduitT () a m ()+sourceChan chan =+  loop+  where+    loop =+      traverse_ recurse =<< atomically (readTBMChan chan)+    recurse a =+      yield a *> loop++sourceTerminated ::+  MonadIO m =>+  MonadBaseControl IO m =>+  TMVar Int ->+  TBMChan a ->+  m ()+sourceTerminated var chan = do+  n <- modifyTMVar (subtract 1) var+  when (n == 0) (atomically $ closeTBMChan chan)++withSourcesInChanAs ::+  MonadIO m =>+  MonadBaseControl IO m =>+  (ConduitT () a m () -> m b) ->+  [ConduitT () a m ()] ->+  TBMChan a ->+  m b+withSourcesInChanAs executor sources chan = do+  activeSources <- atomically $ newTMVar (length sources)+  threadIds <- traverse (fork . start activeSources) sources+  finally listen (release threadIds)+  where+    release =+      traverse_ killThread+    listen =+      executor $ sourceChan chan+    start activeSources source = do+      runConduit (source .| Conduit.mapM_ (atomically . writeTBMChan chan))+      sourceTerminated activeSources chan++simpleExecutor ::+  Monad m =>+  ConduitT a Void m b ->+  ConduitT () a m () ->+  m b+simpleExecutor consumer s =+  runConduit $ s .| consumer++withSourcesInChan ::+  MonadIO m =>+  MonadBaseControl IO m =>+  ConduitT a Void m b ->+  [ConduitT () a m ()] ->+  TBMChan a ->+  m b+withSourcesInChan =+  withSourcesInChanAs . simpleExecutor++withMergedSourcesAs ::+  MonadIO m =>+  MonadBaseControl IO m =>+  (ConduitT () a m () -> m b) ->+  Int ->+  [ConduitT () a m ()] ->+  m b+withMergedSourcesAs executor bound sources =+  withTBMChan bound (withSourcesInChanAs executor sources)++withMergedSources ::+  MonadIO m =>+  MonadBaseControl IO m =>+  ConduitT a Void m b ->+  Int ->+  [ConduitT () a m ()] ->+  m b+withMergedSources =+  withMergedSourcesAs . simpleExecutor
+ lib/Ribosome/Data/Conduit/Composition.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE CPP #-}++module Ribosome.Data.Conduit.Composition where++import Conduit+import qualified Control.Concurrent.Async.Lifted as A+import Control.Concurrent.Async.Lifted hiding (link2)+import Control.Concurrent.STM hiding (atomically, newTVarIO)+import Control.Exception.Lifted (finally)+import Control.Monad hiding (forM_)+import Control.Monad.Base (MonadBase, liftBase)+import Control.Monad.Loops+import Control.Monad.Trans.Resource+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Cereal as C+import qualified Data.Conduit.List as CL+import Data.Foldable (forM_)+import Data.Serialize+import GHC.Exts (Constraint)+import Prelude hiding (get, put)+import System.Directory (removeFile)+import System.IO++-- | Concurrently join the producer and consumer, using a bounded queue of the+-- given size. The producer will block when the queue is full, if it is+-- producing faster than the consumers is taking from it. Likewise, if the+-- consumer races ahead, it will block until more input is available.+--+-- Exceptions are properly managed and propagated between the two sides, so+-- the net effect should be equivalent to not using buffer at all, save for+-- the concurrent interleaving of effects.+--+-- The underlying monad must always be an instance of+-- 'MonadBaseControl IO'.  If at least one of the two conduits is a+-- 'CFConduit', it must additionally be a in instance of+-- 'MonadResource'.+--+-- This function is similar to '$$'; for one more like '=$=', see+-- 'buffer''.+--+-- >>> buffer 1 (CL.sourceList [1,2,3]) CL.consume+-- [1,2,3]+buffer :: (CCatable c1 c2 c3, CRunnable c3, RunConstraints c3 m)+          => Int -- ^ Size of the bounded queue in memory.+          -> c1 () x m ()+          -> c2 x Void m r+          -> m r+buffer i c1 c2 = runCConduit (buffer' i c1 c2)++-- | An operator form of 'buffer'.  In general you should be able to replace+-- any use of '$$' with '$$&' and suddenly reap the benefit of+-- concurrency, if your conduits were spending time waiting on each other.+--+-- The underlying monad must always be an instance of+-- 'MonadBaseControl IO'.  If at least one of the two conduits is a+-- 'CFConduit', it must additionally be a in instance of+-- 'MonadResource'.+--+-- >>> CL.sourceList [1,2,3] $$& CL.consume+-- [1,2,3]+--+-- It can be combined with '$=&' and '$='.  This creates two threads;+-- the first thread produces the list and the second thread does the+-- map and the consume:+--+-- >>> CL.sourceList [1,2,3] $$& mapC (*2) $= CL.consume+-- [2,4,6]+--+-- This creates three threads.  The three conduits all run in their+-- own threads:+--+-- >>> CL.sourceList [1,2,3] $$& mapC (*2) $=& CL.consume+-- [2,4,6]+--+-- >>> CL.sourceList [1,2,3] $$& (mapC (*2) $= mapC (+1)) $=& CL.consume+-- [3,5,7]+($$&) :: (CCatable c1 c2 c3, CRunnable c3, RunConstraints c3 m) => c1 () x m () -> c2 x Void m r -> m r+a $$& b = runCConduit (a =$=& b)+infixr 0 $$&++-- | An operator form of 'buffer''.  In general you should be able to replace+-- any use of '=$=' with '=$=&' and '$$' either with '$$&' or '=$='+-- and 'runCConduit' and suddenly reap the benefit of concurrency, if+-- your conduits were spending time waiting on each other.+--+-- >>> runCConduit $ CL.sourceList [1,2,3] =$=& CL.consume+-- [1,2,3]+(=$=&) :: (CCatable c1 c2 c3) => c1 i x m () -> c2 x o m r -> c3 i o m r+a =$=& b = buffer' 64 a b+infixr 2 =$=&++-- | An alias for '=$=&' by analogy with '=$=' and '$='.+($=&) :: (CCatable c1 c2 c3) => c1 i x m () -> c2 x o m r -> c3 i o m r+($=&) = (=$=&)+infixl 1 $=&++-- | An alias for '=$=&' by analogy with '=$=' and '=$'.+(=$&) :: (CCatable c1 c2 c3) => c1 i x m () -> c2 x o m r -> c3 i o m r+(=$&) = (=$=&)+infixr 2 =$&++-- | Conduits are concatenable; this class describes how.+-- class CCatable (c1 :: * -> * -> (* -> *) -> * -> *) (c2 :: * -> * -> (* -> *) -> * -> *) (c3 :: * -> * -> (* -> *) -> * -> *) | c1 c2 -> c3 where+class CCatable c1 c2 (c3 :: * -> * -> (* -> *) -> * -> *) | c1 c2 -> c3 where+  -- | Concurrently join the producer and consumer, using a bounded queue of the+  -- given size. The producer will block when the queue is full, if it is+  -- producing faster than the consumers is taking from it. Likewise, if the+  -- consumer races ahead, it will block until more input is available.+  --+  -- Exceptions are properly managed and propagated between the two sides, so+  -- the net effect should be equivalent to not using buffer at all, save for+  -- the concurrent interleaving of effects.+  --+  -- This function is similar to '=$='; for one more like '$$', see+  -- 'buffer'.+  --+  -- >>> runCConduit $ buffer' 1 (CL.sourceList [1,2,3]) CL.consume+  -- [1,2,3]+  buffer' :: Int -- ^ Size of the bounded queue in memory+             -> c1 i x m ()+             -> c2 x o m r+             -> c3 i o m r++-- | Like 'buffer', except that when the bounded queue is overflowed, the+-- excess is cached in a local file so that consumption from upstream may+-- continue. When the queue becomes exhausted by yielding, it is filled+-- from the cache until all elements have been yielded.+--+-- Note that the maximum amount of memory consumed is equal to (2 *+-- memorySize + 1), so take this into account when picking a chunking size.+--+-- This function is similar to '$$'; for one more like '=$=', see+-- 'bufferToFile''.+--+-- >>> runResourceT $ bufferToFile 1 Nothing "/tmp" (CL.sourceList [1,2,3]) CL.consume+-- [1,2,3]+bufferToFile :: (CFConduitLike c1, CFConduitLike c2, Serialize x, MonadBaseControl IO m, MonadIO m, MonadResource m, MonadThrow m)+                => Int -- ^ Size of the bounded queue in memory+                -> Maybe Int -- ^ Max elements to keep on disk at one time+                -> FilePath -- ^ Directory to write temp files to+                -> c1 () x m ()+                -> c2 x Void m r+                -> m r+bufferToFile bufsz dsksz tmpDir c1 c2 = runCConduit (bufferToFile' bufsz dsksz tmpDir c1 c2)++-- | Like 'buffer'', except that when the bounded queue is overflowed, the+-- excess is cached in a local file so that consumption from upstream may+-- continue. When the queue becomes exhausted by yielding, it is filled+-- from the cache until all elements have been yielded.+--+-- Note that the maximum amount of memory consumed is equal to (2 *+-- memorySize + 1), so take this into account when picking a chunking size.+--+-- This function is similar to '=$='; for one more like '$$', see+-- 'bufferToFile'.+--+-- >>> runResourceT $ runCConduit $ bufferToFile' 1 Nothing "/tmp" (CL.sourceList [1,2,3]) CL.consume+-- [1,2,3]+--+-- It is frequently convenient to define local function to use this in operator form:+--+-- >>> :{+-- runResourceT $ do+--   let buf c = bufferToFile' 10 Nothing "/tmp" c -- eta-conversion to avoid monomorphism restriction+--   runCConduit $ CL.sourceList [0x30, 0x31, 0x32] `buf` mapC (toEnum :: Int -> Char) `buf` CL.consume+-- :}+-- "012"+bufferToFile' :: (CFConduitLike c1, CFConduitLike c2, Serialize x)+                 => Int -- ^ Size of the bounded queue in memory+                 -> Maybe Int -- ^ Max elements to keep on disk at one time+                 -> FilePath -- ^ Directory to write temp files to+                 -> c1 i x m ()+                 -> c2 x o m r+                 -> CFConduit i o m r+bufferToFile' bufsz dsksz tmpDir c1 c2 = combine (asCFConduit c1) (asCFConduit c2)+  where combine (FSingle a) b = FMultipleF bufsz dsksz tmpDir a b+        combine (FMultiple i a as) b = FMultiple i a (bufferToFile' bufsz dsksz tmpDir as b)+        combine (FMultipleF bufsz' dsksz' tmpDir' a as) b = FMultipleF bufsz' dsksz' tmpDir' a (bufferToFile' bufsz dsksz tmpDir as b)++-- | Conduits are, once there's a producer on one end and a consumer+-- on the other, runnable.+class CRunnable c where+  type RunConstraints c (m :: * -> *) :: Constraint+  -- | Execute a conduit concurrently.  This is the concurrent+  -- equivalent of 'runConduit'.+  --+  -- The underlying monad must always be an instance of+  -- 'MonadBaseControl IO'.  If the conduits is a 'CFConduit', it must+  -- additionally be a in instance of 'MonadResource'.+  runCConduit :: (RunConstraints c m) => c () Void m r -> m r++instance CCatable ConduitT ConduitT CConduit where+  buffer' i a b = buffer' i (Single a) (Single b)++instance CCatable ConduitT CConduit CConduit where+  buffer' i a b = buffer' i (Single a) b++instance CCatable ConduitT CFConduit CFConduit where+  buffer' i a b = buffer' i (asCFConduit a) b++instance CCatable CConduit ConduitT CConduit where+  buffer' i a b = buffer' i a (Single b)++instance CCatable CConduit CConduit CConduit where+  buffer' i (Single a) b = Multiple i a b+  buffer' i (Multiple i' a as) b = Multiple i' a (buffer' i as b)++instance CCatable CConduit CFConduit CFConduit where+  buffer' i a b = buffer' i (asCFConduit a) b++instance CCatable CFConduit ConduitT CFConduit where+  buffer' i a b = buffer' i a (asCFConduit b)++instance CCatable CFConduit CConduit CFConduit where+  buffer' i a b = buffer' i a (asCFConduit b)++instance CCatable CFConduit CFConduit CFConduit where+  buffer' i (FSingle a) b = FMultiple i a b+  buffer' i (FMultiple i' a as) b = FMultiple i' a (buffer' i as b)+  buffer' i (FMultipleF bufsz dsksz tmpDir a as) b = FMultipleF bufsz dsksz tmpDir a (buffer' i as b)++instance CRunnable ConduitT where+  type RunConstraints ConduitT m = (Monad m)+  runCConduit = runConduit++instance CRunnable CConduit where+  type RunConstraints CConduit m = (MonadBaseControl IO m, MonadIO m)+  runCConduit (Single c) = runConduit c+  runCConduit (Multiple bufsz c cs) = do+    chan <- liftIO $ newTBQueueIO bufsz+    withAsync (sender chan c) $ \c' ->+      stage chan c' cs++instance CRunnable CFConduit where+  type RunConstraints CFConduit m = (MonadBaseControl IO m, MonadIO m, MonadResource m, MonadThrow m)+  runCConduit (FSingle c) = runConduit c+  runCConduit (FMultiple bufsz c cs) = do+    chan <- liftIO $ newTBQueueIO bufsz+    withAsync (sender chan c) $ \c' ->+      fstage (receiver chan) c' cs+  runCConduit (FMultipleF bufsz filemax tempDir c cs) = do+    context <- liftIO $ BufferContext <$> newTBQueueIO bufsz+                                      <*> newTQueueIO+                                      <*> newTVarIO filemax+                                      <*> newTVarIO False+                                      <*> pure tempDir+    withAsync (fsender context c) $ \c' ->+      fstage (freceiver context) c' cs++-- | A "concurrent conduit", in which the stages run in parallel with+-- a buffering queue between them.+data CConduit i o m r where+  Single :: ConduitT i o m r -> CConduit i o m r+  Multiple :: Int -> ConduitT i x m () -> CConduit x o m r -> CConduit i o m r++-- C.C.A.L's link2 has the wrong type:  https://github.com/maoe/lifted-async/issues/16+link2 :: MonadBase IO m => Async a -> Async b -> m ()+link2 = (liftBase .) . A.link2++-- Combines a producer with a queue, sending it everything the+-- producer produces.+sender :: (MonadIO m) => TBQueue (Maybe o) -> ConduitT () o m () -> m ()+sender chan input = do+  runConduit $ input .| mapM_C (send chan . Just)+  send chan Nothing++-- One "layer" of withAsync in a CConduit run.+stage :: (MonadBaseControl IO m, MonadIO m) => TBQueue (Maybe i) -> Async x -> CConduit i Void m r -> m r+stage chan prevAsync (Single c) =+  -- The last layer; feed the output of "chan" into the conduit and+  -- wait for the result.+  withAsync (runConduit $ receiver chan .| c) $ \c' -> do+    link2 prevAsync c'+    wait c'+stage chan prevAsync (Multiple bufsz c cs) = do+  -- not the last layer, so take the input from "chan", have this+  -- layer's conduit process it, and send the conduit's output to the+  -- next layer.+  chan' <- liftIO $ newTBQueueIO bufsz+  withAsync (sender chan' $ receiver chan .| c) $ \c' -> do+    link2 prevAsync c'+    stage chan' c' cs++-- A Producer which produces the values of the given channel until+-- Nothing is received.  This is the other half of "sender".+receiver :: (MonadIO m) => TBQueue (Maybe o) -> ConduitT () o m ()+receiver chan = do+  mx <- recv chan+  case mx of+   Nothing -> return ()+   Just x -> yield x >> receiver chan++-- | A "concurrent conduit", in which the stages run in parallel with+-- a buffering queue and possibly a disk file between them.+data CFConduit i o m r where+  FSingle :: ConduitT i o m r -> CFConduit i o m r+  FMultiple :: Int -> ConduitT i x m () -> CFConduit x o m r -> CFConduit i o m r+  FMultipleF :: (Serialize x) => Int -> Maybe Int -> FilePath -> ConduitT i x m () -> CFConduit x o m r -> CFConduit i o m r++class CFConduitLike a where+  asCFConduit :: a i o m r -> CFConduit i o m r++instance CFConduitLike ConduitT where+  asCFConduit = FSingle++instance CFConduitLike CConduit where+  asCFConduit (Single c) = FSingle c+  asCFConduit (Multiple i c cs) = FMultiple i c (asCFConduit cs)++instance CFConduitLike CFConduit where+  asCFConduit = id++data BufferContext m a = BufferContext { chan :: TBQueue a+                                       , restore :: TQueue (ConduitT () a m ())+                                       , slotsFree :: TVar (Maybe Int)+                                       , done :: TVar Bool+                                       , tempDir :: FilePath+                                       }++-- The file-backed equivlent of "sender".  This sends the values+-- generated by "input" to the "chan" in the BufferContext until it+-- gets full, then flushes it to disk via "persistChan".+fsender :: (MonadIO m, MonadResource m, Serialize x, MonadThrow m) => BufferContext m x -> ConduitT () x m () -> m ()+fsender bc@BufferContext{..} input = do+  runConduit $ input .| mapM_C f+  liftIO $ atomically $ writeTVar done True+  where+    f x = join $ liftIO $ atomically $+      (writeTBQueue chan x >> return (return ())) `orElse` do+        action <- persistChan bc+        writeTBQueue chan x+        return action++-- Connect a stage to another stage via either an in-memory queue or a+-- disk buffer.  This is the file-backed equivalent of "stage".+fstage :: (MonadBaseControl IO m, MonadIO m, MonadResource m, MonadThrow m) => ConduitT () i m () -> Async x -> CFConduit i Void m r -> m r+fstage prevStage prevAsync (FSingle c) =+  -- The final conduit in the chain; just accept everything from+  -- the previous stage and wait for the result.+  withAsync (runConduit $ prevStage .| c) $ \c' -> do+    link2 prevAsync c'+    wait c'+fstage prevStage prevAsync (FMultiple bufsz c cs) = do+  -- This stage is connected to the next via a non-file-backed+  -- channel, so it just uses "sender" and "reciever" in the same way+  -- "stage" does.+  chan' <- liftIO $ newTBQueueIO bufsz+  withAsync (sender chan' $ prevStage .| c) $ \c' -> do+    link2 prevAsync c'+    fstage (receiver chan') c' cs+fstage prevStage prevAsync (FMultipleF bufsz dsksz tempDir c cs) = do+  -- This potentially needs to write its output to a file, so it uses+  -- "fsender" send and tells the next stage to use "freceiver" to read.+  bc <- liftIO $ BufferContext <$> newTBQueueIO bufsz+                               <*> newTQueueIO+                               <*> newTVarIO dsksz+                               <*> newTVarIO False+                               <*> pure tempDir+  withAsync (fsender bc $ prevStage .| c) $ \c' -> do+    link2 prevAsync c'+    fstage (freceiver bc) c' cs++-- Receives from disk files or the in-memory queue if no spill-to-disk+-- has occurred.+freceiver :: (MonadIO m) => BufferContext m o -> ConduitT () o m ()+freceiver BufferContext{..} = loop where+  loop = do+    (src, exit) <- liftIO $ atomically $ do+      (readTQueue restore >>= (\action -> return (action, False))) `orElse` do+        xs <- exhaust chan+        isDone <- readTVar done+        return (CL.sourceList xs, isDone)+    src+    unless exit loop++-- The channel is full, so (return an action which will) spill it to disk, unless too+-- many items are there already.+persistChan :: (MonadIO m, MonadResource m, Serialize o, MonadThrow m) => BufferContext m o -> STM (m ())+persistChan BufferContext{..} = do+  xs <- exhaust chan+  mslots <- readTVar slotsFree+  let len = length xs+  forM_ mslots $ \slots -> check (len < slots)+  filePath <- newEmptyTMVar+  writeTQueue restore $ do+    (path, key) <- liftIO $ atomically $ takeTMVar filePath+    CB.sourceFile path .| do+      C.conduitGet2 get+      liftIO $ atomically $ modifyTVar slotsFree (fmap (+ len))+      release key+  case xs of+   [] -> return (return ())+   _ -> do+     modifyTVar slotsFree (fmap (subtract len))+     return $ do+       (key, (path, h)) <- allocate (openBinaryTempFile tempDir "conduit.bin") (\(path, h) -> hClose h `finally` removeFile path)+       liftIO $ do+         runConduit $ CL.sourceList xs .| C.conduitPut put .| CB.sinkHandle h+         hClose h+         atomically $ putTMVar filePath (path, key)++exhaust :: TBQueue a -> STM [a]+exhaust chan = whileM (not <$> isEmptyTBQueue chan) (readTBQueue chan)++recv :: (MonadIO m) => TBQueue a -> m a+recv c = liftIO . atomically $ readTBQueue c++send :: (MonadIO m) => TBQueue a -> a -> m ()+send c = liftIO . atomically . writeTBQueue c++ccMap :: (∀ i1 . ConduitT i1 o1 m a -> ConduitT i1 o2 m a) -> CConduit i o1 m a -> CConduit i o2 m a+ccMap f =+  go+  where+    go (Single c) =+      Single (f c)+    go (Multiple bufsz l r) =+      Multiple bufsz l (ccMap f r)
lib/Ribosome/Data/ErrorReport.hs view
@@ -8,13 +8,12 @@ ) where  import Control.Lens (makeClassy)-import Prelude hiding (log) import System.Log (Priority)  data ErrorReport =   ErrorReport {-    _user :: String,-    _log :: [String],+    _user :: Text,+    _log :: [Text],     _priority :: Priority   }   deriving (Eq, Show)
lib/Ribosome/Data/Errors.hs view
@@ -13,13 +13,13 @@ import Data.Default (Default) import Data.Map (Map) import qualified Data.Map as Map (toList)-import Data.Text.Prettyprint.Doc (Doc, Pretty(..), align, vsep, line, (<+>), (<>))+import Data.Text.Prettyprint.Doc (Doc, Pretty(..), align, line, vsep, (<+>), (<>)) import Prelude hiding (error)  import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))  newtype ComponentName =-  ComponentName String+  ComponentName Text   deriving (Eq, Ord, Show)  data Error =@@ -49,4 +49,4 @@  instance Pretty Errors where   pretty (Errors errors') =-    pretty ("Errors:" :: String) <> vsep (uncurry prettyComponentErrors <$> Map.toList errors')+    vsep (uncurry prettyComponentErrors <$> Map.toList errors')
+ lib/Ribosome/Data/Mapping.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Data.Mapping where++import Data.DeepPrisms (deepPrisms)+import Data.MessagePack (Object)+import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+import Ribosome.Error.Report.Class (ReportError(..))+import System.Log (Priority(NOTICE, ERROR))++newtype MappingIdent =+  MappingIdent Text+  deriving (Eq, Show)++data Mapping =+  Mapping {+    mappingIdent :: MappingIdent,+    mappingLhs :: Text,+    mappingMode :: Text,+    mappingRemap :: Bool,+    mappingBuffer :: Bool+  }+  deriving (Eq, Show)++data MappingError =+  NoSuchMapping MappingIdent+  |+  InvalidArgs [Object]+  deriving (Eq, Show)++deepPrisms ''MappingError++instance ReportError MappingError where+  errorReport (NoSuchMapping (MappingIdent ident)) =+    ErrorReport ("no mapping defined for `" <> ident <>"`") ["no such mapping: " <> ident] NOTICE+  errorReport (InvalidArgs args) =+    ErrorReport "internal error while executing mapping" ["invalid mapping args:", show args] ERROR
+ lib/Ribosome/Data/PersistError.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Data.PersistError where++import System.Log (Priority(INFO, NOTICE, ERROR))++import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+import Ribosome.Error.Report.Class (ReportError(..))++-- TODO use Path+data PersistError =+  FileNotReadable FilePath+  |+  NoSuchFile FilePath+  |+  Decode FilePath Text+  deriving (Eq, Show)++deepPrisms ''PersistError++instance ReportError PersistError where+  errorReport (FileNotReadable path) =+    ErrorReport msg ["PersistError.FileNotReadable:", toText path] NOTICE+    where+      msg = "persistence file not readable: " <> toText path+  errorReport (NoSuchFile path) =+    ErrorReport msg ["PersistError.SoSuchFile:", toText path] INFO+    where+      msg = "no persistence file present at " <> toText path+  errorReport (Decode path err) =+    ErrorReport msg ["PersistError.Decode:", toText path, err] ERROR+    where+      msg = "invalid data in persistence file, please delete it: " <> toText path
lib/Ribosome/Data/Scratch.hs view
@@ -1,13 +1,13 @@-module Ribosome.Data.Scratch(-  Scratch(..),-) where+module Ribosome.Data.Scratch where -import Neovim (Buffer, Window, Tabpage)+import Ribosome.Nvim.Api.Data (Buffer, Tabpage, Window)  data Scratch =   Scratch {+    scratchName :: Text,     scratchBuffer :: Buffer,     scratchWindow :: Window,+    scratchPrevious :: Window,     scratchTab :: Maybe Tabpage   }   deriving (Eq, Show)
lib/Ribosome/Data/ScratchOptions.hs view
@@ -1,21 +1,39 @@-module Ribosome.Data.ScratchOptions(-  ScratchOptions(..),-  defaultScratchOptions,-) where+module Ribosome.Data.ScratchOptions where  import Data.Default (Default(def)) +import Ribosome.Data.Mapping (Mapping)+import Ribosome.Data.Syntax (Syntax)+ data ScratchOptions =   ScratchOptions {     tab :: Bool,     vertical :: Bool,-    size :: Maybe Int,     wrap :: Bool,-    name :: String+    focus :: Bool,+    resize :: Bool,+    bottom :: Bool,+    size :: Maybe Int,+    maxSize :: Maybe Int,+    syntax :: [Syntax],+    mappings :: [Mapping],+    name :: Text   } -defaultScratchOptions :: String -> ScratchOptions-defaultScratchOptions = ScratchOptions False False Nothing False+defaultScratchOptions :: Text -> ScratchOptions+defaultScratchOptions = ScratchOptions False False False False True True Nothing Nothing [] []  instance Default ScratchOptions where   def = defaultScratchOptions "scratch"++scratchFocus :: ScratchOptions -> ScratchOptions+scratchFocus so =+  so { focus = True }++scratchSyntax :: [Syntax] -> ScratchOptions -> ScratchOptions+scratchSyntax syn so =+  so { syntax = syn }++scratchMappings :: [Mapping] -> ScratchOptions -> ScratchOptions+scratchMappings maps so =+  so { mappings = maps }
+ lib/Ribosome/Data/Setting.hs view
@@ -0,0 +1,8 @@+module Ribosome.Data.Setting where++data Setting a =+  Setting {+    name :: Text,+    prefix :: Bool,+    fallback :: Maybe a+  }
+ lib/Ribosome/Data/SettingError.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Data.SettingError where++import Data.DeepPrisms (deepPrisms)+import Data.Text.Prettyprint.Doc (Doc)+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+import System.Log (Priority(NOTICE))++import Ribosome.Data.ErrorReport (ErrorReport(..))+import Ribosome.Error.Report.Class (ReportError(..))++data SettingError =+  Decode Text (Doc AnsiStyle)+  |+  Unset Text+  deriving Show++deepPrisms ''SettingError++instance ReportError SettingError where+  errorReport (Decode name message) =+    ErrorReport ("invalid setting: " <> name) ["failed to decode setting `" <> name <> "`", show message] NOTICE+  errorReport (Unset name) =+    ErrorReport ("required setting unset: " <> name) ["unset setting: `" <> name <> "`"] NOTICE
+ lib/Ribosome/Data/String.hs view
@@ -0,0 +1,11 @@+module Ribosome.Data.String where++import Data.Char (toUpper)++escapeQuotes :: Char -> String+escapeQuotes '\'' = "''"+escapeQuotes a = [a]++capitalize :: String -> String+capitalize [] = []+capitalize (head' : tail') = toUpper head' : tail'
+ lib/Ribosome/Data/Syntax.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveAnyClass #-}++module Ribosome.Data.Syntax where++import Data.Default (Default(def))+import Data.Map (Map)+import qualified Data.Map as Map (fromList)++data SyntaxItemDetail =+  Keyword {+    kwGroup :: Text,+    kwKeyword :: Text,+    kwOptions :: [Text]+  }+  |+  Match {+    matchGroup :: Text,+    matchPattern :: Text+  }+  |+  Region {+    regionGroup :: Text,+    regionStart :: Text,+    regionEnd :: Text,+    regionSkip :: Maybe Text,+    regionStartOffset :: Text,+    regionEndOffset :: Text+  }+  |+  Verbatim {+    verbatimCommand :: Text+  }+  deriving (Eq, Show)++data SyntaxItem =+  SyntaxItem {+    siDetail :: SyntaxItemDetail,+    siOptions :: [Text],+    siParams :: Map Text Text+  }+  deriving (Eq, Show)++syntaxItem :: SyntaxItemDetail -> SyntaxItem+syntaxItem detail =+  SyntaxItem detail def def++syntaxKeyword :: Text -> Text -> SyntaxItem+syntaxKeyword group' keyword =+  syntaxItem $ Keyword group' keyword def++syntaxMatch :: Text -> Text -> SyntaxItem+syntaxMatch group' pat =+  syntaxItem $ Match group' pat++syntaxRegionOffset :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> SyntaxItem+syntaxRegionOffset group' start end skip ms me =+  syntaxItem $ Region group' start end skip ms me++syntaxRegion :: Text -> Text -> Text -> Maybe Text -> SyntaxItem+syntaxRegion group' start end skip =+  syntaxRegionOffset group' start end skip "" ""++syntaxVerbatim :: Text -> SyntaxItem+syntaxVerbatim =+  syntaxItem . Verbatim++data Highlight =+  Highlight {+    hiGroup :: Text,+    hiValues :: Map Text Text+  }+  deriving (Eq, Show)++syntaxHighlight :: Text -> [(Text, Text)] -> Highlight+syntaxHighlight group' =+  Highlight group' . Map.fromList++data HiLink =+  HiLink {+    hlGroup :: Text,+    hlTarget :: Text+  }+  deriving (Eq, Show)++data Syntax =+  Syntax {+     syntaxItems :: [SyntaxItem],+     syntaxHighlights :: [Highlight],+     syntaxHiLinks :: [HiLink]+  }+  deriving (Eq, Show, Generic, Default)
+ lib/Ribosome/Data/Text.hs view
@@ -0,0 +1,17 @@+module Ribosome.Data.Text where++import Data.Char (toUpper)+import qualified Data.Text as Text (concatMap, cons, singleton, uncons)++escapeQuote :: Char -> Text+escapeQuote '\'' = "''"+escapeQuote a = Text.singleton a++escapeQuotes :: Text -> Text+escapeQuotes = Text.concatMap escapeQuote++capitalize :: Text -> Text+capitalize a =+  maybe "" run (Text.uncons a)+  where+    run (h, t) = Text.cons (toUpper h) t
− lib/Ribosome/Data/Time.hs 
@@ -1,25 +0,0 @@-module Ribosome.Data.Time(-  epochSeconds,-  usleep,-  sleep,-  sleepW,-) where--import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Time.Clock.POSIX (getPOSIXTime)-import GHC.Float (word2Double)--epochSeconds :: MonadIO m => m Int-epochSeconds = liftIO $ fmap round getPOSIXTime--usleep :: MonadIO m => Double -> m ()-usleep =-  liftIO . threadDelay . round--sleep :: MonadIO m => Double -> m ()-sleep seconds =-  usleep $ seconds * 1e6--sleepW :: MonadIO m => Word -> m ()-sleepW = sleep . word2Double
lib/Ribosome/Error/Report.hs view
@@ -1,39 +1,27 @@-module Ribosome.Error.Report(-  ErrorReport(..),-  ReportError(..),-  logErrorReport,-  reportErrorWith,-  reportError,-  reportErrorOr,-  reportErrorOr_,-  printAllErrors,-) where+module Ribosome.Error.Report where -import Control.Monad.IO.Class (liftIO)+import Control.Monad ((<=<))+import Control.Monad.Error.Class (MonadError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except (runExceptT) import Data.Foldable (traverse_)+import Data.Functor (void) import qualified Data.Map as Map (alter)-import Data.Text.Prettyprint.Doc (pretty, line, (<>))+import Data.Text.Prettyprint.Doc (line, pretty, (<>)) import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc)-import System.Log.Logger (logM, Priority(NOTICE, DEBUG))+import System.Log (Priority(NOTICE))  import Ribosome.Api.Echo (echom)-import Ribosome.Control.Monad.Ribo (Ribo)-import qualified Ribosome.Control.Ribo as Ribo (name, modifyErrors, getErrors)+import Ribosome.Control.Monad.Ribo (MonadRibo, Nvim, NvimE, RNeovim, Ribo, runRibo)+import qualified Ribosome.Control.Monad.Ribo as Ribo (getErrors, modifyErrors, pluginName) import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))-import Ribosome.Data.Errors (Errors(Errors), ComponentName(ComponentName), Error(Error))-import Ribosome.Data.Time (epochSeconds)--class ReportError a where-  errorReport :: a -> ErrorReport--instance ReportError [Char] where-  errorReport msg = ErrorReport msg [msg] NOTICE--instance ReportError [[Char]] where-  errorReport (msg:extra) = ErrorReport msg (msg:extra) NOTICE-  errorReport [] = ErrorReport "empty error" ["empty error"] DEBUG+import Ribosome.Data.Errors (ComponentName(ComponentName), Error(Error), Errors(Errors))+import Ribosome.Error.Report.Class (ReportError(..))+import Ribosome.Log (logAs)+import Ribosome.Nvim.Api.RpcCall (RpcError)+import Ribosome.System.Time (epochSeconds) -storeError' :: Int -> String -> ErrorReport -> Errors -> Errors+storeError' :: Int -> Text -> ErrorReport -> Errors -> Errors storeError' time name report (Errors errors) =   Errors (Map.alter alter (ComponentName name) errors)   where@@ -41,37 +29,96 @@     alter Nothing = Just [err]     alter (Just current) = Just (err:current) -storeError :: String -> ErrorReport -> Ribo d ()+storeError :: (MonadRibo m, MonadIO m) => Text -> ErrorReport -> m () storeError name e = do   time <- epochSeconds   Ribo.modifyErrors $ storeError' time name e -logErrorReport :: ErrorReport -> Ribo d ()+logErrorReport ::+  (MonadRibo m, NvimE e m, MonadIO m) =>+  ErrorReport ->+  m () logErrorReport (ErrorReport user logMsgs prio) = do-  name <- Ribo.name-  liftIO $ traverse_ (logM name prio) logMsgs-  echom user+  name <- Ribo.pluginName+  liftIO $ traverse_ (logAs prio name) logMsgs+  when (prio >= NOTICE) (echom user) -reportErrorWith :: String -> (a -> ErrorReport) -> a -> Ribo d ()-reportErrorWith name cons err = do+processErrorReport ::+  (MonadRibo m, NvimE e m, MonadIO m) =>+  Text ->+  ErrorReport ->+  m ()+processErrorReport name report = do   storeError name report   logErrorReport report-  where-    report = cons err -reportError :: ReportError a => String -> a -> Ribo d ()+processErrorReport' ::+  (MonadRibo m, Nvim m, MonadIO m) =>+  Text ->+  ErrorReport ->+  m ()+processErrorReport' name =+  void . runExceptT @RpcError . processErrorReport name++reportErrorWith ::+  (MonadRibo m, NvimE e m, MonadIO m) =>+  Text ->+  (a -> ErrorReport) ->+  a ->+  m ()+reportErrorWith name cons err =+  processErrorReport name (cons err)++reportError ::+  MonadRibo m =>+  NvimE e m =>+  MonadIO m =>+  ReportError a =>+  Text ->+  a ->+  m () reportError name =   reportErrorWith name errorReport -reportErrorOr :: ReportError e => String -> (a -> Ribo d ()) -> Either e a -> Ribo d ()+reportErrorOr ::+  (MonadRibo m, NvimE e m, MonadIO m, ReportError e) =>+  Text ->+  (a -> m ()) ->+  Either e a ->+  m () reportErrorOr name =   either $ reportError name -reportErrorOr_ :: ReportError e => String -> Ribo d () -> Either e a -> Ribo d ()+reportErrorOr_ ::+  (MonadError RpcError m, MonadRibo m, NvimE e m, MonadIO m, ReportError e) =>+  Text ->+  m () ->+  Either e a ->+  m () reportErrorOr_ name =   reportErrorOr name . const -printAllErrors :: Ribo e ()+reportError' ::+  ∀ e m a .+  (MonadRibo m, Nvim m, MonadIO m, ReportError e) =>+  Text ->+  Either e a ->+  m ()+reportError' _ (Right _) =+  return ()+reportError' componentName (Left e) =+  void $ runExceptT @RpcError $ reportError componentName e++printAllErrors :: (MonadRibo m, NvimE e m, MonadIO m) => m () printAllErrors = do   errors <- Ribo.getErrors-  liftIO $ putDoc $ (pretty errors <> line)+  liftIO $ putDoc (pretty errors <> line)++runRiboReport ::+  ∀ e s.+  ReportError e =>+  Text ->+  Ribo s e () ->+  RNeovim s ()+runRiboReport componentName =+  reportError' componentName <=< runRibo
+ lib/Ribosome/Error/Report/Class.hs view
@@ -0,0 +1,59 @@+module Ribosome.Error.Report.Class where++import qualified Data.Text as Text (pack)+import GHC.Generics (+  Generic,+  K1(..),+  M1(..),+  Rep,+  from,+  (:+:)(..),+  )+import System.Log.Logger (Priority(NOTICE, DEBUG))++import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))++class ReportError a where+  errorReport :: a -> ErrorReport+  default errorReport ::+    Generic a =>+    GenReportError (Rep a) =>+    a ->+    ErrorReport+  errorReport =+    genErrorReport . from++class GenReportError f where+  genErrorReport :: f a -> ErrorReport++instance GenReportError f => GenReportError (M1 i c f) where+  genErrorReport =+    genErrorReport . unM1++instance (GenReportError f, GenReportError g) => GenReportError (f :+: g) where+  genErrorReport (L1 a) =+    genErrorReport a+  genErrorReport (R1 a) =+    genErrorReport a++instance ReportError a => GenReportError (K1 i a) where+  genErrorReport =+    errorReport . unK1++instance ReportError [Char] where+  errorReport msg = ErrorReport (Text.pack msg) (Text.pack <$> [msg]) NOTICE++instance ReportError [[Char]] where+  errorReport (msg : extra) = ErrorReport (Text.pack msg) (Text.pack <$> (msg : extra)) NOTICE+  errorReport [] = ErrorReport "empty error" ["empty error"] DEBUG++instance ReportError Text where+  errorReport msg = ErrorReport msg [msg] NOTICE++instance ReportError [Text] where+  errorReport (msg : extra) =+    ErrorReport msg (msg : extra) NOTICE+  errorReport [] = ErrorReport "empty error" ["empty error"] DEBUG++instance ReportError () where+  errorReport _ = ErrorReport "" [] DEBUG
lib/Ribosome/File.hs view
@@ -6,7 +6,7 @@  import Control.Monad.IO.Class (MonadIO, liftIO) import Data.String.Utils (replace)-import System.Directory (getHomeDirectory, canonicalizePath)+import System.Directory (canonicalizePath, getHomeDirectory)  canonicalPathWithHome :: FilePath -> FilePath -> FilePath canonicalPathWithHome = replace "~"
lib/Ribosome/Internal/IO.hs view
@@ -3,14 +3,13 @@   forkNeovim, ) where -import GHC.Conc.Sync (forkIO)+import Control.Concurrent (forkIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask, runReaderT, withReaderT) import Control.Monad.Trans.Resource (runResourceT) import Data.Functor (void)-import Neovim.Context.Internal (Neovim(..), Config(..), retypeConfig, runNeovim)+import Neovim.Context.Internal (Config(..), Neovim(..), retypeConfig, runNeovim) --- try using Contravariant with this retypeNeovim :: (e0 -> e1) -> Neovim e1 a -> Neovim e0 a retypeNeovim transform thunk = do   env <- Neovim ask
lib/Ribosome/Internal/NvimObject.hs view
@@ -1,27 +1,22 @@-module Ribosome.Internal.NvimObject(-  deriveString,-  extractObject,-  extractObjectOr,-) where+module Ribosome.Internal.NvimObject where -import qualified Data.ByteString.UTF8 as UTF8 (fromString)-import Data.Map.Strict (Map, (!?))-import Data.Text.Prettyprint.Doc ((<+>), pretty)-import Neovim (Object(ObjectString), Doc, AnsiStyle, fromObject, NvimObject)+import Data.Map (Map, (!?))+import Data.Text.Prettyprint.Doc (pretty, (<+>))+import Neovim (AnsiStyle, Doc, NvimObject, Object(ObjectString), fromObject) -deriveString :: (String -> a) -> Object -> Either (Doc AnsiStyle) a-deriveString cons o = fmap cons (fromObject o :: Either (Doc AnsiStyle) String)+deriveString :: (Text -> a) -> Object -> Either (Doc AnsiStyle) a+deriveString cons o = fmap cons (fromObject o :: Either (Doc AnsiStyle) Text) -objectKeyMissing :: String -> Maybe Object -> Either (Doc AnsiStyle) Object+objectKeyMissing :: Text -> Maybe Object -> Either (Doc AnsiStyle) Object objectKeyMissing _ (Just o) = Right o-objectKeyMissing key Nothing = Left (pretty ("missing key in nvim data:" :: String) <+> pretty key)+objectKeyMissing key Nothing = Left (pretty ("missing key in nvim data:" :: Text) <+> pretty key) -extractObject :: NvimObject o => String -> Map Object Object -> Either (Doc AnsiStyle) o+extractObject :: NvimObject o => Text -> Map Object Object -> Either (Doc AnsiStyle) o extractObject key data' = do-  value <- objectKeyMissing key $ data' !? (ObjectString . UTF8.fromString) key+  value <- objectKeyMissing key $ data' !? (ObjectString . encodeUtf8) key   fromObject value -extractObjectOr :: NvimObject o => String -> o -> Map Object Object -> o+extractObjectOr :: NvimObject o => Text -> o -> Map Object Object -> o extractObjectOr key default' data' =   case extractObject key data' of     Right a -> a
lib/Ribosome/Log.hs view
@@ -1,35 +1,150 @@-module Ribosome.Log(-  debug,-  info,-  err,-  p,-  prefixed,-  debugR,-) where+module Ribosome.Log where  import Control.Monad.IO.Class (MonadIO, liftIO)-import Neovim (ask)-import Neovim.Log (debugM, infoM, errorM)+import Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as ByteString (toString)+import Data.Foldable (traverse_)+import Data.Text (Text)+import qualified Data.Text as Text (unpack)+import System.Log.Logger (Priority(DEBUG, ERROR, INFO), logM) -import Ribosome.Control.Ribo (Ribo)-import qualified Ribosome.Control.Ribosome as R (name)+import Ribosome.Control.Monad.Ribo (MonadRibo, pluginName) -debug :: (MonadIO m, Show a) => String -> a -> m ()-debug name message = liftIO $ debugM name $ show message+class Loggable a where+  logLines :: a -> [String] -info :: (MonadIO m, Show a) => String -> a -> m ()-info name message = liftIO $ infoM name $ show message+instance {-# OVERLAPPABLE #-} Loggable a => Loggable [a] where+  logLines =+    (>>= logLines) -err :: (MonadIO m, Show a) => String -> a -> m ()-err name message = liftIO $ errorM name $ show message+instance {-# OVERLAPPING #-} Loggable String where+  logLines = pure -p :: (MonadIO m, Show a) => a -> m ()-p = liftIO . print+instance Loggable ByteString where+  logLines = pure . ByteString.toString -prefixed :: (MonadIO m, Show a) => String -> a -> m ()-prefixed prefix a = liftIO $ putStrLn $ prefix ++ ": " ++ show a+instance Loggable Text where+  logLines = pure . Text.unpack -debugR :: String -> Ribo e ()-debugR a = do-  pluginName <- R.name <$> ask-  liftIO $ debugM pluginName a+logAs ::+  Loggable a =>+  MonadIO m =>+  Priority ->+  Text ->+  a ->+  m ()+logAs prio name = liftIO . traverse_ (logM (toString name) prio) . logLines++debugAs ::+  Loggable a =>+  MonadIO m =>+  Text ->+  a ->+  m ()+debugAs =+  logAs DEBUG++infoAs ::+  Loggable a =>+  MonadIO m =>+  Text ->+  a ->+  m ()+infoAs =+  logAs INFO++errAs ::+  Loggable a =>+  MonadIO m =>+  Text ->+  a ->+  m ()+errAs =+  logAs ERROR++prefixed :: (MonadIO m, Show a) => Text -> a -> m ()+prefixed prefix a = liftIO $ putStrLn $ prefix <> ": " <> show a++logR ::+  Loggable a =>+  MonadRibo m =>+  Priority ->+  a ->+  m ()+logR prio message = do+  n <- pluginName+  logAs prio n message++debug ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+debug =+  logR DEBUG++logDebug ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+logDebug = debug++showDebug ::+  Show a =>+  MonadRibo m =>+  Text ->+  a ->+  m ()+showDebug prefix a =+  logDebug @Text (prefix <> " " <> show a)++showDebugM ::+  Show a =>+  MonadRibo m =>+  Text ->+  m a ->+  m a+showDebugM prefix ma = do+  a <- ma+  logDebug @Text (prefix <> " " <> show a)+  return a++info ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+info =+  logR INFO++logInfo ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+logInfo = info++err ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+err =+  logR ERROR++logError ::+  Loggable a =>+  MonadRibo m =>+  a ->+  m ()+logError = err++showError ::+  Show a =>+  MonadRibo m =>+  Text ->+  a ->+  m ()+showError prefix a =+  logError @Text (prefix <> " " <> show a)
+ lib/Ribosome/Mapping.hs view
@@ -0,0 +1,29 @@+module Ribosome.Mapping where++import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginName)+import Ribosome.Data.Mapping (Mapping(Mapping), MappingIdent(MappingIdent))+import Ribosome.Data.Text (capitalize)+import Ribosome.Nvim.Api.Data (Buffer)+import Ribosome.Nvim.Api.IO (vimCommand)++activateMapping :: Mapping -> m ()+activateMapping _ =+  undefined++mapCommand :: Text -> Bool -> Text+mapCommand mode remap =+  mode <> (if remap then "map" else "noremap")++activateBufferMapping ::+  MonadRibo m =>+  NvimE e m =>+  Buffer ->+  Mapping ->+  m ()+activateBufferMapping _ (Mapping (MappingIdent ident) lhs mode remap _) = do+  name <- pluginName+  vimCommand (unwords (cmdline name))+  where+    cmdline name = [cmd, "<buffer>", lhs, ":call", func name <> "('" <> ident <> "')<cr>"]+    cmd = mapCommand mode remap+    func name = capitalize name <> "Mapping"
+ lib/Ribosome/Menu/Data/Menu.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Menu.Data.Menu where++import Ribosome.Menu.Data.MenuItem (MenuItem)++newtype MenuFilter =+  MenuFilter Text+  deriving (Eq, Show)++instance Default MenuFilter where+  def = MenuFilter ""++data Menu =+  Menu {+    _items :: [MenuItem],+    _filtered :: [MenuItem],+    _stack :: [(Text, [MenuItem])],+    _selected :: Int,+    _currentFilter :: MenuFilter+  }+  deriving (Eq, Show, Generic, Default)++deepLenses ''Menu
+ lib/Ribosome/Menu/Data/MenuAction.hs view
@@ -0,0 +1,15 @@+module Ribosome.Menu.Data.MenuAction where++import Ribosome.Menu.Data.MenuEvent (QuitReason)++data MenuAction m a =+  Quit (QuitReason m a)+  |+  Continue+  -- |+  -- Cursor Int+  |+  Render Bool+  -- |+  -- Submenu Text+  deriving Show
+ lib/Ribosome/Menu/Data/MenuConfig.hs view
@@ -0,0 +1,16 @@+module Ribosome.Menu.Data.MenuConfig where++import Conduit (ConduitT)++import Ribosome.Menu.Data.MenuConsumer (MenuConsumer)+import Ribosome.Menu.Data.MenuItem (MenuItem)+import Ribosome.Menu.Data.MenuRenderEvent (MenuRenderEvent)+import Ribosome.Menu.Prompt.Data.PromptConfig (PromptConfig)++data MenuConfig m a =+  MenuConfig {+    _items :: ConduitT () MenuItem m (),+    _handle :: MenuConsumer m a,+    _render :: MenuRenderEvent m a -> m (),+    _prompt :: PromptConfig m+  }
+ lib/Ribosome/Menu/Data/MenuConsumer.hs view
@@ -0,0 +1,8 @@+module Ribosome.Menu.Data.MenuConsumer where++import Ribosome.Menu.Data.Menu (Menu)+import Ribosome.Menu.Data.MenuAction (MenuAction)+import Ribosome.Menu.Data.MenuUpdate (MenuUpdate)++newtype MenuConsumer m a =+  MenuConsumer { unMenuConsumer :: MenuUpdate m a -> m (MenuAction m a, Menu) }
+ lib/Ribosome/Menu/Data/MenuConsumerAction.hs view
@@ -0,0 +1,12 @@+module Ribosome.Menu.Data.MenuConsumerAction where++data MenuConsumerAction m a =+  Quit+  |+  QuitWith (m a)+  |+  Continue+  |+  Render Bool+  |+  Return a
+ lib/Ribosome/Menu/Data/MenuConsumerUpdate.hs view
@@ -0,0 +1,9 @@+module Ribosome.Menu.Data.MenuConsumerUpdate where++import Ribosome.Menu.Data.MenuUpdate (MenuUpdate)++data MenuConsumerUpdate m a =+  MenuConsumerUpdate {+    _changed :: Bool,+    _menu :: MenuUpdate m a+  }
+ lib/Ribosome/Menu/Data/MenuEvent.hs view
@@ -0,0 +1,41 @@+module Ribosome.Menu.Data.MenuEvent where++import qualified Text.Show++import Ribosome.Menu.Data.MenuItem (MenuItem)+import Ribosome.Menu.Prompt.Data.Prompt (Prompt)++data QuitReason m a =+  Aborted+  |+  PromptError Text+  |+  NoOutput+  |+  Return a+  |+  Execute (m a)++instance Show (QuitReason m a) where+  show Aborted =+    "Aborted"+  show (PromptError err) =+    "PromptError(" <> toString err <> ")"+  show NoOutput =+    "NoOutput"+  show (Return _) =+    "Return"+  show (Execute _) =+    "Execute"++data MenuEvent m a =+  Init Prompt+  |+  PromptChange Text Prompt+  |+  Mapping Text Prompt+  |+  NewItems MenuItem+  |+  Quit (QuitReason m a)+  deriving Show
+ lib/Ribosome/Menu/Data/MenuItem.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Menu.Data.MenuItem where++import Control.Lens (makeClassy)++data MenuItem =+  MenuItem {+    _ident :: Text,+    _text :: Text+  }+  deriving (Eq, Show)++makeClassy ''MenuItem
+ lib/Ribosome/Menu/Data/MenuRenderEvent.hs view
@@ -0,0 +1,10 @@+module Ribosome.Menu.Data.MenuRenderEvent where++import Ribosome.Menu.Data.Menu (Menu)+import Ribosome.Menu.Data.MenuEvent (QuitReason)++data MenuRenderEvent m a =+  Render Bool Menu+  |+  Quit (QuitReason m a)+  deriving Show
+ lib/Ribosome/Menu/Data/MenuResult.hs view
@@ -0,0 +1,13 @@+module Ribosome.Menu.Data.MenuResult where++data MenuResult a =+  NoOutput+  |+  Error Text+  |+  Executed+  |+  Aborted+  |+  Return a+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Data/MenuUpdate.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Menu.Data.MenuUpdate where++import Control.Lens (makeClassy)++import Ribosome.Menu.Data.Menu (Menu)+import Ribosome.Menu.Data.MenuEvent (MenuEvent)++data MenuUpdate m a =+  MenuUpdate {+    _event :: MenuEvent m a,+    _menu :: Menu+  }++makeClassy ''MenuUpdate
+ lib/Ribosome/Menu/Nvim.hs view
@@ -0,0 +1,37 @@+module Ribosome.Menu.Nvim where++import Ribosome.Api.Window (redraw, setLine)+import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)+import Ribosome.Data.Scratch (Scratch(scratchWindow))+import Ribosome.Data.ScratchOptions (ScratchOptions)+import Ribosome.Log (logDebug)+import Ribosome.Menu.Data.Menu (Menu(Menu))+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.Scratch (killScratch, setScratchContent)++renderNvimMenu ::+  MonadRibo m =>+  NvimE e m =>+  ScratchOptions ->+  Scratch ->+  MenuRenderEvent m a ->+  m ()+renderNvimMenu _ scratch (MenuRenderEvent.Quit _) =+  killScratch scratch+renderNvimMenu options scratch (MenuRenderEvent.Render changed (Menu _ allItems _ selected _)) = do+  when changed $ setScratchContent options scratch (reverse text)+  updateCursor+  redraw+  where+    lineNumber =+      max 0 $ length items - selected - 1+    text = MenuItem._text <$> items+    items = take maxItems (reverse allItems)+    maxItems = 100+    updateCursor = do+      logDebug @Text logMsg+      setLine (scratchWindow scratch) lineNumber+    logMsg =+      "updating menu cursor to line " <> show lineNumber <> "; " <> show selected <> "/" <> show (length items)
+ lib/Ribosome/Menu/Prompt/Data/Codes.hs view
@@ -0,0 +1,121 @@+module Ribosome.Menu.Prompt.Data.Codes where++import Control.Exception.Lifted (try)+import Data.Map (Map, (!?))+import qualified Data.Map as Map (fromList)+import qualified Data.Text as Text (singleton)++specialCodes :: Map Text Text+specialCodes =+  Map.fromList [+    ("\x80\xffX", "c-@"),+    ("\65533kb", "bs"),+    ("\x80kB", "s-ta"),+    ("\x0", "c-k"),+    ("\x80kD", "del"),+    ("\x9B", "csi"),+    ("\x80\xfdP", "xcsi"),+    ("\x80ku", "up"),+    ("\x80kd", "down"),+    ("\x80kl", "left"),+    ("\x80kr", "right"),+    -- ("\x80\xfd", "s-up"),+    -- ("\x80\xfd", "s-down"),+    ("\x80#4", "s-left"),+    ("\x80%i", "s-right"),+    ("\x80\xfdT", "c-left"),+    ("\x80\xfdU", "c-right"),+    ("\x80k1", "f1"),+    ("\x80k2", "f2"),+    ("\x80k3", "f3"),+    ("\x80k4", "f4"),+    ("\x80k5", "f5"),+    ("\x80k6", "f6"),+    ("\x80k7", "f7"),+    ("\x80k8", "f8"),+    ("\x80k9", "f9"),+    ("\x80k;", "f10"),+    ("\x80F1", "f11"),+    ("\x80F2", "f12"),+    ("\x80\xfd\x06", "s-f1"),+    ("\x80\xfd\x07", "s-f2"),+    ("\x80\xfd\x08", "s-f3"),+    ("\x80\xfd\x09", "s-f4"),+    ("\x80\xfd\x0A", "s-f5"),+    ("\x80\xfd\x0B", "s-f6"),+    ("\x80\xfd\x0C", "s-f7"),+    ("\x80\xfd\x0D", "s-f8"),+    ("\x80\xfd\x0E", "s-f9"),+    ("\x80\xfd\x0F", "s-f10"),+    ("\x80\xfd\x10", "s-f11"),+    ("\x80\xfd\x11", "s-f12"),+    ("\x80%1", "help"),+    ("\x80&8", "undo"),+    ("\x80kI", "insert"),+    ("\x80kh", "home"),+    ("\x80@7", "end"),+    ("\x80kP", "pageup"),+    ("\x80kN", "pagedown"),+    ("\x80K1", "khome"),+    ("\x80K4", "kend"),+    ("\x80K3", "kpageup"),+    ("\x80K5", "kpagedown"),+    ("\x80K6", "kplus"),+    ("\x80K7", "kminus"),+    ("\x80K9", "kmultiply"),+    ("\x80K8", "kdivide"),+    ("\x80KA", "kenter"),+    ("\x80KB", "kpoint"),+    ("\x80KC", "k0"),+    ("\x80KD", "k1"),+    ("\x80KE", "k2"),+    ("\x80KF", "k3"),+    ("\x80KG", "k4"),+    ("\x80KH", "k5"),+    ("\x80KI", "k6"),+    ("\x80KJ", "k7"),+    ("\x80KK", "k8"),+    ("\x80KL", "k9")+    ]++specialNumCodes :: Map Int Text+specialNumCodes =+  Map.fromList [+    (9, "ta"),+    (10, "c-j"),+    (11, "c-k"),+    (12, "fe"),+    (13, "cr"),+    (27, "esc"),+    (32, "space"),+    (60, "lt"),+    (92, "bslash"),+    (124, "bar")+    ]++modifierCodes :: [(Int, Text)]+modifierCodes =+  [+    (2, "shift"),+    (4, "control"),+    (8, "alt"),+    (16, "meta"),+    (32, "mouse_double"),+    (64, "mouse_triple"),+    (96, "mouse_quadruple"),+    (128, "command")+    ]++decodeInputChar :: Text -> Maybe Text+decodeInputChar =+  (specialCodes !?)++decodeInputNum ::+  MonadBaseControl IO m =>+  Int ->+  m (Maybe Text)+decodeInputNum a =+  maybe codepoint (return . Just) (specialNumCodes !? a)+  where+    codepoint =+      fmap Text.singleton . rightToMaybe @SomeException <$> try (return $ chr a)
+ lib/Ribosome/Menu/Prompt/Data/CursorUpdate.hs view
@@ -0,0 +1,15 @@+module Ribosome.Menu.Prompt.Data.CursorUpdate where++data CursorUpdate =+  Unmodified+  |+  OneLeft+  |+  OneRight+  |+  Append+  |+  Prepend+  |+  Index Int+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/InputEvent.hs view
@@ -0,0 +1,13 @@+module Ribosome.Menu.Prompt.Data.InputEvent where++data InputEvent =+  Character Text+  |+  NoInput+  |+  Unexpected Int+  |+  Interrupt+  |+  Error Text+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/Prompt.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Menu.Prompt.Data.Prompt where++import Ribosome.Menu.Prompt.Data.PromptState (PromptState)++data Prompt =+  Prompt {+     _cursor :: Int,+     _state :: PromptState,+     _text :: Text+  }+  deriving (Eq, Show)++deepLenses ''Prompt
+ lib/Ribosome/Menu/Prompt/Data/PromptConfig.hs view
@@ -0,0 +1,16 @@+module Ribosome.Menu.Prompt.Data.PromptConfig where++import Conduit (ConduitT)++import Ribosome.Menu.Prompt.Data.PromptEvent (PromptEvent)+import Ribosome.Menu.Prompt.Data.PromptRenderer (PromptRenderer)+import Ribosome.Menu.Prompt.Data.PromptState (PromptState)+import Ribosome.Menu.Prompt.Data.PromptUpdate (PromptUpdate)++data PromptConfig m =+  PromptConfig {+    _source :: ConduitT () PromptEvent m (),+    _modes :: PromptEvent -> PromptState -> m PromptUpdate,+    _render :: PromptRenderer m,+    _insert :: Bool+  }
+ lib/Ribosome/Menu/Prompt/Data/PromptConsumed.hs view
@@ -0,0 +1,7 @@+module Ribosome.Menu.Prompt.Data.PromptConsumed where++data PromptConsumed =+  Yes+  |+  No+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/PromptConsumerUpdate.hs view
@@ -0,0 +1,13 @@+module Ribosome.Menu.Prompt.Data.PromptConsumerUpdate where++import Ribosome.Menu.Prompt.Data.Prompt (Prompt)+import Ribosome.Menu.Prompt.Data.PromptConsumed (PromptConsumed)+import Ribosome.Menu.Prompt.Data.PromptEvent (PromptEvent)++data PromptConsumerUpdate =+  PromptConsumerUpdate {+    _event :: PromptEvent,+    _prompt :: Prompt,+    _consumed :: PromptConsumed+  }+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/PromptEvent.hs view
@@ -0,0 +1,15 @@+module Ribosome.Menu.Prompt.Data.PromptEvent where++data PromptEvent =+  Init+  |+  Character Text+  |+  -- SpecialCharacter Text+  -- |+  Unexpected Int+  |+  Interrupt+  |+  Error Text+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/PromptRenderer.hs view
@@ -0,0 +1,10 @@+module Ribosome.Menu.Prompt.Data.PromptRenderer where++import Ribosome.Menu.Prompt.Data.Prompt (Prompt)++data PromptRenderer m =+  ∀ a. PromptRenderer {+    _acquire :: m a,+    _release :: a -> m (),+    _render :: Prompt -> m ()+  }
+ lib/Ribosome/Menu/Prompt/Data/PromptState.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Menu.Prompt.Data.PromptState where++data PromptState =+  Insert+  |+  Normal+  |+  Quit+  deriving (Eq, Show)++deepLenses ''PromptState
+ lib/Ribosome/Menu/Prompt/Data/PromptUpdate.hs view
@@ -0,0 +1,15 @@+module Ribosome.Menu.Prompt.Data.PromptUpdate where++import Ribosome.Menu.Prompt.Data.CursorUpdate (CursorUpdate)+import Ribosome.Menu.Prompt.Data.PromptConsumed (PromptConsumed)+import Ribosome.Menu.Prompt.Data.PromptState (PromptState)+import Ribosome.Menu.Prompt.Data.TextUpdate (TextUpdate)++data PromptUpdate =+  PromptUpdate {+    _state :: PromptState,+    _cursor :: CursorUpdate,+    _text :: TextUpdate,+    _consumed :: PromptConsumed+  }+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Data/TextUpdate.hs view
@@ -0,0 +1,11 @@+module Ribosome.Menu.Prompt.Data.TextUpdate where++data TextUpdate =+  Unmodified+  |+  Insert Text+  |+  DeleteLeft+  |+  DeleteRight+  deriving (Eq, Show)
+ lib/Ribosome/Menu/Prompt/Nvim.hs view
@@ -0,0 +1,192 @@+module Ribosome.Menu.Prompt.Nvim where++import Conduit (ConduitT, yield)+import Control.Exception.Lifted (bracket_)+import Control.Monad.DeepError (ignoreError)+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 =+  '†'++quitCharOrd :: Int+quitCharOrd =+  ord quitChar++getChar ::+  NvimE e m =>+  MonadRibo m =>+  MonadBaseControl IO m =>+  m InputEvent+getChar =+  catchAs @RpcError InputEvent.Interrupt request+  where+    request =+      event =<< vimCallFunction "getchar" [toMsgpack False]+    event (Right c) =+      return $ InputEvent.Character (fromMaybe c (decodeInputChar c))+    event (Left 0) =+      return InputEvent.NoInput+    event (Left num) | num == quitCharOrd =+      return InputEvent.Interrupt+    event (Left num) =+      maybe (InputEvent.Unexpected num) InputEvent.Character <$> decodeInputNum num++getCharC ::+  MonadIO m =>+  MonadBaseControl IO m =>+  NvimE e m =>+  MonadRibo m =>+  Double ->+  ConduitT () PromptEvent m ()+getCharC interval =+  recurse+  where+    recurse =+      translate =<< lift getChar+    translate (InputEvent.Character a) =+      yield (PromptEvent.Character a) *> recurse+    translate InputEvent.Interrupt =+      yield PromptEvent.Interrupt+    translate (InputEvent.Error e) =+      yield (PromptEvent.Error e)+    translate InputEvent.NoInput =+      sleep interval *> recurse+    translate (InputEvent.Unexpected _) =+      recurse++promptFragment :: Text -> Text -> [Text]+promptFragment hl text =+  ["echohl " <> hl, "echon '" <> escapeQuotes text <> "'"]++nvimRenderPrompt ::+  Monad m =>+  NvimE e m =>+  MonadDeepError e DecodeError m =>+  Prompt ->+  m ()+nvimRenderPrompt (Prompt cursor _ text) =+  void $ atomic calls+  where+    calls = syncRpcCall . ApiData.vimCommand <$> ("silent! redraw!" : (fragments >>= uncurry promptFragment))+    fragments =+      [+        ("RibosomePromptSign", sign),+        ("None", pre),+        ("RibosomePromptCaret", Text.singleton cursorChar),+        ("None", post)+        ]+    (pre, rest) =+      Text.splitAt cursor text+    (cursorChar, post) =+      fromMaybe (' ', "") (Text.uncons rest)+    sign =+      "% "++loopFunctionName :: Text+loopFunctionName =+  "RibosomeMenuLoop"++loopVarName :: Text+loopVarName =+  "ribosome_menu_looping"++defineLoopFunction ::+  NvimE e m =>+  m ()+defineLoopFunction =+  defineFunction loopFunctionName [] lns+  where+    lns =+      [+        "echo ''",+        "while g:" <> loopVarName,+        "try",+        "sleep 5m",+        "catch /^Vim:Interrupt$/",+        "silent! call feedkeys('" <> Text.singleton quitChar <> "')",+        "endtry",+        "endwhile"+        ]++startLoop ::+  NvimE e m =>+  m ()+startLoop = do+  defineLoopFunction+  setVar loopVarName True+  vimCommand $ "call feedkeys(\":call " <> loopFunctionName <> "()\\<cr>\")"++-- FIXME need to wait for the loop to stop before deleting the function+killLoop ::+  NvimE e m =>+  m ()+killLoop = do+  setVar loopVarName False+  ignoreError @RpcError $ vimCommand $ "delfunction! " <> loopFunctionName++promptBlocker ::+  NvimE e m =>+  MonadBaseControl IO m =>+  m a ->+  m a+promptBlocker =+  bracket_ startLoop killLoop++newtype NvimPromptResources =+  NvimPromptResources {+    _guicursor :: Text+  }+  deriving (Eq, Show)++nvimAcquire ::+  NvimE e m =>+  m NvimPromptResources+nvimAcquire = do+  highlightSet <- catchAs @RpcError False $ True <$ vimCommandOutput "highlight RibosomePromptCaret"+  unless highlightSet $ vimCommand "highlight link RibosomePromptCaret TermCursor"+  res <- NvimPromptResources <$> vimGetOption "guicursor"+  vimSetOption "guicursor" (toMsgpack ("a:None" :: Text))+  () <- vimCallFunction "inputsave" []+  startLoop+  return res++nvimRelease ::+  NvimE e m =>+  MonadRibo m =>+  NvimPromptResources ->+  m ()+nvimRelease (NvimPromptResources gc) = do+  vimSetOption "guicursor" (toMsgpack gc)+  redraw+  vimCommand "echon ''"+  () <- vimCallFunction "inputrestore" []+  killLoop++nvimPromptRenderer ::+  NvimE e m =>+  MonadRibo m =>+  MonadDeepError e DecodeError m =>+  PromptRenderer m+nvimPromptRenderer =+  PromptRenderer nvimAcquire nvimRelease nvimRenderPrompt
+ lib/Ribosome/Menu/Prompt/Run.hs view
@@ -0,0 +1,181 @@+module Ribosome.Menu.Prompt.Run where++import Conduit (ConduitT, await, awaitForever, evalStateC, yield, (.|))+import Data.Conduit.Combinators (peek)+import qualified Data.Text as Text (drop, dropEnd, length, splitAt)++import Ribosome.Control.Monad.Ribo (MonadRibo)+import Ribosome.Log (logDebug)+import Ribosome.Menu.Prompt.Data.CursorUpdate (CursorUpdate)+import qualified Ribosome.Menu.Prompt.Data.CursorUpdate as CursorUpdate (CursorUpdate(..))+import Ribosome.Menu.Prompt.Data.Prompt (Prompt(Prompt))+import Ribosome.Menu.Prompt.Data.PromptConfig (PromptConfig(PromptConfig))+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 Ribosome.Menu.Prompt.Data.PromptState (PromptState)+import qualified Ribosome.Menu.Prompt.Data.PromptState as PromptState (PromptState(..))+import Ribosome.Menu.Prompt.Data.PromptUpdate (PromptUpdate(PromptUpdate))+import Ribosome.Menu.Prompt.Data.TextUpdate (TextUpdate)+import qualified Ribosome.Menu.Prompt.Data.TextUpdate as TextUpdate (TextUpdate(..))++updateCursor :: Int -> Text -> CursorUpdate -> Int+updateCursor current text =+  update+  where+    update CursorUpdate.OneLeft | current > 0 =+      current - 1+    update CursorUpdate.OneRight | current <= Text.length text =+      current + 1+    update CursorUpdate.Prepend =+      0+    update CursorUpdate.Append =+      Text.length text + 1+    update _ =+      current++updateText :: Int -> Text -> TextUpdate -> Text+updateText cursor text =+  update+  where+    update TextUpdate.Unmodified =+      text+    update (TextUpdate.Insert new) =+      pre <> new <> post+    update TextUpdate.DeleteLeft =+      Text.dropEnd 1 pre <> post+    update TextUpdate.DeleteRight =+      pre <> Text.drop 1 post+    (pre, post) = Text.splitAt cursor text++updatePrompt ::+  Monad m =>+  (PromptEvent -> PromptState -> m PromptUpdate) ->+  PromptEvent ->+  Prompt ->+  m (PromptConsumed, Prompt)+updatePrompt modes update (Prompt cursor state text) = do+  (PromptUpdate newState cursorUpdate textUpdate consumed) <- modes update state+  let+    newPrompt =+      Prompt (updateCursor cursor text cursorUpdate) newState (updateText cursor text textUpdate)+  return (consumed, newPrompt)++processPromptEvent ::+  MonadIO m =>+  MonadRibo m =>+  PromptConfig m ->+  PromptEvent ->+  ConduitT PromptEvent PromptConsumerUpdate (StateT Prompt m) ()+processPromptEvent (PromptConfig _ modes (PromptRenderer _ _ render) _) event = do+  logDebug @Text $ "prompt event: " <> show event+  consumed <- lift . stateM $ lift . updatePrompt modes event+  newPrompt <- get+  yield (PromptConsumerUpdate event newPrompt consumed)+  lift . lift . render $ newPrompt++skippingRenderer ::+  Monad m =>+  (Prompt -> m ()) ->+  ConduitT PromptConsumerUpdate PromptConsumerUpdate m ()+skippingRenderer render =+  go+  where+    go =+      check =<< await+    check (Just next@(PromptConsumerUpdate _ prompt _)) = do+      yield next+      renderIfIdle prompt =<< peek+      go+    check Nothing =+      return ()+    renderIfIdle _ (Just _) =+      return ()+    renderIfIdle prompt Nothing =+      lift (render prompt)++promptC ::+  MonadIO m =>+  MonadRibo m =>+  PromptConfig m ->+  ConduitT () PromptConsumerUpdate m ()+promptC config@(PromptConfig source _ (PromptRenderer _ _ render) insert) =+  sourceWithInit .| process .| skippingRenderer render+  where+    sourceWithInit =+      yield PromptEvent.Init *> source+    process =+      evalStateC (pristinePrompt insert) (awaitForever (processPromptEvent config))++unprocessable :: [Text]+unprocessable =+  [+    "cr"+    ]++consumeUnmodified :: PromptState -> CursorUpdate -> PromptUpdate+consumeUnmodified s u =+  PromptUpdate s u TextUpdate.Unmodified PromptConsumed.Yes++basicTransitionNormal ::+  PromptEvent ->+  PromptUpdate+basicTransitionNormal (PromptEvent.Character "esc") =+  consumeUnmodified PromptState.Quit CursorUpdate.Unmodified+basicTransitionNormal (PromptEvent.Character "q") =+  consumeUnmodified PromptState.Quit CursorUpdate.Unmodified+basicTransitionNormal (PromptEvent.Character "i") =+  consumeUnmodified PromptState.Insert CursorUpdate.Unmodified+basicTransitionNormal (PromptEvent.Character "I") =+  consumeUnmodified PromptState.Insert CursorUpdate.Prepend+basicTransitionNormal (PromptEvent.Character "a") =+  consumeUnmodified PromptState.Insert CursorUpdate.OneRight+basicTransitionNormal (PromptEvent.Character "A") =+  consumeUnmodified PromptState.Insert CursorUpdate.Append+basicTransitionNormal (PromptEvent.Character "h") =+  consumeUnmodified PromptState.Normal CursorUpdate.OneLeft+basicTransitionNormal (PromptEvent.Character "l") =+  consumeUnmodified PromptState.Normal CursorUpdate.OneRight+basicTransitionNormal (PromptEvent.Character "x") =+  PromptUpdate PromptState.Normal CursorUpdate.OneLeft TextUpdate.DeleteRight PromptConsumed.Yes+basicTransitionNormal _ =+  PromptUpdate PromptState.Normal CursorUpdate.Unmodified TextUpdate.Unmodified PromptConsumed.No++basicTransitionInsert ::+  PromptEvent ->+  PromptUpdate+basicTransitionInsert (PromptEvent.Character "esc") =+  PromptUpdate PromptState.Normal CursorUpdate.OneLeft TextUpdate.Unmodified PromptConsumed.Yes+basicTransitionInsert (PromptEvent.Character "bs") =+  PromptUpdate PromptState.Insert CursorUpdate.OneLeft TextUpdate.DeleteLeft PromptConsumed.Yes+basicTransitionInsert (PromptEvent.Character c) | c `elem` unprocessable =+  PromptUpdate PromptState.Insert CursorUpdate.Unmodified TextUpdate.Unmodified PromptConsumed.No+basicTransitionInsert (PromptEvent.Character c) =+  PromptUpdate PromptState.Insert CursorUpdate.OneRight (TextUpdate.Insert c) PromptConsumed.Yes+basicTransitionInsert _ =+  PromptUpdate PromptState.Insert CursorUpdate.Unmodified TextUpdate.Unmodified PromptConsumed.No++basicTransition ::+  Monad m =>+  PromptEvent ->+  PromptState ->+  m PromptUpdate+basicTransition event PromptState.Normal =+  return $ basicTransitionNormal event+basicTransition event PromptState.Insert =+  return $ basicTransitionInsert event+basicTransition _ PromptState.Quit =+  return $ PromptUpdate PromptState.Quit CursorUpdate.Unmodified TextUpdate.Unmodified PromptConsumed.No++pristinePrompt :: Bool -> Prompt+pristinePrompt insert =+  Prompt 0 (if insert then PromptState.Insert else PromptState.Normal) ""++noPromptRenderer ::+  Applicative m =>+  PromptRenderer m+noPromptRenderer =+  PromptRenderer unit (const unit) (const unit)
+ lib/Ribosome/Menu/Run.hs view
@@ -0,0 +1,170 @@+module Ribosome.Menu.Run where++import Conduit (ConduitT, await, awaitForever, mapC, yield, (.|))+import Control.Exception.Lifted (bracket)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Conduit.Combinators (iterM)+import qualified Data.Conduit.Combinators as Conduit (last)+import Data.Conduit.Lift (evalStateC)++import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)+import Ribosome.Data.Conduit (withMergedSources)+import Ribosome.Data.Scratch (scratchWindow)+import Ribosome.Data.ScratchOptions (ScratchOptions)+import Ribosome.Log (showDebug)+import Ribosome.Menu.Data.Menu (Menu)+import Ribosome.Menu.Data.MenuAction (MenuAction)+import qualified Ribosome.Menu.Data.MenuAction as MenuAction (MenuAction(..))+import Ribosome.Menu.Data.MenuConfig (MenuConfig(MenuConfig))+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 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 (renderNvimMenu)+import Ribosome.Menu.Prompt.Data.Prompt (Prompt(Prompt))+import Ribosome.Menu.Prompt.Data.PromptConfig (PromptConfig(PromptConfig))+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.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Msgpack.Error (DecodeError)+import Ribosome.Nvim.Api.IO (windowSetOption)+import Ribosome.Scratch (showInScratch)++promptEvent ::+  PromptEvent ->+  Prompt ->+  PromptConsumed ->+  MenuEvent m a+promptEvent _ (Prompt _ PromptState.Quit _) _ =+  MenuEvent.Quit QuitReason.Aborted+promptEvent (PromptEvent.Character a) prompt PromptConsumed.No =+  MenuEvent.Mapping a prompt+promptEvent (PromptEvent.Character a) prompt@(Prompt _ PromptState.Insert _) _ =+  MenuEvent.PromptChange a prompt+promptEvent (PromptEvent.Character a) prompt _ =+  MenuEvent.Mapping a 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 ->+  MenuEvent m a+menuEvent =+  either promptUpdate MenuEvent.NewItems+  where+    promptUpdate (PromptConsumerUpdate event prompt consumed) =+      promptEvent event prompt consumed++updateMenu ::+  MonadRibo m =>+  MenuConsumer m a ->+  Either PromptConsumerUpdate MenuItem ->+  ConduitT (Either PromptConsumerUpdate MenuItem) (MenuRenderEvent m a) (StateT Menu m) ()+updateMenu (MenuConsumer consumer) input = do+  showDebug "menu update:" input+  action <- lift . stateM $ lift . consumer . MenuUpdate (menuEvent input)+  showDebug "menu action:" action+  emit action+  where+    emit MenuAction.Continue =+      return ()+    emit (MenuAction.Render changed) =+      yield . MenuRenderEvent.Render changed =<< get+    emit (MenuAction.Quit reason) =+      yield (MenuRenderEvent.Quit reason)++menuSources ::+  MonadIO m =>+  MonadRibo m =>+  PromptConfig m ->+  ConduitT () MenuItem m () ->+  [ConduitT () (Either PromptConsumerUpdate MenuItem) m ()]+menuSources promptConfig items =+  [promptSource, itemSource]+  where+    promptSource =+      promptC promptConfig .| mapC Left+    itemSource =+      items .| mapC Right++menuTerminator ::+  Monad m =>+  ConduitT (MenuRenderEvent m a) (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++runMenu ::+  MonadIO m =>+  MonadRibo m =>+  MonadBaseControl IO m =>+  MenuConfig m a ->+  m (MenuResult a)+runMenu (MenuConfig items handle render promptConfig@(PromptConfig _ _ promptRenderer _)) =+  withPrompt promptRenderer+  where+    withPrompt (PromptRenderer acquire release _) =+      bracket acquire release (const run)+    run =+      menuResult =<< quitReason <$> withMergedSources consumer 64 (menuSources promptConfig items)+    consumer =+      evalStateC def (awaitForever (updateMenu handle)) .| iterM render .| menuTerminator .| Conduit.last+    quitReason =+      fromMaybe QuitReason.NoOutput++nvimMenu ::+  NvimE e m =>+  MonadIO m =>+  MonadRibo m =>+  MonadBaseControl IO m =>+  MonadDeepError e DecodeError m =>+  ScratchOptions ->+  ConduitT () MenuItem m () ->+  (MenuUpdate m a -> m (MenuAction m a, Menu)) ->+  PromptConfig m ->+  m (MenuResult a)+nvimMenu options items handle promptConfig =+  run =<< showInScratch [] options+  where+    run scratch = do+      windowSetOption (scratchWindow scratch) "cursorline" (toMsgpack True)+      runMenu $ MenuConfig items (MenuConsumer handle) (render scratch) promptConfig+    render =+      renderNvimMenu options
+ lib/Ribosome/Menu/Simple.hs view
@@ -0,0 +1,169 @@+module Ribosome.Menu.Simple where++import Control.Lens ((^?))+import qualified Control.Lens as Lens (element, over, views)+import Data.Composition ((.:))+import Data.Map ((!?))+import qualified Data.Map as Map (fromList, union)+import qualified Data.Text as Text (breakOn, null)++import Ribosome.Menu.Data.Menu (Menu(Menu), MenuFilter(MenuFilter))+import qualified Ribosome.Menu.Data.Menu as Menu (filtered, items, selected)+import Ribosome.Menu.Data.MenuAction (MenuAction)+import qualified Ribosome.Menu.Data.MenuAction as MenuAction (MenuAction(..))+import Ribosome.Menu.Data.MenuConsumerAction (MenuConsumerAction)+import qualified Ribosome.Menu.Data.MenuConsumerAction as MenuConsumerAction (MenuConsumerAction(..))+import Ribosome.Menu.Data.MenuEvent (MenuEvent)+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.MenuUpdate (MenuUpdate(MenuUpdate))+import Ribosome.Menu.Prompt.Data.Prompt (Prompt(Prompt))++type Mappings m a = Map Text (Menu -> Prompt -> m (MenuConsumerAction m a, Menu))++textContains :: Text -> Text -> Bool+textContains needle haystack =+  Text.null needle || (not (Text.null haystack) && search needle haystack)+  where+    search =+      not . Text.null . snd .: Text.breakOn++updateFilter :: Text -> Menu -> (Bool, MenuAction m a, Menu)+updateFilter text (Menu items oldFiltered stack selected _) =+  (filtered /= oldFiltered, MenuAction.Continue, Menu items filtered stack selected (MenuFilter text))+  where+    filtered =+      filter (textContains text . MenuItem._text) items++reapplyFilter :: Menu -> (Bool, MenuAction m a, Menu)+reapplyFilter menu@(Menu _ _ _ _ (MenuFilter currentFilter)) =+  updateFilter currentFilter menu++basicMenuTransform :: MenuEvent m a -> Menu -> (Bool, MenuAction m a, Menu)+basicMenuTransform (MenuEvent.PromptChange _ (Prompt _ _ text)) =+  updateFilter text+basicMenuTransform (MenuEvent.Mapping _ _) =+  (False, MenuAction.Continue,)+basicMenuTransform (MenuEvent.NewItems item) =+  reapplyFilter . Lens.over Menu.items (item :)+basicMenuTransform (MenuEvent.Init _) =+  (True, MenuAction.Continue,)+basicMenuTransform (MenuEvent.Quit reason) =+  (False, MenuAction.Quit reason,)++basicMenu ::+  Monad m =>+  (MenuUpdate m a -> m (MenuConsumerAction m a, Menu)) ->+  MenuUpdate m a ->+  m (MenuAction m a, Menu)+basicMenu consumer (MenuUpdate event menu) =+  consumerAction action+  where+    (changed, action, newMenu) = basicMenuTransform event menu+    consumerAction (MenuAction.Quit reason) =+      return (MenuAction.Quit reason, menu)+    consumerAction _ =+      first menuAction <$> consumer (MenuUpdate event newMenu)+    menuAction MenuConsumerAction.Continue =+      if changed then MenuAction.Render True else MenuAction.Continue+    menuAction (MenuConsumerAction.Render consumerChanged) =+      MenuAction.Render (changed || consumerChanged)+    menuAction (MenuConsumerAction.QuitWith ma) =+      MenuAction.Quit (QuitReason.Execute ma)+    menuAction MenuConsumerAction.Quit =+      MenuAction.Quit QuitReason.Aborted+    menuAction (MenuConsumerAction.Return a) =+      MenuAction.Quit (QuitReason.Return a)++mappingConsumer ::+  Monad m =>+  Mappings m a ->+  MenuUpdate m a ->+  m (MenuConsumerAction m a, Menu)+mappingConsumer mappings (MenuUpdate (MenuEvent.Mapping char prompt) menu) =+  handler menu prompt+  where+    handler =+      fromMaybe (const . menuContinue) (mappings !? char)+mappingConsumer _ (MenuUpdate _ menu) =+  menuContinue menu++simpleMenu ::+  Monad m =>+  Mappings m a ->+  MenuUpdate m a ->+  m (MenuAction m a, Menu)+simpleMenu =+  basicMenu . mappingConsumer++menuCycle ::+  Monad m =>+  Int ->+  Menu ->+  Prompt ->+  m (MenuConsumerAction m a, Menu)+menuCycle offset m _ =+  menuRender False (Lens.over Menu.selected add m)+  where+    count =+      Lens.views Menu.filtered length m+    add current =+      if count == 0 then 0 else (current + offset) `mod` count++defaultMappings ::+  Monad m =>+  Mappings m a+defaultMappings =+  Map.fromList [("k", menuCycle 1), ("j", menuCycle (-1))]++defaultMenu ::+  Monad m =>+  Mappings m a ->+  MenuUpdate m a ->+  m (MenuAction m a, Menu)+defaultMenu =+  simpleMenu . (`Map.union` defaultMappings)++menuContinue ::+  Monad m =>+  Menu ->+  m (MenuConsumerAction m a, Menu)+menuContinue =+  return . (MenuConsumerAction.Continue,)++menuRender ::+  Monad m =>+  Bool ->+  Menu ->+  m (MenuConsumerAction m a, Menu)+menuRender changed =+  return . (MenuConsumerAction.Render changed,)++menuQuit ::+  Monad m =>+  Menu ->+  m (MenuConsumerAction m a, Menu)+menuQuit =+  return . (MenuConsumerAction.Quit,)++menuQuitWith ::+  Monad m =>+  m a ->+  Menu ->+  m (MenuConsumerAction m a, Menu)+menuQuitWith next =+  return . (MenuConsumerAction.QuitWith next,)++menuReturn ::+  Monad m =>+  a ->+  Menu ->+  m (MenuConsumerAction m a, Menu)+menuReturn a =+  return . (MenuConsumerAction.Return a,)++selectedMenuItem :: Menu -> Maybe MenuItem+selectedMenuItem (Menu _ items _ selected _) =+  items ^? Lens.element (length items - selected - 1)
− lib/Ribosome/Monad.hs 
@@ -1,13 +0,0 @@-module Ribosome.Monad(-  liftExceptTIO,-  liftExceptT,-) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Except (ExceptT(ExceptT))--liftExceptTIO :: (MonadIO m) => IO a -> ExceptT e m a-liftExceptTIO fa = ExceptT $ Right <$> liftIO fa--liftExceptT :: (Functor m) => m a -> ExceptT e m a-liftExceptT fa = ExceptT $ Right <$> fa
lib/Ribosome/Msgpack/Decode.hs view
@@ -1,30 +1,36 @@-{-# LANGUAGE TypeOperators #-}--module Ribosome.Msgpack.Decode(-  MsgpackDecode(..),-) where+module Ribosome.Msgpack.Decode where -import Data.ByteString.Internal (unpackChars)-import Data.Map.Strict (Map, (!?))-import qualified Data.Map.Strict as Map (fromList, toList)+import Control.Monad.DeepError (MonadDeepError, hoistEitherWith)+import Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as ByteString (toString)+import Data.Either.Combinators (mapLeft)+import Data.Int (Int64)+import Data.Map (Map, (!?))+import qualified Data.Map as Map (fromList, toList) import Data.MessagePack (Object(..))+import Data.Text.Prettyprint.Doc (pretty)+import GHC.Float (double2Float) import GHC.Generics (+  C1,+  Constructor,+  D1,   Generic,-  Rep,-  (:*:)(..),+  K1(..),   M1(..),-  D1,-  C1,+  Rep,   S1,-  K1(..),   Selector,-  Constructor,+  conIsRecord,   selName,   to,-  conIsRecord,+  (:*:)(..),   )+import Neovim (CommandArguments)++import Ribosome.Msgpack.Error (DecodeError)+import qualified Ribosome.Msgpack.Error as DecodeError (DecodeError(Failed)) import Ribosome.Msgpack.Util (Err)-import qualified Ribosome.Msgpack.Util as Util (string, invalid, missingRecordKey, illegalType)+import qualified Ribosome.Msgpack.Util as Util (illegalType, invalid, missingRecordKey, string)  class MsgpackDecode a where   fromMsgpack :: Object -> Either Err a@@ -102,24 +108,95 @@         return (k1, v1)   fromMsgpack o = Util.illegalType "Map" o +msgpackIntegral :: (Integral a, Read a) => Object -> Either Err a+msgpackIntegral (ObjectInt i) = Right $ fromIntegral i+msgpackIntegral (ObjectUInt i) = Right $ fromIntegral i+msgpackIntegral (ObjectString s) = mapLeft pretty . readEither . ByteString.toString $ s+msgpackIntegral o = Util.illegalType "Integral" o+ instance MsgpackDecode Int where-  fromMsgpack (ObjectInt i) = Right $ fromIntegral i-  fromMsgpack o = Util.illegalType "Int" o+  fromMsgpack = msgpackIntegral +instance MsgpackDecode Int64 where+  fromMsgpack = msgpackIntegral++instance MsgpackDecode Float where+  fromMsgpack (ObjectFloat a) = Right a+  fromMsgpack (ObjectDouble a) = Right (double2Float a)+  fromMsgpack (ObjectInt a) = Right (fromIntegral a)+  fromMsgpack (ObjectUInt a) = Right (fromIntegral a)+  fromMsgpack o = Util.illegalType "Float" o+ instance {-# OVERLAPPING #-} MsgpackDecode String where-  fromMsgpack (ObjectString os) = Right $ unpackChars os+  fromMsgpack (ObjectString os) = Right $ decodeUtf8 os+  fromMsgpack (ObjectBinary os) = Right $ decodeUtf8 os   fromMsgpack o = Util.illegalType "String" o  instance {-# OVERLAPPABLE #-} MsgpackDecode a => MsgpackDecode [a] where   fromMsgpack (ObjectArray oa) = traverse fromMsgpack oa   fromMsgpack o = Util.illegalType "List" o +instance MsgpackDecode Text where+  fromMsgpack (ObjectString os) = Right (decodeUtf8 os)+  fromMsgpack (ObjectBinary os) = Right (decodeUtf8 os)+  fromMsgpack o = Util.illegalType "Text" o++instance MsgpackDecode ByteString where+  fromMsgpack (ObjectString os) = Right os+  fromMsgpack (ObjectBinary os) = Right os+  fromMsgpack o = Util.illegalType "ByteString" o++instance MsgpackDecode Char where+  fromMsgpack o@(ObjectString os) =+    check . decodeUtf8 $ os+    where+      check [c] = Right c+      check _ = Util.invalid "multiple characters when decoding Char" o+  fromMsgpack o = Util.illegalType "Char" o+ instance MsgpackDecode a => MsgpackDecode (Maybe a) where   fromMsgpack ObjectNil = Right Nothing   fromMsgpack o = Just <$> fromMsgpack o-   missingKey _ _ = Right Nothing +instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (Either a b) where+  fromMsgpack o =+    fromRight (Left <$> fromMsgpack o) (Right . Right <$> fromMsgpack o)+ instance MsgpackDecode Bool where   fromMsgpack (ObjectBool a) = Right a   fromMsgpack o = Util.illegalType "Bool" o++instance MsgpackDecode () where+  fromMsgpack _ = Right ()++instance MsgpackDecode Object where+  fromMsgpack = Right++instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (a, b) where+  fromMsgpack (ObjectArray [a, b]) =+    (,) <$> fromMsgpack a <*> fromMsgpack b+  fromMsgpack o@(ObjectArray _) =+    Util.invalid "invalid array length for pair" o+  fromMsgpack o =+    Util.illegalType "pair" o++instance MsgpackDecode CommandArguments where++fromMsgpack' ::+  ∀ a e m.+  MonadDeepError e DecodeError m =>+  MsgpackDecode a =>+  Object ->+  m a+fromMsgpack' =+  hoistEitherWith DecodeError.Failed . fromMsgpack++msgpackFromString :: IsString a => String -> Object -> Either Err a+msgpackFromString name o =+  adapt $ fromMsgpack o+  where+    adapt (Right a) =+      Right $ fromString a+    adapt (Left _) =+      Util.illegalType name o
lib/Ribosome/Msgpack/Encode.hs view
@@ -1,30 +1,30 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} -module Ribosome.Msgpack.Encode(-  MsgpackEncode(..),-) where+module Ribosome.Msgpack.Encode where  import Data.Bifunctor (bimap)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map (fromList, toList)+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Map (Map)+import qualified Data.Map as Map (fromList, toList) import Data.MessagePack (Object(..)) import GHC.Generics (+  C1,+  Constructor,+  D1,   Generic,-  Rep,-  (:*:)(..),+  K1(..),   M1(..),-  D1,-  C1,+  Rep,   S1,-  K1(..),   Selector,-  Constructor,-  selName,-  from,   conIsRecord,+  from,+  selName,+  (:*:)(..),   )-import qualified Ribosome.Msgpack.Util as Util (string, assembleMap)+import qualified Ribosome.Msgpack.Util as Util (assembleMap, string, text)  class MsgpackEncode a where   toMsgpack :: a -> Object@@ -55,8 +55,8 @@       f = if conIsRecord c then Util.assembleMap . msgpackEncodeRecord else prodOrNewtype  instance (MsgpackEncodeProd f, MsgpackEncodeProd g) => MsgpackEncodeProd (f :*: g) where-  msgpackEncodeRecord (f :*: g) = msgpackEncodeRecord f ++ msgpackEncodeRecord g-  msgpackEncodeProd (f :*: g) = msgpackEncodeProd f ++ msgpackEncodeProd g+  msgpackEncodeRecord (f :*: g) = msgpackEncodeRecord f <> msgpackEncodeRecord g+  msgpackEncodeProd (f :*: g) = msgpackEncodeProd f <> msgpackEncodeProd g  instance (Selector s, GMsgpackEncode f) => MsgpackEncodeProd (S1 s f) where   msgpackEncodeRecord s@(M1 f) = [(selName s, gMsgpackEncode f)]@@ -71,14 +71,35 @@ instance MsgpackEncode Int where   toMsgpack = ObjectInt . fromIntegral +instance MsgpackEncode Int64 where+  toMsgpack = ObjectInt . fromIntegral++instance MsgpackEncode Float where+  toMsgpack = ObjectFloat+ instance {-# OVERLAPPING #-} MsgpackEncode String where   toMsgpack = Util.string  instance {-# OVERLAPPABLE #-} MsgpackEncode a => MsgpackEncode [a] where   toMsgpack = ObjectArray . fmap toMsgpack +instance MsgpackEncode Text where+  toMsgpack = Util.text+ instance MsgpackEncode a => MsgpackEncode (Maybe a) where   toMsgpack = maybe ObjectNil toMsgpack  instance MsgpackEncode Bool where   toMsgpack = ObjectBool++instance MsgpackEncode () where+  toMsgpack _ = ObjectNil++instance MsgpackEncode Object where+  toMsgpack = id++instance MsgpackEncode ByteString where+  toMsgpack = ObjectString++instance (MsgpackEncode a, MsgpackEncode b) => MsgpackEncode (a, b) where+  toMsgpack (a, b) = ObjectArray [toMsgpack a, toMsgpack b]
+ lib/Ribosome/Msgpack/Error.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Msgpack.Error where++import Data.DeepPrisms (deepPrisms)+import System.Log.Logger (Priority(ERROR))++import Data.Text.Prettyprint.Doc (defaultLayoutOptions, layoutPretty)+import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)+import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+import Ribosome.Error.Report.Class (ReportError(..))+import Ribosome.Msgpack.Util (Err)++newtype DecodeError =+  Failed Err+  deriving Show++deepPrisms ''DecodeError++instance ReportError DecodeError where+  errorReport (Failed err) =+    ErrorReport "error decoding response from neovim" ["DecodeError:", rendered] ERROR+    where+      rendered = renderStrict $ layoutPretty defaultLayoutOptions err
lib/Ribosome/Msgpack/NvimObject.hs view
@@ -6,11 +6,11 @@ import Control.DeepSeq (NFData) import GHC.Generics (Generic) import Neovim (NvimObject(..))-import Ribosome.Msgpack.Encode (MsgpackEncode(..)) import Ribosome.Msgpack.Decode (MsgpackDecode(..))+import Ribosome.Msgpack.Encode (MsgpackEncode(..))  newtype NO a =-  NO a+  NO { unNO :: a }   deriving (Eq, Show, Generic, NFData)  instance (MsgpackEncode a, MsgpackDecode a, NFData a) => NvimObject (NO a) where
lib/Ribosome/Msgpack/Util.hs view
@@ -1,26 +1,23 @@-module Ribosome.Msgpack.Util(-  Err,-  string,-  assembleMap,-  invalid,-  missingRecordKey,-  illegalType,-) where+module Ribosome.Msgpack.Util where  import Data.Bifunctor (first)-import Data.ByteString.Internal (packChars)-import qualified Data.Map.Strict as Map (fromList)+import qualified Data.ByteString.UTF8 as ByteString (fromString)+import qualified Data.Map as Map (fromList) import Data.MessagePack (Object(..))-import Data.Text.Prettyprint.Doc (Doc, (<+>), viaShow, pretty)+import Data.Text.Prettyprint.Doc (Doc, pretty, viaShow, (<+>)) import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)  type Err = Doc AnsiStyle  string :: String -> Object-string = ObjectString . packChars+string = ObjectString . ByteString.fromString +text :: Text -> Object+text = ObjectString . encodeUtf8+ assembleMap :: [(String, Object)] -> Object-assembleMap = ObjectMap . Map.fromList . (fmap . first) string+assembleMap =+  ObjectMap . Map.fromList . (fmap . first) string  invalid :: String -> Object -> Either Err a invalid msg obj =@@ -31,4 +28,5 @@   invalid $ "missing record key " ++ key ++ " in ObjectMap"  illegalType :: String -> Object -> Either Err a-illegalType tpe = invalid $ "illegal type for " ++ tpe+illegalType tpe =+  invalid $ "illegal type for " ++ tpe
+ lib/Ribosome/Nvim/Api/Data.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.Data where++import Data.MessagePack (Object(ObjectExt))+import Prelude+import Ribosome.Msgpack.Decode (MsgpackDecode(..))+import Ribosome.Msgpack.Encode (MsgpackEncode(..))++import Ribosome.Nvim.Api.GenerateData (generateData)++generateData
+ lib/Ribosome/Nvim/Api/Generate.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.Generate where++import Control.Monad (join)+import Data.Bifunctor (first)+import Data.Char (toUpper)+import Data.Int (Int64)+import Data.Map (Map)+import qualified Data.Map as Map (fromList, lookup)+import Data.Maybe (fromMaybe)+import Data.MessagePack (Object)+import Language.Haskell.TH+import Neovim.API.Parser (+  NeovimAPI(functions),+  NeovimFunction(NeovimFunction),+  NeovimType(NestedType, SimpleType, Void),+  customTypes,+  parseAPI,+  )++camelcase :: String -> String+camelcase =+  snd . foldr folder (False, "")+  where+    folder '_' (_, z) = (True, z)+    folder a (True, h : t) = (False, a : toUpper h : t)+    folder a (True, []) = (False, [a])+    folder a (False, z) = (False, a : z)++haskellTypes :: Map String TypeQ+haskellTypes =+  Map.fromList [+    ("Boolean", [t|Bool|]),+    ("Integer", [t|Int|]),+    ("Float", [t|Double|]),+    ("String", [t|Text|]),+    ("Array", [t|[Object]|]),+    ("Dictionary", [t|Map Text Object|]),+    ("void", [t|()|])+    ]++haskellType :: NeovimType -> Q Type+haskellType at =+  case at of+    Void -> [t|()|]+    NestedType t Nothing ->+      appT listT $ haskellType t+    NestedType t (Just n) ->+      foldl appT (tupleT n) . replicate n $ haskellType t+    SimpleType t ->+      fromMaybe (conT . mkName $ t) $ Map.lookup t haskellTypes++data FunctionData =+  FunctionData {+    apiName :: String,+    ccName :: Name,+    async :: Bool,+    names :: [Name],+    types :: [Type],+    returnType :: NeovimType+    }+  deriving (Eq, Show)++functionData :: NeovimFunction -> Q FunctionData+functionData (NeovimFunction name parameters _ async returnType) = do+  names <- traverse newName prefixedNames+  types <- traverse haskellType (fst <$> parameters)+  return (FunctionData name (mkName . camelcase $ name) async names types returnType)+  where+    prefix i n = "arg" <> show i <> "_" <> n+    prefixedNames = zipWith prefix [0 :: Int ..] (snd <$> parameters)++generateFromApi :: (FunctionData -> Q [Dec]) -> (Name -> Int64 -> DecsQ) -> Q [Dec]+generateFromApi handleFunction handleExtType = do+  api <- either (fail . show) return =<< runIO parseAPI+  funcs <- traverse functionData (functions api)+  funcDecs <- traverse handleFunction funcs+  tpeDecs <- traverse (uncurry handleExtType) $ first mkName <$> customTypes api+  return $ join (funcDecs <> tpeDecs)
+ lib/Ribosome/Nvim/Api/GenerateData.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.GenerateData where++import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.MessagePack (Object(ObjectExt))+import Language.Haskell.TH+import Neovim.Plugin.Classes (FunctionName(F))++import Ribosome.Msgpack.Decode (MsgpackDecode)+import Ribosome.Msgpack.Encode (MsgpackEncode)+import Ribosome.Msgpack.Util (illegalType)+import Ribosome.Nvim.Api.Generate (FunctionData(FunctionData), generateFromApi)+import Ribosome.Nvim.Api.RpcCall (AsyncRpcCall(..), RpcCall(..), SyncRpcCall(..))++dataSig :: [Type] -> Name -> Bool -> DecQ+dataSig types name async = do+  returnType <- if async then [t|AsyncRpcCall|] else [t|SyncRpcCall|]+  sigD name . return . foldr (AppT . AppT ArrowT) returnType $ types++dataBody :: String -> Name -> Bool -> [Name] -> DecQ+dataBody apiName name async params =+  funD name [clause (varP <$> params) (normalB $ appE syncCtor rpcCall) []]+  where+    rpcCall = [|RpcCall|] `appE` funcName `appE` listE (toObjVar <$> params)+    funcName = [|F . fromString|] `appE` (litE . stringL $ apiName)+    toObjVar v = [|toMsgpack $(varE v)|]+    syncCtor = if async then [|AsyncRpcCall|] else [|SyncRpcCall|]++genCallData :: FunctionData -> DecsQ+genCallData (FunctionData apiName name async names types _) = do+  sig <- dataSig types name async+  body <- dataBody apiName name async names+  return [sig, body]++extData :: Name -> DecQ+extData name =+  dataD (return []) name [] Nothing [ctor] (deriv ["Eq", "Show"])+  where+    ctor = normalC name [(Bang NoSourceUnpackedness SourceStrict,) <$> [t|ByteString|]]+    deriv = return . return . DerivClause Nothing . (ConT . mkName <$>)++decClause :: Name -> Int64 -> ClauseQ+decClause name number = do+  bytesVar <- newName "bytes"+  clause [pattern bytesVar] (decBody bytesVar) []+  where+    pattern bytesVar = conP (mkName "ObjectExt") [(litP . integerL . fromIntegral) number, varP bytesVar]+    decBody bytesVar = (normalB [|return $ $(conE name) $(varE bytesVar)|])++decErrorClause :: Name -> ClauseQ+decErrorClause name = do+  objectVar <- newName "object"+  clause [varP objectVar] (decBody objectVar) []+  where+    nameString = nameBase name+    decBody objectVar = normalB [|illegalType nameString $(varE objectVar)|]++encClause :: Name -> Int64 -> ClauseQ+encClause name number = do+  bytesVar <- newName "bytes"+  clause [conP name [varP bytesVar]] (encBody bytesVar) []+  where+    encBody bytesVar = normalB [|ObjectExt $((litE . integerL . fromIntegral) number) $(varE bytesVar)|]++extDataCodec :: Name -> Int64 -> DecsQ+extDataCodec name number = do+  dec <- inst [t|MsgpackDecode|] [method "fromMsgpack" [decClause name number, decErrorClause name]]+  enc <- inst [t|MsgpackEncode|] [method "toMsgpack" [encClause name number]]+  return [dec, enc]+  where+    inst t = instanceD (return []) (tpe t)+    tpe = (`appT` conT name)+    method methodName clauses = funD (mkName methodName) clauses++genExtTypes :: Name -> Int64 -> DecsQ+genExtTypes name number = do+  dat <- extData name+  codec <- extDataCodec name number+  return (dat : codec)++generateData :: DecsQ+generateData =+  generateFromApi genCallData genExtTypes
+ lib/Ribosome/Nvim/Api/GenerateIO.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.GenerateIO where++import Control.Monad ((<=<))+import Control.Monad.DeepError (MonadDeepError, hoistEither)+import Data.Maybe (maybeToList)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Neovim.API.Parser (NeovimType(SimpleType))++import Ribosome.Control.Monad.Ribo (Nvim(call))+import Ribosome.Msgpack.Decode (MsgpackDecode)+import Ribosome.Nvim.Api.Generate (FunctionData(FunctionData), generateFromApi, haskellType)+import Ribosome.Nvim.Api.RpcCall (RpcError)++rpcModule :: Module+rpcModule =+  Module (mkPkgName "Ribosome.Nvim.Api") (mkModName "Data")++msgpackDecodeConstraint :: NeovimType -> Q (Maybe Type)+msgpackDecodeConstraint (SimpleType "Object") =+  Just <$> [t|MsgpackDecode $(varT $ mkName "a")|]+msgpackDecodeConstraint _ =+  return Nothing++newT :: String -> TypeQ+newT =+  varT <=< newName++ioReturnType :: NeovimType -> Q Type+ioReturnType (SimpleType "Object") =+  return (VarT $ mkName "a")+ioReturnType a =+  haskellType a++analyzeReturnType :: NeovimType -> Q (Type, Maybe Type)+analyzeReturnType tpe = do+  rt <- ioReturnType tpe+  constraint <- msgpackDecodeConstraint tpe+  return (rt, constraint)++ioSig :: Name -> [Type] -> NeovimType -> DecQ+ioSig name types returnType = do+  mType <- newT "m"+  nvimConstraint <- [t|Nvim $(pure mType)|]+  (retType, decodeConstraint) <- analyzeReturnType returnType+  monadErrorConstraint <- [t|MonadDeepError $(newT "e") RpcError $(pure mType)|]+  let+    params = foldr (AppT . AppT ArrowT) (AppT mType retType) types+    constraints = [nvimConstraint, monadErrorConstraint] <> maybeToList decodeConstraint+  sigD name $ return (ForallT [] constraints params)++ioBody :: Name -> Bool -> [Name] -> DecQ+ioBody name _ names =+  funD name [clause (varP <$> names) (normalB body) []]+  where+    responseName = mkName "response"+    callPat = varP responseName+    callExp = appE [|call|] args+    checkExp = appE [|hoistEither|] (varE responseName)+    args = foldl appE (varE $ mkName $ "RpcData." <> show name) (varE <$> names)+    body = doE [bindS callPat callExp, noBindS checkExp]++genIO :: FunctionData -> Q [Dec]+genIO (FunctionData _ name async names types returnType) = do+  sig <- ioSig name types returnType+  body <- ioBody name async names+  return [sig, body]++generateIO :: Q [Dec]+generateIO =+  generateFromApi genIO (const . const . return $ [])
+ lib/Ribosome/Nvim/Api/IO.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.IO where++import Data.MessagePack (Object)++import Ribosome.Nvim.Api.Data (Buffer, Tabpage, Window)+import qualified Ribosome.Nvim.Api.Data as RpcData+import Ribosome.Nvim.Api.GenerateIO (generateIO)++generateIO
+ lib/Ribosome/Nvim/Api/RpcCall.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Nvim.Api.RpcCall where++import Data.DeepPrisms (deepPrisms)+import Data.Either.Combinators (mapLeft)+import Data.MessagePack (Object)+import Data.Text.Prettyprint.Doc (defaultLayoutOptions, layoutPretty)+import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)+import Neovim (Neovim)+import Neovim.Exceptions (NeovimException)+import Neovim.Plugin.Classes (FunctionName)+import Neovim.RPC.FunctionCall (scall)+import System.Log.Logger (Priority(ERROR))++import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+import Ribosome.Error.Report.Class (ReportError(..))+import Ribosome.Msgpack.Decode (MsgpackDecode(..))+import Ribosome.Msgpack.Util (Err)++data RpcCall =+  RpcCall {+    rpcCallName :: FunctionName,+    rpcCallArgs :: [Object]+  }+  deriving (Eq, Show)++newtype AsyncRpcCall =+  AsyncRpcCall { asyncRpcCall :: RpcCall }+  deriving (Eq, Show)++newtype SyncRpcCall =+  SyncRpcCall { syncRpcCall :: RpcCall }+  deriving (Eq, Show)++data RpcError =+  Decode Err+  |+  Nvim RpcCall NeovimException+  |+  Atomic Text+  deriving Show++deepPrisms ''RpcError++class Rpc c a where+  call :: c -> Neovim e (Either RpcError a)++instance Rpc AsyncRpcCall () where+  call (AsyncRpcCall c@(RpcCall name args)) =+    mapLeft (Nvim c) <$> scall name args++instance MsgpackDecode a => Rpc SyncRpcCall a where+  call (SyncRpcCall c@(RpcCall name args)) =+    either (Left . Nvim c) (mapLeft Decode . fromMsgpack) <$> scall name args++instance ReportError RpcError where+  errorReport (Decode err) =+    ErrorReport "error decoding neovim response" ["RpcError.Decode:", rendered] ERROR+    where+      rendered = renderStrict $ layoutPretty defaultLayoutOptions err+  errorReport (Nvim c exc)  =+    ErrorReport "error in request to neovim" ["RpcError.Nvim:", show c, show exc] ERROR+  errorReport (Atomic msg)  =+    ErrorReport "error in request to neovim" ["RpcError.Atomic:", msg] ERROR
+ lib/Ribosome/Orphans.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Ribosome.Orphans where++import Control.Monad.Catch (MonadCatch(..), MonadMask(..))+import Neovim.Context.Internal (Neovim(..))++deriving instance MonadCatch (Neovim e)+deriving instance MonadMask (Neovim e)
lib/Ribosome/Persist.hs view
@@ -1,55 +1,132 @@-module Ribosome.Persist(-  persistStore,-  persistenceFile,-  persistencePath,-  defaultPersistencePath,-  persistLoad,-) where+module Ribosome.Persist where -import GHC.IO.Exception (IOException)-import Control.Exception (try)+import Control.Exception (IOException, try)+import Control.Monad (unless)+import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Except (ExceptT(ExceptT), catchE)-import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode)-import qualified Data.ByteString.Lazy as B (writeFile, readFile, ByteString)-import System.FilePath (takeDirectory, (</>))-import System.Directory (getXdgDirectory, XdgDirectory(XdgCache), createDirectoryIfMissing)-import Ribosome.Monad (liftExceptT)-import Ribosome.Control.Ribo (Ribo)-import qualified Ribosome.Control.Ribo as Ribo (name)-import Ribosome.Config.Setting (settingE)+import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict', encodeFile)+import Path (Abs, Dir, File, Path, Rel, parent, parseAbsDir, parseRelDir, toFilePath, (<.>), (</>))+import Path.IO (XdgDirectory(XdgCache), createDirIfMissing, doesFileExist, getXdgDir)++import Ribosome.Config.Setting (setting) import qualified Ribosome.Config.Settings as S (persistenceDir)+import Ribosome.Control.Monad.Error (recoveryFor)+import Ribosome.Control.Monad.Ribo+import Ribosome.Data.PersistError (PersistError)+import qualified Ribosome.Data.PersistError as PersistError (PersistError(..))+import Ribosome.Data.SettingError (SettingError) -defaultPersistencePath :: FilePath -> IO FilePath+defaultPersistencePath :: MonadIO m => m (Path Abs Dir) defaultPersistencePath =-  getXdgDirectory XdgCache+  liftIO $ getXdgDir XdgCache Nothing -persistencePath :: FilePath -> Ribo e FilePath+persistencePath ::+  MonadRibo m =>+  NvimE e m =>+  MonadIO m =>+  MonadThrow m =>+  MonadDeepError e SettingError m =>+  Path Rel File ->+  m (Path Abs File) persistencePath path = do-  name <- Ribo.name-  let prefixed = name </> path-  custom <- settingE S.persistenceDir-  either (const $ liftIO $ defaultPersistencePath prefixed) (\c -> return $ c </> prefixed) custom+  base <- defaultPersistencePath `recoveryFor` (parseAbsDir =<< setting S.persistenceDir)+  name <- parseRelDir . toString =<< pluginName+  return $ base </> name </> path -persistenceFile :: FilePath -> Ribo e FilePath+persistenceFile ::+  MonadRibo m =>+  NvimE e m =>+  MonadIO m =>+  MonadThrow m =>+  MonadDeepError e SettingError m =>+  Path Rel File ->+  m (Path Abs File) persistenceFile path = do   file <- persistencePath path-  liftIO $ createDirectoryIfMissing True (takeDirectory file)-  return $ file ++ ".json"+  createDirIfMissing True (parent file)+  file <.> "json" -persistStore :: ToJSON a => FilePath -> a -> Ribo e ()+persistStore ::+  MonadRibo m =>+  NvimE e m =>+  MonadIO m =>+  MonadThrow m =>+  MonadDeepError e SettingError m =>+  ToJSON a =>+  Path Rel File ->+  a ->+  m () persistStore path a = do   file <- persistenceFile path-  liftIO $ B.writeFile file (encode a)+  liftIO $ encodeFile (toFilePath file) a -noSuchFile :: Monad m => FilePath -> ExceptT String m a-noSuchFile file = ExceptT $ return $ Left $ "persistence file " ++ file ++ " doesn't exist"+noSuchFile :: MonadDeepError e PersistError m => Path Abs File -> m a+noSuchFile = throwHoist . PersistError.NoSuchFile . toFilePath -safeReadFile :: MonadIO m => FilePath -> m (Either IOException B.ByteString)-safeReadFile file = liftIO $ try $ B.readFile file+ensureExistence ::+  MonadIO m =>+  MonadDeepError e PersistError m =>+  Path Abs File ->+  m ()+ensureExistence file = do+  exists <- liftIO $ doesFileExist file+  unless exists (noSuchFile file) -persistLoad :: FromJSON a => FilePath -> ExceptT String (Ribo e) a+decodeError ::+  MonadDeepError e SettingError m =>+  MonadDeepError e PersistError m =>+  Path Abs File ->+  Text ->+  m a+decodeError file = throwHoist . PersistError.Decode (toFilePath file)++fileNotReadable ::+  MonadDeepError e PersistError m =>+  Path Abs File ->+  IOException ->+  m (Either String a)+fileNotReadable file _ = throwHoist $ PersistError.FileNotReadable (toFilePath file)++safeDecodeFile ::+  MonadIO m =>+  MonadDeepError e SettingError m =>+  MonadDeepError e PersistError m =>+  FromJSON a =>+  Path Abs File ->+  m a+safeDecodeFile file = do+  result <- either (fileNotReadable file) return =<< (liftIO . try . eitherDecodeFileStrict' . toFilePath $ file)+  either (decodeError file) return . mapLeft toText $ result++persistLoad ::+  MonadIO m =>+  MonadRibo m =>+  NvimE e m =>+  MonadThrow m =>+  MonadDeepError e SettingError m =>+  MonadDeepError e PersistError m =>+  FromJSON a =>+  Path Rel File ->+  m a persistLoad path = do-  file <- liftExceptT $ persistenceFile path-  json <- catchE (ExceptT $ safeReadFile file) (const $ noSuchFile file)-  ExceptT $ return $ eitherDecode json+  file <- persistenceFile path+  ensureExistence file+  safeDecodeFile file++mayPersistLoad ::+  MonadIO m =>+  MonadRibo m =>+  NvimE e m =>+  MonadDeepError e SettingError m =>+  MonadDeepError e PersistError m =>+  MonadThrow m =>+  FromJSON a =>+  Path Rel File ->+  m (Maybe a)+mayPersistLoad =+  catchAt recover . persistLoad+  where+    recover (PersistError.NoSuchFile _) =+      return Nothing+    recover e =+      throwHoist e
+ lib/Ribosome/Plugin.hs view
@@ -0,0 +1,158 @@+module Ribosome.Plugin (+  module Ribosome.Plugin,+  rpcHandler,+  rpcHandlerDef,+  RpcHandlerConfig(..),+  RpcDef(..),+) where++import Control.Monad (join, (<=<))+import Control.Monad.DeepError (MonadDeepError)+import Control.Monad.Trans.Except (runExceptT)+import Data.Default (def)+import qualified Data.Map as Map ()+import Data.MessagePack (Object(ObjectNil, ObjectBool))+import Neovim.Context (Neovim)+import Neovim.Plugin.Classes (+  AutocmdOptions(acmdPattern),+  CommandOption,+  FunctionName(..),+  FunctionalityDescription(..),+  Synchronous(..),+  )+import Neovim.Plugin.Internal (ExportedFunctionality(..), Plugin(..))++import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)+import Ribosome.Data.Mapping (MappingError)+import Ribosome.Data.Text (capitalize)+import Ribosome.Plugin.Builtin (deleteScratchRpc)+import Ribosome.Plugin.Mapping (MappingHandler, handleMappingRequest)+import Ribosome.Plugin.RpcHandler (RpcHandler(..))+import Ribosome.Plugin.TH (rpcHandler, rpcHandlerDef)+import Ribosome.Plugin.TH.Handler (+  RpcDef(RpcDef),+  RpcDefDetail(..),+  RpcHandlerConfig(..),+  rhcCmd,+  )+import Ribosome.Plugin.Watch (handleWatcherRequestSafe, watchedVariables)++poll ::+  Monad m =>+  [Object] ->+  m Object+poll _ =+  return (ObjectBool True)++pollRpc ::+  MonadDeepError e MappingError m =>+  Text ->+  RpcDef m+pollRpc pluginName =+  RpcDef (RpcFunction Sync) (capitalize pluginName <> "Poll") poll++mappingHandlerRpc ::+  MonadDeepError e MappingError m =>+  Text ->+  [MappingHandler m] ->+  RpcDef m+mappingHandlerRpc pluginName mappings =+  RpcDef (RpcFunction Async) (capitalize pluginName <> "Mapping") (handleMappingRequest mappings)++watcherRpc ::+  MonadBaseControl IO m =>+  MonadDeepError e MappingError m =>+  MonadRibo m =>+  NvimE e m =>+  Text ->+  Map Text (Object -> m ()) ->+  [RpcDef m]+watcherRpc pluginName variables =+  chromatinInit : (rpcDef <$> ["CmdlineLeave", "BufWinEnter", "VimEnter"])+  where+    chromatinInit = rpcDefFromDetail ((detail "User") { raOptions = def { acmdPattern = toString ciName } }) ciName+    ciName = "ChromatinInitialized"+    rpcDef event =+      rpcDefFromDetail (detail event) event+    rpcDefFromDetail dt event =+      RpcDef dt (name' event) (handleWatcherRequestSafe (watchedVariables variables))+    name' event = capitalize pluginName <> "VariableChanged" <> event+    detail event = RpcAutocmd event Async def++compileRpcDef ::+  RpcHandler e env m =>+  (e -> m ()) ->+  RpcDef m ->+  ExportedFunctionality env+compileRpcDef errorHandler (RpcDef detail name' rpcHandler') =+  EF (wrapDetail detail (F (encodeUtf8 name')), executeRpcHandler errorHandler rpcHandler')+  where+    wrapDetail (RpcFunction sync') n =+      Function n sync'+    wrapDetail (RpcCommand options) n =+      Command n options+    wrapDetail (RpcAutocmd event sync' options) n =+      Autocmd (encodeUtf8 event) n sync' options++nvimPlugin ::+  MonadDeepError e MappingError m =>+  RpcHandler e env m =>+  env ->+  [[RpcDef m]] ->+  (e -> m ()) ->+  Plugin env+nvimPlugin env rpcDefs errorHandler =+  Plugin env (compileRpcDef errorHandler <$> join rpcDefs)++riboPlugin ::+  MonadBaseControl IO m =>+  MonadDeepError e MappingError m =>+  MonadRibo m =>+  NvimE e m =>+  RpcHandler e env m =>+  Text ->+  env ->+  [[RpcDef m]] ->+  [MappingHandler m] ->+  (e -> m ()) ->+  Map Text (Object -> m ()) ->+  Plugin env+riboPlugin pluginName env rpcDefs mappings errorHandler variables =+  Plugin env ((compileRpcDef errorHandler <$> extra) ++ efs)+  where+    Plugin _ efs = nvimPlugin env rpcDefs errorHandler+    extra = deleteScratchRpc pluginName : pollRpc pluginName : mappingHandlerRpc pluginName mappings : watch+    watch = watcherRpc pluginName variables++executeRpcHandler ::+  ∀ e env m.+  RpcHandler e env m =>+  (e -> m ()) ->+  ([Object] -> m Object) ->+  [Object] ->+  Neovim env Object+executeRpcHandler errorHandler rpcHandler' =+  either handleError return <=< runExceptT . native . rpcHandler'+  where+    handleError e =+      ObjectNil <$ (runExceptT . native @e . errorHandler $ e)++cmd :: [CommandOption] -> RpcHandlerConfig -> RpcHandlerConfig+cmd opts conf =+  conf { rhcCmd = Just opts }++sync :: RpcHandlerConfig -> RpcHandlerConfig+sync conf =+  conf { rhcSync = Sync }++name :: Text -> RpcHandlerConfig -> RpcHandlerConfig+name n conf =+  conf { rhcName = Just n }++autocmd :: Text -> RpcHandlerConfig -> RpcHandlerConfig+autocmd event conf =+  conf { rhcAutocmd = Just event }++autocmdOptions :: AutocmdOptions -> RpcHandlerConfig -> RpcHandlerConfig+autocmdOptions options conf =+  conf { rhcAutocmdOptions = Just options }
+ lib/Ribosome/Plugin/Builtin.hs view
@@ -0,0 +1,29 @@+module Ribosome.Plugin.Builtin where++import Neovim.Plugin.Classes (Synchronous(Async))++import Data.MessagePack (Object(ObjectString, ObjectNil))+import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)+import Ribosome.Data.Mapping (MappingError)+import Ribosome.Data.Text (capitalize)+import Ribosome.Plugin.TH.Handler (RpcDef(RpcDef), RpcDefDetail(RpcFunction))+import Ribosome.Scratch (killScratchByName)++deleteScratch ::+  MonadRibo m =>+  NvimE e m =>+  [Object] ->+  m Object+deleteScratch [ObjectString name] = do+  ObjectNil <$ killScratchByName (decodeUtf8 name)+deleteScratch _ =+  return ObjectNil++deleteScratchRpc ::+  MonadDeepError e MappingError m =>+  MonadRibo m =>+  NvimE e m =>+  Text ->+  RpcDef m+deleteScratchRpc pluginName =+  RpcDef (RpcFunction Async) (capitalize pluginName <> "DeleteScratch") deleteScratch
+ lib/Ribosome/Plugin/Mapping.hs view
@@ -0,0 +1,37 @@+module Ribosome.Plugin.Mapping where++import Control.Monad.DeepError (MonadDeepError(throwHoist))+import Data.Foldable (find)+import Data.MessagePack (Object(ObjectString, ObjectNil))++import Ribosome.Data.Mapping (MappingError(InvalidArgs, NoSuchMapping), MappingIdent(MappingIdent))++data MappingHandler m =+  MappingHandler {+    mhMapping :: MappingIdent,+    mhHandler :: m ()+  }++mappingHandler :: Functor m => Text -> m () -> MappingHandler m+mappingHandler ident =+  MappingHandler (MappingIdent ident)++mapping :: MappingIdent -> [MappingHandler m] -> Maybe (MappingHandler m)+mapping ident =+  find ((ident ==) . mhMapping)++noSuchMapping :: MonadDeepError e MappingError m => MappingIdent -> m a+noSuchMapping =+  throwHoist . NoSuchMapping++executeMapping :: Functor m => MappingHandler m -> m ()+executeMapping (MappingHandler _ f) =+  f++handleMappingRequest :: MonadDeepError e MappingError m => [MappingHandler m] -> [Object] -> m Object+handleMappingRequest mappings [ObjectString s] =+  ObjectNil <$ maybe (noSuchMapping ident) executeMapping (mapping ident mappings)+  where+    ident = MappingIdent (decodeUtf8 s)+handleMappingRequest _ args =+  throwHoist (InvalidArgs args)
+ lib/Ribosome/Plugin/RpcHandler.hs view
@@ -0,0 +1,10 @@+module Ribosome.Plugin.RpcHandler where++import Control.Monad.Trans.Except (ExceptT)+import Neovim (Neovim)++class RpcHandler e env m | m -> e env where+  native :: m a -> ExceptT e (Neovim env) a++instance RpcHandler e env (ExceptT e (Neovim env)) where+  native = id
+ lib/Ribosome/Plugin/TH.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Plugin.TH where++import Data.Default (def)+import Data.Maybe (fromMaybe, maybeToList)+import qualified Data.Text as Text (unpack)+import Language.Haskell.TH+import Neovim.Plugin.Classes (+  AutocmdOptions,+  Synchronous(..),+  )++import Ribosome.Data.String (capitalize)+import Ribosome.Plugin.TH.Command (handlerParams, rpcCommand)+import Ribosome.Plugin.TH.Handler (+  RpcDef(RpcDef),+  RpcDefDetail(RpcFunction, RpcAutocmd),+  RpcHandlerConfig(RpcHandlerConfig),+  argsCase,+  defaultRpcHandlerConfig,+  functionParamTypes,+  lambdaNames,+  listParamsPattern,+  rpcLambdaWithErrorCase,+  )++functionImplementation :: Name -> ExpQ+functionImplementation name = do+  paramTypes <- functionParamTypes name+  paramNames <- lambdaNames (length paramTypes)+  rpcLambdaWithErrorCase name (argsCase name (listParamsPattern paramNames) paramNames)++rpcFunction :: String -> Synchronous -> Name -> ExpQ+rpcFunction name sync funcName = do+  fun <- functionImplementation funcName+  [|RpcDef (RpcFunction sync) $((litE (StringL name))) $(return fun)|]++rpcAutocmd :: String -> Name -> Synchronous -> Maybe AutocmdOptions -> String -> ExpQ+rpcAutocmd name funcName sync options event = do+  fun <- functionImplementation funcName+  [|RpcDef (RpcAutocmd event sync (fromMaybe def options)) $((litE (StringL name))) $(return fun)|]++vimName :: Name -> Maybe String -> String+vimName funcName =+  capitalize . fromMaybe (nameBase funcName)++rpcHandler :: (RpcHandlerConfig -> RpcHandlerConfig) -> Name -> ExpQ+rpcHandler confTrans =+  handler (confTrans defaultRpcHandlerConfig)+  where+    handler (RpcHandlerConfig sync name cmd autocmd auOptions) funcName = do+      params <- handlerParams funcName+      rpcFun <- rpcFunction vimName' sync funcName+      rpcCmd <- traverse (rpcCommand vimName' funcName params) cmd+      rpcAu <- traverse (rpcAutocmd vimName' funcName sync auOptions) (Text.unpack <$> autocmd)+      listE $ return <$> rpcFun : maybeToList rpcCmd <> maybeToList rpcAu+      where+        vimName' = vimName funcName (Text.unpack <$> name)++rpcHandlerDef :: Name -> ExpQ+rpcHandlerDef =+  rpcHandler id
+ lib/Ribosome/Plugin/TH/Command.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Plugin.TH.Command where++import Control.Exception (throw)+import Control.Monad ((<=<))+import Data.Aeson (FromJSON, eitherDecodeStrict)+import qualified Data.ByteString as ByteString (intercalate)+import Data.Either.Combinators (mapLeft)+import Data.MessagePack (Object(ObjectArray))+import Data.Text.Prettyprint.Doc (Pretty(..))+import Language.Haskell.TH+import Neovim.Exceptions (NeovimException(ErrorMessage))+import Neovim.Plugin.Classes (+  CommandArguments,+  CommandOption(..),+  mkCommandOptions,+  )++import Ribosome.Msgpack.Decode (fromMsgpack)+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Msgpack.Util (Err)+import Ribosome.Plugin.TH.Handler (+  RpcDef(RpcDef),+  RpcDefDetail(RpcCommand),+  argsCase,+  decodedCallSequence,+  functionParamTypes,+  lambdaNames,+  listParamsPattern,+  )++data CmdParams =+  ZeroParams+  |+  OnlyPrims Int+  |+  OnlyData+  |+  DataPlus Int+  deriving (Eq, Show)++data HandlerParams =+  HandlerParams {+    handlerHasArgsParam :: Bool,+    handlerCmdParams :: CmdParams+    }+  deriving (Eq, Show)++colon :: Name+colon =+  mkName ":"++colonE :: ExpQ+colonE =+  varE colon++colonP :: PatQ+colonP =+  varP colon++cmdArgsCase :: Name -> [Name] -> Q Match+cmdArgsCase handlerName paramNames =+  argsCase handlerName (listParamsPattern (mkName "_" : paramNames)) paramNames++decodeJson :: FromJSON a => [Object] -> Either Err a+decodeJson =+  mapLeft pretty . eitherDecodeStrict . ByteString.intercalate " " <=< traverse fromMsgpack++primDispatch ::+  String ->+  Name ->+  Name ->+  Name ->+  [Name] ->+  Bool ->+  ExpQ+primDispatch rpcName argsName handlerName cmdArgsName paramNames hasArgsParam =+  caseE (varE argsName) [matching, invalidArgs]+  where+    matching =+      match (primArgPattern paramNames) (normalB $ decodedCallSequence handlerName vars) []+    invalidArgs =+      match wildP (normalB [|invalidArgCount $(nameLit)|]) []+    vars = varE <$> params+    params =+      if hasArgsParam then cmdArgsName : paramNames else paramNames+    nameLit =+      litE (StringL rpcName)++jsonDispatch ::+  Name ->+  Name ->+  Name ->+  [Name] ->+  Bool ->+  ExpQ+jsonDispatch restName handlerName cmdArgsName paramNames hasArgsParam =+  infixApp prims [|(<*>)|] decodedRest+  where+    prims = decodedCallSequence handlerName vars+    vars = varE <$> params+    params = if hasArgsParam then cmdArgsName : paramNames else paramNames+    decodedRest = [|decodeJson $(varE restName)|]++primArgPattern :: [Name] -> PatQ+primArgPattern paramNames =+  foldr f (listP []) (varP <$> paramNames)+  where+    f a = infixP a (mkName ":")++jsonArgPattern :: [Name] -> Name -> PatQ+jsonArgPattern paramNames restName =+  foldr f (varP restName) (varP <$> paramNames)+  where+    f a = infixP a (mkName ":")++newtype ArgNormalizer m =+  ArgNormalizer (Text -> [Object] -> m (Object, [Object]))++shapeError :: Text -> m a+shapeError =+  throw . ErrorMessage . pretty . errorMessage+  where+    errorMessage =+      ("Bad argument shape for rpc command: " <>)++normalizeArgsFlat ::+  Monad m =>+  ArgNormalizer m+normalizeArgsFlat =+  ArgNormalizer normalize+  where+    normalize _ (cmdArgs : rest) =+      return (cmdArgs, rest)+    normalize rpcName _ =+      shapeError rpcName++normalizeArgsPlus ::+  Monad m =>+  ArgNormalizer m+normalizeArgsPlus =+  ArgNormalizer normalize+  where+    normalize _ [cmdArgs, first', ObjectArray rest] =+      return (cmdArgs, first' : rest)+    normalize rpcName _ =+      shapeError rpcName++normalizeArgs ::+  CmdParams ->+  ExpQ+normalizeArgs ZeroParams =+  [|normalizeArgsFlat|]+normalizeArgs (OnlyPrims 1) =+  [|normalizeArgsFlat|]+normalizeArgs _ =+  [|normalizeArgsPlus|]++rpc ::+  Monad m =>+  MsgpackEncode a =>+  Text ->+  ArgNormalizer m ->+  (Object -> [Object] -> Either Err (m a)) ->+  [Object] ->+  m Object+rpc rpcName (ArgNormalizer normalize) dispatch =+  toMsgpack <$$> decodeResult . uncurry dispatch <=< normalize rpcName+  where+    decodeResult =+      either (throw . ErrorMessage) id++invalidArgCount :: String -> m a+invalidArgCount =+  throw . ErrorMessage . pretty . (msg <>)+  where+    msg =+      "Wrong number of arguments for rpc handler: "++command ::+  String ->+  Name ->+  [Name] ->+  HandlerParams ->+  PatQ ->+  (Name -> Name -> [Name] -> Bool ->ExpQ) ->+  ExpQ+command rpcName handlerName paramNames (HandlerParams hasCmdArgs cmdParams) argsPattern dispatch = do+  cmdArgsName <- newName "cmdArgs"+  let+    handler =+      lamE [firstParam cmdArgsName, argsPattern] (dispatch handlerName cmdArgsName paramNames hasCmdArgs)+  [|rpc $(nameLit) $(normalizeArgs cmdParams) $(handler)|]+  where+    firstParam cmdArgsName =+      if hasCmdArgs then varP cmdArgsName+      else wildP+    nameLit =+      litE (StringL rpcName)++primCommand ::+  String ->+  Name ->+  [Name] ->+  HandlerParams ->+  ExpQ+primCommand rpcName handlerName paramNames handlerPar = do+  argsName <- newName "args"+  command rpcName handlerName paramNames handlerPar (varP argsName) (primDispatch rpcName argsName)++jsonCommand :: String -> Name -> [Name] -> HandlerParams -> ExpQ+jsonCommand rpcName handlerName paramNames handlerPar = do+  restName <- newName "rest"+  command rpcName handlerName paramNames handlerPar (jsonArgPattern paramNames restName) (jsonDispatch restName)++commandImplementation :: String -> Name -> HandlerParams -> ExpQ+commandImplementation rpcName handlerName hps@(HandlerParams _ params) =+  forParams params+  where+    forParams ZeroParams =+      primCommand rpcName handlerName [] hps+    forParams (OnlyPrims paramCount) = do+      paramNames <- lambdaNames paramCount+      primCommand rpcName handlerName paramNames hps+    forParams (DataPlus paramCount) = do+      paramNames <- lambdaNames paramCount+      jsonCommand rpcName handlerName paramNames hps+    forParams OnlyData =+      jsonCommand rpcName handlerName [] hps++isRecord :: Info -> Bool+isRecord (TyConI (DataD _ _ _ _ [RecC _ _] _)) =+  True+isRecord _ =+  False++isJsonDecodable :: Type -> Q Bool+isJsonDecodable (ConT name) =+  isRecord <$> reify name+isJsonDecodable _ =+  return False++analyzeCmdParams :: [Type] -> Q CmdParams+analyzeCmdParams =+  check . reverse+  where+    check [a] = do+      isD <- isJsonDecodable a+      return $ if isD then OnlyData else OnlyPrims 1+    check (a : rest) = do+      isD <- isJsonDecodable a+      return $ if isD then DataPlus (length rest) else OnlyPrims (length rest + 1)+    check [] =+      return ZeroParams++cmdNargs :: CmdParams -> CommandOption+cmdNargs ZeroParams =+  CmdNargs "0"+cmdNargs (OnlyPrims 1) =+  CmdNargs "1"+cmdNargs _ =+  CmdNargs "+"++rpcCommand :: String -> Name -> HandlerParams -> [CommandOption] -> ExpQ+rpcCommand rpcName funcName hps@(HandlerParams _ params) opts = do+  fun <- commandImplementation rpcName funcName hps+  [|RpcDef (RpcCommand $ mkCommandOptions (nargs : opts)) $((litE (StringL rpcName))) $(return fun)|]+  where+    nargs = cmdNargs params++removeArgsParam :: [Type] -> Q (Bool, [Type])+removeArgsParam [] =+  return (False, [])+removeArgsParam (p1 : rest) = do+  argsType <- [t|CommandArguments|]+  return $ if p1 == argsType then (True, rest) else (False, p1 : rest)++handlerParams :: Name -> Q HandlerParams+handlerParams name = do+  types <- functionParamTypes name+  (hasArgsParam, userTypes) <- removeArgsParam types+  cp <- analyzeCmdParams userTypes+  return $ HandlerParams hasArgsParam cp
+ lib/Ribosome/Plugin/TH/Handler.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Plugin.TH.Handler where++import Control.Exception (throw)+import Control.Monad (replicateM)+import Data.Functor ((<&>))+import Data.Maybe (maybeToList)+import Data.MessagePack (Object)+import Data.Text.Prettyprint.Doc (Doc, Pretty(..))+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift(..))+import Neovim.Exceptions (NeovimException(ErrorMessage))+import Neovim.Plugin.Classes (+  AutocmdOptions(AutocmdOptions),+  CommandOption(..),+  CommandOptions,+  RangeSpecification(..),+  Synchronous(..),+  )++import Ribosome.Msgpack.Decode (fromMsgpack)+import Ribosome.Msgpack.Encode (toMsgpack)++data RpcHandlerConfig =+  RpcHandlerConfig {+    rhcSync :: Synchronous,+    rhcName :: Maybe Text,+    rhcCmd :: Maybe [CommandOption],+    rhcAutocmd :: Maybe Text,+    rhcAutocmdOptions :: Maybe AutocmdOptions+  }+  deriving (Eq, Show)++defaultRpcHandlerConfig :: RpcHandlerConfig+defaultRpcHandlerConfig =+  RpcHandlerConfig Async Nothing Nothing Nothing Nothing++data RpcDefDetail =+  RpcFunction { rfSync :: Synchronous }+  |+  RpcCommand { rcOptions :: CommandOptions }+  |+  RpcAutocmd {+    raEvent :: Text,+    raSync :: Synchronous,+    raOptions :: AutocmdOptions+    }++data RpcDef m =+  RpcDef {+    rdDetail :: RpcDefDetail,+    rdName :: Text,+    rdHandler :: [Object] -> m Object+  }++instance Lift Synchronous where+  lift Sync = [|Sync|]+  lift Async = [|Async|]++instance Lift RangeSpecification where+  lift CurrentLine =+    [|CurrentLine|]+  lift WholeFile =+    [|WholeFile|]+  lift (RangeCount a) =+    [|RangeCount a|]++instance Lift CommandOption where+  lift (CmdSync a) =+    [|CmdSync a|]+  lift CmdRegister =+    [|CmdRegister|]+  lift (CmdNargs a) =+    [|CmdNargs a|]+  lift (CmdRange a) =+    [|CmdRange a|]+  lift (CmdCount a) =+    [|CmdCount a|]+  lift CmdBang =+    [|CmdBang|]++instance Lift AutocmdOptions where+  lift (AutocmdOptions p n g) =+    [|AutocmdOptions p n g|]++unfoldFunctionParams :: Type -> [Type]+unfoldFunctionParams (ForallT _ _ t) =+  unfoldFunctionParams t+unfoldFunctionParams (AppT (AppT ArrowT t) r) =+  t : unfoldFunctionParams r+unfoldFunctionParams _ = []++functionParamTypes :: Name -> Q [Type]+functionParamTypes name =+  reify name <&> \case+    (VarI _ functionType _) -> unfoldFunctionParams functionType+    _ -> fail $ "rpc handler `" <> show name <> "` is not a function"++errorBody :: Name -> BodyQ+errorBody rpcName =+  normalB [|throw . ErrorMessage . pretty $ ($(errLit) :: String)|]+  where+    errLit =+      litE (StringL errMsg)+    errMsg =+      "Wrong number of arguments for rpc handler: " <> nameBase rpcName++errorCase :: Name -> Q Match+errorCase rpcName =+  match wildP (errorBody rpcName) []++failedEvaluation :: Q Match+failedEvaluation = do+  e <- newName "e"+  match (conP (mkName "Left") [varP e]) (normalB [|throw . ErrorMessage $ ($(varE e) :: Doc AnsiStyle)|]) []++successfulEvaluation :: Q Match+successfulEvaluation = do+  action <- newName "action"+  match (conP (mkName "Right") [varP action]) (normalB [|toMsgpack <$> $(varE action)|]) []++dispatchCase :: PatQ -> ExpQ -> Q Match+dispatchCase params dispatch =+  match params (normalB (caseE dispatch resultCases)) []+  where+    resultCases = [successfulEvaluation, failedEvaluation]++decodedCallSequence :: Name -> [ExpQ] -> ExpQ+decodedCallSequence handlerName =+  foldl decodeSeq [|pure $(varE handlerName)|]+  where+    decodeSeq z a = infixApp z [|(<*>)|] [|fromMsgpack $(a)|]++argsCase :: Name -> PatQ -> [Name] -> Q Match+argsCase handlerName params paramNames =+  dispatchCase params dispatch+  where+    dispatch = decodedCallSequence handlerName paramVars+    paramVars = varE <$> paramNames++rpcLambda :: Q Match -> Maybe (Q Match) -> ExpQ+rpcLambda matchingArgsCase errorCase' = do+  args <- newName "args"+  lamE [varP args] [|$(caseE (varE args) (matchingArgsCase : maybeToList errorCase'))|]++rpcLambdaWithErrorCase :: Name -> Q Match -> ExpQ+rpcLambdaWithErrorCase funcName matchingArgsCase =+  rpcLambda matchingArgsCase $ Just (errorCase funcName)++rpcLambdaWithoutErrorCase :: Q Match -> ExpQ+rpcLambdaWithoutErrorCase matchingArgsCase =+  rpcLambda matchingArgsCase Nothing++listParamsPattern :: [Name] -> PatQ+listParamsPattern =+  listP . (varP <$>)++lambdaNames :: Int -> Q [Name]+lambdaNames count =+  replicateM count (newName "a")
+ lib/Ribosome/Plugin/Watch.hs view
@@ -0,0 +1,82 @@+module Ribosome.Plugin.Watch where++import Control.Lens (Lens')+import qualified Control.Lens as Lens (at)+import Control.Monad.DeepError (catchAt)+import qualified Data.Map as Map (toList)+import Data.Map.Strict (Map)+import Data.MessagePack (Object(ObjectNil))++import Ribosome.Control.Lock (lockOrSkip)+import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginInternalL, pluginInternalModifyL)+import Ribosome.Control.Ribosome (RibosomeInternal)+import qualified Ribosome.Control.Ribosome as RibosomeInternal (watchedVariables)+import Ribosome.Nvim.Api.IO (vimGetVar)+import Ribosome.Nvim.Api.RpcCall (RpcError)++data WatchedVariable m =+  WatchedVariable {+    wvName :: Text,+    wvHandler :: Object -> m ()+  }++watchedVariables :: Map Text (Object -> m ()) -> [WatchedVariable m]+watchedVariables =+  fmap create . Map.toList+  where+    create (name, handler) = WatchedVariable name handler++storedVarLens :: Text -> Lens' RibosomeInternal (Maybe Object)+storedVarLens name =+  RibosomeInternal.watchedVariables . Lens.at name++runHandler ::+  MonadRibo m =>+  WatchedVariable m ->+  Object ->+  m ()+runHandler (WatchedVariable name handler) new = do+  pluginInternalModifyL (storedVarLens name) (const (Just new))+  handler new++compareVar ::+  MonadRibo m =>+  WatchedVariable m ->+  Maybe Object ->+  Object ->+  m ()+compareVar _ (Just old) new | old == new =+  return ()+compareVar wv _ new =+  runHandler wv new++checkVar ::+  MonadRibo m =>+  NvimE e m =>+  WatchedVariable m ->+  m ()+checkVar wv@(WatchedVariable name _) = do+  old <- pluginInternalL (storedVarLens name)+  new <- catchAt @RpcError recover (Right <$> vimGetVar name)+  traverse_ (compareVar wv old) new+  where+  recover _ = return (Left ())++handleWatcherRequest ::+  MonadRibo m =>+  NvimE e m =>+  [WatchedVariable m] ->+  [Object] ->+  m Object+handleWatcherRequest variables _ =+  ObjectNil <$ traverse_ checkVar variables++handleWatcherRequestSafe ::+  MonadBaseControl IO m =>+  MonadRibo m =>+  NvimE e m =>+  [WatchedVariable m] ->+  [Object] ->+  m Object+handleWatcherRequestSafe variables o =+  ObjectNil <$ lockOrSkip "variable-watcher" (void $ handleWatcherRequest variables o)
+ lib/Ribosome/Prelude.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Ribosome.Prelude (+  module Control.Monad.DeepError,+  module Control.Monad.DeepState,+  module Control.Monad.Trans.Control,+  module Data.DeepLenses,+  module Data.DeepPrisms,+  module Data.Default,+  module Data.Foldable,+  module Relude,+  dbg,+  dbgs,+  dbgm,+  makeClassy,+  mapLeft,+  modify,+  tuple,+  undefined,+  unit,+  unsafeLog,+  unsafeLogS,+  (<$$>),+) where++import Control.Lens (makeClassy)+import Control.Monad.DeepError (MonadDeepError(throwHoist), catchAs, catchAt, hoistEither, hoistMaybe, ignoreError)+import Control.Monad.DeepState (+  MonadDeepState,+  get,+  getL,+  gets,+  getsL,+  modifyL,+  modifyM,+  modifyM',+  put,+  setL,+  stateM,+  )+import qualified Control.Monad.DeepState as DeepState (modify)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.DeepLenses (deepLenses)+import Data.DeepPrisms (deepPrisms)+import Data.Default (Default(def))+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldl, traverse_)+import Data.Functor (void)+import Data.Functor.Syntax ((<$$>))+import GHC.Err (undefined)+import GHC.IO.Unsafe (unsafePerformIO)+import Relude hiding (undefined, Type, state, modify, gets, get, put)++dbg :: Monad m => Text -> m ()+dbg msg = do+  () <- return $ unsafePerformIO (putStrLn msg)+  return ()++dbgs :: Monad m => Show a => a -> m ()+dbgs =+  dbg . show++dbgm :: Monad m => Show a => m a -> m a+dbgm ma = do+  a <- ma+  dbgs a+  return a++unit ::+  Applicative f =>+  f ()+unit =+  pure ()++tuple ::+  Applicative f =>+  f a ->+  f b ->+  f (a, b)+tuple fa fb =+  (,) <$> fa <*> fb++unsafeLogS :: Show a => a -> b -> b+unsafeLogS a b = unsafePerformIO $ print a >> return b++unsafeLog :: Text -> b -> b+unsafeLog a b = unsafePerformIO $ putStrLn a >> return b++modify ::+  ∀ s' s m .+  MonadDeepState s s' m =>+  (s' -> s') ->+  m ()+modify =+  DeepState.modify
+ lib/Ribosome/PreludeExport.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Ribosome.PreludeExport (+  module Ribosome.Prelude,+  module Ribosome.Control.Monad.Ribo,+  module Ribosome.Log,+  module Ribosome.Nvim.Api.RpcCall,+  module Ribosome.Msgpack.Decode,+  module Ribosome.Msgpack.Encode,+  sleep,+) where++import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE)+import Ribosome.Log (logDebug, logError, logInfo, showDebug)+import Ribosome.Msgpack.Decode (MsgpackDecode(fromMsgpack))+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))+import Ribosome.Nvim.Api.RpcCall (RpcError(..))+import Ribosome.Prelude+import Ribosome.System.Time (sleep)
lib/Ribosome/Scratch.hs view
@@ -1,83 +1,237 @@-module Ribosome.Scratch(-  showInScratch,-) where+module Ribosome.Scratch where -import Neovim (-  Neovim,-  Buffer,-  Window,-  Tabpage,-  toObject,-  vim_command',-  vim_get_current_window',-  vim_get_current_tabpage',-  buffer_set_option',-  buffer_set_name',-  window_get_buffer',-  window_set_option',-  )+import Control.Lens (Lens')+import qualified Control.Lens as Lens (at, set)+import Control.Monad (unless)+import Data.Default (Default(def))+import Data.Foldable (traverse_)++import Ribosome.Api.Buffer (setBufferContent, wipeBuffer)+import Ribosome.Api.Syntax (executeWindowSyntax)+import Ribosome.Api.Tabpage (closeTabpage)+import Ribosome.Api.Window (closeWindow)+import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginInternalL, pluginInternalModify, pluginName)+import Ribosome.Control.Ribosome (RibosomeInternal)+import qualified Ribosome.Control.Ribosome as Ribosome (scratch) import Ribosome.Data.Scratch (Scratch(Scratch))+import qualified Ribosome.Data.Scratch as Scratch (Scratch(scratchPrevious, scratchWindow)) import Ribosome.Data.ScratchOptions (ScratchOptions(ScratchOptions))-import Ribosome.Api.Buffer (setBufferContent)+import qualified Ribosome.Data.ScratchOptions as ScratchOptions (ScratchOptions(name, resize, maxSize))+import Ribosome.Data.Text (capitalize)+import Ribosome.Mapping (activateBufferMapping)+import Ribosome.Msgpack.Encode (toMsgpack)+import Ribosome.Msgpack.Error (DecodeError)+import Ribosome.Nvim.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Nvim.Api.IO (+  bufferGetNumber,+  bufferSetName,+  bufferSetOption,+  vimCommand,+  vimGetCurrentTabpage,+  vimGetCurrentWindow,+  vimSetCurrentWindow,+  windowGetBuffer,+  windowIsValid,+  windowSetHeight,+  windowSetOption,+  )+import Ribosome.Nvim.Api.RpcCall (RpcError) -createScratchTab :: Neovim e Tabpage+createScratchTab :: NvimE e m => m Tabpage createScratchTab = do-  vim_command' "tabnew"-  vim_get_current_tabpage'+  vimCommand "tabnew"+  vimGetCurrentTabpage -createScratchWindow :: Bool -> Bool -> Maybe Int -> Neovim e Window-createScratchWindow vertical wrap size = do-  vim_command' $ prefix ++ cmd-  win <- vim_get_current_window'-  window_set_option' win "wrap" (toObject wrap)+createScratchWindow :: NvimE e m => Bool -> Bool -> Bool -> Maybe Int -> m Window+createScratchWindow vertical wrap bottom size = do+  vimCommand $ prefix <> cmd+  win <- vimGetCurrentWindow+  windowSetOption win "wrap" (toMsgpack wrap)+  windowSetOption win "number" (toMsgpack False)+  windowSetOption win "cursorline" (toMsgpack True)+  when bottom (vimCommand "wincmd J")   return win   where     cmd = if vertical then "vnew" else "new"     prefix = maybe "" show size -createScratchUiInTab :: Neovim e (Window, Maybe Tabpage)+createScratchUiInTab :: NvimE e m => m (Window, Maybe Tabpage) createScratchUiInTab = do   tab <- createScratchTab-  win <- vim_get_current_window'+  win <- vimGetCurrentWindow   return (win, Just tab) -createScratchUiInWindow :: Bool -> Bool -> Maybe Int -> Neovim e (Window, Maybe Tabpage)-createScratchUiInWindow vertical wrap size = do-  win <- createScratchWindow vertical wrap size+createScratchUiInWindow :: NvimE e m => Bool -> Bool -> Bool -> Maybe Int -> m (Window, Maybe Tabpage)+createScratchUiInWindow vertical wrap bottom size = do+  win <- createScratchWindow vertical wrap bottom size   return (win, Nothing) -createScratchUi :: Bool -> Bool -> Bool -> Maybe Int -> Neovim e (Window, Maybe Tabpage)-createScratchUi True _ _ _ =+createScratchUi :: NvimE e m => ScratchOptions -> m (Window, Maybe Tabpage)+createScratchUi (ScratchOptions False vertical wrap _ _ bottom _ size _ _ _) =+  createScratchUiInWindow vertical wrap bottom size+createScratchUi _ =   createScratchUiInTab-createScratchUi False vertical wrap size =-  createScratchUiInWindow vertical wrap size -configureScratchBuffer :: Buffer -> String -> Neovim e ()+configureScratchBuffer :: NvimE e m => Buffer -> Text -> m () configureScratchBuffer buffer name = do-  buffer_set_option' buffer "buftype" (toObject ("nofile" :: String))-  buffer_set_option' buffer "bufhidden" (toObject ("wipe" :: String))-  buffer_set_name' buffer name+  bufferSetOption buffer "buftype" (toMsgpack ("nofile" :: Text))+  bufferSetOption buffer "bufhidden" (toMsgpack ("wipe" :: Text))+  bufferSetName buffer name -setupScratchBuffer :: Window -> String -> Neovim e Buffer+setupScratchBuffer :: NvimE e m => Window -> Text -> m Buffer setupScratchBuffer window name = do-  buffer <- window_get_buffer' window+  buffer <- windowGetBuffer window   configureScratchBuffer buffer name   return buffer -createScratch :: ScratchOptions -> Neovim e Scratch-createScratch (ScratchOptions useTab vertical size wrap name) = do-  (window, tab) <- createScratchUi useTab vertical wrap size+scratchLens :: Text -> Lens' RibosomeInternal (Maybe Scratch)+scratchLens name =+  Ribosome.scratch . Lens.at name++setupScratchIn ::+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  Window ->+  Window ->+  Maybe Tabpage ->+  ScratchOptions ->+  m Scratch+setupScratchIn previous window tab (ScratchOptions useTab _ _ focus _ _ _ _ syntax mappings name) = do   buffer <- setupScratchBuffer window name-  return (Scratch buffer window tab)+  traverse_ (executeWindowSyntax window) syntax+  traverse_ (activateBufferMapping buffer) mappings+  unless (focus || useTab) $ vimSetCurrentWindow previous+  let scratch = Scratch name buffer window previous tab+  pluginInternalModify $ Lens.set (scratchLens name) (Just scratch)+  setupDeleteAutocmd scratch+  return scratch -setScratchContent :: Scratch -> [String] -> Neovim e ()-setScratchContent (Scratch buffer _ _) lines' = do-  buffer_set_option' buffer "modifiable" (toObject True)-  setBufferContent buffer lines'-  buffer_set_option' buffer "modifiable" (toObject False)+setupDeleteAutocmd ::+  MonadRibo m =>+  NvimE e m =>+  Scratch ->+  m ()+setupDeleteAutocmd (Scratch name buffer _ _ _) = do+  pname <- capitalize <$> pluginName+  number <- bufferGetNumber buffer+  vimCommand "augroup RibosomeScratch"+  vimCommand $ "autocmd RibosomeScratch BufDelete <buffer=" <> show number <> "> " <> deleteCall pname+  where+    deleteCall pname =+      "silent! call " <> pname <> "DeleteScratch('" <> name <> "')" -showInScratch :: [String] -> ScratchOptions -> Neovim e Scratch+createScratch ::+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  ScratchOptions ->+  m Scratch+createScratch options = do+  previous <- vimGetCurrentWindow+  (window, tab) <- createScratchUi options+  setupScratchIn previous window tab options++updateScratch ::+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  Scratch ->+  ScratchOptions ->+  m Scratch+updateScratch (Scratch _ _ oldWindow _ oldTab) options = do+  previous <- vimGetCurrentWindow+  winValid <- windowIsValid oldWindow+  (window, tab) <- if winValid then return (oldWindow, oldTab) else createScratchUi options+  setupScratchIn previous window tab options++lookupScratch ::+  MonadRibo m =>+  Text ->+  m (Maybe Scratch)+lookupScratch name =+  pluginInternalL (scratchLens name)++ensureScratch ::+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  ScratchOptions ->+  m Scratch+ensureScratch options = do+  f <- maybe createScratch updateScratch <$> lookupScratch (ScratchOptions.name options)+  f options++setScratchContent ::+  Foldable t =>+  NvimE e m =>+  ScratchOptions ->+  Scratch ->+  t Text ->+  m ()+setScratchContent options (Scratch _ buffer win _ _) lines' = do+  bufferSetOption buffer "modifiable" (toMsgpack True)+  setBufferContent buffer (toList lines')+  bufferSetOption buffer "modifiable" (toMsgpack False)+  when (ScratchOptions.resize options) (ignoreError @RpcError $ windowSetHeight win size)+  where+    size = max 1 $ min (length lines') (fromMaybe 30 (ScratchOptions.maxSize options))++showInScratch ::+  Foldable t =>+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  t Text ->+  ScratchOptions ->+  m Scratch showInScratch lines' options = do-  scratch <- createScratch options-  setScratchContent scratch lines'+  scratch <- ensureScratch options+  setScratchContent options scratch lines'   return scratch++showInScratchDef ::+  Foldable t =>+  MonadDeepError e DecodeError m =>+  MonadRibo m =>+  NvimE e m =>+  t Text ->+  m Scratch+showInScratchDef lines' =+  showInScratch lines' def++killScratch ::+  MonadRibo m =>+  NvimE e m =>+  Scratch ->+  m ()+killScratch (Scratch name buffer window _ tab) = do+  catchAs @RpcError () removeAutocmd+  traverse_ closeTabpage tab *> closeWindow window *> wipeBuffer buffer+  pluginInternalModify $ Lens.set (scratchLens name) Nothing+  where+    removeAutocmd = do+      number <- bufferGetNumber buffer+      vimCommand $ "autocmd! RibosomeScratch BufDelete <buffer=" <> show number <> ">"++killScratchByName ::+  MonadRibo m =>+  NvimE e m =>+  Text ->+  m ()+killScratchByName name = do+  traverse_ killScratch =<< lookupScratch name++scratchPreviousWindow ::+  MonadRibo m =>+  Text ->+  m (Maybe Window)+scratchPreviousWindow =+  fmap Scratch.scratchPrevious <$$> lookupScratch++scratchWindow ::+  MonadRibo m =>+  Text ->+  m (Maybe Window)+scratchWindow =+  fmap Scratch.scratchWindow <$$> lookupScratch
+ lib/Ribosome/System/Time.hs view
@@ -0,0 +1,20 @@+module Ribosome.System.Time where++import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Time.Clock.POSIX (getPOSIXTime)+import GHC.Float (word2Double)++epochSeconds :: MonadIO m => m Int+epochSeconds = liftIO $ fmap round getPOSIXTime++usleep :: MonadIO m => Double -> m ()+usleep =+  liftIO . threadDelay . round++sleep :: MonadIO m => Double -> m ()+sleep seconds =+  usleep $ seconds * 1e6++sleepW :: MonadIO m => Word -> m ()+sleepW = sleep . word2Double
− lib/Ribosome/Test/Embed.hs 
@@ -1,180 +0,0 @@-module Ribosome.Test.Embed(-  defaultTestConfig,-  defaultTestConfigWith,-  TestConfig (..),-  Vars(..),-  unsafeEmbeddedSpec,-  setVars,-  setupPluginEnv,-  quitNvim,-) where--import Control.Monad.IO.Class (liftIO)-import Control.Monad.Reader (runReaderT)-import Control.Monad.Trans.Resource (runResourceT)-import Data.Default (Default(def))-import Data.Foldable (traverse_)-import Data.Functor (void)-import Data.Maybe (fromMaybe)-import GHC.IO.Handle (Handle)-import Neovim (Neovim, Object, vim_set_var', vim_command)-import qualified Neovim.Context.Internal as Internal(-  Neovim(Neovim),-  Config,-  newConfig,-  retypeConfig,-  mkFunctionMap,-  pluginSettings,-  globalFunctionMap,-  )-import Neovim.RPC.Common (RPCConfig, newRPCConfig)-import Neovim.RPC.EventHandler (runEventHandler)-import Neovim.RPC.SocketReader (runSocketReader)-import System.Directory (makeAbsolute)-import System.Exit (ExitCode)-import qualified System.Posix.Signals as Signal (signalProcess, killProcess)-import System.Process (getPid)-import System.Process.Typed (-  ProcessConfig,-  Process,-  withProcess,-  proc,-  setStdin,-  setStdout,-  getStdin,-  getStdout,-  unsafeProcessHandle,-  createPipe,-  getExitCode,-  )-import UnliftIO.Async (async, cancel, race)-import UnliftIO.Exception (tryAny, bracket)-import UnliftIO.STM (atomically, putTMVar)--import Ribosome.Api.Option (rtpCat)-import Ribosome.Control.Ribo (Ribo)-import Ribosome.Control.Ribosome (Ribosome(Ribosome), newInternalTVar)-import Ribosome.Data.Time (sleep, sleepW)--type Runner env = TestConfig -> Neovim env () -> Neovim env ()--newtype Vars = Vars [(String, Object)]--data TestConfig =-  TestConfig {-    tcPluginName :: String,-    tcExtraRtp :: String,-    tcLogPath :: FilePath,-    tcTimeout :: Word,-    tcCmdline :: Maybe [String],-    tcCmdArgs :: [String],-    tcVariables :: Vars-  }--instance Default TestConfig where-  def = TestConfig "ribosome" "test/f/fixtures/rtp" "test/f/temp/log" 5 def def (Vars [])--defaultTestConfigWith :: String -> Vars -> TestConfig-defaultTestConfigWith name = TestConfig name "test/f/fixtures/rtp" "test/f/temp/log" 5 def def--defaultTestConfig :: String -> TestConfig-defaultTestConfig name = defaultTestConfigWith name (Vars [])--setVars :: Vars -> Neovim e ()-setVars (Vars vars) =-  traverse_ (uncurry vim_set_var') vars--setupPluginEnv :: TestConfig -> Neovim e ()-setupPluginEnv (TestConfig _ rtp _ _ _ _ vars) = do-  absRtp <- liftIO $ makeAbsolute rtp-  rtpCat absRtp-  setVars vars--killPid :: Integral a => a -> IO ()-killPid =-  void . tryAny . Signal.signalProcess Signal.killProcess . fromIntegral--killProcess :: Process i o e -> IO ()-killProcess prc = do-  let handle = unsafeProcessHandle prc-  mayPid <- getPid handle-  traverse_ killPid mayPid--testNvimProcessConfig :: TestConfig -> ProcessConfig Handle Handle ()-testNvimProcessConfig TestConfig {..} =-  setStdin createPipe $ setStdout createPipe $ proc "nvim" $ args ++ tcCmdArgs-  where-    args = fromMaybe defaultArgs tcCmdline-    defaultArgs = ["--embed", "-n", "-u", "NONE", "-i", "NONE"]--startHandlers :: NvimProc -> TestConfig -> Internal.Config RPCConfig -> IO (IO ())-startHandlers prc TestConfig{..} nvimConf = do-  socketReader <- run runSocketReader getStdout-  eventHandler <- run runEventHandler getStdin-  atomically $ putTMVar (Internal.globalFunctionMap nvimConf) (Internal.mkFunctionMap [])-  let stopEventHandlers = traverse_ cancel [socketReader, eventHandler]-  return stopEventHandlers-  where-    run runner stream = async . void $ runner (stream prc) emptyConf-    emptyConf = nvimConf { Internal.pluginSettings = Nothing }--runNeovimThunk :: Internal.Config e -> Neovim e a -> IO ()-runNeovimThunk cfg (Internal.Neovim thunk) =-  void $ runReaderT (runResourceT thunk) cfg--type NvimProc = Process Handle Handle ()--waitQuit :: NvimProc -> IO (Maybe ExitCode)-waitQuit prc =-  wait 30-  where-    wait :: Int -> IO (Maybe ExitCode)-    wait 0 = return Nothing-    wait count = do-      code <- getExitCode prc-      case code of-        Just a -> return $ Just a-        Nothing -> do-          sleep 0.1-          wait $ count - 1--quitNvim :: Internal.Config e -> NvimProc -> IO ()-quitNvim testCfg prc = do-  quitThread <- async $ runNeovimThunk testCfg quit-  result <- waitQuit prc-  case result of-    Just _ -> return ()-    Nothing -> killProcess prc-  cancel quitThread-  where-    quit = vim_command "qall!"--shutdownNvim :: Internal.Config e -> NvimProc -> IO () -> IO ()-shutdownNvim _ prc stopEventHandlers = do-  stopEventHandlers-  killProcess prc-  -- quitNvim testCfg prc--runTest :: TestConfig -> Internal.Config (Ribosome e) -> Ribo e () -> IO () -> IO ()-runTest TestConfig{..} testCfg thunk _ = do-  result <- race (sleepW tcTimeout) (runNeovimThunk testCfg thunk)-  case result of-    Right _ -> return ()-    Left _ -> fail $ "test exceeded timeout of " ++ show tcTimeout ++ " seconds"--runEmbeddedNvim :: TestConfig -> Ribosome e -> Ribo e () -> NvimProc -> IO ()-runEmbeddedNvim conf ribo thunk prc = do-  nvimConf <- Internal.newConfig (pure Nothing) newRPCConfig-  let testCfg = Internal.retypeConfig ribo nvimConf-  bracket (startHandlers prc conf nvimConf) (shutdownNvim testCfg prc) (runTest conf testCfg thunk)--runEmbedded :: TestConfig -> Ribosome e -> Ribo e () -> IO ()-runEmbedded conf ribo thunk = do-  let pc = testNvimProcessConfig conf-  withProcess pc $ runEmbeddedNvim conf ribo thunk--unsafeEmbeddedSpec :: Runner (Ribosome e) -> TestConfig -> e -> Ribo e () -> IO ()-unsafeEmbeddedSpec runner conf env spec = do-  internal <- newInternalTVar-  let ribo = Ribosome (tcPluginName conf) internal env-  runEmbedded conf ribo $ runner conf spec
− lib/Ribosome/Test/Exists.hs 
@@ -1,41 +0,0 @@-module Ribosome.Test.Exists(-  waitForPlugin,-) where--import Control.Monad.IO.Class (MonadIO)-import Data.Char (toUpper)-import Neovim--import Ribosome.Data.Time (epochSeconds, sleep)--capitalize :: String -> String-capitalize [] = []-capitalize (head' : tail') = toUpper head' : tail'--retry :: MonadIO f => Double -> Int -> f a -> (a -> f (Either String b)) -> f b-retry interval timeout thunk check = do-  start <- epochSeconds-  step start-  where-    step start = do-      result <- thunk-      checked <- check result-      recurse start checked-    recurse _ (Right b) = return b-    recurse start (Left e) = do-      current <- epochSeconds-      if (current - start) < timeout-      then do-        sleep interval-        step start-      else fail e--waitForPlugin :: String -> Double -> Int -> Neovim env ()-waitForPlugin name interval timeout =-  retry interval timeout thunk check-  where-    thunk = vim_call_function "exists" [toObject $ "*" ++ capitalize name ++ "Poll"]-    check (Right (ObjectInt 1)) = return $ Right ()-    check (Right a) = return $ Left $ errormsg ++ "weird return type " ++ show a-    check (Left e) = return $ Left $ errormsg ++ show e-    errormsg = "plugin didn't start within " ++ show timeout ++ " seconds: "
− lib/Ribosome/Test/File.hs 
@@ -1,32 +0,0 @@-module Ribosome.Test.File(-  tempDirIO,-  tempDir,-  fixture,-) where--import Control.Monad.IO.Class (liftIO, MonadIO)-import System.Directory (canonicalizePath, createDirectoryIfMissing, removePathForcibly)-import System.FilePath ((</>))--testDir :: String -> IO FilePath-testDir prefix = canonicalizePath $ "test" </> prefix---- raises exception if cwd is not the package root so we don't damage anything-tempDirIO :: String -> FilePath -> IO FilePath-tempDirIO prefix path = do-  base <- testDir prefix-  let dir = base </> "temp"-  removePathForcibly dir-  createDirectoryIfMissing False dir-  let absPath = dir </> path-  createDirectoryIfMissing True absPath-  return absPath--tempDir :: MonadIO m => String -> FilePath -> m FilePath-tempDir prefix path =-  liftIO $ tempDirIO prefix path--fixture :: MonadIO m => String -> FilePath -> m FilePath-fixture prefix path = do-  base <- liftIO $ testDir prefix-  return $ base </> "fixtures" </> path
− lib/Ribosome/Test/Functional.hs 
@@ -1,81 +0,0 @@-module Ribosome.Test.Functional(-  startPlugin,-  fSpec,-  functionalSpec,-  tempDir,-  tempFile,-  fixture,-) where--import Control.Exception (finally)-import Control.Monad (when)-import Control.Monad.IO.Class-import Data.Foldable (traverse_)-import Neovim (Neovim, vim_command')-import System.Console.ANSI (setSGR, SGR(SetColor, Reset), ConsoleLayer(Foreground), ColorIntensity(Dull), Color(Green))-import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removePathForcibly, doesFileExist, makeAbsolute)-import System.FilePath (takeDirectory, (</>), takeFileName)--import Ribosome.Control.Ribo (Ribo)-import Ribosome.Test.Embed (TestConfig(..), unsafeEmbeddedSpec, setupPluginEnv)-import Ribosome.Test.Exists (waitForPlugin)-import qualified Ribosome.Test.File as F (tempDir, fixture)--jobstart :: MonadIO f => String -> f String-jobstart cmd = do-  dir <- liftIO getCurrentDirectory-  return $ "call jobstart('" ++ cmd ++ "', { 'rpc': v:true, 'cwd': '" ++ dir ++ "' })"--logFile :: TestConfig -> IO FilePath-logFile TestConfig{..} = makeAbsolute $ tcLogPath ++ "-spec"--startPlugin :: TestConfig -> Neovim env ()-startPlugin tc@TestConfig{..} = do-  absLogPath <- liftIO $ makeAbsolute tcLogPath-  absLogFile <- liftIO $ logFile tc-  liftIO $ createDirectoryIfMissing True (takeDirectory absLogPath)-  liftIO $ removePathForcibly absLogFile-  setupPluginEnv tc-  cmd <- jobstart $ "stack run -- -l " ++ absLogFile ++ " -v INFO"-  vim_command' cmd-  waitForPlugin tcPluginName 0.1 3--fSpec :: TestConfig -> Neovim env () -> Neovim env ()-fSpec conf spec = startPlugin conf >> spec--showLog' :: String -> IO ()-showLog' output = do-  putStrLn ""-  setSGR [SetColor Foreground Dull Green]-  putStrLn "plugin output:"-  setSGR [Reset]-  traverse_ putStrLn (lines output)-  putStrLn ""--showLog :: TestConfig -> IO ()-showLog conf = do-  file <- logFile conf-  exists <- doesFileExist file-  when exists $ do-    output <- readFile file-    case output of-      [] -> return ()-      o -> showLog' o--functionalSpec :: TestConfig -> Ribo () () -> IO ()-functionalSpec conf spec =-  finally (unsafeEmbeddedSpec fSpec conf () spec) (showLog conf)--fPrefix :: String-fPrefix = "f"--tempDir :: FilePath -> Neovim e FilePath-tempDir = F.tempDir fPrefix--tempFile :: FilePath -> Neovim e FilePath-tempFile file = do-  absDir <- tempDir $ takeDirectory file-  return $ absDir </> takeFileName file--fixture :: MonadIO m => FilePath -> m FilePath-fixture = F.fixture fPrefix
− lib/Ribosome/Test/Unit.hs 
@@ -1,37 +0,0 @@-module Ribosome.Test.Unit(-  unitSpec,-  tempDir,-  tempFile,-  uPrefix,-  fixture,-) where--import Control.Monad.IO.Class (MonadIO)-import Neovim (Neovim)-import Ribosome.Control.Ribo (Ribo)-import Ribosome.Test.Embed (TestConfig(..), setupPluginEnv, unsafeEmbeddedSpec)-import qualified Ribosome.Test.File as F (tempDir, fixture)-import System.FilePath (takeDirectory, takeFileName, (</>))--uPrefix :: String-uPrefix = "u"--uSpec :: TestConfig -> Neovim env () -> Neovim env ()-uSpec conf spec = do-  setupPluginEnv conf-  spec--unitSpec :: TestConfig -> e -> Ribo e () -> IO ()-unitSpec =-  unsafeEmbeddedSpec uSpec--tempDir :: FilePath -> Neovim e FilePath-tempDir = F.tempDir uPrefix--tempFile :: FilePath -> Neovim e FilePath-tempFile file = do-  absDir <- tempDir $ takeDirectory file-  return $ absDir </> takeFileName file--fixture :: MonadIO m => FilePath -> m FilePath-fixture = F.fixture uPrefix
+ lib/Ribosome/Tmux/Run.hs view
@@ -0,0 +1,36 @@+module Ribosome.Tmux.Run where++import Chiasma.Data.TmuxError (TmuxError)+import Chiasma.Monad.Stream (TmuxProg)+import qualified Chiasma.Monad.Stream as Chiasma (runTmux)+import Chiasma.Native.Api (TmuxNative(TmuxNative))+import Control.Monad.Catch (MonadMask)+import Control.Monad.DeepError (MonadDeepError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Data.DeepPrisms (DeepPrisms)++import Ribosome.Config.Setting (settingMaybe)+import Ribosome.Config.Settings (tmuxSocket)+import Ribosome.Control.Monad.Ribo (MonadRibo, Nvim, Ribo)++runTmux ::+  (MonadIO m, MonadRibo m, MonadDeepError e TmuxError m, MonadMask m, Nvim m) =>+  TmuxProg m a ->+  m a+runTmux prog = do+  socket <- settingMaybe tmuxSocket+  Chiasma.runTmux (TmuxNative socket) prog++runTmuxE ::+  (MonadIO m, MonadRibo m, MonadMask m, Nvim m) =>+  TmuxProg (ExceptT TmuxError m) a ->+  m (Either TmuxError a)+runTmuxE =+  runExceptT . runTmux++class RunTmux m where+  runRiboTmux :: TmuxProg m b -> m b++instance DeepPrisms e TmuxError => RunTmux (Ribo s e) where+    runRiboTmux = runTmux
lib/Ribosome/Unsafe.hs view
@@ -1,8 +1,9 @@-module Ribosome.Unsafe(-  unsafeLog,-) where+module Ribosome.Unsafe where  import GHC.IO.Unsafe (unsafePerformIO) -unsafeLog :: Show a => a -> b -> b-unsafeLog a b = unsafePerformIO $ (print a) >> return b+unsafeLogS :: Show a => a -> b -> b+unsafeLogS a b = unsafePerformIO $ print a >> return b++unsafeLog :: Text -> b -> b+unsafeLog a b = unsafePerformIO $ putStrLn a >> return b
ribosome.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: ribosome-version: 0.2.2.0-license: MIT+version: 0.3.0.0+license: OtherLicense license-file: LICENSE copyright: 2019 Torsten Schmits maintainer: tek@tryp.io@@ -10,7 +10,7 @@ bug-reports: https://github.com/tek/ribosome-hs/issues synopsis: api extensions for nvim-hs description:-    Please see the README on GitHub at <https://github.com/tek/proteome-hs>+    Please see the README on GitHub at <https://github.com/tek/ribosome-hs> category: Neovim build-type: Simple @@ -20,53 +20,111 @@  library     exposed-modules:+        Ribosome.Api.Atomic+        Ribosome.Api.Autocmd         Ribosome.Api.Buffer         Ribosome.Api.Echo         Ribosome.Api.Exists         Ribosome.Api.Function+        Ribosome.Api.Input         Ribosome.Api.Option         Ribosome.Api.Path+        Ribosome.Api.Process         Ribosome.Api.Response         Ribosome.Api.Sleep+        Ribosome.Api.Syntax+        Ribosome.Api.Tabpage+        Ribosome.Api.Variable         Ribosome.Api.Window         Ribosome.Config.Setting         Ribosome.Config.Settings+        Ribosome.Control.Concurrent.Wait+        Ribosome.Control.Exception         Ribosome.Control.Lock+        Ribosome.Control.Monad.Error         Ribosome.Control.Monad.Ribo-        Ribosome.Control.Monad.RiboE-        Ribosome.Control.Monad.State-        Ribosome.Control.Monad.Trans.Ribo-        Ribosome.Control.Monad.Trans.Unlift-        Ribosome.Control.Ribo         Ribosome.Control.Ribosome+        Ribosome.Control.StrictRibosome+        Ribosome.Data.Conduit+        Ribosome.Data.Conduit.Composition         Ribosome.Data.ErrorReport         Ribosome.Data.Errors         Ribosome.Data.Foldable+        Ribosome.Data.Mapping         Ribosome.Data.Maybe+        Ribosome.Data.PersistError         Ribosome.Data.Scratch         Ribosome.Data.ScratchOptions-        Ribosome.Data.Time+        Ribosome.Data.Setting+        Ribosome.Data.SettingError+        Ribosome.Data.String+        Ribosome.Data.Syntax+        Ribosome.Data.Text         Ribosome.Error.Report+        Ribosome.Error.Report.Class         Ribosome.File         Ribosome.Internal.IO         Ribosome.Internal.NvimObject         Ribosome.Log-        Ribosome.Monad+        Ribosome.Mapping+        Ribosome.Menu.Data.Menu+        Ribosome.Menu.Data.MenuAction+        Ribosome.Menu.Data.MenuConfig+        Ribosome.Menu.Data.MenuConsumer+        Ribosome.Menu.Data.MenuConsumerAction+        Ribosome.Menu.Data.MenuConsumerUpdate+        Ribosome.Menu.Data.MenuEvent+        Ribosome.Menu.Data.MenuItem+        Ribosome.Menu.Data.MenuRenderEvent+        Ribosome.Menu.Data.MenuResult+        Ribosome.Menu.Data.MenuUpdate+        Ribosome.Menu.Nvim+        Ribosome.Menu.Prompt.Data.Codes+        Ribosome.Menu.Prompt.Data.CursorUpdate+        Ribosome.Menu.Prompt.Data.InputEvent+        Ribosome.Menu.Prompt.Data.Prompt+        Ribosome.Menu.Prompt.Data.PromptConfig+        Ribosome.Menu.Prompt.Data.PromptConsumed+        Ribosome.Menu.Prompt.Data.PromptConsumerUpdate+        Ribosome.Menu.Prompt.Data.PromptEvent+        Ribosome.Menu.Prompt.Data.PromptRenderer+        Ribosome.Menu.Prompt.Data.PromptState+        Ribosome.Menu.Prompt.Data.PromptUpdate+        Ribosome.Menu.Prompt.Data.TextUpdate+        Ribosome.Menu.Prompt.Nvim+        Ribosome.Menu.Prompt.Run+        Ribosome.Menu.Run+        Ribosome.Menu.Simple         Ribosome.Msgpack.Decode         Ribosome.Msgpack.Encode+        Ribosome.Msgpack.Error         Ribosome.Msgpack.NvimObject         Ribosome.Msgpack.Util+        Ribosome.Nvim.Api.Data+        Ribosome.Nvim.Api.Generate+        Ribosome.Nvim.Api.GenerateData+        Ribosome.Nvim.Api.GenerateIO+        Ribosome.Nvim.Api.IO+        Ribosome.Nvim.Api.RpcCall+        Ribosome.Orphans         Ribosome.Persist+        Ribosome.Plugin+        Ribosome.Plugin.Builtin+        Ribosome.Plugin.Mapping+        Ribosome.Plugin.RpcHandler+        Ribosome.Plugin.TH+        Ribosome.Plugin.TH.Command+        Ribosome.Plugin.TH.Handler+        Ribosome.Plugin.Watch+        Ribosome.Prelude+        Ribosome.PreludeExport         Ribosome.Scratch-        Ribosome.Test.Embed-        Ribosome.Test.Exists-        Ribosome.Test.File-        Ribosome.Test.Functional-        Ribosome.Test.Unit+        Ribosome.System.Time+        Ribosome.Tmux.Run         Ribosome.Unsafe     hs-source-dirs: lib     other-modules:-        Paths_ribosome+        Prelude     default-language: Haskell2010     default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals                         ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable@@ -77,150 +135,58 @@                         MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns                         OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds                         RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving-                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances-                        UnicodeSyntax ViewPatterns+                        TupleSections TypeApplications TypeFamilies TypeOperators+                        TypeSynonymInstances UnicodeSyntax ViewPatterns     build-depends:         MissingH >=1.4.1.0 && <1.5,         aeson >=1.3.1.1 && <1.4,         ansi-terminal >=0.8.2 && <0.9,-        base >=4.7 && <5,+        base-noprelude >=4.7 && <5,         bytestring >=0.10.8.2 && <0.11,+        cereal >=0.5.7.0 && <0.6,+        cereal-conduit >=0.8.0 && <0.9,+        chiasma >=0.1.0.0 && <0.2,+        composition >=1.0.2.1 && <1.1,+        composition-extra >=2.0.0 && <2.1,+        conduit >=1.3.1 && <1.4,+        conduit-extra >=1.3.0 && <1.4,         containers >=0.5.11.0 && <0.6,+        cornea >=0.2.2.0 && <0.3,         data-default >=0.7.1.1 && <0.8,         deepseq >=1.4.3.0 && <1.5,         directory >=1.3.1.5 && <1.4,         either >=5.0.1 && <5.1,+        exceptions >=0.10.0 && <0.11,         filepath >=1.4.2 && <1.5,+        free >=5.0.2 && <5.1,         hslogger >=1.2.12 && <1.3,         lens >=4.16.1 && <4.17,+        lifted-async >=0.10.0.3 && <0.11,+        lifted-base >=0.2.3.12 && <0.3,         messagepack >=0.5.4 && <0.6,+        monad-control >=1.0.2.3 && <1.1,+        monad-loops >=0.4.3 && <0.5,         mtl >=2.2.2 && <2.3,-        nvim-hs >=1.0.0.3 && <1.1,+        nvim-hs >=2.1.0.0 && <2.2,+        path >=0.6.1 && <0.7,+        path-io >=1.3.3 && <1.4,         pretty-terminal >=0.1.0.0 && <0.2,         prettyprinter >=1.2.1 && <1.3,         prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,         process >=1.6.3.0 && <1.7,+        relude >=0.1.1 && <0.2,         resourcet >=1.2.2 && <1.3,         safe >=0.3.17 && <0.4,         split >=0.2.3.3 && <0.3,         stm >=2.4.5.1 && <2.5,-        text >=1.2.3.1 && <1.3,-        time >=1.8.0.2 && <1.9,-        transformers >=0.5.5.0 && <0.6,-        typed-process >=0.2.3.0 && <0.3,-        unix >=2.7.2.2 && <2.8,-        unliftio >=0.2.9.0 && <0.3,-        unliftio-core >=0.1.2.0 && <0.2,-        utf8-string >=1.0.1.1 && <1.1--test-suite ribosome-functional-    type: exitcode-stdio-1.0-    main-is: SpecMain.hs-    hs-source-dirs: test/f-    other-modules:-        Paths_ribosome-    default-language: Haskell2010-    default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals-                        ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable-                        DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable-                        DoAndIfThenElse EmptyDataDecls ExistentialQuantification-                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs-                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase-                        MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns-                        OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds-                        RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving-                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances-                        UnicodeSyntax ViewPatterns-    ghc-options: -threaded -rtsopts -with-rtsopts=-N-    build-depends:-        HTF >=0.13.2.5 && <0.14,-        MissingH >=1.4.1.0 && <1.5,-        aeson >=1.3.1.1 && <1.4,-        ansi-terminal >=0.8.2 && <0.9,-        base >=4.7 && <5,-        bytestring >=0.10.8.2 && <0.11,-        containers >=0.5.11.0 && <0.6,-        data-default >=0.7.1.1 && <0.8,-        deepseq >=1.4.3.0 && <1.5,-        directory >=1.3.1.5 && <1.4,-        either >=5.0.1 && <5.1,-        filepath >=1.4.2 && <1.5,-        hslogger >=1.2.12 && <1.3,-        lens >=4.16.1 && <4.17,-        messagepack >=0.5.4 && <0.6,-        mtl >=2.2.2 && <2.3,-        nvim-hs >=1.0.0.3 && <1.1,-        pretty-terminal >=0.1.0.0 && <0.2,-        prettyprinter >=1.2.1 && <1.3,-        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,-        process >=1.6.3.0 && <1.7,-        resourcet >=1.2.2 && <1.3,-        ribosome -any,-        safe >=0.3.17 && <0.4,-        split >=0.2.3.3 && <0.3,-        stm >=2.4.5.1 && <2.5,-        text >=1.2.3.1 && <1.3,-        time >=1.8.0.2 && <1.9,-        transformers >=0.5.5.0 && <0.6,-        typed-process >=0.2.3.0 && <0.3,-        unix >=2.7.2.2 && <2.8,-        unliftio >=0.2.9.0 && <0.3,-        unliftio-core >=0.1.2.0 && <0.2,-        utf8-string >=1.0.1.1 && <1.1--test-suite ribosome-unit-    type: exitcode-stdio-1.0-    main-is: SpecMain.hs-    hs-source-dirs: test/u-    other-modules:-        MsgpackSpec-        RiboSpec-        RiboTransSpec-        ScratchSpec-        Paths_ribosome-    default-language: Haskell2010-    default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals-                        ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable-                        DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable-                        DoAndIfThenElse EmptyDataDecls ExistentialQuantification-                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs-                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase-                        MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns-                        OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds-                        RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving-                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances-                        UnicodeSyntax ViewPatterns-    ghc-options: -threaded -rtsopts -with-rtsopts=-N-    build-depends:-        HTF >=0.13.2.5 && <0.14,-        MissingH >=1.4.1.0 && <1.5,-        aeson >=1.3.1.1 && <1.4,-        ansi-terminal >=0.8.2 && <0.9,-        base >=4.7 && <5,-        bytestring >=0.10.8.2 && <0.11,-        containers >=0.5.11.0 && <0.6,-        data-default >=0.7.1.1 && <0.8,-        deepseq >=1.4.3.0 && <1.5,-        directory >=1.3.1.5 && <1.4,-        either >=5.0.1 && <5.1,-        filepath >=1.4.2 && <1.5,-        hslogger >=1.2.12 && <1.3,-        lens >=4.16.1 && <4.17,-        messagepack >=0.5.4 && <0.6,-        mtl >=2.2.2 && <2.3,-        nvim-hs >=1.0.0.3 && <1.1,-        pretty-terminal >=0.1.0.0 && <0.2,-        prettyprinter >=1.2.1 && <1.3,-        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,-        process >=1.6.3.0 && <1.7,-        resourcet >=1.2.2 && <1.3,-        ribosome -any,-        safe >=0.3.17 && <0.4,-        split >=0.2.3.3 && <0.3,-        stm >=2.4.5.1 && <2.5,+        stm-chans >=3.0.0.4 && <3.1,+        stm-conduit >=4.0.1 && <4.1,+        template-haskell >=2.13.0.0 && <2.14,         text >=1.2.3.1 && <1.3,+        th-abstraction >=0.2.10.0 && <0.3,         time >=1.8.0.2 && <1.9,         transformers >=0.5.5.0 && <0.6,+        transformers-base >=0.4.5.2 && <0.5,         typed-process >=0.2.3.0 && <0.3,         unix >=2.7.2.2 && <2.8,         unliftio >=0.2.9.0 && <0.3,
− test/f/SpecMain.hs 
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module Main where--import Test.Framework-import Test.Framework.BlackBoxTest ()--main :: IO ()-main = return ()--- main = htfMain htf_importedTests
− test/u/MsgpackSpec.hs 
@@ -1,98 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}--module MsgpackSpec(-  htf_thisModulesTests-) where--import Data.Either.Combinators (mapLeft)-import Data.Int (Int64)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map (fromList)-import Data.MessagePack (Object(..))-import Data.Text (Text)-import Data.Text.Prettyprint.Doc (Doc, layoutPretty, defaultLayoutOptions)-import Data.Text.Prettyprint.Doc.Render.Terminal (renderStrict, AnsiStyle)-import GHC.Generics (Generic)-import Test.Framework--import Ribosome.Msgpack.Decode (MsgpackDecode(..))-import Ribosome.Msgpack.Encode (MsgpackEncode(..))-import qualified Ribosome.Msgpack.Util as Util (string)--newtype NT =-  NT String-  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)--data Blob =-  Blob {-    key4 :: [[Int]],-    key5 :: Map Int String,-    key6 :: NT-  }-  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)--data Prod =-  Prod String Int-  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)--data Dat =-  Dat {-    key1 :: Blob,-    key2 :: Bool,-    key3 :: Maybe Prod-  }-  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)--dat :: Dat-dat = Dat (Blob [[1, 2], [3]] (Map.fromList [(1, "1"), (2, "2")]) (NT "nt")) False (Just $ Prod "dat" 27)--os :: String -> Object-os = Util.string--i :: Int64 -> Object-i = ObjectInt--encodedBlob :: Object-encodedBlob =-  ObjectMap $ Map.fromList [-    (os "key4", ObjectArray [ObjectArray [i 1, i 2], ObjectArray [i 3]]),-    (os "key5", ObjectMap $ Map.fromList [(i 1, os "1"), (i 2, os "2")]),-    (os "key6", os "nt")-    ]--encoded :: Object-encoded =-  ObjectMap $ Map.fromList [-    (os "key1", encodedBlob),-    (os "key2", ObjectBool False),-    (os "key3", ObjectArray [os "dat", i 27])-    ]--test_encode :: IO ()-test_encode =-  assertEqual encoded (toMsgpack dat)--doc2Text :: Either (Doc AnsiStyle) a -> Either Text a-doc2Text =-  mapLeft (renderStrict . layoutPretty defaultLayoutOptions)--test_decode :: IO ()-test_decode =-  assertEqual (Right dat) (doc2Text $ fromMsgpack encoded)--data Nope =-  Nope {-    present :: Int,-    absent :: Maybe Int-  }-  deriving (Eq, Show, Generic, MsgpackDecode)--encodedNope :: Object-encodedNope =-  ObjectMap $ Map.fromList [(os "present", i 5)]--test_maybeMissing :: IO ()-test_maybeMissing =-  assertEqual (Right (Nope 5 Nothing)) (doc2Text $ fromMsgpack encodedNope)
− test/u/RiboSpec.hs 
@@ -1,37 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module RiboSpec(-  htf_thisModulesTests,-) where--import Control.Monad.IO.Class (liftIO)-import Data.Bifunctor (Bifunctor(..))-import Data.Default (Default(def))-import Neovim-import Ribosome.Api.Buffer-import Ribosome.Control.Monad.Ribo-import Ribosome.Test.Unit (unitSpec)-import Test.Framework-import UnliftIO.STM--newtype Env =-  Env Int-  deriving (Eq, Show)--rib :: RiboT Env (Doc AnsiStyle) [String]-rib = do-  a <- nvim currentBufferContent-  nvim $ vim_command' "tabnew"-  return a--riboSpec :: Ribo (TVar Env) ()-riboSpec = do-  let target = ["line 1", "line 2"]-  _ <- setCurrentBufferContent target-  content <- unsafeToNeovim $ first (const ()) rib-  liftIO $ assertEqual target content--test_ribo :: IO ()-test_ribo = do-  t <- newTVarIO (Env 5)-  unitSpec def t riboSpec
− test/u/RiboTransSpec.hs 
@@ -1,38 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module RiboTransSpec(-  htf_thisModulesTests,-) where--import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Data.Default (Default(def))-import Neovim-import Test.Framework-import UnliftIO.STM--import Ribosome.Api.Buffer-import Ribosome.Control.Monad.Trans.Ribo-import Ribosome.Test.Unit (unitSpec)--newtype Env =-  Env Int-  deriving (Eq, Show)--rib :: RiboT (ReaderT Env) Env (Doc AnsiStyle) [String]-rib = do-  a <- nvim currentBufferContent-  nvim $ vim_command' "tabnew"-  return a--riboSpec :: Ribo Env ()-riboSpec = do-  let target = ["line 1", "line 2"]-  _ <- setCurrentBufferContent target-  content <- unsafeToNeovimWith (`runReaderT` Env 6) $ mapE (const ()) rib-  liftIO $ assertEqual target content--test_riboTrans :: IO ()-test_riboTrans = do-  t <- newTVarIO (Env 5)-  unitSpec def t riboSpec
− test/u/ScratchSpec.hs 
@@ -1,28 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module ScratchSpec(-  htf_thisModulesTests-) where--import Control.Monad.IO.Class (liftIO)-import Data.Default (def)-import Test.Framework--import Ribosome.Api.Buffer (currentBufferContent)-import Ribosome.Control.Ribo (Ribo)-import Ribosome.Data.ScratchOptions (ScratchOptions(ScratchOptions))-import Ribosome.Scratch (showInScratch)-import Ribosome.Test.Unit (unitSpec)--target :: [String]-target = ["line 1", "line 2"]--scratchSpec :: Ribo e ()-scratchSpec = do-  _ <- showInScratch target (ScratchOptions False True (Just 0) False "buffi")-  content <- currentBufferContent-  liftIO $ assertEqual target content--test_scratch :: IO ()-test_scratch =-  unitSpec def () scratchSpec
− test/u/SpecMain.hs 
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module Main where--import {-@ HTF_TESTS @-} ScratchSpec-import {-@ HTF_TESTS @-} MsgpackSpec-import {-@ HTF_TESTS @-} RiboSpec-import Test.Framework-import Test.Framework.BlackBoxTest ()--main :: IO ()-main = htfMain htf_importedTests