winery 0.1.1 → 0.1.2
raw patch · 10 files changed
+266/−70 lines, 10 filesdep +megaparsecdep +scientificdep −fingertree
Dependencies added: megaparsec, scientific
Dependencies removed: fingertree
Files
- ChangeLog.md +9/−0
- README.md +17/−0
- app/Main.hs +43/−20
- src/Data/Winery.hs +48/−10
- src/Data/Winery/Internal.hs +1/−1
- src/Data/Winery/Internal/Builder.hs +32/−23
- src/Data/Winery/Query.hs +54/−0
- src/Data/Winery/Query/Parser.hs +46/−0
- src/Data/Winery/Term.hs +4/−10
- winery.cabal +12/−6
ChangeLog.md view
@@ -1,3 +1,12 @@+# 0.1.2++* Added `Data.Winery.Query`+* The winery tool now supports a simple jq-like query language++# 0.1.1++* Optimised the code+ # 0.1 Overhauled the encoding; Sorry, incompatible with 0
README.md view
@@ -114,6 +114,23 @@ } ``` +You can use the `winery` command-line tool to inspect values.++```+$ winery '.[:10] | .first_name .last_name' benchmarks/data.winery+Shane Plett+Mata Snead+Levon Sammes+Irina Gourlay+Brooks Titlow+Antons Culleton+Regine Emerton+Starlin Laying+Orv Kempshall+Elizabeth Joseff+Cathee Eberz+```+ ## Benchmark ```haskell
app/Main.hs view
@@ -1,16 +1,22 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase, OverloadedStrings #-} module Main where import Control.Monad import qualified Data.ByteString as B import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal+import Data.Void+import qualified Data.Winery.Query as Q+import Data.Winery.Query.Parser import Data.Winery.Term import Data.Winery import System.Console.GetOpt import System.Environment import System.Exit import System.IO+import qualified Data.Text as T+import Text.Megaparsec+import Text.Megaparsec.Char data Options = Options { streamInput :: Bool@@ -34,31 +40,48 @@ getRight :: Either StrategyError a -> IO a getRight (Left err) = do- hPutDoc stderr err+ hPutDoc stderr (err <> hardline) exitFailure getRight (Right a) = return a +putTerm :: Doc AnsiStyle -> IO ()+putTerm t = putDoc $ t <> hardline++app :: Options -> Q.Query (Doc AnsiStyle) (Doc AnsiStyle) -> Handle -> IO ()+app o q h = do+ let getDec = getRight . getDecoderBy (Q.runQuery q (pure . pretty <$> decodeTerm))+ printer <- case separateSchema o of+ Just mpath -> do+ bs <- maybe (readLn >>= B.hGet h) B.readFile mpath+ sch <- getRight $ deserialise bs+ when (printSchema o) $ putDoc $ pretty sch <> hardline+ dec <- getDec sch+ return $ mapM_ putTerm . dec+ Nothing -> return $ \bs_ -> do+ (s, bs) <- getRight $ splitSchema bs_+ dec <- getDec s+ when (printSchema o) $ putDoc $ pretty s <> hardline+ mapM_ putTerm $ dec bs++ case streamInput o of+ False -> B.hGetContents h >>= printer+ True -> forever $ do+ n <- readLn+ B.hGet h n >>= printer++main :: IO () main = getOpt Permute options <$> getArgs >>= \case- (fs, _, []) -> do+ (fs, qs : paths, []) -> do let o = foldl (flip id) defaultOptions fs-- printer <- case separateSchema o of- Just mpath -> do- bs <- maybe (readLn >>= B.hGet stdin) B.readFile mpath- sch <- getRight $ deserialise bs- when (printSchema o) $ putDoc $ pretty sch <> hardline- dec <- getRight $ getDecoderBy decodeTerm sch- return $ \bs -> putDoc $ pretty (dec bs) <> hardline- Nothing -> return $ \bs -> do- (s, t) <- getRight $ deserialiseTerm bs- when (printSchema o) $ putDoc $ pretty s <> hardline- putDoc $ pretty t <> hardline+ q <- case parse (parseQuery <* eof) "argument" $ T.pack qs of+ Left e -> do+ hPutStrLn stderr $ parseErrorPretty e+ exitWith (ExitFailure 2)+ Right a -> pure a+ forM_ paths $ \case+ "-" -> app o q stdin+ path -> withFile path ReadMode (app o q) - case streamInput o of- False -> B.hGetContents stdin >>= printer- True -> forever $ do- n <- readLn- B.hGet stdin n >>= printer (_, _, es) -> do name <- getProgName die $ unlines es ++ usageInfo name options
src/Data/Winery.hs view
@@ -20,6 +20,8 @@ -- * Standalone serialisation , serialise , deserialise+ , deserialiseBy+ , splitSchema -- * Separate serialisation , Deserialiser(..) , Decoder@@ -31,17 +33,21 @@ , encodeMulti -- * Decoding combinators , Plan(..)+ , extractArrayWith , extractListWith , extractField , extractFieldWith , extractConstructor , extractConstructorWith+ , extractScientific -- * Variable-length quantity , VarInt(..) -- * Internal , unwrapDeserialiser , Strategy , StrategyError+ , unexpectedSchema+ , unexpectedSchema' -- * Generics , GSerialiseRecord , gschemaViaRecord@@ -67,6 +73,7 @@ import Data.Functor.Identity import Data.Foldable import Data.Proxy+import Data.Scientific (Scientific) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HM import Data.Int@@ -221,17 +228,27 @@ $ toEncoding (schema [a], a) {-# INLINE serialise #-} --- | Deserialise a 'serialise'd 'B.Bytestring'.-deserialise :: Serialise a => B.ByteString -> Either StrategyError a-deserialise bs_ = case B.uncons bs_ of+splitSchema :: B.ByteString -> Either StrategyError (Schema, B.ByteString)+splitSchema bs_ = case B.uncons bs_ of Just (ver, bs) -> do m <- getDecoder $ SSchema ver- ($bs) $ evalContT $ do+ return $ ($bs) $ evalContT $ do sizA <- decodeVarInt sch <- lift $ m . B.take sizA- asks $ \bs' -> ($ B.drop sizA bs') <$> getDecoderBy deserialiser sch+ asks $ \bs' -> (sch, B.drop sizA bs') Nothing -> Left "Unexpected empty string" +-- | Deserialise a 'serialise'd 'B.Bytestring'.+deserialise :: Serialise a => B.ByteString -> Either StrategyError a+deserialise = deserialiseBy deserialiser+{-# INLINE deserialise #-}++-- | Deserialise a 'serialise'd 'B.Bytestring'.+deserialiseBy :: Deserialiser a -> B.ByteString -> Either StrategyError a+deserialiseBy d bs_ = do+ (sch, bs) <- splitSchema bs_+ ($bs) <$> getDecoderBy d sch+ -- | Serialise a value without its schema. serialiseOnly :: Serialise a => a -> B.ByteString serialiseOnly = BB.toByteString . toEncoding@@ -484,22 +501,26 @@ toEncoding = toEncoding . UV.toList deserialiser = UV.fromList <$> deserialiser --- | Extract a list or an array of values.-extractListWith :: Deserialiser a -> Deserialiser [a]-extractListWith (Deserialiser plan) = Deserialiser $ Plan $ \case+extractArrayWith :: Deserialiser a -> Deserialiser (Int, Int -> a)+extractArrayWith (Deserialiser plan) = Deserialiser $ Plan $ \case SArray (VarInt size) s -> do getItem <- unPlan plan s return $ evalContT $ do n <- decodeVarInt- asks $ \bs -> [decodeAt (size * i, size) getItem bs | i <- [0..n - 1]]+ asks $ \bs -> (n, \i -> decodeAt (size * i, size) getItem bs) SList s -> do getItem <- unPlan plan s return $ evalContT $ do n <- decodeVarInt offsets <- decodeOffsets n- asks $ \bs -> [decodeAt ofs getItem bs | ofs <- UV.toList offsets]+ asks $ \bs -> (n, \i -> decodeAt (offsets UV.! i) getItem bs) s -> unexpectedSchema' "extractListWith ..." "[a]" s +-- | Extract a list or an array of values.+extractListWith :: Deserialiser a -> Deserialiser [a]+extractListWith d = (\(n, f) -> map f [0..n-1]) <$> extractArrayWith d+{-# INLINE extractListWith #-}+ instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where schemaVia _ = schemaVia (Proxy :: Proxy [(k, v)]) toEncoding = toEncoding . M.toList@@ -529,6 +550,23 @@ schemaVia _ = schemaVia (Proxy :: Proxy [a]) toEncoding = toEncoding . toList deserialiser = Seq.fromList <$> deserialiser++extractScientific :: Deserialiser Scientific+extractScientific = Deserialiser $ Plan $ \s -> case s of+ SWord8 -> f (fromIntegral :: Word8 -> Scientific) s+ SWord16 -> f (fromIntegral :: Word16 -> Scientific) s+ SWord32 -> f (fromIntegral :: Word32 -> Scientific) s+ SWord64 -> f (fromIntegral :: Word64 -> Scientific) s+ SInt8 -> f (fromIntegral :: Int8 -> Scientific) s+ SInt16 -> f (fromIntegral :: Int16 -> Scientific) s+ SInt32 -> f (fromIntegral :: Int32 -> Scientific) s+ SInt64 -> f (fromIntegral :: Int64 -> Scientific) s+ SInteger -> f fromInteger s+ SFloat -> f (realToFrac :: Float -> Scientific) s+ SDouble -> f (realToFrac :: Double -> Scientific) s+ _ -> unexpectedSchema' "extractScientific" "numeric" s+ where+ f c = unwrapDeserialiser (c <$> deserialiser) -- | Extract a field of a record. extractField :: Serialise a => T.Text -> Deserialiser a
src/Data/Winery/Internal.hs view
@@ -52,7 +52,7 @@ type Decoder = (->) B.ByteString decodeAt :: (Int, Int) -> Decoder a -> Decoder a-decodeAt (i, l) m bs = m $ B.take l $ B.drop i bs+decodeAt (i, l) m = m . B.take l . B.drop i encodeVarInt :: (Bits a, Integral a) => a -> Encoding encodeVarInt n
src/Data/Winery/Internal/Builder.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns #-} module Data.Winery.Internal.Builder ( Encoding@@ -13,6 +14,9 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import Data.Word+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable@@ -29,12 +33,15 @@ | LWord64 {-# UNPACK #-} !Word64 | LBytes !B.ByteString +instance Semigroup Encoding where+ Empty <> a = a+ a <> Empty = a+ Encoding s a <> Encoding t b = Encoding (s + t) (Bin a b)+ instance Monoid Encoding where mempty = Empty {-# INLINE mempty #-}- mappend Empty a = a- mappend a Empty = a- mappend (Encoding s a) (Encoding t b) = Encoding (s + t) (Bin a b)+ mappend = (<>) {-# INLINE mappend #-} getSize :: Encoding -> Int@@ -42,30 +49,32 @@ getSize (Encoding s _) = s {-# INLINE getSize #-} +pokeTree :: Ptr Word8 -> Tree -> IO ()+pokeTree ptr l = case l of+ LWord8 w -> poke ptr w+ LWord16 w -> poke (castPtr ptr) $ toBE16 w+ LWord32 w -> poke (castPtr ptr) $ toBE32 w+ LWord64 w -> poke (castPtr ptr) $ toBE64 w+ LBytes (B.PS fp ofs len) -> withForeignPtr fp+ $ \src -> B.memcpy ptr (src `plusPtr` ofs) len+ Bin a b -> rotate ptr a b++rotate :: Ptr Word8 -> Tree -> Tree -> IO ()+rotate ptr (LWord8 w) t = poke ptr w >> pokeTree (ptr `plusPtr` 1) t+rotate ptr (LWord16 w) t = poke (castPtr ptr) (toBE16 w) >> pokeTree (ptr `plusPtr` 2) t+rotate ptr (LWord32 w) t = poke (castPtr ptr) (toBE32 w) >> pokeTree (ptr `plusPtr` 4) t+rotate ptr (LWord64 w) t = poke (castPtr ptr) (toBE64 w) >> pokeTree (ptr `plusPtr` 8) t+rotate ptr (LBytes (B.PS fp ofs len)) t = do+ withForeignPtr fp+ $ \src -> B.memcpy ptr (src `plusPtr` ofs) len+ pokeTree (ptr `plusPtr` len) t+rotate ptr (Bin c d) t = rotate ptr c (Bin d t)+ toByteString :: Encoding -> B.ByteString toByteString Empty = B.empty toByteString (Encoding len tree) = unsafeDupablePerformIO $ do fp <- B.mallocByteString len- withForeignPtr fp $ \ptr -> do- let copyBS ofs (B.PS fp' sofs len') = withForeignPtr fp'- $ \src -> B.memcpy (ptr `plusPtr` ofs) (src `plusPtr` sofs) len'- let go :: Int -> Tree -> IO ()- go ofs l = case l of- LWord8 w -> pokeByteOff ptr ofs w- LWord16 w -> pokeByteOff ptr ofs $ toBE16 w- LWord32 w -> pokeByteOff ptr ofs $ toBE32 w- LWord64 w -> pokeByteOff ptr ofs $ toBE64 w- LBytes bs -> copyBS ofs bs- Bin a b -> rotate ofs a b-- rotate :: Int -> Tree -> Tree -> IO ()- rotate ofs (LWord8 w) t = pokeByteOff ptr ofs w >> go (ofs + 1) t- rotate ofs (LWord16 w) t = pokeByteOff ptr ofs (toBE16 w) >> go (ofs + 2) t- rotate ofs (LWord32 w) t = pokeByteOff ptr ofs (toBE32 w) >> go (ofs + 4) t- rotate ofs (LWord64 w) t = pokeByteOff ptr ofs (toBE64 w) >> go (ofs + 8) t- rotate ofs (LBytes bs) t = copyBS ofs bs >> go (ofs + B.length bs) t- rotate ofs (Bin c d) t = rotate ofs c (Bin d t)- go 0 tree+ withForeignPtr fp $ \ptr -> pokeTree ptr tree return (B.PS fp 0 len) word8 :: Word8 -> Encoding
+ src/Data/Winery/Query.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Winery.Query (Query(..)+ , invalid+ , list+ , range+ , field+ , con+ , select) where++import Prelude hiding ((.), id)+import Control.Applicative+import Control.Category+import Data.Winery+import Data.Winery.Internal+import Data.Typeable+import qualified Data.Text as T++newtype Query a b = Query+ { runQuery :: Deserialiser [a] -> Deserialiser [b] }+ deriving Functor++instance Category Query where+ id = Query $ fmap id+ Query f . Query g = Query $ f . g++instance Applicative (Query a) where+ pure a = Query $ const $ pure [a]+ Query f <*> Query g = Query $ \d -> (<*>) <$> f d <*> g d++instance Alternative (Query a) where+ empty = Query $ const $ pure []+ Query f <|> Query g = Query $ \d -> (++) <$> f d <*> g d++invalid :: StrategyError -> Query a b+invalid = Query . const . Deserialiser . Plan . const . errorStrategy++list :: Query a a+list = Query $ \d -> concat <$> extractListWith d++range :: Int -> Int -> Query a a+range i j = Query $ \d -> (\(n, f) -> concatMap f [mod i n..mod j n]) <$> extractArrayWith d++field :: Typeable a => T.Text -> Query a a+field name = Query $ \d -> extractFieldWith d name++con :: Typeable a => T.Text -> Query a a+con name = Query $ \d -> maybe [] id <$> extractConstructorWith d name++select :: Query a Bool -> Query a a+select qp = Query $ \d -> Deserialiser $ Plan $ \sch -> do+ p <- unwrapDeserialiser (runQuery qp d) sch+ dec <- unwrapDeserialiser d sch+ return $ \bs -> [x | and $ p bs, x <- dec bs]
+ src/Data/Winery/Query/Parser.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+module Data.Winery.Query.Parser (parseQuery) where++import Prelude hiding ((.), id)+import Control.Category+import Data.Winery.Query+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Doc, hsep)+import Data.Typeable+import Data.Void++type Parser = Parsec Void T.Text++symbol :: T.Text -> Parser T.Text+symbol = L.symbol space++name :: Parser T.Text+name = fmap T.pack (some (alphaNumChar <|> oneOf ("_\'" :: [Char])) <?> "field name")++parseQuery :: Typeable a => Parser (Query (Doc a) (Doc a))+parseQuery = foldr (.) id <$> sepBy1 parseTerms (symbol "|")++parseTerms :: Typeable a => Parser (Query (Doc a) (Doc a))+parseTerms = fmap hsep . sequenceA <$> sepBy1 parseTerm space++parseTerm :: Typeable a => Parser (Query (Doc a) (Doc a))+parseTerm = L.lexeme space $ choice+ [ char '.' >> choice+ [ do+ _ <- char '['+ i <- optional L.decimal+ j <- optional (symbol ":" >> L.decimal)+ _ <- char ']'+ return $ range (maybe 0 id i) (maybe (-1) id j)+ , field <$> name+ , return id+ ]+ ]
src/Data/Winery/Term.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-} module Data.Winery.Term where -import Control.Monad.Trans import Control.Monad.Trans.Cont import Control.Monad.Reader import qualified Data.ByteString as B@@ -90,15 +89,10 @@ -- | Deserialise a 'serialise'd 'B.Bytestring'. deserialiseTerm :: B.ByteString -> Either (Doc AnsiStyle) (Schema, Term)-deserialiseTerm bs_ = case B.uncons bs_ of- Just (ver, bs) -> do- getSchema <- getDecoder $ SSchema ver- ($bs) $ evalContT $ do- offB <- decodeVarInt- sch <- lift getSchema- body <- asks $ \bs' -> ($ B.drop offB bs') <$> getDecoderBy decodeTerm sch- return ((,) sch <$> body)- Nothing -> Left "Unexpected empty string"+deserialiseTerm bs_ = do+ (sch, bs) <- splitSchema bs_+ dec <- getDecoderBy decodeTerm sch+ return (sch, dec bs) instance Pretty Term where pretty TUnit = "()"
winery.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 750a23f7c3318207ce7adf5a4637dd1630f0e706c5efab6184ecbb0fc4b4882e+-- hash: f441dfe5896bdc24f2600a35982ae2f08288dc6b07958d380edeabb5e816dfbc name: winery-version: 0.1.1+version: 0.1.2 synopsis: Sustainable serialisation library description: Please see the README on Github at <https://github.com/fumieval/winery#readme> category: Data@@ -36,11 +36,12 @@ , bytestring , containers , cpu- , fingertree , hashable+ , megaparsec , mtl , prettyprinter , prettyprinter-ansi-terminal+ , scientific , text , transformers , unordered-containers@@ -49,6 +50,8 @@ Data.Winery Data.Winery.Term Data.Winery.Internal+ Data.Winery.Query+ Data.Winery.Query.Parser other-modules: Data.Winery.Internal.Builder Paths_winery@@ -63,11 +66,12 @@ , bytestring , containers , cpu- , fingertree , hashable+ , megaparsec , mtl , prettyprinter , prettyprinter-ansi-terminal+ , scientific , text , transformers , unordered-containers@@ -87,11 +91,12 @@ , bytestring , containers , cpu- , fingertree , hashable+ , megaparsec , mtl , prettyprinter , prettyprinter-ansi-terminal+ , scientific , text , transformers , unordered-containers@@ -115,12 +120,13 @@ , containers , cpu , deepseq- , fingertree , gauge , hashable+ , megaparsec , mtl , prettyprinter , prettyprinter-ansi-terminal+ , scientific , serialise , text , transformers