packages feed

ribosome-host (empty) → 0.9.9.9

raw patch · 105 files changed

+6464/−0 lines, 105 filesdep +aesondep +basedep +casingsetup-changed

Dependencies added: aeson, base, casing, cereal, chronos, deepseq, exon, first-class-families, flatparse, generics-sop, hedgehog, messagepack, network, optparse-applicative, path, polysemy, polysemy-chronos, polysemy-conc, polysemy-log, polysemy-plugin, polysemy-process, polysemy-test, prelate, ribosome-host, tasty, template-haskell, type-errors-pretty, typed-process

Files

+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2022 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  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.++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:++  (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.++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.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/Ribosome/Host.hs view
@@ -0,0 +1,130 @@+-- Description: The low-level API to Ribosome's core logic+module Ribosome.Host (+  -- * Introduction+  -- $intro++  -- * Execution+  module Ribosome.Host.Embed,+  module Ribosome.Host.Remote,+  module Ribosome.Host.Data.HostConfig,++  -- * Handlers+  module Ribosome.Host.Data.RpcHandler,+  module Ribosome.Host.Data.RpcType,+  module Ribosome.Host.Data.RpcError,+  module Ribosome.Host.Handler,+  module Ribosome.Host.Data.Execution,+  module Ribosome.Host.Data.Args,+  module Ribosome.Host.Data.Bang,+  module Ribosome.Host.Data.Bar,+  module Ribosome.Host.Data.CommandMods,+  module Ribosome.Host.Data.CommandRegister,+  module Ribosome.Host.Data.Range,++  -- * Effects+  module Ribosome.Host.Effect.Handlers,+  module Ribosome.Host.Effect.Host,+  module Ribosome.Host.Effect.MState,+  module Ribosome.Host.Effect.Reports,+  module Ribosome.Host.Effect.Responses,+  module Ribosome.Host.Effect.Rpc,+  module Ribosome.Host.Effect.UserError,++  -- * Interpreters+  module Ribosome.Host.Interpreter.Handlers,+  module Ribosome.Host.Interpreter.Host,+  module Ribosome.Host.Interpreter.Log,+  module Ribosome.Host.Interpreter.MState,+  module Ribosome.Host.Interpreter.Reports,+  module Ribosome.Host.Interpreter.Responses,+  module Ribosome.Host.Interpreter.Rpc,+  module Ribosome.Host.Interpreter.UserError,++  -- * Neovim API+  module Ribosome.Host.Api.Data,++  -- * Messagepack+  module Ribosome.Host.Class.Msgpack.Array,+  module Ribosome.Host.Class.Msgpack.Decode,+  module Ribosome.Host.Class.Msgpack.Encode,+  module Ribosome.Host.Class.Msgpack.Map,++  -- * Errors+  module Ribosome.Host.Data.Report,+  module Ribosome.Host.Error,+  module Ribosome.Host.Data.BootError,+  module Ribosome.Host.Data.StoredReport,+) where++import Ribosome.Host.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Class.Msgpack.Map (msgpackMap)+import Ribosome.Host.Data.Args+import Ribosome.Host.Data.Bang (Bang (Bang, NoBang))+import Ribosome.Host.Data.Bar (Bar (Bar))+import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.CommandMods (CommandMods (CommandMods))+import Ribosome.Host.Data.CommandRegister (CommandRegister (CommandRegister))+import Ribosome.Host.Data.Execution (Execution (Async, Sync))+import Ribosome.Host.Data.HostConfig (HostConfig (..), LogConfig (..), setStderr)+import Ribosome.Host.Data.Range (Range (Range), RangeStyle (..))+import Ribosome.Host.Data.Report (+  LogReport (LogReport),+  Report (Report),+  ReportContext (..),+  Reportable (toReport),+  basicReport,+  mapReport,+  mapReports,+  mapUserMessage,+  resumeHoistUserMessage,+  resumeReport,+  resumeReports,+  toReport,+  userReport,+  )+import Ribosome.Host.Data.RpcError (RpcError, rpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler (RpcHandler), simpleHandler)+import Ribosome.Host.Data.RpcType (CompleteStyle (..))+import Ribosome.Host.Data.StoredReport (StoredReport (StoredReport))+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Host (Host)+import Ribosome.Host.Effect.MState (+  MState,+  ScopedMState,+  mmodify,+  mread,+  mreads,+  mstate,+  mtrans,+  muse,+  stateToMState,+  withMState,+  )+import Ribosome.Host.Effect.Reports (Reports)+import Ribosome.Host.Effect.Responses (Responses)+import Ribosome.Host.Effect.Rpc (Rpc, async, notify, sync)+import Ribosome.Host.Effect.UserError+import Ribosome.Host.Embed (embedNvim, embedNvim_, interpretHostEmbed, testHostEmbed, withHostEmbed)+import Ribosome.Host.Error (ignoreRpcError)+import Ribosome.Host.Handler (completeBuiltin, completeWith, rpc, rpcAutocmd, rpcCommand, rpcFunction)+import Ribosome.Host.Interpreter.Handlers (interpretHandlers, noHandlers, withHandlers)+import Ribosome.Host.Interpreter.Host (HostDeps, interpretHost, runHost, testHost, withHost)+import Ribosome.Host.Interpreter.Log (interpretLogs)+import Ribosome.Host.Interpreter.MState (evalMState, interpretMState, interpretMStates)+import Ribosome.Host.Interpreter.Reports (interpretReports)+import Ribosome.Host.Interpreter.Responses (interpretResponses)+import Ribosome.Host.Interpreter.Rpc (interpretRpc)+import Ribosome.Host.Interpreter.UserError (interpretUserErrorInfo)+import Ribosome.Host.Remote (interpretHostRemote, runHostRemote, runHostRemoteIO)++-- $intro+-- This library is a framework for building [Neovim](https://neovim.io) plugins with+-- [Polysemy](https://hackage.haskell.org/package/polysemy).+--+-- This package is the low-level core of the Neovim plugin host and is not intended for authors who want to build full+-- plugins.+-- Please consult the documentation for the+-- [main package](https://hackage.haskell.org/package/ribosome/docs/Ribosome.html) instead.
+ lib/Ribosome/Host/Api/Autocmd.hs view
@@ -0,0 +1,48 @@+-- |Helpers for defining autocmds.+module Ribosome.Host.Api.Autocmd where++import Data.MessagePack (Object)+import Prelude hiding (group)++import Ribosome.Host.Api.Data (nvimCreateAugroup, nvimCreateAutocmd)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Class.Msgpack.Map (msgpackMap)+import Ribosome.Host.Data.RpcCall (RpcCall)+import Ribosome.Host.Data.RpcType (+  AutocmdBuffer (AutocmdBuffer),+  AutocmdEvents (AutocmdEvents),+  AutocmdGroup (AutocmdGroup),+  AutocmdId (AutocmdId),+  AutocmdOptions (..),+  AutocmdPatterns (AutocmdPatterns),+  )++-- |Create an @augroup@ if the first argument is 'Just', then call the second argument.+--+-- The parameter of the callback is a 'Map' suitable to be passed to 'nvimCreateAutocmd', containing the group name.+withAugroup :: Maybe AutocmdGroup -> (Map Text Object -> RpcCall a) -> RpcCall a+withAugroup (Just (AutocmdGroup g)) f =+  nvimCreateAugroup g [("clear", toMsgpack False)] *> f [("group", toMsgpack g)]+withAugroup Nothing f =+  f mempty++-- |Create an autocmd.+autocmd ::+  -- |Trigger events.+  AutocmdEvents ->+  -- |Options as defined for @:autocmd@.+  AutocmdOptions ->+  -- |The command to execute.+  Text ->+  RpcCall AutocmdId+autocmd (AutocmdEvents events) AutocmdOptions {..} cmd =+  withAugroup group \ grp -> AutocmdId <$> nvimCreateAutocmd events (opts <> bufPat <> grp)+  where+    opts =+      msgpackMap ("command", cmd) ("once", once) ("nested", nested)+    bufPat =+      either  bufOpt patternOpt target+    patternOpt (AutocmdPatterns pat) =+      [("pattern", toMsgpack pat)]+    bufOpt (AutocmdBuffer buf) =+      [("buffer", toMsgpack buf)]
+ lib/Ribosome/Host/Api/Data.hs view
@@ -0,0 +1,7 @@+{-# options_haddock prune #-}++module Ribosome.Host.Api.Data where++import Ribosome.Host.TH.Api.GenerateData (generateData)++generateData
+ lib/Ribosome/Host/Api/Effect.hs view
@@ -0,0 +1,9 @@+{-# options_haddock prune #-}++module Ribosome.Host.Api.Effect where++import qualified Ribosome.Host.Api.Data as RpcData+import Ribosome.Host.Api.Data (Buffer, Tabpage, Window)+import Ribosome.Host.TH.Api.GenerateEffect (generateEffect)++generateEffect
+ lib/Ribosome/Host/Api/Event.hs view
@@ -0,0 +1,18 @@+module Ribosome.Host.Api.Event where++import Ribosome.Host.Api.Data (Buffer)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack)+import Ribosome.Host.Data.Event (Event (Event))++pattern BufLinesEvent :: Buffer -> Maybe Int -> Int -> Int -> [Text] -> Bool -> Event+pattern BufLinesEvent {buffer, changedtick, firstline, lastline, linedata, more} <- Event "nvim_buf_lines_event" [+  Msgpack buffer,+  Msgpack changedtick,+  Msgpack firstline,+  Msgpack lastline,+  Msgpack linedata,+  Msgpack more+  ] where+    BufLinesEvent b c f l ld m =+      Event "nvim_buf_lines_event" (msgpackArray b c f l ld m)
+ lib/Ribosome/Host/Class/Msgpack/Array.hs view
@@ -0,0 +1,48 @@+-- |Helper for encoding values to a heterogeneous MessagePack array.+module Ribosome.Host.Class.Msgpack.Array where++import Data.MessagePack (Object)+import Data.Sequence ((|>))++import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))++newtype Acc =+  Acc { unAcc :: Seq Object }+  deriving stock (Eq, Show)++-- |This class provides a variadic method for encoding MessagePack arrays.+class MsgpackArray a where+  -- |Encode an arbitrary number of heterogeneously typed values to a single MessagePack array.+  -- This function is variadic, meaning that it takes an arbitrary number of arguments:+  --+  -- >>> msgpackArray (5 :: Int) ("error" :: Text) (3.14 :: Double) :: Object+  -- ObjectArray [ObjectInt 5, ObjectString "error", ObjectFloat 3.14]+  --+  -- This avoids the need to call 'Ribosome.toMsgpack' once for each element and then once more for the array.+  msgpackArray :: a++instance MsgpackArray (Acc -> [Object]) where+  msgpackArray =+    toList . unAcc++instance MsgpackArray (Acc -> Object) where+  msgpackArray =+    toMsgpack . unAcc++instance MsgpackArray (a -> a) where+  msgpackArray =+    id++instance (+    MsgpackEncode a,+    MsgpackArray (Acc -> b)+  ) => MsgpackArray (Acc -> a -> b) where+  msgpackArray (Acc m) a =+    msgpackArray @(Acc -> b) (Acc (m |> toMsgpack a))++instance {-# overlappable #-} (+    MsgpackEncode a,+    MsgpackArray (Acc -> b)+  ) => MsgpackArray (a -> b) where+  msgpackArray a =+    msgpackArray @(Acc -> b) (Acc [toMsgpack a])
+ lib/Ribosome/Host/Class/Msgpack/Decode.hs view
@@ -0,0 +1,322 @@+{-# options_haddock prune #-}++-- |Decoding values from MessagePack format+module Ribosome.Host.Class.Msgpack.Decode where++import qualified Data.Map.Strict as Map (empty, fromList, toList)+import Data.MessagePack (Object (..))+import Exon (exon)+import GHC.Float (double2Float, float2Double)+import GHC.Generics (+  C1,+  Constructor,+  D1,+  K1 (..),+  M1 (..),+  Rep,+  S1,+  Selector,+  conIsRecord,+  selName,+  to,+  (:*:) (..),+  (:+:) (..),+  )+import Path (Abs, Dir, File, Path, Rel, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile)+import Prelude hiding (to)+import Time (MicroSeconds, MilliSeconds, NanoSeconds, Seconds (Seconds))++import qualified Ribosome.Host.Class.Msgpack.Util as Util (illegalType, invalid, lookupObjectMap, missingRecordKey)++-- |Class of values that can be decoded from MessagePack 'Object's.+class MsgpackDecode a where+  -- |Attempt to decode an 'Object', returning an error message in a 'Left' if the data is incompatible.+  --+  -- The default implementation uses generic derivation.+  fromMsgpack :: Object -> Either Text a+  default fromMsgpack :: (Generic a, GMsgpackDecode (Rep a)) => Object -> Either Text a+  fromMsgpack = fmap to . gMsgpackDecode++  -- |Utility method called by the generic machinery when a record key is missing.+  missingKey :: String -> Object -> Either Text a+  missingKey = Util.missingRecordKey++-- |Pattern synonym for decoding an 'Object'.+pattern Msgpack :: ∀ a . MsgpackDecode a => a -> Object+pattern Msgpack a <- (fromMsgpack -> Right a)++class GMsgpackDecode f where+  gMsgpackDecode :: Object -> Either Text (f a)++  gMissingKey :: String -> Object -> Either Text (f a)+  gMissingKey = Util.missingRecordKey++class MsgpackDecodeProd f where+  msgpackDecodeRecord :: Map Object Object -> Either Text (f a)+  msgpackDecodeProd :: [Object] -> Either Text ([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+    pure $ left :*: right+  msgpackDecodeProd o = do+    (rest, left) <- msgpackDecodeProd o+    (rest1, right) <- msgpackDecodeProd rest+    pure (rest1, left :*: right)++instance (GMsgpackDecode f, GMsgpackDecode g) => GMsgpackDecode (f :+: g) where+  gMsgpackDecode o = fromRight (L1 <$> gMsgpackDecode @f o) (Right . R1 <$> gMsgpackDecode @g o)++-- TODO use Proxy instead of undefined+instance (Selector s, GMsgpackDecode f) => MsgpackDecodeProd (S1 s f) where+  msgpackDecodeRecord o =+    M1 <$> maybe (gMissingKey key (ObjectMap o)) gMsgpackDecode lookup+    where+      lookup =+        Util.lookupObjectMap key o <|> lookupUnderscore+      lookupUnderscore =+        if hasUnderscore+        then Util.lookupObjectMap (dropWhile ('_' ==) key) o+        else Nothing+      hasUnderscore =+        take 1 key == "_"+      key =+        selName (undefined :: t s f p)+  msgpackDecodeProd (cur:rest) = do+    a <- gMsgpackDecode cur+    pure (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+        pure (k1, v1)+  fromMsgpack o = Util.illegalType "Map" o+  missingKey _ _ = Right Map.empty++integralFromString ::+  Read a =>+  ByteString ->+  Either Text a+integralFromString =+  readEither . decodeUtf8++msgpackIntegral ::+  Integral a =>+  Read a =>+  Object ->+  Either Text a+msgpackIntegral (ObjectInt i) = Right $ fromIntegral i+msgpackIntegral (ObjectUInt i) = Right $ fromIntegral i+msgpackIntegral (ObjectString s) = integralFromString s+msgpackIntegral (ObjectBinary s) = integralFromString s+msgpackIntegral o = Util.illegalType "Integral" o++msgpackText :: ConvertUtf8 t ByteString => Text -> (t -> Either Text a) -> Object -> Either Text a+msgpackText typeName decode =+  run+  where+    run (ObjectString os) = decode $ decodeUtf8 os+    run (ObjectBinary os) = decode $ decodeUtf8 os+    run o = Util.illegalType typeName o++instance MsgpackDecode Integer where+  fromMsgpack = msgpackIntegral++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 MsgpackDecode Double where+  fromMsgpack (ObjectFloat a) = Right (float2Double a)+  fromMsgpack (ObjectDouble a) = Right a+  fromMsgpack (ObjectInt a) = Right (fromIntegral a)+  fromMsgpack (ObjectUInt a) = Right (fromIntegral a)+  fromMsgpack o = Util.illegalType "Double" o++instance {-# OVERLAPPING #-} MsgpackDecode String where+  fromMsgpack = msgpackText "String" Right++instance {-# OVERLAPPABLE #-} MsgpackDecode a => MsgpackDecode [a] where+  fromMsgpack (ObjectArray oa) = traverse fromMsgpack oa+  fromMsgpack o = Util.illegalType "List" o+  missingKey _ _ = Right []++instance MsgpackDecode Text where+  fromMsgpack =+    msgpackText "Text" Right++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 =+    msgpackText "Char" check o+    where+      check :: [Char] -> Either Text Char+      check [c] = Right c+      check _ = Util.invalid "multiple characters when decoding 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 (ObjectInt 0) = Right False+  fromMsgpack (ObjectInt 1) = Right True+  fromMsgpack o = Util.illegalType "Bool" o++instance MsgpackDecode () where+  fromMsgpack _ = Right ()++instance MsgpackDecode Object where+  fromMsgpack = Right++decodeTuple :: Int -> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a+decodeTuple i f = \case+  o@(ObjectArray oa) ->+    case f oa of+      Right a -> pure a+      Left Nothing -> Util.invalid [exon|invalid array length for #{show i}-tuple|] o+      Left (Just err) -> Left err+  o ->+    Util.illegalType [exon|#{show i}-tuple|] o++instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (a, b) where+  fromMsgpack =+    decodeTuple 2 \case+      [a, b] ->+        first Just ((,) <$> fromMsgpack a <*> fromMsgpack b)+      _ ->+        Left Nothing++instance (MsgpackDecode a, MsgpackDecode b, MsgpackDecode c) => MsgpackDecode (a, b, c) where+  fromMsgpack =+    decodeTuple 3 \case+      [a, b, c] ->+        first Just ((,,) <$> fromMsgpack a <*> fromMsgpack b <*> fromMsgpack c)+      _ ->+        Left Nothing++instance (MsgpackDecode a, MsgpackDecode b, MsgpackDecode c, MsgpackDecode d) => MsgpackDecode (a, b, c, d) where+  fromMsgpack =+    decodeTuple 4 \case+      [a, b, c, d] ->+        first Just ((,,,) <$> fromMsgpack a <*> fromMsgpack b <*> fromMsgpack c <*> fromMsgpack d)+      _ ->+        Left Nothing++class DecodePath b t where+  decodePath :: FilePath -> Either SomeException (Path b t)++instance DecodePath Abs File where+  decodePath =+    parseAbsFile++instance DecodePath Abs Dir where+  decodePath =+    parseAbsDir++instance DecodePath Rel File where+  decodePath =+    parseRelFile++instance DecodePath Rel Dir where+  decodePath =+    parseRelDir++decodePathE ::+  ∀ b t .+  DecodePath b t =>+  Text ->+  Either Text (Path b t)+decodePathE =+  first show . decodePath . toString++instance DecodePath b t => MsgpackDecode (Path b t) where+  fromMsgpack =+    msgpackText "Path" decodePathE++timeUnit ::+  Fractional a =>+  Text ->+  Object ->+  Either Text a+timeUnit name = \case+  Msgpack d -> Right (realToFrac @Double d)+  Msgpack i -> Right (fromIntegral @Int64 i)+  o -> Util.illegalType name o++instance MsgpackDecode NanoSeconds where+  fromMsgpack =+    timeUnit "NanoSeconds"++instance MsgpackDecode MicroSeconds where+  fromMsgpack =+    timeUnit "MicroSeconds"++instance MsgpackDecode MilliSeconds where+  fromMsgpack =+    timeUnit "MilliSeconds"++instance MsgpackDecode Seconds where+  fromMsgpack =+    fmap Seconds . fromMsgpack++msgpackFromString :: IsString a => Text -> Object -> Either Text a+msgpackFromString name o =+  case fromMsgpack o of+    Right a ->+      Right (fromString a)+    Left _ ->+      Util.illegalType name o
+ lib/Ribosome/Host/Class/Msgpack/DecodeSOP.hs view
@@ -0,0 +1,50 @@+module Ribosome.Host.Class.Msgpack.DecodeSOP where++import Data.MessagePack (Object (..))+import Generics.SOP (All2, I (I), NP (Nil, (:*)), NS (Z), SOP (SOP), Top)+import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, GTo, gto)+import Generics.SOP.Type.Metadata (ConstructorInfo, DatatypeInfo (ADT, Newtype))++type ReifySOP (d :: Type) (dss :: [[Type]]) =+  (Generic d, GTo d, GCode d ~ dss, All2 Top dss)++type ConstructSOP (d :: Type) (dss :: [[Type]]) =+  (Generic d, GFrom d, GCode d ~ dss, All2 Top dss)++class MsgpackCtor (ctor :: ConstructorInfo) (as :: [Type]) where++class MsgpackCtors (ctors :: [ConstructorInfo]) (ass :: [[Type]]) where+  msgpackCtors :: Object -> Either Text (SOP I ass)++class GMsgpackDecode (dt :: DatatypeInfo) (ass :: [[Type]]) where+  gMsgpackDecode :: Object -> Either Text (SOP I ass)++instance (+    MsgpackDecode a+  ) => GMsgpackDecode ('Newtype mod name ctor) '[ '[a]] where+    gMsgpackDecode o = do+      a <- fromMsgpack o+      pure (SOP (Z (I a :* Nil)))++instance (+    MsgpackCtors ctors ass+  ) => GMsgpackDecode ('ADT mod name ctors strictness) ass where+  gMsgpackDecode =+      msgpackCtors @ctors++class MsgpackDecode a where+  fromMsgpack :: Object -> Either Text a+  default fromMsgpack ::+    ConstructSOP a ass =>+    ReifySOP a ass =>+    GMsgpackDecode (GDatatypeInfoOf a) (GCode a) =>+    Object ->+    Either Text a+  fromMsgpack =+    fmap gto . gMsgpackDecode @(GDatatypeInfoOf a)++  -- missingKey :: String -> Object -> Either Text a+  -- missingKey = Util.missingRecordKey++pattern Msgpack :: ∀ a . MsgpackDecode a => a -> Object+pattern Msgpack a <- (fromMsgpack -> Right a)
+ lib/Ribosome/Host/Class/Msgpack/Encode.hs view
@@ -0,0 +1,153 @@+{-# options_haddock prune #-}++-- |Encoding values to MessagePack format+module Ribosome.Host.Class.Msgpack.Encode where++import qualified Data.List.NonEmpty as NonEmpty (toList)+import qualified Data.Map.Strict as Map (fromList, toList)+import Data.MessagePack (Object (..))+import GHC.Generics (+  C1,+  Constructor,+  D1,+  K1 (..),+  M1 (..),+  Rep,+  S1,+  Selector,+  conIsRecord,+  from,+  selName,+  (:*:) (..),+  (:+:) (..),+  )+import Path (Path, toFilePath)+import Time (MicroSeconds, MilliSeconds (unMilliSeconds), NanoSeconds (unNanoSeconds), Seconds, unMicroSeconds, unSeconds)++import qualified Ribosome.Host.Class.Msgpack.Util as Util (assembleMap, string, text)++-- |Class of values that can be encoded to MessagePack 'Object's.+class MsgpackEncode a where+  -- |Convert a value to MessagePack.+  --+  -- The default implementation uses generic derivation.+  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 (GMsgpackEncode f, GMsgpackEncode g) => GMsgpackEncode (f :+: g) where+  gMsgpackEncode (L1 a) = gMsgpackEncode a+  gMsgpackEncode (R1 a) = gMsgpackEncode a++instance (Selector s, GMsgpackEncode f) => MsgpackEncodeProd (S1 s f) where+  msgpackEncodeRecord s@(M1 f) =+    [(dropWhile ('_' ==) (selName s), gMsgpackEncode f), (selName s, gMsgpackEncode f)]+  msgpackEncodeProd (M1 f) = [gMsgpackEncode f]++instance MsgpackEncode a => GMsgpackEncode (K1 i a) where+  gMsgpackEncode = toMsgpack . unK1++instance (+    MsgpackEncode k,+    MsgpackEncode v+  ) => MsgpackEncode (Map k v) where+  toMsgpack = ObjectMap . Map.fromList . fmap (bimap toMsgpack toMsgpack) . Map.toList++instance MsgpackEncode Integer where+  toMsgpack = ObjectInt . fromInteger++instance MsgpackEncode Int where+  toMsgpack = ObjectInt . fromIntegral++instance MsgpackEncode Int64 where+  toMsgpack = ObjectInt++instance MsgpackEncode Float where+  toMsgpack = ObjectFloat++instance MsgpackEncode Double where+  toMsgpack = ObjectDouble++instance {-# overlapping #-} MsgpackEncode String where+  toMsgpack = Util.string++instance {-# overlappable #-} MsgpackEncode a => MsgpackEncode [a] where+  toMsgpack = ObjectArray . fmap toMsgpack++instance MsgpackEncode a => MsgpackEncode (NonEmpty a) where+  toMsgpack = toMsgpack . NonEmpty.toList++instance MsgpackEncode a => MsgpackEncode (Seq a) where+  toMsgpack = toMsgpack . toList++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]++instance (MsgpackEncode a, MsgpackEncode b, MsgpackEncode c) => MsgpackEncode (a, b, c) where+  toMsgpack (a, b, c) =+    ObjectArray [toMsgpack a, toMsgpack b, toMsgpack c]++instance MsgpackEncode (Path b t) where+  toMsgpack = ObjectString . encodeUtf8 . toFilePath++instance MsgpackEncode NanoSeconds where+  toMsgpack =+    toMsgpack . unNanoSeconds++instance MsgpackEncode MicroSeconds where+  toMsgpack =+    toMsgpack . unMicroSeconds++instance MsgpackEncode MilliSeconds where+  toMsgpack =+    toMsgpack . unMilliSeconds++instance MsgpackEncode Seconds where+  toMsgpack =+    toMsgpack . unSeconds
+ lib/Ribosome/Host/Class/Msgpack/Error.hs view
@@ -0,0 +1,12 @@+module Ribosome.Host.Class.Msgpack.Error where++newtype DecodeError =+  DecodeError { unDecodeError :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString)++-- instance ReportError DecodeError where+--   errorReport (Failed err) =+--     ErrorReport "error decoding response from neovim" ["DecodeError:", rendered] ERROR+--     where+--       rendered = renderStrict $ layoutPretty defaultLayoutOptions err
+ lib/Ribosome/Host/Class/Msgpack/Map.hs view
@@ -0,0 +1,59 @@+-- |Helper for encoding values to a heterogeneous MessagePack map.+module Ribosome.Host.Class.Msgpack.Map where++import Data.MessagePack (Object)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))++-- |Utility class for 'MsgpackMap'.+class MsgpackMapElem a where+  msgpackMapElem :: a -> Map Text Object++instance {-# overlappable #-} (+    MsgpackEncode a,+    t ~ Text+  ) => MsgpackMapElem (t, a) where+    msgpackMapElem (k, v) =+      [(k, toMsgpack v)]++instance (+    MsgpackEncode a,+    t ~ Text+  ) => MsgpackMapElem (t, Maybe a) where+    msgpackMapElem = \case+      (k, Just v) ->+        [(k, toMsgpack v)]+      (_, Nothing) ->+        mempty++-- |This class provides a variadic method for encoding MessagePack maps.+class MsgpackMap a where+  -- |Encode an arbitrary number of heterogeneously typed values to a single MessagePack map.+  -- This function is variadic, meaning that it takes an arbitrary number of arguments:+  --+  -- >>> msgpackMap ("number", 5 :: Int) ("status", "error" :: Text) ("intensity", 3.14 :: Double) :: Object+  -- ObjectMap (Map.fromList [(ObjectString "number", ObjectInt 5), (ObjectString "status", ObjectString "error"), (ObjectString "intensity", ObjectFloat 3.14)])+  --+  -- This avoids the need to call 'Ribosome.toMsgpack' once for each element and then once more for the map.+  msgpackMap :: a++instance MsgpackMap (Map Text Object -> Object) where+  msgpackMap =+    toMsgpack++instance MsgpackMap (a -> a) where+  msgpackMap =+    id++instance (+    MsgpackMapElem (t, a),+    MsgpackMap (Map Text Object -> b)+  ) => MsgpackMap (Map Text Object -> (t, a) -> b) where+  msgpackMap m a =+    msgpackMap (m <> msgpackMapElem a)++instance (+    MsgpackMapElem (t, a),+    MsgpackMap (Map Text Object -> b)+  ) => MsgpackMap ((t, a) -> b) where+  msgpackMap a =+    msgpackMap (msgpackMapElem a)
+ lib/Ribosome/Host/Class/Msgpack/Util.hs view
@@ -0,0 +1,42 @@+module Ribosome.Host.Class.Msgpack.Util where++import Data.Map.Strict ((!?))+import qualified Data.Map.Strict as Map (fromList)+import Data.MessagePack (Object (..))+import Exon (exon)++string :: ConvertUtf8 a ByteString => a -> Object+string =+  ObjectString . encodeUtf8++binary :: ConvertUtf8 a ByteString => a -> Object+binary =+  ObjectBinary . encodeUtf8++text :: Text -> Object+text =+  ObjectString . encodeUtf8++assembleMap :: [(String, Object)] -> Object+assembleMap =+  ObjectMap . Map.fromList . (fmap . first) string++invalid :: Text -> Object -> Either Text a+invalid msg obj =+  Left [exon|#{msg}: #{show obj}|]++missingRecordKey :: String -> Object -> Either Text a+missingRecordKey key =+  invalid [exon|missing record key #{toText key} in ObjectMap|]++illegalType :: Text -> Object -> Either Text a+illegalType tpe =+  invalid [exon|illegal type for #{tpe}|]++lookupObjectMap ::+  ConvertUtf8 a ByteString =>+  a ->+  Map Object Object ->+  Maybe Object+lookupObjectMap key o =+  (o !? string key) <|> (o !? binary key)
+ lib/Ribosome/Host/Config.hs view
@@ -0,0 +1,11 @@+module Ribosome.Host.Config where++import qualified Ribosome.Host.Data.HostConfig as HostConfig+import Ribosome.Host.Data.HostConfig (HostConfig (HostConfig), LogConfig)++interpretLogConfig ::+  Member (Reader HostConfig) r =>+  InterpreterFor (Reader LogConfig) r+interpretLogConfig sem =+  ask >>= \ HostConfig {hostLog} ->+    runReader hostLog sem
+ lib/Ribosome/Host/Data/ApiInfo.hs view
@@ -0,0 +1,48 @@+module Ribosome.Host.Data.ApiInfo where++import Data.MessagePack (Object)+import qualified Data.Serialize as Serialize+import System.Process.Typed (proc, readProcessStdout_)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))+import Ribosome.Host.Data.ApiType (ApiType)++data RpcDecl =+  RpcDecl {+    name :: String,+    parameters :: [(ApiType, String)],+    since :: Maybe Int64,+    deprecated_since :: Maybe Int64,+    method :: Bool,+    return_type :: ApiType+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackDecode)++newtype ExtType =+  ExtType { unExtType :: String }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackDecode)++data ExtTypeMeta =+  ExtTypeMeta {+    id :: Int64,+    prefix :: String+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackDecode)++data ApiInfo =+  ApiInfo {+    types :: Map ExtType ExtTypeMeta,+    functions :: [RpcDecl]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackDecode)++msgpack :: IO (Either Text Object)+msgpack =+    first toText . Serialize.decode . toStrict <$> readProcessStdout_ (proc "nvim" ["--api-info"])++apiInfo :: IO (Either Text ApiInfo)+apiInfo = (fromMsgpack =<<) <$> msgpack
+ lib/Ribosome/Host/Data/ApiType.hs view
@@ -0,0 +1,122 @@+module Ribosome.Host.Data.ApiType where++import Data.Char (isSpace)+import Exon (exon)+import qualified FlatParse.Basic as FlatParse+import FlatParse.Basic (+  Result (Err, Fail, OK),+  branch,+  char,+  inSpan,+  isLatinLetter,+  many_,+  optional,+  readInt,+  runParser,+  satisfy,+  satisfyASCII,+  string,+  switch,+  takeRest,+  withSpan,+  (<|>),+  )+import Prelude hiding (optional, some, span, try, (<|>))+import Text.Show (showsPrec)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))++-- TODO see if using GADT can move some TH stuff to type level+data ApiPrim =+  Boolean+  |+  Integer+  |+  Float+  |+  String+  |+  Dictionary+  |+  Object+  |+  Void+  |+  LuaRef+  deriving stock (Eq, Show)++data ApiType =+  Prim ApiPrim+  |+  Array ApiType (Maybe Int)+  |+  Ext String+  deriving stock (Show, Eq)++polyType :: ApiType -> Bool+polyType = \case+  Prim Object -> True+  Prim Dictionary -> True+  _ -> False++pattern PolyType :: ApiType+pattern PolyType <- (polyType -> True)++type Parser =+  FlatParse.Parser Text++ws :: Parser ()+ws =+  many_ (satisfy isSpace)++span :: Parser () -> Parser String+span seek =+  withSpan seek \ _ sp -> inSpan sp takeRest++prim :: Parser ApiPrim+prim =+  $(switch [|+  case _ of+    "Boolean" -> pure Boolean+    "Integer" -> pure Integer+    "Float" -> pure Float+    "String" -> pure String+    "Dictionary" -> pure Dictionary+    "Object" -> pure Object+    "void" -> pure Void+    "LuaRef" -> pure LuaRef+  |])++typedArray :: Parser ApiType+typedArray = do+  t <- apiType+  arity <- optional do+    $(char ',')+    ws+    readInt+  pure (Array t arity)++array :: Parser ApiType+array = do+  $(string "Array")+  branch $(string "Of(") (typedArray <* $(char ')')) (pure (Array (Prim Object) Nothing))++ext :: Parser ApiType+ext =+  Ext <$> span (many_ (satisfyASCII isLatinLetter))++apiType :: Parser ApiType+apiType =+  array <|> (Prim <$> prim) <|> ext++parseApiType :: ByteString -> Either Text ApiType+parseApiType =+  runParser apiType >>> \case+    OK a "" -> Right a+    OK a u -> Left [exon|Parsed #{toText (showsPrec 11 a "")} but got leftovers: #{decodeUtf8 u}|]+    Fail -> Left "fail"+    Err e -> Left e++instance MsgpackDecode ApiType where+  fromMsgpack =+    parseApiType <=< fromMsgpack
+ lib/Ribosome/Host/Data/Args.hs view
@@ -0,0 +1,52 @@+-- |Special command parameters governing the aggregation of the entire (rest of the) argument list into one value.+module Ribosome.Host.Data.Args where++import Options.Applicative (Parser)++-- |When this type is used as the (last) parameter of a command handler function, all remaining tokens passed to the+-- command will be consumed and stored in this type.+--+-- The command will be declared with the @-nargs=*@ or @-nargs=+@ option.+--+-- See 'Ribosome.CommandHandler'.+newtype Args =+  Args { unArgs :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)++-- |When this type is used as the (last) parameter of a command handler function, all remaining tokens passed to the+-- command will be consumed and stored in this type, as a list of whitespace separated tokens.+--+-- The command will be declared with the @-nargs=*@ or @-nargs=+@ option.+--+-- See 'Ribosome.CommandHandler'.+newtype ArgList =+  ArgList { unArgList :: [Text] }+  deriving stock (Eq, Show)++-- |When this type is used as the (last) parameter of a command handler function, all remaining tokens passed to the+-- command will be consumed, decoded as JSON and stored in this type.+--+-- The command will be declared with the @-nargs=*@ or @-nargs=+@ option.+--+-- See 'Ribosome.CommandHandler'.+newtype JsonArgs a =+  JsonArgs { unJsonArgs :: a }+  deriving stock (Eq, Show)++-- |When this type is used as the (last) parameter of a command handler function, all remaining tokens passed to the+-- command will be consumed, parsed via [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative)+-- and stored in this type.+--+-- The parser associated with @a@ must be defined as an instance of @'OptionParser' a@.+--+-- The command will be declared with the @-nargs=*@ or @-nargs=+@ option.+--+-- See 'Ribosome.CommandHandler'.+newtype Options a =+  Options a+  deriving stock (Eq, Show)++-- |The parser used when declaring command handlers with the special parameter @'Options' a@.+class OptionParser a where+  optionParser :: Parser a
+ lib/Ribosome/Host/Data/Bang.hs view
@@ -0,0 +1,31 @@+-- |Special command parameter that activates the bang modifier.+module Ribosome.Host.Data.Bang where++import Data.MessagePack (Object (ObjectBool))+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))++-- |When this type is used as a parameter of a command handler function, the command is declared with the @-bang@+-- option, and when invoked, the argument passed to the handler is v'Bang' if the user specified the @!@ and 'NoBang'+-- otherwise.+data Bang =+  -- |Bang was used.+  Bang+  |+  -- |Bang was not used.+  NoBang+  deriving stock (Eq, Show)++instance MsgpackDecode Bang where+  fromMsgpack = \case+    ObjectBool True ->+      Right Bang+    ObjectBool False ->+      Right NoBang+    Msgpack (1 :: Int) ->+      Right Bang+    Msgpack (0 :: Int) ->+      Right NoBang+    o ->+      Left [exon|Bang arg must be Bool: #{show o}|]
+ lib/Ribosome/Host/Data/Bar.hs view
@@ -0,0 +1,16 @@+-- |Special command parameter that enables command chaining.+module Ribosome.Host.Data.Bar where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))++-- |When this type is used as a parameter of a command handler function, the command is declared with the @-bar@ option,+-- allowing other commands to be chained after it with @|@.+--+-- This has no effect on the execution.+data Bar =+  Bar+  deriving stock (Eq, Show)++instance MsgpackDecode Bar where+  fromMsgpack _ =+    Right Bar
+ lib/Ribosome/Host/Data/BootError.hs view
@@ -0,0 +1,12 @@+-- |The fatal error type+module Ribosome.Host.Data.BootError where++-- |This type represents the singular fatal error used by Ribosome.+--+-- Contrary to all other errors, this one is used with 'Error' instead of 'Stop'.+-- It is only thrown from intialization code of interpreters when operation of the plugin is impossible due to the error+-- condition.+newtype BootError =+  BootError { unBootError :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)
+ lib/Ribosome/Host/Data/ChannelId.hs view
@@ -0,0 +1,11 @@+module Ribosome.Host.Data.ChannelId where+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))++newtype ChannelId =+  ChannelId { unChannelId :: Int64 }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord)++instance MsgpackDecode ChannelId where+  fromMsgpack =+    fmap ChannelId . fromMsgpack
+ lib/Ribosome/Host/Data/CommandMods.hs view
@@ -0,0 +1,13 @@+-- |Special command parameter that exposes the used modifiers.+module Ribosome.Host.Data.CommandMods where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)++-- |When this type is used as a parameter of a command handler function, the RPC trigger uses the special token+-- @<q-mods>@ in the call.+--+-- This type then contains the list of pre-command modifiers specified by the user, like @:belowright@.+newtype CommandMods =+  CommandMods { unCommandMods :: Text }+  deriving stock (Eq, Show)+  deriving newtype (MsgpackDecode)
+ lib/Ribosome/Host/Data/CommandRegister.hs view
@@ -0,0 +1,13 @@+-- |Special command parameter that exposes the used register.+module Ribosome.Host.Data.CommandRegister where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)++-- |When this type is used as a parameter of a command handler function, the RPC trigger uses the special token+-- @<reg>@ in the call.+--+-- This type then contains the name of the register specified by the user.+newtype CommandRegister =+  CommandRegister { unCommandRegister :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackDecode)
+ lib/Ribosome/Host/Data/Event.hs view
@@ -0,0 +1,26 @@+-- |Events sent from Neovim to the host.+module Ribosome.Host.Data.Event where++import Data.MessagePack (Object)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++-- |The name of an event, which corresponds to the RPC method in the payload.+newtype EventName =+  EventName { unEventName :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackDecode, MsgpackEncode)++-- |An event is an RPC notification sent by Neovim that is not intended to be dispatched to a named handler, but+-- consumed in a broadcasting fashion.+--+-- Since they aren't marked as such, the host treats any notification with an unknown method name as an event.+--+-- Events can be consumed with 'Conc.Consume' and 'Conc.subscribe'.+data Event =+  Event {+    name :: EventName,+    payload :: [Object]+  }+  deriving stock (Eq, Show)
+ lib/Ribosome/Host/Data/Execution.hs view
@@ -0,0 +1,27 @@+-- |RPC message execution+module Ribosome.Host.Data.Execution where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))++-- |This type indicates the execution style that Neovim should be instructed to use for RPC messages – synchronous+-- requests that block Neovim until a result is returned and asynchronous notifications.+--+-- +data Execution =+  -- |RPC Request+  Sync+  |+  -- |RPC Notification+  Async+  deriving stock (Eq, Show, Enum, Bounded)++instance MsgpackEncode Execution where+  toMsgpack exec =+    toMsgpack (exec == Sync)++instance MsgpackDecode Execution where+  fromMsgpack o =+    fromMsgpack o <&> \case+      True -> Sync+      False -> Async
+ lib/Ribosome/Host/Data/HostConfig.hs view
@@ -0,0 +1,39 @@+-- |The configuration for a Ribosome plugin host.+module Ribosome.Host.Data.HostConfig where++import Log (Severity (Crit, Info))+import Path (Abs, File, Path)++-- |Logging config for a host, with different levels for Neovim echoing, stderr and file logs.+--+-- /Note/ that stderr logging will be sent to Neovim when the plugin is running in remote mode, which will be ignored+-- unless the plugin is started with a stderr handler.+data LogConfig =+  LogConfig {+    logFile :: Maybe (Path Abs File),+    logLevelEcho :: Severity,+    logLevelStderr :: Severity,+    logLevelFile :: Severity,+    dataLogConc :: Bool+  }+  deriving stock (Eq, Show, Generic)++instance Default LogConfig where+  def =+    LogConfig Nothing Info Crit Info True++-- |The configuration for a host, which consists only of a 'LogConfig'.+newtype HostConfig =+  HostConfig {+    hostLog :: LogConfig+  }+  deriving stock (Eq, Show, Generic)++instance Default HostConfig where+  def =+    HostConfig def++-- |Set the stderr level on a 'HostConfig'.+setStderr :: Severity -> HostConfig -> HostConfig+setStderr l c =+  c { hostLog = (hostLog c) { logLevelStderr = l } }
+ lib/Ribosome/Host/Data/LuaRef.hs view
@@ -0,0 +1,9 @@+module Ribosome.Host.Data.LuaRef where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)++newtype LuaRef =+  LuaRef { unLuaRef :: Int64 }+  deriving stock (Generic)+  deriving anyclass (MsgpackDecode, MsgpackEncode)
+ lib/Ribosome/Host/Data/NvimSocket.hs view
@@ -0,0 +1,7 @@+module Ribosome.Host.Data.NvimSocket where++import Path (Abs, File, Path)++newtype NvimSocket =+  NvimSocket { unNvimSocket :: Path Abs File }+  deriving stock (Eq, Show)
+ lib/Ribosome/Host/Data/Range.hs view
@@ -0,0 +1,91 @@+{-# options_haddock prune #-}++-- |Special command parameter that governs the range modifier.+module Ribosome.Host.Data.Range where++import Data.MessagePack (Object (ObjectArray))+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)++-- |Neovim offers different semantics for the command range (see @:help :command-range@).+--+-- This type determines the position (prefix line number/postfix count) and default values.+data RangeStyle =+  -- |Prefix line range, defaulting to the entire file (@-range=%@).+  RangeFile+  |+  -- |'Nothing': Prefix line range defaulting to the current line (@-range@).+  -- |@'Just' N@: Prefix count defaulting to @N@ (@-range=N@).+  RangeLine (Maybe Nat)+  |+  -- |@'Just' N@: Prefix or postfix count defaulting to @N@ (@-count=N@).+  -- |'Nothing': Same as @'Just' 0@ (@-count@).+  RangeCount (Maybe Nat)++-- |When this type is used as a parameter of a command handler function, the command is declared with the @-range@+-- option, and when invoked, the argument passed to the handler contains the line range specified by the user, as in:+--+-- > :5Reverse+-- > :5,20Reverse+--+-- In the first case, the field 'high' is 'Nothing'.+--+-- The type has a phantom parameter of kind 'RangeStyle' that configures the semantics of the range, as defined by+-- Neovim (see @:help :command-range@).+data Range (style :: RangeStyle) =+  Range {+    low :: Int64,+    high :: Maybe Int64+  }+  deriving stock (Eq, Show)++instance MsgpackDecode (Range style) where+  fromMsgpack = \case+    ObjectArray [Msgpack low, Msgpack high] ->+      Right (Range low (Just high))+    ObjectArray [Msgpack low] ->+      Right (Range low Nothing)+    o ->+      Left [exon|Range must be an array with one or two elements: #{show o}|]++class RangeStyleOpt (s :: RangeStyle) where+  rangeStyleOpt :: Map Text Object++  rangeStyleArg :: Text+  rangeStyleArg =+    "[<line1>, <line2>]"++instance RangeStyleOpt ('RangeLine 'Nothing) where+  rangeStyleOpt =+    [("range", toMsgpack True)]++instance RangeStyleOpt 'RangeFile where+  rangeStyleOpt =+    [("range", toMsgpack @Text "%")]++instance (+    KnownNat n+  ) => RangeStyleOpt ('RangeLine ('Just n)) where+  rangeStyleOpt =+    [("range", toMsgpack (natVal (Proxy @n)))]++  rangeStyleArg =+    "[<count>]"++instance RangeStyleOpt ('RangeCount 'Nothing) where+  rangeStyleOpt =+    [("count", toMsgpack True)]++  rangeStyleArg =+    "[<count>]"++instance (+    KnownNat n+  ) => RangeStyleOpt ('RangeCount ('Just n)) where+  rangeStyleOpt =+    [("count", toMsgpack (natVal (Proxy @n)))]++  rangeStyleArg =+    "[<count>]"
+ lib/Ribosome/Host/Data/Report.hs view
@@ -0,0 +1,255 @@+-- |Data structures related to logging and notifying the user+module Ribosome.Host.Data.Report where++import qualified Data.Text as Text+import Exon (exon)+import Fcf (Pure1, type (@@))+import Fcf.Class.Functor (FMap)+import Polysemy.Log (Severity (Error))+import Prelude hiding (tag)+import Text.Show (showParen, showsPrec)++-- |The provenance of a report, for use in logs.+newtype ReportContext =+  ReportContext { unReportContext :: [Text] }+  deriving stock (Eq, Show)+  deriving newtype (Ord, Semigroup, Monoid)++-- |Render a 'ReportContext' by interspersing it with dots, returning 'Nothing' if it is empty.+reportContext' :: ReportContext -> Maybe Text+reportContext' = \case+  ReportContext [] -> Nothing+  ReportContext c -> Just (Text.intercalate "." c)++-- |Render a 'ReportContext' by interspersing it with dots, followed by a colon, returning 'Nothing' if it is empty.+prefixReportContext' :: ReportContext -> Maybe Text+prefixReportContext' c =+  flip Text.snoc ':' <$> reportContext' c++-- |Render a 'ReportContext' by interspersing it with dots, using @global@ if it is empty.+reportContext :: ReportContext -> Text+reportContext c =+  fromMaybe "global" (reportContext' c)++-- |Render a 'ReportContext' by interspersing it with dots, followed by a colon, using @global@ if it is empty.+prefixReportContext :: ReportContext -> Text+prefixReportContext c =+  Text.snoc (reportContext c) ':'++instance IsString ReportContext where+  fromString =+    ReportContext . pure . toText++-- |An report with different messages intended to be sent to Neovim and the log, respectively.+--+-- Used by request handlers and expected by the RPC dispatcher.+--+-- Also contains the 'Severity' of the report, or minimum log level, which determines whether the report should be+-- logged and echoed in Neovim, and what kind of highlighting should be used in Neovim (red for errors, orange for+-- warnings, none for infomrational errors).+--+-- The log message may span multiple lines.+data Report where+  Report :: HasCallStack => {+    user :: Text,+    log :: [Text],+    severity :: Severity+  } -> Report++instance Show Report where+  showsPrec d Report {..} =+    showParen (d > 10)+    [exon|LogReport { user = #{showsPrec 11 user}, log = #{showsPrec 11 log}, severity = #{showsPrec 11 severity} }|]++instance IsString Report where+  fromString (toText -> s) =+    Report s [s] Error++-- |The type used by request handlers and expected by the RPC dispatcher.+data LogReport =+  LogReport {+    -- |The report+    report :: Report,+    -- |Indicates whether this report may be echoed in Neovim+    echo :: Bool,+    -- |Indicates whether to store this report in the state of 'Ribosome.Reports'+    store :: Bool,+    -- |A list of prefixes used for log messages+    context :: ReportContext+  }+  deriving stock (Show, Generic)++-- |Construct a 'LogReport' error from a single 'Text'.+simple ::+  HasCallStack =>+  Text ->+  LogReport+simple msg =+  withFrozenCallStack do+    LogReport (Report msg [msg] Error) True True mempty++-- |Stop with a 'LogReport'.+basicReport ::+  Member (Stop Report) r =>+  HasCallStack =>+  Text ->+  [Text] ->+  Sem r a+basicReport user log =+  withFrozenCallStack do+    stop (Report user log Error)++instance IsString LogReport where+  fromString :: HasCallStack => String -> LogReport+  fromString (toText -> msg) =+    withFrozenCallStack do+      LogReport (Report msg [msg] Error) True True mempty++-- |The class of types that are convertible to a 'Report'.+--+-- This is used to create a uniform format for handlers, since control flow is passed on to the internal machinery when+-- they return.+-- If an error would be thrown that is not caught by the request dispatcher, the entire plugin would stop, so all 'Stop'+-- and 'Resumable' effects need to be converted to 'Report' before returning (see [Errors]("Ribosome#errors")).+--+-- The combinators associated with this class make this task a little less arduous:+--+-- > data NumbersError = InvalidNumber+-- >+-- > instance Reportable NumbersError where+-- >   toReport InvalidNumber = Report "Invalid number!" ["The user entered an invalid number"] Warn+-- >+-- > count :: Int -> Sem r Int+-- > count i =+-- >   resumeReport @Rpc $ mapReport @NumbersError do+-- >     when (i == 0) (stop InvalidNumber)+-- >     nvimGetVar ("number_" <> show i)+--+-- Here 'resumeReport' converts a potential 'RpcError' from 'Ribosome.Api.nvimGetVar' to 'Report' (e.g. if the variable+-- is not set), while 'mapReport' uses the instance @'Reportable' 'NumbersError'@ to convert the call to 'stop'.+class Reportable e where+  toReport :: e -> Report++instance Reportable Report where+  toReport =+    id++instance Reportable Void where+  toReport = \case++-- |Reinterpret @'Stop' err@ to @'Stop' 'Report'@ if @err@ is an instance of 'Reportable'.+mapReport ::+  ∀ e r a .+  Reportable e =>+  Member (Stop Report) r =>+  Sem (Stop e : r) a ->+  Sem r a+mapReport =+  mapStop toReport++type Stops errs =+  FMap (Pure1 Stop) Fcf.@@ errs++-- |Map multiple errors to 'Report'.+class MapReports (errs :: [Type]) (r :: EffectRow) where+  -- |Map multiple errors to 'Report'.+  -- This needs the errors specified as type applications.+  --+  -- > mapReports @[RpcError, SettingError]+  mapReports :: InterpretersFor (Stops errs) r++instance MapReports '[] r where+  mapReports =+    id++instance (+    Reportable err,+    MapReports errs r,+    Member (Stop Report) (Stops errs ++ r)+  ) => MapReports (err : errs) r where+    mapReports =+      mapReports @errs . mapReport @err++-- |Convert the effect @eff@ to @'Resumable' err eff@ and @'Stop' 'Report'@ if @err@ is an instance of 'Reportable'.+resumeReport ::+  ∀ eff e r a .+  Reportable e =>+  Members [eff !! e, Stop Report] r =>+  Sem (eff : r) a ->+  Sem r a+resumeReport =+  resumeHoist toReport++-- |Resume multiple effects as 'Report's.+class ResumeReports (effs :: EffectRow) (errs :: [Type]) (r :: EffectRow) where+  -- |Resume multiple effects as 'Report's.+  -- This needs both effects and errors specified as type applications (though only the shape for the errors).+  --+  -- > resumeReports @[Rpc, Settings] @[_, _]+  resumeReports :: InterpretersFor effs r++instance ResumeReports '[] '[] r where+  resumeReports =+    id++instance (+    Reportable err,+    ResumeReports effs errs r,+    Members [eff !! err, Stop Report] (effs ++ r)+  ) => ResumeReports (eff : effs) (err : errs) r where+    resumeReports =+      resumeReports @effs @errs . resumeReport @eff @err++-- |Extract both user and log messages from an 'Report', for use in tests.+reportMessages :: Report -> Text+reportMessages Report {user, log} =+  unlines (user : log)++-- |Extract the user message from an instance of 'Reportable'.+userReport ::+  ∀ e .+  Reportable e =>+  e ->+  Text+userReport (toReport -> Report {user}) =+  user++-- |Resume an effect with an error that's an instance of 'Reportable' by passing its user message to a function.+resumeHoistUserMessage ::+  ∀ err eff err' r .+  Reportable err =>+  Members [eff !! err, Stop err'] r =>+  (Text -> err') ->+  InterpreterFor eff r+resumeHoistUserMessage f =+  resumeHoist (f . userReport)++-- |Map an error that's an instance of 'Reportable' by passing its user message to a function.+mapUserMessage ::+  ∀ err err' r .+  Reportable err =>+  Member (Stop err') r =>+  (Text -> err') ->+  InterpreterFor (Stop err) r+mapUserMessage f =+  mapStop (f . userReport)++-- |Convert an error that's an instance of 'Reportable' to 'Fail', for use in tests.+stopReportToFail ::+  ∀ e r .+  Member Fail r =>+  Reportable e =>+  InterpreterFor (Stop e) r+stopReportToFail =+  either (fail . toString . userReport) pure <=< runStop+{-# inline stopReportToFail #-}++-- |Resume an effect with an error that's an instance of 'Reportable' by reinterpreting to 'Fail', for use in tests.+resumeReportFail ::+  ∀ eff err r .+  Members [Fail, eff !! err] r =>+  Reportable err =>+  InterpreterFor eff r+resumeReportFail =+  resuming (fail . toString . userReport)+{-# inline resumeReportFail #-}
+ lib/Ribosome/Host/Data/Request.hs view
@@ -0,0 +1,49 @@+module Ribosome.Host.Data.Request where++import Data.MessagePack (Object (ObjectArray))+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))++newtype RpcMethod =+  RpcMethod { unRpcMethod :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord, MsgpackDecode, MsgpackEncode, Semigroup, Monoid)++newtype RequestId =+  RequestId { unRequestId :: Int64 }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, MsgpackDecode, MsgpackEncode)++-- |The payload of an RPC request.+data Request =+  Request {+    -- |The method, which is either the Neovim API function name or the internal identifier of a Ribosome handler.+    method :: RpcMethod,+    -- |The arguments.+    arguments :: [Object]+  }+  deriving stock (Eq, Show, Generic)++instance MsgpackEncode Request where+  toMsgpack (Request m p) =+    ObjectArray [toMsgpack m, toMsgpack p]++-- |An RPC request, which is a payload combined with a request ID.+data TrackedRequest =+  TrackedRequest {+    -- |The ID is used to associate the response with the sender.+    id :: RequestId,+    -- |The payload.+    request :: Request+  }+  deriving stock (Eq, Show)++formatReq :: Request -> Text+formatReq (Request (RpcMethod method) args) =+  [exon|#{method} #{show args}|]++formatTrackedReq :: TrackedRequest -> Text+formatTrackedReq (TrackedRequest (RequestId i) req) =+  [exon|<#{show i}> #{formatReq req}|]
+ lib/Ribosome/Host/Data/Response.hs view
@@ -0,0 +1,28 @@+module Ribosome.Host.Data.Response where++import Data.MessagePack (Object)+import Exon (exon)++import Ribosome.Host.Data.Request (RequestId (RequestId))++data Response =+  Success Object+  |+  Error Text+  deriving stock (Eq, Show)++formatResponse :: Response -> Text+formatResponse = \case+  Success o -> show o+  Error e -> [exon|error: #{e}|]++data TrackedResponse =+  TrackedResponse {+    id :: RequestId,+    payload :: Response+  }+  deriving stock (Eq, Show)++formatTrackedResponse :: TrackedResponse -> Text+formatTrackedResponse (TrackedResponse (RequestId i) payload) =+  [exon|<#{show i}> #{formatResponse payload}|]
+ lib/Ribosome/Host/Data/RpcCall.hs view
@@ -0,0 +1,58 @@+-- |Applicative sequencing for RPC requests+module Ribosome.Host.Data.RpcCall where++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Data.Request (Request)++type RpcCall :: Type -> Type++-- |A wrapper for 'Request' that allows applicative sequencing of calls for batch processing, used for a declarative+-- representation of the Neovim API.+--+-- Neovim has an API function named @nvim_call_atomic@ that makes it possible to send multiple RPC requests at once,+-- reducing the communcation overhead.+-- Applicative sequences of 'RpcCall's are automatically batched into a single call by 'Ribosome.Rpc'.+--+-- This can be combined neatly with @ApplicativeDo@:+--+-- > import Ribosome+-- > import qualified Ribosome.Api.Data as Api+-- >+-- > sync do+-- >   a :: Int <- Api.nvimGetVar "number1"+-- >   b :: Int <- Api.nvimGetVar "number2"+-- >   pure (a + b)+data RpcCall a where+  RpcCallRequest :: MsgpackDecode a => Request -> RpcCall a+  RpcPure :: a -> RpcCall a+  RpcFmap :: (a -> b) -> RpcCall a -> RpcCall b+  RpcAtomic :: (a -> b -> c) -> RpcCall a -> RpcCall b -> RpcCall c++instance Functor RpcCall where+  fmap f = \case+    RpcCallRequest req ->+      RpcFmap f (RpcCallRequest req)+    RpcPure a ->+      RpcPure (f a)+    RpcFmap g a ->+      RpcFmap (f . g) a+    RpcAtomic g a b ->+      RpcAtomic (\ x y -> f (g x y)) a b++instance Applicative RpcCall where+  pure =+    RpcPure+  liftA2 =+    RpcAtomic++instance (+    Semigroup a+  ) => Semigroup (RpcCall a) where+    (<>) =+      liftA2 (<>)++instance (+    Monoid a+  ) => Monoid (RpcCall a) where+    mempty =+      pure mempty
+ lib/Ribosome/Host/Data/RpcError.hs view
@@ -0,0 +1,45 @@+-- |The basic error type for the plugin host.+module Ribosome.Host.Data.RpcError where++import Data.MessagePack (Object)+import qualified Data.Text as Text+import Exon (exon)+import Log (Severity (Error))++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)+import Ribosome.Host.Data.Report (Report (Report), Reportable (toReport))+import Ribosome.Host.Data.Request (RpcMethod (RpcMethod))++-- |The basic error type for the plugin host, used by the listener, 'Rpc' and several other components.+data RpcError =+  -- |An error that is supposed to be prevented by the implementation.+  Unexpected Text+  |+  -- |The Neovim API encountered a problem.+  Api RpcMethod [Object] Text+  |+  -- |A request was instructed to use the wrong decoder or the remote data was invalid.+  Decode Text+  deriving stock (Eq, Show, Generic)+  deriving anyclass (MsgpackEncode, MsgpackDecode)++instance IsString RpcError where+  fromString =+    Unexpected . toText++instance Reportable RpcError where+  toReport = \case+    Unexpected e ->+      Report "Internal error" [e] Error+    Api (RpcMethod m) args e ->+      Report "Nvim API failure" [m, show args, e] Error+    Decode e ->+      Report "Msgpack decoding failed" [e] Error++-- |Extract an error message from an 'RpcError'.+rpcError :: RpcError -> Text+rpcError = \case+  Unexpected e -> e+  Api (RpcMethod m) args e -> [exon|#{m}: #{e}(#{Text.intercalate ", " (show <$> args)})|]+  Decode e -> e
+ lib/Ribosome/Host/Data/RpcHandler.hs view
@@ -0,0 +1,96 @@+{-# options_haddock prune #-}++module Ribosome.Host.Data.RpcHandler where++import Data.MessagePack (Object)+import Exon (exon)+import Text.Show (showParen, showsPrec)++import Ribosome.Host.Data.Execution (Execution)+import Ribosome.Host.Data.Report (Report, resumeReport, Report)+import Ribosome.Host.Data.Request (RpcMethod (RpcMethod))+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcName (RpcName (RpcName))+import qualified Ribosome.Host.Data.RpcType as RpcType+import Ribosome.Host.Data.RpcType (RpcType)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |A request handler function is a 'Sem' with arbitrary stack that has an error of type 'Report' at its head.+--+-- These error messages are reported to the user by return value for synchronous requests and via @echo@ for+-- asynchronous ones, provided that the severity specified in the error is greater than the log level set in+-- 'Ribosome.UserError'.+--+-- If the plugin was started with @--log-file@, it is also written to the file log.+-- Additionally, reports are stored in memory by the effect 'Ribosome.Reports'.+--+-- For an explanation of 'Stop', see [Errors]("Ribosome#errors").+type Handler r a =+  Sem (Stop Report : r) a++-- |This type is the canonical form of an RPC handler, taking a list of MessagePack 'Object's to a 'Sem' with a+-- 'Report' at the head, returning an 'Object'.+type RpcHandlerFun r =+  [Object] -> Handler r Object++-- |This type defines a request handler, using a 'Handler' function, the request type, a name, and whether it should+-- block Neovim while executing.+-- It can be constructed from handler functions using 'Ribosome.rpcFunction', 'Ribosome.rpcCommand' and+-- 'Ribosome.rpcAutocmd'.+--+-- A list of 'RpcHandler's can be used as a Neovim plugin by passing them to 'Ribosome.runNvimHandlersIO'.+data RpcHandler r =+  RpcHandler {+    -- |Whether the trigger is a function, command, or autocmd, and the various options Neovim offers for them.+    rpcType :: RpcType,+    -- |An identifier used to associate a request with a handler, which is also used as the name of the function or+    -- command.+    rpcName :: RpcName,+    -- |If this is 'Ribosome.Sync', the handler will block Neovim via @rpcrequest@.+    -- If it is 'Ribosome.Async', Neovim will use @rpcnotify@ and forget about it.+    rpcExecution :: Execution,+    -- |The function operating on raw msgpack objects, derived from a 'Handler' by the smart constructors.+    rpcHandler :: RpcHandlerFun r+  }+  deriving stock (Generic)++instance Show (RpcHandler m) where+  showsPrec p (RpcHandler t n e _) =+    showParen (p > 10) [exon|RpcHandler #{showsPrec 11 t} #{showsPrec 11 n} #{showsPrec 11 e}|]++-- |Apply a stack-manipulating transformation to the handler function.+hoistRpcHandler ::+  (∀ x . Sem (Stop Report : r) x -> Sem (Stop Report : r1) x) ->+  RpcHandler r ->+  RpcHandler r1+hoistRpcHandler f RpcHandler {..} =+  RpcHandler {rpcHandler = f . rpcHandler, ..}++-- |Apply a stack-manipulating transformation to the handler functions.+hoistRpcHandlers ::+  (∀ x . Sem (Stop Report : r) x -> Sem (Stop Report : r1) x) ->+  [RpcHandler r] ->+  [RpcHandler r1]+hoistRpcHandlers f =+  fmap (hoistRpcHandler f)++-- |Create an 'RpcMethod' by joining an 'RpcType' and an 'RpcName' with a colon.+rpcMethod ::+  RpcType ->+  RpcName ->+  RpcMethod+rpcMethod rpcType (RpcName name) =+  RpcMethod [exon|#{RpcType.methodPrefix rpcType}:#{name}|]++-- |Create an 'RpcMethod' by joining an 'RpcType' and an 'RpcName' with a colon, extracted from an 'RpcHandler'.+rpcHandlerMethod :: RpcHandler r -> RpcMethod+rpcHandlerMethod RpcHandler {rpcType, rpcName} =+  rpcMethod rpcType rpcName++-- |Convert a handler using 'Rpc' without handling errors to the canonical 'Handler' type.+simpleHandler ::+  Member (Rpc !! RpcError) r =>+  Sem (Rpc : Stop Report : r) a ->+  Handler r a+simpleHandler =+  resumeReport
+ lib/Ribosome/Host/Data/RpcMessage.hs view
@@ -0,0 +1,73 @@+module Ribosome.Host.Data.RpcMessage where++import Data.MessagePack (Object (ObjectArray, ObjectNil))+import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize)+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Array (MsgpackArray (msgpackArray))+import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import qualified Ribosome.Host.Data.Request as Request+import Ribosome.Host.Data.Request (Request, TrackedRequest (TrackedRequest), formatReq, formatTrackedReq)+import qualified Ribosome.Host.Data.Response as Response+import Ribosome.Host.Data.Response (TrackedResponse (TrackedResponse), formatTrackedResponse)++rpcError :: Object -> Text+rpcError = \case+  Msgpack e ->+    e+  ObjectArray [_, Msgpack e] ->+    e+  o ->+    show o++pattern ErrorPayload :: Text -> Object+pattern ErrorPayload e <- (rpcError -> e)++data RpcMessage =+  Request TrackedRequest+  |+  Response TrackedResponse+  |+  Notification Request+  deriving stock (Eq, Show)++instance MsgpackEncode RpcMessage where+  toMsgpack = \case+    Request (TrackedRequest i (Request.Request method payload)) ->+      msgpackArray (0 :: Int) i method payload+    Response (TrackedResponse i (Response.Success payload)) ->+      msgpackArray (1 :: Int) i () payload+    Response (TrackedResponse i (Response.Error payload)) ->+      msgpackArray (1 :: Int) i payload ()+    Notification (Request.Request method payload) ->+      msgpackArray (2 :: Int) method payload++instance MsgpackDecode RpcMessage where+  fromMsgpack = \case+    ObjectArray [Msgpack (0 :: Int), Msgpack i, Msgpack method, Msgpack payload] ->+      Right (Request (TrackedRequest i (Request.Request method payload)))+    ObjectArray [Msgpack (1 :: Int), Msgpack i, ObjectNil, payload] ->+      Right (Response (TrackedResponse i (Response.Success payload)))+    ObjectArray [Msgpack (1 :: Int), Msgpack i, ErrorPayload e, ObjectNil] ->+      Right (Response (TrackedResponse i (Response.Error e)))+    ObjectArray [Msgpack (2 :: Int), Msgpack method, Msgpack payload] ->+      Right (Notification (Request.Request method payload))+    o ->+      Left [exon|Invalid format for RpcMessage: #{show o}|]++instance Serialize RpcMessage where+  put =+    Serialize.put . toMsgpack+  get =+    either (fail . toString) pure . fromMsgpack =<< Serialize.get++formatRpcMsg :: RpcMessage -> Text+formatRpcMsg = \case+  Request req ->+    [exon|request #{formatTrackedReq req}|]+  Response res ->+    [exon|response #{formatTrackedResponse res}|]+  Notification req ->+    [exon|notification #{formatReq req}|]
+ lib/Ribosome/Host/Data/RpcName.hs view
@@ -0,0 +1,8 @@+-- |The name of an RPC handler+module Ribosome.Host.Data.RpcName where++-- |This name is used for the function or command registered in Neovim as well as to internally identify a handler.+newtype RpcName =+  RpcName { unRpcName :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)
+ lib/Ribosome/Host/Data/RpcType.hs view
@@ -0,0 +1,143 @@+module Ribosome.Host.Data.RpcType where++import Data.MessagePack (Object)+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)+import Ribosome.Host.Data.RpcName (RpcName (RpcName), unRpcName)++-- |A set of autocmd event specifiers, like @BufEnter@, used to create and trigger autocmds.+newtype AutocmdEvents =+  AutocmdEvents { unAutocmdEvent :: [Text] }+  deriving stock (Eq, Show, Generic)+  deriving newtype (MsgpackEncode, MsgpackDecode)++instance IsString AutocmdEvents where+  fromString =+    AutocmdEvents . pure . fromString++-- |A file pattern like @*.hs@ that defines the files in which an autocmd should be triggered.+--+-- If the 'AutocmdEvents' contain @User@, this denotes the custom event name.+newtype AutocmdPatterns =+  AutocmdPatterns { unAutocmdPattern :: [Text] }+  deriving stock (Eq, Show)+  deriving newtype (MsgpackEncode, MsgpackDecode)++instance IsString AutocmdPatterns where+  fromString =+    AutocmdPatterns . pure . fromString++instance Default AutocmdPatterns where+  def =+    "*"++-- |The buffer number in which a buffer autocmd is supposed to be created.+newtype AutocmdBuffer =+  AutocmdBuffer { unAutocmdBuffer :: Int }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord, MsgpackEncode, MsgpackDecode)++-- |An autocmd group.+newtype AutocmdGroup =+  AutocmdGroup { unAutocmdGroup :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord, MsgpackEncode, MsgpackDecode)++-- |The options with which an autocmd may be defined.+--+-- See @:help :autocmd@.+data AutocmdOptions =+  AutocmdOptions {+    target :: Either AutocmdBuffer AutocmdPatterns,+    nested :: Bool,+    once :: Bool,+    group :: Maybe AutocmdGroup+  }+  deriving stock (Eq, Show, Generic)++instance Default AutocmdOptions where+  def =+    AutocmdOptions (Right "*") False False Nothing++instance IsString AutocmdOptions where+  fromString pat =+    def { target = Right (fromString pat) }++-- |Neovim assigns ID numbers to autocmds.+newtype AutocmdId =+  AutocmdId { unAutocmdId :: Int }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord, MsgpackDecode, MsgpackEncode)++-- |Neovim command completion can be designated as returning /all/ items that may be completed regardless of the current+-- word ('CompleteUnfiltered') or only those that match the current word ('CompleteFiltered').+data CompleteStyle =+  -- |Completion returns matching items.+  CompleteFiltered+  |+  -- |Completion returns all items.+  CompleteUnfiltered+  deriving stock (Eq, Show)++-- |The completion to use for a command.+data CommandCompletion =+  -- |Complete with one of the builtin completions, see @:help :command-completion@.+  CompleteBuiltin Text+  |+  -- |Complete with an RPC handler defined by a plugin.+  CompleteHandler CompleteStyle RpcName+  deriving stock (Eq, Show)++-- |Generate a name for the completion handler of a handler by prefixing its name with @Complete_@.+completionName ::+  RpcName ->+  RpcName+completionName (RpcName n) =+  RpcName [exon|Complete_#{n}|]++-- |Render a 'CommandCompletion' as the value to the @-complete=@ option for a command definition.+completionValue :: CommandCompletion -> Text+completionValue = \case+  CompleteBuiltin completer ->+    completer+  CompleteHandler CompleteFiltered func ->+    [exon|customlist,#{unRpcName (completionName func)}|]+  CompleteHandler CompleteUnfiltered func ->+    [exon|custom,#{unRpcName (completionName func)}|]++-- |Render a 'CommandCompletion' as the @-complete=@ option for a command definition.+completionOption :: CommandCompletion -> Text+completionOption cc =+  [exon|-complete=#{completionValue cc}|]++-- |Options for an RPC command on the Neovim side, consisting of the options described at @:help :command-attributes@+-- and an optional completion handler.+data CommandOptions =+  CommandOptions {+    basic :: Map Text Object,+    completion :: Maybe CommandCompletion+  }+  deriving stock (Show)++-- |The special arguments passed to an RPC call on the Neovim side that correspond to the declared 'CommandOptions'.+newtype CommandArgs =+  CommandArgs { unCommandArgs :: [Text] }+  deriving stock (Eq, Show)++-- |The type of RPC handler and its options.+data RpcType =+  Function+  |+  Command CommandOptions CommandArgs+  |+  Autocmd AutocmdEvents AutocmdOptions+  deriving stock (Show, Generic)++-- |The prefix for the method name used to identify an RPC handler.+methodPrefix :: RpcType -> Text+methodPrefix = \case+  Function -> "function"+  Command _ _ -> "command"+  Autocmd _ _ -> "autocmd"
+ lib/Ribosome/Host/Data/StoredReport.hs view
@@ -0,0 +1,24 @@+-- |Data type that attaches a time stamp to a 'Report'.+module Ribosome.Host.Data.StoredReport where++import qualified Chronos+import Polysemy.Chronos (ChronosTime)+import qualified Time++import Ribosome.Host.Data.Report (Report)++-- |Data type that attaches a time stamp to a 'Report'.+data StoredReport =+  StoredReport {+    report :: Report,+    time :: Chronos.Time+  }+  deriving stock (Show)++-- |Create a new 'StoredReport' by querying the current time from 'ChronosTime'.+now ::+  Member ChronosTime r =>+  Report ->+  Sem r StoredReport+now r =+  StoredReport r <$> Time.now
+ lib/Ribosome/Host/Data/Tuple.hs view
@@ -0,0 +1,5 @@+module Ribosome.Host.Data.Tuple where++dup :: a -> (a, a)+dup a =+  (a, a)
+ lib/Ribosome/Host/Effect/Handlers.hs view
@@ -0,0 +1,11 @@+module Ribosome.Host.Effect.Handlers where++import Data.MessagePack (Object)++import Ribosome.Host.Data.Request (RpcMethod)++data Handlers :: Effect where+  Register :: Handlers m ()+  Run :: RpcMethod -> [Object] -> Handlers m (Maybe Object)++makeSem ''Handlers
+ lib/Ribosome/Host/Effect/Host.hs view
@@ -0,0 +1,10 @@+module Ribosome.Host.Effect.Host where++import Ribosome.Host.Data.Request (Request)+import Ribosome.Host.Data.Response (Response)++data Host :: Effect where+  Request :: Request -> Host m Response+  Notification :: Request -> Host m ()++makeSem ''Host
+ lib/Ribosome/Host/Effect/Log.hs view
@@ -0,0 +1,19 @@+module Ribosome.Host.Effect.Log where++type StderrLog =+  Tagged "stderr" Log++type FileLog =+  Tagged "file" Log++stderrLog ::+  Member StderrLog r =>+  InterpreterFor Log r+stderrLog =+  tag @"stderr"++fileLog ::+  Member FileLog r =>+  InterpreterFor Log r+fileLog =+  tag @"file"
+ lib/Ribosome/Host/Effect/MState.hs view
@@ -0,0 +1,94 @@+-- |A state effect that allows atomic updates with monadic actions.+module Ribosome.Host.Effect.MState where++import Conc (PScoped, pscoped)++-- |A state effect that allows atomic updates with monadic actions.+--+-- The constructor 'muse' is analogous to the usual @state@ combinator, in that it transforms the state monadically+-- alongside a return value, but unlike 'State' and 'AtomicState', the callback may be a 'Sem'.+--+-- This is accomplished by locking every call with an 'MVar'.+--+-- For read-only access to the state that doesn't care about currently running updates, the constructor 'mread' directly+-- returns the state without consulting the lock.+data MState s :: Effect where+  -- |Run a monadic action on the state in a mutually exclusive fashion that additionally returns a value.+  Use :: (s -> m (s, a)) -> MState s m a+  -- |Obtain the current state.+  Read :: MState s m s++-- |Run a monadic action on the state in a mutually exclusive fashion that additionally returns a value.+muse ::+  Member (MState s) r =>+  (s -> Sem r (s, a)) ->+  Sem r a+muse =+  send . Use++-- |Run a monadic action on the state in a mutually exclusive fashion.+mtrans ::+  Member (MState s) r =>+  (s -> Sem r s) ->+  Sem r ()+mtrans f =+  muse (fmap (,()) . f)++-- |Apply a pure function to the state that additionally returns a value.+mstate ::+  Member (MState s) r =>+  (s -> (s, a)) ->+  Sem r a+mstate f =+  muse (pure . f)++-- |Apply a pure function to the state.+mmodify ::+  Member (MState s) r =>+  (s -> s) ->+  Sem r ()+mmodify f =+  mtrans (pure . f)++-- |Replace the state.+mput ::+  Member (MState s) r =>+  s ->+  Sem r ()+mput s =+  mmodify (const s)++-- |Obtain the current state.+mread ::+  Member (MState s) r =>+  Sem r s+mread =+  send Read++-- |Obtain the current state, transformed by a pure function.+mreads ::+  Member (MState s) r =>+  (s -> a) ->+  Sem r a+mreads f =+  f <$> mread++-- |Interpret 'State' in terms of 'MState'.+stateToMState ::+  Member (MState s) r =>+  InterpreterFor (State s) r+stateToMState sem =+  muse \ s ->+    runState s sem++-- |A 'PScoped' alias for 'MState' that allows running it on a local region without having to involve `IO` in the stack.+type ScopedMState s =+  PScoped s () (MState s)++-- |Run a 'PScoped' 'MState' on a local region without having to involve `IO` in the stack.+withMState ::+  Member (ScopedMState s) r =>+  s ->+  InterpreterFor (MState s) r+withMState =+  pscoped
+ lib/Ribosome/Host/Effect/Reports.hs view
@@ -0,0 +1,26 @@+-- |An effect for storing errors.+module Ribosome.Host.Effect.Reports where++import Ribosome.Host.Data.Report (Report, ReportContext)+import Ribosome.Host.Data.StoredReport (StoredReport)++-- |This internal effect stores all errors in memory that have been created through the 'Report' system.+data Reports :: Effect where+  -- |Add a report to the store.+  StoreReport :: ReportContext -> Report -> Reports m ()+  -- |Get all reports.+  StoredReports :: Reports m (Map ReportContext [StoredReport])++makeSem_ ''Reports++-- |Add a report to the store.+storeReport ::+  Member Reports r =>+  ReportContext ->+  Report ->+  Sem r ()++-- |Get all reports.+storedReports ::+  Member Reports r =>+  Sem r (Map ReportContext [StoredReport])
+ lib/Ribosome/Host/Effect/Responses.hs view
@@ -0,0 +1,8 @@+module Ribosome.Host.Effect.Responses where++data Responses k v :: Effect where+  Add :: Responses k v m k+  Wait ::  k -> Responses k v m v+  Respond :: k -> v -> Responses k v m ()++makeSem ''Responses
+ lib/Ribosome/Host/Effect/Rpc.hs view
@@ -0,0 +1,73 @@+module Ribosome.Host.Effect.Rpc where++import Prelude hiding (async)++import Ribosome.Host.Data.ChannelId (ChannelId)+import Ribosome.Host.Data.RpcCall (RpcCall)+import Ribosome.Host.Data.RpcError (RpcError)++-- |This effect abstracts interaction with the Neovim RPC API.+-- An RPC call can either be a /request/ or a /notification/, where the former expects a response to be sent while the+-- latter returns immediately.+--+-- For requests, the constructor 'sync' blocks the current thread while 'async' takes a callback that is called from a+-- new thread.+--+-- The constructor 'notify' sends a notification.+--+-- The module [Ribosome.Api.Data]("Ribosome.Api.Data") contains 'RpcCall's for the entire Neovim API, generated by+-- calling @neovim --api-info@ during compilation from Template Haskell.+--+-- The module "Ribosome.Api" contains functions that call 'sync' with those 'RpcCall's, converting the input and return+-- values to and from msgpack.+--+-- These functions have signatures like:+--+-- > nvimGetVar :: ∀ a r . Member Rpc r => MsgpackDecode a => Text -> Sem r a+--+-- A manual call would be constructed like this:+--+-- > Ribosome.sync (RpcCallRequest (Request "nvim_get_option" [toMsgpack "textwidth"]))+--+-- RPC calls may be batched and sent via @nvim_call_atomic@, see 'RpcCall'.+--+-- This effect's default interpreter uses 'Resumable' for error tracking. See [Errors]("Ribosome#errors").+data Rpc :: Effect where+  -- |Block the current thread while sending an RPC request.+  Sync :: RpcCall a -> Rpc m a+  -- |Send an RPC request and pass the result to the continuation on a new thread.+  Async :: RpcCall a -> (Either RpcError a -> m ()) -> Rpc m ()+  -- |Send an RPC notification and return immediately.+  Notify :: RpcCall a -> Rpc m ()+  -- |The Neovim RPC channel ID+  ChannelId :: Rpc m ChannelId++makeSem_ ''Rpc++-- |Block the current thread while sending an RPC request.+sync ::+  ∀ r a .+  Member Rpc r =>+  RpcCall a ->+  Sem r a++-- |Send an RPC request and pass the result to the continuation on a new thread.+async ::+  ∀ a r .+  Member Rpc r =>+  RpcCall a ->+  (Either RpcError a -> Sem r ()) ->+  Sem r ()++-- |Send an RPC notification and return immediately.+notify ::+  ∀ a r .+  Member Rpc r =>+  RpcCall a ->+  Sem r ()++-- |The Neovim RPC channel ID+channelId ::+  ∀ r .+  Member Rpc r =>+  Sem r ChannelId
+ lib/Ribosome/Host/Effect/UserError.hs view
@@ -0,0 +1,21 @@+-- |The effect 'UserError' decides which messages to display in Neovim.+module Ribosome.Host.Effect.UserError where++import Polysemy.Log (Severity)++-- |The effect 'UserError' decides which messages to display in Neovim.+--+-- Additionally, the text may be manipulated, which is done by the interpreter in "Ribosome", which prefixes the message+-- with the plugin name.+data UserError :: Effect where+  -- |Decide whether and how to display the given message at the given log level.+  UserError :: Text -> Severity -> UserError m (Maybe [Text])++makeSem_ ''UserError++-- |Decide whether and how to display the given message at the given log level.+userError ::+  Member UserError r =>+  Text ->+  Severity ->+  Sem r (Maybe [Text])
+ lib/Ribosome/Host/Embed.hs view
@@ -0,0 +1,95 @@+module Ribosome.Host.Embed where++import Conc (ChanConsumer, ChanEvents, interpretEventsChan)+import Polysemy.Process (Process)+import qualified Polysemy.Process.Effect.Process as Process++import Ribosome.Host.Data.BootError (BootError)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Data.RpcMessage (RpcMessage)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.IOStack (BasicStack)+import Ribosome.Host.Interpreter.Handlers (interpretHandlers, interpretHandlersNull)+import Ribosome.Host.Interpreter.Host (testHost, withHost)+import Ribosome.Host.Interpreter.Process.Embed (interpretProcessCerealNvimEmbed)+import Ribosome.Host.Interpreter.UserError (interpretUserErrorInfo)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)++publishRequests ::+  ∀ res i o r a .+  Members [Process i o, Events res i] r =>+  Sem r a ->+  Sem r a+publishRequests =+  intercept @(Process i o) \case+    Process.Send msg -> do+      publish msg+      Process.send msg+    e ->+      send @(Process i o) (coerce e)++type EmbedExtra =+  [+    ChanEvents RpcMessage,+    ChanConsumer RpcMessage+  ]++type HostEmbedStack =+  RpcStack ++ EmbedExtra ++ RpcDeps++interpretEmbedExtra ::+  Members [Process RpcMessage o, Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  InterpretersFor EmbedExtra r+interpretEmbedExtra =+  interpretEventsChan @RpcMessage .+  publishRequests++interpretRpcDeps ::+  Members [Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  InterpretersFor RpcDeps r+interpretRpcDeps =+  interpretUserErrorInfo .+  interpretProcessCerealNvimEmbed Nothing Nothing++interpretHostEmbed ::+  Members BasicStack r =>+  InterpretersFor HostEmbedStack r+interpretHostEmbed =+  interpretRpcDeps .+  interpretEmbedExtra .+  interpretRpcStack++withHostEmbed ::+  Members BasicStack r =>+  InterpreterFor (Handlers !! Report) (HostEmbedStack ++ r) ->+  InterpretersFor HostEmbedStack r+withHostEmbed handlers =+  interpretHostEmbed .+  handlers .+  withHost .+  insertAt @0++testHostEmbed ::+  Members BasicStack r =>+  InterpreterFor (Handlers !! Report) (HostEmbedStack ++ r) ->+  InterpretersFor (Rpc : HostEmbedStack) r+testHostEmbed handlers =+  interpretHostEmbed .+  handlers .+  testHost .+  insertAt @1++embedNvim ::+  Members BasicStack r =>+  [RpcHandler (HostEmbedStack ++ r)] ->+  InterpretersFor (Rpc : HostEmbedStack) r+embedNvim handlers =+  testHostEmbed (interpretHandlers handlers)++embedNvim_ ::+  Members BasicStack r =>+  InterpretersFor (Rpc : HostEmbedStack) r+embedNvim_ =+  testHostEmbed interpretHandlersNull
+ lib/Ribosome/Host/Error.hs view
@@ -0,0 +1,32 @@+module Ribosome.Host.Error where++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Run a 'Sem' that uses 'Rpc' and discard 'RpcError's, interpreting 'Rpc' to @'Rpc' '!!' 'RpcError'@.+ignoreRpcError ::+  Member (Rpc !! RpcError) r =>+  Sem (Rpc : r) a ->+  Sem r ()+ignoreRpcError =+  resume_ . void++-- |Run a 'Sem' that uses 'Rpc' and catch 'RpcError's with the supplied function, interpreting 'Rpc' to @'Rpc' '!!'+-- 'RpcError'@.+onRpcError ::+  Member (Rpc !! RpcError) r =>+  (RpcError -> Sem r a) ->+  Sem (Rpc : r) a ->+  Sem r a+onRpcError =+  resuming++-- |Resume an error by transforming it to @'Error' 'BootError'@.+resumeBootError ::+  ∀ eff err r .+  Show err =>+  Members [eff !! err, Error BootError] r =>+  InterpreterFor eff r+resumeBootError =+  resumeHoistError @_ @eff (BootError . show @Text)
+ lib/Ribosome/Host/Handler.hs view
@@ -0,0 +1,171 @@+-- |Combinators for creating and manipulating RPC handlers.+module Ribosome.Host.Handler where++import qualified Data.Text as Text++import Ribosome.Host.Data.Execution (Execution (Sync))+import qualified Ribosome.Host.Data.RpcHandler as RpcHandler+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler (RpcHandler))+import Ribosome.Host.Data.RpcName (RpcName)+import qualified Ribosome.Host.Data.RpcType as RpcType+import Ribosome.Host.Data.RpcType (+  AutocmdEvents,+  AutocmdOptions,+  CommandArgs (CommandArgs),+  CommandCompletion (CompleteBuiltin, CompleteHandler),+  CommandOptions (CommandOptions),+  CompleteStyle (CompleteFiltered, CompleteUnfiltered),+  completionName,+  )+import Ribosome.Host.Handler.Codec (HandlerCodec (handlerCodec))+import Ribosome.Host.Handler.Command (CommandHandler (commandOptions), OptionStateZero)++-- |Create an 'RpcHandler' that is triggered by a Neovim function of the specified name.+--+-- The handler can take arbitrary parameters, as long as they are instances of 'Ribosome.MsgpackDecode' (or more+-- specifically, 'Ribosome.Host.Handler.Codec.HandlerArg'), just like the return type.+--+-- When invoking the function from Neovim, a value must be passed for each of the handler function's parameters, except+-- for some special cases, like a number of successive 'Maybe' parameters at the tail of the parameter list.+--+-- The function is converted to use messagepack types by the class 'HandlerCodec'.+--+-- For easier type inference, it is advisable to use @'Handler' r a@ for the return type of the handler instead of using+-- @'Member' ('Stop' 'Ribosome.LogReport') r@.+--+-- Example:+--+-- > import Ribosome+-- >+-- > ping :: Int -> Handler r Int+-- > ping 0 = basicLogReport "Invalid ping number!" ["This is written to the log"]+-- > ping i = pure i+-- >+-- > rpcFunction "Ping" Sync ping+rpcFunction ::+  ∀ r h .+  HandlerCodec h r =>+  -- |Name of the Neovim function that will be created.+  RpcName ->+  -- |Execute sync or async.+  Execution ->+  -- |The handler function.+  h ->+  RpcHandler r+rpcFunction name execution h =+  RpcHandler RpcType.Function name execution (handlerCodec h)++-- |Create an 'RpcHandler' that is triggered by a Neovim command of the specified name.+--+-- The handler can take arbitrary parameters, as long as they are instances of 'Ribosome.MsgpackDecode' (or more+-- specifically, 'Ribosome.Host.Handler.Codec.HandlerArg'), just like the return type.+-- The function is converted to use messagepack types by the class 'HandlerCodec'.+--+-- Commands have an (open) family of special parameter types that will be translated into command options, like+-- 'Ribosome.Range' for the line range specified to the command.+-- See [command params]("Ribosome#command-params").+--+-- For easier type inference, it is advisable to use @'Handler' r a@ for the return type of the handler instead of using+-- @'Member' ('Stop' 'Report') r@.+rpcCommand ::+  ∀ r h .+  HandlerCodec h r =>+  CommandHandler OptionStateZero h =>+  -- |Name of the Neovim function that will be created.+  RpcName ->+  -- |Execute sync or async.+  Execution ->+  -- |The handler function.+  h ->+  RpcHandler r+rpcCommand name execution h =+  RpcHandler (RpcType.Command (CommandOptions opts Nothing) (CommandArgs args)) name execution (handlerCodec h)+  where+    (opts, args) =+      commandOptions @OptionStateZero @h++-- |Add the given completion to an 'RpcHandler'.+complete ::+  CommandCompletion ->+  RpcHandler r ->+  RpcHandler r+complete c = \case+  RpcHandler (RpcType.Command (CommandOptions opts _) args) n e h ->+    RpcHandler (RpcType.Command (CommandOptions opts (Just c)) args) n e h+  h ->+    h++-- |Configure the given 'RpcHandler' to use the specified builtin completion.+completeBuiltin ::+  Text ->+  RpcHandler r ->+  RpcHandler r+completeBuiltin f =+  complete (CompleteBuiltin f)++-- |Create a completion handler that can be used by another handler by wrapping it with 'complete', using the same+-- 'RpcName'.+completeCustom ::+  RpcName ->+  (Text -> Text -> Int -> Handler r [Text]) ->+  CompleteStyle ->+  RpcHandler r+completeCustom name f = \case+  CompleteFiltered ->+    rpcFunction cn Sync f+  CompleteUnfiltered ->+    rpcFunction cn Sync \ lead line pos -> Text.unlines <$> f lead line pos+  where+    cn =+      completionName name++-- |Add command line completion to another 'RpcHandler' by creating a new handler that calls the given function to+-- obtain possible completions.+completeWith ::+  CompleteStyle ->+  (Text -> Text -> Int -> Handler r [Text]) ->+  RpcHandler r ->+  [RpcHandler r]+completeWith style f main@RpcHandler {rpcName} =+  [+    complete (CompleteHandler style rpcName) main,+    completeCustom rpcName f style+  ]++-- |Create an 'RpcHandler' that is triggered by a Neovim autocommand for the specified event.+-- For a user autocommand, specify @User@ for the event and the event name for the file pattern in 'AutocmdOptions'.+--+-- For easier type inference, it is advisable to use @'Handler' r a@ for the return type of the handler instead of using+-- @'Member' ('Stop' 'Report') r@.+rpcAutocmd ::+  ∀ r h .+  HandlerCodec h r =>+  RpcName ->+  -- |Execute sync or async. While autocommands can not interact with return values, this is still useful to keep Neovim+  -- from continuing execution while the handler is active, which is particularly important for @VimLeave@.+  Execution ->+  -- |The Neovim event identifier, like @BufWritePre@ or @User@.+  AutocmdEvents ->+  -- |Various Neovim options like the file pattern.+  AutocmdOptions ->+  -- |The handler function.+  h ->+  RpcHandler r+rpcAutocmd name execution event options h =+  RpcHandler (RpcType.Autocmd event options) name execution (handlerCodec h)++-- |Convenience function for creating a handler that is triggered by both a function and a command of the same name.+-- See 'rpcFunction' and 'rpcCommand'.+rpc ::+  ∀ r h .+  HandlerCodec h r =>+  CommandHandler OptionStateZero h =>+  RpcName ->+  Execution ->+  h ->+  [RpcHandler r]+rpc name execution h =+  [+    rpcFunction name execution h,+    rpcCommand name execution h+  ]
+ lib/Ribosome/Host/Handler/Codec.hs view
@@ -0,0 +1,153 @@+{-# options_haddock prune #-}++module Ribosome.Host.Handler.Codec where++import Data.Aeson (eitherDecodeStrict')+import qualified Data.ByteString as ByteString+import Data.MessagePack (Object)+import qualified Data.Text as Text+import Exon (exon)+import qualified Options.Applicative as Optparse+import Options.Applicative (defaultPrefs, execParserPure, info, renderFailure)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Data.Args (ArgList (ArgList), Args (Args), JsonArgs (JsonArgs), OptionParser (optionParser), Options (Options))+import Ribosome.Host.Data.Bang (Bang (NoBang))+import Ribosome.Host.Data.Bar (Bar (Bar))+import Ribosome.Host.Data.Report (Report, basicReport)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandlerFun)++decodeArg ::+  Member (Stop Report) r =>+  MsgpackDecode a =>+  Object ->+  Sem r a+decodeArg =+  stopEither . first fromText . fromMsgpack++extraError ::+  Member (Stop Report) r =>+  [Object] ->+  Sem r a+extraError o =+  stop (fromString [exon|Extraneous arguments: #{show o}|])++optArg ::+  Member (Stop Report) r =>+  MsgpackDecode a =>+  a ->+  [Object] ->+  Sem r ([Object], a)+optArg dflt = \case+  [] -> pure ([], dflt)+  (o : rest) -> do+    a <- decodeArg o+    pure (rest, a)++-- |This class is used by 'HandlerCodec' to decode handler function parameters.+-- Each parameter may consume zero or arbitrarily many of the RPC message's arguments.+--+-- Users may create instances for their types to implement custom decoding, especially for commands, since those don't+-- have structured arguments.+--+-- See also 'Ribosome.CommandHandler'.+class HandlerArg a r where+  -- Take an arbitrary number of arguments from the list and return a value of type @a@ as well as the remaining+    -- arguments.+  handlerArg :: [Object] -> Sem r ([Object], a)++instance {-# overlappable #-} (+    Member (Stop Report) r,+    MsgpackDecode a+  ) => HandlerArg a r where+    handlerArg = \case+      [] -> stop "too few arguments"+      (o : rest) -> do+        a <- decodeArg o+        pure (rest, a)++instance (+    HandlerArg a r+  ) => HandlerArg (Maybe a) r where+    handlerArg = \case+      [] -> pure ([], Nothing)+      os -> second Just <$> handlerArg os++instance HandlerArg Bar r where+  handlerArg os =+    pure (os, Bar)++instance (+    Member (Stop Report) r+  ) => HandlerArg Bang r where+    handlerArg =+      optArg NoBang++instance (+    Member (Stop Report) r+  ) => HandlerArg Args r where+  handlerArg os =+    case traverse fromMsgpack os of+      Right a ->+        pure ([], Args (Text.unwords a))+      Left e ->+        basicReport [exon|Invalid arguments: #{show os}|] ["Invalid type for Args", show os, e]++instance (+    Member (Stop Report) r+  ) => HandlerArg ArgList r where+  handlerArg os =+    case traverse fromMsgpack os of+      Right a ->+        pure ([], ArgList a)+      Left e ->+        basicReport [exon|Invalid arguments: #{show os}|] ["Invalid type for ArgList", show os, e]++instance (+    Member (Stop Report) r,+    FromJSON a+  ) => HandlerArg (JsonArgs a) r where+  handlerArg os =+    case first toText . eitherDecodeStrict' . ByteString.concat =<< traverse fromMsgpack os of+      Right a ->+        pure ([], JsonArgs a)+      Left e ->+        basicReport [exon|Invalid arguments: #{show os}|] ["Invalid type for JsonArgs", show os, e]++instance (+    Member (Stop Report) r,+    OptionParser a+  ) => HandlerArg (Options a) r where+  handlerArg os =+    case result . execParserPure defaultPrefs (info (optionParser @a) mempty) =<< traverse fromMsgpack os of+      Right a ->+        pure ([], Options a)+      Left e ->+        basicReport [exon|Invalid arguments: #{show os}|] ["Invalid type for Options", show os, e]+    where+      result = \case+        Optparse.Success a -> Right a+        Optparse.Failure e -> Left (toText (fst (renderFailure e "Ribosome")))+        Optparse.CompletionInvoked _ -> Left "Internal optparse error"++-- |The class of functions that can be converted to canonical RPC handlers of type 'RpcHandlerFun'.+class HandlerCodec h r | h -> r where+  -- |Convert a type containing a 'Sem' to a canonicalized 'RpcHandlerFun' by transforming each function parameter with+  -- 'HandlerArg'.+  handlerCodec :: h -> RpcHandlerFun r++instance (+    MsgpackEncode a+  ) => HandlerCodec (Handler r a) r where+    handlerCodec h = \case+      [] -> toMsgpack <$> h+      o -> extraError o++instance (+    HandlerArg a (Stop Report : r),+    HandlerCodec b r+  ) => HandlerCodec (a -> b) r where+  handlerCodec h o = do+    (rest, a) <- handlerArg o+    handlerCodec (h a) rest
+ lib/Ribosome/Host/Handler/Command.hs view
@@ -0,0 +1,242 @@+{-# options_haddock prune #-}++-- |Compute the command options and arguments based on handler function parameters.+module Ribosome.Host.Handler.Command where++import Type.Errors.Pretty (type (%), type (<>))++import Ribosome.Host.Data.Args (ArgList, Args, JsonArgs, Options)+import Ribosome.Host.Data.Bang (Bang)+import Ribosome.Host.Data.Bar (Bar)+import Ribosome.Host.Data.CommandMods (CommandMods)+import Ribosome.Host.Data.CommandRegister (CommandRegister)+import Ribosome.Host.Data.Range (Range, RangeStyleOpt (rangeStyleArg, rangeStyleOpt))+import Data.MessagePack (Object)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)++-- |Represents the value for the command option @-nargs@.+data ArgCount =+  -- |@-nargs=0@+  Zero+  |+  -- |@-nargs=*@+  MinZero+  |+  -- |@-nargs=+@+  MinOne+  deriving stock (Eq, Show)++type family Max (l :: ArgCount) (r :: ArgCount) :: ArgCount where+  Max 'Zero r = r+  Max 'MinZero 'MinOne = 'MinOne+  Max l _ = l++-- |Determines how different special command handler parameter types may interact.+data OptionState =+  OptionState {+    -- |Are special option parameters allowed at this position?+    allowed :: Bool,+    -- |The minimum number of arguments that are expected+    minArgs :: ArgCount,+    -- |Have all arguments been consumed, by types like 'ArgList'?+    argsConsumed :: Maybe Type+  }++type OptionStateZero =+  'OptionState 'True 'Zero 'Nothing++type family CommandSpecial (a :: Type) :: Bool where+  CommandSpecial (Range _) = 'True+  CommandSpecial Bang = 'True+  CommandSpecial Bar = 'True+  CommandSpecial CommandMods = 'True+  CommandSpecial CommandRegister = 'True+  CommandSpecial Args = 'True+  CommandSpecial ArgList = 'True+  CommandSpecial (JsonArgs _) = 'True+  CommandSpecial (Options _) = 'True+  CommandSpecial _ = 'False++-- |Determine the command options and arguments that need to be specified when registering a command, for a special+-- command option parameter.+--+-- See [Command params]("Ribosome#command-params") for the list of supported special types.+class SpecialParam (state :: OptionState) (a :: Type) where+  type TransSpecial state a :: OptionState+  type TransSpecial s _ =+    s++  specialOpt :: Map Text Object+  specialOpt =+    mempty++  specialArg :: Maybe Text+  specialArg =+    Nothing++-- |Emit a compile error if a special command option type is used as a handler parameter after a regular, value+-- parameter.+--+-- The parameter @allowed@ is set to 'False' when the first non-option parameter is encountered.+type family BeforeRegular (allowed :: Bool) (a :: Type) :: Constraint where+  BeforeRegular 'False a =+    TypeError ("Command option type " <> a <> " may not come after non-option") ~ ()+  BeforeRegular 'True _ =+    ()++instance (+    BeforeRegular al (Range rs),+    RangeStyleOpt rs+  ) => SpecialParam ('OptionState al c ac) (Range rs) where+  specialOpt =+    rangeStyleOpt @rs+  specialArg =+    Just (rangeStyleArg @rs)++instance (+    BeforeRegular al Bang+  ) => SpecialParam ('OptionState al c ac) Bang where+  specialOpt =+    [("bang", toMsgpack True)]+  specialArg =+    Just "'<bang>' == '!'"++instance (+    BeforeRegular al Bar+  ) => SpecialParam ('OptionState al c ac) Bar where+  specialOpt =+    [("bar", toMsgpack True)]+  specialArg =+    Nothing++instance (+    BeforeRegular al CommandMods+  ) => SpecialParam ('OptionState al c ac) CommandMods where+  specialOpt =+    mempty+  specialArg =+    Just "<q-mods>"++instance (+    BeforeRegular al CommandRegister+  ) => SpecialParam ('OptionState al c ac) CommandRegister where+  specialOpt =+    [("register", toMsgpack True)]+  specialArg =+    Just "<q-register>"++instance SpecialParam ('OptionState al count 'Nothing) Args where+  type TransSpecial ('OptionState _ count _) _ =+    'OptionState 'True (Max count 'MinZero) ('Just Args)++instance SpecialParam ('OptionState al count ac) (JsonArgs a) where+  type TransSpecial ('OptionState _ count _) (JsonArgs a) =+    'OptionState 'True (Max count 'MinZero) ('Just (JsonArgs a))++instance SpecialParam ('OptionState al count ac) ArgList where+  type TransSpecial ('OptionState _ count _) _ =+    'OptionState 'True (Max count 'MinZero) ('Just ArgList)++instance SpecialParam ('OptionState al count 'Nothing) (Options a) where+  type TransSpecial ('OptionState _ count _) (Options a) =+    'OptionState 'True (Max count 'MinZero) ('Just (Options a))++-- |Determines whether a regular, value parameter is allowed (it isn't after types like 'ArgList' that consume all+-- remaining arguments), and increases the minimum argument count if the parameter isn't 'Maybe'.+class RegularParam (state :: OptionState) (isMaybe :: Bool) a where+  type TransRegular state isMaybe a :: OptionState++type family ArgsError consumer a where+  ArgsError consumer a =+    TypeError (+      "Custom parameter types (here " <> a <> ") cannot be combined with " <> consumer+      %+      "since " <> consumer <> " consumes all arguments"+    )++instance RegularParam ('OptionState al count ('Just consumer)) m a where+  type TransRegular ('OptionState al count ('Just consumer)) m a =+    ArgsError consumer a++instance RegularParam ('OptionState al count 'Nothing) 'True (Maybe a) where+  type TransRegular ('OptionState al count 'Nothing) 'True (Maybe a) =+    'OptionState 'False (Max count 'MinZero) 'Nothing++instance RegularParam ('OptionState al count 'Nothing) 'False a where+  type TransRegular ('OptionState al count 'Nothing) 'False a =+    'OptionState 'False 'MinOne 'Nothing++-- |Determine the command option and parameter that a handler parameter type requires, if any.+class CommandParam (special :: Bool) (state :: OptionState) (a :: Type) where+  -- |Transition the current 'OptionState'.+  type TransState special state a :: OptionState++  paramOpt :: Map Text Object+  paramOpt =+    mempty++  paramArg :: Maybe Text+  paramArg =+    Nothing++instance (+    SpecialParam state a+  ) => CommandParam 'True state a where+    type TransState 'True state a =+      TransSpecial state a++    paramOpt =+      specialOpt @state @a++    paramArg =+      specialArg @state @a++type family IsMaybe (a :: Type) :: Bool where+  IsMaybe (Maybe _) = 'True+  IsMaybe _ = 'False++instance (+    RegularParam state (IsMaybe a) a+  ) => CommandParam 'False state a where+    type TransState 'False state a =+      TransRegular state (IsMaybe a) a++-- |Derive the command options and arguments that should be used when registering the Neovim command, from the+-- parameters of the handler function.+--+-- See [Command params]("Ribosome#command-params") for the list of supported special types.+--+-- The parameter @state@ is a type level value that determines which parameter types may be used after another and+-- counts the number of command arguments that are required or allowed.+-- It is transitioned by families in the classes 'CommandParam', 'SpecialParam' and 'RegularParam'.+class CommandHandler (state :: OptionState) (h :: Type) where+  -- |Return the list of command options and special arguments determined by the handler function's parameters.+  commandOptions :: (Map Text Object, [Text])++instance CommandHandler ('OptionState _a 'Zero c) (Sem r a) where+  commandOptions =+    ([("nargs", toMsgpack @Int 0)], [])++instance CommandHandler ('OptionState _a 'MinZero c) (Sem r a) where+  commandOptions =+    ([("nargs", toMsgpack @Text "*")], ["<f-args>"])++instance CommandHandler ('OptionState _a 'MinOne c) (Sem r a) where+  commandOptions =+    ([("nargs", toMsgpack @Text "+")], ["<f-args>"])++instance (+    special ~ CommandSpecial a,+    next ~ TransState special state a,+    CommandParam special state a,+    CommandHandler next b+  ) => CommandHandler state (a -> b) where+    commandOptions =+      (opts, args)+      where+        opts =+          paramOpt @special @state @a <> optsAfter+        args =+          maybeToList (paramArg @special @state @a) <> argsAfter+        (optsAfter, argsAfter) =+          commandOptions @next @b
+ lib/Ribosome/Host/IOStack.hs view
@@ -0,0 +1,63 @@+module Ribosome.Host.IOStack where++import Conc (ConcStack)+import qualified Data.Text.IO as Text+import Polysemy.Chronos (ChronosTime, interpretTimeChronos)+import System.IO (stderr)++import Ribosome.Host.Config (interpretLogConfig)+import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.HostConfig (HostConfig, LogConfig)+import Ribosome.Host.Effect.Log (FileLog, StderrLog)+import Ribosome.Host.Interpreter.Log (interpretLogStderrFile, interpretLogs)++type LogConfStack =+  [+    Log,+    StderrLog,+    FileLog,+    Reader LogConfig,+    Reader HostConfig+  ]++interpretLogConfStack ::+  Members [ChronosTime, Error BootError, Resource, Race, Async, Embed IO] r =>+  HostConfig ->+  InterpretersFor LogConfStack r+interpretLogConfStack conf =+  runReader conf .+  interpretLogConfig .+  interpretLogs .+  interpretLogStderrFile++type IOStack =+  [+    ChronosTime,+    Error BootError+  ] ++ ConcStack++errorStderr :: IO (Either BootError ()) -> IO ()+errorStderr ma =+  ma >>= \case+    Left (BootError err) -> Text.hPutStrLn stderr err+    Right () -> unit++runIOStack ::+  Sem IOStack () ->+  IO ()+runIOStack =+  errorStderr .+  runConc .+  errorToIOFinal .+  interpretTimeChronos++type BasicStack =+  LogConfStack ++ IOStack++runBasicStack ::+  HostConfig ->+  Sem BasicStack () ->+  IO ()+runBasicStack conf =+  runIOStack .+  interpretLogConfStack conf
+ lib/Ribosome/Host/Interpret.hs view
@@ -0,0 +1,16 @@+module Ribosome.Host.Interpret where++type (|>) :: [k] -> k -> [k]+type (a :: [k]) |> (b :: k) =+  a ++ '[b]++infixl 6 |>++type HigherOrder r r' =+  Members r' (r ++ r')++with :: Sem r a -> (a -> InterpreterFor eff r) -> InterpreterFor eff r+with acquire f sem = do+  a <- acquire+  f a sem+{-# inline with #-}
+ lib/Ribosome/Host/Interpreter/Handlers.hs view
@@ -0,0 +1,77 @@+-- |Interpreters for 'Handlers'.+module Ribosome.Host.Interpreter.Handlers where++import qualified Data.Map.Strict as Map+import Data.MessagePack (Object)++import Ribosome.Host.Data.BootError (BootError)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.Request (RpcMethod)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (+  Handler,+  RpcHandler (RpcHandler),+  RpcHandlerFun,+  hoistRpcHandlers,+  rpcHandlerMethod,+  )+import qualified Ribosome.Host.Effect.Handlers as Handlers+import Ribosome.Host.Effect.Handlers (Handlers (Register, Run))+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.RegisterHandlers (registerHandlers)++-- |Interpret 'Handlers' by performing no actions.+interpretHandlersNull :: InterpreterFor (Handlers !! Report) r+interpretHandlersNull =+  interpretResumable \case+    Register ->+      unit+    Run _ _ ->+      pure Nothing++-- |Interpret 'Handlers' by performing no actions.+noHandlers :: InterpreterFor (Handlers !! Report) r+noHandlers =+  interpretHandlersNull++-- |Create a method-indexed 'Map' from a set of 'RpcHandler's.+handlersByName ::+  [RpcHandler r] ->+  Map RpcMethod (RpcHandlerFun r)+handlersByName =+  Map.fromList . fmap \ rpcDef@(RpcHandler _ _ _ handler) -> (rpcHandlerMethod rpcDef, handler)++-- |Execute the handler corresponding to an 'RpcMethod', if it exists.+runHandler ::+  Map RpcMethod (RpcHandlerFun r) ->+  RpcMethod ->+  [Object] ->+  Handler r (Maybe Object)+runHandler handlers method args =+  traverse ($ args) (Map.lookup method handlers)++-- |Add a set of 'RpcHandler's to the plugin.+--+-- This can be used multiple times and has to be terminated by 'interpretHandlersNull', which is done automatically when+-- using the plugin main functions.+withHandlers ::+  Members [Handlers !! Report, Rpc !! RpcError, Log, Error BootError] r =>+  [RpcHandler r] ->+  Sem r a ->+  Sem r a+withHandlers handlersList@(handlersByName -> handlers) =+  interceptResumable @Report \case+    Register -> do+      restop @Report Handlers.register+      registerHandlers handlersList+    Run method args ->+      maybe (runHandler handlers method args) (pure . Just) =<< restop (Handlers.run method args)++-- |Interpret 'Handlers' with a set of 'RpcHandlers'.+interpretHandlers ::+  Members [Rpc !! RpcError, Log, Error BootError] r =>+  [RpcHandler r] ->+  InterpreterFor (Handlers !! Report) r+interpretHandlers handlers =+  interpretHandlersNull .+  withHandlers (hoistRpcHandlers raiseUnder handlers)
+ lib/Ribosome/Host/Interpreter/Host.hs view
@@ -0,0 +1,132 @@+module Ribosome.Host.Interpreter.Host where++import Conc (Restoration, withAsync_)+import Data.MessagePack (Object (ObjectNil))+import Exon (exon)+import Log (Severity (Error, Warn), dataLog)+import Polysemy.Process (Process)+import System.IO.Error (IOError)++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.Event (Event (Event), EventName (EventName))+import Ribosome.Host.Data.Report (LogReport (LogReport), Report (Report), severity)+import Ribosome.Host.Data.Request (Request (Request), RequestId, RpcMethod (RpcMethod))+import qualified Ribosome.Host.Data.Response as Response+import Ribosome.Host.Data.Response (Response)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcMessage (RpcMessage)+import qualified Ribosome.Host.Effect.Handlers as Handlers+import Ribosome.Host.Effect.Handlers (Handlers)+import qualified Ribosome.Host.Effect.Host as Host+import Ribosome.Host.Effect.Host (Host)+import Ribosome.Host.Effect.Responses (Responses)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Error (resumeBootError)+import Ribosome.Host.Listener (listener)++invalidMethod ::+  Request ->+  Response+invalidMethod (Request (RpcMethod name) _) =+  Response.Error [exon|Invalid method for request: #{name}|]++publishEvent ::+  Member (Events er Event) r =>+  Request ->+  Sem r ()+publishEvent (Request (RpcMethod name) args) =+  publish (Event (EventName name) args)++handlerIOError ::+  Members [Error Report, Final IO] r =>+  Sem r a ->+  Sem r a+handlerIOError =+  fromExceptionSemVia \ (e :: IOError) ->+    Report "Internal error" ["Handler exception", show e] Error++handlerReport ::+  Member (DataLog LogReport) r =>+  Bool ->+  RpcMethod ->+  Report ->+  Sem r ()+handlerReport notification (RpcMethod method) r =+  dataLog (LogReport r (notification || severity r < Error) (severity r >= Warn) (fromText method))++handle ::+  Members [Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Log, Final IO] r =>+  Bool ->+  Request ->+  Sem r (Maybe Response)+handle notification (Request method args) =+  errorToIOFinal (handlerIOError (resuming throw (Handlers.run method args))) >>= \case+    Right Nothing ->+      pure Nothing+    Right (Just a) ->+      pure (Just (Response.Success a))+    Left r@(Report e _ severity) -> do+      handlerReport notification method r+      let+        response =+          if severity < Error then Response.Success ObjectNil else Response.Error e+      pure (Just response)++interpretHost ::+  Members [Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Events er Event, Log, Final IO] r =>+  InterpreterFor Host r+interpretHost =+  interpret \case+    Host.Request req ->+      fromMaybe (invalidMethod req) <$> handle False req+    Host.Notification req -> do+      res <- handle True req+      when (isNothing res) (publishEvent req)++register ::+  Members [Handlers !! Report, Error BootError] r =>+  Sem r ()+register =+  Handlers.register !! \ e -> throw (BootError [exon|Registering handlers: #{show e}|])++type HostDeps er =+  [+    Handlers !! Report,+    Process RpcMessage (Either Text RpcMessage),+    Rpc !! RpcError,+    DataLog LogReport,+    Events er Event,+    Responses RequestId Response !! RpcError,+    Log,+    Error BootError,+    Resource,+    Mask Restoration,+    Race,+    Async,+    Embed IO,+    Final IO+  ]++withHost ::+  Members (HostDeps er) r =>+  InterpreterFor Host r+withHost sem =+  interpretHost do+    withAsync_ listener do+      register+      sem++testHost ::+  Members (HostDeps er) r =>+  InterpretersFor [Rpc, Host] r+testHost =+  withHost .+  resumeBootError @Rpc++runHost ::+  Members (HostDeps er) r =>+  Sem r ()+runHost =+  interpretHost do+    withAsync_ register do+      listener
+ lib/Ribosome/Host/Interpreter/Id.hs view
@@ -0,0 +1,15 @@+module Ribosome.Host.Interpreter.Id where++import Conc (interpretAtomic)+import Polysemy.Input (Input (Input))++-- |Interpret 'Input' by incrementing a numeric type starting from @1@.+interpretInputNum ::+  ∀ a r .+  Num a =>+  Member (Embed IO) r =>+  InterpreterFor (Input a) r+interpretInputNum =+  interpretAtomic @a 1 .+  reinterpret \ Input ->+    atomicState' \ i -> (i + 1, i)
+ lib/Ribosome/Host/Interpreter/Log.hs view
@@ -0,0 +1,118 @@+module Ribosome.Host.Interpreter.Log where++import qualified Data.Text as Text+import Exon (exon)+import qualified Log+import Log (+  Log (Log),+  LogMessage (LogMessage),+  Severity (Warn),+  dataLog,+  formatLogEntry,+  interceptDataLogConc,+  interpretLogDataLogConc,+  interpretLogNull,+  setLogLevel,+  )+import Path (Abs, File, Path, toFilePath)+import Polysemy.Chronos (ChronosTime)+import Polysemy.Log (interpretLogStderrLevelConc)+import Polysemy.Log.Handle (interpretDataLogHandleWith)+import Polysemy.Log.Log (interpretDataLog)+import System.IO (Handle, IOMode (AppendMode), hClose, openFile)++import Ribosome.Host.Api.Effect (nvimEcho)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import qualified Ribosome.Host.Data.HostConfig as HostConfig+import Ribosome.Host.Data.HostConfig (LogConfig (LogConfig))+import Ribosome.Host.Data.Report (LogReport (LogReport), Report (Report), prefixReportContext')+import Ribosome.Host.Effect.Log (FileLog, StderrLog, fileLog, stderrLog)+import qualified Ribosome.Host.Effect.Reports as Reports+import Ribosome.Host.Effect.Reports (Reports)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Effect.UserError (UserError, userError)++echoError ::+  Show e =>+  Members [Rpc !! e, UserError, Log] r =>+  Severity ->+  Text ->+  Severity ->+  Sem r ()+echoError minSeverity err severity | severity >= minSeverity =+  userError err severity >>= traverse_ \ msg ->+    nvimEcho [toMsgpack @[_] msg] True mempty !! \ e' ->+      Log.error [exon|Couldn't echo handler error: #{show e'}|]+echoError _ _ _ =+  unit++logLogReport ::+  Show e =>+  Members [Rpc !! e, Reports, UserError, Log] r =>+  Severity ->+  LogReport ->+  Sem r ()+logLogReport minSeverity (LogReport msg@(Report user log severity) echo store context) =+  withFrozenCallStack do+    Log.log severity (Text.intercalate "\n" (maybeToList (prefixReportContext' context) <> log))+    when store (Reports.storeReport context msg)+    when echo (echoError minSeverity user severity)++interpretDataLogRpc ::+  Show e =>+  Members [Reader LogConfig, Rpc !! e, Reports, UserError, Log, Resource, Race, Async, Embed IO] r =>+  InterpreterFor (DataLog LogReport) r+interpretDataLogRpc sem = do+  LogConfig {..} <- ask+  interpretDataLog (logLogReport logLevelEcho) ((if dataLogConc then interceptDataLogConc 64 else id) sem)++interpretLogRpc ::+  Members [Log, DataLog LogReport] r =>+  InterpreterFor Log r+interpretLogRpc =+  interpret \case+    Log (LogMessage severity msg) -> do+      dataLog (LogReport (Report msg [msg] severity) True (severity >= Warn) mempty)++interpretLogStderrFile ::+  Members [StderrLog, FileLog] r =>+  InterpreterFor Log r+interpretLogStderrFile =+  interpret \case+    Log m ->+      fileLog (send (Log m)) *> stderrLog (send (Log m))++interpretLogHandleLevel ::+  Members [Resource, ChronosTime, Race, Async, Embed IO] r =>+  Handle ->+  Maybe Severity ->+  InterpreterFor Log r+interpretLogHandleLevel handle level =+  interpretDataLogHandleWith handle formatLogEntry .+  setLogLevel level .+  interpretLogDataLogConc 64 .+  raiseUnder+{-# inline interpretLogHandleLevel #-}++interpretLogFileLevel ::+  Members [Resource, ChronosTime, Race, Async, Embed IO] r =>+  Maybe Severity ->+  Path Abs File ->+  InterpreterFor Log r+interpretLogFileLevel level path sem =+  bracket acquire (embed . hClose) \ handle ->+    interpretLogHandleLevel handle level sem+  where+    acquire =+      embed (openFile (toFilePath path) AppendMode)+{-# inline interpretLogFileLevel #-}++interpretLogs ::+  Members [Reader LogConfig, Resource, ChronosTime, Race, Async, Embed IO] r =>+  InterpretersFor [StderrLog, FileLog] r+interpretLogs sem =+  ask >>= \ LogConfig {..} ->+    maybe interpretLogNull (\ f -> interpretLogFileLevel (Just logLevelFile) f) logFile $+    untag @"file" $+    interpretLogStderrLevelConc (Just logLevelStderr) $+    untag @"stderr" sem
+ lib/Ribosome/Host/Interpreter/MState.hs view
@@ -0,0 +1,70 @@+-- |Interpreters for 'MState'.+module Ribosome.Host.Interpreter.MState where++import Conc (Lock, interpretAtomic, interpretLockReentrant, interpretPScopedWithH, lock)+import Polysemy.Internal.Tactics (liftT)++import qualified Ribosome.Host.Effect.MState as MState+import Ribosome.Host.Effect.MState (MState, ScopedMState)++-- |Interpret 'MState' using 'AtomicState' and 'Lock'.+interpretMState ::+  Members [Resource, Race, Mask mres, Embed IO] r =>+  s ->+  InterpreterFor (MState s) r+interpretMState initial =+  interpretLockReentrant .+  interpretAtomic initial .+  reinterpret2H \case+    MState.Use f ->+      lock do+        s0 <- atomicGet+        res <- runTSimple (f s0)+        Inspector ins <- getInspectorT+        for_ (ins res) \ (s, _) -> atomicPut s+        pure (snd <$> res)+    MState.Read ->+      liftT atomicGet++-- |Interpret 'MState' as 'State'.+evalMState ::+  s ->+  InterpreterFor (MState s) r+evalMState initial =+  evalState initial .+  reinterpretH \case+    MState.Use f -> do+      s0 <- raise get+      res <- runTSimple (f s0)+      Inspector ins <- getInspectorT+      for_ (ins res) \ (s, _) -> put s+      pure (snd <$> res)+    MState.Read ->+      liftT get++-- |Internal combinator that runs the dependencies of the scope for 'MState'.+scope ::+  Members [Mask mres, Resource, Race, Embed IO] r =>+  s ->+  (() ->+  Sem (AtomicState s : Lock : r) a) ->+  Sem r a+scope initial use =+  interpretLockReentrant $ interpretAtomic initial $ use ()++-- |Interpret 'MState' as a scoped effect.+interpretMStates ::+  ∀ s mres r .+  Members [Mask mres, Resource, Race, Embed IO] r =>+  InterpreterFor (ScopedMState s) r+interpretMStates =+  interpretPScopedWithH @[AtomicState s, Lock] scope \ () -> \case+    MState.Use f ->+      lock do+        s0 <- atomicGet+        res <- runTSimple (f s0)+        Inspector ins <- getInspectorT+        for_ (ins res) \ (s, _) -> atomicPut s+        pure (snd <$> res)+    MState.Read ->+      liftT atomicGet
+ lib/Ribosome/Host/Interpreter/Process/Cereal.hs view
@@ -0,0 +1,86 @@+module Ribosome.Host.Interpreter.Process.Cereal where++import qualified Data.ByteString as ByteString+import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize, runGetPartial)+import Exon (exon)+import qualified Polysemy.Log as Log+import Polysemy.Process (+  OutputPipe (Stderr, Stdout),+  Process,+  ProcessInput,+  ProcessOptions,+  ProcessOutputParseResult (Done, Fail, Partial),+  SystemProcess,+  interpretProcessOutputIncremental,+  interpretProcess_,+  interpretSystemProcessNative_, SystemProcessScopeError,+  )+import Polysemy.Process.Data.ProcessError (ProcessError)+import Polysemy.Process.Data.SystemProcessError (SystemProcessError)+import qualified Polysemy.Process.Effect.ProcessInput as ProcessInput+import Polysemy.Process.Effect.ProcessOutput (ProcessOutput (Chunk))+import Polysemy.Process.Interpreter.SystemProcess (PipesProcess)+import System.Process.Typed (ProcessConfig)++convertResult :: Serialize.Result a -> ProcessOutputParseResult a+convertResult = \case+  Serialize.Fail err _ ->+    Fail (toText err)+  Serialize.Done a leftover ->+    Done a leftover+  Serialize.Partial cont ->+    Partial (convertResult . cont)++type Parser a =+  ByteString -> ProcessOutputParseResult a++interpretProcessOutputCereal ::+  ∀ a r .+  Serialize a =>+  InterpreterFor (ProcessOutput 'Stdout (Either Text a)) r+interpretProcessOutputCereal =+  interpretProcessOutputIncremental (convertResult . runGetPartial Serialize.get)++interpretProcessOutputLog ::+  ∀ p a r .+  Member Log r =>+  InterpreterFor (ProcessOutput p a) r+interpretProcessOutputLog =+  interpret \case+    Chunk _ msg ->+      ([], "") <$ unless (ByteString.null msg) (Log.debug [exon|Nvim stderr: #{decodeUtf8 msg}|])++interpretProcessInputCereal ::+  Serialize a =>+  InterpreterFor (ProcessInput a) r+interpretProcessInputCereal =+  interpret \case+    ProcessInput.Encode msg ->+      pure (Serialize.encode msg)++interpretProcessCereal ::+  ∀ resource a r .+  Serialize a =>+  Member (Scoped resource (SystemProcess !! SystemProcessError) !! SystemProcessScopeError) r =>+  Members [Log, Resource, Race, Async, Embed IO] r =>+  ProcessOptions ->+  InterpreterFor (Scoped () (Process a (Either Text a)) !! ProcessError) r+interpretProcessCereal options =+  interpretProcessOutputLog @'Stderr .+  interpretProcessOutputCereal .+  interpretProcessInputCereal .+  interpretProcess_ @resource options .+  raiseUnder3++interpretProcessCerealNative ::+  ∀ a r .+  Serialize a =>+  Members [Log, Resource, Race, Async, Embed IO] r =>+  ProcessOptions ->+  ProcessConfig () () () ->+  InterpreterFor (Scoped () (Process a (Either Text a)) !! ProcessError) r+interpretProcessCerealNative options conf =+  interpretSystemProcessNative_ conf .+  interpretProcessCereal @PipesProcess @a options .+  raiseUnder
+ lib/Ribosome/Host/Interpreter/Process/Embed.hs view
@@ -0,0 +1,28 @@+module Ribosome.Host.Interpreter.Process.Embed where++import Data.Serialize (Serialize)+import Polysemy.Process (Process, ProcessOptions, withProcess_)+import System.Process.Typed (ProcessConfig, proc)++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Interpreter.Process.Cereal (interpretProcessCerealNative)++nvimArgs :: [String]+nvimArgs =+  ["--embed", "-n", "-u", "NONE", "-i", "NONE", "--clean", "--headless"]++nvimProc :: ProcessConfig () () ()+nvimProc =+  proc "nvim" nvimArgs++interpretProcessCerealNvimEmbed ::+  Serialize a =>+  Members [Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  Maybe ProcessOptions ->+  Maybe (ProcessConfig () () ()) ->+  InterpreterFor (Process a (Either Text a)) r+interpretProcessCerealNvimEmbed options conf =+  interpretProcessCerealNative (fromMaybe def options) (fromMaybe nvimProc conf) .+  resumeHoistError (BootError . show) .+  withProcess_ @() .+  raiseUnder2
+ lib/Ribosome/Host/Interpreter/Process/Socket.hs view
@@ -0,0 +1,41 @@+module Ribosome.Host.Interpreter.Process.Socket where++import Data.Serialize (Serialize)+import qualified Network.Socket as Socket+import Network.Socket (socketToHandle)+import Path (toFilePath)+import Polysemy.Process (Process, ProcessOptions, interpretProcessHandles)+import Polysemy.Process.Data.ProcessError (ProcessError)+import System.IO (Handle, IOMode (ReadWriteMode))++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.NvimSocket (NvimSocket (NvimSocket))+import Ribosome.Host.Interpreter.Process.Cereal (interpretProcessInputCereal, interpretProcessOutputCereal)++withSocket ::+  Members [Reader NvimSocket, Resource, Error BootError, Embed IO] r =>+  (Handle -> Sem r a) ->+  Sem r a+withSocket use =+  bracket acquire release \ socket ->+    use =<< embed (socketToHandle socket ReadWriteMode)+  where+    acquire = do+      NvimSocket path <- ask+      fromEither . first BootError =<< tryAny do+        socket <- Socket.socket Socket.AF_UNIX Socket.Stream 0+        socket <$ Socket.connect socket (Socket.SockAddrUnix (toFilePath path))+    release =+      tryAny_ . Socket.close++interpretProcessCerealSocket ::+  ∀ a r .+  Serialize a =>+  Members [Reader NvimSocket, Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  ProcessOptions ->+  InterpreterFor (Process a (Either Text a) !! ProcessError) r+interpretProcessCerealSocket options sem =+  withSocket \ handle ->+    interpretProcessOutputCereal $+    interpretProcessInputCereal $+    interpretProcessHandles options handle handle (raiseUnder2 sem)
+ lib/Ribosome/Host/Interpreter/Process/Stdio.hs view
@@ -0,0 +1,20 @@+module Ribosome.Host.Interpreter.Process.Stdio where++import Data.Serialize (Serialize)+import Polysemy.Process (Process, interpretProcessCurrent)++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.IOStack (IOStack)+import Ribosome.Host.Interpreter.Process.Cereal (interpretProcessInputCereal, interpretProcessOutputCereal)++interpretProcessCerealStdio ::+  Serialize a =>+  Members IOStack r =>+  InterpreterFor (Process a (Either Text a)) r+interpretProcessCerealStdio =+  interpretProcessOutputCereal .+  interpretProcessInputCereal .+  interpretProcessCurrent def .+  raiseUnder2 .+  resumeHoistError (BootError . show @Text) .+  raiseUnder
+ lib/Ribosome/Host/Interpreter/Reports.hs view
@@ -0,0 +1,37 @@+-- |Interpreters for 'Reports'.+module Ribosome.Host.Interpreter.Reports where++import Conc (interpretAtomic)+import qualified Data.Map.Strict as Map+import Polysemy.Chronos (ChronosTime)++import Ribosome.Host.Data.Report (ReportContext)+import qualified Ribosome.Host.Data.StoredReport as StoredReport+import Ribosome.Host.Data.StoredReport (StoredReport)+import qualified Ribosome.Host.Effect.Reports as Reports+import Ribosome.Host.Effect.Reports (Reports)++-- |Interpret 'Reports' by storing reports in 'AtomicState'.+interpretReportsAtomic ::+  Members [AtomicState (Map ReportContext [StoredReport]), ChronosTime] r =>+  Int ->+  InterpreterFor Reports r+interpretReportsAtomic maxReports =+  interpret \case+    Reports.StoreReport htag msg -> do+      sr <- StoredReport.now msg+      atomicModify' (Map.alter (alter sr) htag)+      where+        alter sr =+          Just . take maxReports . maybe [sr] (sr :)+    Reports.StoredReports ->+      atomicGet++-- |Interpret 'Reports' by storing reports in 'AtomicState' and interpret the state effect.+interpretReports ::+  Members [ChronosTime, Embed IO] r =>+  InterpreterFor Reports r+interpretReports =+  interpretAtomic mempty .+  interpretReportsAtomic 100 .+  raiseUnder
+ lib/Ribosome/Host/Interpreter/Responses.hs view
@@ -0,0 +1,65 @@+module Ribosome.Host.Interpreter.Responses where++import qualified Data.Map.Strict as Map+import Exon (exon)+import Conc (interpretAtomic)++import qualified Ribosome.Host.Data.RpcError as RpcError+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Effect.Responses (Responses (Add, Respond, Wait))+import Ribosome.Host.Interpreter.Id (interpretInputNum)++failAbsentKey ::+  Show k =>+  Member (Stop RpcError) r =>+  k ->+  (a -> Sem r b) ->+  Maybe a ->+  Sem r b+failAbsentKey k f = \case+  Just resp ->+    f resp+  Nothing ->+    stop (RpcError.Unexpected [exon|No response registered for #{show k}|])++waitAndRemove ::+  Ord k =>+  Members [AtomicState (Map k (MVar v)), Embed IO] r =>+  k ->+  MVar v ->+  Sem r v+waitAndRemove k mv = do+  v <- embed (takeMVar mv)+  v <$ atomicModify' (Map.delete k)++interpretResponsesAtomic ::+  ∀ k v r .+  Ord k =>+  Show k =>+  Members [Input k, AtomicState (Map k (MVar v)), Embed IO] r =>+  InterpreterFor (Responses k v !! RpcError) r+interpretResponsesAtomic =+  interpretResumable \case+    Add -> do+      k <- input+      resp <- embed newEmptyMVar+      k <$ atomicModify' (Map.insert k resp)+    Wait k -> do+      v <- atomicGets (Map.lookup k)+      failAbsentKey k (waitAndRemove k) v+    Respond k v -> do+      stored <- atomicGets (Map.lookup k)+      failAbsentKey k (void . embed . flip tryPutMVar v) stored++interpretResponses ::+  ∀ k v r .+  Ord k =>+  Num k =>+  Show k =>+  Member (Embed IO) r =>+  InterpreterFor (Responses k v !! RpcError) r+interpretResponses =+  interpretAtomic (mempty :: Map k (MVar v)) .+  interpretInputNum .+  interpretResponsesAtomic .+  raiseUnder2
+ lib/Ribosome/Host/Interpreter/Rpc.hs view
@@ -0,0 +1,95 @@+module Ribosome.Host.Interpreter.Rpc where++import Data.MessagePack (Object)+import Exon (exon)+import qualified Polysemy.Log as Log+import qualified Polysemy.Process as Process+import Polysemy.Process (Process)++import Ribosome.Host.Data.ChannelId (ChannelId)+import Ribosome.Host.Data.Request (+  Request (Request, method),+  RequestId,+  TrackedRequest (TrackedRequest),+  arguments,+  formatReq,+  formatTrackedReq,+  )+import qualified Ribosome.Host.Data.Response as Response+import Ribosome.Host.Data.Response (Response)+import Ribosome.Host.Data.RpcCall (RpcCall (RpcCallRequest))+import qualified Ribosome.Host.Data.RpcError as RpcError+import Ribosome.Host.Data.RpcError (RpcError)+import qualified Ribosome.Host.Data.RpcMessage as RpcMessage+import Ribosome.Host.Data.RpcMessage (RpcMessage)+import qualified Ribosome.Host.Effect.Responses as Responses+import Ribosome.Host.Effect.Responses (Responses)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import qualified Ribosome.Host.RpcCall as RpcCall++request ::+  ∀ a o r .+  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>+  Text ->+  Request ->+  (Object -> Either Text a) ->+  Sem r a+request exec req@Request {method, arguments} decode = do+  reqId <- restop Responses.add+  let treq = TrackedRequest reqId (coerce req)+  Log.trace [exon|#{exec} rpc: #{formatTrackedReq treq}|]+  Process.send (RpcMessage.Request treq)+  restop (Responses.wait reqId) >>= \case+    Response.Success a ->+      stopEitherWith RpcError.Decode (decode a)+    Response.Error e ->+      stop (RpcError.Api method arguments e)++handleCall ::+  RpcCall a ->+  (Request -> (Object -> Either Text a) -> Sem r a) ->+  Sem r a+handleCall call handle =+  RpcCall.cata call & \case+    Right (req, decode) -> do+      handle req decode+    Left a ->+      pure a++fetchChannelId ::+  Member (AtomicState (Maybe ChannelId)) r =>+  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>+  Sem r ChannelId+fetchChannelId = do+  (cid, ()) <- handleCall (RpcCallRequest (Request "nvim_get_api_info" [])) (request "sync")+  cid <$ atomicPut (Just cid)++cachedChannelId ::+  Member (AtomicState (Maybe ChannelId)) r =>+  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>+  Sem r ChannelId+cachedChannelId =+  maybe fetchChannelId pure =<< atomicGet++interpretRpc ::+  ∀ o r .+  Member (AtomicState (Maybe ChannelId)) r =>+  Members [Responses RequestId Response !! RpcError, Process RpcMessage o, Log, Async] r =>+  InterpreterFor (Rpc !! RpcError) r+interpretRpc =+  interpretResumableH \case+    Rpc.Sync call ->+      pureT =<< handleCall call (request "sync")+    Rpc.Async call use -> do+      void $ async do+        a <- runStop @RpcError (handleCall call (request "async"))+        runTSimple (use a)+      unitT+    Rpc.Notify call -> do+      handleCall (void call) \ req _ -> do+        Log.trace [exon|notify rpc: #{formatReq req}|]+        Process.send (RpcMessage.Notification req)+      unitT+    Rpc.ChannelId ->+      pureT =<< cachedChannelId
+ lib/Ribosome/Host/Interpreter/UserError.hs view
@@ -0,0 +1,13 @@+module Ribosome.Host.Interpreter.UserError where++import Polysemy.Log (Severity (Info))++import Ribosome.Host.Effect.UserError (UserError (UserError))++interpretUserErrorInfo :: InterpreterFor UserError r+interpretUserErrorInfo =+  interpret \case+    UserError e severity | severity >= Info ->+      pure (Just [e])+    UserError _ _ ->+      pure Nothing
+ lib/Ribosome/Host/Listener.hs view
@@ -0,0 +1,112 @@+module Ribosome.Host.Listener where++import Conc (Lock, Restoration, interpretAtomic, interpretEventsChan, interpretLockReentrant, lock)+import Exon (exon)+import qualified Polysemy.Log as Log+import qualified Polysemy.Process as Process+import Polysemy.Process (Process)++import Ribosome.Host.Data.Request (RequestId (unRequestId), TrackedRequest (TrackedRequest))+import Ribosome.Host.Data.Response (Response, TrackedResponse (TrackedResponse), formatResponse)+import Ribosome.Host.Data.RpcError (RpcError)+import qualified Ribosome.Host.Data.RpcMessage as RpcMessage+import Ribosome.Host.Data.RpcMessage (RpcMessage, formatRpcMsg)+import qualified Ribosome.Host.Effect.Host as Host+import Ribosome.Host.Effect.Host (Host)+import qualified Ribosome.Host.Effect.Responses as Responses+import Ribosome.Host.Effect.Responses (Responses)+import Ribosome.Host.Text (ellipsize)++data ResponseLock =+  ResponseLock+  deriving stock (Eq, Show)++data ResponseSent =+  ResponseSent+  deriving stock (Eq, Show)++readyToSend ::+  Member (AtomicState RequestId) r =>+  RequestId ->+  Sem r Bool+readyToSend i =+  atomicGets \ prev -> prev >= i - 1++-- |Send a response, increment the 'RequestId' tracking the latest sent response, and publish an event that unblocks all+-- waiting responses.+sendResponse ::+  Members [Process RpcMessage a, AtomicState RequestId, Events res ResponseSent, Log] r =>+  RequestId ->+  Response ->+  Sem r ()+sendResponse i response = do+  Log.trace [exon|send response: <#{show (unRequestId i)}> #{formatResponse response}|]+  Process.send (RpcMessage.Response (TrackedResponse i response))+  atomicModify' (max i)+  publish ResponseSent++-- |Check whether the last sent response has a 'RequestId' one smaller than the current response.+-- If true, send the response.+-- This is protected by a mutex to avoid deadlock.+-- Returns whether the response was sent for 'sendWhenReady' to decide whether to recurse.+sendIfReady ::+  Member (Events res ResponseSent) r =>+  Members [Tagged ResponseLock Lock, Process RpcMessage a, AtomicState RequestId, Log, Resource] r =>+  RequestId ->+  Response ->+  Sem r Bool+sendIfReady i response =+  tag $ lock do+    ifM (readyToSend i) (True <$ sendResponse i response) (pure False)++-- |Neovim doesn't permit responses to be sent out of order.+-- If multiple requests from Neovim have been sent concurrently (e.g. triggered from rpc calls themselves, since the+-- user can't achieve this through the UI due to it being single-threaded), and the first one runs longer than the rest,+-- the others have to wait for the first response to be sent.+-- Otherwise, Neovim will just terminate the client connection.+--+-- To ensure this, the last sent 'RequestId' is stored and compared to the current response's ID before sending.+-- If the last ID is not @i - 1@, this waits until all previous responses are sent.+-- A new attempt to respond is triggered via 'Events' in 'sendResponse'.+-- This function calls 'subscribe' before doing the initial ID comparison, to avoid the race condition in which the last+-- response is sent at the same time that the call to 'subscribe' is made after comparing the IDs unsuccessfully and the+-- 'ResponseSent' event is therefore missed, causing this to block indefinitely.+sendWhenReady ::+  Members [Events res ResponseSent, EventConsumer res ResponseSent] r =>+  Members [Tagged ResponseLock Lock, Process RpcMessage a, AtomicState RequestId, Log, Resource] r =>+  RequestId ->+  Response ->+  Sem r ()+sendWhenReady i response =+  subscribe trySend+  where+    trySend =+      unlessM (sendIfReady i response) do+        ResponseSent <- consume+        trySend++dispatch ::+  Members [AtomicState RequestId, Tagged ResponseLock Lock, Events res ResponseSent, EventConsumer res ResponseSent] r =>+  Members [Host, Process RpcMessage a, Responses RequestId Response !! RpcError, Log, Resource, Async] r =>+  RpcMessage ->+  Sem r ()+dispatch = \case+  RpcMessage.Request (TrackedRequest i req) ->+    void (async (sendWhenReady i =<< Host.request req))+  RpcMessage.Response (TrackedResponse i response) ->+    Responses.respond i response !! \ e -> Log.error (show e)+  RpcMessage.Notification req ->+    void (async (Host.notification req))++listener ::+  Members [Host, Process RpcMessage (Either Text RpcMessage)] r =>+  Members [Responses RequestId Response !! RpcError, Log, Resource, Mask Restoration, Race, Async, Embed IO] r =>+  Sem r ()+listener =+  interpretLockReentrant $ untag $ interpretEventsChan $ interpretAtomic 0 $ forever do+    Process.recv >>= \case+      Right msg -> do+        Log.trace [exon|listen: #{ellipsize 500 (formatRpcMsg msg)}|]+        dispatch msg+      Left err ->+        Log.error [exon|listen error: #{err}|]
+ lib/Ribosome/Host/Modify.hs view
@@ -0,0 +1,96 @@+-- |Modify 'RpcCall' constructors that contain calls to @nvim_command@.+--+-- See @:h :command-modifiers@.+module Ribosome.Host.Modify where++import Data.MessagePack (Object (ObjectString))+import Exon (exon)++import Ribosome.Host.Api.Data (Buffer, Window)+import Ribosome.Host.Api.Effect (+  nvimBufGetNumber,+  nvimGetCurrentBuf,+  nvimGetCurrentWin,+  nvimSetCurrentBuf,+  nvimWinGetNumber,+  vimSetCurrentWindow,+  )+import Ribosome.Host.Data.Request (Request (Request))+import Ribosome.Host.Data.RpcCall (RpcCall (RpcCallRequest))+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)++-- |Modify an 'RpcCall' constructor if it contains a request for @nvim_command@ by prefixing it with the given string.+modifyCall :: Text -> RpcCall a -> RpcCall a+modifyCall modifier = \case+  RpcCallRequest (Request "nvim_command" [ObjectString cmd]) ->+    RpcCallRequest (Request "nvim_command" [ObjectString [exon|#{encodeUtf8 modifier} #{cmd}|]])+  c ->+    c++-- |Prefix all @nvim_commands@ called in an action with the given string.+modifyCmd ::+  Member Rpc r =>+  Text ->+  Sem r a ->+  Sem r a+modifyCmd modifier =+  interceptH \case+    Rpc.Sync call ->+      pureT =<< Rpc.sync (modifyCall modifier call)+    Rpc.Async call use ->+      pureT =<< Rpc.async (modifyCall modifier call) (\ r -> void (runTSimple (use r)))+    Rpc.Notify call ->+      pureT =<< Rpc.notify (modifyCall modifier call)+    Rpc.ChannelId ->+      pureT =<< Rpc.channelId++-- |Prefix all @nvim_commands@ called in an action with @silent@.+silent ::+  Member Rpc r =>+  Sem r a ->+  Sem r a+silent =+  modifyCmd "silent"++-- |Prefix all @nvim_commands@ called in an action with @silent!@.+silentBang ::+  Member Rpc r =>+  Sem r a ->+  Sem r a+silentBang =+  modifyCmd "silent!"++-- |Prefix all @nvim_commands@ called in an action with @noautocmd@.+noautocmd ::+  Member Rpc r =>+  Sem r a ->+  Sem r a+noautocmd =+  modifyCmd "noautocmd"++-- |Prefix all @nvim_commands@ called in an action with @windo N@ where @N@ is the number of the given window.+windo ::+  Member Rpc r =>+  Window ->+  Sem r a ->+  Sem r a+windo win ma = do+  previous <- nvimGetCurrentWin+  number <- nvimWinGetNumber win+  a <- modifyCmd [exon|#{show number}windo|] ma+  when (previous /= win) (vimSetCurrentWindow previous)+  pure a++-- |Prefix all @nvim_commands@ called in an action with @bufdo N@ where @N@ is the number of the given buffer.+bufdo ::+  Member Rpc r =>+  Buffer ->+  Sem r a ->+  Sem r a+bufdo buf ma = do+  previous <- nvimGetCurrentBuf+  number <- nvimBufGetNumber buf+  a <- modifyCmd [exon|#{show number}bufdo|] ma+  when (previous /= buf) (nvimSetCurrentBuf previous)+  pure a
+ lib/Ribosome/Host/Optparse.hs view
@@ -0,0 +1,59 @@+-- |Combinators for @optparse-applicative@.+module Ribosome.Host.Optparse where++import Exon (exon)+import Log (Severity, parseSeverity)+import Options.Applicative (ReadM, readerError)+import Options.Applicative.Types (readerAsk)+import Path (Abs, Dir, File, Path, SomeBase (Abs, Rel), parseSomeDir, parseSomeFile, (</>))++-- |Convert a path to absolute, using the first argument as base dir for relative paths.+somePath ::+  Path Abs Dir ->+  SomeBase t ->+  Path Abs t+somePath cwd = \case+  Abs p ->+    p+  Rel p ->+    cwd </> p++-- |A logging severity option for @optparse-applicative@.+severityOption :: ReadM Severity+severityOption = do+  raw <- readerAsk+  maybe (readerError [exon|invalid log level: #{raw}|]) pure (parseSeverity (toText raw))++-- |Parse a path from a string in 'ReadM'.+readPath ::+  String ->+  (String -> Either e (SomeBase t)) ->+  Path Abs Dir ->+  String ->+  ReadM (Path Abs t)+readPath pathType parse cwd raw =+  either (const (readerError [exon|not a valid #{pathType} path: #{raw}|])) (pure . somePath cwd) (parse raw)++-- |A path option for @optparse-applicative@.+pathOption ::+  String ->+  (String -> Either e (SomeBase t)) ->+  Path Abs Dir ->+  ReadM (Path Abs t)+pathOption pathType parse cwd = do+  raw <- readerAsk+  readPath pathType parse cwd raw++-- |A directory path option for @optparse-applicative@.+dirPathOption ::+  Path Abs Dir ->+  ReadM (Path Abs Dir)+dirPathOption =+  pathOption "directory" parseSomeDir++-- |A file path option for @optparse-applicative@.+filePathOption ::+  Path Abs Dir ->+  ReadM (Path Abs File)+filePathOption =+  pathOption "file" parseSomeFile
+ lib/Ribosome/Host/Path.hs view
@@ -0,0 +1,11 @@+-- |Path combinators.+module Ribosome.Host.Path where++import Path (Path, toFilePath)++-- |Render a 'Path' as 'Text'.+pathText ::+  Path b t ->+  Text+pathText =+  toText . toFilePath
+ lib/Ribosome/Host/RegisterHandlers.hs view
@@ -0,0 +1,82 @@+module Ribosome.Host.RegisterHandlers where++import qualified Data.Text as Text+import Exon (exon)+import qualified Polysemy.Log as Log++import Ribosome.Host.Api.Autocmd (autocmd)+import Ribosome.Host.Api.Data (nvimCommand, nvimCreateUserCommand)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.ChannelId (ChannelId (ChannelId))+import Ribosome.Host.Data.Execution (Execution (Async, Sync))+import Ribosome.Host.Data.Report (Report, resumeReport)+import Ribosome.Host.Data.Request (RpcMethod (RpcMethod))+import Ribosome.Host.Data.RpcCall (RpcCall)+import Ribosome.Host.Data.RpcError (RpcError, rpcError)+import Ribosome.Host.Data.RpcHandler (RpcHandler (RpcHandler), rpcMethod)+import Ribosome.Host.Data.RpcName (RpcName (RpcName))+import qualified Ribosome.Host.Data.RpcType as RpcType+import Ribosome.Host.Data.RpcType (CommandArgs (CommandArgs), CommandOptions (CommandOptions), RpcType, completionValue)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)++registerFailed ::+  Member Log r =>+  RpcError ->+  Sem r ()+registerFailed e =+  Log.error [exon|Registering rpc handlers failed: #{rpcError e}|]++trigger :: Execution -> Text+trigger = \case+  Sync -> "rpcrequest"+  Async -> "rpcnotify"++rpcCall ::+  ChannelId ->+  RpcMethod ->+  Execution ->+  Maybe Text ->+  Text+rpcCall (ChannelId i) (RpcMethod method) exec args =+  [exon|call('#{trigger exec}', [#{show i}, '#{method}']#{foldMap appendArgs args})|]+  where+    appendArgs a =+      [exon| + #{a}|]++registerType ::+  ChannelId ->+  RpcMethod ->+  RpcName ->+  Execution ->+  RpcType ->+  RpcCall ()+registerType i method (RpcName name) exec = \case+  RpcType.Function ->+    nvimCommand [exon|function! #{name}(...) range+return #{rpcCall i method exec (Just "a:000")}+endfunction|]+  RpcType.Command (CommandOptions options comp) (CommandArgs args) ->+    nvimCreateUserCommand name [exon|call #{rpcCall i method exec (Just argsText)}|] (options <> foldMap compOpt comp)+    where+      compOpt c =+        [("complete", toMsgpack (completionValue c))]+      argsText =+        [exon|[#{Text.intercalate ", " args}]|]+  RpcType.Autocmd events options ->+    void (autocmd events options [exon|call #{rpcCall i method exec Nothing}|])++registerHandler ::+  ChannelId ->+  RpcHandler r ->+  RpcCall ()+registerHandler i (RpcHandler tpe name exec _) =+  registerType i (rpcMethod tpe name) name exec tpe++registerHandlers ::+  Members [Rpc !! RpcError, Log] r =>+  [RpcHandler r] ->+  Sem (Stop Report : r) ()+registerHandlers defs = do+  i <- resumeReport Rpc.channelId+  Rpc.sync (foldMap (registerHandler i) defs) !! registerFailed
+ lib/Ribosome/Host/Remote.hs view
@@ -0,0 +1,47 @@+module Ribosome.Host.Remote where++import Ribosome.Host.Data.HostConfig (HostConfig)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.IOStack (BasicStack, IOStack, runBasicStack)+import Ribosome.Host.Interpreter.Handlers (interpretHandlers)+import Ribosome.Host.Interpreter.Host (runHost)+import Ribosome.Host.Interpreter.Process.Stdio (interpretProcessCerealStdio)+import Ribosome.Host.Interpreter.UserError (interpretUserErrorInfo)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)++type HostRemoteStack =+  RpcStack ++ RpcDeps++type HostRemoteIOStack =+  HostRemoteStack ++ BasicStack++interpretRpcDeps ::+  Members IOStack r =>+  InterpretersFor RpcDeps r+interpretRpcDeps =+  interpretUserErrorInfo .+  interpretProcessCerealStdio++interpretHostRemote ::+  Members BasicStack r =>+  InterpretersFor HostRemoteStack r+interpretHostRemote =+  interpretRpcDeps .+  interpretRpcStack++runHostRemote ::+  Members BasicStack r =>+  InterpreterFor (Handlers !! Report) (HostRemoteStack ++ r) ->+  Sem r ()+runHostRemote handlers =+  interpretHostRemote (handlers runHost)++runHostRemoteIO ::+  HostConfig ->+  [RpcHandler HostRemoteIOStack] ->+  IO ()+runHostRemoteIO conf handlers =+  runBasicStack conf $+  runHostRemote (interpretHandlers handlers)
+ lib/Ribosome/Host/RpcCall.hs view
@@ -0,0 +1,70 @@+module Ribosome.Host.RpcCall where++import Data.MessagePack (Object (ObjectArray, ObjectNil))+import Exon (exon)++import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Request (Request (Request))+import Ribosome.Host.Data.RpcCall (RpcCall (RpcAtomic, RpcCallRequest, RpcFmap, RpcPure))++decodeAtom ::+  MsgpackDecode a =>+  [Object] ->+  Either Text ([Object], a)+decodeAtom = \case+  o : rest ->+    (rest,) <$> fromMsgpack o+  [] ->+    Left "Too few results in atomic call response"++foldAtomic :: RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))+foldAtomic = \case+  RpcCallRequest req ->+    ([coerce req], decodeAtom)+  RpcPure a ->+    ([], Right . (,a))+  RpcFmap f a ->+    second (second (second f) .) (foldAtomic a)+  RpcAtomic f aa ab ->+    (reqsA <> reqsB, decode)+    where+      decode o = do+        (restA, a) <- decodeA o+        second (f a) <$> decodeB restA+      (reqsB, decodeB) =+        foldAtomic ab+      (reqsA, decodeA) =+        foldAtomic aa++checkLeftovers :: ([Object], a) -> Either Text a+checkLeftovers = \case+  ([], a) -> Right a+  (res, _) -> Left [exon|Excess results in atomic call response: #{show res}|]++atomicRequest :: [Request] -> Request+atomicRequest reqs =+  Request "nvim_call_atomic" [toMsgpack reqs]++atomicResult ::+  ([Object] -> Either Text ([Object], a)) ->+  Object ->+  Either Text a+atomicResult decode = \case+  ObjectArray [Msgpack res, ObjectNil] ->+    checkLeftovers =<< decode res+  ObjectArray [_, errs] ->+    Left (show errs)+  o ->+    Left ("Bad atomic result: " <> show o)++cata :: RpcCall a -> Either a (Request, Object -> Either Text a)+cata = \case+  RpcCallRequest req ->+    Right (req, fromMsgpack)+  RpcPure a ->+    Left a+  RpcFmap f a ->+    bimap f (second (second f .)) (cata a)+  a@RpcAtomic {} ->+    Right (bimap atomicRequest atomicResult (foldAtomic a))
+ lib/Ribosome/Host/Run.hs view
@@ -0,0 +1,56 @@+module Ribosome.Host.Run where++import Conc (ChanConsumer, ChanEvents, interpretAtomic, interpretEventsChan)+import Polysemy.Process (Process)++import Ribosome.Host.Data.Event (Event)+import Ribosome.Host.Data.HostConfig (LogConfig)+import Ribosome.Host.Data.Report (LogReport)+import Ribosome.Host.Data.Request (RequestId)+import Ribosome.Host.Data.Response (Response)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcMessage (RpcMessage)+import Ribosome.Host.Effect.Reports (Reports)+import Ribosome.Host.Effect.Responses (Responses)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Effect.UserError (UserError)+import Ribosome.Host.IOStack (IOStack)+import Ribosome.Host.Interpreter.Log (interpretDataLogRpc, interpretLogRpc)+import Ribosome.Host.Interpreter.Reports (interpretReports)+import Ribosome.Host.Interpreter.Responses (interpretResponses)+import Ribosome.Host.Interpreter.Rpc (interpretRpc)++type RpcProcess =+  Process RpcMessage (Either Text RpcMessage)++type RpcStack =+  [+    Log,+    DataLog LogReport,+    Rpc !! RpcError,+    Responses RequestId Response !! RpcError,+    ChanEvents Event,+    ChanConsumer Event,+    Reports+  ]++type RpcDeps =+  [+    RpcProcess,+    UserError+  ]++interpretRpcStack ::+  Members IOStack r =>+  Members RpcDeps r =>+  Members [Log, Reader LogConfig] r =>+  InterpretersFor RpcStack r+interpretRpcStack =+  interpretReports .+  interpretEventsChan @Event .+  interpretResponses .+  interpretAtomic Nothing .+  interpretRpc .+  raiseUnder .+  interpretDataLogRpc .+  interpretLogRpc
+ lib/Ribosome/Host/Socket.hs view
@@ -0,0 +1,71 @@+module Ribosome.Host.Socket where++import Ribosome.Host.Data.BootError (BootError (BootError))+import Ribosome.Host.Data.NvimSocket (NvimSocket)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Effect.Handlers (Handlers)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.IOStack (BasicStack)+import Ribosome.Host.Interpreter.Handlers (interpretHandlers, interpretHandlersNull)+import Ribosome.Host.Interpreter.Host (testHost, withHost)+import Ribosome.Host.Interpreter.Process.Socket (interpretProcessCerealSocket)+import Ribosome.Host.Interpreter.UserError (interpretUserErrorInfo)+import Ribosome.Host.Run (RpcDeps, RpcStack, interpretRpcStack)++type HostSocketStack =+  RpcStack ++ RpcDeps++interpretRpcDeps ::+  Members [Reader NvimSocket, Error BootError, Log, Resource, Race, Async, Embed IO] r =>+  InterpretersFor RpcDeps r+interpretRpcDeps =+  interpretUserErrorInfo .+  interpretProcessCerealSocket def .+  resumeHoistError (BootError . show @Text) .+  raiseUnder++interpretHostSocket ::+  Members BasicStack r =>+  Member (Reader NvimSocket) r =>+  InterpretersFor HostSocketStack r+interpretHostSocket =+  interpretRpcDeps .+  interpretRpcStack++withHostSocket ::+  Members BasicStack r =>+  Member (Reader NvimSocket) r =>+  InterpreterFor (Handlers !! Report) (HostSocketStack ++ r) ->+  InterpretersFor HostSocketStack r+withHostSocket handlers =+  interpretHostSocket .+  handlers .+  withHost .+  insertAt @0++testHostSocket ::+  Members BasicStack r =>+  Member (Reader NvimSocket) r =>+  InterpreterFor (Handlers !! Report) (HostSocketStack ++ r) ->+  InterpretersFor (Rpc : HostSocketStack) r+testHostSocket handlers =+  interpretHostSocket .+  handlers .+  testHost .+  insertAt @1++runHostSocket ::+  Members BasicStack r =>+  Member (Reader NvimSocket) r =>+  [RpcHandler (HostSocketStack ++ r)] ->+  InterpretersFor (Rpc : HostSocketStack) r+runHostSocket handlers =+  testHostSocket (interpretHandlers handlers)++runHostSocket_ ::+  Members BasicStack r =>+  Member (Reader NvimSocket) r =>+  InterpretersFor (Rpc : HostSocketStack) r+runHostSocket_ =+  testHostSocket interpretHandlersNull
+ lib/Ribosome/Host/TH/Api/Generate.hs view
@@ -0,0 +1,88 @@+module Ribosome.Host.TH.Api.Generate where++import Data.Char (toUpper)+import qualified Data.Map.Strict as Map+import Data.MessagePack (Object)+import Exon (exon)+import Language.Haskell.TH (Dec, DecsQ, Name, Q, Type, appT, conT, listT, mkName, newName, runIO, tupleT)+import Prelude hiding (Type)++import qualified Ribosome.Host.Data.ApiInfo as ApiInfo+import Ribosome.Host.Data.ApiInfo (ApiInfo (ApiInfo), ExtType, ExtTypeMeta, RpcDecl (RpcDecl), apiInfo, unExtType)+import Ribosome.Host.Data.ApiType (ApiPrim (..), ApiType (..))+import Ribosome.Host.Data.LuaRef (LuaRef)+import Ribosome.Host.TH.Api.Param (Param (Param))++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)++reifyApiPrim :: ApiPrim -> Q Type+reifyApiPrim = \case+  Boolean -> [t|Bool|]+  Integer -> [t|Int|]+  Float -> [t|Double|]+  String -> [t|Text|]+  Dictionary -> [t|Map Text Object|]+  Object -> [t|Object|]+  Void -> [t|()|]+  LuaRef -> [t|LuaRef|]++reifyApiType :: ApiType -> Q Type+reifyApiType = \case+  Prim t ->+    reifyApiPrim t+  Array t (Just count) ->+    foldl appT (tupleT count) (replicate count (reifyApiType t))+  Array t Nothing ->+    appT listT (reifyApiType t)+  Ext t ->+    conT (mkName t)++polyName :: Int -> ApiType -> Q (Maybe Name)+polyName i = \case+  Prim Object ->+    Just <$> newName [exon|p_#{show i}|]+  _ ->+    pure Nothing++reifyParam :: Int -> (ApiType, String) -> Q Param+reifyParam i (t, n) = do+  name <- newName prefixed+  mono <- reifyApiType t+  paramType <- polyName i t+  pure (Param name mono paramType)+  where+    prefixed =+      [exon|arg#{show i}_#{n}|]++data MethodSpec =+  MethodSpec {+    apiName :: String,+    camelcaseName :: Name,+    params :: [Param],+    returnType :: ApiType+  }+  deriving stock (Eq, Show)++functionData :: RpcDecl -> Q MethodSpec+functionData (RpcDecl name parameters _ _ _ returnType) = do+  params <- zipWithM reifyParam [0..] parameters+  pure (MethodSpec name (mkName (camelcase name)) params returnType)++genExtTypes :: Map ExtType ExtTypeMeta -> (Name -> ExtTypeMeta -> DecsQ) -> Q [[Dec]]+genExtTypes types gen =+  traverse (uncurry gen) (first (mkName . unExtType) <$> Map.toList types)++generateFromApi :: (MethodSpec -> Q [Dec]) -> Maybe (Name -> ExtTypeMeta -> DecsQ) -> Q [Dec]+generateFromApi handleFunction handleExtType = do+  ApiInfo {functions, types} <- either (fail . show) pure =<< runIO apiInfo+  funcs <- traverse functionData functions+  funcDecs <- traverse handleFunction funcs+  tpeDecs <- traverse (genExtTypes types) handleExtType+  pure (join (funcDecs <> fold tpeDecs))
+ lib/Ribosome/Host/TH/Api/GenerateData.hs view
@@ -0,0 +1,135 @@+module Ribosome.Host.TH.Api.GenerateData where++import Data.MessagePack (Object (ObjectExt))+import Language.Haskell.TH (+  Bang (Bang),+  DecQ,+  DecsQ,+  DerivClause (DerivClause),+  DerivStrategy (StockStrategy),+  Name,+  Q,+  SourceStrictness (SourceStrict),+  SourceUnpackedness (NoSourceUnpackedness),+  Specificity (SpecifiedSpec),+  TyVarBndr (KindedTV),+  Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),+  clause,+  conE,+  conP,+  conT,+  dataD,+  funD,+  integerL,+  listE,+  litP,+  mkName,+  nameBase,+  normalB,+  normalC,+  sigD,+  varE,+  varP,+  )+import Prelude hiding (Type)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Class.Msgpack.Util (illegalType)+import Ribosome.Host.Data.ApiInfo (ExtTypeMeta (ExtTypeMeta))+import Ribosome.Host.Data.ApiType (ApiType, pattern PolyType)+import Ribosome.Host.Data.Request (Request (Request), RpcMethod (RpcMethod))+import Ribosome.Host.Data.RpcCall (RpcCall (RpcCallRequest))+import Ribosome.Host.TH.Api.Generate (MethodSpec (MethodSpec), generateFromApi, reifyApiType)+import Ribosome.Host.TH.Api.GenerateEffect (analyzeReturnType, msgpackEncodeConstraint)+import Ribosome.Host.TH.Api.Param (Param (Param), paramName)++effectiveType :: ApiType -> Q Type+effectiveType = \case+  PolyType ->+    pure (VarT (mkName "a"))+  a ->+    reifyApiType a++dataSig :: [Param] -> Name -> ApiType -> DecQ+dataSig params name returnType = do+  (retTv, retType, decodeConstraint) <- analyzeReturnType returnType+  encodeConstraints <- traverse msgpackEncodeConstraint params+  rc <- [t|RpcCall|]+  let+    paramType = \case+      Param _ _ (Just n) ->+        VarT n+      Param _ t Nothing ->+        t+    paramsType =+      foldr (AppT . AppT ArrowT . paramType) (AppT rc retType) params+    constraints =+      maybeToList decodeConstraint <> catMaybes encodeConstraints+    paramTv = \case+      Param _ _ (Just n) ->+        Just n+      Param _ _ Nothing ->+        Nothing+    paramTvs =+      mapMaybe paramTv params+    tv n =+      KindedTV n SpecifiedSpec StarT+  sigD name (pure (ForallT ((tv <$> paramTvs) <> maybeToList (tv <$> retTv)) constraints paramsType))++dataBody :: String -> Name -> [Param] -> DecQ+dataBody apiName name params =+  funD name [clause (varP <$> names) (normalB rpcCall) []]+  where+    rpcCall =+      [|RpcCallRequest (Request (RpcMethod apiName) $(listE (toObjVar <$> names)))|]+    toObjVar v =+      [|toMsgpack $(varE v)|]+    names =+      paramName <$> params++genRequest :: MethodSpec -> DecsQ+genRequest (MethodSpec apiName name params returnType) = do+  sig <- dataSig params name returnType+  body <- dataBody apiName name params+  pure [sig, body]++extData :: Name -> DecQ+extData name =+  dataD (pure []) name [] Nothing [con] (deriv ["Eq", "Show"])+  where+    con =+      normalC name [(Bang NoSourceUnpackedness SourceStrict,) <$> [t|ByteString|]]+    deriv cls =+      [pure (DerivClause (Just StockStrategy) (ConT . mkName <$> cls))]++decodeInstance :: Name -> Int64 -> DecsQ+decodeInstance name number =+  [d|+  instance MsgpackDecode $(conT name) where+    fromMsgpack = \case+      ObjectExt $(litP (integerL (fromIntegral number))) bytes ->+        pure ($(conE name) bytes)+      o ->+        illegalType (toText (nameBase name)) o+  |]++encodeInstance :: Name -> Int64 -> DecsQ+encodeInstance name number =+  [d|+  instance MsgpackEncode $(conT name) where+    toMsgpack $(conP name [varP (mkName "bytes")]) =+      ObjectExt number bytes+  |]++extDataCodec :: Name -> Int64 -> DecsQ+extDataCodec name number =+  mappend <$> decodeInstance name number <*> encodeInstance name number++genExtTypes :: Name -> ExtTypeMeta -> DecsQ+genExtTypes name (ExtTypeMeta number _) =+  (:) <$> extData name <*> extDataCodec name number++generateData :: DecsQ+generateData =+  generateFromApi genRequest (Just genExtTypes)
+ lib/Ribosome/Host/TH/Api/GenerateEffect.hs view
@@ -0,0 +1,118 @@+module Ribosome.Host.TH.Api.GenerateEffect where++import qualified Data.Kind as Kind+import Exon (exon)+import Language.Haskell.TH (+  Dec,+  DecQ,+  Name,+  Q,+  Quote (newName),+  Specificity (SpecifiedSpec),+  TyVarBndr (KindedTV),+  Type (AppT, ArrowT, ForallT, StarT, VarT),+  appE,+  clause,+  funD,+  mkName,+  nameBase,+  normalB,+  sigD,+  varE,+  varP,+  varT,+  )+import Prelude hiding (Type)++import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))+import Ribosome.Host.Data.ApiType (ApiType, pattern PolyType)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.TH.Api.Generate (MethodSpec (MethodSpec), generateFromApi, reifyApiType)+import Ribosome.Host.TH.Api.Param (Param (Param, paramName))++msgpackDecodeConstraint :: ApiType -> Q (Maybe Type)+msgpackDecodeConstraint = \case+  PolyType ->+    Just <$> [t|MsgpackDecode $(varT (mkName "a"))|]+  _ ->+    pure Nothing++msgpackEncodeConstraint :: Param -> Q (Maybe Type)+msgpackEncodeConstraint = \case+  Param _ _ (Just p) ->+    Just <$> [t|MsgpackEncode $(varT p)|]+  Param _ _ Nothing ->+    pure Nothing++effReturnType :: ApiType -> Q (Maybe Name, Type)+effReturnType = \case+  PolyType -> do+    let n = mkName "a"+    pure (Just n, VarT (mkName "a"))+  a -> do+    t <- reifyApiType a+    pure (Nothing, t)++analyzeReturnType :: ApiType -> Q (Maybe Name, Type, Maybe Type)+analyzeReturnType tpe = do+  (n, rt) <- effReturnType tpe+  constraint <- msgpackDecodeConstraint tpe+  pure (n, rt, constraint)++effSig :: Name -> [Param] -> ApiType -> DecQ+effSig name params returnType = do+  stackName <- newName "r"+  stack <- varT stackName+  rpcConstraint <- [t|Member Rpc $(pure stack)|]+  (retTv, retType, decodeConstraint) <- analyzeReturnType returnType+  encodeConstraints <- traverse msgpackEncodeConstraint params+  semT <- [t|Sem|]+  stackKind <- [t|[(Kind.Type -> Kind.Type) -> Kind.Type -> Kind.Type]|]+  let+    paramType = \case+      Param _ _ (Just n) ->+        VarT n+      Param _ t Nothing ->+        t+    paramsType =+      foldr (AppT . AppT ArrowT . paramType) (AppT (AppT semT stack) retType) params+    constraints =+      rpcConstraint : maybeToList decodeConstraint <> catMaybes encodeConstraints+    paramTv = \case+      Param _ _ (Just n) ->+        Just n+      Param _ _ Nothing ->+        Nothing+    paramTvs =+      mapMaybe paramTv params+    tv n =+      KindedTV n SpecifiedSpec StarT+    stackTv =+      KindedTV stackName SpecifiedSpec stackKind+  sigD name (pure (ForallT ((tv <$> paramTvs) <> maybeToList (tv <$> retTv) <> [stackTv]) constraints paramsType))++effBody :: Name -> [Param] -> DecQ+effBody name params =+  funD name [clause (varP <$> names) (normalB effectCons) []]+  where+    effectCons =+      appE [|Rpc.sync|] args+    args =+      foldl appE (varE (mkName [exon|RpcData.#{nameBase name}|])) (paramE <$> params)+    names =+      paramName <$> params+    paramE = \case+      Param n _ p ->+        fromMaybe id (appE [e|toMsgpack|] <$ p) (varE n)++genMethod :: MethodSpec -> Q [Dec]+genMethod (MethodSpec _ name params returnType) = do+  sig <- effSig name params returnType+  body <- effBody name params+  pure [sig, body]++generateEffect :: Q [Dec]+generateEffect =+  generateFromApi genMethod Nothing
+ lib/Ribosome/Host/TH/Api/Param.hs view
@@ -0,0 +1,8 @@+module Ribosome.Host.TH.Api.Param where++import Language.Haskell.TH (Name, Type)+import Prelude hiding (Type)++data Param =+  Param { paramName :: Name, monoType :: Type, polyName :: Maybe Name }+  deriving stock (Eq, Show)
+ lib/Ribosome/Host/TH/Api/Sig.hs view
@@ -0,0 +1,2 @@+module Ribosome.Host.TH.Api.Sig where+
+ lib/Ribosome/Host/Text.hs view
@@ -0,0 +1,20 @@+module Ribosome.Host.Text where++import qualified Data.Text as Text+import Exon (exon)+import Text.Casing (pascal)++ellipsize :: Int -> Text -> Text+ellipsize maxChars msg =+  [exon|#{pre}#{if Text.null post then "" else "..."}|]+  where+    (pre, post) =+      Text.splitAt maxChars msg++pascalCase ::+  ToString a =>+  IsString b =>+  a ->+  b+pascalCase =+  fromString . pascal . toString
+ ribosome-host.cabal view
@@ -0,0 +1,310 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name:           ribosome-host+version:        0.9.9.9+synopsis:       Neovim plugin host for Polysemy+description:    See https://hackage.haskell.org/package/ribosome-host/docs/Ribosome-Host.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.Host+      Ribosome.Host.Api.Autocmd+      Ribosome.Host.Api.Data+      Ribosome.Host.Api.Effect+      Ribosome.Host.Api.Event+      Ribosome.Host.Class.Msgpack.Array+      Ribosome.Host.Class.Msgpack.Decode+      Ribosome.Host.Class.Msgpack.DecodeSOP+      Ribosome.Host.Class.Msgpack.Encode+      Ribosome.Host.Class.Msgpack.Error+      Ribosome.Host.Class.Msgpack.Map+      Ribosome.Host.Class.Msgpack.Util+      Ribosome.Host.Config+      Ribosome.Host.Data.ApiInfo+      Ribosome.Host.Data.ApiType+      Ribosome.Host.Data.Args+      Ribosome.Host.Data.Bang+      Ribosome.Host.Data.Bar+      Ribosome.Host.Data.BootError+      Ribosome.Host.Data.ChannelId+      Ribosome.Host.Data.CommandMods+      Ribosome.Host.Data.CommandRegister+      Ribosome.Host.Data.Event+      Ribosome.Host.Data.Execution+      Ribosome.Host.Data.HostConfig+      Ribosome.Host.Data.LuaRef+      Ribosome.Host.Data.NvimSocket+      Ribosome.Host.Data.Range+      Ribosome.Host.Data.Report+      Ribosome.Host.Data.Request+      Ribosome.Host.Data.Response+      Ribosome.Host.Data.RpcCall+      Ribosome.Host.Data.RpcError+      Ribosome.Host.Data.RpcHandler+      Ribosome.Host.Data.RpcMessage+      Ribosome.Host.Data.RpcName+      Ribosome.Host.Data.RpcType+      Ribosome.Host.Data.StoredReport+      Ribosome.Host.Data.Tuple+      Ribosome.Host.Effect.Handlers+      Ribosome.Host.Effect.Host+      Ribosome.Host.Effect.Log+      Ribosome.Host.Effect.MState+      Ribosome.Host.Effect.Reports+      Ribosome.Host.Effect.Responses+      Ribosome.Host.Effect.Rpc+      Ribosome.Host.Effect.UserError+      Ribosome.Host.Embed+      Ribosome.Host.Error+      Ribosome.Host.Handler+      Ribosome.Host.Handler.Codec+      Ribosome.Host.Handler.Command+      Ribosome.Host.Interpret+      Ribosome.Host.Interpreter.Handlers+      Ribosome.Host.Interpreter.Host+      Ribosome.Host.Interpreter.Id+      Ribosome.Host.Interpreter.Log+      Ribosome.Host.Interpreter.MState+      Ribosome.Host.Interpreter.Process.Cereal+      Ribosome.Host.Interpreter.Process.Embed+      Ribosome.Host.Interpreter.Process.Socket+      Ribosome.Host.Interpreter.Process.Stdio+      Ribosome.Host.Interpreter.Reports+      Ribosome.Host.Interpreter.Responses+      Ribosome.Host.Interpreter.Rpc+      Ribosome.Host.Interpreter.UserError+      Ribosome.Host.IOStack+      Ribosome.Host.Listener+      Ribosome.Host.Modify+      Ribosome.Host.Optparse+      Ribosome.Host.Path+      Ribosome.Host.RegisterHandlers+      Ribosome.Host.Remote+      Ribosome.Host.RpcCall+      Ribosome.Host.Run+      Ribosome.Host.Socket+      Ribosome.Host.Text+      Ribosome.Host.TH.Api.Generate+      Ribosome.Host.TH.Api.GenerateData+      Ribosome.Host.TH.Api.GenerateEffect+      Ribosome.Host.TH.Api.Param+      Ribosome.Host.TH.Api.Sig+  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 >=2+    , base >=4.12 && <5+    , casing+    , cereal+    , chronos+    , exon+    , first-class-families+    , flatparse+    , generics-sop+    , messagepack+    , network+    , optparse-applicative+    , path+    , polysemy+    , polysemy-chronos+    , polysemy-log+    , polysemy-plugin+    , polysemy-process+    , prelate >=0.1+    , template-haskell+    , type-errors-pretty+    , typed-process+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010++test-suite ribosome-host-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Ribosome.Host.Test.ApiInfoTest+      Ribosome.Host.Test.AsyncTest+      Ribosome.Host.Test.AtomicTest+      Ribosome.Host.Test.AutocmdTest+      Ribosome.Host.Test.CommandArgsTest+      Ribosome.Host.Test.CommandBangTest+      Ribosome.Host.Test.CommandCompleteTest+      Ribosome.Host.Test.CommandModsTest+      Ribosome.Host.Test.CommandParamErrorDecls+      Ribosome.Host.Test.CommandParamErrorTest+      Ribosome.Host.Test.CommandRangeTest+      Ribosome.Host.Test.CommandRegisterTest+      Ribosome.Host.Test.EventTest+      Ribosome.Host.Test.FunctionTest+      Ribosome.Host.Test.LogTest+      Ribosome.Host.Test.MaybeParamTest+      Ribosome.Host.Test.MsgpackTest+      Ribosome.Host.Test.NotifyTest+      Ribosome.Host.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+    , chronos+    , deepseq+    , exon+    , hedgehog+    , messagepack+    , optparse-applicative+    , path+    , polysemy+    , polysemy-chronos+    , polysemy-conc+    , polysemy-plugin+    , polysemy-test+    , prelate >=0.1+    , ribosome-host+    , tasty+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,47 @@+module Main where++import Polysemy.Test (unitTest)+import Ribosome.Host.Test.ApiInfoTest (test_parseType)+import Ribosome.Host.Test.AsyncTest (test_async)+import Ribosome.Host.Test.AtomicTest (test_atomic)+import Ribosome.Host.Test.AutocmdTest (test_autocmd)+import Ribosome.Host.Test.CommandArgsTest (test_args)+import Ribosome.Host.Test.CommandBangTest (test_bang)+import Ribosome.Host.Test.CommandCompleteTest (test_complete)+import Ribosome.Host.Test.CommandModsTest (test_mods)+import Ribosome.Host.Test.CommandParamErrorTest (test_paramError)+import Ribosome.Host.Test.CommandRangeTest (test_range)+import Ribosome.Host.Test.CommandRegisterTest (test_register)+import Ribosome.Host.Test.EventTest (test_errorEvent)+import Ribosome.Host.Test.FunctionTest (test_function)+import Ribosome.Host.Test.LogTest (test_logFile)+import Ribosome.Host.Test.MaybeParamTest (test_maybeParams)+import Ribosome.Host.Test.NotifyTest (test_notify)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "host" [+    unitTest "parse api info types" test_parseType,+    unitTest "function" test_function,+    unitTest "function with Maybe params" test_maybeParams,+    unitTest "async function" test_async,+    testGroup "command" [+      unitTest "args" test_args,+      unitTest "bang" test_bang,+      unitTest "mods" test_mods,+      unitTest "range" test_range,+      unitTest "register" test_register,+      unitTest "errors" test_paramError,+      unitTest "complete" test_complete+    ],+    unitTest "autocmd" test_autocmd,+    unitTest "notify" test_notify,+    unitTest "error event" test_errorEvent,+    unitTest "atomic" test_atomic,+    unitTest "log to file" test_logFile+  ]++main :: IO ()+main =+  defaultMain tests
+ test/Ribosome/Host/Test/ApiInfoTest.hs view
@@ -0,0 +1,36 @@+module Ribosome.Host.Test.ApiInfoTest where++import Polysemy.Test (Hedgehog, UnitTest, assertLeft, assertRight, evalEither, runTestAuto, (===))++import Ribosome.Host.Data.ApiInfo (apiInfo, functions, types)+import Ribosome.Host.Data.ApiType (+  ApiPrim (Boolean, Dictionary, Float, Integer, LuaRef, Object, String, Void),+  ApiType (Array, Ext, Prim),+  parseApiType,+  )++checkType ::+  Member (Hedgehog IO) r =>+  ApiType ->+  ByteString ->+  Sem r ()+checkType target spec =+  assertRight target (parseApiType spec)++test_parseType :: UnitTest+test_parseType =+  runTestAuto do+    checkType (Array (Prim Integer) (Just 5)) "ArrayOf(Integer, 5)"+    checkType (Array (Array (Ext "Buffer") (Just 2)) (Just 3)) "ArrayOf(ArrayOf(Buffer, 2), 3)"+    checkType (Array (Prim Boolean) Nothing) "ArrayOf(Boolean)"+    checkType (Array (Prim Object) Nothing) "Array"+    checkType (Prim Float) "Float"+    checkType (Prim String) "String"+    checkType (Prim Dictionary) "Dictionary"+    checkType (Prim Object) "Object"+    checkType (Prim Void) "void"+    checkType (Prim LuaRef) "LuaRef"+    assertLeft "Parsed (Prim Boolean) but got leftovers: s" (parseApiType "Booleans")+    info <- evalEither =<< embed apiInfo+    246 === length (functions info)+    3 === length (types info)
+ test/Ribosome/Host/Test/AsyncTest.hs view
@@ -0,0 +1,37 @@+module Ribosome.Host.Test.AsyncTest where++import Conc (interpretSync)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertJust)+import Polysemy.Time (Seconds (Seconds))++import Ribosome.Host.Api.Data (nvimCallFunction)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Execution (Execution (Async))+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcFunction)+import Ribosome.Host.Unit.Run (runTest)++hand ::+  Member (Sync Int) r =>+  Int ->+  Handler r ()+hand =+  void . Sync.putWait (Seconds 5)++handlers ::+  ∀ r .+  Member (Sync Int) r =>+  [RpcHandler r]+handlers =+  [+    rpcFunction "Fun" Async hand+  ]++test_async :: UnitTest+test_async =+  runTest $ interpretSync $ embedNvim handlers do+    Rpc.notify (nvimCallFunction @() "Fun" [toMsgpack (47 :: Int)])+    assertJust 47 =<< Sync.takeWait (Seconds 1)
+ test/Ribosome/Host/Test/AtomicTest.hs view
@@ -0,0 +1,55 @@+module Ribosome.Host.Test.AtomicTest where++import Data.MessagePack (Object)+import qualified Conc as Race+import Polysemy.Test (UnitTest, assert, assertJust, (===))+import Polysemy.Time (Seconds (Seconds))++import Ribosome.Host.Api.Data (nvimGetOption, nvimGetVar)+import Ribosome.Host.Api.Effect (nvimSetVar)+import Ribosome.Host.Class.Msgpack.Array (MsgpackArray (msgpackArray))+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Request (Request (Request), TrackedRequest (TrackedRequest))+import Ribosome.Host.Data.RpcCall (RpcCall (RpcPure))+import qualified Ribosome.Host.Data.RpcMessage as RpcMessage+import Ribosome.Host.Data.RpcMessage (RpcMessage)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Unit.Run (embedTest_)++atomicPayload :: [Object]+atomicPayload =+  [+    msgpackArray+    (Request "nvim_get_option" [toMsgpack @Text "modifiable"])+    (Request "nvim_get_option" [toMsgpack @Text "modified"])+    (Request "nvim_get_var" [toMsgpack @Text "a"])+    (Request "nvim_get_var" [toMsgpack @Text "b"])+  ]++test_atomic :: UnitTest+test_atomic =+  embedTest_ do+    subscribe @RpcMessage do+      nvimSetVar "a" (3 :: Int)+      nvimSetVar "b" (7 :: Int)+      (modi, a, b, c) <- Rpc.sync do+        able <- nvimGetOption "modifiable"+        modded <- nvimGetOption "modified"+        c <- RpcPure 11+        a <- nvimGetVar "a"+        b <- nvimGetVar "b"+        pure (able && not modded, a, b, c)+      assert modi+      (3 :: Int) === a+      (7 :: Int) === b+      (11 :: Int) === c+      assert . not =<< Rpc.sync (not <$> nvimGetOption "modifiable")+      void tryConsume+      void tryConsume+      assertJust (req 3 (Request "nvim_call_atomic" atomicPayload)) =<< tryConsume+      assertJust (req 4 (Request "nvim_get_option" (msgpackArray ("modifiable" :: Text)))) =<< tryConsume+  where+    tryConsume =+      Race.timeoutMaybe (Seconds 5) consume+    req n r =+      RpcMessage.Request (TrackedRequest n r)
+ test/Ribosome/Host/Test/AutocmdTest.hs view
@@ -0,0 +1,55 @@+module Ribosome.Host.Test.AutocmdTest where++import Conc (interpretSync)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertJust)+import Polysemy.Time (Seconds (Seconds))++import Ribosome.Host.Api.Effect (nvimCommand, nvimGetVar, nvimSetVar)+import Ribosome.Host.Data.Execution (Execution (Async))+import Ribosome.Host.Data.Report (resumeReport)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import qualified Ribosome.Host.Data.RpcType as AutocmdOptions+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcAutocmd)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "test_var"++au ::+  Members [Rpc !! RpcError, Sync ()] r =>+  Handler r ()+au = do+  resumeReport (nvimSetVar var (12 :: Int))+  void $ Sync.putWait (Seconds 5) ()++bn ::+  Members [Rpc !! RpcError, Sync ()] r =>+  Handler r ()+bn = do+  resumeReport (nvimSetVar var (21 :: Int))+  void $ Sync.putWait (Seconds 5) ()++handlers ::+  ∀ r .+  Members [Rpc !! RpcError, Sync ()] r =>+  [RpcHandler r]+handlers =+  [+    rpcAutocmd "Au" Async "User" "Au" au,+    rpcAutocmd "Bn" Async "BufNew" def { AutocmdOptions.group = Just "test" } bn+  ]++test_autocmd :: UnitTest+test_autocmd =+  runTest $ interpretSync $ embedNvim handlers do+    nvimCommand "doautocmd User Au"+    Sync.takeWait (Seconds 5)+    assertJust @Int 12 =<< nvimGetVar var+    nvimCommand "new"+    Sync.takeWait (Seconds 5)+    assertJust @Int 21 =<< nvimGetVar var
+ test/Ribosome/Host/Test/CommandArgsTest.hs view
@@ -0,0 +1,96 @@+module Ribosome.Host.Test.CommandArgsTest where++import Conc (interpretAtomic)+import Exon (exon)+import Options.Applicative (auto, option, short, switch)+import Polysemy.Test (UnitTest, assertJust)++import Ribosome.Host.Api.Effect (nvimCommand, nvimGetVar, nvimSetVar)+import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)+import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode)+import Ribosome.Host.Data.Args (+  ArgList (ArgList),+  Args (Args),+  JsonArgs (JsonArgs),+  OptionParser (optionParser),+  Options (Options),+  )+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 Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++data Cat =+  Cat {+    fuzziness :: Double,+    sleepy :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, MsgpackEncode, MsgpackDecode)++var :: Text+var =+  "test_var"++args ::+  Member (Rpc !! RpcError) r =>+  Args ->+  Handler r ()+args (Args a) =+  resumeReport (nvimSetVar var a)++argList ::+  Member (Rpc !! RpcError) r =>+  Text ->+  ArgList ->+  Handler r ()+argList _ (ArgList a) =+  resumeReport (nvimSetVar var a)++jsonArgs ::+  Member (Rpc !! RpcError) r =>+  Text ->+  JsonArgs Cat ->+  Handler r ()+jsonArgs _ (JsonArgs cat) =+  resumeReport (nvimSetVar var cat)++instance OptionParser Cat where+  optionParser =+    Cat <$> option auto (short 'f') <*> switch (short 's')++options ::+  Member (Rpc !! RpcError) r =>+  Text ->+  Options Cat ->+  Handler r ()+options _ (Options cat) =+  resumeReport (nvimSetVar var cat)++handlers ::+  ∀ r .+  Members [AtomicState Int, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcCommand "Args" Sync args,+    rpcCommand "ArgList" Sync argList,+    rpcCommand "JsonArgs" Sync jsonArgs,+    rpcCommand "Options" Sync options+  ]++test_args :: UnitTest+test_args =+  runTest $ interpretAtomic 0 $ embedNvim handlers do+    nvimCommand "Args 1 2 3 4 5"+    assertJust @Text "1 2 3 4 5" =<< nvimGetVar var+    nvimCommand "ArgList 1 2 3 4 5"+    assertJust @[Text] ["2", "3", "4", "5"] =<< nvimGetVar var+    nvimCommand [exon|JsonArgs 1 { "fuzziness": 15.1, "sleepy": true }|]+    assertJust (Cat 15.1 True) =<< nvimGetVar var+    nvimCommand [exon|Options 1 -f 15.1 -s|]+    assertJust (Cat 15.1 True) =<< nvimGetVar var
+ test/Ribosome/Host/Test/CommandBangTest.hs view
@@ -0,0 +1,48 @@+module Ribosome.Host.Test.CommandBangTest where++import Conc (interpretAtomic)+import Polysemy.Test (UnitTest, assertJust)++import Ribosome.Host.Api.Effect (nvimCommand, nvimGetVar, nvimSetVar)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Bang (Bang (Bang, NoBang))+import Ribosome.Host.Data.Execution (Execution (Sync))+import Ribosome.Host.Data.Report (Report, resumeReport)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "test_var"++bang ::+  Members [Rpc !! RpcError, Stop Report] r =>+  Bang ->+  Int64 ->+  Sem r ()+bang = \case+  Bang ->+    \ i -> resumeReport (nvimSetVar @[_] var [toMsgpack True, toMsgpack i])+  NoBang ->+    \ i -> resumeReport (nvimSetVar @[_] var [toMsgpack False, toMsgpack i])++handlers ::+  ∀ r .+  Members [AtomicState Int, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcCommand "Bang" Sync (bang @(Stop Report : r))+  ]++test_bang :: UnitTest+test_bang =+  runTest $ interpretAtomic 0 $ embedNvim handlers do+    nvimCommand "Bang! 9"+    assertJust @(_, Int) (True, 9) =<< nvimGetVar var+    nvimCommand "Bang 10"+    assertJust @(_, Int) (False, 10) =<< nvimGetVar var
+ test/Ribosome/Host/Test/CommandCompleteTest.hs view
@@ -0,0 +1,71 @@+module Ribosome.Host.Test.CommandCompleteTest where++import Conc (interpretSync)+import qualified Data.Text as Text+import Exon (exon)+import Polysemy.Test (UnitTest, assertEq, (===))+import qualified Sync+import Time (Seconds (Seconds))++import Ribosome.Host.Api.Effect (nvimCallFunction, nvimGetVar, nvimInput, nvimSetVar)+import Ribosome.Host.Class.Msgpack.Array (msgpackArray)+import Ribosome.Host.Data.Args (Args (Args))+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 Ribosome.Host.Data.RpcType (CompleteStyle (CompleteFiltered, CompleteUnfiltered))+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (completeWith, rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "var"++completing ::+  Members [Sync (), Rpc !! RpcError] r =>+  Args ->+  Handler r ()+completing (Args a) = do+  resumeReport (nvimSetVar var a)+  void (Sync.putWait (Seconds 5) ())++dictionary :: [Text]+dictionary =+  [+    "completion",+    "somethingelse"+  ]++completeFiltered :: Text -> Text -> Int -> Handler r [Text]+completeFiltered lead _ _ =+  pure (filter (Text.isPrefixOf lead) dictionary)++completeUnfiltered :: Text -> Text -> Int -> Handler r [Text]+completeUnfiltered _ _ _ =+  pure dictionary++handlers ::+  ∀ r .+  Members [Sync (), Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  completeWith CompleteFiltered completeFiltered (rpcCommand "CompletingFiltered" Sync completing)+  <>+  completeWith CompleteUnfiltered completeUnfiltered (rpcCommand "CompletingUnfiltered" Sync completing)++test_complete :: UnitTest+test_complete =+  runTest $ interpretSync $ embedNvim handlers do+    test "CompletingFiltered"+    nvimSetVar var ("reset" :: Text)+    test "CompletingUnfiltered"+    res <- nvimCallFunction "Complete_CompletingUnfiltered" (msgpackArray ("comp" :: Text) ("" :: Text) (0 :: Int))+    Text.unlines dictionary === res+  where+    test fun = do+      void (nvimInput [exon|:#{fun} comp<tab><cr>|])+      Sync.takeWait (Seconds 5)+      assertEq "completion" =<< nvimGetVar @Text var
+ test/Ribosome/Host/Test/CommandModsTest.hs view
@@ -0,0 +1,42 @@+module Ribosome.Host.Test.CommandModsTest where++import Conc (interpretAtomic)+import Polysemy.Test (UnitTest, assertJust)++import Ribosome.Host.Api.Effect (nvimCommand, nvimGetVar, nvimSetVar)+import Ribosome.Host.Data.CommandMods (CommandMods (CommandMods))+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 Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "test_var"++mods ::+  Member (Rpc !! RpcError) r =>+  CommandMods ->+  Handler r ()+mods = \case+  CommandMods m ->+    resumeReport (nvimSetVar var m)++handlers ::+  ∀ r .+  Members [AtomicState Int, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcCommand "Mods" Sync mods+  ]++test_mods :: UnitTest+test_mods =+  runTest $ interpretAtomic 0 $ embedNvim handlers do+    nvimCommand "belowright silent lockmarks Mods"+    assertJust @Text "belowright lockmarks silent" =<< nvimGetVar var
+ test/Ribosome/Host/Test/CommandParamErrorDecls.hs view
@@ -0,0 +1,20 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors #-}++module Ribosome.Host.Test.CommandParamErrorDecls where++import Data.MessagePack (Object)++import Ribosome.Host.Data.Args (Args)+import Ribosome.Host.Data.Bang (Bang)+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Handler.Command (OptionStateZero, commandOptions)++argAfterArgs ::+  (Map Text Object, [Text])+argAfterArgs =+  commandOptions @OptionStateZero @(Args -> Int -> ())++argsAfterArg ::+  (Map Text Object, [Text])+argsAfterArg =+  commandOptions @OptionStateZero @(Int -> Bang -> Sem '[Stop Report] ())
+ test/Ribosome/Host/Test/CommandParamErrorTest.hs view
@@ -0,0 +1,40 @@+module Ribosome.Host.Test.CommandParamErrorTest where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import qualified Data.Text as Text+import Polysemy.Test (Hedgehog, UnitTest, assertLeft, runTestAuto)++import Ribosome.Host.Test.CommandParamErrorDecls (argAfterArgs, argsAfterArg)+import Data.MessagePack (Object)++typeError ::+  Members [Hedgehog IO, Embed IO] r =>+  [Text] ->+  (Map Text Object, [Text]) ->+  Sem r ()+typeError msg t = do+  e <- tryAny (evaluate (force t))+  assertLeft msg (first trunc e)+  where+    trunc =+      fmap Text.strip . take (length msg) . drop 1 . lines++argAfterArgsError :: [Text]+argAfterArgsError =+  [+    "• Custom parameter types (here Int) cannot be combined with Args",+    "since Args consumes all arguments"+  ]++argsAfterArgError :: [Text]+argsAfterArgError =+  [+    "• Command option type Bang may not come after non-option"+  ]++test_paramError :: UnitTest+test_paramError =+  runTestAuto do+    typeError argAfterArgsError argAfterArgs+    typeError argsAfterArgError argsAfterArg
+ test/Ribosome/Host/Test/CommandRangeTest.hs view
@@ -0,0 +1,114 @@+module Ribosome.Host.Test.CommandRangeTest where++import Polysemy.Test (UnitTest, assertJust)++import Ribosome.Host.Api.Effect (+  nvimBufSetLines,+  nvimCommand,+  nvimGetCurrentBuf,+  nvimGetCurrentWin,+  nvimGetVar,+  nvimSetVar,+  nvimWinSetCursor,+  )+import Ribosome.Host.Data.Execution (Execution (Sync))+import Ribosome.Host.Data.Report (resumeReport)+import Ribosome.Host.Data.Range (Range (Range), RangeStyle (RangeCount, RangeFile, RangeLine))+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "test_var"++rangeFile ::+  Member (Rpc !! RpcError) r =>+  Range 'RangeFile ->+  Int64 ->+  Handler r ()+rangeFile = \case+  Range l (Just h) ->+    \ i -> resumeReport (nvimSetVar var (l, h, i))+  Range _ Nothing ->+    const (stop "no upper range bound given")++rangeLine ::+  Member (Rpc !! RpcError) r =>+  Range ('RangeLine 'Nothing) ->+  Handler r ()+rangeLine = \case+  Range l (Just h) ->+    resumeReport (nvimSetVar var (l, h))+  Range _ Nothing ->+    stop "no upper range bound given"++rangeLineDefault ::+  Member (Rpc !! RpcError) r =>+  Range ('RangeLine ('Just 13)) ->+  Handler r ()+rangeLineDefault = \case+  Range l Nothing ->+    resumeReport (nvimSetVar var l)+  Range _ (Just _) ->+    stop "range line count function got upper bound"++rangeCountImplicit ::+  Member (Rpc !! RpcError) r =>+  Range ('RangeCount 'Nothing) ->+  Handler r ()+rangeCountImplicit = \case+  Range _ (Just _) ->+    stop "range count function got upper bound"+  Range l Nothing ->+    resumeReport (nvimSetVar var l)++rangeCountDefault ::+  Member (Rpc !! RpcError) r =>+  Range ('RangeCount ('Just 23)) ->+  Handler r ()+rangeCountDefault = \case+  Range _ (Just _) ->+    stop "range count function got upper bound"+  Range l Nothing ->+    resumeReport (nvimSetVar var l)++rangeHandlers ::+  ∀ r .+  Member (Rpc !! RpcError) r =>+  [RpcHandler r]+rangeHandlers =+  [+    rpcCommand "RangeFile" Sync rangeFile,+    rpcCommand "RangeLine" Sync rangeLine,+    rpcCommand "RangeLineDefault" Sync rangeLineDefault,+    rpcCommand "RangeCountImplicit" Sync rangeCountImplicit,+    rpcCommand "RangeCountDefault" Sync rangeCountDefault+  ]++test_range :: UnitTest+test_range =+  runTest $ embedNvim rangeHandlers do+    buf <- nvimGetCurrentBuf+    win <- nvimGetCurrentWin+    nvimBufSetLines buf 0 1 True ["1", "2", "3", "4", "5"]+    nvimWinSetCursor win (3, 1)+    nvimCommand "RangeFile 9"+    assertJust @(Int64, Int64, Int64) (1, 5, 9) =<< nvimGetVar var+    nvimCommand "RangeLine"+    assertJust @(Int64, Int64) (3, 3) =<< nvimGetVar var+    nvimCommand "2,4RangeLine"+    assertJust @(Int64, Int64) (2, 4) =<< nvimGetVar var+    nvimCommand "RangeLineDefault"+    assertJust @Int64 13 =<< nvimGetVar var+    nvimCommand "RangeCountImplicit"+    assertJust @Int64 0 =<< nvimGetVar var+    nvimCommand "RangeCountDefault"+    assertJust @Int64 23 =<< nvimGetVar var+    nvimCommand "144RangeCountDefault"+    assertJust @Int64 144 =<< nvimGetVar var+    nvimCommand "RangeCountDefault 201"+    assertJust @Int64 201 =<< nvimGetVar var
+ test/Ribosome/Host/Test/CommandRegisterTest.hs view
@@ -0,0 +1,41 @@+module Ribosome.Host.Test.CommandRegisterTest where++import Conc (interpretAtomic)+import Polysemy.Test (UnitTest, assertJust)++import Ribosome.Host.Api.Effect (nvimCommand, nvimGetVar, nvimSetVar)+import Ribosome.Host.Data.CommandRegister (CommandRegister (CommandRegister))+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 Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand)+import Ribosome.Host.Unit.Run (runTest)++var :: Text+var =+  "test_var"++reg ::+  Member (Rpc !! RpcError) r =>+  CommandRegister ->+  Handler r ()+reg (CommandRegister r) =+  resumeReport (nvimSetVar var r)++handlers ::+  ∀ r .+  Members [AtomicState Int, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcCommand "Register" Sync reg+  ]++test_register :: UnitTest+test_register =+  runTest $ interpretAtomic 0 $ embedNvim handlers do+    nvimCommand "Register x"+    assertJust @Text "x" =<< nvimGetVar var
+ test/Ribosome/Host/Test/EventTest.hs view
@@ -0,0 +1,31 @@+module Ribosome.Host.Test.EventTest where++import Conc (interpretSync, withAsync_)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertJust)+import Polysemy.Time (Seconds (Seconds))++import qualified Ribosome.Host.Api.Data as Data+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Event (Event (Event))+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Embed (embedNvim_)+import Ribosome.Host.Unit.Run (runTest)++listenEvent ::+  Members [EventConsumer res Event, Sync Event] r =>+  Sem r ()+listenEvent =+  subscribe do+    void . Sync.putWait (Seconds 5) =<< consume @Event++target :: Event+target =+  Event "nvim_error_event" [toMsgpack (0 :: Int), toMsgpack ("Vim(write):E32: No file name" :: Text)]++test_errorEvent :: UnitTest+test_errorEvent =+  runTest $ interpretSync $ embedNvim_ do+    withAsync_ listenEvent do+      Rpc.notify (Data.nvimCommand "write")+      assertJust target =<< Sync.wait (Seconds 5)
+ test/Ribosome/Host/Test/FunctionTest.hs view
@@ -0,0 +1,63 @@+module Ribosome.Host.Test.FunctionTest where++import Conc (interpretAtomic, interpretSync)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertEq, assertJust, assertLeft, assertRight, evalMaybe)+import Polysemy.Time (Seconds (Seconds))++import qualified Ribosome.Host.Api.Data as Data+import Ribosome.Host.Api.Effect (nvimCallFunction, nvimGetVar, nvimSetVar)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Bar (Bar (Bar))+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)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcFunction)+import Ribosome.Host.Unit.Run (runTest)+import qualified Ribosome.Host.Data.RpcError as RpcError+import Data.MessagePack (Object)++var :: Text+var =+  "test_var"++hand ::+  Members [AtomicState Int, Rpc !! RpcError] r =>+  Bar ->+  Bool ->+  Int ->+  Handler r Int+hand Bar _ n = do+  atomicGet >>= \case+    13 ->+      stop "already 13"+    _ -> do+      resumeReport (nvimSetVar var n)+      47 <$ atomicPut 13++targetError :: RpcError+targetError =+  RpcError.Api "nvim_call_function" [toMsgpack @Text "Fun", toMsgpack @[Object] [toMsgpack True, toMsgpack (14 :: Int)]]+  "Vim(return):Error invoking 'function:Fun' on channel 1:\nalready 13"++callTest ::+  Member Rpc r =>+  Int ->+  Sem r Int+callTest n =+  nvimCallFunction "Fun" [toMsgpack True, toMsgpack n]++test_function :: UnitTest+test_function =+  runTest $ interpretAtomic 0 $ embedNvim [rpcFunction "Fun" Sync hand] $ interpretSync do+    nvimSetVar var (10 :: Int)+    Rpc.async (Data.nvimGetVar var) (void . Sync.putTry)+    assertRight (10 :: Int) =<< evalMaybe =<< Sync.wait (Seconds 5)+    assertEq 47 =<< callTest 23+    assertJust (23 :: Int) =<< nvimGetVar var+    assertEq 13 =<< atomicGet+    assertLeft targetError =<< resumeEither (callTest 14)
+ test/Ribosome/Host/Test/LogTest.hs view
@@ -0,0 +1,42 @@+module Ribosome.Host.Test.LogTest where++import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Log (Severity (Crit))+import Path (relfile, toFilePath)+import qualified Polysemy.Test as Test+import Polysemy.Test (UnitTest, assertEq, assertLeft)++import Ribosome.Host.Api.Effect (nvimCallFunction)+import Ribosome.Host.Data.Execution (Execution (Sync))+import Ribosome.Host.Data.Report (Report (Report))+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (Handler, RpcHandler)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcFunction)+import Ribosome.Host.Unit.Run (runTestConf, runUnitTest)++stopper :: Handler r ()+stopper =+  stop (Report "error" ["error!!", "meltdown"] Crit)++handlers :: [RpcHandler r]+handlers =+  [rpcFunction "Stopper" Sync stopper]++fileTarget :: [Text]+fileTarget =+  [+    "\ESC[35m[crit] \ESC[0m [R.H.T.LogTest#21] function:Stopper:",+    "error!!",+    "meltdown"+  ]++test_logFile :: UnitTest+test_logFile =+  runUnitTest do+    file <- Test.tempFile [] [relfile|log/log|]+    runTestConf (def & #hostLog . #logFile ?~ file) do+      embedNvim handlers do+        assertLeft () . first unit =<< resumeEither @RpcError @_ @_ @() (nvimCallFunction "Stopper" [])+    assertEq fileTarget . Text.lines =<< embed (Text.readFile (toFilePath file))
+ test/Ribosome/Host/Test/MaybeParamTest.hs view
@@ -0,0 +1,66 @@+module Ribosome.Host.Test.MaybeParamTest where++import Conc (interpretSync)+import Exon (exon)+import Polysemy.Test (Hedgehog, UnitTest, assertEq, assertJust)+import qualified Sync+import Time (Seconds (Seconds))++import Ribosome.Host.Api.Effect (nvimCallFunction, nvimCommand)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Execution (Execution (Async, Sync))+import Ribosome.Host.Data.RpcHandler (Handler)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcCommand, rpcFunction)+import Ribosome.Host.Unit.Run (runTest)++fun ::+  Maybe Text ->+  Maybe Int ->+  Maybe Int ->+  Handler r Int+fun _ (Just m) (Just n) =+  pure (m * n)+fun _ (Just m) Nothing =+  pure m+fun _ Nothing (Just _) =+  stop "first arg is Nothing"+fun _ Nothing Nothing =+  pure 100++cmd ::+  Member (Sync Int) r =>+  Maybe Text ->+  Maybe Int ->+  Maybe Int ->+  Handler r ()+cmd b m n =+  void . Sync.putWait (Seconds 5) =<< fun b m n++callTest ::+  Members [Rpc, Hedgehog IO] r =>+  Int ->+  [Int] ->+  Sem r ()+callTest target args =+  assertEq target =<< nvimCallFunction "Fun" (toMsgpack ("1" :: Text) : (toMsgpack <$> args))++cmdTest ::+  Members [Sync Int, Rpc, Hedgehog IO] r =>+  Int ->+  Text ->+  Sem r ()+cmdTest target args = do+  nvimCommand [exon|Com 1 #{args}|]+  assertJust target =<< Sync.takeWait (Seconds 5)++test_maybeParams :: UnitTest+test_maybeParams =+  runTest $ interpretSync $ embedNvim [rpcFunction "Fun" Sync fun, rpcCommand "Com" Async cmd] do+    callTest 299 [13, 23]+    callTest 13 [13]+    callTest 100 []+    cmdTest 299 "13 23"+    cmdTest 13 "13"+    cmdTest 100 ""
+ test/Ribosome/Host/Test/MsgpackTest.hs view
@@ -0,0 +1,34 @@+module Ribosome.Host.Test.MsgpackTest where++-- import Data.MessagePack (Object (ObjectMap, ObjectInt, ObjectArray, ObjectString, ObjectFloat))+-- import Polysemy.Test (UnitTest, runTestAuto, assertRight)+-- import Ribosome.Host.Class.Msgpack.DecodeSOP (fromMsgpack, MsgpackDecode)++-- data B =+--   B Double Int64 Object+--   deriving stock (Eq, Show, Generic)+--   deriving anyclass (MsgpackDecode)++-- data A =+--   A1 {+--     a :: Int,+--     b :: B+--   }+--   |+--   A2 B Double+--   |+--   A3 {+--     c :: Double+--   }+--   deriving stock (Eq, Show, Generic)+--   deriving anyclass (MsgpackDecode)++-- test_msgpack :: UnitTest+-- test_msgpack =+--   runTestAuto do+--     assertRight a1 (fromMsgpack (ObjectMap [(ObjectString "a", ObjectInt 5), (ObjectString "b", ObjectArray [ObjectFloat 23.23, ObjectInt 13, o])]))+--   where+--     a1 =+--       A1 5 (B 23.23 13 o)+--     o =+--       ObjectArray [ObjectInt 100, ObjectInt 101]
+ test/Ribosome/Host/Test/NotifyTest.hs view
@@ -0,0 +1,43 @@+module Ribosome.Host.Test.NotifyTest where++import Conc (interpretSync)+import qualified Polysemy.Conc.Sync as Sync+import Polysemy.Test (UnitTest, assertJust)+import Polysemy.Time (Seconds (Seconds))++import Ribosome.Host.Api.Data (nvimCallFunction)+import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)+import Ribosome.Host.Data.Execution (Execution (Async))+import Ribosome.Host.Data.Report (Report)+import Ribosome.Host.Data.RpcError (RpcError)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import qualified Ribosome.Host.Effect.Rpc as Rpc+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (embedNvim)+import Ribosome.Host.Handler (rpcFunction)+import Ribosome.Host.Unit.Run (runTest)++hand ::+  Members [Rpc !! RpcError, Sync Int, Stop Report] r =>+  Int ->+  Sem r ()+hand =+  void . Sync.putWait (Seconds 5)++handlers ::+  ∀ r .+  Members [Sync Int, Rpc !! RpcError] r =>+  [RpcHandler r]+handlers =+  [+    rpcFunction "Fun" Async (hand @(Stop Report : r))+  ]++test_notify :: UnitTest+test_notify =+  runTest $ interpretSync $ embedNvim handlers do+    Rpc.notify (nvimCallFunction @() "Fun" [toMsgpack i])+    assertJust i =<< Sync.takeWait (Seconds 5)+  where+    i =+      13 :: Int
+ test/Ribosome/Host/Unit/Run.hs view
@@ -0,0 +1,121 @@+module Ribosome.Host.Unit.Run where++import qualified Chronos+import Conc (+  GatesIO,+  MaskIO,+  UninterruptibleMaskIO,+  interpretGates,+  interpretMaskFinal,+  interpretRace,+  interpretUninterruptibleMaskFinal,+  )+import Hedgehog.Internal.Property (Failure)+import Log (Severity (Trace), interpretLogStderrConc)+import Polysemy.Chronos (ChronosTime, interpretTimeChronos)+import Polysemy.Test (Hedgehog, Test, TestError (TestError), UnitTest, runTestAuto)+import Time (mkDatetime)++import Ribosome.Host.Data.BootError (BootError (unBootError))+import Ribosome.Host.Data.HostConfig (HostConfig, setStderr)+import Ribosome.Host.Data.RpcHandler (RpcHandler)+import Ribosome.Host.Effect.Rpc (Rpc)+import Ribosome.Host.Embed (HostEmbedStack, embedNvim, embedNvim_)+import Ribosome.Host.IOStack (LogConfStack, interpretLogConfStack)++type TestIOStack =+  [+    Log,+    MaskIO,+    UninterruptibleMaskIO,+    GatesIO,+    Race,+    Async,+    Error BootError,+    Test,+    Fail,+    Error TestError,+    Hedgehog IO,+    Error Failure,+    Embed IO,+    Resource,+    Final IO+  ]++type TestConfStack =+  LogConfStack ++ '[ChronosTime]++type TestStack =+  TestConfStack ++ TestIOStack++type EmbedTestStack =+  HostEmbedStack ++ TestStack++testTime :: Chronos.Time+testTime =+  Chronos.datetimeToTime (mkDatetime 2025 6 15 12 30 30)++runUnitTest ::+  HasCallStack =>+  Sem TestIOStack () ->+  UnitTest+runUnitTest =+  runTestAuto .+  mapError (TestError . unBootError) .+  asyncToIOFinal .+  interpretRace .+  interpretGates .+  interpretUninterruptibleMaskFinal .+  interpretMaskFinal .+  interpretLogStderrConc++runTestConf ::+  Members [Error BootError, Resource, Race, Async, Embed IO] r =>+  HostConfig ->+  InterpretersFor TestConfStack r+runTestConf conf =+  interpretTimeChronos .+  interpretLogConfStack conf++runTest ::+  HasCallStack =>+  Sem TestStack () ->+  UnitTest+runTest =+  runUnitTest .+  runTestConf def++runTestTrace ::+  HasCallStack =>+  Sem TestStack () ->+  UnitTest+runTestTrace =+  runUnitTest .+  runTestConf (setStderr Trace def)++embedTestConf ::+  HasCallStack =>+  HostConfig ->+  [RpcHandler EmbedTestStack] ->+  Sem (Rpc : EmbedTestStack) () ->+  UnitTest+embedTestConf conf handlers =+  runUnitTest .+  runTestConf conf .+  embedNvim handlers++embedTest ::+  HasCallStack =>+  [RpcHandler EmbedTestStack] ->+  Sem (Rpc : EmbedTestStack) () ->+  UnitTest+embedTest =+  embedTestConf def++embedTest_ ::+  HasCallStack =>+  Sem (Rpc : EmbedTestStack) () ->+  UnitTest+embedTest_ =+  runTest .+  embedNvim_