packages feed

ribosome 0.3.0.1 → 0.9.9.9

raw patch · 174 files changed

Files

LICENSE view
@@ -1,55 +1,34 @@-# Blue Oak Model License--Version 1.0.0--## Purpose--This license gives everyone as much permission to work with-this software as possible, while protecting contributors-from liability.--## 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+Copyright (c) 2022 Torsten Schmits -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.+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met: -## Patent+  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution. -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.+Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by: -## Reliability+  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution. -No contributor can revoke this license.+Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise. -## No Liability+DISCLAIMER -***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.***+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− lib/Prelude.hs 
@@ -1,5 +0,0 @@-module Prelude (-  module Ribosome.Prelude-) where--import Ribosome.Prelude
+ lib/Ribosome.hs view
@@ -0,0 +1,586 @@+-- Description: The high-level API to Ribosome+module Ribosome (+  -- * Introduction+  -- $intro++  -- * Creating a project+  -- $project++  -- * Handlers+  -- $handlers++  -- ** Handler definition+  RpcHandler (..),+  Handler,+  RpcName (..),++  -- ** Constructing handlers+  rpcFunction,+  rpcCommand,+  rpcAutocmd,+  rpc,+  Execution (..),++  -- * Remote plugin execution #execution#+  -- $execution+  runNvimPluginIO,+  runNvimPluginIO_,+  runNvimPluginCli,+  withHandlers,+  remotePlugin,+  RemoteStack,+  runRemoteStack,+  runRemoteStackCli,+  interpretPluginRemote,+  BasicPluginStack,+  runBasicPluginStack,+  runCli,+  NvimPlugin,++  -- * Interacting with Neovim+  -- $api+  Rpc,+  Request (Request),+  RpcCall,+  sync,+  async,+  notify,+  channelId,+  Buffer,+  Window,+  Tabpage,+  Event (Event),+  EventName (EventName),++  -- * Watching variables+  -- $watched-variables+  watchVariables,+  WatchedVariable (..),++  -- * Embedded Neovim execution+  -- $embed+  runEmbedPluginIO,+  runEmbedPluginIO_,+  runEmbedPluginCli,+  embedPlugin,+  runEmbedStack,+  runEmbedStackCli,+  interpretPluginEmbed,++  -- * MessagePack codec+  -- $msgpack+  MsgpackDecode (fromMsgpack),+  MsgpackEncode (toMsgpack),+  pattern Msgpack,+  msgpackArray,+  msgpackMap,++  -- * Utility effects+  -- $util++  -- ** Settings+  Settings,+  Setting (Setting),+  SettingError,+  interpretSettingsRpc,++  -- ** Scratch buffers+  -- $scratch+  Scratch,+  ScratchOptions,+  scratch,+  FloatOptions,+  ScratchId (ScratchId),+  ScratchState (ScratchState),++  -- ** Mappings #mappings#+  -- $mappings+  Mapping (Mapping),+  MappingAction (..),+  MappingId (MappingId),+  MappingLhs (MappingLhs),+  MapMode (..),+  MappingSpec (MappingSpec),+  mappingFor,+  eventMapping,+  activateBufferMapping,+  activateMapping,++  -- ** Persisting data across vim sessions+  Persist,+  interpretPersist,+  interpretPersistNull,+  PersistPath,+  persistPath,+  interpretPersistPath,+  interpretPersistPathSetting,+  interpretPersistPathAt,+  PersistError,+  PersistPathError,+  -- ** The plugin's name+  PluginName (PluginName),+  interpretPluginName,++  -- * More functionality for handlers++  -- ** Command completion+  completeWith,+  completeBuiltin,+  CompleteStyle (..),++  -- ** Special command parameter types #command-params#+  HandlerArg (handlerArg),+  CommandHandler (commandOptions),+  Args (..),+  ArgList (..),+  JsonArgs (..),+  Options (..),+  OptionParser (..),+  Bang (..),+  Bar (..),+  Range (Range),+  RangeStyle (..),+  CommandMods (..),+  CommandRegister (..),+  HandlerCodec (handlerCodec),++  -- * Command Modifiers+  modifyCmd,+  bufdo,+  windo,+  noautocmd,+  silent,+  silentBang,++  -- * Configuring the host+  HostConfig (..),+  LogConfig (..),+  setStderr,+  PluginConfig (PluginConfig),+  pluginNamed,++  -- * Reports+  -- $errors+  resumeReport,+  mapReport,+  resumeReports,+  mapReports,+  LogReport (LogReport),+  Report (Report),+  Reportable (toReport),+  ReportContext (..),+  reportContext,+  prefixReportContext,+  reportContext',+  prefixReportContext',+  basicReport,+  userReport,+  reportMessages,+  resumeHoistUserMessage,+  mapUserMessage,+  logReport,+  pluginLogReports,+  RpcError,+  rpcError,+  ignoreRpcError,+  onRpcError,+  BootError (..),+  StoredReport (..),+  Reports,+  storedReports,+  reportStop,+  resumeLogReport,+  UserError,+  interpretUserErrorPrefixed,++  -- * Mutex State+  MState,+  ScopedMState,+  mmodify,+  mread,+  mreads,+  mstate,+  mtrans,+  muse,+  stateToMState,+  withMState,+  evalMState,+  interpretMState,+  interpretMStates,++  -- * Misc+  simpleHandler,+  noHandlers,+  interpretHandlers,+  Register,+  RegisterType,+  registerRepr,+  pathText,+  CustomConfig (CustomConfig),++  -- * Reexports+  module Prelate.Prelude,+) where++import Prelate.Prelude (Stop, type (!!), (<!))+import Prelude hiding (async)++import Ribosome.Data.CustomConfig (CustomConfig (CustomConfig))+import Ribosome.Data.FloatOptions (FloatOptions)+import Ribosome.Data.Mapping (+  MapMode (..),+  Mapping (Mapping),+  MappingAction (..),+  MappingId (MappingId),+  MappingLhs (MappingLhs),+  MappingSpec (MappingSpec),+  )+import Ribosome.Data.PersistError (PersistError)+import Ribosome.Data.PersistPathError (PersistPathError)+import Ribosome.Data.PluginConfig (PluginConfig (PluginConfig), pluginNamed)+import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Data.Register (Register, registerRepr)+import Ribosome.Data.RegisterType (RegisterType)+import Ribosome.Data.ScratchId (ScratchId (ScratchId))+import Ribosome.Data.ScratchOptions (ScratchOptions, scratch)+import Ribosome.Data.ScratchState (ScratchState (ScratchState))+import Ribosome.Data.Setting (Setting (Setting))+import Ribosome.Data.SettingError (SettingError)+import Ribosome.Effect.Persist (Persist)+import Ribosome.Effect.PersistPath (PersistPath, persistPath)+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Effect.Settings (Settings)+import Ribosome.Effect.VariableWatcher (WatchedVariable (..))+import Ribosome.Embed (+  embedPlugin,+  interpretPluginEmbed,+  runEmbedPluginCli,+  runEmbedPluginIO,+  runEmbedPluginIO_,+  runEmbedStack,+  runEmbedStackCli,+  )+import Ribosome.Host.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Class.Msgpack.Map (msgpackMap)+import Ribosome.Host.Data.Args (ArgList (..), Args (..), JsonArgs (..), OptionParser (..), Options (..))+import Ribosome.Host.Data.Bang (Bang (..))+import Ribosome.Host.Data.Bar (Bar (Bar))+import Ribosome.Host.Data.BootError (BootError (..))+import Ribosome.Host.Data.CommandMods (CommandMods (CommandMods))+import Ribosome.Host.Data.CommandRegister (CommandRegister (CommandRegister))+import Ribosome.Host.Data.Event (Event (Event), EventName (EventName))+import Ribosome.Host.Data.Execution (Execution (..))+import Ribosome.Host.Data.HostConfig (HostConfig (..), LogConfig (..), setStderr)+import Ribosome.Host.Data.Range (Range (Range), RangeStyle (..))+import Ribosome.Host.Data.Report (+  LogReport (LogReport),+  Report (Report),+  ReportContext (..),+  Reportable (toReport),+  basicReport,+  mapReport,+  mapReports,+  mapUserMessage,+  prefixReportContext,+  prefixReportContext',+  reportContext,+  reportContext',+  reportMessages,+  resumeHoistUserMessage,+  resumeReport,+  resumeReports,+  toReport,+  userReport,+  )+import Ribosome.Host.Data.Request (Request (Request))+import Ribosome.Host.Data.RpcCall (RpcCall)+import Ribosome.Host.Data.RpcError (RpcError, rpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler (..), simpleHandler)+import Ribosome.Host.Data.RpcName (RpcName (..))+import Ribosome.Host.Data.RpcType (CompleteStyle (..))+import Ribosome.Host.Data.StoredReport (StoredReport (StoredReport))+import Ribosome.Host.Effect.MState (+  MState,+  ScopedMState,+  mmodify,+  mread,+  mreads,+  mstate,+  mtrans,+  muse,+  stateToMState,+  withMState,+  )+import Ribosome.Host.Effect.Reports (Reports, storedReports)+import Ribosome.Host.Effect.Rpc (Rpc, async, channelId, notify, sync)+import Ribosome.Host.Effect.UserError (UserError)+import Ribosome.Host.Error (ignoreRpcError, onRpcError)+import Ribosome.Host.Handler (+  completeBuiltin,+  completeWith,+  rpc,+  rpcAutocmd,+  rpcCommand,+  rpcFunction,+  )+import Ribosome.Host.Handler.Codec (HandlerArg (handlerArg), HandlerCodec (handlerCodec))+import Ribosome.Host.Handler.Command (CommandHandler (commandOptions))+import Ribosome.Host.Interpreter.Handlers (interpretHandlers, noHandlers, withHandlers)+import Ribosome.Host.Interpreter.MState (evalMState, interpretMState, interpretMStates)+import Ribosome.Host.Modify (bufdo, modifyCmd, noautocmd, silent, silentBang, windo)+import Ribosome.Host.Path (pathText)+import Ribosome.IOStack (BasicPluginStack, runBasicPluginStack, runCli)+import Ribosome.Interpreter.Persist (interpretPersist, interpretPersistNull)+import Ribosome.Interpreter.PersistPath (interpretPersistPath, interpretPersistPathAt, interpretPersistPathSetting)+import Ribosome.Interpreter.PluginName (interpretPluginName)+import Ribosome.Interpreter.Settings (interpretSettingsRpc)+import Ribosome.Interpreter.UserError (interpretUserErrorPrefixed)+import Ribosome.Interpreter.VariableWatcher (watchVariables)+import Ribosome.Mapping (activateBufferMapping, activateMapping, eventMapping, mappingFor)+import Ribosome.Remote (+  RemoteStack,+  interpretPluginRemote,+  remotePlugin,+  runNvimPluginCli,+  runNvimPluginIO,+  runNvimPluginIO_,+  runRemoteStack,+  runRemoteStackCli,+  )+import Ribosome.Report (logReport, pluginLogReports, reportStop, resumeLogReport)+import Ribosome.Run (NvimPlugin)++-- $intro+-- This library is a framework for building [Neovim](https://neovim.io) plugins with+-- [Polysemy](https://hackage.haskell.org/package/polysemy).+--+-- A plugin consists of a set of request handlers that can be executed by Neovim functions, commands, autocmds, or+-- events, and may communicate with Neovim by calling its RPC API.+--+-- Here is an example for a simple plugin with a single request handler.+--+-- > import Ribosome+-- > import Ribosome.Api+-- >+-- > count ::+-- >   Members NvimPlugin r =>+-- >   Int ->+-- >   Handler r Int+-- > count n = do+-- >   s <- 0 <! nvimGetVar "sum"+-- >   let s' = s + n+-- >   ignoreRpcError (nvimSetVar "sum" s')+-- >   pure s'+-- >+-- > main :: IO ()+-- > main =+-- >   runNvimPluginIO_ "counter" [rpcFunction "Count" Sync count]+--+-- This module can be used as a Neovim plugin by running it with @jobstart@ from Neovim:+--+-- > :call jobstart(['/path/to/plugin.exe'], { 'rpc': 1 })+--+-- The handler will add up all numbers that are passed to the Neovim function @Count@ and store the sum in the variable+-- @g:sum@:+--+-- > :echo Count(5)+-- > 5+-- > :echo Count(13)+-- > 18+-- > :echo g:sum+-- > 18++-- $project+-- The most reliable way to set up a repository for a plugin is to use Nix, for which Ribosome provides an app that+-- generates a ready-to-use plugin project that includes Neovim glue that fetches static binaries from Github, as well+-- as config files for Github Actions that release those binaries for every commit and tag:+--+-- > $ nix run 'github:tek/ribosome#new' my-plugin+--+-- The created plugin can be added to Neovim like any other.+-- For example, linking its directory to @~\/.local\/share\/nvim\/site\/pack\/foo\/opt\/my-plugin@ will allow you to+-- run:+--+-- > :packadd my-plugin+--+-- Using @start@ instead of @opt@ in the pack path will run the plugin at startup.+--+-- Or simply use one of the many plugin managers.+--+-- On the first start, the plugin will either be built with Nix, if it is available, or a static binary will be fetched+-- from Github.+-- Once that is done, the template project's dummy handler can be executed:+--+-- > :echo MyPluginPing()+-- > 0+-- > :echo MyPluginPing()+-- > 1+--+-- The second time the plugin ist started, the executable will be run directly, without checking for updates, unless the+-- result has been garbage collected by Nix (i.e. the @result@ link in the repo is broken).+-- In order to force a rebuild after pulling, run the command:+--+-- > $ nix build++-- $handlers+-- A list of 'RpcHandler's can be created by passing a handler function to one the smart constructors:+--+-- > echoHello :: Member (Rpc !! RpcError) => Sem r ()+-- > echoHello = ignoreRpcError (echo "Hello")+-- >+-- > handlers = [+-- >   rpcFunction "Hello" Async echoHello,+-- >   rpcCommand "Hello" Async echoHello,+-- >   rpcAutocmd "HelloHaskellFile" Async "BufEnter" "*.hs" echoHello+-- > ]+--+-- Passing these handlers to 'runNvimPluginIO_' starts a plugin that calls @echoHello@ when running @:call Hello()@,+-- @:Hello@, or when entering a Haskell buffer.+--+-- When the plugin's main loop starts, 'withHandlers' registers the triggers in Neovim by running vim code like this:+--+-- > function! Hello(...) range+-- >   return call('rpcnotify', [1, 'function:Hello'] + a:000)+-- > endfunction+-- > command! -nargs=0 Hello call call('rpcnotify', [1, 'command:Hello'])+-- > autocmd BufEnter *.hs call call('rpcnotify', [1, 'autocmd:HelloHaskellFile'])++-- $execution+-- There are many ways of running a plugin for different purposes, like as a remote plugin from Neovim (the usual+-- production mode), directly in a test using an embedded Neovim process, or over a socket when testing a plugin in+-- tmux.++-- $watched-variables+-- /Watched variable handlers/ are called whenever a certain Neovim variable's value has changed:+--+-- > changed ::+-- >   Members NvimPlugin r =>+-- >   Object ->+-- >   Handler r ()+-- > changed value =+-- >   ignoreRpcError (echo ("Update value to: " <> show value))+-- >+-- > main :: IO ()+-- > main = runRemoteStack "watch-plugin" (watchVariables [("trigger", changed)] remotePlugin)+--+-- This registers the variable named @trigger@ to be watched for changes.+-- When a change is detected, the handler @changed@ whill be executed with the new value as its argument.+--+-- /Note/ that the combinators in the main function are simply what's run by 'runNvimPluginIO', with 'watchVariables'+-- being used as the custom effect stack and an empty list of handlers.++-- $api+--+-- - The effect 'Rpc' governs access to Neovim's remote API.+--+-- - The module [Ribosome.Api.Data]("Ribosome.Api.Data") contains declarative representations of all API calls that are+-- listed at @:help api@.+--+-- - The module [Ribosome.Api.Effect]("Ribosome.Api.Effect"), reexported from [Ribosome.Api]("Ribosome.Api"), contains+-- the same set of API functions, but as callable 'Sem' functions that use the data declarations with 'sync'.+-- [Ribosome.Api]("Ribosome.Api") additionally contains many composite functions using the Neovim API.+--+-- The API also defines the data types 'Buffer', 'Window' and 'Tabpage', which are abstract types carrying an internal+-- identifier generated by Neovim.++-- $embed+-- While [remote plugins]("Ribosome#execution") are executed from within Neovim, Ribosome can also run Neovim from a+-- Haskell process and attach to the subprocess' stdio.+--+-- The primary purpose of embedding Neovim is testing a plugin, but it could also be used to build a GUI application+-- around Neovim.+--+-- The library [Ribosome.Test](https://hackage.haskell.org/package/ribosome-test/docs/Ribosome-Test.html) provides more+-- comprehensive functionality for the testing use case.+--+-- When embedding Neovim, the main loop is forked and the test is run synchronously:+--+-- > import qualified Data.Text.IO as Text+-- > import Ribosome+-- > import Ribosome.Api+-- >+-- > ping :: Handler r Text+-- > ping = pure "Ping"+-- >+-- > main :: IO ()+-- > main =+-- >   runEmbedPluginIO_ "ping-plugin" [rpcFunction "Ping" Sync ping] do+-- >     ignoreRpcError do+-- >       embed . Text.putStrLn =<< nvimCallFunction "Ping" []++-- $msgpack+-- Neovim's RPC communication uses the MessagePack protocol.+-- All API functions convert their arguments and return values using the classes 'MsgpackEncode' and 'MsgpackDecode'.+-- There are several Haskell libraries for this purpose.+-- Ribosome uses [messagepack](https://hackage.haskell.org/package/messagepack), simply for the reason that it allows+-- easy incremental parsing via [cereal](https://hackage.haskell.org/package/cereal).+--+-- All API functions that are declared as taking or returning an 'Data.MessagePack.Object' by Neovim are kept+-- polymorphic, allowing the user to interface with them using arbitrary types.+-- Codec classes for record types can be derived generically:+--+-- > data Cat =+-- >   Cat { name :: Text, age :: Int }+-- >   deriving stock (Generic)+-- >   deriving anyclass (MsgpackEncode, MsgpackDecode)+-- >+-- > nvimSetVar "cat" (Cat "Dr. Boots" 4)++-- $util+-- TODO++-- $scratch+-- A scratch buffer is what Neovim calls text not associated with a file, used for informational or interactive content.+-- Ribosome provides an interface for maintaining those, by associating a view configuration with an ID and allowing to+-- update the text displayed in it.+-- Its full API is exposed by [Ribosome.Scratch]("Ribosome.Scratch").++-- $mappings+-- The function 'activateBufferMapping' can be used to dynamically create buffer-local Neovim key mappings that trigger+-- handlers of a Ribosome plugin.+--+-- A slightly reliable way of constructing a 'Mapping' is to use 'mappingFor', which takes an 'RpcHandler' to ensure+-- that the name it calls was at least associated with a handler at some point.+--+-- One use case for mappings is in a 'Scratch' buffer, which automatically registers a set of them after initializing+-- the buffer.++-- $errors+-- Ribosome uses+-- [polysemy-resume](https://hackage.haskell.org/package/polysemy-resume/docs/Polysemy-Resume.html)+-- extensively, which is a concept for tracking errors across interpreters by attaching them to a wrapper effect.+--+-- In short, when an interpreter is written for the effect @'Rpc' !! 'RpcError'@ (which is a symbolic alias for+-- @'Resumable' 'RpcError' 'Rpc'@), every use of the bare effect 'Rpc' must be converted at some point, with the+-- possiblity of exposing the error on another interpreter that uses the effect.+--+-- Take the effect 'Scratch' for example, whose interpreter is for the effect @'Scratch' !! 'RpcError'@.+-- In there is the expression:+--+-- > restop @RpcError @Rpc (setScratchContent s text)+--+-- The function @setScratchContent@ has a dependency on the bare effect 'Rpc'.+-- The function 'restop' converts this dependency into @'Rpc' !! 'RpcError'@ /and/ @'Stop' 'RpcError'@, meaning that+-- this expression acknowledges that 'Rpc' might fail with 'RpcError', and rethrows the error, which is then turned into+-- @'Scratch' !! 'RpcError'@ by the special interpreter combinator 'interpretResumable'.+--+-- Instead of rethrowing, the error can also be caught, by using a combinator like 'resume' or the operator '<!' that is+-- similar to '<$'.+--+-- The concept is similar to 'Error', with the difference that a 'Resumable' interpreter can communicate that it throws+-- this type of error, while with plain 'Error', this would have to be tracked manually by the developer.+--+-- Since handler functions yield the control flow to Ribosome's internal machinery when returning, all 'Stop' effects+-- have to be converted to 'Report' (which is expected by the request dispatcher and part of the 'Handler' stack),+-- and all bare effects like 'Rpc' have to be resumed or restopped since their interpreters only operate on the+-- 'Resumable' variants.+--+-- To make this chore a little less verbose, the class 'Reportable' can be leveraged to convert errors to+-- 'Report', which consists of an 'Report' and 'ReportContext', which optionally identifies the plugin+-- component that threw the error.+--+-- Since 'RpcError' is an instance of 'Reportable', the combinators 'resumeReport' and 'mapReport' can be used to+-- reinterpret to @'Stop' 'Report'@.
+ lib/Ribosome/Api.hs view
@@ -0,0 +1,40 @@+-- |All exports for the composite and atomic Neovim API functions.+module Ribosome.Api (+  module Ribosome.Api.Autocmd,+  module Ribosome.Api.Buffer,+  FileBuffer (FileBuffer),+  module Ribosome.Api.Echo,+  module Ribosome.Api.Function,+  module Ribosome.Api.Mode,+  module Ribosome.Api.Normal,+  module Ribosome.Api.Option,+  module Ribosome.Api.Path,+  module Ribosome.Api.Position,+  module Ribosome.Api.Process,+  module Ribosome.Api.Register,+  module Ribosome.Api.Sleep,+  module Ribosome.Api.Syntax,+  module Ribosome.Api.Tabpage,+  module Ribosome.Api.Undo,+  module Ribosome.Api.Window,+  module Ribosome.Host.Api.Effect,+) where++import Ribosome.Api.Autocmd+import Ribosome.Api.Buffer+import Ribosome.Api.Echo+import Ribosome.Api.Function+import Ribosome.Api.Mode+import Ribosome.Api.Normal+import Ribosome.Api.Option+import Ribosome.Api.Path+import Ribosome.Api.Position+import Ribosome.Api.Process+import Ribosome.Api.Register+import Ribosome.Api.Sleep+import Ribosome.Api.Syntax+import Ribosome.Api.Tabpage+import Ribosome.Api.Undo+import Ribosome.Api.Window+import Ribosome.Data.FileBuffer (FileBuffer (FileBuffer))+import Ribosome.Host.Api.Effect
− lib/Ribosome/Api/Atomic.hs 
@@ -1,60 +0,0 @@-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
@@ -1,11 +1,71 @@-module Ribosome.Api.Autocmd where+-- |Autocmd functions.+module Ribosome.Api.Autocmd (+  module Ribosome.Api.Autocmd,+  autocmd,+) where -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.IO (vimCommand)+import Data.MessagePack (Object) +import Ribosome.Host.Api.Autocmd (autocmd)+import Ribosome.Host.Api.Data (Buffer)+import Ribosome.Host.Api.Effect (bufferGetNumber, nvimExecAutocmds, vimGetOption, vimSetOption)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.RpcType (AutocmdBuffer (AutocmdBuffer), AutocmdEvents, AutocmdId, AutocmdOptions, target)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Trigger a set of autocmds.+--+-- Same as 'nvimExecAutocmds', but specializing the parameter type.+doautocmdWith ::+  Member Rpc r =>+  AutocmdEvents ->+  Map Text Object ->+  Sem r ()+doautocmdWith =+  nvimExecAutocmds++-- |Trigger a set of autocmds. doautocmd ::-  NvimE e m =>+  Member Rpc r =>+  AutocmdEvents ->+  Sem r ()+doautocmd events =+  nvimExecAutocmds events mempty++-- |Trigger a user autocmd.+uautocmd ::+  Member Rpc r =>   Text ->-  m ()-doautocmd name =-  vimCommand $ "doautocmd " <> name+  Sem r ()+uautocmd name =+  doautocmdWith "User" [("pattern", toMsgpack name)]++-- |Execute an action with all autocmds disabled.+eventignore ::+  Members [Rpc, Resource] r =>+  Sem r a ->+  Sem r a+eventignore =+  bracket getAndSet restore . const+  where+    getAndSet = do+      previous :: Text <- vimGetOption "eventignore"+      vimSetOption "eventignore" ("all" :: Text)+      pure previous+    restore =+      vimSetOption "eventignore"++-- |Create an autocmd in a buffer.+bufferAutocmd ::+  Member Rpc r =>+  Buffer ->+  AutocmdEvents ->+  AutocmdOptions ->+  -- |Command to execute when the autocmd triggers.+  Text ->+  Sem r AutocmdId+bufferAutocmd buf events options cmd = do+  number <- bufferGetNumber buf+  Rpc.sync do+    autocmd events options { target = Left (AutocmdBuffer number) } cmd
lib/Ribosome/Api/Buffer.hs view
@@ -1,104 +1,245 @@+-- |API functions for buffers. module Ribosome.Api.Buffer where -import Control.Monad (when)-import Data.Bifunctor (second)-import Data.MessagePack (Object)-import System.FilePath ((</>))+import qualified Data.Text as Text (null)+import Exon (exon)+import Path (Abs, Dir, File, Path, parseAbsFile, parseRelFile, (</>)) -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 (+import Ribosome.Data.FileBuffer (FileBuffer (FileBuffer))+import qualified Ribosome.Host.Api.Data as Data+import Ribosome.Host.Api.Data (Buffer)+import Ribosome.Host.Api.Effect (   bufferGetLines,+  bufferGetName,   bufferGetNumber,+  bufferGetOption,   bufferIsValid,   bufferSetLines,-  vimCallFunction,-  vimCommand,+  nvimBufDelete,+  nvimCallFunction,+  nvimCommand,+  nvimGetCurrentBuf,+  nvimWinSetBuf,   vimGetBuffers,   vimGetCurrentBuffer,+  vimGetCurrentWindow,   )-import Ribosome.Nvim.Api.RpcCall (syncRpcCall)--edit :: NvimE e m => FilePath -> m ()-edit path = vimCommand $ "silent! edit " <> toText path+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.RpcError (RpcError)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Modify (silentBang)+import Ribosome.Host.Path (pathText) -nvimCallBool :: NvimE e m => Text -> [Object] -> m Bool-nvimCallBool =-  vimCallFunction+-- |Load a 'Path' into a buffer in the current window using @:edit@.+edit ::+  Member Rpc r =>+  Path b t ->+  Sem r ()+edit path =+  silentBang do+    nvimCommand [exon|edit #{pathText path}|] -buflisted :: NvimE e m => Buffer -> m Bool+-- |Call the Neovim function @buflisted@ for a buffer, indicating whether it is shown in the buffer list (@:ls@).+buflisted ::+  Member (Rpc !! RpcError) r =>+  Buffer ->+  Sem r Bool buflisted buf = do-  num <- bufferGetNumber buf-  nvimCallBool "buflisted" [toMsgpack num]+  resumeAs False do+    num <- bufferGetNumber buf+    nvimCallFunction "buflisted" [toMsgpack num] -bufferContent :: NvimE e m => Buffer -> m [Text]+-- |Return the entire content of the given buffer.+bufferContent ::+  Member Rpc r =>+  Buffer ->+  Sem r [Text] bufferContent buffer =   bufferGetLines buffer 0 (-1) False -currentBufferContent :: NvimE e m => m [Text]+-- |Return the entire content of the current buffer.+currentBufferContent ::+  Member Rpc r =>+  Sem r [Text] currentBufferContent =   bufferContent =<< vimGetCurrentBuffer -setBufferContent :: NvimE e m => Buffer -> [Text] -> m ()+-- |Replace the content of the given buffer.+setBufferContent ::+  Member Rpc r =>+  Buffer ->+  [Text] ->+  Sem r () setBufferContent buffer =   bufferSetLines buffer 0 (-1) False +-- |Replace the content of the current buffer. setCurrentBufferContent ::-  NvimE e m =>+  Member Rpc r =>   [Text] ->-  m ()+  Sem r () setCurrentBufferContent content = do   buffer <- vimGetCurrentBuffer   setBufferContent buffer content +-- |Replace a single line in the given buffer.+setBufferLine ::+  Member Rpc r =>+  Buffer ->+  Int ->+  Text ->+  Sem r ()+setBufferLine buffer line text =+  bufferSetLines buffer line (line + 1) False [text]++-- |Execute an action only if the given buffer is valid, i.e. it exists but may be unloaded.+whenValid ::+  Member Rpc r =>+  (Buffer -> Sem r ()) ->+  Buffer ->+  Sem r ()+whenValid use buffer =+  whenM (bufferIsValid buffer) (use buffer)++-- |Execute an action with the given buffer's number if it is valid.+withBufferNumber ::+  Member Rpc r =>+  (Int -> Sem r ()) ->+  Buffer ->+  Sem r ()+withBufferNumber run =+ whenValid (run <=< bufferGetNumber)++-- |Force-delete a buffer, discarding changes. closeBuffer ::-  NvimE e m =>+  Member Rpc r =>   Buffer ->-  m ()-closeBuffer buffer = do-  valid <- bufferIsValid buffer-  when valid $ do-    number <- bufferGetNumber buffer-    vimCommand ("silent! bdelete! " <> show number)+  Sem r ()+closeBuffer =+  silentBang . withBufferNumber del+  where+    del number =+      nvimCommand [exon|bdelete! #{show number}|] +-- |Force-wipe a buffer, discarding changes. wipeBuffer ::-  NvimE e m =>+  Member Rpc r =>   Buffer ->-  m ()-wipeBuffer buffer = do-  valid <- bufferIsValid buffer-  when valid $ do-    number <- bufferGetNumber buffer-    vimCommand ("silent! bwipeout! " <> show number)+  Sem r ()+wipeBuffer =+  whenValid \ b -> nvimBufDelete b [("force", toMsgpack True)] -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)+-- |Force-unload a buffer, discarding changes.+unloadBuffer ::+  Member Rpc r =>+  Buffer ->+  Sem r ()+unloadBuffer =+  whenValid \ b -> nvimBufDelete b [("force", toMsgpack True), ("unload", toMsgpack True)] -bufferForFile ::-  MonadIO m =>-  MonadDeepError e DecodeError m =>-  NvimE e m =>+-- |Add a buffer to the list without loading it.+addBuffer ::+  Member Rpc r =>   Text ->-  m (Maybe Buffer)-bufferForFile target = do+  Sem r ()+addBuffer path =+  nvimCommand [exon|badd #{path}|]++-- |Construct a file buffer from a path if it is parseable.+fileBuffer ::+  Path Abs Dir ->+  Buffer ->+  Text ->+  Maybe FileBuffer+fileBuffer cwd buffer (toString -> path) =+  FileBuffer buffer <$> (parseAbsFile path <|> (cwd </>) <$> parseRelFile path)++-- |Get all buffers in the buffer list whose name is a path.+fileBuffers ::+  Member Rpc r =>+  Sem r [FileBuffer]+fileBuffers = do   cwd <- nvimCwd-  fmap fst . find sameBuffer . fmap (second (toText . absolute cwd . toString)) <$> buffersAndNames+  buffers <- vimGetBuffers+  names <- Rpc.sync (foldMap (fmap pure . Data.bufferGetName) buffers)+  pure (catMaybes (zipWith (fileBuffer cwd) buffers names))++-- |Find the buffer whose name is the given path.+bufferForFile ::+  Member Rpc r =>+  Path Abs File ->+  Sem r (Maybe FileBuffer)+bufferForFile target =+  find sameBuffer <$> fileBuffers   where-    sameBuffer (_, name) = name == target-    absolute dir ('.' : '/' : rest) =-      dir </> rest-    absolute _ p@('/' : _) =-      p-    absolute dir path =-      dir </> path+    sameBuffer (FileBuffer _ path) =+      path == target++-- |Return the name of the current buffer.+currentBufferName ::+  Member Rpc r =>+  Sem r Text+currentBufferName =+  bufferGetName =<< vimGetCurrentBuffer++-- |Set the current buffer.+setCurrentBuffer ::+  Member Rpc r =>+  Buffer ->+  Sem r ()+setCurrentBuffer buf = do+  win <- vimGetCurrentWindow+  nvimWinSetBuf win buf++-- |Indicate whether the given buffer is a file, i.e. has empty @buftype@.+bufferIsFile ::+  Member Rpc r =>+  Buffer ->+  Sem r Bool+bufferIsFile buf =+  Text.null <$> bufferGetOption buf "buftype"++-- |Return the number of buffers in the list.+bufferCount ::+  Member Rpc r =>+  Sem r Natural+bufferCount =+  fromIntegral . length <$> vimGetBuffers++-- |Return the file system path of the given buffer, if its name is a valid path.+bufferPath ::+  Member Rpc r =>+  Buffer ->+  Sem r (Maybe (Path Abs File))+bufferPath buffer = do+  Rpc.sync do+    cwd <- Data.vimCallFunction "getcwd" []+    name <- Data.bufferGetName buffer+    pure (fileBuffer cwd buffer name <&> \ (FileBuffer _ path) -> path)++-- |Return the file system path of the current buffer, if its name is a valid path.+currentBufferPath ::+  Member Rpc r =>+  Sem r (Maybe (Path Abs File))+currentBufferPath =+  bufferPath =<< nvimGetCurrentBuf++-- |Filter out the unlisted buffers from the given list.+filterListed ::+  Member Rpc r =>+  [Buffer] ->+  Sem r [Buffer]+filterListed bufs = do+  nums <- Rpc.sync (traverse Data.bufferGetNumber bufs)+  listedFlags <- Rpc.sync (traverse (Data.nvimCallFunction "buflisted" . pure . toMsgpack) nums)+  let listed = mapMaybe chooseListed (zip bufs listedFlags)+  buftypes :: [Text] <- Rpc.sync (traverse (\ buf -> Data.bufferGetOption buf "buftype") listed)+  pure (mapMaybe chooseEmptyTypes (zip bufs buftypes))+  where+    chooseListed (b, l) =+      if l then Just b else Nothing+    chooseEmptyTypes = \case+      (b, "") -> Just b+      (_, _) -> Nothing
+ lib/Ribosome/Api/Data.hs view
@@ -0,0 +1,6 @@+-- |Reexport of the declarative Neovim API+module Ribosome.Api.Data (+  module Ribosome.Host.Api.Data+) where++import Ribosome.Host.Api.Data
lib/Ribosome/Api/Echo.hs view
@@ -1,46 +1,53 @@+-- |API functions for echoing messages in Neovim. module Ribosome.Api.Echo where -import Ribosome.Control.Monad.Ribo (MonadRibo, NvimE, pluginName)-import Ribosome.Data.Text (escapeQuotes)-import Ribosome.Nvim.Api.IO (vimCommand)+import Ribosome.Data.PluginName (PluginName)+import Ribosome.Host.Api.Effect (nvimEcho)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.PluginName (pluginNamePrefixed) -echoWith :: NvimE e m => Text -> Text -> m ()-echoWith cmd msg =-  vimCommand $ cmd <> " '" <> escapeQuotes msg <> "'"+-- |Echo a string, adding it to the message history if the first argument is 'True'.+simpleEcho ::+  Member Rpc r =>+  Bool ->+  Text ->+  Sem r ()+simpleEcho history msg =+  nvimEcho [msgpackArray msg] history mempty -echoWithName :: MonadRibo m => NvimE e m => Text -> Text -> m ()-echoWithName cmd msg = do-  name <- pluginName-  echoWith cmd $ name <> ": " <> msg+-- |Echo a string prefixed with the plugin name, adding it to the message history if the first argument is 'True'.+prefixedEcho ::+  Members [Rpc, Reader PluginName] r =>+  Bool ->+  Text ->+  Sem r ()+prefixedEcho history msg = do+  pref <- pluginNamePrefixed msg+  simpleEcho history pref -echo' :: NvimE e m => Text -> m ()-echo' =-  echoWith "echo"+-- |Echo a string with a highlight group.+echohl ::+  Member Rpc r =>+  Bool ->+  Text ->+  Text ->+  Sem r ()+echohl history hl msg =+  nvimEcho [msgpackArray msg hl] history mempty -echo :: MonadRibo m => NvimE e m => Text -> m ()+-- |Echo a string prefixed with the plugin name, without adding it to the message history.+echo ::+  Members [Rpc, Reader PluginName] r =>+  Text ->+  Sem r () echo =-  echoWithName "echo"--echom' :: NvimE e m => Text -> m ()-echom' =-  echoWith "echom"+  prefixedEcho False -echom :: MonadRibo m => NvimE e m => Text -> m ()+-- |Echo a string prefixed with the plugin name and add it to the message history.+echom ::+  Members [Rpc, Reader PluginName] r =>+  Text ->+  Sem r () 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 " <>)+  prefixedEcho True
− lib/Ribosome/Api/Exists.hs 
@@ -1,124 +0,0 @@-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, (<+>))-import Neovim (-  AnsiStyle,-  Doc,-  NvimObject,-  Object(ObjectInt),-  )--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-  deriving Show--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 thunk check (Retry timeout interval) = do-  start <- epochSeconds-  step start-  where-    step start = do-      result <- thunk-      checked <- check result-      recurse start checked-    recurse _ (Right b) = return (Right b)-    recurse start (Left e) = do-      current <- epochSeconds-      if (current - start) < timeout-      then do-        sleep interval-        step start-      else return $ Left e--waitFor ::-  NvimE e m =>-  MonadIO m =>-  NvimObject b =>-  m Object ->-  (Object -> m (Either (Doc AnsiStyle) b)) ->-  Retry ->-  m (Either (Doc AnsiStyle) b)-waitFor thunk check' =-  retry thunk check-  where-    check result =-      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 $ "weird return type " <+> viaShow a--vimExists ::-  NvimE e m =>-  Text ->-  m Object-vimExists entity =-  vimCallFunction "exists" [toMsgpack entity]--vimDoesExist ::-  NvimE e m =>-  Text ->-  m Bool-vimDoesExist entity =-  fmap (isRight . existsResult) (vimExists entity)--function ::-  NvimE e m =>-  Text ->-  m Bool-function name =-  vimDoesExist ("*" <> name)--waitForFunction ::-  NvimE e m =>-  MonadIO m =>-  Text ->-  Retry ->-  m (Either (Doc AnsiStyle) ())-waitForFunction name =-  waitFor thunk (return . existsResult)-  where-    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,18 +1,24 @@+-- |Defining Neovim functions. module Ribosome.Api.Function where -import qualified Data.Text as Text (intercalate)+import qualified Data.Text as Text+import Exon (exon) -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.IO (vimCommand)+import Ribosome.Host.Api.Effect (nvimExec)+import Ribosome.Host.Effect.Rpc (Rpc) +-- |Define a Neovim function. defineFunction ::-  NvimE e m =>+  Member Rpc r =>+  -- |Function name.   Text ->+  -- |Function parameters.   [Text] ->+  -- |Vimscript lines that form the function body.   [Text] ->-  m ()+  Sem r () defineFunction name params body =-  vimCommand $ unlines $ sig : body ++ ["endfunction"]+  void $ nvimExec (unlines (sig : body ++ ["endfunction"])) True   where     sig =-      "function! " <> name <> "(" <> Text.intercalate ", " params <> ")"+      [exon|function! #{name}(#{Text.intercalate ", " params})|]
lib/Ribosome/Api/Input.hs view
@@ -1,17 +1,53 @@+-- |Functions for simulating user input in tests. module Ribosome.Api.Input where -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.IO (vimInput)-import Ribosome.System.Time (sleep)+import Conc (withAsync_)+import qualified Polysemy.Time as Time+import Time (MilliSeconds, NanoSeconds, convert) +import Ribosome.Host.Api.Effect (nvimInput, nvimReplaceTermcodes, nvimFeedkeys)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Send a list of character sequences as user input to Neovim with an optional wait interval.+--+-- Uses @nvim_input@. syntheticInput ::-  MonadIO m =>-  NvimE e m =>-  Maybe Double ->+  Members [Rpc, Time t d] r =>+  Maybe NanoSeconds ->   [Text] ->-  m ()+  Sem r () syntheticInput interval =-  traverse_ send-  where-    send c =-      traverse_ sleep interval *> vimInput c+  traverse_ \ c ->+    traverse_ Time.sleep interval *> nvimInput c++-- |Send a sequence of keys using @nvim_feedkeys@ after replacing terminal codes.+feedKey ::+  Member Rpc r =>+  Text ->+  Sem r ()+feedKey k = do+  key <- nvimReplaceTermcodes k True False True+  nvimFeedkeys key "mt" False++-- |Send a list of character sequences as user input to Neovim with an optional wait interval.+--+-- Uses @nvim_feedkeys@.+syntheticInputFk ::+  Members [Rpc, Time t d] r =>+  Maybe NanoSeconds ->+  [Text] ->+  Sem r ()+syntheticInputFk interval =+  traverse_ \ c ->+    traverse_ Time.sleep interval *> feedKey c++-- |Run an action after forking a thread that sends user input to Neovim. +withInput ::+  Members [Rpc, Resource, Race, Async, Time t d] r =>+  Maybe MilliSeconds ->+  Maybe MilliSeconds ->+  [Text] ->+  Sem r a ->+  Sem r a+withInput delay interval chrs =+  withAsync_ (traverse_ Time.sleep delay *> syntheticInput (convert <$> interval) chrs)
+ lib/Ribosome/Api/Mode.hs view
@@ -0,0 +1,51 @@+-- |API functions for obtaining Neovim's current mode.+module Ribosome.Api.Mode where++import Ribosome.Data.Mode (NvimMode)+import Ribosome.Host.Api.Effect (nvimGetMode, vimCallFunction)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (..), msgpackFromString)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |An encoding of Neovim's mode for only the most basic variants.+data SimpleMode =+  Normal+  |+  Visual+  |+  Insert+  |+  Other Text+  deriving stock (Eq, Show)++instance IsString SimpleMode where+  fromString "n" = Normal+  fromString "v" = Visual+  fromString "V" = Visual+  fromString "CTRL-V" = Visual+  fromString "i" = Insert+  fromString a = Other (toText a)++instance MsgpackDecode SimpleMode where+  fromMsgpack =+    msgpackFromString "SimpleMode"++-- |Get the current mode as a 'SimpleMode'.+simpleMode ::+  Member Rpc r =>+  Sem r SimpleMode+simpleMode =+  vimCallFunction "mode" []++-- |Indicate whether Neovim is in visual mode.+visualModeActive ::+  Member Rpc r =>+  Sem r Bool+visualModeActive =+  (== Visual) <$> simpleMode++-- |Get the current mode.+mode ::+  Member Rpc r =>+  Sem r NvimMode+mode =+  nvimGetMode
+ lib/Ribosome/Api/Normal.hs view
@@ -0,0 +1,23 @@+-- |Functions for triggering normal mode commands.+module Ribosome.Api.Normal where++import Ribosome.Host.Api.Effect (nvimCommand)++import Ribosome.Host.Effect.Rpc (Rpc)+import Exon (exon)++-- |Execute a sequence of characters in normal mode that may trigger mappings.+normalm ::+  Member Rpc r =>+  Text ->+  Sem r ()+normalm cmd =+  nvimCommand [exon|normal #{cmd}|]++-- |Execute a sequence of characters in normal mode that may not trigger mappings.+normal ::+  Member Rpc r =>+  Text ->+  Sem r ()+normal cmd =+  nvimCommand [exon|normal! #{cmd}|]
lib/Ribosome/Api/Option.hs view
@@ -1,22 +1,54 @@+-- |API functions for Neovim options. module Ribosome.Api.Option where +import Data.MessagePack (Object) import Data.Text (splitOn)-import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Msgpack.Encode (toMsgpack)-import Ribosome.Nvim.Api.IO (vimGetOption, vimSetOption)+import Exon (exon) -optionCat :: NvimE e m => Text -> Text -> m ()+import Ribosome.Host.Api.Effect (vimGetOption, vimSetOption)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Append a string to a comma-separated option.+optionCat ::+  Member Rpc r =>+  Text ->+  Text ->+  Sem r () optionCat name extra = do   current <- vimGetOption name-  vimSetOption name $ toMsgpack $ current <> "," <> extra--rtpCat :: NvimE e m => Text -> m ()-rtpCat = optionCat "runtimepath"+  vimSetOption name [exon|#{current},#{extra}|] -optionString :: NvimE e m => Text -> m Text-optionString = vimGetOption+-- |Append a string to the option @runtimepath@.+rtpCat ::+  Member Rpc r =>+  Text ->+  Sem r ()+rtpCat =+  optionCat "runtimepath" -optionList :: NvimE e m => Text -> m [Text]+-- |Get a list of strings from a comma-separated option.+optionList ::+  Member Rpc r =>+  Text ->+  Sem r [Text] optionList name = do   s <- vimGetOption name-  return $ splitOn "," s+  pure (splitOn "," s)++-- |Run an action with an option temporarily set to a value, then restore the old value.+withOption ::+  ∀ a r b .+  Members [Rpc, Resource] r =>+  MsgpackEncode a =>+  Text ->+  a ->+  Sem r b ->+  Sem r b+withOption name value =+  bracket setOpt reset . const+  where+    setOpt =+      vimGetOption @Object name <* vimSetOption name value+    reset =+      vimSetOption name
lib/Ribosome/Api/Path.hs view
@@ -1,7 +1,77 @@+-- |API function for file system paths. module Ribosome.Api.Path where -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.IO (vimCallFunction)+import Exon (exon)+import Path (Abs, Dir, File, Path, SomeBase (Abs, Rel), parseSomeDir, parseSomeFile, (</>)) -nvimCwd :: NvimE e m => m FilePath-nvimCwd = vimCallFunction "getcwd" []+import Ribosome.Host.Api.Effect (nvimCommand, vimCallFunction)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Internal.Path (failInvalidPath)+import Ribosome.Host.Path (pathText)++-- |Get Neovim's current working directory.+nvimCwd ::+  Member Rpc r =>+  Sem r (Path Abs Dir)+nvimCwd =+  vimCallFunction "getcwd" []++-- |Set Neovim's current working directory.+nvimSetCwd ::+  Member Rpc r =>+  Path Abs Dir ->+  Sem r ()+nvimSetCwd dir =+  nvimCommand [exon|cd #{pathText dir}|]++-- |Convert an abstract path to an absolute one, using Neovim's current working directory as the base for relative+-- paths.+nvimRelativePath ::+  Member Rpc r =>+  SomeBase t ->+  Sem r (Path Abs t)+nvimRelativePath = \case+  Abs p ->+    pure p+  Rel p -> do+    cwd <- nvimCwd+    pure (cwd </> p)++-- |Parse a directory path and prepend Neovim's current working directory to it if it's relative.+parseNvimDir ::+  Member Rpc r =>+  Text ->+  Sem r (Maybe (Path Abs Dir))+parseNvimDir "" =+  Just <$> nvimCwd+parseNvimDir p =+  traverse nvimRelativePath (parseSomeDir (toString p))++-- |Parse a file path and prepend Neovim's current working directory to it if it's relative.+parseNvimFile ::+  Member Rpc r =>+  Text ->+  Sem r (Maybe (Path Abs File))+parseNvimFile =+  traverse nvimRelativePath . parseSomeFile . toString++-- |Parse a directory path and prepend Neovim's current working directory to it if it's relative.+--+-- If parsing fails, emit an error 'Report'.+nvimDir ::+  Members [Rpc, Stop Report] r =>+  Text ->+  Sem r (Path Abs Dir)+nvimDir spec =+  failInvalidPath spec =<< parseNvimDir spec++-- |Parse a file path and prepend Neovim's current working directory to it if it's relative.+--+-- If parsing fails, emit an error 'Report'.+nvimFile ::+  Members [Rpc, Stop Report] r =>+  Text ->+  Sem r (Path Abs File)+nvimFile spec =+  failInvalidPath spec =<< parseNvimFile spec
+ lib/Ribosome/Api/Position.hs view
@@ -0,0 +1,34 @@+-- |API functions for @getpos@.+module Ribosome.Api.Position where++import Ribosome.Host.Api.Data (nvimCallFunction)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.RpcCall (RpcCall)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)++-- |'RpcCall' for the function @getpos@ that returns a 4-tuple.+getposCall ::+  Text ->+  RpcCall (Int, Int, Int, Int)+getposCall expr =+  nvimCallFunction "getpos" [toMsgpack expr]++-- |Call the function @getpos@ and return a 4-tuple.+getpos ::+  Member Rpc r =>+  Text ->+  Sem r (Int, Int, Int, Int)+getpos =+  Rpc.sync . getposCall++-- |Return the start and end coordinates of visual mode.+visualPos ::+  Member Rpc r =>+  Sem r ((Int, Int), (Int, Int))+visualPos = do+  ((_, lnumStart, colStart, _), (_, lnumEnd, colEnd, _)) <- Rpc.sync do+    start <- getposCall "'<"+    end <- getposCall "'>"+    pure (start, end)+  pure ((lnumStart, colStart), (lnumEnd, colEnd))
lib/Ribosome/Api/Process.hs view
@@ -1,11 +1,12 @@+-- |API functions for process IDs. 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)+import Ribosome.Host.Api.Effect (vimCallFunction)+import Ribosome.Host.Effect.Rpc (Rpc) -vimPid :: (MonadDeepError e RpcError m, Nvim m) => m Int+-- |Return Neovim's process ID.+vimPid ::+  Member Rpc r =>+  Sem r Int vimPid =   vimCallFunction "getpid" []
+ lib/Ribosome/Api/Register.hs view
@@ -0,0 +1,99 @@+-- |API functions for registers.+module Ribosome.Api.Register where++import Ribosome.Data.Register (Register)+import qualified Ribosome.Data.Register as Register (Register (..))+import Ribosome.Data.RegisterType (RegisterType)+import qualified Ribosome.Data.RegisterType as RegisterType (RegisterType (..))+import Ribosome.Host.Api.Effect (vimCallFunction)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Effect.Rpc (Rpc)++-- |The special register referring to the primary X11 selection.+starRegister :: Register+starRegister =+  Register.Special "*"++-- |The special register referring to the clipboard X11 selection.+plusRegister :: Register+plusRegister =+  Register.Special "+"++-- |The special register referring to the unnamed register.+unnamedRegister :: Register+unnamedRegister =+  Register.Special "\""++-- |Set a Neovim register's contents, using the specified type.+--+-- A register's type determines whether the contents are supposed to be pasted as lines or characters, for example.+setregAs ::+  Member Rpc r =>+  MsgpackEncode a =>+  RegisterType ->+  Register ->+  a ->+  Sem r ()+setregAs regType register text =+  vimCallFunction "setreg" (msgpackArray register text regType)++-- |Set a Neovim register's contents as inline characters.+setreg ::+  Member Rpc r =>+  Register ->+  Text ->+  Sem r ()+setreg =+  setregAs RegisterType.Character++-- |Set a Neovim register's contents as whole lines.+setregLine ::+  Member Rpc r =>+  Register ->+  [Text] ->+  Sem r ()+setregLine =+  setregAs RegisterType.Line++-- |Get the type of a register's contents.+getregtype ::+  Member Rpc r =>+  Register ->+  Sem r RegisterType+getregtype register =+  vimCallFunction "getregtype" [toMsgpack register]++-- |Get a Neovim register's contents, using the specified type.+--+-- A register's type determines whether the contents are supposed to be pasted as lines or characters, for example.+getregAs ::+  Member Rpc r =>+  MsgpackDecode a =>+  Bool ->+  Register ->+  Sem r a+getregAs list register =+  vimCallFunction "getreg" (msgpackArray register (0 :: Int) list)++-- |Get a Neovim register's contents as inline characters.+getreg ::+  Member Rpc r =>+  Register ->+  Sem r (Either [Text] Text)+getreg register =+  withType =<< getregtype register+  where+    withType RegisterType.Line =+      Left <$> getregAs True register+    withType _ =+      Right <$> getregAs False register++-- |Get a Neovim register's contents as whole lines.+getregLines ::+  Member Rpc r =>+  Register ->+  Sem r [Text]+getregLines =+  getregAs True
− lib/Ribosome/Api/Response.hs 
@@ -1,26 +0,0 @@-module Ribosome.Api.Response(-  nvimFatal,-  nvimResponseString,-  nvimResponseStringArray,-  nvimValidateFatal,-)-where--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 Text-nvimResponseString (ObjectString a) = return $ decodeUtf8 a-nvimResponseString a = liftIO . fail $ "invalid nvim type for Text: " <> show a--nvimResponseStringArray :: Object -> Neovim env [Text]-nvimResponseStringArray (ObjectArray a) = traverse nvimResponseString 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-  result <- nvimFatal response-  validate result
lib/Ribosome/Api/Sleep.hs view
@@ -1,18 +1,23 @@+-- |API functions for sleeping in Neovim. module Ribosome.Api.Sleep where -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.IO (vimCommand)+import Exon (exon) +import Ribosome.Host.Api.Effect (nvimCommand)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Run the @sleep@ command. nvimSleep ::-  NvimE e m =>+  Member Rpc r =>   Int ->-  m ()+  Sem r () nvimSleep interval =-  vimCommand $ "sleep " <> show interval+  nvimCommand [exon|sleep #{show interval}|] +-- |Run the @sleep@ command with the number interpreted as milliseconds. nvimMSleep ::-  NvimE e m =>+  Member Rpc r =>   Int ->-  m ()+  Sem r () nvimMSleep interval =-  vimCommand $ "sleep " <> show interval <> "m"+  nvimCommand [exon|sleep #{show interval}m|]
lib/Ribosome/Api/Syntax.hs view
@@ -1,89 +1,38 @@+-- |API functions for applying syntax rules to Neovim. 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)+import Ribosome.Data.Syntax (Syntax)+import Ribosome.Host.Api.Data (Window)+import Ribosome.Host.Api.Effect (vimCallFunction)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Modify (windo)+import Ribosome.Internal.Syntax (catCmds, syntaxCmds) +-- |Apply syntax rules to the current window. executeSyntax ::-  MonadDeepError e DecodeError m =>-  NvimE e m =>+  Member Rpc r =>   Syntax ->-  m [Object]+  Sem r () executeSyntax =-  atomic . (rpcCommand <$$> syntaxCmds)+  Rpc.sync . catCmds . syntaxCmds +-- |Apply syntax rules to a window. executeWindowSyntax ::-  MonadDeepError e DecodeError m =>-  NvimE e m =>+  Member Rpc r =>   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)+  Sem r ()+executeWindowSyntax win syntax =+  windo win (executeSyntax syntax)++-- |Get the name of the syntax group at a given position.+syntaxName ::+  Member Rpc r =>+  Int ->+  Int ->+  Sem r (Text, Text)+syntaxName l c = do+  synId <- vimCallFunction "synID" (toMsgpack <$> [l, c, 0])+  (,) <$> vimCallFunction "getline" [toMsgpack l] <*> vimCallFunction "synIDattr" [synId, toMsgpack ("name" :: Text)]
lib/Ribosome/Api/Tabpage.hs view
@@ -1,17 +1,20 @@+-- |API functions for tabpages. module Ribosome.Api.Tabpage where -import Control.Monad (when)+import Exon (exon) -import Ribosome.Control.Monad.Ribo (NvimE)-import Ribosome.Nvim.Api.Data (Tabpage)-import Ribosome.Nvim.Api.IO (nvimTabpageGetNumber, tabpageIsValid, vimCommand)+import Ribosome.Host.Api.Data (Tabpage)+import Ribosome.Host.Api.Effect (nvimTabpageGetNumber, tabpageIsValid, vimCommand)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Modify (silentBang) +-- |Close a tabpage. closeTabpage ::-  NvimE e m =>+  Member Rpc r =>   Tabpage ->-  m ()-closeTabpage tabpage = do-  valid <- tabpageIsValid tabpage-  when valid $ do+  Sem r ()+closeTabpage tabpage =+  whenM (tabpageIsValid tabpage) do     number <- nvimTabpageGetNumber tabpage-    vimCommand ("silent! tabclose! " <> show number)+    silentBang do+      vimCommand [exon|tabclose! #{show number}|]
+ lib/Ribosome/Api/Undo.hs view
@@ -0,0 +1,12 @@+-- |API functions for @:undo@.+module Ribosome.Api.Undo where++import Ribosome.Host.Api.Effect (nvimCommand)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Run @:undo@.+undo ::+  Member Rpc r =>+  Sem r ()+undo =+  nvimCommand "undo"
− lib/Ribosome/Api/Variable.hs 
@@ -1,25 +0,0 @@-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,80 +1,157 @@+-- |API functions for windows. 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 (+import Ribosome.Data.WindowView (PartialWindowView, WindowView)+import Ribosome.Host.Api.Data (Window)+import Ribosome.Host.Api.Effect (+  nvimBufGetOption,+  nvimCallFunction,+  nvimCommand,   nvimGetCurrentWin,   nvimWinClose,+  nvimWinGetBuf,   nvimWinGetCursor,   nvimWinSetCursor,-  vimCommand,+  vimCallFunction,+  vimGetWindows,+  vimSetCurrentWindow,   windowIsValid,   )+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Modify (silentBang) +-- |Close a window if it is valid and not the last one. closeWindow ::-  NvimE e m =>+  Member Rpc r =>   Window ->-  m ()+  Sem r () closeWindow window = do   valid <- windowIsValid window-  when valid $ nvimWinClose window True+  last' <- (1 ==) . length <$> vimGetWindows+  when (valid && not last') $ nvimWinClose window True +-- |Get the zero-based position of the cursor in a window. cursor ::-  NvimE e m =>+  Member Rpc r =>   Window ->-  m (Int, Int)+  Sem r (Int, Int) cursor window = do   (line, col) <- nvimWinGetCursor window-  return (fromIntegral line - 1, fromIntegral col)+  pure (line - 1, col) +-- |Get the zero-based position of the cursor in the active window. currentCursor ::-  NvimE e m =>-  m (Int, Int)+  Member Rpc r =>+  Sem r (Int, Int) currentCursor =   cursor =<< nvimGetCurrentWin +-- |Get the zero-based line number of the cursor in a window. windowLine ::-  NvimE e m =>+  Member Rpc r =>   Window ->-  m Int+  Sem r Int windowLine window =   fst <$> cursor window +-- |Get the zero-based line number of the cursor in the active window. currentLine ::-  NvimE e m =>-  m Int+  Member Rpc r =>+  Sem r Int currentLine =   windowLine =<< nvimGetCurrentWin +-- |Set the zero-based position of the cursor in a window. setCursor ::-  NvimE e m =>+  Member Rpc r =>   Window ->   Int ->   Int ->-  m ()+  Sem r () setCursor window line col =   nvimWinSetCursor window (line + 1, col) +-- |Set the zero-based position of the cursor in the current window.+setCurrentCursor ::+  Member Rpc r =>+  Int ->+  Int ->+  Sem r ()+setCurrentCursor line col = do+  window <- nvimGetCurrentWin+  setCursor window line col++-- |Set the zero-based line number of the cursor in a window, using the beginning of the line for the column. setLine ::-  NvimE e m =>+  Member Rpc r =>   Window ->   Int ->-  m ()+  Sem r () setLine window line =   setCursor window line 0 +-- |Set the zero-based line number of the cursor in the current window, using the beginning of the line for the column. setCurrentLine ::-  NvimE e m =>+  Member Rpc r =>   Int ->-  m ()-setCurrentLine line = do-  window <- nvimGetCurrentWin-  setLine window line+  Sem r ()+setCurrentLine line =+  setCurrentCursor line 0 +-- |Redraw the screen. redraw ::-  NvimE e m =>-  m ()+  Member Rpc r =>+  Sem r () redraw =-  vimCommand "silent! redraw!"+  silentBang do+    nvimCommand "redraw!"++-- |A main window means here any non-window that may be used to edit a file, i.e. one with an empty @buftype@.+findMainWindow ::+  Member Rpc r =>+  Sem r (Maybe Window)+findMainWindow =+  listToMaybe <$> (filterM isFile =<< vimGetWindows)+  where+    isFile w = do+      buf <- nvimWinGetBuf w+      (("" :: Text) ==) <$> nvimBufGetOption buf "buftype"++-- |Create a new window at the top if no existing window has empty @buftype@.+-- Focuses the window.+ensureMainWindow ::+  Member Rpc r =>+  Sem r Window+ensureMainWindow =+  maybe create focus =<< findMainWindow+  where+    create = do+      nvimCommand "aboveleft new"+      nvimGetCurrentWin <* nvimCommand "wincmd K"+    focus w =+      w <$ vimSetCurrentWindow w++-- |Call @winsaveview@.+saveView ::+  Member Rpc r =>+  Sem r WindowView+saveView =+  vimCallFunction "winsaveview" []++-- |Call @winrestview@ with a previously obtained view from 'saveView'.+restoreView ::+  Member Rpc r =>+  PartialWindowView ->+  Sem r ()+restoreView v =+  vimCallFunction "winrestview" [toMsgpack v]++-- |Execute a command in a window.+windowExec ::+  Member Rpc r =>+  Window ->+  Text ->+  Sem r ()+windowExec window cmd =+  nvimCallFunction "win_execute" [toMsgpack window, toMsgpack cmd]
+ lib/Ribosome/Cli.hs view
@@ -0,0 +1,83 @@+-- |@optparse-applicative@ parsers for the Ribosome CLI.+module Ribosome.Cli where++import Exon (exon)+import Options.Applicative (+  Parser,+  customExecParser,+  fullDesc,+  header,+  helper,+  info,+  long,+  option,+  prefs,+  showHelpOnEmpty,+  showHelpOnError,+  )+import Path (Abs, Dir, Path)+import Path.IO (getCurrentDir)++import Ribosome.Host.Optparse (filePathOption, severityOption)+import Ribosome.Data.CliConfig (CliConfig (CliConfig), CliLogConfig (CliLogConfig))+import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Host.Data.HostConfig (HostConfig (HostConfig), LogConfig (LogConfig))++-- |Parse the options related to logging.+logParser ::+  Path Abs Dir ->+  Parser CliLogConfig+logParser cwd = do+  logFile <- optional (option (filePathOption cwd) (long "log-file"))+  levelEcho <- optional (option severityOption (long "log-level-echo"))+  levelStderr <- optional (option severityOption (long "log-level-stderr"))+  levelFile <- optional (option severityOption (long "log-level-file"))+  pure (CliLogConfig logFile levelEcho levelStderr levelFile)++-- |Parse the host config as well as the arbitrary user defined config.+confParser ::+  Path Abs Dir ->+  Parser c ->+  Parser (CliConfig, c)+confParser cwd customParser = do+  cli <- CliConfig <$> logParser cwd+  custom <- customParser+  pure (cli, custom)++-- |Parse the host config as well as the arbitrary user defined config, in 'IO'.+parseCli ::+  PluginName ->+  Parser c ->+  IO (CliConfig, c)+parseCli (PluginName name) customParser = do+  cwd <- getCurrentDir+  customExecParser parserPrefs (info (helper <*> confParser cwd customParser) desc)+  where+    parserPrefs =+      prefs (showHelpOnEmpty <> showHelpOnError)+    desc =+      fullDesc <> header [exon|#{toString name} is a Neovim plugin.|]++-- |Parse the CLI options for a plugin config and update a default 'HostConfig' with the CLI options.+withDefault :: HostConfig -> CliConfig -> HostConfig+withDefault (HostConfig defLog) cliConfig =+  HostConfig log+  where+    CliConfig (CliLogConfig file levelEcho levelStderr levelFile) =+      cliConfig+    LogConfig defFile defLevelEcho defLevelStderr defLevelFile conc =+      defLog+    log =+      LogConfig (file <|> defFile) (fromMaybe defLevelEcho levelEcho) (fromMaybe defLevelStderr levelStderr)+      (fromMaybe defLevelFile levelFile) conc++-- |Parse the CLI options for a plugin config and pass an updated default 'HostConfig' to a callback.+withCli ::+  PluginName ->+  HostConfig ->+  Parser c ->+  (HostConfig -> c -> IO a) ->+  IO a+withCli name defaultConf customParser f = do+  (cliConfig, custom) <- parseCli name customParser+  f (withDefault defaultConf cliConfig) custom
− lib/Ribosome/Config/Setting.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Ribosome.Config.Setting where--import Control.Monad.DeepError (MonadDeepError(throwHoist), catchAt)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Except (runExceptT)-import Data.DeepPrisms (deepPrisms)--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 ::-  (MonadRibo m) =>-  Setting a ->-  m Text-settingVariableName (Setting settingName False _) =-  return settingName-settingVariableName (Setting settingName True _) = do-  name <- pluginName-  return $ name <> "_" <> settingName--settingRaw :: (MonadRibo m, Nvim m, MsgpackDecode a, MonadDeepError e RpcError m) => Setting a -> m a-settingRaw s =-  vimGetVar =<< settingVariableName s--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--data SettingOrError =-  Sett SettingError-  |-  Rpc RpcError--deepPrisms ''SettingOrError--settingOr ::-  (MonadIO m, Nvim m, MonadRibo m, MsgpackDecode a) =>-  a ->-  Setting a ->-  m a-settingOr a =-  (fromRight a <$>) . runExceptT . setting @SettingOrError--settingMaybe ::-  (MonadIO m, Nvim m, MonadRibo m, MsgpackDecode a) =>-  Setting a ->-  m (Maybe a)-settingMaybe =-  (rightToMaybe <$>) . runExceptT . setting @SettingOrError--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 
@@ -1,9 +0,0 @@-module Ribosome.Config.Settings where--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 
@@ -1,103 +0,0 @@-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 
@@ -1,18 +0,0 @@-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 
@@ -1,51 +0,0 @@-module Ribosome.Control.Lock where--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.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 :: (MonadRibo m, MonadIO m) => m Locks-getLocks =-  pluginInternalL Ribosome.locks--inspectLocks :: (MonadRibo m, MonadIO m) => (Locks -> a) -> m a-inspectLocks = (<$> getLocks)--modifyLocks :: MonadRibo m => (Locks -> Locks) -> m ()-modifyLocks =-  pluginInternalModifyL Ribosome.locks--getOrCreateLock :: (MonadRibo m, MonadIO m) => Text -> m (TMVar ())-getOrCreateLock key = do-  currentLock <- inspectLocks $ Lens.view $ Lens.at key-  case currentLock of-    Just tv -> return tv-    Nothing -> do-      tv <- newTMVarIO ()-      modifyLocks $ Map.insert key tv-      getOrCreateLock key--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.debug $ "locking MVar `" <> key <> "`"-      finally thunk $ atomically $ tryPutTMVar currentLock ()-      Log.debug $ "unlocking MVar `" <> key <> "`"-    Nothing -> return ()
− lib/Ribosome/Control/Monad/Error.hs 
@@ -1,12 +0,0 @@-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 
@@ -1,230 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-}--module Ribosome.Control.Monad.Ribo where--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.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)--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 ()--type RNeovim s = Neovim (Ribosome s)--instance MonadBase IO (Neovim e) where-  liftBase = liftIO--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--newtype Ribo s e a =-  Ribo { unRibo :: ExceptT e (RNeovim s) a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadFail, MonadBase IO)--deriving instance MonadError e (Ribo s e)--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--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)--deriving instance MonadReader (Ribosome s) (Ribo s e)--riboStateVar ::-  MonadReader (Ribosome s) m =>-  m (TMVar (RibosomeState s))-riboStateVar =-  asks (Lens.view Ribosome.state)--public ::-  DeepLenses s s' =>-  Lens' (RibosomeState s) s'-public =-  RibosomeState.public . deepLens--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/Ribosome.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveAnyClass #-}--module Ribosome.Control.Ribosome where--import Control.Lens (makeClassy)-import Control.Monad.IO.Class (MonadIO)-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 Text (TMVar ())--data RibosomeInternal =-  RibosomeInternal {-    _locks :: Locks,-    _errors :: Errors,-    _scratch :: Map Text Scratch,-    _watchedVariables :: Map Text Object,-    _projectDir :: Maybe (Path Abs Dir)-  }-  deriving (Generic, Default)--makeClassy ''RibosomeInternal--data RibosomeState s =-  RibosomeState {-    _internal :: RibosomeInternal,-    _public :: s-  }-  deriving (Generic, Default)--makeClassy ''RibosomeState--data Ribosome s =-  Ribosome {-    _name :: Text,-    _state :: TMVar (RibosomeState s)-  }--makeClassy ''Ribosome--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 
@@ -1,18 +0,0 @@-{-# 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/CliConfig.hs view
@@ -0,0 +1,22 @@+-- |Config data types for the CLI option parser.+module Ribosome.Data.CliConfig where++import Log (Severity)+import Path (Abs, File, Path)++-- |Intermediate data type with optional fields for 'Ribosome.LogConfig'.+data CliLogConfig =+  CliLogConfig {+    logFile :: Maybe (Path Abs File),+    logLevelEcho :: Maybe Severity,+    logLevelStderr :: Maybe Severity,+    logLevelFile :: Maybe Severity+  }+  deriving stock (Eq, Show)++-- |Intermediate data type with optional fields for 'Ribosome.HostConfig'.+data CliConfig =+  CliConfig {+    log :: CliLogConfig+  }+  deriving stock (Eq, Show)
− lib/Ribosome/Data/Conduit.hs 
@@ -1,105 +0,0 @@-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 
@@ -1,418 +0,0 @@-{-# 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/CustomConfig.hs view
@@ -0,0 +1,7 @@+-- |Disambiguation type for @Reader@.+module Ribosome.Data.CustomConfig where++-- |Disambiguation type used for the custom CLI configuration that is polymorphic in the stack.+newtype CustomConfig c =+  CustomConfig { unCustomConfig :: c }+  deriving stock (Eq, Show)
− lib/Ribosome/Data/ErrorReport.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Ribosome.Data.ErrorReport(-  ErrorReport(..),-  user,-  log,-  priority,-) where--import Control.Lens (makeClassy)-import System.Log (Priority)--data ErrorReport =-  ErrorReport {-    _user :: Text,-    _log :: [Text],-    _priority :: Priority-  }-  deriving (Eq, Show)--makeClassy ''ErrorReport
− lib/Ribosome/Data/Errors.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Ribosome.Data.Errors(-  ComponentName(..),-  Errors(..),-  Error(..),-  componentErrors,-  timestamp,-  report,-) where--import Control.Lens (makeClassy)-import Data.Default (Default)-import Data.Map (Map)-import qualified Data.Map as Map (toList)-import Data.Text.Prettyprint.Doc (Doc, Pretty(..), align, line, vsep, (<+>), (<>))-import Prelude hiding (error)--import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))--newtype ComponentName =-  ComponentName Text-  deriving (Eq, Ord, Show)--data Error =-  Error {-    _timestamp :: Int,-    _report :: ErrorReport-  }-  deriving (Eq, Show)--makeClassy ''Error--instance Pretty Error where-  pretty (Error stamp (ErrorReport _ lines' _)) =-    pretty stamp <+> align (vsep (pretty <$> lines'))--newtype Errors =-  Errors {-    _componentErrors :: Map ComponentName [Error]-    }-  deriving (Eq, Show, Default)--makeClassy ''Errors--prettyComponentErrors :: ComponentName -> [Error] -> Doc a-prettyComponentErrors (ComponentName name) errors' =-  line <> line <> pretty name <> ":" <> line <> vsep (pretty <$> errors')--instance Pretty Errors where-  pretty (Errors errors') =-    vsep (uncurry prettyComponentErrors <$> Map.toList errors')
+ lib/Ribosome/Data/FileBuffer.hs view
@@ -0,0 +1,14 @@+-- |Data type representing a buffer associated with a file system path.+module Ribosome.Data.FileBuffer where++import Path (Abs, File, Path)++import Ribosome.Host.Api.Data (Buffer)++-- |Data type representing a buffer associated with a file system path.+data FileBuffer =+  FileBuffer {+    buffer :: Buffer,+    path :: Path Abs File+  }+  deriving stock (Eq, Show)
+ lib/Ribosome/Data/FloatOptions.hs view
@@ -0,0 +1,138 @@+-- |Data types for floating window API codec.+module Ribosome.Data.FloatOptions where++import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Class.Msgpack.Map (msgpackMap)++-- |The reference point to which a floating window's position is defined.+data FloatRelative =+  Editor+  |+  Win+  |+  Cursor+  deriving stock (Eq, Show)++instance MsgpackEncode FloatRelative where+  toMsgpack Editor = toMsgpack ("editor" :: Text)+  toMsgpack Win = toMsgpack ("win" :: Text)+  toMsgpack Cursor = toMsgpack ("cursor" :: Text)++instance Default FloatRelative where+  def = Cursor++-- |The corner of a floating window that is positioned at the specified coordinates.+data FloatAnchor =+  NW+  |+  NE+  |+  SW+  |+  SE+  deriving stock (Eq, Show)++instance MsgpackEncode FloatAnchor where+  toMsgpack NW = toMsgpack ("NW" :: Text)+  toMsgpack NE = toMsgpack ("NE" :: Text)+  toMsgpack SW = toMsgpack ("SW" :: Text)+  toMsgpack SE = toMsgpack ("SE" :: Text)++instance Default FloatAnchor where+  def = NW++-- |The border style of a floating window.+data FloatBorder =+  None+  |+  Single+  |+  Double+  |+  Rounded+  |+  Solid+  |+  Shadow+  |+  -- |A list of characters that is drawn for the border, starting with the top left corner, going clockwise, repeating+  -- if too short.+  Manual [Text]+  deriving stock (Eq, Show, Generic)++instance MsgpackEncode FloatBorder where+  toMsgpack = \case+    None -> toMsgpack @Text "none"+    Single -> toMsgpack @Text "single"+    Double -> toMsgpack @Text "double"+    Rounded -> toMsgpack @Text "rounded"+    Solid -> toMsgpack @Text "solid"+    Shadow -> toMsgpack @Text "shadow"+    Manual cs -> toMsgpack cs++instance Default FloatBorder where+  def =+    Rounded++-- |Neovim has a style option for floating windows that sets a few options in bulk, with only one possible value.+data FloatStyle =+  FloatStyleMinimal+  deriving stock (Eq, Show)++instance Default FloatStyle where+  def =+    FloatStyleMinimal++instance MsgpackEncode FloatStyle where+  toMsgpack FloatStyleMinimal =+    toMsgpack @Text "minimal"++-- |The z-index of a floating window, determining occlusion.+newtype FloatZindex =+  FloatZindex { unFloatZindex :: Int }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord)++instance MsgpackEncode FloatZindex where+  toMsgpack (FloatZindex i) =+    toMsgpack i++-- |The set of options accepted by the @float@ key of the argument to @nvim_open_win@, configuring the appearance and+-- geometry of a floating window.+data FloatOptions =+  FloatOptions {+    relative :: FloatRelative,+    width :: Int,+    height :: Int,+    row :: Int,+    col :: Int,+    focusable :: Bool,+    anchor :: FloatAnchor,+    bufpos :: Maybe (Int, Int),+    border :: FloatBorder,+    noautocmd :: Bool,+    enter :: Bool,+    style :: Maybe FloatStyle,+    zindex :: Maybe FloatZindex+  }+  deriving stock (Eq, Show, Generic)++instance MsgpackEncode FloatOptions where+  toMsgpack FloatOptions {..} =+    msgpackMap+    ("relative", relative)+    ("width", width)+    ("height", height)+    ("row", row)+    ("col", col)+    ("focusable", focusable)+    ("anchor", anchor)+    ("bufpos", bufpos)+    ("border", border)+    ("noautocmd", noautocmd)+    ("style", style)+    ("zindex", zindex)++instance Default FloatOptions where+  def =+    FloatOptions def 30 10 1 1 False def def def False True (Just FloatStyleMinimal) Nothing
− lib/Ribosome/Data/Foldable.hs 
@@ -1,12 +0,0 @@-module Ribosome.Data.Foldable(-  findMapMaybeM,-) where--import Control.Monad (foldM)--findMapMaybeM :: (Monad m, Foldable f) => (a -> m (Maybe b)) -> f a -> m (Maybe b)-findMapMaybeM f fa =-  foldM evaluate Nothing fa-  where-    evaluate (Just b) _ = return (Just b)-    evaluate Nothing a = f a
lib/Ribosome/Data/Mapping.hs view
@@ -1,37 +1,121 @@-{-# LANGUAGE TemplateHaskell #-}-+-- |Data types for Neovim mappings 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)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)+import Ribosome.Host.Data.Event (EventName)+import Ribosome.Host.Data.RpcName (RpcName) -data Mapping =-  Mapping {-    mappingIdent :: MappingIdent,-    mappingLhs :: Text,-    mappingMode :: Text,-    mappingRemap :: Bool,-    mappingBuffer :: Bool-  }-  deriving (Eq, Show)+-- |The sequence of keys that triggers a mapping.+newtype MappingLhs =+  MappingLhs { unMappingLhs :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord) -data MappingError =-  NoSuchMapping MappingIdent+-- |This ID type is intended to carry information about what buffer or other component triggered a mapping, if needed.+newtype MappingId =+  MappingId { unMappingId :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackDecode, MsgpackEncode)++-- |All possible variants of Neovim's @map@ commands, causing mappings to be registered for different modes.+data MapMode =+  -- |@:map@ – normal, visual, select and operator-pending+  MapDefault   |-  InvalidArgs [Object]-  deriving (Eq, Show)+  -- |@:nmap@ – normal+  MapNormal+  |+  -- |@:map!@ – insert and cmdline+  MapInsertCmdline+  |+  -- |@:imap@ – insert+  MapInsert+  |+  -- |@:cmap@ – cmdline+  MapCmdline+  |+  -- |@:lmap@ – insert, cmdline, lang-arg+  MapLangArg+  |+  -- |@:xmap@ – visual+  MapVisual+  |+  -- |@:smap@ – select+  MapSelect+  |+  -- |@:vmap@ – visual and select+  MapVisualSelect+  |+  -- |@:omap@ – operator-pending+  MapOperator+  deriving stock (Eq, Show, Ord, Enum) -deepPrisms ''MappingError+instance Default MapMode where+  def =+    MapNormal -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+-- |The character representing a map mode prefixing a @map@ command.+mapModePrefix :: MapMode -> Text+mapModePrefix = \case+  MapDefault -> ""+  MapNormal -> "n"+  MapInsertCmdline -> ""+  MapInsert -> "i"+  MapCmdline -> "c"+  MapLangArg -> "l"+  MapVisual -> "x"+  MapSelect -> "s"+  MapVisualSelect -> "v"+  MapOperator -> "o"++-- |The bang suffixing the insert+cmdline map cmd.+mapModeSuffix :: MapMode -> Text+mapModeSuffix = \case+  MapInsertCmdline -> "!"+  _ -> ""++-- |The character representing a map mode when passing it to an api function.+mapModeShortName :: MapMode -> Text+mapModeShortName m =+  mapModePrefix m <> mapModeSuffix m++-- |The action that should be performed when a mapping is triggered.+data MappingAction =+  -- |The name of the 'Ribosome.RpcHandler' that should be called when the mapping is triggered.+  MappingCall RpcName+  |+  -- |The event to publish when the mapping is triggered.+  MappingEvent EventName+  deriving stock (Eq, Show)++-- |The configuration for a mapping that is specific to Neovim.+data MappingSpec =+  MappingSpec {+    -- |The key sequence that triggers the mapping.+    lhs :: MappingLhs,+    -- |The modes in which the mapping should be installed.+    mode :: NonEmpty MapMode+  }+  deriving stock (Eq, Show, Ord, Generic)++instance IsString MappingSpec where+  fromString s =+    MappingSpec (fromString s) [def]++-- |This type associates a sequence of keys and a mode for a Neovim mapping with an RPC handler or event.+-- It is intended to be used with 'Ribosome.mappingFor' or 'Ribosome.eventMapping' and 'Ribosome.activateBufferMapping'.+data Mapping =+  Mapping {+    -- |The action to take when the mapping is triggered.+    action :: MappingAction,+    -- |The Neovim related configuration for the mapping, i.e. its key sequence and modes.+    spec :: MappingSpec,+    -- |An optional string identifying the source of the mapping, for example when adding it to multiple buffers.+    id :: Maybe MappingId,+    -- |Options like @remap@, @nowait@ or @desc@.+    opts :: Map Text Object+  }+  deriving stock (Eq, Show, Generic)
− lib/Ribosome/Data/Maybe.hs 
@@ -1,7 +0,0 @@-module Ribosome.Data.Maybe(-  orElse,-) where--orElse :: Maybe a -> Maybe a -> Maybe a-orElse fallback Nothing = fallback-orElse _ a = a
+ lib/Ribosome/Data/Mode.hs view
@@ -0,0 +1,14 @@+-- |Codec data type for the result type of @nvim_get_mode@.+module Ribosome.Data.Mode where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |Codec data type for the result type of @nvim_get_mode@.+data NvimMode =+  NvimMode {+    mode :: Text,+    blocking :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackEncode, MsgpackDecode)
lib/Ribosome/Data/PersistError.hs view
@@ -1,33 +1,35 @@-{-# LANGUAGE TemplateHaskell #-}-+-- |Error for 'Ribosome.Persist'. module Ribosome.Data.PersistError where -import System.Log (Priority(INFO, NOTICE, ERROR))+import Exon (exon)+import Polysemy.Log (Severity (Error)) -import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))-import Ribosome.Error.Report.Class (ReportError(..))+import Ribosome.Data.PersistPathError (PersistPathError)+import Ribosome.Host.Data.Report (Report (Report), Reportable (toReport)) --- TODO use Path+-- |The errors emitted by the effect 'Ribosome.PersistPath'. data PersistError =-  FileNotReadable FilePath+  -- |Can't access the persistence files.+  Permission Text   |-  NoSuchFile FilePath+  -- |Data in the persistence file has invalid format.+  Decode Text Text   |-  Decode FilePath Text-  deriving (Eq, Show)--deepPrisms ''PersistError+  -- |'Ribosome.PeristPath' threw an error.+  Path PersistPathError+  deriving stock (Eq, Show) -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+instance Reportable PersistError where+  toReport = \case+    Permission path ->+      Report msg ["PersistError.Permission:", path] Error+      where+        msg =+          [exon|Insufficient permissions for persistence file: #{path}|]+    Decode path err ->+      Report msg ["PersistError.Decode:", path, err] Error+      where+        msg =+          [exon|invalid data in persistence file, please delete it: #{path}|]+    Path err ->+      toReport err
+ lib/Ribosome/Data/PersistPathError.hs view
@@ -0,0 +1,31 @@+-- |Error for 'Ribosome.PersistPath'.+module Ribosome.Data.PersistPathError where++import Exon (exon)+import Path (Abs, Dir, Path)+import Polysemy.Log (Severity (Error))++import Ribosome.Host.Data.Report (Report (Report), Reportable (toReport))+import Ribosome.Host.Path (pathText)++-- |The errors emitted by the effect 'Ribosome.PersistPath'.+data PersistPathError =+  -- |Cannot determine the cache directory.+  Undefined+  |+  -- |General permissions error.+  Permissions (Path Abs Dir)+  deriving stock (Eq, Show)++instance Reportable PersistPathError where+  toReport = \case+    Undefined ->+      Report msg ["PersistPathError.Undefined"] Error+      where+        msg =+          "g:ribosome_persistence_dir unset and XDG not available."+    Permissions (pathText -> path) ->+      Report msg ["PersistPathError.Permissions:", path] Error+      where+        msg =+          [exon|Couldn't create persistence dir '#{path}'|]
+ lib/Ribosome/Data/PluginConfig.hs view
@@ -0,0 +1,36 @@+-- |Global configuration for a Ribosome plugin.+module Ribosome.Data.PluginConfig where++import Ribosome.Data.PluginName (PluginName)+import Ribosome.Host.Data.HostConfig (HostConfig)+import Options.Applicative (Parser)+import GHC.Show (showParen)+import Text.Show (showsPrec)+import Exon (exon)++-- |The full configuration for a Ribosome plugin, consisting of the 'HostConfig', the plugin's name, and an arbitrary+-- type for additional config defined by individual plugins.+data PluginConfig c =+  PluginConfig {+    name :: PluginName,+    host :: HostConfig,+    custom :: Parser c+  }+  deriving stock (Generic)++instance Show (PluginConfig c) where+  showsPrec d PluginConfig {..} =+    showParen (d > 10) [exon|PluginConfing { name = #{showsPrec 11 name}, host = #{showsPrec 11 host} }|]++instance Eq (PluginConfig c) where+  PluginConfig ln lh _ == PluginConfig rn rh _ =+    ln == rn && lh == rh++-- |Construct a simple 'PluginConfig' with the default config for the host, given the plugin's name.+pluginNamed :: PluginName -> PluginConfig ()+pluginNamed name =+  PluginConfig name def unit++instance IsString (PluginConfig ()) where+  fromString =+    pluginNamed . fromString
+ lib/Ribosome/Data/PluginName.hs view
@@ -0,0 +1,11 @@+-- |Data type 'PluginName'+module Ribosome.Data.PluginName where++-- |Represents the name of the plugin, to be used via 'Reader' by all its components.+--+-- The name is usually provided by main function combinators like 'Ribosome.runNvimPluginIO' via @'Reader'+-- 'Ribosome.PluginConfig'@.+newtype PluginName =+  PluginName { unPluginName :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)
+ lib/Ribosome/Data/Register.hs view
@@ -0,0 +1,70 @@+-- |Data types for register-related API functions.+module Ribosome.Data.Register where++import Data.Char (isAlpha, isNumber)+import qualified Data.Text as Text+import Exon (exon)+import Prettyprinter (Pretty (pretty))++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (..), msgpackFromString)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (..))++-- |A Neovim register.+data Register =+  Named Text+  |+  Numbered Text+  |+  Special Text+  |+  Empty+  deriving stock (Eq, Show, Generic)++instance IsString Register where+  fromString = \case+    "" ->+      Empty+    [a] | isAlpha a ->+      Named (Text.singleton a)+    [a] | isNumber a ->+      Numbered (Text.singleton a)+    a ->+      Special (toText a)++instance MsgpackDecode Register where+  fromMsgpack =+    msgpackFromString "Register"++instance MsgpackEncode Register where+  toMsgpack (Named a) =+    toMsgpack a+  toMsgpack (Numbered a) =+    toMsgpack a+  toMsgpack (Special a) =+    toMsgpack a+  toMsgpack Empty =+    toMsgpack ("" :: Text)++-- |Render a register name by prefixing it with @"@.+quoted :: Text -> Text+quoted a =+  [exon|"#{a}|]++-- |Render a register name as is usual for Neovim.+registerRepr :: Register -> Text+registerRepr = \case+  Named a ->+    quoted a+  Numbered a ->+    quoted a+  Special a ->+    quoted a+  Empty ->+    ""++instance Pretty Register where+  pretty = \case+    Empty ->+      "no register"+    a ->+      pretty (registerRepr a)
+ lib/Ribosome/Data/RegisterType.hs view
@@ -0,0 +1,58 @@+-- |Codec data type for Neovim register types.+module Ribosome.Data.RegisterType where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (..), msgpackFromString)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (..))+import Prettyprinter (Pretty (pretty))++-- |The type of a Neovim register, corresponding to concepts like line- or character-wise visual mode.+data RegisterType =+  Character+  |+  Line+  |+  Block+  |+  BlockWidth Int+  |+  Unknown Text+  deriving stock (Eq, Show, Ord)++instance IsString RegisterType where+  fromString "v" =+    Character+  fromString "V" =+    Line+  fromString a@('c' : 'v' : _) =+    Unknown (toText a)+  fromString a =+    Unknown (toText a)++instance MsgpackDecode RegisterType where+  fromMsgpack =+    msgpackFromString "RegisterType"++instance MsgpackEncode RegisterType where+  toMsgpack Character =+    toMsgpack ("v" :: Text)+  toMsgpack Line =+    toMsgpack ("V" :: Text)+  toMsgpack Block =+    toMsgpack ("b" :: Text)+  toMsgpack (BlockWidth width) =+    toMsgpack ("b" <> show width :: Text)+  toMsgpack (Unknown _) =+    toMsgpack ("" :: Text)++instance Pretty RegisterType where+  pretty = \case+    Character ->+      "c"+    Line ->+      "v"+    Block ->+      "<c-v>"+    BlockWidth width ->+      "<c-v>" <> pretty width+    Unknown a ->+      pretty a
− lib/Ribosome/Data/Scratch.hs 
@@ -1,13 +0,0 @@-module Ribosome.Data.Scratch where--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/ScratchId.hs view
@@ -0,0 +1,11 @@+-- |The ID type used to store active scratch buffers.+module Ribosome.Data.ScratchId where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |The ID type used to store active scratch buffers.+newtype ScratchId =+  ScratchId { unScratchId :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackDecode, MsgpackEncode)
lib/Ribosome/Data/ScratchOptions.hs view
@@ -1,39 +1,67 @@+-- |Scratch buffer configuration. module Ribosome.Data.ScratchOptions where -import Data.Default (Default(def))-+import Ribosome.Data.FloatOptions (FloatOptions) import Ribosome.Data.Mapping (Mapping)+import Ribosome.Data.ScratchId (ScratchId) import Ribosome.Data.Syntax (Syntax) +-- |Configure the visual properties of a scratch buffer.+-- If the option @float@ is specified, the buffer will be opened in a floating window. data ScratchOptions =   ScratchOptions {+    -- |Whether to open the buffer in a new tab.     tab :: Bool,+    -- |Whether to split the current window vertically, only relevant for non-floating windows.     vertical :: Bool,+    -- |Whether to set the @wrap@ option in the window, to disable breaking long lines.     wrap :: Bool,+    -- |Whether to move the cursor to the window after opening it.     focus :: Bool,+    -- |Whether to adapt the buffer's size to the number of lines, for horizontal splits.     resize :: Bool,+    -- |Whether to place the window at the bottom of the stack, only relevant for non-floating windows.     bottom :: Bool,+    -- |Whether to set the @modifiable@ option for the buffer.+    modify :: Bool,+    -- |If 'Just', creates a floating window with the given config.+    float :: Maybe FloatOptions,+    -- |The initial size of the window.     size :: Maybe Int,+    -- |When resizing automatically, do not exceed this size.     maxSize :: Maybe Int,+    -- |A set of syntax rules to apply to the buffer.     syntax :: [Syntax],+    -- |A set of key mappings to define buffer-locally. See [Ribosome.Mappings]("Ribosome#mappings").     mappings :: [Mapping],-    name :: Text+    -- |The value for the @filetype@ option.+    filetype :: Maybe Text,+    -- |The ID of the scratch buffer.+    name :: ScratchId   }+  deriving stock (Eq, Show, Generic) -defaultScratchOptions :: Text -> ScratchOptions-defaultScratchOptions = ScratchOptions False False False False True True Nothing Nothing [] []+-- |The default configuration, setting all flags to 'False' except for 'resize' and 'bottom', and everything else to+-- 'mempty'.+scratch :: ScratchId -> ScratchOptions+scratch name =+  ScratchOptions {+      tab = False,+      vertical = False,+      wrap = False,+      focus = False,+      resize = True,+      bottom = True,+      modify = False,+      float = Nothing,+      size = Nothing,+      maxSize = Nothing,+      syntax = [],+      mappings = [],+      filetype = 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 }+  def =+    scratch "scratch"
+ lib/Ribosome/Data/ScratchState.hs view
@@ -0,0 +1,28 @@+-- |Scratch buffer state.+module Ribosome.Data.ScratchState where++import Ribosome.Data.ScratchId (ScratchId)+import Ribosome.Data.ScratchOptions (ScratchOptions)+import Ribosome.Host.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Host.Data.RpcType (AutocmdId)++-- |The configuration and Neovim resources that define a scratch buffer and describe its previously recorded UI state.+data ScratchState =+  ScratchState {+    -- |The scratch buffer's ID stored in the state.+    id :: ScratchId,+    -- |The configuration used to create the scratch buffer.+    options :: ScratchOptions,+    -- |The Neovim buffer handle that was returned when it was last updated.+    buffer :: Buffer,+    -- |The Neovim window handle that was returned when it was last updated.+    window :: Window,+    -- |The Neovim window handle that denotes the window that was active when the scratch buffer was created.+    previous :: Window,+    -- |The Neovim tabpage handle that was returned when it was last updated, if a tab was requested by the+    -- configuration.+    tab :: Maybe Tabpage,+    -- |The ID of the autocmd that fires when the user deletes the scratch buffer.+    autocmdId :: AutocmdId+  }+  deriving stock (Eq, Show, Generic)
lib/Ribosome/Data/Setting.hs view
@@ -1,8 +1,15 @@+-- |Data type abstracting a Neovim variable with a default value. module Ribosome.Data.Setting where +-- |This type is used by the effect 'Ribosome.Settings', representing a Neovim variable associated with a plugin.+--+-- It has a name, can optionally prefixed by the plugin's name and may define a default value that is used when the+-- variable is undefined.+--+-- The type parameter determines how the Neovim value is decoded. data Setting a =   Setting {-    name :: Text,+    key :: Text,     prefix :: Bool,     fallback :: Maybe a   }
lib/Ribosome/Data/SettingError.hs view
@@ -1,25 +1,29 @@-{-# LANGUAGE TemplateHaskell #-}-+-- |Error for 'Ribosome.Settings'. 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 Exon (exon)+import Log (Severity (Error)) -import Ribosome.Data.ErrorReport (ErrorReport(..))-import Ribosome.Error.Report.Class (ReportError(..))+import Ribosome.Host.Data.Report (Report (Report), Reportable (toReport))+import Ribosome.Host.Data.RpcError (RpcError, rpcError) +-- |The errors emitted by the effect 'Ribosome.Settings'. data SettingError =-  Decode Text (Doc AnsiStyle)-  |+  -- |The variable is unset and has no associated default.   Unset Text-  deriving Show--deepPrisms ''SettingError+  |+  -- |The variable contains data that is incompatible with the type parameter of the 'Ribosome.Setting'.+  Decode Text Text+  |+  -- |Something went wrong while attempting to set a variable.+  UpdateFailed Text RpcError+  deriving stock (Eq, Show) -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+instance Reportable SettingError where+  toReport = \case+    Unset key ->+      Report [exon|Mandatory setting '#{key}' is unset|] ["SettingError.Unset:", key] Error+    Decode key msg ->+      Report [exon|Setting '#{key}' has invalid value: #{msg}|] ["SettingError.Decode:", key, msg] Error+    UpdateFailed key err ->+      Report [exon|Failed to update setting '#{key}': #{rpcError err}|] ["SettingError.UpdateFailed:", key, show err] Error
− lib/Ribosome/Data/String.hs 
@@ -1,11 +0,0 @@-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
@@ -1,11 +1,7 @@-{-# LANGUAGE DeriveAnyClass #-}-+-- |Data types for the Neovim syntax API. module Ribosome.Data.Syntax where -import Data.Default (Default(def))-import Data.Map (Map)-import qualified Data.Map as Map (fromList)-+-- |Different kinds of syntax items. data SyntaxItemDetail =   Keyword {     kwGroup :: Text,@@ -30,62 +26,39 @@   Verbatim {     verbatimCommand :: Text   }-  deriving (Eq, Show)+  deriving stock (Eq, Show) +-- |A syntax item like @keyword@ or @match@, bundled with options for the @:syntax@ command. 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+  deriving stock (Eq, Show) +-- |Options for a highlight group. data Highlight =   Highlight {     hiGroup :: Text,     hiValues :: Map Text Text   }-  deriving (Eq, Show)--syntaxHighlight :: Text -> [(Text, Text)] -> Highlight-syntaxHighlight group' =-  Highlight group' . Map.fromList+  deriving stock (Eq, Show) +-- |Options for a @:highlight link@ command. data HiLink =   HiLink {     hlGroup :: Text,     hlTarget :: Text   }-  deriving (Eq, Show)+  deriving stock (Eq, Show) +-- |A set of syntax settings, consisting of syntax items like @keyword@ and @match@, highlights and highlight links. data Syntax =   Syntax {      syntaxItems :: [SyntaxItem],      syntaxHighlights :: [Highlight],      syntaxHiLinks :: [HiLink]   }-  deriving (Eq, Show, Generic, Default)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)
− lib/Ribosome/Data/Text.hs 
@@ -1,17 +0,0 @@-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/WindowConfig.hs view
@@ -0,0 +1,15 @@+-- |Codec data type for @vim_get_windows@.+module Ribosome.Data.WindowConfig where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |Codec data type for @vim_get_windows@.+data WindowConfig =+  WindowConfig {+     relative :: Text,+     focusable :: Bool,+     external :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackEncode, MsgpackDecode)
+ lib/Ribosome/Data/WindowView.hs view
@@ -0,0 +1,35 @@+-- |Codec data type for @winsaveview@.+module Ribosome.Data.WindowView where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |Codec data type for @winsaveview@.+data WindowView =+  WindowView {+    lnum :: Int,+    topline :: Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackEncode, MsgpackDecode)++-- |Codec data type for @winrestview@.+data PartialWindowView =+  PartialWindowView {+    lnum :: Maybe Int,+    topline :: Maybe Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackEncode, MsgpackDecode)++-- |Convert between the return type of @winsaveview@ and the parameter type of @winrestview@.+class AsPartialWindowView a where+  asPartialWindowView :: a -> PartialWindowView++instance AsPartialWindowView WindowView where+  asPartialWindowView (WindowView l t) =+    PartialWindowView (Just l) (Just t)++instance AsPartialWindowView PartialWindowView where+  asPartialWindowView =+    id
+ lib/Ribosome/Effect/Persist.hs view
@@ -0,0 +1,90 @@+-- |Persisting data across vim sessions+module Ribosome.Effect.Persist where++import Path (File, Path, Rel)++-- |This effect abstracts storing data of type @a@ in the file system to allow loading it when a plugin starts.+--+-- Each distinct type corresponds to a separate copy of this effect. When the same type should be stored in separate+-- files for different components of the plugin, use 'Tagged'.+-- The subdirectory or file name used for a type is specified to the interpreter.+-- If the constructor 'store' is called with 'Just' a file name, each value is stored in a separate file, otherwise the+-- same file is overwritten on every call to 'store'.+--+-- The default interpreter delegates file path resolution to the effect 'Ribosome.Persist.PersistPath' and uses JSON to+-- codec the data.+data Persist a :: Effect where+  -- |Store a value in the persistence file or, if the first argument is 'Just', in that file in the persistence+  -- directory.+  Store :: Maybe (Path Rel File) -> a -> Persist a m ()+  -- |Load a value from the persistence file or, if the first argument is 'Just', from that file in the persistence+  -- directory.+  -- Returns 'Nothing' if the file doesn't exist.+  Load :: Maybe (Path Rel File) -> Persist a m (Maybe a)++makeSem_ ''Persist++-- |Store a value in the persistence file or, if the first argument is 'Just', in that file in the persistence+-- directory.+store ::+  ∀ a r .+  Member (Persist a) r =>+  Maybe (Path Rel File) ->+  a ->+  Sem r ()++-- |Load a value from the persistence file or, if the first argument is 'Just', from that file in the persistence+-- directory.+-- Returns 'Nothing' if the file doesn't exist.+load ::+  ∀ a r .+  Member (Persist a) r =>+  Maybe (Path Rel File) ->+  Sem r (Maybe a)++-- |Load a value from the persistence file or, if the first argument is 'Just', from that file in the persistence+-- directory.+-- Returns the fallback value if the file doesn't exist.+loadOr ::+  Member (Persist a) r =>+  Maybe (Path Rel File) ->+  a ->+  Sem r a+loadOr path a =+  fromMaybe a <$> load path++-- |Load a value from the persistence file.+-- Returns 'Nothing' if the file doesn't exist.+loadSingle ::+  Member (Persist a) r =>+  Sem r (Maybe a)+loadSingle =+  load Nothing++-- |Load a value from the persistence file.+-- Returns the fallback value if the file doesn't exist.+loadSingleOr ::+  Member (Persist a) r =>+  a ->+  Sem r a+loadSingleOr a =+  fromMaybe a <$> loadSingle++-- |Load a value from the specified file in the persistence directory.+-- Returns 'Nothing' if the file doesn't exist.+loadPath ::+  Member (Persist a) r =>+  Path Rel File ->+  Sem r (Maybe a)+loadPath path =+  load (Just path)++-- |Load a value from the specified file in the persistence directory.+-- Returns the fallback value if the file doesn't exist.+loadPathOr ::+  Member (Persist a) r =>+  Path Rel File ->+  a ->+  Sem r a+loadPathOr path a =+  fromMaybe a <$> loadPath path
+ lib/Ribosome/Effect/PersistPath.hs view
@@ -0,0 +1,41 @@+-- |Provide paths for 'Ribosome.Persist'+module Ribosome.Effect.PersistPath where++import Path (Abs, Dir, Path, Rel)++import Ribosome.Data.Setting (Setting (Setting))++-- |This is a utility effect for 'Ribosome.Persist', determining the root directory for persistence files.+data PersistPath :: Effect where+  -- |Return the root if 'Nothing' is given, or the subdir of the root if 'Just' is given.+  PersistPath :: Maybe (Path Rel Dir) -> PersistPath m (Path Abs Dir)++makeSem_ ''PersistPath++-- |Return the root if 'Nothing' is given, or the subdir of the root if 'Just' is given.+persistPath ::+  ∀ r .+  Member PersistPath r =>+  Maybe (Path Rel Dir) ->+  Sem r (Path Abs Dir)++-- |This setting may be used to specify the root directory for all plugins.+-- The default is to use the XDG cache dir.+setting :: Setting (Path Abs Dir)+setting =+  Setting "ribosome_persistence_dir" False Nothing++-- |Get the root directory for persistence files.+persistRoot ::+  Member PersistPath r =>+  Sem r (Path Abs Dir)+persistRoot =+  persistPath Nothing++-- |Get a subdir of the root directory for persistence files.+persistSubPath ::+  Member PersistPath r =>+  Path Rel Dir ->+  Sem r (Path Abs Dir)+persistSubPath p =+  persistPath (Just p)
+ lib/Ribosome/Effect/Scratch.hs view
@@ -0,0 +1,34 @@+{-# options_haddock prune #-}++-- |Scratch buffers+module Ribosome.Effect.Scratch where++import Prelude hiding (show)++import Ribosome.Data.ScratchId (ScratchId)+import Ribosome.Data.ScratchOptions (ScratchOptions)+import Ribosome.Data.ScratchState (ScratchState)++-- |This effect manages scratch buffers, that is, transient buffers displaying text not associated with a file.+-- See 'ScratchOptions' for configuration.+data Scratch :: Effect where+  -- |Open a new scratch buffer and set its content to the supplied text.+  Show :: Foldable t => t Text -> ScratchOptions -> Scratch m ScratchState+  -- |Find a previously defined scratch buffer, ensure it is open and set its content to the supplied text.+  Update :: Foldable t => ScratchId -> t Text -> Scratch m ScratchState+  -- |Close a scratch buffer.+  Delete :: ScratchId -> Scratch m ()+  -- |Return the state of all currently managed scratch buffers.+  Get :: Scratch m [ScratchState]+  -- |Look up a scratch buffer by its ID.+  Find :: ScratchId -> Scratch m (Maybe ScratchState)++makeSem ''Scratch++-- |Create an empty scratch buffer.+open ::+  Member Scratch r =>+  ScratchOptions ->+  Sem r ScratchState+open =+  show @_ @[] mempty
+ lib/Ribosome/Effect/Settings.hs view
@@ -0,0 +1,56 @@+-- |The effect 'Settings' abstracts Neovim variables+module Ribosome.Effect.Settings where++import Prelude hiding (get)++import Ribosome.Data.Setting (Setting)+import Ribosome.Data.SettingError (SettingError)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |This effects abstracts Neovim variables with associated defaults.+data Settings :: Effect where+  -- |Get the value of the setting's Neovim variable or return the default if it is undefined.+  Get :: MsgpackDecode a => Setting a -> Settings m a+  -- |Set the value of the setting's Neovim variable.+  Update :: MsgpackEncode a => Setting a -> a -> Settings m ()++makeSem_ ''Settings++-- |Get the value of the setting's Neovim variable or return the default if it is undefined.+get ::+  ∀ a r .+  MsgpackDecode a =>+  Member Settings r =>+  Setting a ->+  Sem r a++-- |Set the value of the setting's Neovim variable.+update ::+  ∀ a r .+  MsgpackEncode a =>+  Member Settings r =>+  Setting a ->+  a ->+  Sem r ()++-- |Get the setting's value or return the supplied fallback value if the Neovim variable is undefined and the setting+-- has no default value.+or ::+  MsgpackDecode a =>+  Member (Settings !! SettingError) r =>+  a ->+  Setting a ->+  Sem r a+or a s =+  a <! get s++-- |Get 'Just' the setting's value or return 'Nothing' if the Neovim variable is undefined and the setting has no+-- default value.+maybe ::+  MsgpackDecode a =>+  Member (Settings !! SettingError) r =>+  Setting a ->+  Sem r (Maybe a)+maybe s =+  Nothing <! (Just <$> get s)
+ lib/Ribosome/Effect/VariableWatcher.hs view
@@ -0,0 +1,28 @@+-- |An effect used internally to execute handlers when Neovim variables are changed.+module Ribosome.Effect.VariableWatcher where++-- |The name of a variable that Ribosome should watch for changes.+newtype WatchedVariable =+  WatchedVariable { unWatchedVariable :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)++-- |An effect used internally to execute handlers when Neovim variables are changed.+data VariableWatcher :: Effect where+  -- |Called when the internal logic determines that variables should be examined for updates.+  Update :: VariableWatcher m ()+  -- |Stop running update handlers for the given variable.+  Unwatch :: WatchedVariable -> VariableWatcher m ()++makeSem_ ''VariableWatcher++-- |Called when the internal logic determines that variables should be examined for updates.+update ::+  Member VariableWatcher r =>+  Sem r ()++-- |Stop running update handlers for the given variable.+unwatch ::+  Member VariableWatcher r =>+  WatchedVariable ->+  Sem r ()
+ lib/Ribosome/Embed.hs view
@@ -0,0 +1,138 @@+{-# options_haddock prune #-}++-- |Main function combinators for embedding Neovim+module Ribosome.Embed where++import Ribosome.Data.PluginConfig (PluginConfig)+import Ribosome.Data.PluginName (PluginName)+import Ribosome.Host.Data.BootError (BootError)+import Ribosome.Host.Data.HostConfig (LogConfig)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Embed (EmbedExtra, interpretEmbedExtra)+import Ribosome.Host.IOStack (IOStack)+import Ribosome.Host.Interpret (HigherOrder)+import Ribosome.Host.Interpreter.Handlers (interpretHandlersNull, withHandlers)+import Ribosome.Host.Interpreter.Host (HostDeps, withHost)+import Ribosome.Host.Interpreter.Process.Embed (interpretProcessCerealNvimEmbed)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)+import Ribosome.IOStack (BasicPluginStack, runCli)+import Ribosome.Interpreter.Scratch (interpretScratch)+import Ribosome.Interpreter.Settings (interpretSettingsRpc)+import Ribosome.Interpreter.UserError (interpretUserErrorPrefixed)+import Ribosome.Interpreter.VariableWatcher (interpretVariableWatcherNull)+import Ribosome.Plugin.Builtin (BuiltinHandlersDeps, interceptHandlersBuiltin)+import Ribosome.Run (PluginEffects)++type HandlerEffects =+  PluginEffects ++ RpcStack ++ EmbedExtra ++ RpcDeps++-- |The complete stack for an embedded plugin test.+type EmbedStack c =+  HandlerEffects ++ BasicPluginStack c++interpretRpcDeps ::+  Members [Reader PluginName, Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  InterpretersFor RpcDeps r+interpretRpcDeps =+  interpretUserErrorPrefixed .+  interpretProcessCerealNvimEmbed Nothing Nothing++-- |Run the internal stack for an embedded Neovim test, without IO effects.+interpretPluginEmbed ::+  Members [Log, Reader LogConfig, Reader PluginName] r =>+  Members IOStack r =>+  InterpretersFor HandlerEffects r+interpretPluginEmbed =+  interpretRpcDeps .+  interpretEmbedExtra .+  interpretRpcStack .+  interpretHandlersNull .+  interpretVariableWatcherNull .+  interpretSettingsRpc .+  interpretScratch++-- |Fork the main loop for a plugin connected to an embedded Neovim.+embedPlugin ::+  Members (HostDeps er) r =>+  Members BuiltinHandlersDeps r =>+  Sem r a ->+  Sem r a+embedPlugin =+  interceptHandlersBuiltin .+  withHost .+  insertAt @0++-- |Run an embedded Neovim, plugin internals and IO effects, reading options from the CLI.+--+-- Like 'runEmbedStack', but allows the CLI option parser to be specified.+runEmbedStackCli ::+  PluginConfig c ->+  Sem (EmbedStack c) () ->+  IO ()+runEmbedStackCli conf =+  runCli conf . interpretPluginEmbed++-- |Run an embedded Neovim, plugin internals and IO effects, reading options from the CLI.+runEmbedStack ::+  PluginConfig () ->+  Sem (EmbedStack ()) () ->+  IO ()+runEmbedStack conf =+  runCli conf . interpretPluginEmbed++-- |Run a 'Sem' in an embedded plugin context by starting a Neovim subprocess, forking the Ribosome main loop and+-- registering the supplied handlers, using the supplied custom effect stack.+--+-- Like 'runEmbedPluginIO', but allows the 'PluginConfig' to contain a CLI parser for an arbitrary type @c@ that is then+-- provided in a @'Reader' c@ to the plugin.+--+-- This is separate from 'runEmbedPluginIO' because it requires a type hint when using @OverloadedStrings@ or 'def' to+-- construct the config without an option parser.+runEmbedPluginCli ::+  HigherOrder r (EmbedStack c) =>+  PluginConfig c ->+  InterpretersFor r (EmbedStack c) ->+  [RpcHandler (r ++ EmbedStack c)] ->+  Sem (r ++ EmbedStack c) () ->+  IO ()+runEmbedPluginCli conf effs handlers =+  runEmbedStackCli conf .+  effs .+  withHandlers handlers .+  embedPlugin++-- |Run a 'Sem' in an embedded plugin context by starting a Neovim subprocess, forking the Ribosome main loop and+-- registering the supplied handlers, using the supplied custom effect stack.+--+-- This is a basic version of what+-- [ribosome-test](https://hackage.haskell.org/package/ribosome-test/docs/Ribosome-Test.html) provides, which uses+-- [polysemy-test](https://hackage.haskell.org/package/polysemy-test/docs/Polysemy-Test.html) and+-- [hedgehog](https://hackage.haskell.org/package/hedgehog) for a comprehensive testing framework.+--+-- The parameters have the same meaning as for [remote plugins]("Ribosome#execution").+runEmbedPluginIO ::+  HigherOrder r (EmbedStack ()) =>+  PluginConfig () ->+  InterpretersFor r (EmbedStack ()) ->+  [RpcHandler (r ++ EmbedStack ())] ->+  Sem (r ++ EmbedStack ()) () ->+  IO ()+runEmbedPluginIO conf effs handlers =+  runEmbedStack conf .+  effs .+  withHandlers handlers .+  embedPlugin++-- |Run a 'Sem' in an embedded plugin context by starting a Neovim subprocess, forking the Ribosome main loop and+-- registering the supplied handlers.+--+-- Like 'runEmbedPluginIO', but without extra effects.+runEmbedPluginIO_ ::+  PluginConfig () ->+  [RpcHandler (EmbedStack ())] ->+  Sem (EmbedStack ()) () ->+  IO ()+runEmbedPluginIO_ conf handlers =+  runEmbedStack conf .+  withHandlers handlers .+  embedPlugin
− lib/Ribosome/Error/Report.hs 
@@ -1,124 +0,0 @@-module Ribosome.Error.Report where--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 (line, pretty, (<>))-import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc)-import System.Log (Priority(NOTICE))--import Ribosome.Api.Echo (echom)-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 (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 -> Text -> ErrorReport -> Errors -> Errors-storeError' time name report (Errors errors) =-  Errors (Map.alter alter (ComponentName name) errors)-  where-    err = Error time report-    alter Nothing = Just [err]-    alter (Just current) = Just (err:current)--storeError :: (MonadRibo m, MonadIO m) => Text -> ErrorReport -> m ()-storeError name e = do-  time <- epochSeconds-  Ribo.modifyErrors $ storeError' time name e--logErrorReport ::-  (MonadRibo m, NvimE e m, MonadIO m) =>-  ErrorReport ->-  m ()-logErrorReport (ErrorReport user logMsgs prio) = do-  name <- Ribo.pluginName-  liftIO $ traverse_ (logAs prio name) logMsgs-  when (prio >= NOTICE) (echom user)--processErrorReport ::-  (MonadRibo m, NvimE e m, MonadIO m) =>-  Text ->-  ErrorReport ->-  m ()-processErrorReport name report = do-  storeError name report-  logErrorReport report--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 ::-  (MonadRibo m, NvimE e m, MonadIO m, ReportError e) =>-  Text ->-  (a -> m ()) ->-  Either e a ->-  m ()-reportErrorOr name =-  either $ reportError name--reportErrorOr_ ::-  (MonadError RpcError m, MonadRibo m, NvimE e m, MonadIO m, ReportError e) =>-  Text ->-  m () ->-  Either e a ->-  m ()-reportErrorOr_ name =-  reportErrorOr name . const--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)--runRiboReport ::-  ∀ e s.-  ReportError e =>-  Text ->-  Ribo s e () ->-  RNeovim s ()-runRiboReport componentName =-  reportError' componentName <=< runRibo
− lib/Ribosome/Error/Report/Class.hs 
@@ -1,59 +0,0 @@-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/Examples/Example1.hs view
@@ -0,0 +1,21 @@+{-# options_haddock prune, hide #-}++-- |An example for the docs.+module Ribosome.Examples.Example1 where++import Ribosome+import Ribosome.Api++count ::+  Member (Rpc !! RpcError) r =>+  Int ->+  Handler r Int+count n = do+  s <- 0 <! nvimGetVar "counter"+  let s' = s + n+  ignoreRpcError (nvimSetVar "counter" s')+  pure s'++main :: IO ()+main =+  runNvimPluginIO_ "counter" [rpcFunction "Count" Sync count]
+ lib/Ribosome/Examples/Example2.hs view
@@ -0,0 +1,20 @@+{-# options_haddock prune, hide #-}++-- |An example for the docs.+module Ribosome.Examples.Example2 where++import Data.MessagePack (Object)++import Ribosome+import Ribosome.Api++changed ::+  Members NvimPlugin r =>+  Object ->+  Handler r ()+changed value =+  ignoreRpcError (echo ("Update value to: " <> show value))++main :: IO ()+main =+  runRemoteStack "watch-plugin" (watchVariables [("trigger", changed)] remotePlugin)
+ lib/Ribosome/Examples/Example3.hs view
@@ -0,0 +1,19 @@+{-# options_haddock prune, hide #-}++-- |An example for the docs.+module Ribosome.Examples.Example3 where++import qualified Data.Text.IO as Text++import Ribosome+import Ribosome.Api++ping :: Handler r Text+ping =+  pure "Ping"++main :: IO ()+main =+  runEmbedPluginIO_ "ping-plugin" [rpcFunction "Ping" Sync ping] do+    ignoreRpcError do+      embed . Text.putStrLn =<< nvimCallFunction "Ping" []
− lib/Ribosome/File.hs 
@@ -1,23 +0,0 @@-module Ribosome.File(-  canonicalPathWithHome,-  canonicalPath,-  canonicalPaths,-) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.String.Utils (replace)-import System.Directory (canonicalizePath, getHomeDirectory)--canonicalPathWithHome :: FilePath -> FilePath -> FilePath-canonicalPathWithHome = replace "~"--canonicalPath :: MonadIO m => FilePath -> m FilePath-canonicalPath path = do-  home <- liftIO getHomeDirectory-  return $ canonicalPathWithHome home path--canonicalPaths :: MonadIO m => [FilePath] -> m [FilePath]-canonicalPaths paths = do-  home <- liftIO getHomeDirectory-  let withHome = fmap (canonicalPathWithHome home) paths-  liftIO $ mapM canonicalizePath withHome
+ lib/Ribosome/Final.hs view
@@ -0,0 +1,31 @@+{-# options_haddock prune, hide #-}++-- |Combinators for using 'Final', used internally.+module Ribosome.Final where++import Polysemy.Final (withWeavingToFinal)++inFinal ::+  ∀ r a .+  Member (Final IO) r =>+  (∀ f . Functor f => f () -> (∀ x . Sem r x -> IO (f x)) -> (∀ x . x -> IO (f x)) -> (∀ x . f x -> Maybe x) -> IO (f a)) ->+  Sem r a+inFinal f =+  withWeavingToFinal \ s wv ex ->+    f s (\ ma -> wv (ma <$ s)) (\ a -> pure (a <$ s)) ex++inFinal_ ::+  ∀ r a .+  Member (Final IO) r =>+  (∀ f . Functor f => (∀ x . Sem r x -> IO (Maybe x)) -> (Sem r () -> IO ()) -> (∀ x . x -> IO (f x)) -> IO (f a)) ->+  Sem r a+inFinal_ f =+  withWeavingToFinal \ s wv ex ->+    let+      lowerMaybe :: ∀ x . Sem r x -> IO (Maybe x)+      lowerMaybe sem =+        ex <$> wv (sem <$ s)+      lowerUnit :: ∀ x . Sem r x -> IO ()+      lowerUnit =+        fmap (fromMaybe ()) . lowerMaybe . void+    in f lowerMaybe lowerUnit (\ a -> pure (a <$ s))
+ lib/Ribosome/Float.hs view
@@ -0,0 +1,13 @@+-- |Data types for floating window configuration.+module Ribosome.Float (+  module Ribosome.Data.FloatOptions+) where++import Ribosome.Data.FloatOptions (+  FloatAnchor (..),+  FloatBorder (..),+  FloatOptions (..),+  FloatRelative (..),+  FloatStyle (..),+  FloatZindex (..),+  )
+ lib/Ribosome/IOStack.hs view
@@ -0,0 +1,37 @@+-- |Interpreters for basic plugin effects down to 'IO'+module Ribosome.IOStack where++import Ribosome.Cli (withCli)+import Ribosome.Data.CustomConfig (CustomConfig (CustomConfig))+import Ribosome.Data.PluginConfig (PluginConfig (PluginConfig))+import Ribosome.Data.PluginName (PluginName)+import Ribosome.Host.Data.HostConfig (HostConfig)+import Ribosome.Host.IOStack (BasicStack, runBasicStack)++-- |The effects that are shared by all variants (like embedded, remote, socket) of main functions.+--+-- Contains logging effects, IO related stuff and the plugin's name in a 'Reader'.+type BasicPluginStack c =+  Reader PluginName : Reader (CustomConfig c) : BasicStack++-- |Execute the basic plugin stack all the way to an 'IO', given the plugin name and logging settings.+runBasicPluginStack ::+  PluginName ->+  HostConfig ->+  c ->+  Sem (BasicPluginStack c) () ->+  IO ()+runBasicPluginStack name conf custom =+  runBasicStack conf .+  runReader (CustomConfig custom) .+  runReader name++-- |Execute the basic plugin stack all the way to an 'IO' like 'runBasicPluginStack', reading config overrides from+-- command line options.+runCli ::+  PluginConfig c ->+  Sem (BasicPluginStack c) () ->+  IO ()+runCli (PluginConfig name defaultConf customParser) prog =+  withCli name defaultConf customParser \ conf custom ->+    runBasicPluginStack name conf custom prog
− lib/Ribosome/Internal/IO.hs 
@@ -1,24 +0,0 @@-module Ribosome.Internal.IO(-  retypeNeovim,-  forkNeovim,-) where--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 (Config(..), Neovim(..), retypeConfig, runNeovim)--retypeNeovim :: (e0 -> e1) -> Neovim e1 a -> Neovim e0 a-retypeNeovim transform thunk = do-  env <- Neovim ask-  liftIO $ runReaderT (withReaderT (newEnv env) $ runResourceT $ unNeovim thunk) env-  where-    newEnv = retypeConfig . transform . customConfig--forkNeovim :: Neovim e () -> Neovim e ()-forkNeovim thunk = do-  env <- Neovim ask-  _ <- liftIO $ forkIO $ void $ runNeovim env thunk-  return ()
− lib/Ribosome/Internal/NvimObject.hs 
@@ -1,23 +0,0 @@-module Ribosome.Internal.NvimObject where--import Data.Map (Map, (!?))-import Data.Text.Prettyprint.Doc (pretty, (<+>))-import Neovim (AnsiStyle, Doc, NvimObject, Object(ObjectString), fromObject)--deriveString :: (Text -> a) -> Object -> Either (Doc AnsiStyle) a-deriveString cons o = fmap cons (fromObject o :: Either (Doc AnsiStyle) Text)--objectKeyMissing :: Text -> Maybe Object -> Either (Doc AnsiStyle) Object-objectKeyMissing _ (Just o) = Right o-objectKeyMissing key Nothing = Left (pretty ("missing key in nvim data:" :: Text) <+> pretty key)--extractObject :: NvimObject o => Text -> Map Object Object -> Either (Doc AnsiStyle) o-extractObject key data' = do-  value <- objectKeyMissing key $ data' !? (ObjectString . encodeUtf8) key-  fromObject value--extractObjectOr :: NvimObject o => Text -> o -> Map Object Object -> o-extractObjectOr key default' data' =-  case extractObject key data' of-    Right a -> a-    Left _ -> default'
+ lib/Ribosome/Internal/Path.hs view
@@ -0,0 +1,17 @@+{-# options_haddock prune, hide #-}++-- |Internal combinators for paths.+module Ribosome.Internal.Path where++import Exon (exon)++import Ribosome.Host.Data.Report (Report)++failInvalidPath ::+  Member (Stop Report) r =>+  Text ->+  Maybe a ->+  Sem r a+failInvalidPath spec result =+  withFrozenCallStack do+    stopNote (fromText [exon|Invalid path: #{spec}|]) result
+ lib/Ribosome/Internal/Scratch.hs view
@@ -0,0 +1,334 @@+{-# options_haddock prune #-}++-- |Internal logic for 'Ribosome.Scratch'.+module Ribosome.Internal.Scratch where++import qualified Data.Map.Strict as Map+import Data.MessagePack (Object)+import Exon (exon)+import qualified Polysemy.Log as Log+import Prelude hiding (group)++import Ribosome.Api.Autocmd (bufferAutocmd, eventignore)+import Ribosome.Api.Buffer (setBufferContent, wipeBuffer)+import Ribosome.Api.Syntax (executeWindowSyntax)+import Ribosome.Api.Tabpage (closeTabpage)+import Ribosome.Api.Window (closeWindow)+import Ribosome.Data.FloatOptions (FloatOptions, enter)+import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Data.ScratchId (ScratchId (ScratchId, unScratchId))+import Ribosome.Data.ScratchOptions (ScratchOptions (ScratchOptions, filetype, name), focus, mappings, syntax)+import qualified Ribosome.Data.ScratchState as ScratchState+import Ribosome.Data.ScratchState (ScratchState (ScratchState))+import Ribosome.Host.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Host.Api.Effect (+  bufferGetName,+  bufferSetName,+  bufferSetOption,+  nvimBufIsLoaded,+  nvimCreateBuf,+  nvimDelAutocmd,+  nvimOpenWin,+  vimCommand,+  vimGetCurrentBuffer,+  vimGetCurrentTabpage,+  vimGetCurrentWindow,+  vimSetCurrentWindow,+  windowGetBuffer,+  windowIsValid,+  windowSetHeight,+  windowSetOption,+  windowSetWidth,+  )+import Ribosome.Host.Class.Msgpack.Decode (fromMsgpack)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcType (AutocmdId (AutocmdId), group)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Mapping (activateBufferMapping)+import Ribosome.PluginName (pluginNamePascalCase)++createScratchTab :: Member Rpc r => Sem r Tabpage+createScratchTab = do+  vimCommand "tabnew"+  vimGetCurrentTabpage++createRegularWindow ::+  Member Rpc r =>+  Bool ->+  Bool ->+  Maybe Int ->+  Sem r (Buffer, Window)+createRegularWindow vertical bottom size = do+  vimCommand prefixedCmd+  buf <- vimGetCurrentBuffer+  win <- vimGetCurrentWindow+  pure (buf, win)+  where+    prefixedCmd = locationPrefix <> " " <> sizePrefix <> cmd+    cmd = if vertical then "vnew" else "new"+    sizePrefix = maybe "" show size+    locationPrefix = if bottom then "belowright" else "aboveleft"++floatConfig ::+  FloatOptions ->+  Map Text Object+floatConfig =+  fromRight Map.empty . fromMsgpack . toMsgpack++createFloatWith ::+  Member Rpc r =>+  Bool ->+  Bool ->+  FloatOptions ->+  Sem r (Buffer, Window)+createFloatWith listed scratch options = do+  buffer <- nvimCreateBuf listed scratch+  window <- nvimOpenWin buffer (enter options) (floatConfig options)+  pure (buffer, window)++createFloat ::+  Member Rpc r =>+  FloatOptions ->+  Sem r (Buffer, Window)+createFloat =+  createFloatWith True True++createScratchWindow ::+  Member Rpc r =>+  Bool ->+  Bool ->+  Bool ->+  Maybe FloatOptions ->+  Maybe Int ->+  Sem r (Buffer, Window)+createScratchWindow vertical wrap bottom float size = do+  (buffer, win) <- createWindow+  windowSetOption win "wrap" (toMsgpack wrap)+  windowSetOption win "number" (toMsgpack False)+  windowSetOption win "cursorline" (toMsgpack True)+  windowSetOption win "colorcolumn" (toMsgpack ("" :: Text))+  windowSetOption win "foldmethod" (toMsgpack ("manual" :: Text))+  windowSetOption win "conceallevel" (toMsgpack (2 :: Int))+  windowSetOption win "concealcursor" (toMsgpack ("nvic" :: Text))+  pure (buffer, win)+  where+    createWindow =+      maybe regular createFloat float+    regular =+      createRegularWindow vertical bottom size++createScratchUiInTab :: Member Rpc r => Sem r (Buffer, Window, Maybe Tabpage)+createScratchUiInTab = do+  tab <- createScratchTab+  win <- vimGetCurrentWindow+  buffer <- windowGetBuffer win+  pure (buffer, win, Just tab)++createScratchUi ::+  Member Rpc r =>+  ScratchOptions ->+  Sem r (Buffer, Window, Maybe Tabpage)+createScratchUi (ScratchOptions False vertical wrap _ _ bottom _ float size _ _ _ _ _) =+  uncurry (,,Nothing) <$> createScratchWindow vertical wrap bottom float size+createScratchUi _ =+  createScratchUiInTab++configureScratchBuffer ::+  Member Rpc r =>+  Buffer ->+  Maybe Text ->+  ScratchId ->+  Sem r ()+configureScratchBuffer buffer ft (ScratchId name) = do+  bufferSetOption buffer "bufhidden" ("wipe" :: Text)+  bufferSetOption buffer "buftype" ("nofile" :: Text)+  bufferSetOption buffer "swapfile" False+  traverse_ (bufferSetOption buffer "filetype") ft+  bufferSetName buffer name++setupScratchBuffer ::+  Members [Rpc, Log] r =>+  Window ->+  Buffer ->+  Maybe Text ->+  ScratchId ->+  Sem r Buffer+setupScratchBuffer window buffer ft name = do+  valid <- nvimBufIsLoaded buffer+  Log.debug [exon|#{if valid then "" else "in"}valid scratch buffer|]+  validBuffer <- if valid then pure buffer else windowGetBuffer window+  configureScratchBuffer validBuffer ft name+  pure validBuffer++setupDeleteAutocmd ::+  Members [Rpc, Reader PluginName] r =>+  ScratchId ->+  Buffer ->+  Sem r AutocmdId+setupDeleteAutocmd (ScratchId name) buffer = do+  PluginName pname <- pluginNamePascalCase+  bufferAutocmd buffer "BufDelete" def { group = Just "RibosomeScratch" } (deleteCall pname)+  where+    deleteCall pname =+      [exon|silent! call #{pname}DeleteScratch('#{name}')|]++setupScratchIn ::+  Members [Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log] r =>+  Buffer ->+  Window ->+  Window ->+  Maybe Tabpage ->+  ScratchOptions ->+  Sem r ScratchState+setupScratchIn buffer previous window tab options@(ScratchOptions {..}) = do+  validBuffer <- setupScratchBuffer window buffer filetype name+  traverse_ (executeWindowSyntax window) syntax+  traverse_ (activateBufferMapping validBuffer) mappings+  unless focus (vimSetCurrentWindow previous)+  auId <- setupDeleteAutocmd name validBuffer+  let scratch = ScratchState name options validBuffer window previous tab auId+  atomicModify' (Map.insert name scratch)+  pure scratch++createScratch ::+  Members [Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  ScratchOptions ->+  Sem r ScratchState+createScratch options = do+  Log.debug [exon|creating new scratch: #{show options}|]+  previous <- vimGetCurrentWindow+  (buffer, window, tab) <- eventignore (createScratchUi options)+  eventignore $ setupScratchIn buffer previous window tab options++bufferStillLoaded ::+  Members [Rpc !! RpcError, Rpc] r =>+  ScratchId ->+  Buffer ->+  Sem r Bool+bufferStillLoaded (ScratchId name) buffer =+  (&&) <$> loaded <*> loadedName+  where+    loaded =+      nvimBufIsLoaded buffer+    loadedName =+      resumeAs @RpcError False ((name ==) <$> bufferGetName buffer)++updateScratch ::+  Members [Rpc !! RpcError, Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  ScratchState ->+  ScratchOptions ->+  Sem r ScratchState+updateScratch oldScratch@(ScratchState name _ oldBuffer oldWindow _ _ _) options = do+  Log.debug [exon|updating existing scratch `#{coerce name}`|]+  ifM (windowIsValid oldWindow) attemptReuseWindow reset+  where+    attemptReuseWindow =+      ifM (bufferStillLoaded name oldBuffer) (pure oldScratch) closeAndReset+    closeAndReset =+      closeWindow oldWindow *> reset+    reset =+      createScratch options++lookupScratch ::+  Member (AtomicState (Map ScratchId ScratchState)) r =>+  ScratchId ->+  Sem r (Maybe ScratchState)+lookupScratch name =+  atomicGets (Map.lookup name)++ensureScratch ::+  Members [Rpc !! RpcError, Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  ScratchOptions ->+  Sem r ScratchState+ensureScratch options = do+  f <- maybe createScratch updateScratch <$> lookupScratch (options ^. #name)+  f options++withModifiable ::+  Member Rpc r =>+  Buffer ->+  ScratchOptions ->+  Sem r a ->+  Sem r a+withModifiable buffer options thunk =+  if isWrite then thunk else wrap+  where+    isWrite =+      options ^. #modify+    wrap =+      update True *> thunk <* update False+    update =+      bufferSetOption buffer "modifiable"++setScratchContent ::+  Foldable t =>+  Members [Rpc !! RpcError, Rpc] r =>+  ScratchState ->+  t Text ->+  Sem r ()+setScratchContent (ScratchState _ options buffer win _ _ _) lines' = do+  withModifiable buffer options $ setBufferContent buffer (toList lines')+  when (options ^. #resize) (resume_ @RpcError @Rpc (setSize win size))+  where+    size =+      max 1 calculateSize+    calculateSize =+      if vertical then fromMaybe 50 maxSize else min (length lines') (fromMaybe 30 maxSize)+    maxSize =+      options ^. #maxSize+    vertical =+      options ^. #vertical+    setSize =+      if vertical then windowSetWidth else windowSetHeight++showInScratch ::+  Foldable t =>+  Members [Rpc !! RpcError, Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  t Text ->+  ScratchOptions ->+  Sem r ScratchState+showInScratch lines' options = do+  scratch <- ensureScratch options+  scratch <$ setScratchContent scratch lines'++showInScratchDef ::+  Foldable t =>+  Members [Rpc !! RpcError, Rpc, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  t Text ->+  Sem r ScratchState+showInScratchDef lines' =+  showInScratch lines' def++killScratch ::+  Members [Rpc !! RpcError, AtomicState (Map ScratchId ScratchState), Log] r =>+  ScratchState ->+  Sem r ()+killScratch (ScratchState name _ buffer window _ tab (AutocmdId auId)) = do+  Log.debug [exon|Killing scratch buffer `#{unScratchId name}`|]+  atomicModify' (Map.delete @_ @ScratchState name)+  resume_ (nvimDelAutocmd auId)+  traverse_ (resume_ . closeTabpage) tab+  resume_ (closeWindow window)+  resume_ (wipeBuffer buffer)++scratchPreviousWindow ::+  Member (AtomicState (Map ScratchId ScratchState)) r =>+  ScratchId ->+  Sem r (Maybe Window)+scratchPreviousWindow =+  fmap (fmap ScratchState.previous) . lookupScratch++scratchWindow ::+  Member (AtomicState (Map ScratchId ScratchState)) r =>+  ScratchId ->+  Sem r (Maybe Window)+scratchWindow =+  fmap (fmap ScratchState.window) . lookupScratch++scratchBuffer ::+  Member (AtomicState (Map ScratchId ScratchState)) r =>+  ScratchId ->+  Sem r (Maybe Buffer)+scratchBuffer =+  fmap (fmap ScratchState.buffer) . lookupScratch
+ lib/Ribosome/Internal/Syntax.hs view
@@ -0,0 +1,69 @@+{-# options_haddock prune #-}++-- |Internal combinators for syntax.+module Ribosome.Internal.Syntax where++import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import Exon (exon)++import Ribosome.Data.Syntax (+  HiLink (HiLink),+  Highlight (Highlight),+  Syntax (Syntax),+  SyntaxItem (SyntaxItem),+  SyntaxItemDetail (Keyword, Match, Region, Verbatim),+  )+import qualified Ribosome.Host.Api.Data as Data+import Ribosome.Host.Data.RpcCall (RpcCall)++joinEquals :: Map Text Text -> Text+joinEquals =+  unwords . fmap equals . Map.toList+  where+    equals (a, b) =+      [exon|#{a}=#{b}|]++synPattern :: Text -> Text+synPattern pat =+  [exon|/#{pat}/|]++namedPattern :: Text -> Text -> Text -> Text+namedPattern param pat offset =+  [exon|#{param}=#{synPattern pat}#{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", "default", group', joinEquals values]++hilinkCmd :: HiLink -> [Text]+hilinkCmd (HiLink group' target) =+  ["highlight", "default", "link", group', target]++syntaxCmds :: Syntax -> [[Text]]+syntaxCmds (Syntax items highlights hilinks) =+  (syntaxItemCmd <$> items) <> (highlightCmd <$> highlights) <> (hilinkCmd <$> hilinks)++catCmd :: [Text] -> RpcCall ()+catCmd =+  Data.nvimCommand . Text.unwords++catCmds :: [[Text]] -> RpcCall ()+catCmds =+  foldMap catCmd
+ lib/Ribosome/Interpreter/Persist.hs view
@@ -0,0 +1,103 @@+-- |Interpreters for 'Persist'+module Ribosome.Interpreter.Persist where++import Data.Aeson (eitherDecodeFileStrict', encodeFile)+import Exon (exon)+import qualified Log+import Path (Abs, Dir, File, Path, Rel, parent, parseRelDir, parseRelFile, toFilePath, (</>))+import Path.IO (createDirIfMissing, doesFileExist)++import qualified Ribosome.Data.PersistError as PersistError+import Ribosome.Data.PersistError (PersistError)+import Ribosome.Data.PersistPathError (PersistPathError)+import qualified Ribosome.Effect.Persist as Persist+import Ribosome.Effect.Persist (Persist)+import Ribosome.Effect.PersistPath (PersistPath, persistRoot)+import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Interpret (with)+import Ribosome.Host.Path (pathText)++-- |Obtain the root directory or stop.+persistBase ::+  Members [PersistPath !! PersistPathError, Stop PersistError] r =>+  Sem r (Path Abs Dir)+persistBase =+  resumeHoist PersistError.Path persistRoot++-- |Load a file and JSON-decode it.+loadFile ::+  FromJSON a =>+  Members [Stop PersistError, Log, Embed IO] r =>+  Path Abs File ->+  Sem r a+loadFile file = do+  Log.debug [exon|Loading persistence file: #{show file}|]+  stopEitherWith decodeFailed =<< stopNote notReadable =<< tryMaybe (eitherDecodeFileStrict' (toFilePath file))+  where+    notReadable =+      PersistError.Permission (pathText file)+    decodeFailed =+      PersistError.Decode (pathText file) . toText++-- |Determine the path to use for a 'Persist' action.+-- If a @subpath@ is given, append it to @dir@, otherwise use @singleFile@.+-- Append the result of the first step to the root dir given by 'PersistPath'.+filepath ::+  Members [PersistPath !! PersistPathError, Stop PersistError] r =>+  Path Rel File ->+  Path Rel Dir ->+  Maybe (Path Rel File) ->+  Sem r (Path Abs File)+filepath singleFile dir subpath = do+  base <- persistBase+  pure (base </> maybe singleFile (dir </>) subpath)++-- |Interpret 'Persist' by writing to the file system.+--+-- Paths are determined as follows:+--+-- - 'PersistPath' defines the root directory for all 'Persist' effects, which might be specific to a plugin, or+-- additionally to entities like the currently edited project (e.g. by directory).+--+-- - The value in the @name@ argument is appended to the root depending on the arguments to the effect constructors.+--+-- - When 'Ribosome.Effect.Persist.store' or 'Ribosome.Effect.Persist.load' are invoked with 'Nothing' for the @subpath@+-- argument, a file named @<name>.json@ is used.+--+-- - When invoked with 'Just' a subpath, a file named @<name>/<subpath>.json@ is used.+--+-- This uses 'Resumable', see [Errors]("Ribosome#errors").+interpretPersist ::+  ToJSON a =>+  FromJSON a =>+  Members [PersistPath !! PersistPathError, Error BootError, Log, Embed IO] r =>+  Text ->+  InterpreterFor (Persist a !! PersistError) r+interpretPersist name =+  with parse \ (singleFile, dir) ->+    interpretResumable \case+      Persist.Store subpath a -> do+        path <- filepath singleFile dir subpath+        let base = parent path+        stopNote (PersistError.Permission (pathText base)) =<< tryMaybe (createDirIfMissing True base)+        embed (encodeFile (toFilePath path) a)+      Persist.Load subpath -> do+        path <- filepath singleFile dir subpath+        Log.debug [exon|Persistence path requested: #{show path}|]+        ifM (fromMaybe False <$> tryMaybe (doesFileExist path)) (loadFile path) (pure Nothing)+  where+    parse =+      note (BootError [exon|Invalid persist name: #{name}|]) namePaths+    namePaths =+      (,) <$> parseRelFile (toString [exon|#{name}.json|]) <*> parseRelDir (toString name)++-- |Interpret 'Persist' by storing nothing.+interpretPersistNull ::+  ∀ a err r .+  InterpreterFor (Persist a !! err) r+interpretPersistNull =+  interpretResumable \case+    Persist.Store _ _ ->+      unit+    Persist.Load _ ->+      pure Nothing
+ lib/Ribosome/Interpreter/PersistPath.hs view
@@ -0,0 +1,86 @@+-- |Interpreters for 'PersistPath'+module Ribosome.Interpreter.PersistPath where++import Path (Abs, Dir, Path, Rel, parseRelDir, (</>))+import Path.IO (XdgDirectory (XdgCache), createDirIfMissing, getXdgDir)++import Ribosome.Data.PersistPathError (PersistPathError (Permissions, Undefined))+import Ribosome.Data.PluginName (PluginName (unPluginName))+import Ribosome.Data.SettingError (SettingError)+import qualified Ribosome.Effect.PersistPath as PersistPath+import Ribosome.Effect.PersistPath (PersistPath (PersistPath))+import qualified Ribosome.Effect.Settings as Settings+import Ribosome.Effect.Settings (Settings)+import Ribosome.Host.Data.BootError (BootError)+import Ribosome.PluginName (pluginName)++-- |Append an optional subdir to a dir.+maybeSubdir :: Path b Dir -> Maybe (Path Rel Dir) -> Path b Dir+maybeSubdir root = \case+  Just sub ->+    root </> sub+  Nothing ->+    root++-- |Append an optional subdir to a dir and ensure existence of the resulting directory if 'True' is given.+persistPath ::+  Members [Stop PersistPathError, Embed IO] r =>+  Bool ->+  Path Abs Dir ->+  Maybe (Path Rel Dir) ->+  Sem r (Path Abs Dir)+persistPath create base sub = do+  when create (stopTryAny (const (Permissions path)) (createDirIfMissing True path))+  pure path+  where+    path =+      maybeSubdir base sub++-- |Interpret 'PersistPath' by using the specified root directory.+interpretPersistPathAt ::+  Member (Embed IO) r =>+  Bool ->+  Path Abs Dir ->+  InterpreterFor (PersistPath !! PersistPathError) r+interpretPersistPathAt create base =+  interpretResumable \case+    PersistPath sub ->+      persistPath create base sub++-- |Look up the XDG cache directory, returning 'Nothing' if it is unavailable.+xdgCache ::+  Member (Embed IO) r =>+  Sem r (Maybe (Path Abs Dir))+xdgCache =+  rightToMaybe <$> tryAny (getXdgDir XdgCache Nothing)++-- |Interpret 'PersistPath' by reading the global setting for the root directory, or using the given directory if the+-- variable is unset.+--+-- The given @name@ is appended to the root, which usually identifies the plugin.+interpretPersistPathSetting ::+  Members [Settings !! SettingError, Embed IO] r =>+  Bool ->+  Maybe (Path Abs Dir) ->+  Path Rel Dir ->+  InterpreterFor (PersistPath !! PersistPathError) r+interpretPersistPathSetting create fallback name =+  interpretResumable \case+    PersistPath sub -> do+      base <- stopNote Undefined . (<|> fallback) =<< Settings.maybe PersistPath.setting+      persistPath create (base </> name) sub++-- |Interpret 'PersistPath' by reading the global setting for the root directory, or using the XDG cache directory if+-- the variable is unset.+--+-- The plugin name is used as a subdir of the root.+--+-- This uses 'Resumable', see [Errors]("Ribosome#errors").+interpretPersistPath ::+  Members [Settings !! SettingError, Reader PluginName, Error BootError, Embed IO] r =>+  Bool ->+  InterpreterFor (PersistPath !! PersistPathError) r+interpretPersistPath create sem = do+  xdg <- xdgCache+  name <- note "plugin name not suitable for file system paths" . parseRelDir . toString . unPluginName =<< pluginName+  interpretPersistPathSetting create xdg name sem
+ lib/Ribosome/Interpreter/PluginName.hs view
@@ -0,0 +1,16 @@+-- |Interpreters for @'Reader' ('PluginConfig' c)@+module Ribosome.Interpreter.PluginName where++import Ribosome.Data.PluginConfig (PluginConfig (PluginConfig, name))+import Ribosome.Data.PluginName (PluginName)++-- |Interpret @'Reader' 'PluginName'@ by extracting the name from the plugin config provided by another @'Reader'+-- 'PluginConfig'@.+--+-- This interpreter is used by the main function machinery.+interpretPluginName ::+  Member (Reader (PluginConfig c)) r =>+  InterpreterFor (Reader PluginName) r+interpretPluginName sem =+  ask >>= \ PluginConfig {name} ->+    runReader name sem
+ lib/Ribosome/Interpreter/Scratch.hs view
@@ -0,0 +1,44 @@+-- |Interpreters for 'Scratch'+module Ribosome.Interpreter.Scratch where++import Conc (interpretAtomic)+import qualified Data.Map.Strict as Map+import Exon (exon)++import Ribosome.Data.PluginName (PluginName)+import Ribosome.Data.ScratchId (ScratchId (ScratchId))+import Ribosome.Data.ScratchState (ScratchState)+import Ribosome.Effect.Scratch (Scratch (Delete, Find, Get, Show, Update))+import qualified Ribosome.Host.Data.RpcError as RpcError+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Internal.Scratch (killScratch, lookupScratch, setScratchContent, showInScratch)++-- |Interpret 'Scratch' by storing the Neovim UI handles in 'AtomicState'.+-- This uses 'Resumable', see [Errors]("Ribosome#errors").+interpretScratchAtomic ::+  Members [Rpc !! RpcError, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>+  InterpreterFor (Scratch !! RpcError) r+interpretScratchAtomic =+  interpretResumable \case+    Show text options ->+      restop (showInScratch text options)+    Update i text -> do+      s <- stopNote (RpcError.Unexpected [exon|No scratch buffer named '#{coerce i}' exists|]) =<< lookupScratch i+      s <$ restop @_ @Rpc (setScratchContent s text)+    Delete i ->+      traverse_ killScratch =<< lookupScratch i+    Get ->+      atomicGets Map.elems+    Find i ->+      atomicGets (Map.lookup i)++-- |Interpret 'Scratch' by storing the Neovim UI handles in 'AtomicState'.+-- This uses 'Resumable', see [Errors]("Ribosome#errors").+interpretScratch ::+  Members [Rpc !! RpcError, Reader PluginName, Log, Resource, Embed IO] r =>+  InterpreterFor (Scratch !! RpcError) r+interpretScratch =+  interpretAtomic mempty .+  interpretScratchAtomic .+  raiseUnder
+ lib/Ribosome/Interpreter/Settings.hs view
@@ -0,0 +1,68 @@+-- |Interpreters for 'Settings'+module Ribosome.Interpreter.Settings where++import Exon (exon)++import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Data.Setting (Setting (Setting))+import qualified Ribosome.Data.SettingError as SettingError+import Ribosome.Data.SettingError (SettingError)+import Ribosome.Effect.Settings (Settings (Get, Update))+import Ribosome.Host.Api.Effect (nvimGetVar, nvimSetVar)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import qualified Ribosome.Host.Data.RpcError as RpcError+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.PluginName (pluginName)++-- |Assemble the name of a setting variable by prefixing the 'Setting' key with the plugin name if the flag is set.+settingVariableName ::+  Member (Reader PluginName) r =>+  Setting a ->+  Sem r Text+settingVariableName = \case+  Setting key False _ ->+    pure key+  Setting key True _ -> do+    PluginName name <- pluginName+    pure [exon|#{name}_#{key}|]++-- |Fetch the value for a setting stored in its Neovim variable.+settingRaw ::+  Members [Rpc, Reader PluginName] r =>+  MsgpackDecode a =>+  Setting a ->+  Sem r a+settingRaw s =+  nvimGetVar =<< settingVariableName s++-- |Return the default value for a setting or stop with an error if none is set.+fallback ::+  Members [Reader PluginName, Stop SettingError] r =>+  Setting a ->+  Sem r a+fallback = \case+  Setting _ _ (Just a) ->+    pure a+  s@(Setting _ _ Nothing) -> do+    n <- settingVariableName s+    stop (SettingError.Unset n)++-- |Interpret 'Settings' natively, using Neovim variables.+interpretSettingsRpc ::+  Members [Rpc !! RpcError, Reader PluginName] r =>+  InterpreterFor (Settings !! SettingError) r+interpretSettingsRpc =+  interpretResumable \case+    Get s ->+      settingRaw s !! \case+        RpcError.Decode e -> do+          n <- settingVariableName s+          stop (SettingError.Decode n e)+        RpcError.Api _ _ _ ->+          fallback s+        RpcError.Unexpected _ ->+          fallback s+    Update s a -> do+      n <- settingVariableName s+      resumeHoist (SettingError.UpdateFailed n) (nvimSetVar n a)
+ lib/Ribosome/Interpreter/UserError.hs view
@@ -0,0 +1,19 @@+-- |Interpreters for 'UserError'.+module Ribosome.Interpreter.UserError where++import Log (Severity (Info))++import Ribosome.Data.PluginName (PluginName)+import Ribosome.Host.Effect.UserError (UserError (UserError))+import Ribosome.PluginName (pluginNamePrefixed)++-- |Interpret 'UserError' by prefixing messages with the plugin name.+interpretUserErrorPrefixed ::+  Member (Reader PluginName) r =>+  InterpreterFor UserError r+interpretUserErrorPrefixed =+  interpret \case+    UserError e severity | severity >= Info ->+      Just . pure <$> pluginNamePrefixed e+    UserError _ _ ->+      pure Nothing
+ lib/Ribosome/Interpreter/VariableWatcher.hs view
@@ -0,0 +1,80 @@+-- |Interpreters for 'VariableWatcher'+module Ribosome.Interpreter.VariableWatcher where++import Conc (interpretAtomic, interpretLockReentrant, lockOrSkip_)+import qualified Data.Map.Strict as Map+import Data.MessagePack (Object (ObjectNil))++import Ribosome.Effect.VariableWatcher (WatchedVariable (WatchedVariable))+import qualified Ribosome.Effect.VariableWatcher as VariableWatcher+import Ribosome.Effect.VariableWatcher (VariableWatcher)+import Ribosome.Host.Api.Effect (nvimGetVar)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Interpret 'VariableWatcher' by doing nothing.+interpretVariableWatcherNull :: InterpreterFor (VariableWatcher !! Report) r+interpretVariableWatcherNull =+  interpretResumable \case+    VariableWatcher.Update -> unit+    VariableWatcher.Unwatch _ -> unit++-- |Run the handler if the two 'Object's are different.+runIfDifferent ::+  (Object -> Handler r ()) ->+  Object ->+  Object ->+  Handler r ()+runIfDifferent handler new old =+  unless (old == new) (handler new)++-- |Fetch the current value of the watched variable and call the handler if its value has changed.+checkVar ::+  Member (Rpc !! RpcError) r =>+  WatchedVariable ->+  Object ->+  (Object -> Handler r ()) ->+  Handler r Object+checkVar (WatchedVariable var) old handler =+  resumeAs old do+    new <- nvimGetVar var+    new <$ raise (runIfDifferent handler new old)++-- |This is a reactive system that is triggered by several frequently sent autocommands to inspect a user-defined set of+-- Neovim variables for changes.+-- When a variable's value has been observed to have changed from the previously recorded state, the associated handler+-- is executed.+--+-- This handler has to be passed to 'Ribosome.runNvimPluginIO' or similar as part of the custom effect stack, like:+--+-- > runNvimPluginIO "my-plugin" (watchVariables [("variable_name", handler)]) mempty+--+-- This does not remove 'VariableWatcher' from the stack, but intercepts and resends it, to make it simpler to use+-- with the plugin runners.+watchVariables ::+  Members [VariableWatcher !! Report, Rpc !! RpcError, Resource, Mask mres, Race, Embed IO] r =>+  Map WatchedVariable (Object -> Handler r ()) ->+  Sem r a ->+  Sem r a+watchVariables vars =+  interpretLockReentrant .+  interpretAtomic ((ObjectNil,) <$> vars) .+  interceptResumable \case+    VariableWatcher.Update -> do+      lockOrSkip_ do+        atomicPut =<< Map.traverseWithKey (\ var (old, h) -> (,h) <$> raiseUnder2 (checkVar var old h)) =<< atomicGet+      restop @Report VariableWatcher.update+    VariableWatcher.Unwatch var -> do+      atomicModify' (Map.delete var)+      restop @Report (VariableWatcher.unwatch var)+  . raise . raise++-- |Interpret 'VariableWatcher' with 'watchVariables', but eliminate the effect from the stack.+interpretVariableWatcher ::+  Members [Rpc !! RpcError, Resource, Mask mres, Race, Embed IO] r =>+  Map WatchedVariable (Object -> Handler (VariableWatcher !! Report : r) ()) ->+  InterpreterFor (VariableWatcher !! Report) r+interpretVariableWatcher vars =+  interpretVariableWatcherNull . watchVariables vars
+ lib/Ribosome/Lens.hs view
@@ -0,0 +1,9 @@+{-# options_haddock prune, hide #-}++-- |Lens combinators, used internally+module Ribosome.Lens where++(<|>~) :: Alternative f => ASetter s t (f a) (f a) -> f a -> s -> t+l <|>~ fa =+  over l (<|> fa)+{-# inline (<|>~) #-}
− lib/Ribosome/Log.hs 
@@ -1,150 +0,0 @@-module Ribosome.Log where--import Control.Monad.IO.Class (MonadIO, liftIO)-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.Monad.Ribo (MonadRibo, pluginName)--class Loggable a where-  logLines :: a -> [String]--instance {-# OVERLAPPABLE #-} Loggable a => Loggable [a] where-  logLines =-    (>>= logLines)--instance {-# OVERLAPPING #-} Loggable String where-  logLines = pure--instance Loggable ByteString where-  logLines = pure . ByteString.toString--instance Loggable Text where-  logLines = pure . Text.unpack--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
@@ -1,29 +1,104 @@+-- |Functions for constructing and activating 'Mapping's 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)+import Data.MessagePack (Object)+import Exon (exon) -activateMapping :: Mapping -> m ()-activateMapping _ =-  undefined+import Ribosome.Data.Mapping (+  MapMode,+  Mapping (Mapping),+  MappingAction (MappingCall, MappingEvent),+  MappingId (MappingId),+  MappingLhs (MappingLhs),+  MappingSpec (MappingSpec),+  mapModeShortName,+  unMappingId,+  )+import qualified Ribosome.Host.Api.Data as Data+import Ribosome.Host.Api.Data (Buffer)+import Ribosome.Host.Data.ChannelId (ChannelId (ChannelId))+import Ribosome.Host.Data.Event (EventName (EventName))+import Ribosome.Host.Data.RpcCall (RpcCall)+import Ribosome.Host.Data.RpcHandler (RpcHandler (RpcHandler, rpcName))+import Ribosome.Host.Data.RpcName (RpcName (RpcName))+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc) -mapCommand :: Text -> Bool -> Text-mapCommand mode remap =-  mode <> (if remap then "map" else "noremap")+-- |Generate an atomic call executing a mapping cmd for all modes specified in the 'Mapping' and run it.+mappingCmdWith ::+  Member Rpc r =>+  (Text -> Text -> Text -> Map Text Object -> RpcCall ()) ->+  Mapping ->+  Sem r ()+mappingCmdWith call (Mapping action (MappingSpec (MappingLhs lhs) modes) ident opts) = do+  cmd <- command action+  Rpc.sync $ for_ modes \ mode ->+    call (mapModeShortName mode) lhs [exon|<cmd>#{cmd}<cr>|] opts+  where+    command = \case+      MappingCall (RpcName name) ->+        pure [exon|silent #{name}#{i}|]+      MappingEvent (EventName name) -> do+        ChannelId cid <- Rpc.channelId+        pure [exon|call rpcnotify(#{show cid}, '#{name}'#{foldMap idArg ident})|]+    i =+      foldMap unMappingId ident+    idArg = \case+      MappingId mi -> [exon|, '#{mi}'|] +-- |Generate an atomic call executing a mapping cmd for all modes specified in the 'Mapping' and run it.+mappingCmd ::+  Member Rpc r =>+  Mapping ->+  Sem r ()+mappingCmd = do+  mappingCmdWith Data.nvimSetKeymap++-- |Generate an atomic call executing a buffer mapping cmd for all modes specified in the 'Mapping' and run it.+bufferMappingCmd ::+  Member Rpc r =>+  -- |Use @<buffer>@ to create a buffer-local mapping.+  Buffer ->+  Mapping ->+  Sem r ()+bufferMappingCmd buffer =+  mappingCmdWith (Data.nvimBufSetKeymap buffer)++-- |Register a mapping globally.+activateMapping ::+  Member Rpc r =>+  Mapping ->+  Sem r ()+activateMapping =+  mappingCmd++-- |Register a mapping in the supplied buffer. activateBufferMapping ::-  MonadRibo m =>-  NvimE e m =>+  Member Rpc r =>   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"+  Sem r ()+activateBufferMapping buffer =+  bufferMappingCmd buffer++-- |Construct a 'Mapping' using the name from the supplied 'RpcHandler'.+mappingFor ::+  RpcHandler r ->+  MappingLhs ->+  NonEmpty MapMode ->+  Maybe MappingId ->+  Map Text Object ->+  Mapping+mappingFor RpcHandler {rpcName} lhs mode =+  Mapping (MappingCall rpcName) (MappingSpec lhs mode)++-- |Construct a 'Mapping' using the supplied 'EventName'.+eventMapping ::+  EventName ->+  MappingLhs ->+  NonEmpty MapMode ->+  Maybe MappingId ->+  Map Text Object ->+  Mapping+eventMapping event lhs mode =+  Mapping (MappingEvent event) (MappingSpec lhs mode)
− lib/Ribosome/Menu/Data/Menu.hs 
@@ -1,25 +0,0 @@-{-# 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 
@@ -1,15 +0,0 @@-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 
@@ -1,16 +0,0 @@-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 
@@ -1,8 +0,0 @@-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 
@@ -1,12 +0,0 @@-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 
@@ -1,9 +0,0 @@-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 
@@ -1,41 +0,0 @@-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 
@@ -1,14 +0,0 @@-{-# 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 
@@ -1,10 +0,0 @@-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 
@@ -1,13 +0,0 @@-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 
@@ -1,16 +0,0 @@-{-# 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 
@@ -1,37 +0,0 @@-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 
@@ -1,121 +0,0 @@-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 
@@ -1,15 +0,0 @@-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 
@@ -1,13 +0,0 @@-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 
@@ -1,15 +0,0 @@-{-# 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 
@@ -1,16 +0,0 @@-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 
@@ -1,7 +0,0 @@-module Ribosome.Menu.Prompt.Data.PromptConsumed where--data PromptConsumed =-  Yes-  |-  No-  deriving (Eq, Show)
− lib/Ribosome/Menu/Prompt/Data/PromptConsumerUpdate.hs 
@@ -1,13 +0,0 @@-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 
@@ -1,15 +0,0 @@-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 
@@ -1,10 +0,0 @@-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 
@@ -1,13 +0,0 @@-{-# 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 
@@ -1,15 +0,0 @@-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 
@@ -1,11 +0,0 @@-module Ribosome.Menu.Prompt.Data.TextUpdate where--data TextUpdate =-  Unmodified-  |-  Insert Text-  |-  DeleteLeft-  |-  DeleteRight-  deriving (Eq, Show)
− lib/Ribosome/Menu/Prompt/Nvim.hs 
@@ -1,192 +0,0 @@-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 
@@ -1,181 +0,0 @@-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 
@@ -1,170 +0,0 @@-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 
@@ -1,169 +0,0 @@-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/Msgpack/Decode.hs 
@@ -1,202 +0,0 @@-module Ribosome.Msgpack.Decode where--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,-  K1(..),-  M1(..),-  Rep,-  S1,-  Selector,-  conIsRecord,-  selName,-  to,-  (:*:)(..),-  )-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 (illegalType, invalid, missingRecordKey, string)--class MsgpackDecode a where-  fromMsgpack :: Object -> Either Err a-  default fromMsgpack :: (Generic a, GMsgpackDecode (Rep a)) => Object -> Either Err a-  fromMsgpack = fmap to . gMsgpackDecode--  missingKey :: String -> Object -> Either Err a-  missingKey = Util.missingRecordKey--class GMsgpackDecode f where-  gMsgpackDecode :: Object -> Either Err (f a)--  gMissingKey :: String -> Object -> Either Err (f a)-  gMissingKey = Util.missingRecordKey--class MsgpackDecodeProd f where-  msgpackDecodeRecord :: Map Object Object -> Either Err (f a)-  msgpackDecodeProd :: [Object] -> Either Err ([Object], f a)--instance (GMsgpackDecode f) => GMsgpackDecode (D1 c f) where-  gMsgpackDecode =-    fmap M1 . gMsgpackDecode @f--instance (Constructor c, MsgpackDecodeProd f) => GMsgpackDecode (C1 c f) where-  gMsgpackDecode =-    fmap M1 . decode-    where-      isRec = conIsRecord (undefined :: t c f p)-      decode o@(ObjectMap om) =-        if isRec then msgpackDecodeRecord om else Util.invalid "illegal ObjectMap for product" o-      decode o | isRec =-        Util.invalid "illegal non-ObjectMap for record" o-      decode o =-        msgpackDecodeProd (prod o) >>= check-        where-          check ([], a) = Right a-          check _ = Util.invalid "too many values for product" o-          prod (ObjectArray oa) = oa-          prod ob = [ob]--instance (MsgpackDecodeProd f, MsgpackDecodeProd g) => MsgpackDecodeProd (f :*: g) where-  msgpackDecodeRecord o = do-    left <- msgpackDecodeRecord o-    right <- msgpackDecodeRecord o-    return $ left :*: right-  msgpackDecodeProd o = do-    (rest, left) <- msgpackDecodeProd o-    (rest1, right) <- msgpackDecodeProd rest-    return (rest1, left :*: right)--instance (Selector s, GMsgpackDecode f) => MsgpackDecodeProd (S1 s f) where-  msgpackDecodeRecord o =-    M1 <$> maybe (gMissingKey key (ObjectMap o)) gMsgpackDecode (o !? Util.string key)-    where-      key = selName (undefined :: t s f p)-  msgpackDecodeProd (cur:rest) = do-    a <- gMsgpackDecode cur-    return (rest, M1 a)-  msgpackDecodeProd [] = Util.invalid "too few values for product" ObjectNil--instance MsgpackDecode a => GMsgpackDecode (K1 i a) where-  gMsgpackDecode = fmap K1 . fromMsgpack--  gMissingKey key =-    fmap K1 . missingKey key--instance (Ord k, MsgpackDecode k, MsgpackDecode v) => MsgpackDecode (Map k v) where-  fromMsgpack (ObjectMap om) = do-    m <- traverse decodePair $ Map.toList om-    Right $ Map.fromList m-    where-      decodePair (k, v) = do-        k1 <- fromMsgpack k-        v1 <- fromMsgpack v-        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 = 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 $ 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 
@@ -1,105 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeOperators #-}--module Ribosome.Msgpack.Encode where--import Data.Bifunctor (bimap)-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,-  K1(..),-  M1(..),-  Rep,-  S1,-  Selector,-  conIsRecord,-  from,-  selName,-  (:*:)(..),-  )-import qualified Ribosome.Msgpack.Util as Util (assembleMap, string, text)--class MsgpackEncode a where-  toMsgpack :: a -> Object-  default toMsgpack :: (Generic a, GMsgpackEncode (Rep a)) => a -> Object-  toMsgpack = gMsgpackEncode . from--class GMsgpackEncode f where-  gMsgpackEncode :: f a -> Object--class MsgpackEncodeProd f where-  msgpackEncodeRecord :: f a -> [(String, Object)]-  msgpackEncodeProd :: f a -> [Object]--instance GMsgpackEncode f => GMsgpackEncode (D1 c f) where-  gMsgpackEncode = gMsgpackEncode . unM1--prodOrNewtype :: MsgpackEncodeProd f => f a -> Object-prodOrNewtype =-  wrap . msgpackEncodeProd-  where-    wrap [a] = a-    wrap as = ObjectArray as--instance (Constructor c, MsgpackEncodeProd f) => GMsgpackEncode (C1 c f) where-  gMsgpackEncode c =-    f $ unM1 c-    where-      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--instance (Selector s, GMsgpackEncode f) => MsgpackEncodeProd (S1 s f) where-  msgpackEncodeRecord s@(M1 f) = [(selName s, gMsgpackEncode f)]-  msgpackEncodeProd (M1 f) = [gMsgpackEncode f]--instance MsgpackEncode a => GMsgpackEncode (K1 i a) where-  gMsgpackEncode = toMsgpack . unK1--instance (Ord k, MsgpackEncode k, MsgpackEncode v) => MsgpackEncode (Map k v) where-  toMsgpack = ObjectMap . Map.fromList . fmap (bimap toMsgpack toMsgpack) . Map.toList--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 
@@ -1,24 +0,0 @@-{-# 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 
@@ -1,21 +0,0 @@-module Ribosome.Msgpack.NvimObject(-  NO(..),-  (-$),-) where--import Control.DeepSeq (NFData)-import GHC.Generics (Generic)-import Neovim (NvimObject(..))-import Ribosome.Msgpack.Decode (MsgpackDecode(..))-import Ribosome.Msgpack.Encode (MsgpackEncode(..))--newtype NO a =-  NO { unNO :: a }-  deriving (Eq, Show, Generic, NFData)--instance (MsgpackEncode a, MsgpackDecode a, NFData a) => NvimObject (NO a) where-  toObject (NO a) = toMsgpack a-  fromObject a = NO <$> fromMsgpack a--(-$) :: (NO a -> b) -> a -> b-(-$) f a = f (NO a)
− lib/Ribosome/Msgpack/Util.hs 
@@ -1,32 +0,0 @@-module Ribosome.Msgpack.Util where--import Data.Bifunctor (first)-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, pretty, viaShow, (<+>))-import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)--type Err = Doc AnsiStyle--string :: String -> Object-string = ObjectString . ByteString.fromString--text :: Text -> Object-text = ObjectString . encodeUtf8--assembleMap :: [(String, Object)] -> Object-assembleMap =-  ObjectMap . Map.fromList . (fmap . first) string--invalid :: String -> Object -> Either Err a-invalid msg obj =-  Left $ pretty (msg ++ ": ") <+> viaShow obj--missingRecordKey :: String -> Object -> Either Err a-missingRecordKey key =-  invalid $ "missing record key " ++ key ++ " in ObjectMap"--illegalType :: String -> Object -> Either Err a-illegalType tpe =-  invalid $ "illegal type for " ++ tpe
− lib/Ribosome/Nvim/Api/Data.hs 
@@ -1,12 +0,0 @@-{-# 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 
@@ -1,80 +0,0 @@-{-# 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 
@@ -1,85 +0,0 @@-{-# 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 
@@ -1,73 +0,0 @@-{-# 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 
@@ -1,11 +0,0 @@-{-# 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 
@@ -1,65 +0,0 @@-{-# 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 
@@ -1,9 +0,0 @@-{-# 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,132 +1,12 @@-module Ribosome.Persist where--import Control.Exception (IOException, try)-import Control.Monad (unless)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.IO.Class (MonadIO, liftIO)-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 :: MonadIO m => m (Path Abs Dir)-defaultPersistencePath =-  liftIO $ getXdgDir XdgCache Nothing--persistencePath ::-  MonadRibo m =>-  NvimE e m =>-  MonadIO m =>-  MonadThrow m =>-  MonadDeepError e SettingError m =>-  Path Rel File ->-  m (Path Abs File)-persistencePath path = do-  base <- defaultPersistencePath `recoveryFor` (parseAbsDir =<< setting S.persistenceDir)-  name <- parseRelDir . toString =<< pluginName-  return $ base </> name </> path--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-  createDirIfMissing True (parent file)-  file <.> "json"--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 $ encodeFile (toFilePath file) a--noSuchFile :: MonadDeepError e PersistError m => Path Abs File -> m a-noSuchFile = throwHoist . PersistError.NoSuchFile . toFilePath--ensureExistence ::-  MonadIO m =>-  MonadDeepError e PersistError m =>-  Path Abs File ->-  m ()-ensureExistence file = do-  exists <- liftIO $ doesFileExist file-  unless exists (noSuchFile file)--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 <- persistenceFile path-  ensureExistence file-  safeDecodeFile file+-- |API for the effect 'Persist'.+module Ribosome.Persist (+  module Ribosome.Effect.Persist,+  module Ribosome.Effect.PersistPath,+  module Ribosome.Data.PersistError,+  module Ribosome.Data.PersistPathError,+) where -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+import Ribosome.Data.PersistError+import Ribosome.Data.PersistPathError+import Ribosome.Effect.Persist+import Ribosome.Effect.PersistPath
− lib/Ribosome/Plugin.hs 
@@ -1,158 +0,0 @@-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
@@ -1,29 +1,99 @@+-- |Interceptor that adds internal RPC handlers to the host. module Ribosome.Plugin.Builtin where -import Neovim.Plugin.Classes (Synchronous(Async))+import Exon (exon)+import Prelude hiding (group) -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)+import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Data.ScratchId (ScratchId)+import qualified Ribosome.Effect.Scratch as Scratch+import Ribosome.Effect.Scratch (Scratch)+import qualified Ribosome.Effect.VariableWatcher as VariableWatcher+import Ribosome.Effect.VariableWatcher (VariableWatcher)+import Ribosome.Host.Data.BootError (BootError)+import Ribosome.Host.Data.Execution (Execution (Async))+import Ribosome.Host.Data.Report (Report, resumeReport)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import Ribosome.Host.Data.RpcName (RpcName (RpcName))+import Ribosome.Host.Data.RpcType (AutocmdGroup (AutocmdGroup), AutocmdOptions (target), AutocmdPatterns, group)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Handler (rpcAutocmd, rpcFunction)+import Ribosome.Host.Interpreter.Handlers (withHandlers)+import Ribosome.Text (capitalize) -deleteScratch ::-  MonadRibo m =>-  NvimE e m =>-  [Object] ->-  m Object-deleteScratch [ObjectString name] = do-  ObjectNil <$ killScratchByName (decodeUtf8 name)-deleteScratch _ =-  return ObjectNil+-- |The set of autocmds that should trigger an update in 'VariableWatcher'.+watcherEvents :: [(Text, AutocmdPatterns)]+watcherEvents =+  [+    ("CmdlineLeave", def),+    ("BufWinEnter", def),+    ("VimEnter", def),+    ("User", "RibosomeUpdateVariables")+  ] -deleteScratchRpc ::-  MonadDeepError e MappingError m =>-  MonadRibo m =>-  NvimE e m =>+-- |Run 'VariableWatcher.update' and restop errors.+updateVar ::+  Member (VariableWatcher !! Report) r =>+  Handler r ()+updateVar =+  restop VariableWatcher.update++-- |Declare an autocmd that triggers the variable watcher.+watcherRpc ::+  ∀ r .+  Member (VariableWatcher !! Report) r =>+  PluginName ->   Text ->-  RpcDef m-deleteScratchRpc pluginName =-  RpcDef (RpcFunction Async) (capitalize pluginName <> "DeleteScratch") deleteScratch+  AutocmdPatterns ->+  RpcHandler r+watcherRpc (PluginName name) event pat =+  rpcAutocmd (RpcName method) Async (fromText event) def { target = Right pat, group = Just (AutocmdGroup name) } do+    updateVar+  where+    method =+      [exon|#{capitalize name}VariableChanged#{event}|]++-- |Delete a scratch buffer.+deleteScratch ::+  Member (Scratch !! RpcError) r =>+  ScratchId ->+  Handler r ()+deleteScratch =+  resumeReport . Scratch.delete++-- |The name for the handler that is triggered by a scratch buffer being deleted.+deleteName :: PluginName -> RpcName+deleteName (PluginName name) =+  RpcName [exon|#{capitalize name}DeleteScratch|]++-- |A set of 'RpcHandler's for internal tasks.+builtinHandlers ::+  ∀ r .+  Members [Scratch !! RpcError, VariableWatcher !! Report] r =>+  PluginName ->+  [RpcHandler r]+builtinHandlers name =+  rpcFunction (deleteName name) Async deleteScratch : (uncurry (watcherRpc name) <$> watcherEvents)++-- |The dependencies of the builtin handlers.+type BuiltinHandlersDeps =+  [+    VariableWatcher !! Report,+    Handlers !! Report,+    Scratch !! RpcError,+    Rpc !! RpcError,+    Reader PluginName,+    Error BootError,+    Log+  ]++-- |Add builtin handlers to 'Handlers' without removing the effect from the stack.+interceptHandlersBuiltin ::+  Members BuiltinHandlersDeps r =>+  Sem r a ->+  Sem r a+interceptHandlersBuiltin sem = do+  name <- ask+  withHandlers (builtinHandlers name) sem
− lib/Ribosome/Plugin/Mapping.hs 
@@ -1,37 +0,0 @@-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 
@@ -1,10 +0,0 @@-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 
@@ -1,64 +0,0 @@-{-# 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 
@@ -1,285 +0,0 @@-{-# 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 
@@ -1,163 +0,0 @@-{-# 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 
@@ -1,82 +0,0 @@-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/PluginName.hs view
@@ -0,0 +1,31 @@+-- |Combinators for 'PluginName'.+module Ribosome.PluginName where++import Exon (exon)++import Ribosome.Data.PluginName (PluginName (PluginName))+import Ribosome.Host.Text (pascalCase)++-- |Get the 'PluginName' from a 'Reader'.+pluginName ::+  Member (Reader PluginName) r =>+  Sem r PluginName+pluginName =+  ask++-- |Get the 'PluginName' from a 'Reader' and prefix the given string with it, followed by a colon..+pluginNamePrefixed ::+  Member (Reader PluginName) r =>+  Text ->+  Sem r Text+pluginNamePrefixed msg = do+  PluginName name <- pluginName+  pure [exon|#{name}: #{msg}|]++-- |Get the 'PluginName' from a 'Reader' and convert it to PascalCase.+pluginNamePascalCase ::+  Member (Reader PluginName) r =>+  Sem r PluginName+pluginNamePascalCase = do+  PluginName n <- pluginName+  pure (PluginName (pascalCase n))
− lib/Ribosome/Prelude.hs 
@@ -1,95 +0,0 @@-{-# 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 
@@ -1,19 +0,0 @@-{-# 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/Register.hs view
@@ -0,0 +1,8 @@+-- |API for registers.+module Ribosome.Register (+  module Ribosome.Data.Register,+  module Ribosome.Data.RegisterType,+) where++import Ribosome.Data.Register (Register (..), registerRepr)+import Ribosome.Data.RegisterType (RegisterType (..))
+ lib/Ribosome/Remote.hs view
@@ -0,0 +1,150 @@+-- |Main function combinators for remote plugins.+module Ribosome.Remote where++import Ribosome.Data.PluginConfig (PluginConfig)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Interpret (HigherOrder)+import Ribosome.Host.Interpreter.Handlers (interpretHandlersNull, withHandlers)+import Ribosome.Host.Interpreter.Host (runHost)+import Ribosome.Host.Interpreter.Process.Stdio (interpretProcessCerealStdio)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)+import Ribosome.IOStack (BasicPluginStack, runCli)+import Ribosome.Interpreter.Scratch (interpretScratch)+import Ribosome.Interpreter.Settings (interpretSettingsRpc)+import Ribosome.Interpreter.UserError (interpretUserErrorPrefixed)+import Ribosome.Interpreter.VariableWatcher (interpretVariableWatcherNull)+import Ribosome.Plugin.Builtin (interceptHandlersBuiltin)+import Ribosome.Run (PluginEffects)++-- |The stack of plugin internals.+type HandlerStack =+  PluginEffects ++ RpcStack ++ RpcDeps++-- |The complete stack of a Neovim plugin.+type RemoteStack c =+  HandlerStack ++ BasicPluginStack c++-- |Run plugin internals without IO effects.+interpretPluginRemote ::+  Members (BasicPluginStack c) r =>+  InterpretersFor HandlerStack r+interpretPluginRemote =+  interpretUserErrorPrefixed .+  interpretProcessCerealStdio .+  interpretRpcStack .+  interpretHandlersNull .+  interpretVariableWatcherNull .+  interpretSettingsRpc .+  interpretScratch++-- |Run the main loop for a remote plugin.+remotePlugin ::+  ∀ c r .+  Members HandlerStack r =>+  Members (BasicPluginStack c) r =>+  Sem r ()+remotePlugin =+  interceptHandlersBuiltin runHost++-- |Run plugin internals and IO effects for a remote plugin, reading options from the CLI.+--+-- Like 'runRemoteStack', but allows the CLI option parser to be specified.+runRemoteStackCli ::+  PluginConfig c ->+  Sem (RemoteStack c) () ->+  IO ()+runRemoteStackCli conf =+  runCli conf . interpretPluginRemote++-- |Run plugin internals and IO effects for a remote plugin, reading options from the CLI.+runRemoteStack ::+  PluginConfig () ->+  Sem (RemoteStack ()) () ->+  IO ()+runRemoteStack conf =+  runCli conf . interpretPluginRemote++-- |Run a Neovim plugin using a set of handlers and configuration, with an arbitrary stack of custom effects placed+-- between the handlers and the Ribosome stack.+--+-- Like 'runNvimPluginIO', but allows the 'PluginConfig' to contain a CLI parser for an arbitrary type @c@ that is then+-- provided in a @'Reader' c@ to the plugin.+--+-- This is separate from 'runNvimPluginIO' because it requires a type hint when using @OverloadedStrings@ or 'def' to+-- construct the config without an option parser.+runNvimPluginCli ::+  HigherOrder r (RemoteStack c) =>+  PluginConfig c ->+  InterpretersFor r (RemoteStack c) ->+  [RpcHandler (r ++ RemoteStack c)] ->+  IO ()+runNvimPluginCli conf effs handlers =+  runRemoteStackCli conf (effs (withHandlers handlers remotePlugin))++-- |Run a Neovim plugin using a set of handlers and configuration, with an arbitrary stack of custom effects placed+-- between the handlers and the Ribosome stack.+-- This is important, because the custom effects may want to use the Neovim API, while the handlers want to use both+-- Neovim and the custom effects.+--+-- Example:+--+-- > data Numbers :: Effect where+-- >   Number :: Int -> Sem r Int+-- >+-- > makeSem ''Numbers+-- >+-- > runNumbers :: Member (Rpc !! RpcError) r => InterpreterFor Numbers r+-- > runNumbers = \case+-- >   Number i -> (-1) <! nvimGetVar ("number_" <> show i)+-- >+-- > type CustomStack = [AtomicState Int, Numbers]+-- >+-- > currentNumber :: Handler r Int+-- > currentNumber = number =<< atomicGet+-- >+-- > setNumber :: Int -> Handler r ()+-- > setNumber = atomicPut+-- >+-- > runCustomStack :: InterpretersFor CustomStack r+-- > runCustomStack = interpretAtomic . runNumbers+-- >+-- > main :: IO ()+-- > main = runNvimPluginIO @CustomStack "numbers" runCustomStack [+-- >   rpcFunction "CurrentNumber" Sync currentNumber,+-- >   rpcFunction "SetNumber" Async setNumber+-- >   ]+--+-- /Note/:+--+-- - 'PluginConfig' is being constructed via @OverloadedStrings@+--+-- - @CustomStack@ has to be specified as a type application, because GHC cannot figure it out on its own.+--+-- - For an explanation of @Rpc !! RpcError@, see [Errors]("Ribosome#errors")+--+-- This runs the entire stack to completion, so it can be used in the app's @main@ function.+--+-- For more flexibility and less type inference noise, this can be inlined as:+--+-- > runRemoteStack conf $ runCustomStack $ withHandlers handlers remotePlugin+runNvimPluginIO ::+  ∀ r .+  HigherOrder r (RemoteStack ()) =>+  PluginConfig () ->+  InterpretersFor r (RemoteStack ()) ->+  [RpcHandler (r ++ RemoteStack ())] ->+  IO ()+runNvimPluginIO conf effs handlers =+  runRemoteStack conf (effs (withHandlers handlers remotePlugin))++-- |Run a Neovim plugin using a set of handlers and configuration.+--+-- This function does not allow additional effects to be used. See 'runNvimPluginIO' for that purpose.+--+-- This runs the entire stack to completion, so it can be used in the app's @main@ function.+runNvimPluginIO_ ::+  PluginConfig () ->+  [RpcHandler (RemoteStack ())] ->+  IO ()+runNvimPluginIO_ conf handlers =+  runRemoteStack conf (withHandlers handlers remotePlugin)
+ lib/Ribosome/Report.hs view
@@ -0,0 +1,117 @@+-- |Smart constructors for @'DataLog' 'LogReport'@+module Ribosome.Report (+  module Ribosome.Report,+  module Ribosome.Host.Effect.Reports,+  module Ribosome.Host.Interpreter.Reports,+  LogReport (LogReport),+  Report (Report),+  ReportContext (ReportContext),+  Reportable (toReport),+) where++import Log (Severity (Error, Info, Warn), dataLog)+import qualified Polysemy.Log as Log++import Ribosome.Data.SettingError (SettingError)+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Effect.Settings (Settings)+import qualified Ribosome.Host.Data.Report as Report+import Ribosome.Host.Data.Report (+  LogReport (LogReport),+  Report (Report),+  ReportContext (ReportContext),+  Reportable (toReport),+  resumeReport,+  severity,+  )+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Reports (Reports (..), storeReport, storedReports)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Interpreter.Reports++-- |Add a segment to the current 'Report' logging context.+context ::+  Member (DataLog LogReport) r =>+  Text ->+  Sem r a ->+  Sem r a+context ctx =+  Log.local (#context %~ \ (ReportContext cur) -> ReportContext (ctx : cur))++-- |Set the current 'Report' logging context.+setContext ::+  Member (DataLog LogReport) r =>+  ReportContext ->+  Sem r a ->+  Sem r a+setContext ctx =+  Log.local (#context .~ ctx)++-- |Convert a value to 'Report' via 'Reportable' and send it to the log.+logReport ::+  Reportable e =>+  Member (DataLog LogReport) r =>+  e ->+  Sem r ()+logReport e =+  dataLog (LogReport r True (severity r >= Warn) mempty)+  where+    r = toReport e++-- |Send a 'Report' to the log given a user and log message, with serverity 'Info'.+info ::+  Member (DataLog LogReport) r =>+  Text ->+  [Text] ->+  Sem r ()+info user log =+  logReport Report {severity = Info, ..}++-- |Send a 'Report' to the log given a user and log message, with serverity 'Warn'.+warn ::+  Member (DataLog LogReport) r =>+  Text ->+  [Text] ->+  Sem r ()+warn user log =+  logReport Report {severity = Warn, ..}++-- |Send a 'Report' to the log given a user and log message, with serverity 'Log.Error'.+error ::+  Member (DataLog LogReport) r =>+  Text ->+  [Text] ->+  Sem r ()+error user log =+  logReport Report {severity = Error, ..}++-- |Eliminate @'Stop' err@ by converting @err@ to a 'Report' and logging it, continuing execution for a unit action.+reportStop ::+  ∀ err r .+  Reportable err =>+  Member (DataLog LogReport) r =>+  Sem (Stop err : r) () ->+  Sem r ()+reportStop sem =+  withFrozenCallStack do+    either logReport pure =<< runStop sem++-- |Resume an effect by converting the error to a 'Report' and logging it, continuing execution for a unit action.+resumeLogReport ::+  ∀ eff e r .+  Reportable e =>+  Members [eff !! e, DataLog LogReport] r =>+  Sem (eff : r) () ->+  Sem r ()+resumeLogReport sem =+  withFrozenCallStack do+    sem !! logReport++-- |Resume all plugin effects.+pluginLogReports ::+  Members [Scratch !! RpcError, Settings !! SettingError, Rpc !! RpcError, Stop Report] r =>+  InterpretersFor [Scratch, Settings, Rpc] r+pluginLogReports =+  resumeReport @Rpc .+  resumeReport @Settings .+  resumeReport @Scratch
+ lib/Ribosome/Run.hs view
@@ -0,0 +1,30 @@+-- |Convenience aliases for plugin effects.+module Ribosome.Run where++import Ribosome.Data.PluginName (PluginName)+import Ribosome.Data.SettingError (SettingError)+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Effect.Settings (Settings)+import Ribosome.Effect.VariableWatcher (VariableWatcher)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |The set of core effects that are intepreted by the main logic, minus what's in "Ribosome.Host".+type PluginEffects =+  [+    Scratch !! RpcError,+    Settings !! SettingError,+    VariableWatcher !! Report,+    Handlers !! Report+  ]++-- |The set of core effects that handlers and API functions commonly use.+type NvimPlugin =+  [+    Scratch !! RpcError,+    Settings !! SettingError,+    Rpc !! RpcError,+    Reader PluginName+  ]
lib/Ribosome/Scratch.hs view
@@ -1,237 +1,20 @@-module Ribosome.Scratch where--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 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 :: NvimE e m => m Tabpage-createScratchTab = do-  vimCommand "tabnew"-  vimGetCurrentTabpage--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 :: NvimE e m => m (Window, Maybe Tabpage)-createScratchUiInTab = do-  tab <- createScratchTab-  win <- vimGetCurrentWindow-  return (win, Just tab)--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 :: NvimE e m => ScratchOptions -> m (Window, Maybe Tabpage)-createScratchUi (ScratchOptions False vertical wrap _ _ bottom _ size _ _ _) =-  createScratchUiInWindow vertical wrap bottom size-createScratchUi _ =-  createScratchUiInTab--configureScratchBuffer :: NvimE e m => Buffer -> Text -> m ()-configureScratchBuffer buffer name = do-  bufferSetOption buffer "buftype" (toMsgpack ("nofile" :: Text))-  bufferSetOption buffer "bufhidden" (toMsgpack ("wipe" :: Text))-  bufferSetName buffer name--setupScratchBuffer :: NvimE e m => Window -> Text -> m Buffer-setupScratchBuffer window name = do-  buffer <- windowGetBuffer window-  configureScratchBuffer buffer name-  return buffer--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-  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--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 <> "')"--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 <- 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+-- |A scratch buffer is what Neovim calls text not associated with a file, used for informational or interactive+-- content.+--+-- Ribosome provides an interface for maintaining those, by associating a view configuration with an ID and allowing to+-- update the text displayed in it.+module Ribosome.Scratch (+  module Ribosome.Effect.Scratch,+  module Ribosome.Data.ScratchOptions,+  module Ribosome.Data.ScratchId,+  module Ribosome.Data.ScratchState,+  module Ribosome.Data.FloatOptions,+  module Ribosome.Interpreter.Scratch,+) where -scratchWindow ::-  MonadRibo m =>-  Text ->-  m (Maybe Window)-scratchWindow =-  fmap Scratch.scratchWindow <$$> lookupScratch+import Ribosome.Data.FloatOptions+import Ribosome.Data.ScratchId+import Ribosome.Data.ScratchOptions+import Ribosome.Data.ScratchState+import Ribosome.Effect.Scratch+import Ribosome.Interpreter.Scratch
+ lib/Ribosome/Settings.hs view
@@ -0,0 +1,21 @@+-- |The 'Settings' API, an effect for accessing Neovim variables with defaults.+module Ribosome.Settings (+  module Ribosome.Data.Setting,+  module Ribosome.Data.SettingError,+  module Ribosome.Settings,+  module Ribosome.Effect.Settings,+) where++import Ribosome.Data.Setting (Setting (..))+import Ribosome.Data.SettingError (SettingError (..))+import Ribosome.Effect.Settings (Settings, get, maybe, or, update)++-- |The vertical margin for floating windows used by @ribosome-menu@.+menuMarginVertical :: Setting Float+menuMarginVertical =+  Setting "ribosome_menu_margin_vertical" False (Just 0.2)++-- |The horizontal margin for floating windows used by @ribosome-menu@.+menuMarginHorizontal :: Setting Float+menuMarginHorizontal =+  Setting "ribosome_menu_margin_horizontal" False (Just 0.1)
+ lib/Ribosome/Socket.hs view
@@ -0,0 +1,38 @@+-- |Main function combinators for connecting to Neovim over a socket.+module Ribosome.Socket where++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.NvimSocket (NvimSocket)+import Ribosome.Host.Interpreter.Handlers (interpretHandlersNull)+import Ribosome.Host.Interpreter.Process.Socket (interpretProcessCerealSocket)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)+import Ribosome.IOStack (BasicPluginStack)+import Ribosome.Interpreter.Scratch (interpretScratch)+import Ribosome.Interpreter.Settings (interpretSettingsRpc)+import Ribosome.Interpreter.UserError (interpretUserErrorPrefixed)+import Ribosome.Interpreter.VariableWatcher (interpretVariableWatcherNull)+import Ribosome.Run (PluginEffects)++-- |The stack of plugin internals.+type SocketHandlerEffects =+  PluginEffects ++ RpcStack ++ RpcDeps++-- |The complete stack of a Neovim plugin.+type PluginSocketStack c =+  SocketHandlerEffects ++ Reader NvimSocket : BasicPluginStack c++-- |Run plugin internals without IO effects.+interpretPluginSocket ::+  Members (BasicPluginStack c) r =>+  Member (Reader NvimSocket) r =>+  InterpretersFor SocketHandlerEffects r+interpretPluginSocket =+  interpretUserErrorPrefixed .+  interpretProcessCerealSocket def .+  resumeHoistError (BootError . show @Text) .+  raiseUnder .+  interpretRpcStack .+  interpretHandlersNull .+  interpretVariableWatcherNull .+  interpretSettingsRpc .+  interpretScratch
+ lib/Ribosome/Syntax.hs view
@@ -0,0 +1,50 @@+-- |Data types and combinators for [Ribosome.Api.Syntax]("Ribosome.Api.Syntax").+module Ribosome.Syntax (+  module Ribosome.Data.Syntax,+  module Ribosome.Syntax,+) where++import qualified Data.Map.Strict as Map++import Ribosome.Data.Syntax (+  HiLink (..),+  Highlight (..),+  Syntax (..),+  SyntaxItem (..),+  SyntaxItemDetail (..),+  )++-- |Construct a default 'SyntaxItem' from a 'SyntaxItemDetail'.+syntaxItem :: SyntaxItemDetail -> SyntaxItem+syntaxItem detail =+  SyntaxItem detail def def++-- |Construct a simple keyword syntax item.+syntaxKeyword :: Text -> Text -> SyntaxItem+syntaxKeyword group' keyword =+  syntaxItem $ Keyword group' keyword def++-- |Construct a simple match syntax item.+syntaxMatch :: Text -> Text -> SyntaxItem+syntaxMatch group' pat =+  syntaxItem $ Match group' pat++-- |Construct a region syntax item with offsets.+syntaxRegionOffset :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> SyntaxItem+syntaxRegionOffset group' start end skip ms me =+  syntaxItem $ Region group' start end skip ms me++-- |Construct a simple region syntax item.+syntaxRegion :: Text -> Text -> Text -> Maybe Text -> SyntaxItem+syntaxRegion group' start end skip =+  syntaxRegionOffset group' start end skip "" ""++-- |Construct a simple verbatim syntax item.+syntaxVerbatim :: Text -> SyntaxItem+syntaxVerbatim =+  syntaxItem . Verbatim++-- |Construct a syntax highlight.+syntaxHighlight :: Text -> [(Text, Text)] -> Highlight+syntaxHighlight group' =+  Highlight group' . Map.fromList
− lib/Ribosome/System/Time.hs 
@@ -1,20 +0,0 @@-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/Text.hs view
@@ -0,0 +1,26 @@+-- |Combinators for 'Text'.+module Ribosome.Text where++import Data.Char (toUpper)+import qualified Data.Text as Text++-- |Escape a single quote Neovim-style by replacing it with two single quotes.+escapeQuote :: Char -> Text+escapeQuote = \case+  '\'' ->+    "''"+  a ->+    Text.singleton a++-- |Escape all single quotes Neovim-style by replacing them with two single quotes.+escapeQuotes :: Text -> Text+escapeQuotes =+  Text.concatMap escapeQuote++-- |Upcase the first letter of a 'Text', if any.+capitalize :: Text -> Text+capitalize a =+  maybe "" run (Text.uncons a)+  where+    run (h, t) =+      Text.cons (toUpper h) t
− lib/Ribosome/Tmux/Run.hs 
@@ -1,36 +0,0 @@-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 
@@ -1,9 +0,0 @@-module Ribosome.Unsafe where--import GHC.IO.Unsafe (unsafePerformIO)--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,194 +1,286 @@-cabal-version: 1.12-name: ribosome-version: 0.3.0.1-license: OtherLicense-license-file: LICENSE-copyright: 2019 Torsten Schmits-maintainer: tek@tryp.io-author: Torsten Schmits-homepage: https://github.com/tek/ribosome-hs#readme-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/ribosome-hs>-category: Neovim-build-type: Simple+cabal-version: 2.2 -source-repository head-    type: git-    location: https://github.com/tek/ribosome-hs+-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack +name:           ribosome+version:        0.9.9.9+synopsis:       Neovim plugin framework for Polysemy+description:    See https://hackage.haskell.org/package/ribosome/docs/Ribosome.html+category:       Neovim+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2022 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+ 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.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.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.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.System.Time-        Ribosome.Tmux.Run-        Ribosome.Unsafe-    hs-source-dirs: lib-    other-modules:-        Prelude-    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 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-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 >=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,-        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,-        unliftio-core >=0.1.2.0 && <0.2,-        utf8-string >=1.0.1.1 && <1.1+  exposed-modules:+      Ribosome+      Ribosome.Api+      Ribosome.Api.Autocmd+      Ribosome.Api.Buffer+      Ribosome.Api.Data+      Ribosome.Api.Echo+      Ribosome.Api.Function+      Ribosome.Api.Input+      Ribosome.Api.Mode+      Ribosome.Api.Normal+      Ribosome.Api.Option+      Ribosome.Api.Path+      Ribosome.Api.Position+      Ribosome.Api.Process+      Ribosome.Api.Register+      Ribosome.Api.Sleep+      Ribosome.Api.Syntax+      Ribosome.Api.Tabpage+      Ribosome.Api.Undo+      Ribosome.Api.Window+      Ribosome.Cli+      Ribosome.Data.CliConfig+      Ribosome.Data.CustomConfig+      Ribosome.Data.FileBuffer+      Ribosome.Data.FloatOptions+      Ribosome.Data.Mapping+      Ribosome.Data.Mode+      Ribosome.Data.PersistError+      Ribosome.Data.PersistPathError+      Ribosome.Data.PluginConfig+      Ribosome.Data.PluginName+      Ribosome.Data.Register+      Ribosome.Data.RegisterType+      Ribosome.Data.ScratchId+      Ribosome.Data.ScratchOptions+      Ribosome.Data.ScratchState+      Ribosome.Data.Setting+      Ribosome.Data.SettingError+      Ribosome.Data.Syntax+      Ribosome.Data.WindowConfig+      Ribosome.Data.WindowView+      Ribosome.Effect.Persist+      Ribosome.Effect.PersistPath+      Ribosome.Effect.Scratch+      Ribosome.Effect.Settings+      Ribosome.Effect.VariableWatcher+      Ribosome.Embed+      Ribosome.Examples.Example1+      Ribosome.Examples.Example2+      Ribosome.Examples.Example3+      Ribosome.Final+      Ribosome.Float+      Ribosome.Internal.Path+      Ribosome.Internal.Scratch+      Ribosome.Internal.Syntax+      Ribosome.Interpreter.Persist+      Ribosome.Interpreter.PersistPath+      Ribosome.Interpreter.PluginName+      Ribosome.Interpreter.Scratch+      Ribosome.Interpreter.Settings+      Ribosome.Interpreter.UserError+      Ribosome.Interpreter.VariableWatcher+      Ribosome.IOStack+      Ribosome.Lens+      Ribosome.Mapping+      Ribosome.Persist+      Ribosome.Plugin.Builtin+      Ribosome.PluginName+      Ribosome.Register+      Ribosome.Remote+      Ribosome.Report+      Ribosome.Run+      Ribosome.Scratch+      Ribosome.Settings+      Ribosome.Socket+      Ribosome.Syntax+      Ribosome.Text+  hs-source-dirs:+      lib+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+      StandaloneKindSignatures+      OverloadedLabels+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin+  build-depends:+      aeson+    , base >=4.12 && <5+    , exon+    , messagepack+    , optparse-applicative+    , path+    , path-io+    , polysemy+    , polysemy-plugin+    , prelate >=0.1+    , prettyprinter+    , ribosome-host+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010++test-suite ribosome-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Ribosome.Test.BufferTest+      Ribosome.Test.Error+      Ribosome.Test.MappingTest+      Ribosome.Test.PathTest+      Ribosome.Test.PersistTest+      Ribosome.Test.ScratchTest+      Ribosome.Test.SettingTest+      Ribosome.Test.UndoTest+      Ribosome.Test.Wait+      Ribosome.Test.WatcherTest+      Ribosome.Test.WindowTest+      Ribosome.Unit.Run+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+      StandaloneKindSignatures+      OverloadedLabels+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , exon+    , hedgehog+    , messagepack+    , path+    , polysemy+    , polysemy-conc+    , polysemy-plugin+    , polysemy-test+    , prelate >=0.1+    , ribosome+    , ribosome-host+    , ribosome-host-test+    , tasty+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,29 @@+module Main where++import Polysemy.Test (unitTest)+import Ribosome.Test.BufferTest (test_bufferForFile)+import Ribosome.Test.MappingTest (test_mapping)+import Ribosome.Test.PersistTest (test_persist)+import Ribosome.Test.ScratchTest (test_scratch)+import Ribosome.Test.SettingTest (test_settings)+import Ribosome.Test.UndoTest (test_undo)+import Ribosome.Test.WatcherTest (test_varWatcher)+import Ribosome.Test.WindowTest (test_window)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "ribosome" [+    unitTest "buffer for file" test_bufferForFile,+    test_scratch,+    unitTest "mapping" test_mapping,+    unitTest "variable watcher" test_varWatcher,+    unitTest "persist" test_persist,+    test_window,+    test_settings,+    unitTest "undo" test_undo+  ]++main :: IO ()+main =+  defaultMain tests
+ test/Ribosome/Test/BufferTest.hs view
@@ -0,0 +1,24 @@+module Ribosome.Test.BufferTest where++import Path (relfile)+import qualified Polysemy.Test as Test+import Polysemy.Test (UnitTest, assert, assertEq, evalMaybe, (/==), (===))++import Ribosome.Api.Buffer (bufferCount, bufferForFile, bufferIsFile, edit)+import Ribosome.Data.FileBuffer (FileBuffer (FileBuffer))+import Ribosome.Host.Api.Effect (nvimGetCurrentBuf)+import Ribosome.Host.Test.Run (embedTest_)++test_bufferForFile :: UnitTest+test_bufferForFile =+  embedTest_ do+    file1 <- Test.tempFile [] [relfile|file.x|]+    file2 <- Test.tempFile [] [relfile|file.y|]+    edit file1+    edit file2+    assertEq 2 =<< bufferCount+    cb <- nvimGetCurrentBuf+    assert =<< bufferIsFile cb+    FileBuffer buf path <- evalMaybe =<< bufferForFile file1+    cb /== buf+    path === file1
+ test/Ribosome/Test/Error.hs view
@@ -0,0 +1,34 @@+-- |Combinators for aborting tests on Ribosome errors+module Ribosome.Test.Error where++import Polysemy.Test (TestError (TestError))++import Ribosome.Host.Data.Report (Reportable, mapReport, reportMessages)+import Ribosome.Host.Data.RpcHandler (Handler)++-- |Convert the effect @eff@ to @eff '!!' err@ and @'Error' 'TestError'@, failing the test when 'Stop' is used.+resumeTestError ::+  ∀ eff e r .+  Show e =>+  Members [eff !! e, Error TestError] r =>+  InterpreterFor eff r+resumeTestError =+  resumeHoistError (TestError . show)++-- |Convert a 'LogReport' from a 'Handler' to an @'Error' 'TestError'@, failing the test when 'Stop' is used.+testHandler ::+  Member (Error TestError) r =>+  Handler r a ->+  Sem r a+testHandler =+  stopToError . mapStop (TestError . reportMessages) . raiseUnder++-- |Reinterpret @'Stop' err@ to @'Error' 'TestError'@ if @err@ is an instance of 'Reportable'.+testError ::+  ∀ e r a .+  Reportable e =>+  Member (Error TestError) r =>+  Sem (Stop e : r) a ->+  Sem r a+testError =+  testHandler . mapReport . raiseUnder
+ test/Ribosome/Test/MappingTest.hs view
@@ -0,0 +1,65 @@+module Ribosome.Test.MappingTest where++import Conc (interpretSync)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertJust, (===))+import Polysemy.Time (Seconds (Seconds))++import Ribosome.Api.Buffer (currentBufferContent)+import Ribosome.Data.Mapping (MapMode (MapNormal), Mapping)+import Ribosome.Data.ScratchOptions (ScratchOptions (ScratchOptions))+import qualified Ribosome.Effect.Scratch as Scratch+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Host.Api.Data (nvimFeedkeys, vimCallFunction)+import Ribosome.Host.Data.Execution (Execution (Sync))+import Ribosome.Host.Data.Report (resumeReport)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Handler (rpcCommand, rpcFunction)+import Ribosome.Mapping (mappingFor)+import Ribosome.Test.Wait (assertWait)+import Ribosome.Unit.Run (runTest, testHandlers)++target :: [Text]+target = ["line 1", "line 2"]++mappingHandler ::+  Members [Sync Int, Rpc !! RpcError] r =>+  Handler r ()+mappingHandler =+  void (Sync.putWait (Seconds 5) 13)++setupMappingScratch ::+  Member (Scratch !! RpcError) r =>+  Mapping ->+  Handler r ()+setupMappingScratch mapping = do+  resumeReport (void (Scratch.show target options))+  where+    options =+      ScratchOptions False True False True True True False Nothing Nothing Nothing [] [mapping] Nothing "mappo"++handlers ::+  ∀ r .+  Members [Sync Int, Scratch !! RpcError, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcFunction "Setup" Sync (setupMappingScratch m),+    mapRpc+  ]+  where+    m =+      mappingFor mapRpc "a" [MapNormal] Nothing mempty+    mapRpc =+      rpcCommand "Map" Sync mappingHandler++test_mapping :: UnitTest+test_mapping =+  runTest $ interpretSync $ testHandlers handlers mempty do+    () <- Rpc.sync (vimCallFunction @() "Setup" [])+    assertWait currentBufferContent (target ===)+    Rpc.notify (nvimFeedkeys "a" "x" False)+    assertJust (13 :: Int) =<< Sync.wait (Seconds 5)
+ test/Ribosome/Test/PathTest.hs view
@@ -0,0 +1,16 @@+module Ribosome.Test.PathTest where++import Path (reldir)+import qualified Polysemy.Test as Test+import Polysemy.Test (UnitTest, assertEq)++import Ribosome.Api.Path (nvimDir, nvimSetCwd)+import Ribosome.Host.Test.Run (embedTest_)+import Ribosome.Test.Error (testHandler)++test_nvimPath :: UnitTest+test_nvimPath =+  embedTest_ $ testHandler do+    dir <- Test.tempDir [reldir|path|]+    nvimSetCwd dir+    assertEq dir =<< nvimDir ""
+ test/Ribosome/Test/PersistTest.hs view
@@ -0,0 +1,31 @@+module Ribosome.Test.PersistTest where++import Path (reldir)+import qualified Polysemy.Test as Test+import Polysemy.Test (UnitTest, assertJust)++import qualified Ribosome.Effect.Persist as Persist+import Ribosome.Host.Test.Run (embedTest_)+import Ribosome.Interpreter.Persist (interpretPersist)+import Ribosome.Interpreter.PersistPath (interpretPersistPathAt)+import Ribosome.Test.Error (resumeTestError)++data Thing =+  Thing {+    number :: Int,+    name :: Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++thing :: Thing+thing =+  Thing 13 "thingo"++test_persist :: UnitTest+test_persist =+  embedTest_ do+    dir <- Test.tempDir [reldir|persist|]+    interpretPersistPathAt False dir $ interpretPersist "thing" $ resumeTestError do+      Persist.store Nothing thing+      assertJust thing =<< Persist.load Nothing
+ test/Ribosome/Test/ScratchTest.hs view
@@ -0,0 +1,90 @@+module Ribosome.Test.ScratchTest where++import Polysemy.Test (UnitTest, assertEq, unitTest)+import Test.Tasty (TestTree, testGroup)++import Ribosome.Api.Buffer (currentBufferContent)+import Ribosome.Data.FloatOptions (FloatOptions (FloatOptions), FloatRelative (Cursor))+import Ribosome.Data.ScratchId (ScratchId)+import Ribosome.Data.ScratchOptions (ScratchOptions (ScratchOptions))+import qualified Ribosome.Effect.Scratch as Scratch+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Host.Api.Data (nvimCommand)+import Ribosome.Host.Api.Effect (vimCallFunction)+import Ribosome.Host.Data.Execution (Execution (Sync))+import Ribosome.Host.Data.Report (resumeReport)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Handler (rpcFunction)+import Ribosome.Test.Wait (assertWait)+import Ribosome.Unit.Run (runTestHandlers)++target :: [Text]+target = ["line 1", "line 2"]++name :: ScratchId+name =+  "buffi"++makeScratch ::+  Member (Scratch !! RpcError) r =>+  Handler r ()+makeScratch =+  resumeReport (void (Scratch.show target options))+  where+    options =+      ScratchOptions False True False True True True False Nothing Nothing Nothing [] [] Nothing name++floatOptions :: FloatOptions+floatOptions =+  FloatOptions Cursor 30 2 1 1 True def Nothing def False True (Just def) Nothing++makeFloatScratch ::+  Member (Scratch !! RpcError) r =>+  Handler r ()+makeFloatScratch =+  resumeReport (void (Scratch.show target options))+  where+    options =+      ScratchOptions False True False True True True False (Just floatOptions) Nothing (Just 0) [] [] Nothing name++scratchCount ::+  Member (Scratch !! RpcError) r =>+  Sem r Int+scratchCount =+  (-1) <! (length <$> Scratch.get)++handlers ::+  ∀ r .+  Member (Scratch !! RpcError) r =>+  [RpcHandler r]+handlers =+  [+    rpcFunction "MakeFloatScratch" Sync makeFloatScratch,+    rpcFunction "MakeScratch" Sync makeScratch+  ]++scratchTest :: Text -> UnitTest+scratchTest fun = do+  runTestHandlers handlers mempty do+    () <- vimCallFunction fun []+    assertWait scratchCount (assertEq (1 :: Int))+    assertWait currentBufferContent (assertEq target)+    Rpc.notify (nvimCommand "bdelete")+    assertWait scratchCount (assertEq 0)++test_regularScratch :: UnitTest+test_regularScratch = do+  scratchTest "MakeScratch"++test_floatScratch :: UnitTest+test_floatScratch = do+  scratchTest "MakeFloatScratch"++test_scratch :: TestTree+test_scratch =+  testGroup "scratch" [+    unitTest "regular window" test_regularScratch,+    unitTest "float window" test_floatScratch+  ]
+ test/Ribosome/Test/SettingTest.hs view
@@ -0,0 +1,56 @@+module Ribosome.Test.SettingTest where++import Exon (exon)+import Polysemy.Test (TestError (TestError), UnitTest, assertEq, unitTest, (===))+import Test.Tasty (TestTree, testGroup)++import Ribosome.Data.Setting (Setting (Setting))+import qualified Ribosome.Data.SettingError as SettingError+import Ribosome.Data.SettingError (SettingError)+import qualified Ribosome.Effect.Settings as Settings+import Ribosome.Effect.Settings (Settings)+import Ribosome.Host.Api.Effect (nvimSetVar)+import Ribosome.Test.Error (resumeTestError)+import Ribosome.Unit.Run (runTestRibosome)++setting :: Setting Int+setting =+  Setting "name" True Nothing++settingDefault :: Setting Int+settingDefault =+  Setting "name" True (Just 13)++test_settingUpdate :: UnitTest+test_settingUpdate =+  runTestRibosome do+    resumeTestError @Settings do+      Settings.update setting 5+      r <- Settings.get setting+      5 === r++test_settingUnset :: UnitTest+test_settingUnset =+  runTestRibosome do+    resumeEither @SettingError (Settings.get setting) >>= \case+      Left (SettingError.Unset _) -> unit+      Right _ -> throw "Unset setting didn't produce error"+      e -> throw (TestError [exon|Invalid setting error for unset: #{show e}|])+    assertEq 13 =<< resumeTestError @Settings (Settings.get settingDefault)++test_settingDecodeError :: UnitTest+test_settingDecodeError =+  runTestRibosome do+    nvimSetVar "test_name" (["text"] :: [Text])+    resumeEither @SettingError (Settings.get setting) >>= \case+      Left (SettingError.Decode _ _) -> unit+      Right _ -> throw "Invalid setting didn't produce error"+      e -> throw (TestError [exon|Invalid setting error for decode error: #{show e}|])++test_settings :: TestTree+test_settings =+  testGroup "settings" [+    unitTest "update" test_settingUpdate,+    unitTest "unset" test_settingUnset,+    unitTest "decode error" test_settingDecodeError+  ]
+ test/Ribosome/Test/UndoTest.hs view
@@ -0,0 +1,25 @@+module Ribosome.Test.UndoTest where++import Polysemy.Test (UnitTest, assertEq)++import Ribosome.Api.Buffer (currentBufferContent, setCurrentBufferContent)+import Ribosome.Api.Register (setregLine, unnamedRegister)+import Ribosome.Api.Window (setCurrentCursor)+import Ribosome.Host.Api.Effect (nvimCommand)+import Ribosome.Host.Test.Run (embedTest_)++test_undo :: UnitTest+test_undo =+  embedTest_ do+    setCurrentBufferContent orig+    setCurrentCursor 1 0+    setregLine unnamedRegister new+    nvimCommand "normal! p"+    assertEq (orig <> new) =<< currentBufferContent+    nvimCommand "undo"+    assertEq orig =<< currentBufferContent+  where+    orig =+      ["line1", "line2"]+    new =+      ["new1", "new2"]
+ test/Ribosome/Test/Wait.hs view
@@ -0,0 +1,53 @@+-- |Assertions that are made repeatedly until the succeed+module Ribosome.Test.Wait where++import Hedgehog.Internal.Property (Failure, failWith, liftTest, mkTest)+import qualified Conc+import Conc (interpretAtomic)+import Polysemy.Test (Hedgehog, liftH)+import qualified Polysemy.Time as Time+import Polysemy.Time (MilliSeconds (MilliSeconds), Seconds (Seconds))++-- |Run an action and make an assertion about its result.+-- Repeat on failure until the @timeout@ has been exceeded.+--+-- Sleeps for @interval@ between attempts.+assertWaitFor ::+  Monad m =>+  HasCallStack =>+  Members [Hedgehog m, Time t d, Race, Error Failure, Embed IO] r =>+  TimeUnit t1 =>+  TimeUnit t2 =>+  t1 ->+  t2 ->+  Sem r a ->+  (a -> Sem r b) ->+  Sem r b+assertWaitFor timeout interval acquire test =+  withFrozenCallStack do+    interpretAtomic Nothing do+      Conc.timeout_ timeoutError timeout spin+  where+    spin = do+      a <- raise acquire+      catch (raise (test a)) \ e -> do+        atomicPut (Just e)+        Time.sleep interval+        spin+    timeoutError =+      atomicGet >>= liftH . \case+        Just e -> liftTest (mkTest (Left e, mempty))+        Nothing -> failWith Nothing "timed out before an assertion was made"++-- |Run an action and make an assertion about its result.+-- Repeat on failure for three seconds, every 100 milliseconds.+assertWait ::+  Monad m =>+  HasCallStack =>+  Members [Hedgehog m, Time t d, Race, Error Failure, Embed IO] r =>+  Sem r a ->+  (a -> Sem r b) ->+  Sem r b+assertWait acquire test =+  withFrozenCallStack do+    assertWaitFor (Seconds 3) (MilliSeconds 100) acquire test
+ test/Ribosome/Test/WatcherTest.hs view
@@ -0,0 +1,35 @@+module Ribosome.Test.WatcherTest where++import Conc (interpretAtomic)+import Data.MessagePack (Object)+import Polysemy.Test (UnitTest, (===))++import Ribosome.Api.Autocmd (doautocmd)+import Ribosome.Host.Api.Effect (nvimSetVar)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Test.Wait (assertWait)+import Ribosome.Unit.Run (runTest, testHandlers)++changed ::+  Members [AtomicState Int, Rpc !! RpcError, Stop Report] r =>+  Object ->+  Sem r ()+changed _ =+  atomicModify' (+ 1)++test_varWatcher :: UnitTest+test_varWatcher =+  runTest $ interpretAtomic 0 $ testHandlers mempty [("trigger", changed)] do+    nvimSetVar "trigger" (4 :: Int)+    doautocmd "CmdlineLeave"+    assertWait atomicGet ((1 :: Int) ===)+    nvimSetVar "trigger" (5 :: Int)+    doautocmd "CmdlineLeave"+    doautocmd "CmdlineLeave"+    doautocmd "CmdlineLeave"+    assertWait atomicGet ((2 :: Int) ===)+    nvimSetVar "trigger" (6 :: Int)+    doautocmd "CmdlineLeave"+    assertWait atomicGet ((3 :: Int) ===)
+ test/Ribosome/Test/WindowTest.hs view
@@ -0,0 +1,48 @@+module Ribosome.Test.WindowTest where++import Polysemy.Test (UnitTest, assertEq, unitTest, (===))+import Test.Tasty (TestTree, testGroup)++import Ribosome.Api.Window (ensureMainWindow)+import Ribosome.Host.Api.Data (Window)+import Ribosome.Host.Api.Effect (bufferSetOption, nvimCommand, vimGetCurrentBuffer, vimGetCurrentWindow, vimGetWindows)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Test.Run (embedTest_)++setCurrentNofile ::+  Member Rpc r =>+  Sem r ()+setCurrentNofile = do+  buf <- vimGetCurrentBuffer+  bufferSetOption buf "buftype" (toMsgpack ("nofile" :: Text))++createNofile ::+  Member Rpc r =>+  Sem r Window+createNofile = do+  initialWindow <- vimGetCurrentWindow+  nvimCommand "new"+  setCurrentNofile+  pure initialWindow++test_findMainWindowExisting :: UnitTest+test_findMainWindowExisting =+  embedTest_ do+    initialWindow <- createNofile+    (initialWindow ===) =<< ensureMainWindow++test_findMainWindowCreate :: UnitTest+test_findMainWindowCreate =+  embedTest_ do+    setCurrentNofile+    void createNofile+    void ensureMainWindow+    assertEq 3 . length =<< vimGetWindows++test_window :: TestTree+test_window =+  testGroup "window" [+    unitTest "find existing" test_findMainWindowExisting,+    unitTest "find create" test_findMainWindowCreate+  ]
+ test/Ribosome/Unit/Run.hs view
@@ -0,0 +1,87 @@+module Ribosome.Unit.Run where++import Data.MessagePack (Object)+import Log (Severity (Trace))+import Polysemy.Test (TestError (TestError), UnitTest)++import Ribosome.Data.PluginName (PluginName)+import Ribosome.Effect.VariableWatcher (WatchedVariable)+import Ribosome.Effect.Scratch (Scratch)+import Ribosome.Effect.Settings (Settings)+import Ribosome.Embed (HandlerEffects, embedPlugin, interpretPluginEmbed)+import Ribosome.Host.Data.HostConfig (setStderr)+import Ribosome.Host.Data.Report (Report, reportMessages)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Error (resumeBootError)+import Ribosome.Host.Interpret (type (|>))+import Ribosome.Host.Interpreter.Handlers (interpretHandlers)+import Ribosome.Host.Test.Data.TestConfig (host)+import qualified Ribosome.Host.Test.Run as Host+import Ribosome.Host.Test.Run (TestStack)+import Ribosome.Interpreter.VariableWatcher (watchVariables)++type HandlerTestStack =+  HandlerEffects ++ Reader PluginName : TestStack++type EmbedEffects =+  [+    Stop Report,+    Scratch,+    Settings,+    Rpc+  ] |> Handlers !! Report++type PluginTestStack =+  EmbedEffects ++ HandlerTestStack++runTest ::+  HasCallStack =>+  Sem HandlerTestStack () ->+  UnitTest+runTest =+  Host.runTest .+  runReader "test" .+  interpretPluginEmbed++runTestTrace ::+  HasCallStack =>+  Sem HandlerTestStack () ->+  UnitTest+runTestTrace =+  Host.runTestConf def { host = setStderr Trace def } .+  runReader "test" .+  interpretPluginEmbed++testHandlers ::+  Members HandlerTestStack r =>+  [RpcHandler r] ->+  Map WatchedVariable (Object -> Handler r ()) ->+  InterpretersFor EmbedEffects r+testHandlers handlers vars =+  watchVariables vars .+  interpretHandlers handlers .+  embedPlugin .+  resumeBootError @Rpc .+  resumeBootError @Settings .+  resumeBootError @Scratch .+  stopToErrorWith (TestError . reportMessages) .+  insertAt @4++runTestHandlers ::+  HasCallStack =>+  [RpcHandler HandlerTestStack] ->+  Map WatchedVariable (Object -> Handler HandlerTestStack ()) ->+  Sem PluginTestStack () ->+  UnitTest+runTestHandlers handlers vars =+  runTest .+  testHandlers handlers vars++runTestRibosome ::+  HasCallStack =>+  Sem PluginTestStack () ->+  UnitTest+runTestRibosome =+  runTestHandlers mempty mempty