winery 0.1.2 → 0.2
raw patch · 10 files changed
+228/−97 lines, 10 filesdep +aesondep +directory
Dependencies added: aeson, directory
Files
- ChangeLog.md +8/−4
- README.md +9/−6
- app/Main.hs +11/−3
- benchmarks/bench.hs +15/−2
- src/Data/Winery.hs +40/−29
- src/Data/Winery/Internal.hs +19/−33
- src/Data/Winery/Internal/Builder.hs +72/−0
- src/Data/Winery/Query.hs +5/−4
- src/Data/Winery/Term.hs +31/−2
- winery.cabal +18/−14
ChangeLog.md view
@@ -1,11 +1,15 @@-# 0.1.2+# 0.2 -* Added `Data.Winery.Query`-* The winery tool now supports a simple jq-like query language+* Renamed `extract*With` to `extract*By` for consistency+* Added `hPut`+* Improved the performance+* Added `-J` option to `winery` which exports a JSON+* Decoder now throws `DecodeException` rather than error calls # 0.1.1 -* Optimised the code+* Add `Data.Winery.Query`+* The command line tool supports a simple query language # 0.1
README.md view
@@ -149,12 +149,15 @@ (De)serialisation of the datatype above using generic instances: ```-serialise/winery mean 658.6 μs ( +- 45.04 μs )-serialise/binary mean 1.056 ms ( +- 58.95 μs )-serialise/serialise mean 258.8 μs ( +- 5.654 μs )-deserialise/winery mean 706.4 μs ( +- 52.41 μs )-deserialise/binary mean 1.393 ms ( +- 56.71 μs )-deserialise/serialise mean 765.8 μs ( +- 30.26 μs )+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 ) ``` Not bad, considering that binary and serialise don't encode field names.
app/Main.hs view
@@ -2,10 +2,11 @@ module Main where import Control.Monad+import qualified Data.Aeson as JSON import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL 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@@ -15,13 +16,14 @@ import System.Exit import System.IO import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Text.Megaparsec-import Text.Megaparsec.Char data Options = Options { streamInput :: Bool , separateSchema :: Maybe (Maybe FilePath) , printSchema :: Bool+ , outputJSON :: Bool } defaultOptions :: Options@@ -29,6 +31,7 @@ { streamInput = False , printSchema = False , separateSchema = Nothing+ , outputJSON = False } options :: [OptDescr (Options -> Options)]@@ -36,6 +39,7 @@ [ Option "s" ["stream"] (NoArg $ \o -> o { streamInput = True }) "stream input" , Option "S" ["separate-schema"] (OptArg (\s o -> o { separateSchema = Just s }) "PATH") "the schema is separated" , Option "" ["print-schema"] (NoArg $ \o -> o { printSchema = True }) "print the schema"+ , Option "J" ["JSON"] (NoArg $ \o -> o { outputJSON = True }) "print as JSON" ] getRight :: Either StrategyError a -> IO a@@ -49,7 +53,11 @@ 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))+ let p+ | outputJSON o = pretty . T.decodeUtf8 . BL.toStrict . JSON.encode+ | otherwise = pretty+ let getDec = getRight . getDecoderBy (Q.runQuery q (pure . p <$> decodeTerm))+ printer <- case separateSchema o of Just mpath -> do bs <- maybe (readLn >>= B.hGet h) B.readFile mpath
benchmarks/bench.hs view
@@ -13,6 +13,7 @@ import qualified Codec.Serialise as CBOR import qualified Data.Csv as CSV import Data.Winery.Term+import System.Directory data Gender = Male | Female deriving (Show, Generic) @@ -47,11 +48,23 @@ binary <- B.readFile "benchmarks/data.binary" cbor <- B.readFile "benchmarks/data.cbor" values :: [TestRec] <- return $ B.decode $ BL.fromStrict binary+ let aValue = head values+ temp <- getTemporaryDirectory defaultMain- [ bgroup "serialise"- [ bench "winery" $ nf serialise values+ [ bgroup "serialise/list"+ [ bench "winery" $ nf serialiseOnly values , bench "binary" $ nf (BL.toStrict . B.encode) values , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) values+ ]+ , bgroup "serialise/item"+ [ bench "winery" $ nf serialiseOnly aValue+ , bench "binary" $ nf (BL.toStrict . B.encode) aValue+ , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) aValue+ ]+ , bgroup "serialise/file"+ [ bench "winery" $ whnfIO $ writeFileSerialise (temp ++ "/data.winery") values+ , bench "binary" $ whnfIO $ B.encodeFile (temp ++ "/data.binary") values+ , bench "serialise" $ whnfIO $ CBOR.writeFileSerialise (temp ++ "/data.cbor") values ] , bgroup "deserialise" [ bench "winery" $ nf (fromRight undefined . deserialise :: B.ByteString -> [TestRec]) winery
src/Data/Winery.hs view
@@ -16,12 +16,14 @@ module Data.Winery ( Schema(..) , Serialise(..)+ , DecodeException(..) , schema -- * Standalone serialisation , serialise , deserialise , deserialiseBy , splitSchema+ , writeFileSerialise -- * Separate serialisation , Deserialiser(..) , Decoder@@ -33,12 +35,12 @@ , encodeMulti -- * Decoding combinators , Plan(..)- , extractArrayWith- , extractListWith+ , extractArrayBy+ , extractListBy , extractField- , extractFieldWith+ , extractFieldBy , extractConstructor- , extractConstructorWith+ , extractConstructorBy , extractScientific -- * Variable-length quantity , VarInt(..)@@ -63,6 +65,7 @@ )where import Control.Applicative+import Control.Exception import Control.Monad.Trans.Cont import Control.Monad.Reader import qualified Data.ByteString as B@@ -95,6 +98,7 @@ import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Typeable import GHC.Generics+import System.IO import Unsafe.Coerce data Schema = SSchema !Word8@@ -228,6 +232,13 @@ $ toEncoding (schema [a], a) {-# INLINE serialise #-} +-- | 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)+ $ toEncoding (schema [a], a)+{-# INLINE writeFileSerialise #-}+ splitSchema :: B.ByteString -> Either StrategyError (Schema, B.ByteString) splitSchema bs_ = case B.uncons bs_ of Just (ver, bs) -> do@@ -435,7 +446,7 @@ instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where schemaVia _ _ = SInteger- toEncoding = encodeVarInt . getVarInt+ toEncoding = BB.varInt . getVarInt {-# INLINE toEncoding #-} deserialiser = Deserialiser $ Plan $ \case SInteger -> pure $ evalContT decodeVarInt@@ -456,8 +467,8 @@ instance Serialise a => Serialise (Maybe a) where schemaVia _ ts = SVariant [("Nothing", []) , ("Just", [substSchema (Proxy :: Proxy a) ts])]- toEncoding Nothing = encodeVarInt (0 :: Word8)- toEncoding (Just a) = encodeVarInt (1 :: Word8) <> toEncoding a+ toEncoding Nothing = BB.varInt (0 :: Word8)+ toEncoding (Just a) = BB.varInt (1 :: Word8) <> toEncoding a deserialiser = Deserialiser $ Plan $ \case SVariant [_, (_, [sch])] -> do dec <- unwrapDeserialiser deserialiser sch@@ -481,10 +492,10 @@ Nothing -> SList (substSchema (Proxy :: Proxy a) ts) Just s -> SArray (VarInt s) (substSchema (Proxy :: Proxy a) ts) toEncoding xs = case constantSize (Proxy :: Proxy a) of- Nothing -> encodeVarInt (length xs)+ Nothing -> BB.varInt (length xs) <> encodeMulti (\r -> foldr (encodeItem . toEncoding) r xs)- Just _ -> encodeVarInt (length xs) <> foldMap toEncoding xs- deserialiser = extractListWith deserialiser+ Just _ -> BB.varInt (length xs) <> foldMap toEncoding xs+ deserialiser = extractListBy deserialiser instance Serialise a => Serialise (V.Vector a) where schemaVia _ = schemaVia (Proxy :: Proxy [a])@@ -501,8 +512,8 @@ toEncoding = toEncoding . UV.toList deserialiser = UV.fromList <$> deserialiser -extractArrayWith :: Deserialiser a -> Deserialiser (Int, Int -> a)-extractArrayWith (Deserialiser plan) = Deserialiser $ Plan $ \case+extractArrayBy :: Deserialiser a -> Deserialiser (Int, Int -> a)+extractArrayBy (Deserialiser plan) = Deserialiser $ Plan $ \case SArray (VarInt size) s -> do getItem <- unPlan plan s return $ evalContT $ do@@ -514,12 +525,12 @@ n <- decodeVarInt offsets <- decodeOffsets n asks $ \bs -> (n, \i -> decodeAt (offsets UV.! i) getItem bs)- s -> unexpectedSchema' "extractListWith ..." "[a]" s+ s -> unexpectedSchema' "extractListBy ..." "[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 #-}+extractListBy :: Deserialiser a -> Deserialiser [a]+extractListBy d = (\(n, f) -> map f [0..n-1]) <$> extractArrayBy d+{-# INLINE extractListBy #-} instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where schemaVia _ = schemaVia (Proxy :: Proxy [(k, v)])@@ -570,12 +581,12 @@ -- | Extract a field of a record. extractField :: Serialise a => T.Text -> Deserialiser a-extractField = extractFieldWith deserialiser+extractField = extractFieldBy deserialiser {-# INLINE extractField #-} -- | Extract a field using the supplied 'Deserialiser'.-extractFieldWith :: Typeable a => Deserialiser a -> T.Text -> Deserialiser a-extractFieldWith (Deserialiser g) name = Deserialiser $ handleRecursion $ \case+extractFieldBy :: Typeable a => Deserialiser a -> T.Text -> Deserialiser a+extractFieldBy (Deserialiser g) name = Deserialiser $ handleRecursion $ \case SRecord schs -> do let schs' = [(k, (i, s)) | (i, (k, s)) <- zip [0..] schs] case lookup name schs' of@@ -587,12 +598,12 @@ Nothing -> errorStrategy $ rep <> ": Schema not found in " <> pretty (map fst schs) s -> unexpectedSchema' rep "a record" s where- rep = "extractFieldWith ... " <> dquotes (pretty name)- msg = "Data.Winery.extractFieldWith ... " <> show name <> ": impossible"+ rep = "extractFieldBy ... " <> dquotes (pretty name)+ msg = "Data.Winery.extractFieldBy ... " <> show name <> ": impossible" handleRecursion :: Typeable a => (Schema -> Strategy (Decoder a)) -> Plan (Decoder a) handleRecursion k = Plan $ \sch -> Strategy $ \decs -> case sch of- SSelf i -> return $ fmap (`fromDyn` error "Invalid recursion")+ SSelf i -> return $ fmap (`fromDyn` throw InvalidTag) $ unsafeIndex "Data.Winery.handleRecursion: unbound fixpoint" decs (fromIntegral i) SFix s -> mfix $ \a -> unPlan (handleRecursion k) s `unStrategy` (fmap toDyn a : decs) s -> k s `unStrategy` decs@@ -705,8 +716,8 @@ -- | Tries to extract a specific constructor of a variant. Useful for -- implementing backward-compatible deserialisers.-extractConstructorWith :: Typeable a => Deserialiser a -> T.Text -> Deserialiser (Maybe a)-extractConstructorWith d name = Deserialiser $ handleRecursion $ \case+extractConstructorBy :: Typeable a => Deserialiser a -> T.Text -> Deserialiser (Maybe a)+extractConstructorBy d name = Deserialiser $ handleRecursion $ \case SVariant schs0 -> Strategy $ \decs -> do (j, dec) <- case [(i :: Int, ss) | (i, (k, ss)) <- zip [0..] schs0, name == k] of [(i, [s])] -> fmap ((,) i) $ unwrapDeserialiser d s `unStrategy` decs@@ -720,10 +731,10 @@ else pure Nothing s -> unexpectedSchema' rep "a variant" s where- rep = "extractConstructorWith ... " <> dquotes (pretty name)+ rep = "extractConstructorBy ... " <> dquotes (pretty name) extractConstructor :: (Serialise a) => T.Text -> Deserialiser (Maybe a)-extractConstructor = extractConstructorWith deserialiser+extractConstructor = extractConstructorBy deserialiser {-# INLINE extractConstructor #-} -- | Generic implementation of 'schemaVia' for a record.@@ -844,7 +855,7 @@ m <- go 0 schs0 $ runTransFusion productDecoder return $ evalContT $ do offsets <- decodeOffsets (length schs0)- asks $ \bs -> m offsets bs+ lift $ m offsets -- | Generic implementation of 'schemaVia' for an ADT. gschemaViaVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> [TypeRep] -> Schema@@ -867,7 +878,7 @@ | (name, sch) <- schs0] return $ evalContT $ do i <- decodeVarInt- lift $ fmap to $ ds' V.! i+ lift $ fmap to $ maybe (throw InvalidTag) id $ ds' V.!? i s -> unexpectedSchema' rep "a variant" s where rep = "gdeserialiserVariant :: Deserialiser "@@ -890,7 +901,7 @@ instance (GSerialiseProduct f, Constructor c) => GSerialiseVariant (C1 c f) where variantCount _ = 1 variantSchema _ ts = [(T.pack $ conName (M1 undefined :: M1 i c f x), productSchema (Proxy :: Proxy f) ts)]- variantEncoder i (M1 a) = encodeVarInt i <> encodeMulti (productEncoder a)+ variantEncoder i (M1 a) = BB.varInt i <> encodeMulti (productEncoder a) variantDecoder = [(T.pack $ conName (M1 undefined :: M1 i c f x) , fmap (fmap M1) . deserialiserProduct') ]
src/Data/Winery/Internal.hs view
@@ -12,13 +12,13 @@ , EncodingMulti , encodeMulti , encodeItem- , encodeVarInt , Decoder , decodeAt , decodeVarInt , Offsets , decodeOffsets , getWord8+ , DecodeException(..) , word16be , word32be , word64be@@ -33,12 +33,14 @@ )where import Control.Applicative+import Control.Exception import Control.Monad import Control.Monad.Fix import Control.Monad.ST import Control.Monad.Trans.Cont import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B import Data.Winery.Internal.Builder import Data.Bits import Data.Dynamic@@ -48,34 +50,25 @@ import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as UM import Data.Word+import Foreign.ForeignPtr+import Foreign.Storable+import System.Endian type Decoder = (->) B.ByteString decodeAt :: (Int, Int) -> Decoder a -> Decoder a decodeAt (i, l) m = m . B.take l . B.drop i -encodeVarInt :: (Bits a, Integral a) => a -> Encoding-encodeVarInt n- | n < 0 = case negate n of- n'- | n' < 0x40 -> word8 (fromIntegral n' `setBit` 6)- | otherwise -> encodesUVarInt (word8 (0xc0 .|. fromIntegral n')) (unsafeShiftR n' 6)- | n < 0x40 = word8 (fromIntegral n)- | otherwise = encodesUVarInt (word8 (fromIntegral n `setBit` 7 `clearBit` 6)) (unsafeShiftR n 6)-{-# SPECIALISE encodeVarInt :: Int -> Encoding #-}--encodesUVarInt :: (Bits a, Integral a) => Encoding -> a -> Encoding-encodesUVarInt !acc m- | m < 0x80 = acc `mappend` word8 (fromIntegral m)- | otherwise = encodesUVarInt (acc <> word8 (setBit (fromIntegral m) 7)) (unsafeShiftR m 7)-{-# SPECIALISE encodesUVarInt :: Encoding -> Int -> Encoding #-}- getWord8 :: ContT r Decoder Word8 getWord8 = ContT $ \k bs -> case B.uncons bs of Nothing -> k 0 bs Just (x, bs') -> k x $! bs' {-# INLINE getWord8 #-} +data DecodeException = InsufficientInput+ | InvalidTag deriving (Eq, Show)+instance Exception DecodeException+ decodeVarInt :: (Num a, Bits a) => ContT r Decoder a decodeVarInt = getWord8 >>= \case n | testBit n 7 -> do@@ -98,7 +91,7 @@ then (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 1))- else error "word16be"+ else throw InsufficientInput word32be :: B.ByteString -> Word32 word32be = \s -> if B.length s >= 4@@ -107,20 +100,13 @@ (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|. (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 3) )- else error "word32be"+ else throw InsufficientInput word64be :: B.ByteString -> Word64-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+word64be (B.PS fp ofs len)+ | len >= 8 = B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromBE64 <$> peekByteOff ptr ofs+ | otherwise = throw InsufficientInput data EncodingMulti = EncodingMulti0 | EncodingMulti !Encoding !Encoding@@ -134,7 +120,7 @@ encodeItem :: Encoding -> EncodingMulti -> EncodingMulti encodeItem e EncodingMulti0 = EncodingMulti mempty e encodeItem e (EncodingMulti a b) = EncodingMulti- (mappend (encodeVarInt (getSize e)) a) (mappend e b)+ (mappend (varInt (getSize e)) a) (mappend e b) {-# INLINE encodeItem #-} type Offsets = U.Vector (Int, Int)@@ -146,12 +132,12 @@ r <- UM.unsafeNew (U.length xs + 1) let go s i | i == U.length xs = do- UM.write r i (s, maxBound)+ UM.unsafeWrite 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)+ UM.unsafeWrite r i (s, x) go s' (i + 1) go 0 0
src/Data/Winery/Internal/Builder.hs view
@@ -1,25 +1,34 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}+{-# LANGUAGE RecordWildCards #-} module Data.Winery.Internal.Builder ( Encoding , getSize , toByteString+ , hPut , word8 , word16 , word32 , word64 , bytes+ , varInt ) where +import Data.Bits hiding (rotate) 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.IORef import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable+import GHC.IO.Buffer+import GHC.IO.Handle.Internals+import GHC.IO.Handle.Types+import qualified GHC.IO.BufferedIO as Buffered import System.IO.Unsafe import System.Endian @@ -96,3 +105,66 @@ bytes :: B.ByteString -> Encoding bytes bs = Encoding (B.length bs) $ LBytes bs {-# INLINE bytes #-}++varInt :: (Bits a, Integral a) => a -> Encoding+varInt n+ | n < 0 = case negate n of+ n'+ | n' < 0x40 -> word8 (fromIntegral n' `setBit` 6)+ | otherwise -> uvarInt 1 (LWord8 (0xc0 .|. fromIntegral n')) (unsafeShiftR n' 6)+ | n < 0x40 = word8 (fromIntegral n)+ | otherwise = uvarInt 1 (LWord8 (fromIntegral n `setBit` 7 `clearBit` 6)) (unsafeShiftR n 6)+{-# SPECIALISE varInt :: Int -> Encoding #-}++uvarInt :: (Bits a, Integral a) => Int -> Tree -> a -> Encoding+uvarInt siz acc m+ | m < 0x80 = Encoding (siz + 1) (acc `Bin` LWord8 (fromIntegral m))+ | otherwise = uvarInt (siz + 1) (acc `Bin` LWord8 (setBit (fromIntegral m) 7)) (unsafeShiftR m 7)++pokeBuffer :: (Buffered.BufferedIO dev, Storable a) => dev -> Buffer Word8 -> a -> IO (Buffer Word8)+pokeBuffer dev buf x+ | bufferAvailable buf >= sizeOf x = bufferAdd (sizeOf x) buf+ <$ withBuffer buf (\ptr -> pokeByteOff ptr (bufR buf) x)+ | otherwise = Buffered.flushWriteBuffer dev buf+ >>= \buf' -> bufferAdd (sizeOf x) buf'+ <$ 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+ $ \Handle__{..} -> do+ buf0 <- readIORef haByteBuffer++ let go (LWord8 w) !buf = pokeBuffer haDevice buf w+ go (LWord16 w) buf = pokeBuffer haDevice buf (toBE16 w)+ go (LWord32 w) buf = pokeBuffer haDevice buf (toBE32 w)+ go (LWord64 w) buf = pokeBuffer haDevice buf (toBE64 w)+ go t@(LBytes (B.PS fp ofs len)) !buf+ | bufferAvailable buf >= len = (bufferAdd len buf<$) $ withBuffer buf+ $ \ptr -> withForeignPtr fp+ $ \src -> B.memcpy (ptr `plusPtr` bufR buf) (src `plusPtr` ofs) len+ | bufSize buf >= len = Buffered.flushWriteBuffer haDevice buf+ >>= go t+ | otherwise = newByteBuffer len WriteBuffer >>= go t+ go (Bin c d) buf = rot c d buf++ rot (LWord8 w) t !buf = pokeBuffer haDevice buf w >>= go t+ rot (LWord16 w) t buf = pokeBuffer haDevice buf (toBE16 w) >>= go t+ rot (LWord32 w) t buf = pokeBuffer haDevice buf (toBE32 w) >>= go t+ rot (LWord64 w) t buf = pokeBuffer haDevice buf (toBE64 w) >>= go t+ rot t@(LBytes (B.PS fp ofs len)) t' buf+ | bufferAvailable buf >= len = do+ withBuffer buf+ $ \ptr -> withForeignPtr fp+ $ \src -> B.memcpy (ptr `plusPtr` bufR buf) (src `plusPtr` ofs) len+ go t' $ bufferAdd len buf+ | bufSize buf >= len = Buffered.flushWriteBuffer haDevice buf+ >>= rot t t'+ | otherwise = do+ _ <- Buffered.flushWriteBuffer haDevice buf+ newByteBuffer len WriteBuffer >>= rot t t'+ rot (Bin c d) t buf = rot c (Bin d t) buf++ buf' <- go t0 buf0+ writeIORef haByteBuffer buf'
src/Data/Winery/Query.hs view
@@ -36,16 +36,17 @@ invalid = Query . const . Deserialiser . Plan . const . errorStrategy list :: Query a a-list = Query $ \d -> concat <$> extractListWith d+list = Query $ \d -> concat <$> extractListBy d range :: Int -> Int -> Query a a-range i j = Query $ \d -> (\(n, f) -> concatMap f [mod i n..mod j n]) <$> extractArrayWith d+range i j = Query $ \d -> (\(n, f) -> concatMap f [mod i n..mod j n])+ <$> extractArrayBy d field :: Typeable a => T.Text -> Query a a-field name = Query $ \d -> extractFieldWith d name+field name = Query $ \d -> extractFieldBy d name con :: Typeable a => T.Text -> Query a a-con name = Query $ \d -> maybe [] id <$> extractConstructorWith d name+con name = Query $ \d -> maybe [] id <$> extractConstructorBy d name select :: Query a Bool -> Query a a select qp = Query $ \d -> Deserialiser $ Plan $ \sch -> do
src/Data/Winery/Term.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-} module Data.Winery.Term where +import Data.Aeson import Control.Monad.Trans.Cont import Control.Monad.Reader import qualified Data.ByteString as B@@ -12,6 +13,7 @@ import Data.Winery.Internal import Data.Word import qualified Data.Vector.Unboxed as V+import qualified Data.HashMap.Strict as HM -- | Common representation for any winery data. -- Handy for prettyprinting winery-serialised data.@@ -37,6 +39,33 @@ | TVariant !T.Text [Term] deriving Show +instance ToJSON Term where+ toJSON TUnit = toJSON ()+ toJSON (TBool b) = toJSON b+ toJSON (TChar c) = toJSON c+ toJSON (TWord8 w) = toJSON w+ toJSON (TWord16 w) = toJSON w+ toJSON (TWord32 w) = toJSON w+ toJSON (TWord64 w) = toJSON w+ toJSON (TInt8 w) = toJSON w+ toJSON (TInt16 w) = toJSON w+ toJSON (TInt32 w) = toJSON w+ toJSON (TInt64 w) = toJSON w+ toJSON (TInteger w) = toJSON w+ toJSON (TFloat x) = toJSON x+ toJSON (TDouble x) = toJSON x+ toJSON (TBytes bs) = toJSON (B.unpack bs)+ toJSON (TText t) = toJSON t+ toJSON (TList xs) = toJSON xs+ toJSON (TProduct xs) = toJSON xs+ toJSON (TRecord xs) = toJSON $ HM.fromList xs+ toJSON (TVariant "Just" [x]) = toJSON x+ toJSON (TVariant "Nothing" []) = Null+ toJSON (TVariant t []) = toJSON t+ toJSON (TVariant t [x]) = object ["tag" .= toJSON t, "contents" .= toJSON x]+ toJSON (TVariant t xs) = object ["tag" .= toJSON t, "contents" .= toJSON xs]++ -- | Deserialiser for a 'Term'. decodeTerm :: Deserialiser Term decodeTerm = go [] where@@ -58,8 +87,8 @@ SDouble -> p s TDouble SBytes -> p s TBytes Data.Winery.SText -> p s TText- SArray siz sch -> fmap TList <$> extractListWith (go points) `unwrapDeserialiser` SArray siz sch- SList sch -> fmap TList <$> extractListWith (go points) `unwrapDeserialiser` SList sch+ SArray siz sch -> fmap TList <$> extractListBy (go points) `unwrapDeserialiser` SArray siz sch+ SList sch -> fmap TList <$> extractListBy (go points) `unwrapDeserialiser` SList sch SProduct schs -> do decoders <- traverse (unwrapDeserialiser $ go points) schs return $ evalContT $ do
winery.cabal view
@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack ----- hash: f441dfe5896bdc24f2600a35982ae2f08288dc6b07958d380edeabb5e816dfbc+-- hash: ef83aa777baa5f4b7fcf4c9708a493c8fbd187e078f3eef8d6ea02d8e257fcd9 name: winery-version: 0.1.2+version: 0.2 synopsis: Sustainable serialisation library description: Please see the README on Github at <https://github.com/fumieval/winery#readme> category: Data@@ -13,12 +13,11 @@ bug-reports: https://github.com/fumieval/winery/issues author: Fumiaki Kinoshita maintainer: fumiexcel@gmail.com-copyright: Copyright (c) 2017 Fumiaki Kinoshita+copyright: Copyright (c) 2018 Fumiaki Kinoshita license: BSD3 license-file: LICENSE build-type: Simple cabal-version: >= 1.10- extra-source-files: ChangeLog.md README.md@@ -32,7 +31,8 @@ src ghc-options: -Wall -O2 build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5 , bytestring , containers , cpu@@ -50,19 +50,22 @@ Data.Winery Data.Winery.Term Data.Winery.Internal+ Data.Winery.Internal.Builder Data.Winery.Query Data.Winery.Query.Parser other-modules:- Data.Winery.Internal.Builder Paths_winery default-language: Haskell2010 executable winery main-is: Main.hs+ other-modules:+ Paths_winery hs-source-dirs: app build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5 , bytestring , containers , cpu@@ -77,8 +80,6 @@ , unordered-containers , vector , winery- other-modules:- Paths_winery default-language: Haskell2010 test-suite spec@@ -87,7 +88,8 @@ hs-source-dirs: test build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5 , bytestring , containers , cpu@@ -109,17 +111,21 @@ benchmark bench-winery type: exitcode-stdio-1.0 main-is: bench.hs+ other-modules:+ Paths_winery hs-source-dirs: benchmarks ghc-options: -O2 build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5 , binary , bytestring , cassava , containers , cpu , deepseq+ , directory , gauge , hashable , megaparsec@@ -133,6 +139,4 @@ , unordered-containers , vector , winery- other-modules:- Paths_winery default-language: Haskell2010