winery 0.2 → 0.2.1
raw patch · 6 files changed
+144/−113 lines, 6 filesdep +QuickCheck
Dependencies added: QuickCheck
Files
- README.md +38/−14
- src/Data/Winery.hs +56/−31
- src/Data/Winery/Internal.hs +3/−17
- src/Data/Winery/Internal/Builder.hs +24/−14
- test/Spec.hs +12/−28
- winery.cabal +11/−9
README.md view
@@ -1,11 +1,11 @@ # winery -winery is a serialisation library for Haskell. It tries to achieve two-goals: compact representation and perpetual inspectability.--The standard `binary` library has no way to inspect the serialised value without the original instance.+winery is a serialisation library for Haskell. -There's `serialise`, which is an alternative library based on CBOR. Every value has to be accompanied with tags, so it tends to be redundant for arrays of small values. Encoding records with field names is also redudant.+* __Fast encoding__: can create a bytestring or write to a handle efficiently+* __Compact representation__: uses VLQ by default. Separates schemata and contents+* __Stateless decoding__: you can decode a value without reading all the leading bytes+* __Inspectable__: data can be read without the original instance ## Interface @@ -51,6 +51,17 @@ for any ADT. The former explicitly describes field names in the schema, and the latter does constructor names. +## Streaming output++You can write data to a handle without allocating a ByteString. You can see the+length before serialisation.++```haskell+toEncoding :: Serialise a => a -> Encoding+hPutEncoding :: Handle -> Encoding -> IO ()+getSize :: Encoding -> Int+```+ ## The schema The definition of `Schema` is as follows:@@ -131,6 +142,15 @@ Cathee Eberz ``` +At the moment, the following queries are supported:++* `.` return itself+* `.[]` enumerate all the elements in a list+* `.[i]` get the i-th element+* `.[i:j]` enumerate i-th to j-th items+* `.foo` Get a field named `foo`+* `F | G` compose queries (left to right)+ ## Benchmark ```haskell@@ -149,15 +169,19 @@ (De)serialisation of the datatype above using generic instances: ```-serialise/list/winery mean 830.4 μs ( +- 126.1 μs )-serialise/list/binary mean 1.268 ms ( +- 126.3 μs )-serialise/list/serialise mean 309.5 μs ( +- 22.33 μs )-serialise/item/winery mean 248.9 ns ( +- 22.84 ns )-serialise/item/binary mean 1.222 μs ( +- 77.28 ns )-serialise/item/serialise mean 384.6 ns ( +- 15.63 ns )-deserialise/winery mean 972.5 μs ( +- 150.6 μs )-deserialise/binary mean 1.721 ms ( +- 99.67 μs )-deserialise/serialise mean 957.3 μs ( +- 80.95 μs )+serialise/list/winery mean 847.4 μs ( +- 122.7 μs )+serialise/list/binary mean 1.221 ms ( +- 169.0 μs )+serialise/list/serialise mean 290.4 μs ( +- 34.98 μs )+serialise/item/winery mean 243.1 ns ( +- 27.50 ns )+serialise/item/binary mean 1.080 μs ( +- 75.82 ns )+serialise/item/serialise mean 322.4 ns ( +- 21.09 ns )+serialise/file/winery mean 681.9 μs ( +- 247.0 μs )+serialise/file/binary mean 1.731 ms ( +- 611.6 μs )+serialise/file/serialise mean 652.9 μs ( +- 185.8 μs )+deserialise/winery mean 733.2 μs ( +- 11.70 μs )+deserialise/binary mean 1.582 ms ( +- 122.3 μs )+deserialise/serialise mean 823.3 μs ( +- 38.08 μs )+ ``` Not bad, considering that binary and serialise don't encode field names.
src/Data/Winery.hs view
@@ -30,9 +30,13 @@ , serialiseOnly , getDecoder , getDecoderBy+ , decodeCurrent -- * Encoding combinators , Encoding , encodeMulti+ , BB.getSize+ , BB.toByteString+ , BB.hPutEncoding -- * Decoding combinators , Plan(..) , extractArrayBy@@ -41,7 +45,6 @@ , extractFieldBy , extractConstructor , extractConstructorBy- , extractScientific -- * Variable-length quantity , VarInt(..) -- * Internal@@ -67,6 +70,7 @@ import Control.Applicative import Control.Exception import Control.Monad.Trans.Cont+import Control.Monad.Trans.State import Control.Monad.Reader import qualified Data.ByteString as B import qualified Data.Winery.Internal.Builder as BB@@ -76,7 +80,7 @@ import Data.Functor.Identity import Data.Foldable import Data.Proxy-import Data.Scientific (Scientific)+import Data.Scientific (Scientific, scientific, coefficient, base10Exponent) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HM import Data.Int@@ -167,6 +171,10 @@ pure = Deserialiser . pure . pure Deserialiser f <*> Deserialiser x = Deserialiser $ (<*>) <$> f <*> x +instance Alternative Deserialiser where+ empty = Deserialiser empty+ Deserialiser f <|> Deserialiser g = Deserialiser $ f <|> g+ newtype Plan a = Plan { unPlan :: Schema -> Strategy a } deriving Functor @@ -226,6 +234,13 @@ getDecoderBy (Deserialiser plan) sch = unPlan plan sch `unStrategy` [] {-# INLINE getDecoderBy #-} +-- | Decode a value with the current schema.+decodeCurrent :: forall a. Serialise a => Decoder a+decodeCurrent = case getDecoder (schema (Proxy :: Proxy a)) of+ Left err -> error $ show $ "decodeCurrent: failed to get a decoder from the current schema"+ <+> parens err+ Right a -> a+ -- | Serialise a value along with its schema. serialise :: Serialise a => a -> B.ByteString serialise a = BB.toByteString $ mappend (BB.word8 currentSchemaVersion)@@ -235,7 +250,7 @@ -- | Serialise a value along with its schema. writeFileSerialise :: Serialise a => FilePath -> a -> IO () writeFileSerialise path a = withFile path WriteMode- $ \h -> BB.hPut h $ mappend (BB.word8 currentSchemaVersion)+ $ \h -> BB.hPutEncoding h $ mappend (BB.word8 currentSchemaVersion) $ toEncoding (schema [a], a) {-# INLINE writeFileSerialise #-} @@ -487,6 +502,13 @@ SBytes -> pure id s -> unexpectedSchema "Serialise ByteString" s +instance Serialise Encoding where+ schemaVia _ _ = SBytes+ toEncoding = id+ deserialiser = Deserialiser $ Plan $ \case+ SBytes -> pure BB.bytes+ s -> unexpectedSchema "Serialise Encoding" s+ instance Serialise a => Serialise [a] where schemaVia _ ts = case constantSize (Proxy :: Proxy a) of Nothing -> SList (substSchema (Proxy :: Proxy a) ts)@@ -562,22 +584,24 @@ 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)+instance Serialise Scientific where+ schemaVia _ = schemaVia (Proxy :: Proxy (Integer, Int))+ toEncoding s = toEncoding (coefficient s, base10Exponent s)+ deserialiser = 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+ _ -> f (uncurry scientific) s+ where+ f c = unwrapDeserialiser (c <$> deserialiser) -- | Extract a field of a record. extractField :: Serialise a => T.Text -> Deserialiser a@@ -821,7 +845,7 @@ class GSerialiseProduct f where productSchema :: proxy f -> [TypeRep] -> [Schema] productEncoder :: f x -> EncodingMulti -> EncodingMulti- productDecoder :: TransFusion (FieldDecoder ()) Decoder (Decoder (f x))+ productDecoder :: Compose (State Int) (TransFusion (FieldDecoder Int) Decoder) (Decoder (f x)) instance GSerialiseProduct U1 where productSchema _ _ = []@@ -831,7 +855,9 @@ instance (Serialise a) => GSerialiseProduct (K1 i a) where productSchema _ ts = [substSchema (Proxy :: Proxy a) ts] productEncoder (K1 a) = encodeItem (toEncoding a)- productDecoder = TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder () Nothing (getDeserialiser deserialiser)+ productDecoder = Compose $ state $ \i ->+ ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (getDeserialiser deserialiser)+ , i + 1) instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where productSchema _ ts = productSchema (Proxy :: Proxy f) ts@@ -844,17 +870,16 @@ productDecoder = liftA2 (:*:) <$> productDecoder <*> productDecoder deserialiserProduct' :: GSerialiseProduct f => [Schema] -> Strategy (Decoder (f x))-deserialiserProduct' schs0 = Strategy $ \recs -> do- let go :: Int -> [Schema] -> TransList (FieldDecoder ()) Decoder x -> Either StrategyError (Offsets -> x)- go _ _ (Done a) = Right $ const a- go _ [] _ = Left "deserialiserProduct': Mismatching number of fields"- go i (sch : schs) (More (FieldDecoder () _ p) k) = do- getItem <- unPlan p sch `unStrategy` recs- r <- go (i + 1) schs k- return $ \offsets -> r offsets $ decodeAt (unsafeIndexV "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem- m <- go 0 schs0 $ runTransFusion productDecoder+deserialiserProduct' schs = Strategy $ \recs -> do+ let go :: FieldDecoder Int x -> Compose (Either StrategyError) ((->) Offsets) (Decoder x)+ go (FieldDecoder i _ p) = Compose $ do+ getItem <- if i < length schs+ then unPlan p (schs !! i) `unStrategy` recs+ else Left "Data.Winery.gdeserialiserProduct: insufficient fields"+ return $ \offsets -> decodeAt (unsafeIndexV "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem+ m <- getCompose $ unTransFusion (getCompose productDecoder `evalState` 0) go return $ evalContT $ do- offsets <- decodeOffsets (length schs0)+ offsets <- decodeOffsets (length schs) lift $ m offsets -- | Generic implementation of 'schemaVia' for an ADT.
src/Data/Winery/Internal.hs view
@@ -27,9 +27,7 @@ , Strategy(..) , StrategyError , errorStrategy- , TransList(..) , TransFusion(..)- , runTransFusion )where import Control.Applicative@@ -44,7 +42,6 @@ import Data.Winery.Internal.Builder import Data.Bits import Data.Dynamic-import Data.Monoid import Data.Text.Prettyprint.Doc (Doc) import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) import qualified Data.Vector.Unboxed as U@@ -58,15 +55,16 @@ decodeAt :: (Int, Int) -> Decoder a -> Decoder a decodeAt (i, l) m = m . B.take l . B.drop i+{-# INLINE decodeAt #-} getWord8 :: ContT r Decoder Word8 getWord8 = ContT $ \k bs -> case B.uncons bs of- Nothing -> k 0 bs+ Nothing -> throw InsufficientInput Just (x, bs') -> k x $! bs' {-# INLINE getWord8 #-} data DecodeException = InsufficientInput- | InvalidTag deriving (Eq, Show)+ | InvalidTag deriving (Eq, Show, Read) instance Exception DecodeException decodeVarInt :: (Num a, Bits a) => ContT r Decoder a@@ -180,9 +178,6 @@ newtype TransFusion f g a = TransFusion { unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a } -runTransFusion :: TransFusion f g a -> TransList f g a-runTransFusion (TransFusion k) = k (\f -> More f (Done id))- instance Functor (TransFusion f g) where fmap f (TransFusion m) = TransFusion $ \k -> fmap f (m k) {-# INLINE fmap #-}@@ -191,12 +186,3 @@ pure a = TransFusion $ \_ -> pure a TransFusion a <*> TransFusion b = TransFusion $ \k -> a k <*> b k {-# INLINE (<*>) #-}--data TransList f g a = Done a | forall x. More (f x) (TransList f g (g x -> a))--deriving instance Functor (TransList f g)--instance Applicative (TransList f g) where- pure = Done- Done f <*> a = fmap f a- More i k <*> c = More i (flip <$> k <*> c)
src/Data/Winery/Internal/Builder.hs view
@@ -5,7 +5,7 @@ ( Encoding , getSize , toByteString- , hPut+ , hPutEncoding , word8 , word16 , word32@@ -14,13 +14,14 @@ , varInt ) where -import Data.Bits hiding (rotate)+import Data.Bits 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 Data.String import Data.IORef import Foreign.Ptr import Foreign.ForeignPtr@@ -32,15 +33,23 @@ import System.IO.Unsafe import System.Endian -data Encoding = Encoding {-# UNPACK #-}!Int !Tree+data Encoding = Encoding {-# UNPACK #-}!Int Tree | Empty+ deriving Eq +instance Show Encoding where+ show = show . toByteString++instance IsString Encoding where+ fromString = bytes . fromString+ data Tree = Bin Tree Tree | LWord8 {-# UNPACK #-} !Word8 | LWord16 {-# UNPACK #-} !Word16 | LWord32 {-# UNPACK #-} !Word32 | LWord64 {-# UNPACK #-} !Word64 | LBytes !B.ByteString+ deriving Eq instance Semigroup Encoding where Empty <> a = a@@ -66,21 +75,22 @@ 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+ Bin a b -> rotateTree 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+rotateTree :: Ptr Word8 -> Tree -> Tree -> IO ()+rotateTree ptr (LWord8 w) t = poke ptr w >> pokeTree (ptr `plusPtr` 1) t+rotateTree ptr (LWord16 w) t = poke (castPtr ptr) (toBE16 w) >> pokeTree (ptr `plusPtr` 2) t+rotateTree ptr (LWord32 w) t = poke (castPtr ptr) (toBE32 w) >> pokeTree (ptr `plusPtr` 4) t+rotateTree ptr (LWord64 w) t = poke (castPtr ptr) (toBE64 w) >> pokeTree (ptr `plusPtr` 8) t+rotateTree 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)+rotateTree ptr (Bin c d) t = rotateTree ptr c (Bin d t) toByteString :: Encoding -> B.ByteString toByteString Empty = B.empty+toByteString (Encoding _ (LBytes bs)) = bs toByteString (Encoding len tree) = unsafeDupablePerformIO $ do fp <- B.mallocByteString len withForeignPtr fp $ \ptr -> pokeTree ptr tree@@ -130,9 +140,9 @@ <$ withBuffer buf' (\ptr -> pokeByteOff ptr (bufR buf') x) {-# INLINE pokeBuffer #-} -hPut :: Handle -> Encoding -> IO ()-hPut _ Empty = return ()-hPut h (Encoding _ t0) = wantWritableHandle "Data.Winery.Intenal.Builder.hPut" h+hPutEncoding :: Handle -> Encoding -> IO ()+hPutEncoding _ Empty = return ()+hPutEncoding h (Encoding _ t0) = wantWritableHandle "Data.Winery.Intenal.Builder.hPutEncoding" h $ \Handle__{..} -> do buf0 <- readIORef haByteBuffer
test/Spec.hs view
@@ -1,32 +1,16 @@-{-# LANGUAGE DeriveGeneric, OverloadedStrings, OverloadedLabels, DataKinds, TypeOperators, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-} import Control.Monad.Fix-import Data.ByteString (ByteString)+import qualified Data.ByteString as B import Data.Winery-import Data.Winery.Term-import GHC.Generics--data TestRec = TestRec- { foo :: Maybe Int- , bar :: [ByteString]- , nodes :: [TestRec]- } deriving (Show, Generic)--instance Serialise TestRec where- schemaVia = gschemaViaRecord- toEncoding = gtoEncodingRecord- deserialiser = TestRec- <$> extractField "foo"- <*> extractField "bar"- <*> extractFieldWith (extractListWith deserialiser) "nodes"--defTest :: TestRec-defTest = TestRec Nothing ["hello"] [TestRec (Just 42) ["world"] []]--main :: IO ()-main = return ()--data TestVar = VFoo | VBar !Int | VBaz !Bool !Bool deriving (Show, Generic)+import qualified Data.Winery.Internal.Builder as WB+import Test.QuickCheck+import Control.Monad -instance Serialise TestVar+prop_VarInt :: [Int] -> Property+prop_VarInt i = B.length bs === WB.getSize e .&&. decodeCurrent bs === i+ where+ bs = WB.toByteString e+ e = toEncoding i -newtype UserId = UserId Int deriving Serialise+return []+main = void $ $quickCheckAll
winery.cabal view
@@ -1,14 +1,14 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack ----- hash: ef83aa777baa5f4b7fcf4c9708a493c8fbd187e078f3eef8d6ea02d8e257fcd9+-- hash: 93787e5525d90ec1aeb81d521ead44d1b77000046d92228940a76c519e23d0ca name: winery-version: 0.2+version: 0.2.1 synopsis: Sustainable serialisation library description: Please see the README on Github at <https://github.com/fumieval/winery#readme>-category: Data+category: Data, Codec, Parsing, Serialization homepage: https://github.com/fumieval/winery#readme bug-reports: https://github.com/fumieval/winery/issues author: Fumiaki Kinoshita@@ -18,6 +18,7 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10+ extra-source-files: ChangeLog.md README.md@@ -59,8 +60,6 @@ executable winery main-is: Main.hs- other-modules:- Paths_winery hs-source-dirs: app build-depends:@@ -80,6 +79,8 @@ , unordered-containers , vector , winery+ other-modules:+ Paths_winery default-language: Haskell2010 test-suite spec@@ -88,7 +89,8 @@ hs-source-dirs: test build-depends:- aeson+ QuickCheck+ , aeson , base >=4.7 && <5 , bytestring , containers@@ -111,8 +113,6 @@ benchmark bench-winery type: exitcode-stdio-1.0 main-is: bench.hs- other-modules:- Paths_winery hs-source-dirs: benchmarks ghc-options: -O2@@ -139,4 +139,6 @@ , unordered-containers , vector , winery+ other-modules:+ Paths_winery default-language: Haskell2010