winery 0 → 0.1
raw patch · 6 files changed
+328/−132 lines, 6 filesdep +binarydep +cassavadep +deepseq
Dependencies added: binary, cassava, deepseq, fast-builder, gauge, serialise
Files
- ChangeLog.md +4/−0
- benchmarks/bench.hs +61/−0
- src/Data/Winery.hs +88/−83
- src/Data/Winery/Internal.hs +131/−39
- src/Data/Winery/Term.hs +5/−4
- winery.cabal +39/−6
ChangeLog.md view
@@ -1,3 +1,7 @@+# 0.1++Overhauled the encoding; Sorry, incompatible with 0+ # 0 Initial release
+ benchmarks/bench.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+import Control.DeepSeq+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Data.Binary as B+import Data.Either+import Data.Winery+import Data.Word+import Data.Text (Text)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Gauge.Main+import qualified Codec.Serialise as CBOR+import qualified Data.Csv as CSV+import Data.Winery.Term++data Gender = Male | Female deriving (Show, Generic)++instance Serialise Gender+instance CBOR.Serialise Gender+instance B.Binary Gender++data TestRec = TestRec+ { id_ :: !Int+ , first_name :: !Text+ , last_name :: !Text+ , email :: !Text+ , gender :: !Gender+ , num :: !Int+ , latitude :: !Double+ , longitude :: !Double+ } deriving (Show, Generic)++instance NFData TestRec where+ rnf TestRec{} = ()++instance Serialise TestRec where+ schemaVia = gschemaViaRecord+ toEncoding = gtoEncodingRecord+ deserialiser = gdeserialiserRecord Nothing++instance B.Binary TestRec+instance CBOR.Serialise TestRec++main = do+ winery <- B.readFile "benchmarks/data.winery"+ binary <- B.readFile "benchmarks/data.binary"+ cbor <- B.readFile "benchmarks/data.cbor"+ Right (values :: [TestRec]) <- return $ deserialise winery+ defaultMain+ [ bgroup "serialise"+ [ bench "winery" $ nf serialise values+ , bench "binary" $ nf (BL.toStrict . B.encode) values+ , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) values+ ]+ , bgroup "deserialise"+ [ bench "winery" $ nf (fromRight undefined . deserialise :: B.ByteString -> [TestRec]) winery+ , bench "binary" $ nf (B.decode . BL.fromStrict :: B.ByteString -> [TestRec]) binary+ , bench "serialise" $ nf (CBOR.deserialise . BL.fromStrict :: B.ByteString -> [TestRec]) cbor+ ]+ ]
src/Data/Winery.hs view
@@ -8,12 +8,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE ExistentialQuantification #-} module Data.Winery ( Schema(..) , Serialise(..)@@ -46,6 +44,7 @@ -- * Generics , GSerialiseRecord , gschemaViaRecord+ , GEncodeRecord , gtoEncodingRecord , gdeserialiserRecord , GSerialiseVariant@@ -60,10 +59,10 @@ import Control.Monad.Trans.Cont import Control.Monad.Reader import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.FastBuilder as BB import Data.Bits import Data.Dynamic+import Data.Functor.Compose import Data.Functor.Identity import Data.Foldable import Data.Proxy@@ -217,8 +216,8 @@ -- | Serialise a value along with its schema. serialise :: Serialise a => a -> B.ByteString-serialise a = BL.toStrict $ BB.toLazyByteString $ mappend (BB.word8 currentSchemaVersion)- $ snd $ toEncoding (schema [a], a)+serialise a = BB.toStrictByteString $ mappend (BB.word8 currentSchemaVersion)+ $ encodingBuilder $ toEncoding (schema [a], a) -- | Deserialise a 'serialise'd 'B.Bytestring'. deserialise :: Serialise a => B.ByteString -> Either StrategyError a@@ -226,14 +225,14 @@ Just (ver, bs) -> do m <- getDecoder $ SSchema ver ($bs) $ evalContT $ do- offB <- decodeVarInt- sch <- lift m- asks $ \bs' -> ($ B.drop offB bs') <$> getDecoderBy deserialiser sch+ sizA <- decodeVarInt+ sch <- lift $ m . B.take sizA+ asks $ \bs' -> ($ B.drop sizA bs') <$> getDecoderBy deserialiser sch Nothing -> Left "Unexpected empty string" -- | Serialise a value without its schema. serialiseOnly :: Serialise a => a -> B.ByteString-serialiseOnly = BL.toStrict . BB.toLazyByteString . snd . toEncoding+serialiseOnly = BB.toStrictByteString . encodingBuilder . toEncoding {-# INLINE serialiseOnly #-} substSchema :: Serialise a => Proxy a -> [TypeRep] -> Schema@@ -242,10 +241,10 @@ | otherwise = schemaVia p ts currentSchemaVersion :: Word8-currentSchemaVersion = 0+currentSchemaVersion = 1 bootstrapSchema :: Word8 -> Either StrategyError Schema-bootstrapSchema 0 = Right $ SFix $ SVariant [("SSchema",[SWord8])+bootstrapSchema 1 = Right $ SFix $ SVariant [("SSchema",[SWord8]) ,("SUnit",[]) ,("SBool",[]) ,("SChar",[])@@ -299,8 +298,8 @@ instance Serialise Bool where schemaVia _ _ = SBool- toEncoding False = (1, BB.word8 0)- toEncoding True = (1, BB.word8 1)+ toEncoding False = Encoding 1 (BB.word8 0)+ toEncoding True = Encoding 1 (BB.word8 1) deserialiser = Deserialiser $ Plan $ \case SBool -> pure $ (/=0) <$> evalContT getWord8 s -> unexpectedSchema "Serialise Bool" s@@ -308,7 +307,7 @@ instance Serialise Word8 where schemaVia _ _ = SWord8- toEncoding x = (1, BB.word8 x)+ toEncoding x = Encoding 1 (BB.word8 x) deserialiser = Deserialiser $ Plan $ \case SWord8 -> pure $ evalContT getWord8 s -> unexpectedSchema "Serialise Word8" s@@ -316,7 +315,7 @@ instance Serialise Word16 where schemaVia _ _ = SWord16- toEncoding x = (2, BB.word16BE x)+ toEncoding x = Encoding 2 (BB.word16BE x) deserialiser = Deserialiser $ Plan $ \case SWord16 -> pure $ evalContT $ do a <- getWord8@@ -327,7 +326,7 @@ instance Serialise Word32 where schemaVia _ _ = SWord32- toEncoding x = (4, BB.word32BE x)+ toEncoding x = Encoding 4 (BB.word32BE x) deserialiser = Deserialiser $ Plan $ \case SWord32 -> pure word32be s -> unexpectedSchema "Serialise Word32" s@@ -335,7 +334,7 @@ instance Serialise Word64 where schemaVia _ _ = SWord64- toEncoding x = (8, BB.word64BE x)+ toEncoding x = Encoding 8 (BB.word64BE x) deserialiser = Deserialiser $ Plan $ \case SWord64 -> pure word64be s -> unexpectedSchema "Serialise Word64" s@@ -343,7 +342,7 @@ instance Serialise Word where schemaVia _ _ = SWord64- toEncoding x = (8, BB.word64BE $ fromIntegral x)+ toEncoding x = Encoding 8 $ BB.word64BE $ fromIntegral x deserialiser = Deserialiser $ Plan $ \case SWord64 -> pure $ fromIntegral <$> word64be s -> unexpectedSchema "Serialise Word" s@@ -351,7 +350,7 @@ instance Serialise Int8 where schemaVia _ _ = SInt8- toEncoding x = (1, BB.int8 x)+ toEncoding x = Encoding 1 (BB.int8 x) deserialiser = Deserialiser $ Plan $ \case SInt8 -> pure $ fromIntegral <$> evalContT getWord8 s -> unexpectedSchema "Serialise Int8" s@@ -359,7 +358,7 @@ instance Serialise Int16 where schemaVia _ _ = SInt16- toEncoding x = (2, BB.int16BE x)+ toEncoding x = Encoding 2 (BB.int16BE x) deserialiser = Deserialiser $ Plan $ \case SInt16 -> pure $ fromIntegral <$> word16be s -> unexpectedSchema "Serialise Int16" s@@ -367,7 +366,7 @@ instance Serialise Int32 where schemaVia _ _ = SInt32- toEncoding x = (4, BB.int32BE x)+ toEncoding x = Encoding 4 (BB.int32BE x) deserialiser = Deserialiser $ Plan $ \case SInt32 -> pure $ fromIntegral <$> word32be s -> unexpectedSchema "Serialise Int32" s@@ -375,7 +374,7 @@ instance Serialise Int64 where schemaVia _ _ = SInt64- toEncoding x = (8, BB.int64BE x)+ toEncoding x = Encoding 8 (BB.int64BE x) deserialiser = Deserialiser $ Plan $ \case SInt64 -> pure $ fromIntegral <$> word64be s -> unexpectedSchema "Serialise Int64" s@@ -390,7 +389,7 @@ instance Serialise Float where schemaVia _ _ = SFloat- toEncoding x = (4, BB.word32BE $ unsafeCoerce x)+ toEncoding x = Encoding 4 $ BB.word32BE $ unsafeCoerce x deserialiser = Deserialiser $ Plan $ \case SFloat -> pure $ unsafeCoerce <$> word32be s -> unexpectedSchema "Serialise Float" s@@ -398,7 +397,7 @@ instance Serialise Double where schemaVia _ _ = SDouble- toEncoding x = (8, BB.word64BE $ unsafeCoerce x)+ toEncoding x = Encoding 8 $ BB.word64BE $ unsafeCoerce x deserialiser = Deserialiser $ Plan $ \case SDouble -> pure $ unsafeCoerce <$> word64be s -> unexpectedSchema "Serialise Double" s@@ -408,16 +407,17 @@ schemaVia _ _ = SText toEncoding = toEncoding . T.encodeUtf8 deserialiser = Deserialiser $ Plan $ \case- SText -> pure $ T.decodeUtf8 <$> getBytes+ SText -> pure T.decodeUtf8 s -> unexpectedSchema "Serialise Text" s -- | Encoded in variable-length quantity. newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum , Bounded, Num, Real, Integral, Bits, Typeable) -instance (Typeable a, Integral a, Bits a) => Serialise (VarInt a) where+instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where schemaVia _ _ = SInteger- toEncoding = encodeVarInt+ toEncoding = encodeVarInt . getVarInt+ {-# INLINE toEncoding #-} deserialiser = Deserialiser $ Plan $ \case SInteger -> pure $ evalContT decodeVarInt s -> unexpectedSchema "Serialise (VarInt a)" s@@ -452,10 +452,9 @@ instance Serialise B.ByteString where schemaVia _ _ = SBytes- toEncoding bs = encodeVarInt (B.length bs)- <> (Sum $ B.length bs, BB.byteString bs)+ toEncoding bs = Encoding (B.length bs) (BB.byteString bs) deserialiser = Deserialiser $ Plan $ \case- SBytes -> pure getBytes+ SBytes -> pure id s -> unexpectedSchema "Serialise ByteString" s instance Serialise a => Serialise [a] where@@ -490,13 +489,13 @@ getItem <- unPlan plan s return $ evalContT $ do n <- decodeVarInt- asks $ \bs -> [decodeAt (size * i) getItem bs | i <- [0..n - 1]]+ asks $ \bs -> [decodeAt (size * i, size) getItem bs | i <- [0..n - 1]] SList s -> do getItem <- unPlan plan s return $ evalContT $ do n <- decodeVarInt offsets <- decodeOffsets n- asks $ \bs -> [decodeAt ofs getItem bs | ofs <- offsets]+ asks $ \bs -> [decodeAt ofs getItem bs | ofs <- UV.toList offsets] s -> unexpectedSchema' "extractListWith ..." "[a]" s instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where@@ -550,7 +549,7 @@ m <- unPlan g sch return $ evalContT $ do offsets <- decodeOffsets (length schs)- lift $ decodeAt (unsafeIndex msg offsets i) m+ lift $ decodeAt (unsafeIndexV msg offsets i) m Nothing -> errorStrategy $ rep <> ": Schema not found in " <> pretty (map fst schs) s -> unexpectedSchema' rep "a record" s where@@ -580,11 +579,11 @@ getB <- unwrapDeserialiser deserialiser sb return $ evalContT $ do offA <- decodeVarInt- asks $ \bs -> (getA bs, decodeAt offA getB bs)- SProductFixed [(VarInt la, sa), (_, sb)] -> do+ asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offA, maxBound) getB bs)+ SProductFixed [(VarInt la, sa), (VarInt lb, sb)] -> do getA <- unwrapDeserialiser deserialiser sa getB <- unwrapDeserialiser deserialiser sb- return $ \bs -> (getA bs, decodeAt la getB bs)+ return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs) s -> unexpectedSchema "Serialise (a, b)" s constantSize _ = (+) <$> constantSize (Proxy :: Proxy a) <*> constantSize (Proxy :: Proxy b)@@ -608,12 +607,12 @@ return $ evalContT $ do offA <- decodeVarInt offB <- decodeVarInt- asks $ \bs -> (getA bs, decodeAt offA getB bs, decodeAt (offA + offB) getC bs)- SProductFixed [(VarInt la, sa), (VarInt lb, sb), (_, sc)] -> do+ asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offA, offB) getB bs, decodeAt (offA + offB, maxBound) getC bs)+ SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc)] -> do getA <- unwrapDeserialiser deserialiser sa getB <- unwrapDeserialiser deserialiser sb getC <- unwrapDeserialiser deserialiser sc- return $ \bs -> (getA bs, decodeAt la getB bs, decodeAt (la + lb) getC bs)+ return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs, decodeAt (la + lb, lc) getC bs) s -> unexpectedSchema "Serialise (a, b, c)" s constantSize _ = fmap sum $ sequence [constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c)]@@ -640,13 +639,13 @@ offA <- decodeVarInt offB <- decodeVarInt offC <- decodeVarInt- asks $ \bs -> (getA bs, decodeAt offA getB bs, decodeAt (offA + offB) getC bs, decodeAt (offA + offB + offC) getD bs)- SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc), (_, sd)] -> do+ asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offB, offA) getB bs, decodeAt (offA + offB, offC) getC bs, decodeAt (offA + offB + offC, maxBound) getD bs)+ SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc), (VarInt ld, sd)] -> do getA <- unwrapDeserialiser deserialiser sa getB <- unwrapDeserialiser deserialiser sb getC <- unwrapDeserialiser deserialiser sc getD <- unwrapDeserialiser deserialiser sd- return $ \bs -> (getA bs, decodeAt la getB bs, decodeAt (la + lb) getC bs, decodeAt (la + lb + lc) getD bs)+ return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs, decodeAt (la + lb, lc) getC bs, decodeAt (la + lb + lc, ld) getD bs) s -> unexpectedSchema "Serialise (a, b, c, d)" s constantSize _ = fmap sum $ sequence [constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c), constantSize (Proxy :: Proxy d)]@@ -654,8 +653,8 @@ instance (Serialise a, Serialise b) => Serialise (Either a b) where schemaVia _ ts = SVariant [("Left", [substSchema (Proxy :: Proxy a) ts]) , ("Right", [substSchema (Proxy :: Proxy b) ts])]- toEncoding (Left a) = (1, BB.word8 0) <> toEncoding a- toEncoding (Right b) = (1, BB.word8 1) <> toEncoding b+ toEncoding (Left a) = Encoding 1 (BB.word8 0) <> toEncoding a+ toEncoding (Right b) = Encoding 1 (BB.word8 1) <> toEncoding b deserialiser = Deserialiser $ Plan $ \case SVariant [(_, [sa]), (_, [sb])] -> do getA <- unwrapDeserialiser deserialiser sa@@ -693,24 +692,17 @@ extractConstructor = extractConstructorWith deserialiser {-# INLINE extractConstructor #-} -data RecordDecoder i x = Done x | forall a. More !i !(Maybe a) !(Plan (Decoder a)) (RecordDecoder i (Decoder a -> x))--deriving instance Functor (RecordDecoder i)--instance Applicative (RecordDecoder i) where- pure = Done- Done f <*> a = fmap f a- More i p d k <*> c = More i p d (flip <$> k <*> c)- -- | Generic implementation of 'schemaVia' for a record. gschemaViaRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> [TypeRep] -> Schema gschemaViaRecord p ts = SFix $ SRecord $ recordSchema (Proxy :: Proxy (Rep a)) (typeRep p : ts) -- | Generic implementation of 'toEncoding' for a record.-gtoEncodingRecord :: (GSerialiseRecord (Rep a), Generic a) => a -> Encoding+gtoEncodingRecord :: (GEncodeRecord (Rep a), Generic a) => a -> Encoding gtoEncodingRecord = encodeMulti . recordEncoder . from {-# INLINE gtoEncodingRecord #-} +data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (Decoder a))+ -- | Generic implementation of 'deserialiser' for a record. gdeserialiserRecord :: forall a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => Maybe a -- ^ default value (optional)@@ -718,18 +710,15 @@ gdeserialiserRecord def = Deserialiser $ handleRecursion $ \case SRecord schs -> Strategy $ \decs -> do let schs' = [(k, (i, s)) | (i, (k, s)) <- zip [0..] schs]- let go :: RecordDecoder T.Text x -> Either StrategyError ([Int] -> x)- go (Done a) = Right $ const a- go (More name def' p k) = case lookup name schs' of- Nothing -> case def' of- Just d -> go k >>= \r -> return $ \offsets -> r offsets (pure d)+ let go :: FieldDecoder T.Text x -> Compose (Either StrategyError) ((->) Offsets) (Decoder x)+ go (FieldDecoder name def' p) = case lookup name schs' of+ Nothing -> Compose $ case def' of+ Just d -> Right (pure (pure d)) Nothing -> Left $ rep <> ": Default value not found for " <> pretty name- Just (i, sch) -> do- getItem <- p `unPlan` sch `unStrategy` decs- r <- go k- return $ \offsets -> r offsets- $ decodeAt (unsafeIndex "Data.Winery.gdeserialiserRecord: impossible" offsets i) getItem- m <- go $ recordDecoder $ from <$> def+ Just (i, sch) -> Compose $ case p `unPlan` sch `unStrategy` decs of+ Right getItem -> Right $ \offsets -> decodeAt (unsafeIndexV "Data.Winery.gdeserialiserRecord: impossible" offsets i) getItem+ Left e -> Left e+ m <- getCompose $ unTransFusion (recordDecoder $ from <$> def) go return $ evalContT $ do offsets <- decodeOffsets (length schs) asks $ \bs -> to $ m offsets bs@@ -738,49 +727,65 @@ rep = "gdeserialiserRecord :: Deserialiser " <> viaShow (typeRep (Proxy :: Proxy a)) +class GEncodeRecord f where+ recordEncoder :: f x -> [Encoding]++instance (GEncodeRecord f, GEncodeRecord g) => GEncodeRecord (f :*: g) where+ recordEncoder (f :*: g) = recordEncoder f ++ recordEncoder g+ {-# INLINE recordEncoder #-}++instance Serialise a => GEncodeRecord (S1 c (K1 i a)) where+ recordEncoder (M1 (K1 a)) = pure $! toEncoding a+ {-# INLINE recordEncoder #-}++instance GEncodeRecord f => GEncodeRecord (C1 c f) where+ recordEncoder (M1 a) = recordEncoder a+ {-# INLINE recordEncoder #-}++instance GEncodeRecord f => GEncodeRecord (D1 c f) where+ recordEncoder (M1 a) = recordEncoder a+ {-# INLINE recordEncoder #-}+ class GSerialiseRecord f where recordSchema :: proxy f -> [TypeRep] -> [(T.Text, Schema)]- recordEncoder :: f x -> [Encoding]- recordDecoder :: Maybe (f x) -> RecordDecoder T.Text (Decoder (f x))+ recordDecoder :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) Decoder (Decoder (f x)) instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where recordSchema _ ts = recordSchema (Proxy :: Proxy f) ts ++ recordSchema (Proxy :: Proxy g) ts- recordEncoder (f :*: g) = recordEncoder f ++ recordEncoder g recordDecoder def = (\f g -> (:*:) <$> f <*> g) <$> recordDecoder ((\(x :*: _) -> x) <$> def) <*> recordDecoder ((\(_ :*: x) -> x) <$> def) instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where recordSchema _ ts = [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), substSchema (Proxy :: Proxy a) ts)]- recordEncoder (M1 (K1 a)) = [toEncoding a]- recordDecoder def = More (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x)) (unK1 . unM1 <$> def) (getDeserialiser deserialiser)- $ Done $ fmap $ M1 . K1+ recordDecoder def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder+ (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x))+ (unK1 . unM1 <$> def)+ (getDeserialiser deserialiser) instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where recordSchema _ = recordSchema (Proxy :: Proxy f)- recordEncoder (M1 a) = recordEncoder a recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def) instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where recordSchema _ = recordSchema (Proxy :: Proxy f)- recordEncoder (M1 a) = recordEncoder a recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def) class GSerialiseProduct f where productSchema :: proxy f -> [TypeRep] -> [Schema] productEncoder :: f x -> [Encoding]- productDecoder :: RecordDecoder () (Decoder (f x))+ productDecoder :: TransFusion (FieldDecoder ()) Decoder (Decoder (f x)) instance GSerialiseProduct U1 where productSchema _ _ = [] productEncoder _ = []- productDecoder = Done (pure U1)+ productDecoder = pure (pure U1) instance (Serialise a) => GSerialiseProduct (K1 i a) where productSchema _ ts = [substSchema (Proxy :: Proxy a) ts] productEncoder (K1 a) = [toEncoding a]- productDecoder = More () Nothing (getDeserialiser deserialiser) $ Done $ fmap K1+ productDecoder = TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder () Nothing (getDeserialiser deserialiser) instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where productSchema _ ts = productSchema (Proxy :: Proxy f) ts@@ -794,14 +799,14 @@ deserialiserProduct' :: GSerialiseProduct f => [Schema] -> Strategy (Decoder (f x)) deserialiserProduct' schs0 = Strategy $ \recs -> do- let go :: Int -> [Schema] -> RecordDecoder () x -> Either StrategyError ([Int] -> x)+ 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 () _ p k) = do+ 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 (unsafeIndex "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem- m <- go 0 schs0 productDecoder+ return $ \offsets -> r offsets $ decodeAt (unsafeIndexV "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem+ m <- go 0 schs0 $ runTransFusion productDecoder return $ evalContT $ do offsets <- decodeOffsets (length schs0) asks $ \bs -> m offsets bs@@ -820,14 +825,14 @@ => Deserialiser a gdeserialiserVariant = Deserialiser $ handleRecursion $ \case SVariant schs0 -> Strategy $ \decs -> do- ds' <- sequence+ ds' <- V.fromList <$> sequence [ case lookup name variantDecoder of Nothing -> Left $ rep <> ": Schema not found for " <> pretty name Just f -> f sch `unStrategy` decs | (name, sch) <- schs0] return $ evalContT $ do i <- decodeVarInt- lift $ fmap to $ unsafeIndex "Data.Winery.gdeserialiserVariant" ds' i+ lift $ fmap to $ ds' V.! i s -> unexpectedSchema' rep "a variant" s where rep = "gdeserialiserVariant :: Deserialiser "
src/Data/Winery/Internal.hs view
@@ -1,99 +1,168 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} module Data.Winery.Internal- ( Encoding+ ( Encoding(..) , encodeMulti , encodeVarInt , Decoder , decodeAt , decodeVarInt+ , Offsets , decodeOffsets , getWord8- , getBytes , word16be , word32be , word64be , unsafeIndex+ , unsafeIndexV , Strategy(..) , StrategyError , errorStrategy+ , TransList(..)+ , TransFusion(..)+ , runTransFusion )where import Control.Applicative import Control.Monad import Control.Monad.Fix+import Control.Monad.ST import Control.Monad.Trans.Cont-import Data.ByteString.Builder+import Data.ByteString.FastBuilder import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.FastBuilder as BB 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+import qualified Data.Vector.Unboxed.Mutable as UM import Data.Word -type Encoding = (Sum Int, Builder)+data Encoding = Encoding+ { encodingLength :: !Int, encodingBuilder :: !Builder } +instance Monoid Encoding where+ mempty = Encoding 0 mempty+ mappend (Encoding m a) (Encoding n b) = Encoding (m + n) (mappend a b)++rebuildEncoding :: Encoding -> Encoding+rebuildEncoding (Encoding l b) = Encoding l (BB.rebuild b)+ type Decoder = (->) B.ByteString -decodeAt :: Int -> Decoder a -> Decoder a-decodeAt i m bs = m $ B.drop i bs+decodeAt :: (Int, Int) -> Decoder a -> Decoder a+decodeAt (i, l) m bs = m $ B.take l $ B.drop i bs -encodeVarInt :: (Integral a, Bits a) => a -> Encoding+encodeVarInt :: (Bits a, Integral a) => a -> Encoding encodeVarInt n- | n < 0x80 = (1, BB.word8 $ fromIntegral n)- | otherwise = let (s, b) = encodeVarInt (shiftR n 7)- in (1 + s, BB.word8 (setBit (fromIntegral n) 7) `mappend` b)+ | n < 0 = case negate n of+ n'+ | n' < 0x40 -> e1 (fromIntegral n' `setBit` 6)+ | otherwise -> go (e1 (0xc0 .|. fromIntegral n')) (shiftR n' 6)+ | n < 0x40 = e1 (fromIntegral n)+ | otherwise = go (e1 (fromIntegral n `setBit` 7 `clearBit` 6)) (shiftR n 6)+ where+ e1 = Encoding 1 . BB.word8+ go !acc m+ | m < 0x80 = acc `mappend` e1 (fromIntegral m)+ | otherwise = go (acc <> e1 (setBit (fromIntegral m) 7)) (shiftR m 7)+{-# INLINE encodeVarInt #-} getWord8 :: ContT r Decoder Word8 getWord8 = ContT $ \k bs -> case B.uncons bs of Nothing -> k 0 bs- Just (x, bs') -> k x bs'--getBytes :: Decoder B.ByteString-getBytes = runContT decodeVarInt B.take+ Just (x, bs') -> k x $! bs'+{-# INLINE getWord8 #-} decodeVarInt :: (Num a, Bits a) => ContT r Decoder a decodeVarInt = getWord8 >>= \case n | testBit n 7 -> do- m <- decodeVarInt- return $! shiftL m 7 .|. clearBit (fromIntegral n) 7+ m <- getWord8 >>= go+ if testBit n 6+ then return $! negate $ shiftL m 6 .|. fromIntegral n .&. 0x3f+ else return $! shiftL m 6 .|. clearBit (fromIntegral n) 7+ | testBit n 6 -> return $ negate $ fromIntegral $ clearBit n 6 | otherwise -> return $ fromIntegral n+ where+ go n+ | testBit n 7 = do+ m <- getWord8 >>= go+ return $! shiftL m 7 .|. clearBit (fromIntegral n) 7+ | otherwise = return $ fromIntegral n+{-# INLINE decodeVarInt #-} word16be :: B.ByteString -> Word16-word16be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.- (fromIntegral (s `B.unsafeIndex` 1))+word16be = \s -> if B.length s >= 2+ then+ (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 1))+ else error "word16be" word32be :: B.ByteString -> Word32-word32be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 8) .|.- (fromIntegral (s `B.unsafeIndex` 3) )+word32be = \s -> if B.length s >= 4+ then+ (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 3) )+ else error "word32be" word64be :: B.ByteString -> Word64-word64be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 56) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 48) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 40) .|.- (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 32) .|.- (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL` 8) .|.- (fromIntegral (s `B.unsafeIndex` 7) )+word64be = \s -> if B.length s >= 8+ then+ (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 56) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 48) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 40) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 32) .|.+ (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 7) )+ else error $ "word64be" ++ show s encodeMulti :: [Encoding] -> Encoding-encodeMulti ls = foldMap encodeVarInt offsets <> foldMap id ls where- offsets = take (length ls - 1) $ map (getSum . fst) ls+encodeMulti xs = rebuildEncoding+ $ foldMap (encodeVarInt . encodingLength) (safeInit xs) <> mconcat xs+ where+ safeInit [] = []+ safeInit [_] = []+ safeInit (y:ys) = y : safeInit ys+{-# INLINE encodeMulti #-} -decodeOffsets :: Int -> ContT r Decoder [Int]-decodeOffsets 0 = pure []-decodeOffsets n = scanl (+) 0 <$> replicateM (n - 1) decodeVarInt+type Offsets = U.Vector (Int, Int) +decodeOffsets :: Int -> ContT r Decoder Offsets+decodeOffsets 0 = pure U.empty+decodeOffsets n = accum <$> U.replicateM (n - 1) decodeVarInt where+ accum xs = runST $ do+ r <- UM.unsafeNew (U.length xs + 1)+ let go s i+ | i == U.length xs = do+ UM.write r i (s, maxBound)+ U.unsafeFreeze r+ | otherwise = do+ let x = U.unsafeIndex xs i+ let s' = s + x+ UM.write r i (s, x)+ go s' (i + 1)+ go 0 0++unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a+unsafeIndexV err xs i+ | i >= U.length xs || i < 0 = error err+ | otherwise = U.unsafeIndex xs i+{-# INLINE unsafeIndexV #-}+ unsafeIndex :: String -> [a] -> Int -> a unsafeIndex err xs i = (xs ++ repeat (error err)) !! i @@ -124,3 +193,26 @@ errorStrategy :: Doc AnsiStyle -> Strategy a errorStrategy = Strategy . const . Left++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 #-}++instance Applicative (TransFusion f g) where+ 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/Term.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, LambdaCase #-}+{-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-} module Data.Winery.Term where import Control.Monad.Trans@@ -12,6 +12,7 @@ import Data.Winery import Data.Winery.Internal import Data.Word+import qualified Data.Vector.Unboxed as V -- | Common representation for any winery data. -- Handy for prettyprinting winery-serialised data.@@ -63,7 +64,7 @@ SProduct schs -> do decoders <- traverse (unwrapDeserialiser $ go points) schs return $ evalContT $ do- offsets <- decodeOffsets (length decoders)+ offsets <- V.toList <$> decodeOffsets (length decoders) asks $ \bs -> TProduct [decodeAt ofs dec bs | (dec, ofs) <- zip decoders offsets] SProductFixed schs -> do decoders <- traverse (\(VarInt n, sch) -> (,) n <$> unwrapDeserialiser (go points) sch) schs@@ -73,14 +74,14 @@ SRecord schs -> do decoders <- traverse (\(name, sch) -> (,) name <$> unwrapDeserialiser (go points) sch) schs return $ evalContT $ do- offsets <- decodeOffsets (length decoders)+ offsets <- V.toList <$> decodeOffsets (length decoders) asks $ \bs -> TRecord [(name, decodeAt ofs dec bs) | ((name, dec), ofs) <- zip decoders offsets] SVariant schs -> do decoders <- traverse (\(name, sch) -> (,) name <$> traverse (unwrapDeserialiser (go points)) sch) schs return $ evalContT $ do tag <- decodeVarInt let (name, decs) = unsafeIndex ("decodeTerm/SVariant") decoders tag- offsets <- decodeOffsets (length decs)+ offsets <- V.toList <$> decodeOffsets (length decs) asks $ \bs -> TVariant name [decodeAt ofs dec bs | (dec, ofs) <- zip decs offsets] SSelf i -> return $ unsafeIndex "decodeTerm/SSelf" points $ fromIntegral i SFix s' -> mfix $ \a -> go (a : points) `unwrapDeserialiser` s'
winery.cabal view
@@ -1,11 +1,11 @@--- 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: bfdedbe9822eecf89f3ba7e7ecbf8802c6078d4f65ce427c1f942dbc695ac72b+-- hash: cd7f7da4332784c7d2fa7dab5a2c1c418d2f8c00ede5bbb3c1b560a6323fb4a6 name: winery-version: 0+version: 0.1 synopsis: Sustainable serialisation library description: Please see the README on Github at <https://github.com/fumieval/winery#readme> category: Data@@ -18,6 +18,7 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10+ extra-source-files: ChangeLog.md README.md@@ -29,11 +30,12 @@ library hs-source-dirs: src- ghc-options: -Wall+ ghc-options: -Wall -O2 build-depends: base >=4.7 && <5 , bytestring , containers+ , fast-builder , hashable , mtl , prettyprinter@@ -52,14 +54,13 @@ executable winery main-is: Main.hs- other-modules:- Paths_winery hs-source-dirs: app build-depends: base >=4.7 && <5 , bytestring , containers+ , fast-builder , hashable , mtl , prettyprinter@@ -69,6 +70,8 @@ , unordered-containers , vector , winery+ other-modules:+ Paths_winery default-language: Haskell2010 test-suite spec@@ -80,10 +83,40 @@ base >=4.7 && <5 , bytestring , containers+ , fast-builder , hashable , mtl , prettyprinter , prettyprinter-ansi-terminal+ , text+ , transformers+ , unordered-containers+ , vector+ , winery+ other-modules:+ Paths_winery+ default-language: Haskell2010++benchmark bench-winery+ type: exitcode-stdio-1.0+ main-is: bench.hs+ hs-source-dirs:+ benchmarks+ ghc-options: -O2+ build-depends:+ base >=4.7 && <5+ , binary+ , bytestring+ , cassava+ , containers+ , deepseq+ , fast-builder+ , gauge+ , hashable+ , mtl+ , prettyprinter+ , prettyprinter-ansi-terminal+ , serialise , text , transformers , unordered-containers