ribosome 0.2.1.0 → 0.2.2.0
raw patch · 9 files changed
+205/−71 lines, 9 files
Files
- lib/Ribosome/Config/Setting.hs +43/−0
- lib/Ribosome/Control/Lock.hs +48/−0
- lib/Ribosome/Control/Ribo.hs +4/−37
- lib/Ribosome/Log.hs +10/−0
- lib/Ribosome/Msgpack/Decode.hs +36/−18
- lib/Ribosome/Msgpack/Encode.hs +18/−5
- lib/Ribosome/Test/Exists.hs +1/−1
- ribosome.cabal +2/−1
- test/u/MsgpackSpec.hs +43/−9
lib/Ribosome/Config/Setting.hs view
@@ -6,13 +6,41 @@ settingVariableName, settingOr, settingMaybe,+ settingR,+ SettingError(..),+ updateSettingR, ) where import Data.Either (fromRight)+import Data.Text.Prettyprint.Doc (Doc)+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) import Neovim+import System.Log (Priority(NOTICE))++import Ribosome.Control.Monad.RiboE (RiboE, liftRibo, riboE, mapE) import Ribosome.Control.Ribo (Ribo) import qualified Ribosome.Control.Ribosome as R (name)+import Ribosome.Data.ErrorReport (ErrorReport(..))+import Ribosome.Error.Report (ReportError(..))+import Ribosome.Msgpack.Decode (MsgpackDecode(fromMsgpack))+import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack)) +data SettingError =+ Other String String+ |+ Decode String (Doc AnsiStyle)+ |+ Unset String+ deriving Show++instance ReportError SettingError where+ errorReport (Other name message) =+ ErrorReport ("weird setting: " ++ name) ["failed to read setting `" ++ name ++ "`", message] NOTICE+ errorReport (Decode name message) =+ ErrorReport ("invalid setting: " ++ name) ["failed to decode setting `" ++ name ++ "`", show message] NOTICE+ errorReport (Unset name) =+ ErrorReport ("required setting unset: " ++ name) ["unset setting: `" ++ name ++ "`"] NOTICE+ data Setting a = Setting { name :: String,@@ -56,3 +84,18 @@ varName <- settingVariableName s _ <- vim_set_var' varName (toObject a) return ()++settingR :: MsgpackDecode a => Setting a -> RiboE s SettingError a+settingR s@(Setting n _ fallback') = do+ varName <- liftRibo $ settingVariableName s+ raw <- liftRibo $ vim_get_var varName+ case raw of+ Right o -> mapE (Decode n) $ riboE $ pure $ fromMsgpack o+ Left _ -> riboE $ return $ case fallback' of+ Just fb -> Right fb+ Nothing -> Left $ Unset n++updateSettingR :: MsgpackEncode a => Setting a -> a -> Ribo e ()+updateSettingR s a = do+ varName <- settingVariableName s+ void $ vim_set_var' varName (toMsgpack a)
+ lib/Ribosome/Control/Lock.hs view
@@ -0,0 +1,48 @@+module Ribosome.Control.Lock(+ getOrCreateLock,+ lockOrSkip,+) where++import qualified Control.Lens as Lens (view, over, at)+import qualified Data.Map.Strict as Map (insert)+import Neovim (ask)+import UnliftIO (finally)+import UnliftIO.STM (TMVar, atomically, newTMVarIO, tryTakeTMVar, tryPutTMVar, modifyTVar)++import Ribosome.Control.Ribo (Ribo, riboInternal)+import Ribosome.Control.Ribosome (Ribosome(Ribosome), Locks)+import qualified Ribosome.Control.Ribosome as Ribosome (_locks, locks)+import qualified Ribosome.Log as Log (debugR)++getLocks :: Ribo e Locks+getLocks =+ Ribosome.locks <$> riboInternal++inspectLocks :: (Locks -> a) -> Ribo e a+inspectLocks f = fmap f getLocks++modifyLocks :: (Locks -> Locks) -> Ribo e ()+modifyLocks f = do+ Ribosome _ intTv _ <- ask+ atomically $ modifyTVar intTv $ Lens.over Ribosome._locks f++getOrCreateLock :: String -> Ribo e (TMVar ())+getOrCreateLock key = do+ currentLock <- inspectLocks $ Lens.view $ Lens.at key+ case currentLock of+ Just tv -> return tv+ Nothing -> do+ tv <- newTMVarIO ()+ modifyLocks $ Map.insert key tv+ getOrCreateLock key++lockOrSkip :: String -> Ribo e () -> Ribo e ()+lockOrSkip key thunk = do+ currentLock <- getOrCreateLock key+ currentState <- atomically $ tryTakeTMVar currentLock+ case currentState of+ Just _ -> do+ Log.debugR $ "locking MVar `" ++ key ++ "`"+ finally thunk $ atomically $ tryPutTMVar currentLock ()+ Log.debugR $ "unlocking MVar `" ++ key ++ "`"+ Nothing -> return ()
lib/Ribosome/Control/Ribo.hs view
@@ -6,7 +6,6 @@ inspect, modify, name,- lockOrSkip, prepend, modifyL, riboInternal,@@ -17,15 +16,13 @@ import Control.Concurrent.STM.TVar (modifyTVar, swapTVar) import Control.Lens (Lens')-import qualified Control.Lens as Lens (view, over, at)+import qualified Control.Lens as Lens (over) 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 UnliftIO.STM (TVar, atomically, readTVarIO) -import Ribosome.Control.Ribosome (Ribosome(Ribosome), Locks, RibosomeInternal)-import qualified Ribosome.Control.Ribosome as Ribosome (_locks, locks, errors, _errors)+import Ribosome.Control.Ribosome (Ribosome(Ribosome), RibosomeInternal)+import qualified Ribosome.Control.Ribosome as Ribosome (errors, _errors) import Ribosome.Data.Errors (Errors) type Ribo e = Neovim (Ribosome e)@@ -69,18 +66,6 @@ Ribosome _ intTv _ <- ask readTVarIO intTv -getLocks :: Ribo e Locks-getLocks =- Ribosome.locks <$> riboInternal--inspectLocks :: (Locks -> a) -> Ribo e a-inspectLocks f = fmap f getLocks--modifyLocks :: (Locks -> Locks) -> Ribo e ()-modifyLocks f = do- Ribosome _ intTv _ <- ask- atomically $ modifyTVar intTv $ Lens.over Ribosome._locks f- getErrors :: Ribo e Errors getErrors = Ribosome.errors <$> riboInternal@@ -92,21 +77,3 @@ modifyErrors f = do Ribosome _ intTv _ <- ask atomically $ modifyTVar intTv $ Lens.over Ribosome._errors f--getOrCreateLock :: String -> Ribo e (TMVar ())-getOrCreateLock key = do- currentLock <- inspectLocks $ Lens.view $ Lens.at key- case currentLock of- Just tv -> return tv- Nothing -> do- tv <- newTMVarIO ()- modifyLocks $ Map.insert key tv- getOrCreateLock key--lockOrSkip :: String -> Ribo e () -> Ribo e ()-lockOrSkip key thunk = do- currentLock <- getOrCreateLock key- currentState <- atomically $ tryTakeTMVar currentLock- case currentState of- Just _ -> finally thunk $ atomically $ tryPutTMVar currentLock ()- Nothing -> return ()
lib/Ribosome/Log.hs view
@@ -4,11 +4,16 @@ err, p, prefixed,+ debugR, ) where import Control.Monad.IO.Class (MonadIO, liftIO)+import Neovim (ask) import Neovim.Log (debugM, infoM, errorM) +import Ribosome.Control.Ribo (Ribo)+import qualified Ribosome.Control.Ribosome as R (name)+ debug :: (MonadIO m, Show a) => String -> a -> m () debug name message = liftIO $ debugM name $ show message @@ -23,3 +28,8 @@ prefixed :: (MonadIO m, Show a) => String -> a -> m () prefixed prefix a = liftIO $ putStrLn $ prefix ++ ": " ++ show a++debugR :: String -> Ribo e ()+debugR a = do+ pluginName <- R.name <$> ask+ liftIO $ debugM pluginName a
lib/Ribosome/Msgpack/Decode.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeOperators #-} module Ribosome.Msgpack.Decode( MsgpackDecode(..), ) where +import Data.ByteString.Internal (unpackChars)+import Data.Map.Strict (Map, (!?))+import qualified Data.Map.Strict as Map (fromList, toList)+import Data.MessagePack (Object(..)) import GHC.Generics ( Generic, Rep,@@ -20,10 +23,6 @@ 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) @@ -32,15 +31,22 @@ default fromMsgpack :: (Generic a, GMsgpackDecode (Rep a)) => Object -> Either Err a fromMsgpack = fmap to . gMsgpackDecode + missingKey :: String -> Object -> Either Err a+ missingKey = Util.missingRecordKey+ class GMsgpackDecode f where gMsgpackDecode :: Object -> Either Err (f a) + gMissingKey :: String -> Object -> Either Err (f a)+ gMissingKey = Util.missingRecordKey+ class MsgpackDecodeProd f where msgpackDecodeRecord :: Map Object Object -> Either Err (f a) msgpackDecodeProd :: [Object] -> Either Err ([Object], f a) -instance GMsgpackDecode f => GMsgpackDecode (D1 c f) where- gMsgpackDecode = fmap M1 . gMsgpackDecode @f+instance (GMsgpackDecode f) => GMsgpackDecode (D1 c f) where+ gMsgpackDecode =+ fmap M1 . gMsgpackDecode @f instance (Constructor c, MsgpackDecodeProd f) => GMsgpackDecode (C1 c f) where gMsgpackDecode =@@ -49,16 +55,15 @@ 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 | isRec =+ Util.invalid "illegal non-ObjectMap for record" o decode o =- Util.invalid "illegal Object for constructor" 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@@ -72,17 +77,20 @@ 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)+ M1 <$> maybe (gMissingKey key (ObjectMap o)) gMsgpackDecode (o !? Util.string key) where key = selName (undefined :: t s f p) msgpackDecodeProd (cur:rest) = do a <- gMsgpackDecode cur- return $ (rest, M1 a)+ return (rest, M1 a) msgpackDecodeProd [] = Util.invalid "too few values for product" ObjectNil instance MsgpackDecode a => GMsgpackDecode (K1 i a) where gMsgpackDecode = fmap K1 . fromMsgpack + gMissingKey key =+ fmap K1 . missingKey key+ instance (Ord k, MsgpackDecode k, MsgpackDecode v) => MsgpackDecode (Map k v) where fromMsgpack (ObjectMap om) = do m <- traverse decodePair $ Map.toList om@@ -105,3 +113,13 @@ instance {-# OVERLAPPABLE #-} MsgpackDecode a => MsgpackDecode [a] where fromMsgpack (ObjectArray oa) = traverse fromMsgpack oa fromMsgpack o = Util.illegalType "List" o++instance MsgpackDecode a => MsgpackDecode (Maybe a) where+ fromMsgpack ObjectNil = Right Nothing+ fromMsgpack o = Just <$> fromMsgpack o++ missingKey _ _ = Right Nothing++instance MsgpackDecode Bool where+ fromMsgpack (ObjectBool a) = Right a+ fromMsgpack o = Util.illegalType "Bool" o
lib/Ribosome/Msgpack/Encode.hs view
@@ -5,6 +5,10 @@ MsgpackEncode(..), ) where +import Data.Bifunctor (bimap)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map (fromList, toList)+import Data.MessagePack (Object(..)) import GHC.Generics ( Generic, Rep,@@ -20,10 +24,6 @@ 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@@ -41,11 +41,18 @@ 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 ObjectArray . msgpackEncodeProd+ 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@@ -69,3 +76,9 @@ instance {-# OVERLAPPABLE #-} MsgpackEncode a => MsgpackEncode [a] where toMsgpack = ObjectArray . fmap toMsgpack++instance MsgpackEncode a => MsgpackEncode (Maybe a) where+ toMsgpack = maybe ObjectNil toMsgpack++instance MsgpackEncode Bool where+ toMsgpack = ObjectBool
lib/Ribosome/Test/Exists.hs view
@@ -2,7 +2,7 @@ waitForPlugin, ) where -import Control.Monad.IO.Class+import Control.Monad.IO.Class (MonadIO) import Data.Char (toUpper) import Neovim
ribosome.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: ribosome-version: 0.2.1.0+version: 0.2.2.0 license: MIT license-file: LICENSE copyright: 2019 Torsten Schmits@@ -31,6 +31,7 @@ Ribosome.Api.Window Ribosome.Config.Setting Ribosome.Config.Settings+ Ribosome.Control.Lock Ribosome.Control.Monad.Ribo Ribosome.Control.Monad.RiboE Ribosome.Control.Monad.State
test/u/MsgpackSpec.hs view
@@ -1,25 +1,35 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} 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 Data.Text (Text)+import Data.Text.Prettyprint.Doc (Doc, layoutPretty, defaultLayoutOptions)+import Data.Text.Prettyprint.Doc.Render.Terminal (renderStrict, AnsiStyle)+import GHC.Generics (Generic) import Test.Framework-import Ribosome.Msgpack.Encode (MsgpackEncode(..))+ import Ribosome.Msgpack.Decode (MsgpackDecode(..))+import Ribosome.Msgpack.Encode (MsgpackEncode(..)) import qualified Ribosome.Msgpack.Util as Util (string) +newtype NT =+ NT String+ deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode)+ data Blob = Blob { key4 :: [[Int]],- key5 :: Map Int String+ key5 :: Map Int String,+ key6 :: NT } deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode) @@ -30,13 +40,13 @@ data Dat = Dat { key1 :: Blob,- key2 :: Int,- key3 :: Prod+ key2 :: Bool,+ key3 :: Maybe Prod } deriving (Eq, Show, Generic, MsgpackEncode, MsgpackDecode) dat :: Dat-dat = Dat (Blob [[1, 2], [3]] (Map.fromList [(1, "1"), (2, "2")])) 13 (Prod "dat" 27)+dat = Dat (Blob [[1, 2], [3]] (Map.fromList [(1, "1"), (2, "2")]) (NT "nt")) False (Just $ Prod "dat" 27) os :: String -> Object os = Util.string@@ -48,17 +58,41 @@ encodedBlob = ObjectMap $ Map.fromList [ (os "key4", ObjectArray [ObjectArray [i 1, i 2], ObjectArray [i 3]]),- (os "key5", ObjectMap $ Map.fromList [(i 1, os "1"), (i 2, os "2")])+ (os "key5", ObjectMap $ Map.fromList [(i 1, os "1"), (i 2, os "2")]),+ (os "key6", os "nt") ] encoded :: Object encoded =- ObjectMap $ Map.fromList [(os "key1", encodedBlob), (os "key2", i 13), (os "key3", ObjectArray [os "dat", i 27])]+ ObjectMap $ Map.fromList [+ (os "key1", encodedBlob),+ (os "key2", ObjectBool False),+ (os "key3", ObjectArray [os "dat", i 27])+ ] test_encode :: IO () test_encode = assertEqual encoded (toMsgpack dat) +doc2Text :: Either (Doc AnsiStyle) a -> Either Text a+doc2Text =+ mapLeft (renderStrict . layoutPretty defaultLayoutOptions)+ test_decode :: IO () test_decode =- assertEqual (Right dat) (mapLeft (const ()) $ fromMsgpack encoded)+ assertEqual (Right dat) (doc2Text $ fromMsgpack encoded)++data Nope =+ Nope {+ present :: Int,+ absent :: Maybe Int+ }+ deriving (Eq, Show, Generic, MsgpackDecode)++encodedNope :: Object+encodedNope =+ ObjectMap $ Map.fromList [(os "present", i 5)]++test_maybeMissing :: IO ()+test_maybeMissing =+ assertEqual (Right (Nope 5 Nothing)) (doc2Text $ fromMsgpack encodedNope)