packages feed

ribosome 0.1.2.0 → 0.2.0.0

raw patch · 32 files changed

+1355/−251 lines, 32 filesdep +data-defaultdep +prettyprinter-ansi-terminaldep +typed-processdep −data-default-classdep −stringsdep ~HTFdep ~MissingHdep ~aeson

Dependencies added: data-default, prettyprinter-ansi-terminal, typed-process, unix, unliftio-core

Dependencies removed: data-default-class, strings

Dependency ranges changed: HTF, MissingH, aeson, ansi-terminal, bytestring, containers, deepseq, directory, either, filepath, hslogger, lens, messagepack, mtl, nvim-hs, pretty-terminal, prettyprinter, process, resourcet, safe, split, stm, text, time, transformers, unliftio, utf8-string

Files

lib/Ribosome/Api/Exists.hs view
@@ -1,18 +1,14 @@ module Ribosome.Api.Exists(-  sleep,   retry,   waitForFunction,   vimDoesExist,   function,-  epochSeconds, ) where -import Data.Default.Class (Default(def))+import Control.Monad.IO.Class (MonadIO)+import Data.Default (Default(def)) import Data.Either (isRight)-import Data.Text.Prettyprint.Doc ((<+>), viaShow)-import Data.Time.Clock.POSIX (getPOSIXTime)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Concurrent (threadDelay)+import Data.Text.Prettyprint.Doc ((<+>), viaShow, prettyList) import Neovim (   Neovim,   NvimObject,@@ -24,6 +20,8 @@   vim_call_function',   ) +import Ribosome.Data.Time (epochSeconds, sleep)+ data Retry =   Retry Int Double   deriving Show@@ -31,12 +29,6 @@ instance Default Retry where   def = Retry 3 0.1 -epochSeconds :: MonadIO f => f Int-epochSeconds = liftIO $ fmap round getPOSIXTime--sleep :: MonadIO f => Double -> f ()-sleep seconds = liftIO $ threadDelay $ round $ seconds * 10e6- retry :: MonadIO f => f a -> (a -> f (Either c b)) -> Retry -> f (Either c b) retry thunk check (Retry timeout interval) = do   start <- epochSeconds@@ -70,7 +62,7 @@  existsResult :: Object -> Either (Doc AnsiStyle) () existsResult (ObjectInt 1) = Right ()-existsResult a = Left $ viaShow "weird return type " <+> viaShow a+existsResult a = Left $ prettyList "weird return type " <+> viaShow a  vimExists :: String -> Neovim e Object vimExists entity =
+ lib/Ribosome/Api/Sleep.hs view
@@ -0,0 +1,12 @@+module Ribosome.Api.Sleep(+  nvimSleep,+  nvimMSleep,+) where++import Neovim (Neovim, vim_command')++nvimSleep :: Int -> Neovim e ()+nvimSleep interval = vim_command' $ "sleep " ++ show interval++nvimMSleep :: Int -> Neovim e ()+nvimMSleep interval = vim_command' $ "sleep " ++ show interval ++ "m"
lib/Ribosome/Config/Setting.hs view
@@ -4,8 +4,11 @@   settingE,   updateSetting,   settingVariableName,+  settingOr,+  settingMaybe, ) where +import Data.Either (fromRight) import Neovim import Ribosome.Control.Ribo (Ribo) import qualified Ribosome.Control.Ribosome as R (name)@@ -36,9 +39,17 @@ setting :: NvimObject a => Setting a -> Ribo e a setting s = do   raw <- settingE s-  case raw of-    Right o -> return o-    Left e -> fail e+  either fail return raw++settingOr :: NvimObject a => a -> Setting a -> Ribo e a+settingOr a s = do+  raw <- settingE s+  return $ fromRight a raw++settingMaybe :: NvimObject a => Setting a -> Ribo e (Maybe a)+settingMaybe s = do+  raw <- settingE s+  return $ either (const Nothing) Just raw  updateSetting :: NvimObject a => Setting a -> a -> Ribo e () updateSetting s a = do
+ lib/Ribosome/Control/Monad/Ribo.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}++module Ribosome.Control.Monad.Ribo(+  Ribo,+  RiboT(..),+  MonadRibo(..),+  MonadRiboError(..),+  unsafeToNeovim,+) where++import Control.Concurrent.STM.TVar (swapTVar)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.State (MonadState(..))+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT)+import qualified Control.Monad.Trans.Except as Except (catchE)+import Data.Bifunctor (Bifunctor(..))+import Data.Either.Combinators (mapLeft)+import Data.Functor (void)+import UnliftIO.Exception (throwString)+import UnliftIO.STM (TVar, atomically, readTVarIO)+import Neovim (ask)+import Neovim.Context.Internal (Neovim(Neovim))+import Ribosome.Control.Ribosome (Ribosome)+import qualified Ribosome.Control.Ribosome as Ribosome (env)++type Ribo e = Neovim (Ribosome e)++newtype RiboT s e a =+  RiboT { unRiboT :: ExceptT e (Neovim (Ribosome (TVar s))) a }+  deriving (Functor, Applicative, Monad)++instance Bifunctor (RiboT s) where+  first f (RiboT r) =+    RiboT $ mapExceptT (fmap $ mapLeft f) r++  second = fmap++class MonadRibo s e m | m -> s, m -> e where+  nvim :: Neovim (Ribosome (TVar s)) a -> m a+  asNeovim :: m a -> Neovim (Ribosome (TVar s)) (Either e a)++class Monad (t e) => MonadRiboError e t where+  liftEither :: Either e a -> t e a+  mapE :: (e -> e') -> t e a -> t e' a+  catchE :: (e -> t e' a) -> t e a -> t e' a++instance MonadRibo s e (RiboT s e) where+  nvim = RiboT . ExceptT . fmap Right+  asNeovim = runExceptT . unRiboT++instance MonadRiboError e (RiboT s) where+  liftEither = RiboT . ExceptT . return+  mapE f = RiboT . mapExceptT (fmap $ mapLeft f) . unRiboT+  catchE f = RiboT . flip Except.catchE (unRiboT . f) . unRiboT++instance MonadError e (RiboT s e) where+  throwError = liftEither . Left+  catchError = flip catchE++stateTVar :: (Functor m, MonadRibo s e m) => m (TVar s)+stateTVar =+  Ribosome.env <$> nvim ask++instance MonadState s (RiboT s e) where+  get = do+    t <- stateTVar+    nvim $ readTVarIO t+  put newState = do+    t <- stateTVar+    void $ nvim $ atomically $ swapTVar t newState++unsafeToNeovim :: (MonadRibo s e m, Show e) => m a -> Neovim (Ribosome (TVar s)) a+unsafeToNeovim ra = do+  r <- asNeovim ra+  either (throwString . show) return r
+ lib/Ribosome/Control/Monad/RiboE.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Ribosome.Control.Monad.RiboE(+  Ribo,+  RiboE(..),+  riboE,+  liftRibo,+  runRiboE,+  mapE,+  anaE,+  cataE,+  runRiboReport,+) where++import Control.Monad (join)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (ExceptT(ExceptT), mapExceptT, runExceptT)+import Data.Either.Combinators (mapLeft)+import Neovim.Context.Internal (Neovim)+import UnliftIO.STM (TVar)++import Ribosome.Control.Ribosome (Ribosome)+import Ribosome.Error.Report (ReportError, reportError)++type Ribo e = Neovim (Ribosome (TVar e))++newtype RiboE s e a =+  RiboE { unRiboE :: ExceptT e (Ribo s) a }+  deriving (Functor, Applicative, Monad, MonadIO)++riboE :: (Ribo s) (Either e a) -> RiboE s e a+riboE = RiboE . ExceptT++liftRibo :: Ribo s a -> RiboE s e a+liftRibo = RiboE . lift++runRiboE :: RiboE s e a -> Ribo s (Either e a)+runRiboE = runExceptT . unRiboE++runRiboReport :: ReportError e => String -> RiboE s e () -> Ribo s ()+runRiboReport componentName ma = do+  result <- runRiboE ma+  case result of+    Right _ -> return ()+    Left e -> reportError componentName e++mapE :: (e -> e') -> RiboE s e a -> RiboE s e' a+mapE f =+  RiboE . trans . unRiboE+  where+    trans = mapExceptT (fmap $ mapLeft f)++anaE :: (e -> e') -> RiboE s e (Either e' a) -> RiboE s e' a+anaE f =+  riboE . fmap (join . mapLeft f) . runRiboE++cataE :: (e' -> e) -> RiboE s e (Either e' a) -> RiboE s e a+cataE f =+  riboE . fmap join . runRiboE . fmap (mapLeft f)++instance MonadError e (RiboE s e) where+  throwError =+    RiboE . throwError+  catchError ma f =+    RiboE $ catchError (unRiboE ma) (unRiboE . f)
+ lib/Ribosome/Control/Monad/State.hs view
@@ -0,0 +1,91 @@+module Ribosome.Control.Monad.State(+  riboStateLocalT,+  riboStateT,+  riboStateLocal,+  riboState,+  modifyL,+  prepend,+  riboStateLocalE,+  riboStateE,+  runRiboStateE,+) where++import Control.Lens (Lens')+import qualified Control.Lens as Lens (over, view, set)+import Control.Monad.State.Class (MonadState, modify)+import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.State (StateT, runStateT)+import Ribosome.Control.Monad.RiboE (Ribo, RiboE(..), runRiboE)+import qualified Ribosome.Control.Ribo as Ribo (inspect, modify)++riboStateLocalT ::+  (Monad (t (Ribo s)), MonadTrans t) =>+  Lens' s s' ->+  StateT s' (ExceptT e (t (Ribo s))) a ->+  ExceptT e (t (Ribo s)) a+riboStateLocalT zoom ma = do+  state <- lift $ lift $ Ribo.inspect $ Lens.view zoom+  (output, newState) <- runStateT ma state+  lift $ lift $ Ribo.modify $ Lens.set zoom newState+  return output++riboStateT ::+  (Monad (t (Ribo s)), MonadTrans t) =>+  StateT s (ExceptT e (t (Ribo s))) a ->+  ExceptT e (t (Ribo s)) a+riboStateT =+  riboStateLocalT id++riboStateLocalE ::+  Lens' s s' ->+  StateT s' (ExceptT e (Ribo s)) a ->+  RiboE s e a+riboStateLocalE zoom ma = RiboE $ do+  state <- lift $ Ribo.inspect $ Lens.view zoom+  (output, newState) <- runStateT ma state+  lift $ Ribo.modify $ Lens.set zoom newState+  return output++riboStateE ::+  StateT s (ExceptT e (Ribo s)) a ->+  RiboE s e a+riboStateE =+  riboStateLocalE id++runRiboStateE ::+  StateT s (ExceptT e (Ribo s)) a ->+  Ribo s (Either e a)+runRiboStateE = runRiboE . riboStateE++riboStateLocal ::+  Lens' s s' ->+  StateT s' (Ribo s) a ->+  Ribo s a+riboStateLocal zoom ma = do+  state <- Ribo.inspect $ Lens.view zoom+  (output, newState) <- runStateT ma state+  Ribo.modify $ Lens.set zoom newState+  return output++riboState ::+  StateT s (Ribo s) a ->+  Ribo s a+riboState =+  riboStateLocal id++modifyL ::+  (MonadState s m) =>+  Lens' s a ->+  (a -> a) ->+  m ()+modifyL lens f =+  modify $ Lens.over lens f++prepend ::+  (MonadState s m) =>+  Lens' s [a] ->+  a ->+  m ()+prepend lens a =+  modifyL lens (a :)
+ lib/Ribosome/Control/Monad/Trans/Ribo.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}++module Ribosome.Control.Monad.Trans.Ribo where++import Control.Concurrent.STM.TVar (swapTVar)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.State (MonadState(..))+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT)+import Control.Monad.Trans.Class+import Control.Monad.IO.Class (MonadIO)+import qualified Control.Monad.Trans.Except as Except (catchE)+import Data.Bifunctor (Bifunctor(..))+import Data.Either.Combinators (mapLeft)+import Data.Functor (void)+import UnliftIO.Exception (throwString)+import UnliftIO.STM (TVar, atomically, readTVarIO)+import Neovim (ask)+import Neovim.Context.Internal (Neovim)+import Ribosome.Control.Ribosome (Ribosome)+import qualified Ribosome.Control.Ribosome as Ribosome (env)++type Ribo e = Neovim (Ribosome (TVar e))++newtype RiboT t s e a =+  RiboT { unRiboT :: ExceptT e (t (Ribo s)) a }++deriving instance Functor (t (Ribo s)) => Functor (RiboT t s e)+deriving instance Monad (t (Ribo s)) => Applicative (RiboT t s e)+deriving instance Monad (t (Ribo s)) => Monad (RiboT t s e)+deriving instance MonadIO (t (Ribo s)) => MonadIO (RiboT t s e)+deriving instance Monad (t (Ribo s)) => MonadError e (RiboT t s e)++nvim :: MonadTrans t => Neovim (Ribosome (TVar s)) a -> RiboT t s e a+nvim = RiboT . ExceptT . lift . fmap Right++asNeovim :: RiboT t s e a -> t (Ribo s) (Either e a)+asNeovim = runExceptT . unRiboT++asNeovimWith :: (∀ b. t (Ribo s) b -> Ribo s b) -> RiboT t s e a -> Ribo s (Either e a)+asNeovimWith run = run . runExceptT . unRiboT++mapE :: (Functor (t (Ribo s))) => (e -> e') -> RiboT t s e a -> RiboT t s e' a+mapE f =+  RiboT . trans . unRiboT+  where+    trans = mapExceptT (fmap $ mapLeft f)++liftEither :: (Monad (t (Ribo s))) => Either e a -> RiboT t s e a+liftEither = RiboT . ExceptT . return++catchE :: (Monad (t (Ribo s))) => (e -> RiboT t s e' a) -> RiboT t s e a -> RiboT t s e' a+catchE f = RiboT . flip Except.catchE (unRiboT . f) . unRiboT++stateTVar :: (MonadTrans t, Functor (t (Ribo s))) => RiboT t s e (TVar s)+stateTVar =+  Ribosome.env <$> nvim ask++toException :: Show e => Ribo s (Either e a) -> Ribo s a+toException ma = ma >>= either (throwString . show) return++unsafeToNeovim :: (MonadTrans t, Monad (t (Ribo s)), Show e) => RiboT t s e a -> t (Ribo s) a+unsafeToNeovim ra = do+  r <- asNeovim ra+  lift $ either (throwString . show) return r++unsafeToNeovimWith :: Show e => (∀ b. t (Ribo s) b -> Ribo s b) -> RiboT t s e a -> Ribo s a+unsafeToNeovimWith run =+  toException . run . asNeovim++instance (MonadTrans t, Monad (t (Ribo s))) => MonadState s (RiboT t s e) where+  get = do+    t <- stateTVar+    nvim $ readTVarIO t+  put newState = do+    t <- stateTVar+    void $ nvim $ atomically $ swapTVar t newState++instance (Functor (t (Ribo s))) => Bifunctor (RiboT t s) where+  first = mapE+  second = fmap
+ lib/Ribosome/Control/Monad/Trans/Unlift.hs view
@@ -0,0 +1,15 @@+module Ribosome.Control.Monad.Trans.Unlift(+  MonadUnlift(..),+) where++import Control.Monad.Trans.Except (ExceptT, mapExceptT)++class MonadUnlift t where+  unlift :: Monad m => (m a -> m b) -> t m a -> t m b++instance MonadUnlift (ExceptT e) where+  unlift f =+    mapExceptT (>>= trans)+    where+      trans (Left e) = return $ Left e+      trans (Right a) = Right <$> f (return a)
lib/Ribosome/Control/Ribo.hs view
@@ -1,21 +1,33 @@ module Ribosome.Control.Ribo(   Ribo,   state,+  swap,+  put,   inspect,   modify,   name,   lockOrSkip,+  prepend,+  modifyL,+  riboInternal,+  getErrors,+  inspectErrors,+  modifyErrors, ) where -import Control.Concurrent.STM.TVar (modifyTVar)+import Control.Concurrent.STM.TVar (modifyTVar, swapTVar)+import Control.Lens (Lens') import qualified Control.Lens as Lens (view, over, at)+import Data.Functor (void) import qualified Data.Map.Strict as Map (insert)+import Neovim (Neovim, ask) import UnliftIO (finally) import UnliftIO.STM (TVar, TMVar, atomically, readTVarIO, newTMVarIO, tryTakeTMVar, tryPutTMVar)-import Neovim (Neovim, ask)-import Ribosome.Control.Ribosome (Ribosome(Ribosome), Locks)-import qualified Ribosome.Control.Ribosome as Ribosome (_locks, locks) +import Ribosome.Control.Ribosome (Ribosome(Ribosome), Locks, RibosomeInternal)+import qualified Ribosome.Control.Ribosome as Ribosome (_locks, locks, errors, _errors)+import Ribosome.Data.Errors (Errors)+ type Ribo e = Neovim (Ribosome e)  state :: Ribo (TVar e) e@@ -23,6 +35,14 @@   Ribosome _ _ t <- ask   readTVarIO t +swap :: e -> Ribo (TVar e) e+swap newState = do+  Ribosome _ _ t <- ask+  atomically $ swapTVar t newState++put :: e -> Ribo (TVar e) ()+put = void . swap+ inspect :: (e -> a) -> Ribo (TVar e) a inspect f = fmap f state @@ -31,17 +51,28 @@   Ribosome _ _ t <- ask   atomically $ modifyTVar t f +modifyL :: Lens' s a -> (a -> a) -> Ribo (TVar s) ()+modifyL lens f =+  modify $ Lens.over lens f++prepend :: Lens' s [a] -> a -> Ribo (TVar s) ()+prepend lens a =+  modifyL lens (a :)+ name :: Ribo e String name = do   Ribosome n _ _ <- ask   return n -getLocks :: Ribo e Locks-getLocks = do+riboInternal :: Ribo d RibosomeInternal+riboInternal = do   Ribosome _ intTv _ <- ask-  int <- readTVarIO intTv-  return $ Ribosome.locks int+  readTVarIO intTv +getLocks :: Ribo e Locks+getLocks =+  Ribosome.locks <$> riboInternal+ inspectLocks :: (Locks -> a) -> Ribo e a inspectLocks f = fmap f getLocks @@ -49,6 +80,18 @@ modifyLocks f = do   Ribosome _ intTv _ <- ask   atomically $ modifyTVar intTv $ Lens.over Ribosome._locks f++getErrors :: Ribo e Errors+getErrors =+  Ribosome.errors <$> riboInternal++inspectErrors :: (Errors -> a) -> Ribo e a+inspectErrors f = fmap f getErrors++modifyErrors :: (Errors -> Errors) -> Ribo e ()+modifyErrors f = do+  Ribosome _ intTv _ <- ask+  atomically $ modifyTVar intTv $ Lens.over Ribosome._errors f  getOrCreateLock :: String -> Ribo e (TMVar ()) getOrCreateLock key = do
lib/Ribosome/Control/Ribosome.hs view
@@ -5,25 +5,30 @@  module Ribosome.Control.Ribosome(   Ribosome (..),-  newRibosome,   RibosomeInternal (..),-  _internal,-  _locks,   Locks,+  newRibosome,+  _locks,+  _errors,   newInternalTVar,+  _internal, ) where  import Control.Lens (makeClassy_)-import UnliftIO.STM (TVar, newTVarIO, TMVar) import Control.Monad.IO.Class (MonadIO)+import Data.Default (def) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map (empty)+import UnliftIO.STM (TVar, newTVarIO, TMVar) +import Ribosome.Data.Errors (Errors)+ type Locks = Map String (TMVar ()) -newtype RibosomeInternal =+data RibosomeInternal =   RibosomeInternal {-    locks :: Locks+    locks :: Locks,+    errors :: Errors   } makeClassy_ ''RibosomeInternal @@ -36,7 +41,7 @@ makeClassy_ ''Ribosome  newInternalTVar :: MonadIO m => m (TVar RibosomeInternal)-newInternalTVar = newTVarIO (RibosomeInternal Map.empty)+newInternalTVar = newTVarIO (RibosomeInternal Map.empty def)  newRibosome :: MonadIO m => String -> e -> m (Ribosome (TVar e)) newRibosome name' env' = do
+ lib/Ribosome/Data/ErrorReport.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}++module Ribosome.Data.ErrorReport(+  ErrorReport(..),+  user,+  log,+  priority,+) where++import Control.Lens (makeClassy)+import Prelude hiding (log)+import System.Log (Priority)++data ErrorReport =+  ErrorReport {+    _user :: String,+    _log :: [String],+    _priority :: Priority+  }+  deriving (Eq, Show)++makeClassy ''ErrorReport
lib/Ribosome/Data/Errors.hs view
@@ -1,27 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+ module Ribosome.Data.Errors(   ComponentName(..),-  Error(..),   Errors(..),+  Error(..),+  componentErrors,+  timestamp,+  report, ) where -import qualified Data.Map as Map-import Data.Default.Class (Default(def))-import Data.Map.Strict (Map)+import Control.Lens (makeClassy)+import Data.Default (Default)+import Data.Map (Map)+import qualified Data.Map as Map (toList)+import Data.Text.Prettyprint.Doc (Doc, Pretty(..), align, vsep, line, (<+>), (<>))+import Prelude hiding (error) +import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+ newtype ComponentName =   ComponentName String   deriving (Eq, Ord, Show)  data Error =   Error {-    errorTimestamp :: Int,-    errorMessage :: [String]+    _timestamp :: Int,+    _report :: ErrorReport   }-  deriving Show+  deriving (Eq, Show) +makeClassy ''Error++instance Pretty Error where+  pretty (Error stamp (ErrorReport _ lines' _)) =+    pretty stamp <+> align (vsep (pretty <$> lines'))+ newtype Errors =-  Errors (Map ComponentName [Error])-  deriving Show+  Errors {+    _componentErrors :: Map ComponentName [Error]+    }+  deriving (Eq, Show, Default) -instance Default Errors where-  def = Errors Map.empty+makeClassy ''Errors++prettyComponentErrors :: ComponentName -> [Error] -> Doc a+prettyComponentErrors (ComponentName name) errors' =+  line <> line <> pretty name <> ":" <> line <> vsep (pretty <$> errors')++instance Pretty Errors where+  pretty (Errors errors') =+    pretty ("Errors:" :: String) <> vsep (uncurry prettyComponentErrors <$> Map.toList errors')
lib/Ribosome/Data/ScratchOptions.hs view
@@ -3,7 +3,7 @@   defaultScratchOptions, ) where -import Data.Default.Class (Default(def))+import Data.Default (Default(def))  data ScratchOptions =   ScratchOptions {
+ lib/Ribosome/Data/Time.hs view
@@ -0,0 +1,25 @@+module Ribosome.Data.Time(+  epochSeconds,+  usleep,+  sleep,+  sleepW,+) where++import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Time.Clock.POSIX (getPOSIXTime)+import GHC.Float (word2Double)++epochSeconds :: MonadIO m => m Int+epochSeconds = liftIO $ fmap round getPOSIXTime++usleep :: MonadIO m => Double -> m ()+usleep =+  liftIO . threadDelay . round++sleep :: MonadIO m => Double -> m ()+sleep seconds =+  usleep $ seconds * 1e6++sleepW :: MonadIO m => Word -> m ()+sleepW = sleep . word2Double
+ lib/Ribosome/Error/Report.hs view
@@ -0,0 +1,77 @@+module Ribosome.Error.Report(+  ErrorReport(..),+  ReportError(..),+  logErrorReport,+  reportErrorWith,+  reportError,+  reportErrorOr,+  reportErrorOr_,+  printAllErrors,+) where++import Control.Monad.IO.Class (liftIO)+import Data.Foldable (traverse_)+import qualified Data.Map as Map (alter)+import Data.Text.Prettyprint.Doc (pretty, line, (<>))+import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc)+import System.Log.Logger (logM, Priority(NOTICE, DEBUG))++import Ribosome.Api.Echo (echom)+import Ribosome.Control.Monad.Ribo (Ribo)+import qualified Ribosome.Control.Ribo as Ribo (name, modifyErrors, getErrors)+import Ribosome.Data.ErrorReport (ErrorReport(ErrorReport))+import Ribosome.Data.Errors (Errors(Errors), ComponentName(ComponentName), Error(Error))+import Ribosome.Data.Time (epochSeconds)++class ReportError a where+  errorReport :: a -> ErrorReport++instance ReportError [Char] where+  errorReport msg = ErrorReport msg [msg] NOTICE++instance ReportError [[Char]] where+  errorReport (msg:extra) = ErrorReport msg (msg:extra) NOTICE+  errorReport [] = ErrorReport "empty error" ["empty error"] DEBUG++storeError' :: Int -> String -> ErrorReport -> Errors -> Errors+storeError' time name report (Errors errors) =+  Errors (Map.alter alter (ComponentName name) errors)+  where+    err = Error time report+    alter Nothing = Just [err]+    alter (Just current) = Just (err:current)++storeError :: String -> ErrorReport -> Ribo d ()+storeError name e = do+  time <- epochSeconds+  Ribo.modifyErrors $ storeError' time name e++logErrorReport :: ErrorReport -> Ribo d ()+logErrorReport (ErrorReport user logMsgs prio) = do+  name <- Ribo.name+  liftIO $ traverse_ (logM name prio) logMsgs+  echom user++reportErrorWith :: String -> (a -> ErrorReport) -> a -> Ribo d ()+reportErrorWith name cons err = do+  storeError name report+  logErrorReport report+  where+    report = cons err++reportError :: ReportError a => String -> a -> Ribo d ()+reportError name =+  reportErrorWith name errorReport++reportErrorOr :: ReportError e => String -> (a -> Ribo d ()) -> Either e a -> Ribo d ()+reportErrorOr name =+  either $ reportError name++reportErrorOr_ :: ReportError e => String -> Ribo d () -> Either e a -> Ribo d ()+reportErrorOr_ name =+  reportErrorOr name . const++printAllErrors :: Ribo e ()+printAllErrors = do+  errors <- Ribo.getErrors+  liftIO $ putDoc $ (pretty errors <> line)
lib/Ribosome/Internal/NvimObject.hs view
@@ -14,7 +14,7 @@  objectKeyMissing :: String -> Maybe Object -> Either (Doc AnsiStyle) Object objectKeyMissing _ (Just o) = Right o-objectKeyMissing key Nothing = Left (pretty "missing key in nvim data:" <+> pretty key)+objectKeyMissing key Nothing = Left (pretty ("missing key in nvim data:" :: String) <+> pretty key)  extractObject :: NvimObject o => String -> Map Object Object -> Either (Doc AnsiStyle) o extractObject key data' = do
lib/Ribosome/Log.hs view
@@ -1,11 +1,13 @@ module Ribosome.Log(   debug,   info,+  err,   p,+  prefixed, ) where  import Control.Monad.IO.Class (MonadIO, liftIO)-import Neovim.Log (debugM, infoM)+import Neovim.Log (debugM, infoM, errorM)  debug :: (MonadIO m, Show a) => String -> a -> m () debug name message = liftIO $ debugM name $ show message@@ -13,5 +15,11 @@ info :: (MonadIO m, Show a) => String -> a -> m () info name message = liftIO $ infoM name $ show message +err :: (MonadIO m, Show a) => String -> a -> m ()+err name message = liftIO $ errorM name $ show message+ p :: (MonadIO m, Show a) => a -> m () p = liftIO . print++prefixed :: (MonadIO m, Show a) => String -> a -> m ()+prefixed prefix a = liftIO $ putStrLn $ prefix ++ ": " ++ show a
+ lib/Ribosome/Msgpack/Decode.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}++module Ribosome.Msgpack.Decode(+  MsgpackDecode(..),+) where++import GHC.Generics (+  Generic,+  Rep,+  (:*:)(..),+  M1(..),+  D1,+  C1,+  S1,+  K1(..),+  Selector,+  Constructor,+  selName,+  to,+  conIsRecord,+  )+import Data.ByteString.Internal (unpackChars)+import Data.Map.Strict (Map, (!?))+import qualified Data.Map.Strict as Map (fromList, toList)+import Data.MessagePack (Object(..))+import Ribosome.Msgpack.Util (Err)+import qualified Ribosome.Msgpack.Util as Util (string, invalid, missingRecordKey, illegalType)++class MsgpackDecode a where+  fromMsgpack :: Object -> Either Err a+  default fromMsgpack :: (Generic a, GMsgpackDecode (Rep a)) => Object -> Either Err a+  fromMsgpack = fmap to . gMsgpackDecode++class GMsgpackDecode f where+  gMsgpackDecode :: Object -> Either Err (f a)++class MsgpackDecodeProd f where+  msgpackDecodeRecord :: Map Object Object -> Either Err (f a)+  msgpackDecodeProd :: [Object] -> Either Err ([Object], f a)++instance GMsgpackDecode f => GMsgpackDecode (D1 c f) where+  gMsgpackDecode = fmap M1 . gMsgpackDecode @f++instance (Constructor c, MsgpackDecodeProd f) => GMsgpackDecode (C1 c f) where+  gMsgpackDecode =+    fmap M1 . decode+    where+      isRec = conIsRecord (undefined :: t c f p)+      decode o@(ObjectMap om) =+        if isRec then msgpackDecodeRecord om else Util.invalid "illegal ObjectMap for product" o+      decode o@(ObjectArray oa) =+        if isRec then Util.invalid "illegal ObjectArray for record" o else decode'+        where+          decode' = do+            (rest, a) <- msgpackDecodeProd oa+            case rest of+              [] -> Right a+              _ -> Util.invalid "too many values for product" o+      decode o =+        Util.invalid "illegal Object for constructor" o++instance (MsgpackDecodeProd f, MsgpackDecodeProd g) => MsgpackDecodeProd (f :*: g) where+  msgpackDecodeRecord o = do+    left <- msgpackDecodeRecord o+    right <- msgpackDecodeRecord o+    return $ left :*: right+  msgpackDecodeProd o = do+    (rest, left) <- msgpackDecodeProd o+    (rest1, right) <- msgpackDecodeProd rest+    return (rest1, left :*: right)++instance (Selector s, GMsgpackDecode f) => MsgpackDecodeProd (S1 s f) where+  msgpackDecodeRecord o =+    maybe (Util.missingRecordKey key (ObjectMap o)) (fmap M1 . gMsgpackDecode) (o !? Util.string key)+    where+      key = selName (undefined :: t s f p)+  msgpackDecodeProd (cur:rest) = do+    a <- gMsgpackDecode cur+    return $ (rest, M1 a)+  msgpackDecodeProd [] = Util.invalid "too few values for product" ObjectNil++instance MsgpackDecode a => GMsgpackDecode (K1 i a) where+  gMsgpackDecode = fmap K1 . fromMsgpack++instance (Ord k, MsgpackDecode k, MsgpackDecode v) => MsgpackDecode (Map k v) where+  fromMsgpack (ObjectMap om) = do+    m <- traverse decodePair $ Map.toList om+    Right $ Map.fromList m+    where+      decodePair (k, v) = do+        k1 <- fromMsgpack k+        v1 <- fromMsgpack v+        return (k1, v1)+  fromMsgpack o = Util.illegalType "Map" o++instance MsgpackDecode Int where+  fromMsgpack (ObjectInt i) = Right $ fromIntegral i+  fromMsgpack o = Util.illegalType "Int" o++instance {-# OVERLAPPING #-} MsgpackDecode String where+  fromMsgpack (ObjectString os) = Right $ unpackChars os+  fromMsgpack o = Util.illegalType "String" o++instance {-# OVERLAPPABLE #-} MsgpackDecode a => MsgpackDecode [a] where+  fromMsgpack (ObjectArray oa) = traverse fromMsgpack oa+  fromMsgpack o = Util.illegalType "List" o
+ lib/Ribosome/Msgpack/Encode.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}++module Ribosome.Msgpack.Encode(+  MsgpackEncode(..),+) where++import GHC.Generics (+  Generic,+  Rep,+  (:*:)(..),+  M1(..),+  D1,+  C1,+  S1,+  K1(..),+  Selector,+  Constructor,+  selName,+  from,+  conIsRecord,+  )+import Data.Bifunctor (bimap)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map (fromList, toList)+import Data.MessagePack (Object(..))+import qualified Ribosome.Msgpack.Util as Util (string, assembleMap)++class MsgpackEncode a where+  toMsgpack :: a -> Object+  default toMsgpack :: (Generic a, GMsgpackEncode (Rep a)) => a -> Object+  toMsgpack = gMsgpackEncode . from++class GMsgpackEncode f where+  gMsgpackEncode :: f a -> Object++class MsgpackEncodeProd f where+  msgpackEncodeRecord :: f a -> [(String, Object)]+  msgpackEncodeProd :: f a -> [Object]++instance GMsgpackEncode f => GMsgpackEncode (D1 c f) where+  gMsgpackEncode = gMsgpackEncode . unM1++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 ObjectArray . msgpackEncodeProd++instance (MsgpackEncodeProd f, MsgpackEncodeProd g) => MsgpackEncodeProd (f :*: g) where+  msgpackEncodeRecord (f :*: g) = msgpackEncodeRecord f ++ msgpackEncodeRecord g+  msgpackEncodeProd (f :*: g) = msgpackEncodeProd f ++ msgpackEncodeProd g++instance (Selector s, GMsgpackEncode f) => MsgpackEncodeProd (S1 s f) where+  msgpackEncodeRecord s@(M1 f) = [(selName s, gMsgpackEncode f)]+  msgpackEncodeProd (M1 f) = [gMsgpackEncode f]++instance MsgpackEncode a => GMsgpackEncode (K1 i a) where+  gMsgpackEncode = toMsgpack . unK1++instance (Ord k, MsgpackEncode k, MsgpackEncode v) => MsgpackEncode (Map k v) where+  toMsgpack = ObjectMap . Map.fromList . fmap (bimap toMsgpack toMsgpack) . Map.toList++instance MsgpackEncode Int where+  toMsgpack = ObjectInt . fromIntegral++instance {-# OVERLAPPING #-} MsgpackEncode String where+  toMsgpack = Util.string++instance {-# OVERLAPPABLE #-} MsgpackEncode a => MsgpackEncode [a] where+  toMsgpack = ObjectArray . fmap toMsgpack
+ lib/Ribosome/Msgpack/NvimObject.hs view
@@ -0,0 +1,21 @@+module Ribosome.Msgpack.NvimObject(+  NO(..),+  (-$),+) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Neovim (NvimObject(..))+import Ribosome.Msgpack.Encode (MsgpackEncode(..))+import Ribosome.Msgpack.Decode (MsgpackDecode(..))++newtype NO a =+  NO a+  deriving (Eq, Show, Generic, NFData)++instance (MsgpackEncode a, MsgpackDecode a, NFData a) => NvimObject (NO a) where+  toObject (NO a) = toMsgpack a+  fromObject a = NO <$> fromMsgpack a++(-$) :: (NO a -> b) -> a -> b+(-$) f a = f (NO a)
+ lib/Ribosome/Msgpack/Util.hs view
@@ -0,0 +1,34 @@+module Ribosome.Msgpack.Util(+  Err,+  string,+  assembleMap,+  invalid,+  missingRecordKey,+  illegalType,+) where++import Data.Bifunctor (first)+import Data.ByteString.Internal (packChars)+import qualified Data.Map.Strict as Map (fromList)+import Data.MessagePack (Object(..))+import Data.Text.Prettyprint.Doc (Doc, (<+>), viaShow, pretty)+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)++type Err = Doc AnsiStyle++string :: String -> Object+string = ObjectString . packChars++assembleMap :: [(String, Object)] -> Object+assembleMap = ObjectMap . Map.fromList . (fmap . first) string++invalid :: String -> Object -> Either Err a+invalid msg obj =+  Left $ pretty (msg ++ ": ") <+> viaShow obj++missingRecordKey :: String -> Object -> Either Err a+missingRecordKey key =+  invalid $ "missing record key " ++ key ++ " in ObjectMap"++illegalType :: String -> Object -> Either Err a+illegalType tpe = invalid $ "illegal type for " ++ tpe
lib/Ribosome/Scratch.hs view
@@ -54,8 +54,8 @@  configureScratchBuffer :: Buffer -> String -> Neovim e () configureScratchBuffer buffer name = do-  buffer_set_option' buffer "buftype" (toObject "nofile")-  buffer_set_option' buffer "bufhidden" (toObject "wipe")+  buffer_set_option' buffer "buftype" (toObject ("nofile" :: String))+  buffer_set_option' buffer "bufhidden" (toObject ("wipe" :: String))   buffer_set_name' buffer name  setupScratchBuffer :: Window -> String -> Neovim e Buffer
lib/Ribosome/Test/Embed.hs view
@@ -6,17 +6,55 @@   unsafeEmbeddedSpec,   setVars,   setupPluginEnv,+  quitNvim, ) where  import Control.Monad.IO.Class (liftIO)-import Data.Default.Class (Default(def))+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Resource (runResourceT)+import Data.Default (Default(def)) import Data.Foldable (traverse_)+import Data.Functor (void)+import Data.Maybe (fromMaybe)+import GHC.IO.Handle (Handle)+import Neovim (Neovim, Object, vim_set_var', vim_command)+import qualified Neovim.Context.Internal as Internal(+  Neovim(Neovim),+  Config,+  newConfig,+  retypeConfig,+  mkFunctionMap,+  pluginSettings,+  globalFunctionMap,+  )+import Neovim.RPC.Common (RPCConfig, newRPCConfig)+import Neovim.RPC.EventHandler (runEventHandler)+import Neovim.RPC.SocketReader (runSocketReader) import System.Directory (makeAbsolute)-import Neovim (Neovim, Object, vim_set_var')-import Neovim.Test (testWithEmbeddedNeovim, Seconds(..))+import System.Exit (ExitCode)+import qualified System.Posix.Signals as Signal (signalProcess, killProcess)+import System.Process (getPid)+import System.Process.Typed (+  ProcessConfig,+  Process,+  withProcess,+  proc,+  setStdin,+  setStdout,+  getStdin,+  getStdout,+  unsafeProcessHandle,+  createPipe,+  getExitCode,+  )+import UnliftIO.Async (async, cancel, race)+import UnliftIO.Exception (tryAny, bracket)+import UnliftIO.STM (atomically, putTMVar)++import Ribosome.Api.Option (rtpCat) import Ribosome.Control.Ribo (Ribo) import Ribosome.Control.Ribosome (Ribosome(Ribosome), newInternalTVar)-import Ribosome.Api.Option (rtpCat)+import Ribosome.Data.Time (sleep, sleepW)  type Runner env = TestConfig -> Neovim env () -> Neovim env () @@ -24,18 +62,20 @@  data TestConfig =   TestConfig {-    pluginName :: String,-    extraRtp :: String,-    logPath :: FilePath,+    tcPluginName :: String,+    tcExtraRtp :: String,+    tcLogPath :: FilePath,     tcTimeout :: Word,-    variables :: Vars+    tcCmdline :: Maybe [String],+    tcCmdArgs :: [String],+    tcVariables :: Vars   }  instance Default TestConfig where-  def = TestConfig "ribosome" "test/f/fixtures/rtp" "test/f/temp/log" 5 (Vars [])+  def = TestConfig "ribosome" "test/f/fixtures/rtp" "test/f/temp/log" 5 def def (Vars [])  defaultTestConfigWith :: String -> Vars -> TestConfig-defaultTestConfigWith name = TestConfig name "test/f/fixtures/rtp" "test/f/temp/log" 5+defaultTestConfigWith name = TestConfig name "test/f/fixtures/rtp" "test/f/temp/log" 5 def def  defaultTestConfig :: String -> TestConfig defaultTestConfig name = defaultTestConfigWith name (Vars [])@@ -45,12 +85,96 @@   traverse_ (uncurry vim_set_var') vars  setupPluginEnv :: TestConfig -> Neovim e ()-setupPluginEnv (TestConfig _ rtp _ _ vars) = do+setupPluginEnv (TestConfig _ rtp _ _ _ _ vars) = do   absRtp <- liftIO $ makeAbsolute rtp   rtpCat absRtp   setVars vars +killPid :: Integral a => a -> IO ()+killPid =+  void . tryAny . Signal.signalProcess Signal.killProcess . fromIntegral++killProcess :: Process i o e -> IO ()+killProcess prc = do+  let handle = unsafeProcessHandle prc+  mayPid <- getPid handle+  traverse_ killPid mayPid++testNvimProcessConfig :: TestConfig -> ProcessConfig Handle Handle ()+testNvimProcessConfig TestConfig {..} =+  setStdin createPipe $ setStdout createPipe $ proc "nvim" $ args ++ tcCmdArgs+  where+    args = fromMaybe defaultArgs tcCmdline+    defaultArgs = ["--embed", "-n", "-u", "NONE", "-i", "NONE"]++startHandlers :: NvimProc -> TestConfig -> Internal.Config RPCConfig -> IO (IO ())+startHandlers prc TestConfig{..} nvimConf = do+  socketReader <- run runSocketReader getStdout+  eventHandler <- run runEventHandler getStdin+  atomically $ putTMVar (Internal.globalFunctionMap nvimConf) (Internal.mkFunctionMap [])+  let stopEventHandlers = traverse_ cancel [socketReader, eventHandler]+  return stopEventHandlers+  where+    run runner stream = async . void $ runner (stream prc) emptyConf+    emptyConf = nvimConf { Internal.pluginSettings = Nothing }++runNeovimThunk :: Internal.Config e -> Neovim e a -> IO ()+runNeovimThunk cfg (Internal.Neovim thunk) =+  void $ runReaderT (runResourceT thunk) cfg++type NvimProc = Process Handle Handle ()++waitQuit :: NvimProc -> IO (Maybe ExitCode)+waitQuit prc =+  wait 30+  where+    wait :: Int -> IO (Maybe ExitCode)+    wait 0 = return Nothing+    wait count = do+      code <- getExitCode prc+      case code of+        Just a -> return $ Just a+        Nothing -> do+          sleep 0.1+          wait $ count - 1++quitNvim :: Internal.Config e -> NvimProc -> IO ()+quitNvim testCfg prc = do+  quitThread <- async $ runNeovimThunk testCfg quit+  result <- waitQuit prc+  case result of+    Just _ -> return ()+    Nothing -> killProcess prc+  cancel quitThread+  where+    quit = vim_command "qall!"++shutdownNvim :: Internal.Config e -> NvimProc -> IO () -> IO ()+shutdownNvim _ prc stopEventHandlers = do+  stopEventHandlers+  killProcess prc+  -- quitNvim testCfg prc++runTest :: TestConfig -> Internal.Config (Ribosome e) -> Ribo e () -> IO () -> IO ()+runTest TestConfig{..} testCfg thunk _ = do+  result <- race (sleepW tcTimeout) (runNeovimThunk testCfg thunk)+  case result of+    Right _ -> return ()+    Left _ -> fail $ "test exceeded timeout of " <> show tcTimeout <> " seconds"++runEmbeddedNvim :: TestConfig -> Ribosome e -> Ribo e () -> NvimProc -> IO ()+runEmbeddedNvim conf ribo thunk prc = do+  nvimConf <- Internal.newConfig (pure Nothing) newRPCConfig+  let testCfg = Internal.retypeConfig ribo nvimConf+  bracket (startHandlers prc conf nvimConf) (shutdownNvim testCfg prc) (runTest conf testCfg thunk)++runEmbedded :: TestConfig -> Ribosome e -> Ribo e () -> IO ()+runEmbedded conf ribo thunk = do+  let pc = testNvimProcessConfig conf+  withProcess pc $ runEmbeddedNvim conf ribo thunk+ unsafeEmbeddedSpec :: Runner (Ribosome e) -> TestConfig -> e -> Ribo e () -> IO () unsafeEmbeddedSpec runner conf env spec = do   internal <- newInternalTVar-  testWithEmbeddedNeovim Nothing (Seconds (tcTimeout conf)) (Ribosome (pluginName conf) internal env) $ runner conf spec+  let ribo = Ribosome (tcPluginName conf) internal env+  runEmbedded conf ribo $ runner conf spec
lib/Ribosome/Test/Exists.hs view
@@ -1,19 +1,16 @@ module Ribosome.Test.Exists(   waitForPlugin,-  sleep, ) where -import Data.Time.Clock.POSIX-import Data.Strings (strCapitalize) import Control.Monad.IO.Class-import Control.Concurrent (threadDelay)+import Data.Char (toUpper) import Neovim -epochSeconds :: MonadIO f => f Int-epochSeconds = liftIO $ fmap round getPOSIXTime+import Ribosome.Data.Time (epochSeconds, sleep) -sleep :: MonadIO f => Double -> f ()-sleep seconds = liftIO $ threadDelay $ round $ seconds * 10e6+capitalize :: String -> String+capitalize [] = []+capitalize (head' : tail') = toUpper head' : tail'  retry :: MonadIO f => Double -> Int -> f a -> (a -> f (Either String b)) -> f b retry interval timeout thunk check = do@@ -37,7 +34,7 @@ waitForPlugin name interval timeout =   retry interval timeout thunk check   where-    thunk = vim_call_function "exists" [toObject $ "*" ++ strCapitalize name ++ "Poll"]+    thunk = vim_call_function "exists" [toObject $ "*" ++ capitalize name ++ "Poll"]     check (Right (ObjectInt 1)) = return $ Right ()     check (Right a) = return $ Left $ errormsg ++ "weird return type " ++ show a     check (Left e) = return $ Left $ errormsg ++ show e
lib/Ribosome/Test/Functional.hs view
@@ -7,17 +7,18 @@   fixture, ) where +import Control.Exception (finally) import Control.Monad (when) import Control.Monad.IO.Class-import Control.Exception (finally) import Data.Foldable (traverse_)+import Neovim (Neovim, vim_command')+import System.Console.ANSI (setSGR, SGR(SetColor, Reset), ConsoleLayer(Foreground), ColorIntensity(Dull), Color(Green)) import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removePathForcibly, doesFileExist, makeAbsolute) import System.FilePath (takeDirectory, (</>), takeFileName)-import System.Console.ANSI (setSGR, SGR(SetColor, Reset), ConsoleLayer(Foreground), ColorIntensity(Dull), Color(Green))-import Neovim (Neovim, vim_command')+ import Ribosome.Control.Ribo (Ribo)-import Ribosome.Test.Exists (waitForPlugin) import Ribosome.Test.Embed (TestConfig(..), unsafeEmbeddedSpec, setupPluginEnv)+import Ribosome.Test.Exists (waitForPlugin) import qualified Ribosome.Test.File as F (tempDir, fixture)  jobstart :: MonadIO f => String -> f String@@ -26,18 +27,18 @@   return $ "call jobstart('" ++ cmd ++ "', { 'rpc': v:true, 'cwd': '" ++ dir ++ "' })"  logFile :: TestConfig -> IO FilePath-logFile conf = makeAbsolute $ logPath conf ++ "-spec"+logFile TestConfig{..} = makeAbsolute $ tcLogPath ++ "-spec"  startPlugin :: TestConfig -> Neovim env ()-startPlugin conf = do-  absLogPath <- liftIO $ makeAbsolute (logPath conf)-  absLogFile <- liftIO $ logFile conf+startPlugin tc@TestConfig{..} = do+  absLogPath <- liftIO $ makeAbsolute tcLogPath+  absLogFile <- liftIO $ logFile tc   liftIO $ createDirectoryIfMissing True (takeDirectory absLogPath)   liftIO $ removePathForcibly absLogFile-  setupPluginEnv conf+  setupPluginEnv tc   cmd <- jobstart $ "stack run -- -l " ++ absLogFile ++ " -v INFO"   vim_command' cmd-  waitForPlugin (pluginName conf) 0.1 3+  waitForPlugin tcPluginName 0.1 3  fSpec :: TestConfig -> Neovim env () -> Neovim env () fSpec conf spec = startPlugin conf >> spec
lib/Ribosome/Test/Unit.hs view
@@ -7,11 +7,11 @@ ) where  import Control.Monad.IO.Class (MonadIO)-import System.FilePath (takeDirectory, takeFileName, (</>)) import Neovim (Neovim) import Ribosome.Control.Ribo (Ribo) import Ribosome.Test.Embed (TestConfig(..), setupPluginEnv, unsafeEmbeddedSpec) import qualified Ribosome.Test.File as F (tempDir, fixture)+import System.FilePath (takeDirectory, takeFileName, (</>))  uPrefix :: String uPrefix = "u"
ribosome.cabal view
@@ -1,178 +1,227 @@ cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.31.1.------ see: https://github.com/sol/hpack------ hash: 473e4deafa3bb3e51b7612893daa51020a229009cef026ee00b9974d477e32a0--name:           ribosome-version:        0.1.2.0-synopsis:       api extensions for nvim-hs-description:    Please see the README on GitHub at <https://github.com/tek/proteome-hs>-category:       Neovim-homepage:       https://github.com/tek/ribosome-hs#readme-bug-reports:    https://github.com/tek/ribosome-hs/issues-author:         Torsten Schmits-maintainer:     tek@tryp.io-copyright:      2018 Torsten Schmits-license:        MIT-license-file:   LICENSE-build-type:     Simple+name: ribosome+version: 0.2.0.0+license: MIT+license-file: LICENSE+copyright: 2019 Torsten Schmits+maintainer: tek@tryp.io+author: Torsten Schmits+homepage: https://github.com/tek/ribosome-hs#readme+bug-reports: https://github.com/tek/ribosome-hs/issues+synopsis: api extensions for nvim-hs+description:+    Please see the README on GitHub at <https://github.com/tek/proteome-hs>+category: Neovim+build-type: Simple  source-repository head-  type: git-  location: https://github.com/tek/ribosome-hs+    type: git+    location: https://github.com/tek/ribosome-hs  library-  exposed-modules:-      Ribosome.Api.Buffer-      Ribosome.Api.Echo-      Ribosome.Api.Exists-      Ribosome.Api.Function-      Ribosome.Api.Option-      Ribosome.Api.Path-      Ribosome.Api.Response-      Ribosome.Api.Window-      Ribosome.Config.Setting-      Ribosome.Config.Settings-      Ribosome.Control.Ribo-      Ribosome.Control.Ribosome-      Ribosome.Data.Errors-      Ribosome.Data.Foldable-      Ribosome.Data.Maybe-      Ribosome.Data.Scratch-      Ribosome.Data.ScratchOptions-      Ribosome.File-      Ribosome.Internal.IO-      Ribosome.Internal.NvimObject-      Ribosome.Log-      Ribosome.Monad-      Ribosome.Persist-      Ribosome.Scratch-      Ribosome.Test.Embed-      Ribosome.Test.Exists-      Ribosome.Test.File-      Ribosome.Test.Functional-      Ribosome.Test.Unit-      Ribosome.Unsafe-  other-modules:-      Paths_ribosome-  hs-source-dirs:-      lib-  build-depends:-      MissingH-    , aeson-    , ansi-terminal-    , base >=4.7 && <5-    , bytestring-    , containers-    , data-default-class-    , deepseq-    , directory-    , either-    , filepath-    , hslogger-    , lens-    , messagepack-    , mtl-    , nvim-hs-    , pretty-terminal-    , prettyprinter-    , process-    , resourcet-    , safe-    , split-    , stm-    , strings-    , text-    , time-    , transformers-    , unliftio-    , utf8-string-  default-language: Haskell2010+    exposed-modules:+        Ribosome.Api.Buffer+        Ribosome.Api.Echo+        Ribosome.Api.Exists+        Ribosome.Api.Function+        Ribosome.Api.Option+        Ribosome.Api.Path+        Ribosome.Api.Response+        Ribosome.Api.Sleep+        Ribosome.Api.Window+        Ribosome.Config.Setting+        Ribosome.Config.Settings+        Ribosome.Control.Monad.Ribo+        Ribosome.Control.Monad.RiboE+        Ribosome.Control.Monad.State+        Ribosome.Control.Monad.Trans.Ribo+        Ribosome.Control.Monad.Trans.Unlift+        Ribosome.Control.Ribo+        Ribosome.Control.Ribosome+        Ribosome.Data.ErrorReport+        Ribosome.Data.Errors+        Ribosome.Data.Foldable+        Ribosome.Data.Maybe+        Ribosome.Data.Scratch+        Ribosome.Data.ScratchOptions+        Ribosome.Data.Time+        Ribosome.Error.Report+        Ribosome.File+        Ribosome.Internal.IO+        Ribosome.Internal.NvimObject+        Ribosome.Log+        Ribosome.Monad+        Ribosome.Msgpack.Decode+        Ribosome.Msgpack.Encode+        Ribosome.Msgpack.NvimObject+        Ribosome.Msgpack.Util+        Ribosome.Persist+        Ribosome.Scratch+        Ribosome.Test.Embed+        Ribosome.Test.Exists+        Ribosome.Test.File+        Ribosome.Test.Functional+        Ribosome.Test.Unit+        Ribosome.Unsafe+    hs-source-dirs: lib+    other-modules:+        Paths_ribosome+    default-language: Haskell2010+    default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals+                        ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable+                        DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+                        DoAndIfThenElse EmptyDataDecls ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns+                        OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds+                        RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving+                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances+                        UnicodeSyntax ViewPatterns+    build-depends:+        MissingH >=1.4.1.0 && <1.5,+        aeson >=1.3.1.1 && <1.4,+        ansi-terminal >=0.8.2 && <0.9,+        base >=4.7 && <5,+        bytestring >=0.10.8.2 && <0.11,+        containers >=0.5.11.0 && <0.6,+        data-default >=0.7.1.1 && <0.8,+        deepseq >=1.4.3.0 && <1.5,+        directory >=1.3.1.5 && <1.4,+        either >=5.0.1 && <5.1,+        filepath >=1.4.2 && <1.5,+        hslogger >=1.2.12 && <1.3,+        lens >=4.16.1 && <4.17,+        messagepack >=0.5.4 && <0.6,+        mtl >=2.2.2 && <2.3,+        nvim-hs >=1.0.0.3 && <1.1,+        pretty-terminal >=0.1.0.0 && <0.2,+        prettyprinter >=1.2.1 && <1.3,+        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,+        process >=1.6.3.0 && <1.7,+        resourcet >=1.2.2 && <1.3,+        safe >=0.3.17 && <0.4,+        split >=0.2.3.3 && <0.3,+        stm >=2.4.5.1 && <2.5,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9,+        transformers >=0.5.5.0 && <0.6,+        typed-process >=0.2.3.0 && <0.3,+        unix >=2.7.2.2 && <2.8,+        unliftio >=0.2.9.0 && <0.3,+        unliftio-core >=0.1.2.0 && <0.2,+        utf8-string >=1.0.1.1 && <1.1  test-suite ribosome-functional-  type: exitcode-stdio-1.0-  main-is: SpecMain.hs-  other-modules:-      Paths_ribosome-  hs-source-dirs:-      test/f-  ghc-options: -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      HTF-    , MissingH-    , aeson-    , ansi-terminal-    , base >=4.7 && <5-    , bytestring-    , containers-    , data-default-class-    , deepseq-    , directory-    , either-    , filepath-    , hslogger-    , lens-    , messagepack-    , mtl-    , nvim-hs-    , pretty-terminal-    , prettyprinter-    , process-    , resourcet-    , ribosome-    , safe-    , split-    , stm-    , strings-    , text-    , time-    , transformers-    , unliftio-    , utf8-string-  default-language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: SpecMain.hs+    hs-source-dirs: test/f+    other-modules:+        Paths_ribosome+    default-language: Haskell2010+    default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals+                        ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable+                        DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+                        DoAndIfThenElse EmptyDataDecls ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns+                        OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds+                        RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving+                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances+                        UnicodeSyntax ViewPatterns+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        HTF >=0.13.2.5 && <0.14,+        MissingH >=1.4.1.0 && <1.5,+        aeson >=1.3.1.1 && <1.4,+        ansi-terminal >=0.8.2 && <0.9,+        base >=4.7 && <5,+        bytestring >=0.10.8.2 && <0.11,+        containers >=0.5.11.0 && <0.6,+        data-default >=0.7.1.1 && <0.8,+        deepseq >=1.4.3.0 && <1.5,+        directory >=1.3.1.5 && <1.4,+        either >=5.0.1 && <5.1,+        filepath >=1.4.2 && <1.5,+        hslogger >=1.2.12 && <1.3,+        lens >=4.16.1 && <4.17,+        messagepack >=0.5.4 && <0.6,+        mtl >=2.2.2 && <2.3,+        nvim-hs >=1.0.0.3 && <1.1,+        pretty-terminal >=0.1.0.0 && <0.2,+        prettyprinter >=1.2.1 && <1.3,+        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,+        process >=1.6.3.0 && <1.7,+        resourcet >=1.2.2 && <1.3,+        ribosome -any,+        safe >=0.3.17 && <0.4,+        split >=0.2.3.3 && <0.3,+        stm >=2.4.5.1 && <2.5,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9,+        transformers >=0.5.5.0 && <0.6,+        typed-process >=0.2.3.0 && <0.3,+        unix >=2.7.2.2 && <2.8,+        unliftio >=0.2.9.0 && <0.3,+        unliftio-core >=0.1.2.0 && <0.2,+        utf8-string >=1.0.1.1 && <1.1  test-suite ribosome-unit-  type: exitcode-stdio-1.0-  main-is: SpecMain.hs-  other-modules:-      ScratchSpec-      Paths_ribosome-  hs-source-dirs:-      test/u-  ghc-options: -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      HTF-    , MissingH-    , aeson-    , ansi-terminal-    , base >=4.7 && <5-    , bytestring-    , containers-    , data-default-class-    , deepseq-    , directory-    , either-    , filepath-    , hslogger-    , lens-    , messagepack-    , mtl-    , nvim-hs-    , pretty-terminal-    , prettyprinter-    , process-    , resourcet-    , ribosome-    , safe-    , split-    , stm-    , strings-    , text-    , time-    , transformers-    , unliftio-    , utf8-string-  default-language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: SpecMain.hs+    hs-source-dirs: test/u+    other-modules:+        MsgpackSpec+        RiboSpec+        RiboTransSpec+        ScratchSpec+        Paths_ribosome+    default-language: Haskell2010+    default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals+                        ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable+                        DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+                        DoAndIfThenElse EmptyDataDecls ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns+                        OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds+                        RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving+                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances+                        UnicodeSyntax ViewPatterns+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        HTF >=0.13.2.5 && <0.14,+        MissingH >=1.4.1.0 && <1.5,+        aeson >=1.3.1.1 && <1.4,+        ansi-terminal >=0.8.2 && <0.9,+        base >=4.7 && <5,+        bytestring >=0.10.8.2 && <0.11,+        containers >=0.5.11.0 && <0.6,+        data-default >=0.7.1.1 && <0.8,+        deepseq >=1.4.3.0 && <1.5,+        directory >=1.3.1.5 && <1.4,+        either >=5.0.1 && <5.1,+        filepath >=1.4.2 && <1.5,+        hslogger >=1.2.12 && <1.3,+        lens >=4.16.1 && <4.17,+        messagepack >=0.5.4 && <0.6,+        mtl >=2.2.2 && <2.3,+        nvim-hs >=1.0.0.3 && <1.1,+        pretty-terminal >=0.1.0.0 && <0.2,+        prettyprinter >=1.2.1 && <1.3,+        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,+        process >=1.6.3.0 && <1.7,+        resourcet >=1.2.2 && <1.3,+        ribosome -any,+        safe >=0.3.17 && <0.4,+        split >=0.2.3.3 && <0.3,+        stm >=2.4.5.1 && <2.5,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9,+        transformers >=0.5.5.0 && <0.6,+        typed-process >=0.2.3.0 && <0.3,+        unix >=2.7.2.2 && <2.8,+        unliftio >=0.2.9.0 && <0.3,+        unliftio-core >=0.1.2.0 && <0.2,+        utf8-string >=1.0.1.1 && <1.1
+ test/u/MsgpackSpec.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# LANGUAGE DeriveAnyClass #-}++module MsgpackSpec(+  htf_thisModulesTests+) where++import GHC.Generics (Generic)+import Data.Either.Combinators (mapLeft)+import Data.Int (Int64)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map (fromList)+import Data.MessagePack (Object(..))+import Test.Framework+import Ribosome.Msgpack.Encode (MsgpackEncode(..))+import Ribosome.Msgpack.Decode (MsgpackDecode(..))+import qualified Ribosome.Msgpack.Util as Util (string)++data Blob =+  Blob {+    key4 :: [[Int]],+    key5 :: Map Int String+  }+  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)++data Prod =+  Prod String Int+  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)++data Dat =+  Dat {+    key1 :: Blob,+    key2 :: Int,+    key3 :: Prod+  }+  deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)++dat :: Dat+dat = Dat (Blob [[1, 2], [3]] (Map.fromList [(1, "1"), (2, "2")])) 13 (Prod "dat" 27)++os :: String -> Object+os = Util.string++i :: Int64 -> Object+i = ObjectInt++encodedBlob :: Object+encodedBlob =+  ObjectMap $ Map.fromList [+    (os "key4", ObjectArray [ObjectArray [i 1, i 2], ObjectArray [i 3]]),+    (os "key5", ObjectMap $ Map.fromList [(i 1, os "1"), (i 2, os "2")])+    ]++encoded :: Object+encoded =+  ObjectMap $ Map.fromList [(os "key1", encodedBlob), (os "key2", i 13), (os "key3", ObjectArray [os "dat", i 27])]++test_encode :: IO ()+test_encode =+  assertEqual encoded (toMsgpack dat)++test_decode :: IO ()+test_decode =+  assertEqual (Right dat) (mapLeft (const ()) $ fromMsgpack encoded)
+ test/u/RiboSpec.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++module RiboSpec(+  htf_thisModulesTests,+) where++import Control.Monad.IO.Class (liftIO)+import Data.Bifunctor (Bifunctor(..))+import Data.Default (Default(def))+import Neovim+import Ribosome.Api.Buffer+import Ribosome.Control.Monad.Ribo+import Ribosome.Test.Unit (unitSpec)+import Test.Framework+import UnliftIO.STM++newtype Env =+  Env Int+  deriving (Eq, Show)++rib :: RiboT Env (Doc AnsiStyle) [String]+rib = do+  a <- nvim currentBufferContent+  nvim $ vim_command' "tabnew"+  return a++riboSpec :: Ribo (TVar Env) ()+riboSpec = do+  let target = ["line 1", "line 2"]+  _ <- setCurrentBufferContent target+  content <- unsafeToNeovim $ first (const ()) rib+  liftIO $ assertEqual target content++test_ribo :: IO ()+test_ribo = do+  t <- newTVarIO (Env 5)+  unitSpec def t riboSpec
+ test/u/RiboTransSpec.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++module RiboTransSpec(+  htf_thisModulesTests,+) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.Default (Default(def))+import Neovim+import Test.Framework+import UnliftIO.STM++import Ribosome.Api.Buffer+import Ribosome.Control.Monad.Trans.Ribo+import Ribosome.Test.Unit (unitSpec)++newtype Env =+  Env Int+  deriving (Eq, Show)++rib :: RiboT (ReaderT Env) Env (Doc AnsiStyle) [String]+rib = do+  a <- nvim currentBufferContent+  nvim $ vim_command' "tabnew"+  return a++riboSpec :: Ribo Env ()+riboSpec = do+  let target = ["line 1", "line 2"]+  _ <- setCurrentBufferContent target+  content <- unsafeToNeovimWith (`runReaderT` Env 6) $ mapE (const ()) rib+  liftIO $ assertEqual target content++test_riboTrans :: IO ()+test_riboTrans = do+  t <- newTVarIO (Env 5)+  unitSpec def t riboSpec
test/u/ScratchSpec.hs view
@@ -5,12 +5,13 @@ ) where  import Control.Monad.IO.Class (liftIO)-import Data.Default.Class (def)+import Data.Default (def) import Test.Framework+ import Ribosome.Api.Buffer (currentBufferContent)+import Ribosome.Control.Ribo (Ribo) import Ribosome.Data.ScratchOptions (ScratchOptions(ScratchOptions)) import Ribosome.Scratch (showInScratch)-import Ribosome.Control.Ribo (Ribo) import Ribosome.Test.Unit (unitSpec)  target :: [String]
test/u/SpecMain.hs view
@@ -3,6 +3,8 @@ module Main where  import {-@ HTF_TESTS @-} ScratchSpec+import {-@ HTF_TESTS @-} MsgpackSpec+import {-@ HTF_TESTS @-} RiboSpec import Test.Framework import Test.Framework.BlackBoxTest ()