diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 -. - -## 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/Prelude.hs b/lib/Prelude.hs deleted file mode 100644 --- a/lib/Prelude.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Prelude ( - module Ribosome.Prelude -) where - -import Ribosome.Prelude diff --git a/lib/Ribosome.hs b/lib/Ribosome.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome.hs @@ -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 Ribosome +-- > import Ribosome.Api +-- > +-- > count :: +-- > Members NvimPlugin r => +-- > Int -> +-- > Handler r Int +-- > count n = do +-- > s <- 0 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 ' - 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 diff --git a/lib/Ribosome/Api/Autocmd.hs b/lib/Ribosome/Api/Autocmd.hs --- a/lib/Ribosome/Api/Autocmd.hs +++ b/lib/Ribosome/Api/Autocmd.hs @@ -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 diff --git a/lib/Ribosome/Api/Buffer.hs b/lib/Ribosome/Api/Buffer.hs --- a/lib/Ribosome/Api/Buffer.hs +++ b/lib/Ribosome/Api/Buffer.hs @@ -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 diff --git a/lib/Ribosome/Api/Data.hs b/lib/Ribosome/Api/Data.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Data.hs @@ -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 diff --git a/lib/Ribosome/Api/Echo.hs b/lib/Ribosome/Api/Echo.hs --- a/lib/Ribosome/Api/Echo.hs +++ b/lib/Ribosome/Api/Echo.hs @@ -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 diff --git a/lib/Ribosome/Api/Exists.hs b/lib/Ribosome/Api/Exists.hs deleted file mode 100644 --- a/lib/Ribosome/Api/Exists.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Api/Function.hs b/lib/Ribosome/Api/Function.hs --- a/lib/Ribosome/Api/Function.hs +++ b/lib/Ribosome/Api/Function.hs @@ -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})|] diff --git a/lib/Ribosome/Api/Input.hs b/lib/Ribosome/Api/Input.hs --- a/lib/Ribosome/Api/Input.hs +++ b/lib/Ribosome/Api/Input.hs @@ -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) diff --git a/lib/Ribosome/Api/Mode.hs b/lib/Ribosome/Api/Mode.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Mode.hs @@ -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 diff --git a/lib/Ribosome/Api/Normal.hs b/lib/Ribosome/Api/Normal.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Normal.hs @@ -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}|] diff --git a/lib/Ribosome/Api/Option.hs b/lib/Ribosome/Api/Option.hs --- a/lib/Ribosome/Api/Option.hs +++ b/lib/Ribosome/Api/Option.hs @@ -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 diff --git a/lib/Ribosome/Api/Path.hs b/lib/Ribosome/Api/Path.hs --- a/lib/Ribosome/Api/Path.hs +++ b/lib/Ribosome/Api/Path.hs @@ -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 diff --git a/lib/Ribosome/Api/Position.hs b/lib/Ribosome/Api/Position.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Position.hs @@ -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)) diff --git a/lib/Ribosome/Api/Process.hs b/lib/Ribosome/Api/Process.hs --- a/lib/Ribosome/Api/Process.hs +++ b/lib/Ribosome/Api/Process.hs @@ -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" [] diff --git a/lib/Ribosome/Api/Register.hs b/lib/Ribosome/Api/Register.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Register.hs @@ -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 diff --git a/lib/Ribosome/Api/Response.hs b/lib/Ribosome/Api/Response.hs deleted file mode 100644 --- a/lib/Ribosome/Api/Response.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Api/Sleep.hs b/lib/Ribosome/Api/Sleep.hs --- a/lib/Ribosome/Api/Sleep.hs +++ b/lib/Ribosome/Api/Sleep.hs @@ -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|] diff --git a/lib/Ribosome/Api/Syntax.hs b/lib/Ribosome/Api/Syntax.hs --- a/lib/Ribosome/Api/Syntax.hs +++ b/lib/Ribosome/Api/Syntax.hs @@ -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)] diff --git a/lib/Ribosome/Api/Tabpage.hs b/lib/Ribosome/Api/Tabpage.hs --- a/lib/Ribosome/Api/Tabpage.hs +++ b/lib/Ribosome/Api/Tabpage.hs @@ -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}|] diff --git a/lib/Ribosome/Api/Undo.hs b/lib/Ribosome/Api/Undo.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Api/Undo.hs @@ -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" diff --git a/lib/Ribosome/Api/Variable.hs b/lib/Ribosome/Api/Variable.hs deleted file mode 100644 --- a/lib/Ribosome/Api/Variable.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Api/Window.hs b/lib/Ribosome/Api/Window.hs --- a/lib/Ribosome/Api/Window.hs +++ b/lib/Ribosome/Api/Window.hs @@ -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] diff --git a/lib/Ribosome/Cli.hs b/lib/Ribosome/Cli.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Cli.hs @@ -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 diff --git a/lib/Ribosome/Config/Setting.hs b/lib/Ribosome/Config/Setting.hs deleted file mode 100644 --- a/lib/Ribosome/Config/Setting.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Config/Settings.hs b/lib/Ribosome/Config/Settings.hs deleted file mode 100644 --- a/lib/Ribosome/Config/Settings.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/Concurrent/Wait.hs b/lib/Ribosome/Control/Concurrent/Wait.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Concurrent/Wait.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/Exception.hs b/lib/Ribosome/Control/Exception.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Exception.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/Lock.hs b/lib/Ribosome/Control/Lock.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Lock.hs +++ /dev/null @@ -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 () diff --git a/lib/Ribosome/Control/Monad/Error.hs b/lib/Ribosome/Control/Monad/Error.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Monad/Error.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/Monad/Ribo.hs b/lib/Ribosome/Control/Monad/Ribo.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Monad/Ribo.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/Ribosome.hs b/lib/Ribosome/Control/Ribosome.hs deleted file mode 100644 --- a/lib/Ribosome/Control/Ribosome.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Control/StrictRibosome.hs b/lib/Ribosome/Control/StrictRibosome.hs deleted file mode 100644 --- a/lib/Ribosome/Control/StrictRibosome.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Data/CliConfig.hs b/lib/Ribosome/Data/CliConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/CliConfig.hs @@ -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) diff --git a/lib/Ribosome/Data/Conduit.hs b/lib/Ribosome/Data/Conduit.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Conduit.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Data/Conduit/Composition.hs b/lib/Ribosome/Data/Conduit/Composition.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Conduit/Composition.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Data/CustomConfig.hs b/lib/Ribosome/Data/CustomConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/CustomConfig.hs @@ -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) diff --git a/lib/Ribosome/Data/ErrorReport.hs b/lib/Ribosome/Data/ErrorReport.hs deleted file mode 100644 --- a/lib/Ribosome/Data/ErrorReport.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Data/Errors.hs b/lib/Ribosome/Data/Errors.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Errors.hs +++ /dev/null @@ -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') diff --git a/lib/Ribosome/Data/FileBuffer.hs b/lib/Ribosome/Data/FileBuffer.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/FileBuffer.hs @@ -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) diff --git a/lib/Ribosome/Data/FloatOptions.hs b/lib/Ribosome/Data/FloatOptions.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/FloatOptions.hs @@ -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 diff --git a/lib/Ribosome/Data/Foldable.hs b/lib/Ribosome/Data/Foldable.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Foldable.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Data/Mapping.hs b/lib/Ribosome/Data/Mapping.hs --- a/lib/Ribosome/Data/Mapping.hs +++ b/lib/Ribosome/Data/Mapping.hs @@ -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) diff --git a/lib/Ribosome/Data/Maybe.hs b/lib/Ribosome/Data/Maybe.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Maybe.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Ribosome.Data.Maybe( - orElse, -) where - -orElse :: Maybe a -> Maybe a -> Maybe a -orElse fallback Nothing = fallback -orElse _ a = a diff --git a/lib/Ribosome/Data/Mode.hs b/lib/Ribosome/Data/Mode.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/Mode.hs @@ -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) diff --git a/lib/Ribosome/Data/PersistError.hs b/lib/Ribosome/Data/PersistError.hs --- a/lib/Ribosome/Data/PersistError.hs +++ b/lib/Ribosome/Data/PersistError.hs @@ -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 diff --git a/lib/Ribosome/Data/PersistPathError.hs b/lib/Ribosome/Data/PersistPathError.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/PersistPathError.hs @@ -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}'|] diff --git a/lib/Ribosome/Data/PluginConfig.hs b/lib/Ribosome/Data/PluginConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/PluginConfig.hs @@ -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 diff --git a/lib/Ribosome/Data/PluginName.hs b/lib/Ribosome/Data/PluginName.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/PluginName.hs @@ -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) diff --git a/lib/Ribosome/Data/Register.hs b/lib/Ribosome/Data/Register.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/Register.hs @@ -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) diff --git a/lib/Ribosome/Data/RegisterType.hs b/lib/Ribosome/Data/RegisterType.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/RegisterType.hs @@ -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 -> + "" + BlockWidth width -> + "" <> pretty width + Unknown a -> + pretty a diff --git a/lib/Ribosome/Data/Scratch.hs b/lib/Ribosome/Data/Scratch.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Scratch.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Data/ScratchId.hs b/lib/Ribosome/Data/ScratchId.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/ScratchId.hs @@ -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) diff --git a/lib/Ribosome/Data/ScratchOptions.hs b/lib/Ribosome/Data/ScratchOptions.hs --- a/lib/Ribosome/Data/ScratchOptions.hs +++ b/lib/Ribosome/Data/ScratchOptions.hs @@ -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" diff --git a/lib/Ribosome/Data/ScratchState.hs b/lib/Ribosome/Data/ScratchState.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/ScratchState.hs @@ -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) diff --git a/lib/Ribosome/Data/Setting.hs b/lib/Ribosome/Data/Setting.hs --- a/lib/Ribosome/Data/Setting.hs +++ b/lib/Ribosome/Data/Setting.hs @@ -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 } diff --git a/lib/Ribosome/Data/SettingError.hs b/lib/Ribosome/Data/SettingError.hs --- a/lib/Ribosome/Data/SettingError.hs +++ b/lib/Ribosome/Data/SettingError.hs @@ -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 diff --git a/lib/Ribosome/Data/String.hs b/lib/Ribosome/Data/String.hs deleted file mode 100644 --- a/lib/Ribosome/Data/String.hs +++ /dev/null @@ -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' diff --git a/lib/Ribosome/Data/Syntax.hs b/lib/Ribosome/Data/Syntax.hs --- a/lib/Ribosome/Data/Syntax.hs +++ b/lib/Ribosome/Data/Syntax.hs @@ -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) diff --git a/lib/Ribosome/Data/Text.hs b/lib/Ribosome/Data/Text.hs deleted file mode 100644 --- a/lib/Ribosome/Data/Text.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Data/WindowConfig.hs b/lib/Ribosome/Data/WindowConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/WindowConfig.hs @@ -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) diff --git a/lib/Ribosome/Data/WindowView.hs b/lib/Ribosome/Data/WindowView.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Data/WindowView.hs @@ -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 diff --git a/lib/Ribosome/Effect/Persist.hs b/lib/Ribosome/Effect/Persist.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Effect/Persist.hs @@ -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 diff --git a/lib/Ribosome/Effect/PersistPath.hs b/lib/Ribosome/Effect/PersistPath.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Effect/PersistPath.hs @@ -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) diff --git a/lib/Ribosome/Effect/Scratch.hs b/lib/Ribosome/Effect/Scratch.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Effect/Scratch.hs @@ -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 diff --git a/lib/Ribosome/Effect/Settings.hs b/lib/Ribosome/Effect/Settings.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Effect/Settings.hs @@ -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 + Member (Settings !! SettingError) r => + Setting a -> + Sem r (Maybe a) +maybe s = + Nothing get s) diff --git a/lib/Ribosome/Effect/VariableWatcher.hs b/lib/Ribosome/Effect/VariableWatcher.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Effect/VariableWatcher.hs @@ -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 () diff --git a/lib/Ribosome/Embed.hs b/lib/Ribosome/Embed.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Embed.hs @@ -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 diff --git a/lib/Ribosome/Error/Report.hs b/lib/Ribosome/Error/Report.hs deleted file mode 100644 --- a/lib/Ribosome/Error/Report.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Error/Report/Class.hs b/lib/Ribosome/Error/Report/Class.hs deleted file mode 100644 --- a/lib/Ribosome/Error/Report/Class.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Examples/Example1.hs b/lib/Ribosome/Examples/Example1.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Examples/Example1.hs @@ -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 + Object -> + Handler r () +changed value = + ignoreRpcError (echo ("Update value to: " <> show value)) + +main :: IO () +main = + runRemoteStack "watch-plugin" (watchVariables [("trigger", changed)] remotePlugin) diff --git a/lib/Ribosome/Examples/Example3.hs b/lib/Ribosome/Examples/Example3.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Examples/Example3.hs @@ -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" [] diff --git a/lib/Ribosome/File.hs b/lib/Ribosome/File.hs deleted file mode 100644 --- a/lib/Ribosome/File.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Final.hs b/lib/Ribosome/Final.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Final.hs @@ -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)) diff --git a/lib/Ribosome/Float.hs b/lib/Ribosome/Float.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Float.hs @@ -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 (..), + ) diff --git a/lib/Ribosome/IOStack.hs b/lib/Ribosome/IOStack.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/IOStack.hs @@ -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 diff --git a/lib/Ribosome/Internal/IO.hs b/lib/Ribosome/Internal/IO.hs deleted file mode 100644 --- a/lib/Ribosome/Internal/IO.hs +++ /dev/null @@ -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 () diff --git a/lib/Ribosome/Internal/NvimObject.hs b/lib/Ribosome/Internal/NvimObject.hs deleted file mode 100644 --- a/lib/Ribosome/Internal/NvimObject.hs +++ /dev/null @@ -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' diff --git a/lib/Ribosome/Internal/Path.hs b/lib/Ribosome/Internal/Path.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Internal/Path.hs @@ -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 diff --git a/lib/Ribosome/Internal/Scratch.hs b/lib/Ribosome/Internal/Scratch.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Internal/Scratch.hs @@ -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 diff --git a/lib/Ribosome/Internal/Syntax.hs b/lib/Ribosome/Internal/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Internal/Syntax.hs @@ -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 diff --git a/lib/Ribosome/Interpreter/Persist.hs b/lib/Ribosome/Interpreter/Persist.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/Persist.hs @@ -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 @.json@ is used. +-- +-- - When invoked with 'Just' a subpath, a file named @/.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 diff --git a/lib/Ribosome/Interpreter/PersistPath.hs b/lib/Ribosome/Interpreter/PersistPath.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/PersistPath.hs @@ -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 diff --git a/lib/Ribosome/Interpreter/PluginName.hs b/lib/Ribosome/Interpreter/PluginName.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/PluginName.hs @@ -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 diff --git a/lib/Ribosome/Interpreter/Scratch.hs b/lib/Ribosome/Interpreter/Scratch.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/Scratch.hs @@ -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 diff --git a/lib/Ribosome/Interpreter/Settings.hs b/lib/Ribosome/Interpreter/Settings.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/Settings.hs @@ -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) diff --git a/lib/Ribosome/Interpreter/UserError.hs b/lib/Ribosome/Interpreter/UserError.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/UserError.hs @@ -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 diff --git a/lib/Ribosome/Interpreter/VariableWatcher.hs b/lib/Ribosome/Interpreter/VariableWatcher.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Interpreter/VariableWatcher.hs @@ -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 diff --git a/lib/Ribosome/Lens.hs b/lib/Ribosome/Lens.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Lens.hs @@ -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 (<|>~) #-} diff --git a/lib/Ribosome/Log.hs b/lib/Ribosome/Log.hs deleted file mode 100644 --- a/lib/Ribosome/Log.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Mapping.hs b/lib/Ribosome/Mapping.hs --- a/lib/Ribosome/Mapping.hs +++ b/lib/Ribosome/Mapping.hs @@ -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}|] 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 @@ 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, "", lhs, ":call", func name <> "('" <> ident <> "')"] - 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) diff --git a/lib/Ribosome/Menu/Data/Menu.hs b/lib/Ribosome/Menu/Data/Menu.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/Menu.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Data/MenuAction.hs b/lib/Ribosome/Menu/Data/MenuAction.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuAction.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Data/MenuConfig.hs b/lib/Ribosome/Menu/Data/MenuConfig.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuConfig.hs +++ /dev/null @@ -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 - } diff --git a/lib/Ribosome/Menu/Data/MenuConsumer.hs b/lib/Ribosome/Menu/Data/MenuConsumer.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuConsumer.hs +++ /dev/null @@ -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) } diff --git a/lib/Ribosome/Menu/Data/MenuConsumerAction.hs b/lib/Ribosome/Menu/Data/MenuConsumerAction.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuConsumerAction.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Ribosome.Menu.Data.MenuConsumerAction where - -data MenuConsumerAction m a = - Quit - | - QuitWith (m a) - | - Continue - | - Render Bool - | - Return a diff --git a/lib/Ribosome/Menu/Data/MenuConsumerUpdate.hs b/lib/Ribosome/Menu/Data/MenuConsumerUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuConsumerUpdate.hs +++ /dev/null @@ -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 - } diff --git a/lib/Ribosome/Menu/Data/MenuEvent.hs b/lib/Ribosome/Menu/Data/MenuEvent.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuEvent.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Data/MenuItem.hs b/lib/Ribosome/Menu/Data/MenuItem.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuItem.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Data/MenuRenderEvent.hs b/lib/Ribosome/Menu/Data/MenuRenderEvent.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuRenderEvent.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Data/MenuResult.hs b/lib/Ribosome/Menu/Data/MenuResult.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuResult.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Ribosome.Menu.Data.MenuResult where - -data MenuResult a = - NoOutput - | - Error Text - | - Executed - | - Aborted - | - Return a - deriving (Eq, Show) diff --git a/lib/Ribosome/Menu/Data/MenuUpdate.hs b/lib/Ribosome/Menu/Data/MenuUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Data/MenuUpdate.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Nvim.hs b/lib/Ribosome/Menu/Nvim.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Nvim.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Prompt/Data/Codes.hs b/lib/Ribosome/Menu/Prompt/Data/Codes.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/Codes.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Prompt/Data/CursorUpdate.hs b/lib/Ribosome/Menu/Prompt/Data/CursorUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/CursorUpdate.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Ribosome.Menu.Prompt.Data.CursorUpdate where - -data CursorUpdate = - Unmodified - | - OneLeft - | - OneRight - | - Append - | - Prepend - | - Index Int - deriving (Eq, Show) diff --git a/lib/Ribosome/Menu/Prompt/Data/InputEvent.hs b/lib/Ribosome/Menu/Prompt/Data/InputEvent.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/InputEvent.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Ribosome.Menu.Prompt.Data.InputEvent where - -data InputEvent = - Character Text - | - NoInput - | - Unexpected Int - | - Interrupt - | - Error Text - deriving (Eq, Show) diff --git a/lib/Ribosome/Menu/Prompt/Data/Prompt.hs b/lib/Ribosome/Menu/Prompt/Data/Prompt.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/Prompt.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptConfig.hs b/lib/Ribosome/Menu/Prompt/Data/PromptConfig.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptConfig.hs +++ /dev/null @@ -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 - } diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptConsumed.hs b/lib/Ribosome/Menu/Prompt/Data/PromptConsumed.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptConsumed.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Ribosome.Menu.Prompt.Data.PromptConsumed where - -data PromptConsumed = - Yes - | - No - deriving (Eq, Show) diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptConsumerUpdate.hs b/lib/Ribosome/Menu/Prompt/Data/PromptConsumerUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptConsumerUpdate.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptEvent.hs b/lib/Ribosome/Menu/Prompt/Data/PromptEvent.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptEvent.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptRenderer.hs b/lib/Ribosome/Menu/Prompt/Data/PromptRenderer.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptRenderer.hs +++ /dev/null @@ -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 () - } diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptState.hs b/lib/Ribosome/Menu/Prompt/Data/PromptState.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptState.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Ribosome.Menu.Prompt.Data.PromptState where - -data PromptState = - Insert - | - Normal - | - Quit - deriving (Eq, Show) - -deepLenses ''PromptState diff --git a/lib/Ribosome/Menu/Prompt/Data/PromptUpdate.hs b/lib/Ribosome/Menu/Prompt/Data/PromptUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/PromptUpdate.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Prompt/Data/TextUpdate.hs b/lib/Ribosome/Menu/Prompt/Data/TextUpdate.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Data/TextUpdate.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Ribosome.Menu.Prompt.Data.TextUpdate where - -data TextUpdate = - Unmodified - | - Insert Text - | - DeleteLeft - | - DeleteRight - deriving (Eq, Show) diff --git a/lib/Ribosome/Menu/Prompt/Nvim.hs b/lib/Ribosome/Menu/Prompt/Nvim.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Nvim.hs +++ /dev/null @@ -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 <> "()\\\")" - --- 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 diff --git a/lib/Ribosome/Menu/Prompt/Run.hs b/lib/Ribosome/Menu/Prompt/Run.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Prompt/Run.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Menu/Run.hs b/lib/Ribosome/Menu/Run.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Run.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Menu/Simple.hs b/lib/Ribosome/Menu/Simple.hs deleted file mode 100644 --- a/lib/Ribosome/Menu/Simple.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Msgpack/Decode.hs b/lib/Ribosome/Msgpack/Decode.hs deleted file mode 100644 --- a/lib/Ribosome/Msgpack/Decode.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Msgpack/Encode.hs b/lib/Ribosome/Msgpack/Encode.hs deleted file mode 100644 --- a/lib/Ribosome/Msgpack/Encode.hs +++ /dev/null @@ -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] diff --git a/lib/Ribosome/Msgpack/Error.hs b/lib/Ribosome/Msgpack/Error.hs deleted file mode 100644 --- a/lib/Ribosome/Msgpack/Error.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Msgpack/NvimObject.hs b/lib/Ribosome/Msgpack/NvimObject.hs deleted file mode 100644 --- a/lib/Ribosome/Msgpack/NvimObject.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Msgpack/Util.hs b/lib/Ribosome/Msgpack/Util.hs deleted file mode 100644 --- a/lib/Ribosome/Msgpack/Util.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Nvim/Api/Data.hs b/lib/Ribosome/Nvim/Api/Data.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/Data.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Nvim/Api/Generate.hs b/lib/Ribosome/Nvim/Api/Generate.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/Generate.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Nvim/Api/GenerateData.hs b/lib/Ribosome/Nvim/Api/GenerateData.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/GenerateData.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Nvim/Api/GenerateIO.hs b/lib/Ribosome/Nvim/Api/GenerateIO.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/GenerateIO.hs +++ /dev/null @@ -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 $ []) diff --git a/lib/Ribosome/Nvim/Api/IO.hs b/lib/Ribosome/Nvim/Api/IO.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/IO.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Nvim/Api/RpcCall.hs b/lib/Ribosome/Nvim/Api/RpcCall.hs deleted file mode 100644 --- a/lib/Ribosome/Nvim/Api/RpcCall.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Orphans.hs b/lib/Ribosome/Orphans.hs deleted file mode 100644 --- a/lib/Ribosome/Orphans.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Persist.hs b/lib/Ribosome/Persist.hs --- a/lib/Ribosome/Persist.hs +++ b/lib/Ribosome/Persist.hs @@ -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 diff --git a/lib/Ribosome/Plugin.hs b/lib/Ribosome/Plugin.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin.hs +++ /dev/null @@ -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 } diff --git a/lib/Ribosome/Plugin/Builtin.hs b/lib/Ribosome/Plugin/Builtin.hs --- a/lib/Ribosome/Plugin/Builtin.hs +++ b/lib/Ribosome/Plugin/Builtin.hs @@ -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 diff --git a/lib/Ribosome/Plugin/Mapping.hs b/lib/Ribosome/Plugin/Mapping.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/Mapping.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Plugin/RpcHandler.hs b/lib/Ribosome/Plugin/RpcHandler.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/RpcHandler.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Plugin/TH.hs b/lib/Ribosome/Plugin/TH.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/TH.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Plugin/TH/Command.hs b/lib/Ribosome/Plugin/TH/Command.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/TH/Command.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Plugin/TH/Handler.hs b/lib/Ribosome/Plugin/TH/Handler.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/TH/Handler.hs +++ /dev/null @@ -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") diff --git a/lib/Ribosome/Plugin/Watch.hs b/lib/Ribosome/Plugin/Watch.hs deleted file mode 100644 --- a/lib/Ribosome/Plugin/Watch.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/PluginName.hs b/lib/Ribosome/PluginName.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/PluginName.hs @@ -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)) diff --git a/lib/Ribosome/Prelude.hs b/lib/Ribosome/Prelude.hs deleted file mode 100644 --- a/lib/Ribosome/Prelude.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/PreludeExport.hs b/lib/Ribosome/PreludeExport.hs deleted file mode 100644 --- a/lib/Ribosome/PreludeExport.hs +++ /dev/null @@ -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) diff --git a/lib/Ribosome/Register.hs b/lib/Ribosome/Register.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Register.hs @@ -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 (..)) diff --git a/lib/Ribosome/Remote.hs b/lib/Ribosome/Remote.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Remote.hs @@ -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) 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) diff --git a/lib/Ribosome/Report.hs b/lib/Ribosome/Report.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Report.hs @@ -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 diff --git a/lib/Ribosome/Run.hs b/lib/Ribosome/Run.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Run.hs @@ -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 + ] diff --git a/lib/Ribosome/Scratch.hs b/lib/Ribosome/Scratch.hs --- a/lib/Ribosome/Scratch.hs +++ b/lib/Ribosome/Scratch.hs @@ -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 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 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 diff --git a/lib/Ribosome/Settings.hs b/lib/Ribosome/Settings.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Settings.hs @@ -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) diff --git a/lib/Ribosome/Socket.hs b/lib/Ribosome/Socket.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Socket.hs @@ -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 diff --git a/lib/Ribosome/Syntax.hs b/lib/Ribosome/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Syntax.hs @@ -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 diff --git a/lib/Ribosome/System/Time.hs b/lib/Ribosome/System/Time.hs deleted file mode 100644 --- a/lib/Ribosome/System/Time.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Text.hs b/lib/Ribosome/Text.hs new file mode 100644 --- /dev/null +++ b/lib/Ribosome/Text.hs @@ -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 diff --git a/lib/Ribosome/Tmux/Run.hs b/lib/Ribosome/Tmux/Run.hs deleted file mode 100644 --- a/lib/Ribosome/Tmux/Run.hs +++ /dev/null @@ -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 diff --git a/lib/Ribosome/Unsafe.hs b/lib/Ribosome/Unsafe.hs deleted file mode 100644 --- a/lib/Ribosome/Unsafe.hs +++ /dev/null @@ -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 diff --git a/ribosome.cabal b/ribosome.cabal --- a/ribosome.cabal +++ b/ribosome.cabal @@ -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 -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Ribosome/Test/BufferTest.hs b/test/Ribosome/Test/BufferTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/BufferTest.hs @@ -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 diff --git a/test/Ribosome/Test/Error.hs b/test/Ribosome/Test/Error.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/Error.hs @@ -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 diff --git a/test/Ribosome/Test/MappingTest.hs b/test/Ribosome/Test/MappingTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/MappingTest.hs @@ -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) diff --git a/test/Ribosome/Test/PathTest.hs b/test/Ribosome/Test/PathTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/PathTest.hs @@ -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 "" diff --git a/test/Ribosome/Test/PersistTest.hs b/test/Ribosome/Test/PersistTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/PersistTest.hs @@ -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 diff --git a/test/Ribosome/Test/ScratchTest.hs b/test/Ribosome/Test/ScratchTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/ScratchTest.hs @@ -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) 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 + ] diff --git a/test/Ribosome/Test/SettingTest.hs b/test/Ribosome/Test/SettingTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/SettingTest.hs @@ -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 + ] diff --git a/test/Ribosome/Test/UndoTest.hs b/test/Ribosome/Test/UndoTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/UndoTest.hs @@ -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"] diff --git a/test/Ribosome/Test/Wait.hs b/test/Ribosome/Test/Wait.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/Wait.hs @@ -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 diff --git a/test/Ribosome/Test/WatcherTest.hs b/test/Ribosome/Test/WatcherTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/WatcherTest.hs @@ -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) ===) diff --git a/test/Ribosome/Test/WindowTest.hs b/test/Ribosome/Test/WindowTest.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Test/WindowTest.hs @@ -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 + ] diff --git a/test/Ribosome/Unit/Run.hs b/test/Ribosome/Unit/Run.hs new file mode 100644 --- /dev/null +++ b/test/Ribosome/Unit/Run.hs @@ -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