winery 0.3.1 → 1
raw patch · 14 files changed
+2220/−1634 lines, 14 filesdep +HUnitdep +cerealdep +fast-builderdep −cassavadep ~megaparsec
Dependencies added: HUnit, cereal, fast-builder, quickcheck-instances
Dependencies removed: cassava
Dependency ranges changed: megaparsec
Files
- ChangeLog.md +8/−0
- README.md +68/−89
- app/Main.hs +5/−6
- benchmarks/bench.hs +40/−19
- src/Data/Winery.hs +1207/−991
- src/Data/Winery/Base.hs +293/−0
- src/Data/Winery/Internal.hs +166/−92
- src/Data/Winery/Internal/Builder.hs +0/−187
- src/Data/Winery/Query.hs +37/−15
- src/Data/Winery/Query/Parser.hs +16/−1
- src/Data/Winery/Term.hs +0/−152
- src/Data/Winery/Test.hs +199/−0
- test/Spec.hs +138/−9
- winery.cabal +43/−73
ChangeLog.md view
@@ -1,3 +1,11 @@+# 1++* Changed the encoding more compact+* Decoders are now stateful+* Significantly improved the performance+* `decodeCurrent` is now a method of `Serialise`+* Added `STag`+ # 0.3 * Supported `UTCTime`
README.md view
@@ -1,118 +1,102 @@ # winery -winery is a serialisation library for Haskell.+winery is a serialisation library focusing on __performance__, __compactness__+and __compatibility__. The primary feature is that metadata (types, field names,+etc) are packed into one schema. -* __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+A number of formats, like JSON and CBOR, attach metadata for each value: +`[{"id": 0, "name": "Alice"}, {"id": 1, "name": "Bob"}]`++In contrast, winery stores them separately, eliminating redundancy while+guaranteeing well-typedness:++```+0402 0402 0269 6410 046e 616d 6514 [{ id :: Integer, name :: Text }]+0200 0541 6c69 6365 0103 426f 62 [(0, "Alice"), (1, "Bob")]+```++Unlike `binary` or `cereal` which doesn't preserve metadata at all, winery also+allows readers to decode values regardless of the current implementation.+ ## Interface The interface is simple; `serialise` encodes a value with its schema, and `deserialise` decodes a ByteString using the schema in it. ```haskell-class Serialise a+class Serialise a where+ schema :: Serialise a => proxy a -> Schema serialise :: Serialise a => a -> B.ByteString-deserialise :: Serialise a => B.ByteString -> Either String a+deserialise :: Serialise a => B.ByteString -> Either WineryException a ``` -It's also possible to serialise schemata and data separately.+It's also possible to serialise schemata and data separately. `serialiseSchema`+encodes a schema and its version number into a ByteString, and+`serialiseOnly` serialises a value without a schema. ```haskell--- Note that 'Schema' is an instance of 'Serialise'-schema :: Serialise a => proxy a -> Schema+serialiseSchema :: Schema -> B.ByteString serialiseOnly :: Serialise a => a -> B.ByteString ``` -`getDecoder` gives you a deserialiser.+In order to decode data generated this way, pass the result of `deserialiseSchema`+to `getDecoder`. Finally run `evalDecoder` to deserialise them. ```haskell-getDecoder :: Serialise a => Schema -> Either StrategyError (ByteString -> a)+deserialiseSchema :: B.ByteString -> Either WineryException Schema+getDecoder :: Serialise a => Schema -> Either WineryException (Decoder a)+evalDecoder :: Decoder a -> B.ByteString -> a ``` -For user-defined datatypes, you can either define instances+## Deriving an instance +The recommended way to create an instance of `Serialise` is to use `DerivingVia`.+ ```haskell-instance Serialise Foo where- schemaVia = gschemaViaRecord- toEncoding = gtoEncodingRecord- deserialiser = gdeserialiserRecord Nothing+ deriving Generic+ deriving Serialise via WineryRecord Foo ``` for single-constructor records, or just ```haskell-instance Serialise Foo+ deriving Generic+ deriving Serialise via WineryVariant Foo ``` 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.+## Backward compatibility -```haskell-toEncoding :: Serialise a => a -> Encoding-hPutEncoding :: Handle -> Encoding -> IO ()-getSize :: Encoding -> Int-```+If the representation is not the same as the current version (i.e. the schema+ is different), the data cannot be decoded directly. This is where extractors+come in. -## The schema+`Extractor` parses a schema and returns a function which gives a value back from+a `Term`. -The definition of `Schema` is as follows:+If having default values for missing fields is sufficient, you can pass a+default value to `gextractorRecord`: ```haskell-data Schema = SSchema !Word8- | SUnit- | SBool- | SChar- | SWord8- | SWord16- | SWord32- | SWord64- | SInt8- | SInt16- | SInt32- | SInt64- | SInteger- | SFloat- | SDouble- | SBytes- | SText- | SList !Schema- | SArray !(VarInt Int) !Schema -- fixed size- | SProduct [Schema]- | SProductFixed [(VarInt Int, Schema)] -- fixed size- | SRecord [(T.Text, Schema)]- | SVariant [(T.Text, [Schema])]- | SFix Schema -- ^ binds a fixpoint- | SSelf !Word8 -- ^ @SSelf n@ refers to the n-th innermost fixpoint- deriving (Show, Read, Eq, Generic)+ extractor = gextractorRecord $ Just $ Foo "" 42 0 ``` -The `Serialise` instance is derived by generics.--There are some special schemata:--* `SSchema n` is a schema of schema. The winery library stores the concrete schema of `Schema` for each version, so it can deserialise data even if the schema changes.-* `SFix` binds a fixpoint.-* `SSelf n` refers to the n-th innermost fixpoint bound by `SFix`. This allows it to provide schemata for inductive datatypes.--## Backward compatibility--If having default values for missing fields is sufficient, you can pass a-default value to `gdeserialiserRecord`:+You can also build an extractor using combinators such as `extractField`, `extractConstructor`, etc. ```haskell- deserialiser = gdeserialiserRecord $ Just $ Foo "" 42 0+buildExtractor+ $ ("None", \() -> Nothing)+ `extractConstructor` ("Some", Just)+ `extractConstructor` extractVoid+ :: Extractor (Maybe a) ``` -You can also build a custom deserialiser using the Alternative instance and combinators such as `extractField`, `extractConstructor`, etc.+`Extractor` is Alternative, meaning that multiple extractors (such as a default+generic implementation and fallback plans) can be combined into one. ## Pretty-printing @@ -151,9 +135,14 @@ * `.foo` Get a field named `foo` * `F | G` compose queries (left to right) -## Benchmark+## Performance +A useful library should also be fast. Benchmarking encoding/decoding of the+following datatype.+ ```haskell+data Gender = Male | Female+ data TestRec = TestRec { id_ :: !Int , first_name :: !Text@@ -163,25 +152,15 @@ , num :: !Int , latitude :: !Double , longitude :: !Double- } deriving (Show, Generic)+ } ``` -(De)serialisation of the datatype above using generic instances:--```-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 )--```+Here's the result: -Not bad, considering that binary and serialise don't encode field names.+| | encode 1 | encode 1000 | decode |+|-----------|----------|-------------|---------|+| winery | __0.28 μs__ | __0.26 ms__ | __0.81 ms__ |+| cereal | 0.82 μs | 0.78 ms | 0.90 ms |+| binary | 1.7 μs | 1.7 ms | 2.0 ms |+| serialise | 0.61 μs | 0.50 ms | 1.4 ms |+| aeson | 9.9 μs | 9.7 ms | 17 ms |
app/Main.hs view
@@ -9,7 +9,6 @@ import Data.Text.Prettyprint.Doc.Render.Terminal 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@@ -42,9 +41,9 @@ , Option "J" ["JSON"] (NoArg $ \o -> o { outputJSON = True }) "print as JSON" ] -getRight :: Either StrategyError a -> IO a+getRight :: Either WineryException a -> IO a getRight (Left err) = do- hPutDoc stderr (err <> hardline)+ hPutDoc stderr $ prettyWineryException err <> hardline exitFailure getRight (Right a) = return a @@ -56,7 +55,7 @@ let p | outputJSON o = pretty . T.decodeUtf8 . BL.toStrict . JSON.encode | otherwise = pretty- let getDec = getRight . getDecoderBy (Q.runQuery q (pure . p <$> decodeTerm))+ let getDec = getRight . getDecoderBy (Q.runQuery q (Extractor (pure (pure . p)))) printer <- case separateSchema o of Just mpath -> do@@ -64,12 +63,12 @@ sch <- getRight $ deserialise bs when (printSchema o) $ putDoc $ pretty sch <> hardline dec <- getDec sch- return $ mapM_ putTerm . dec+ return $ mapM_ putTerm . evalDecoder dec Nothing -> return $ \bs_ -> do (s, bs) <- getRight $ splitSchema bs_ dec <- getDec s when (printSchema o) $ putDoc $ pretty s <> hardline- mapM_ putTerm $ dec bs+ mapM_ putTerm $ evalDecoder dec bs case streamInput o of False -> B.hGetContents h >>= printer
benchmarks/bench.hs view
@@ -1,25 +1,31 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS -Wno-orphans #-} import Control.DeepSeq+import qualified Data.Aeson as J 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 qualified Data.Text.Encoding as TE+import qualified Data.Serialize as C import GHC.Generics (Generic) import Gauge.Main 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) -instance Serialise Gender+instance Serialise Gender where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant instance CBOR.Serialise Gender instance B.Binary Gender+instance C.Serialize Gender+instance J.FromJSON Gender+instance J.ToJSON Gender data TestRec = TestRec { id_ :: !Int@@ -32,43 +38,58 @@ , longitude :: !Double } deriving (Show, Generic) +instance Serialise TestRec where+ schemaGen = gschemaGenRecord+ toBuilder = gtoBuilderRecord+ extractor = gextractorRecord Nothing+ decodeCurrent = gdecodeCurrentRecord+ instance NFData TestRec where rnf TestRec{} = () -instance Serialise TestRec where- schemaVia = gschemaViaRecord- toEncoding = gtoEncodingRecord- deserialiser = gdeserialiserRecord Nothing- instance B.Binary TestRec+instance C.Serialize TestRec instance CBOR.Serialise TestRec+instance J.FromJSON TestRec+instance J.ToJSON TestRec +instance C.Serialize Text where+ put = C.put . TE.encodeUtf8+ get = TE.decodeUtf8 <$> C.get++main :: IO () main = do winery <- B.readFile "benchmarks/data.winery" binary <- B.readFile "benchmarks/data.binary" cbor <- B.readFile "benchmarks/data.cbor"+ cereal <- B.readFile "benchmarks/data.cereal"+ json <- B.readFile "benchmarks/data.json" values :: [TestRec] <- return $ B.decode $ BL.fromStrict binary let aValue = head values- temp <- getTemporaryDirectory- defaultMain+ let serialisedInts = serialiseOnly [floor (2**x) :: Int | x <- [0 :: Double, 0.5..62]]+ deepseq values $ defaultMain [ bgroup "serialise/list"- [ bench "winery" $ nf serialiseOnly values+ [ bench "winery" $ nf serialise values , bench "binary" $ nf (BL.toStrict . B.encode) values+ , bench "cereal" $ nf C.encode values , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) values+ , bench "aeson" $ nf (BL.toStrict . J.encode) values ] , bgroup "serialise/item" [ bench "winery" $ nf serialiseOnly aValue , bench "binary" $ nf (BL.toStrict . B.encode) aValue+ , bench "cereal" $ nf C.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+ , bench "aeson" $ nf (BL.toStrict . J.encode) aValue ] , bgroup "deserialise" [ bench "winery" $ nf (fromRight undefined . deserialise :: B.ByteString -> [TestRec]) winery , bench "binary" $ nf (B.decode . BL.fromStrict :: B.ByteString -> [TestRec]) binary+ , bench "cereal" $ nf (C.decode :: B.ByteString -> Either String [TestRec]) cereal , bench "serialise" $ nf (CBOR.deserialise . BL.fromStrict :: B.ByteString -> [TestRec]) cbor+ , bench "aeson" $ nf (J.decode . BL.fromStrict :: B.ByteString -> Maybe [TestRec]) json+ ]+ , bgroup "deserialise/Int"+ [ bench "winery" $ nf (evalDecoder decodeCurrent :: B.ByteString -> [Int]) serialisedInts ] ]
src/Data/Winery.hs view
@@ -1,991 +1,1207 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE StandaloneDeriving #-}-module Data.Winery- ( Schema(..)- , Serialise(..)- , DecodeException(..)- , schema- -- * Standalone serialisation- , toEncodingWithSchema- , serialise- , deserialise- , deserialiseBy- , splitSchema- , writeFileSerialise- -- * Separate serialisation- , Deserialiser(..)- , Decoder- , serialiseOnly- , getDecoder- , getDecoderBy- , decodeCurrent- -- * Encoding combinators- , Encoding- , encodeMulti- , BB.getSize- , BB.toByteString- , BB.hPutEncoding- -- * Decoding combinators- , Plan(..)- , extractArrayBy- , extractListBy- , extractField- , extractFieldBy- , extractConstructor- , extractConstructorBy- -- * Variable-length quantity- , VarInt(..)- -- * Internal- , unwrapDeserialiser- , Strategy- , StrategyError- , unexpectedSchema- , unexpectedSchema'- -- * Generics- , GSerialiseRecord- , gschemaViaRecord- , GEncodeRecord- , gtoEncodingRecord- , gdeserialiserRecord- , GSerialiseVariant- , gschemaViaVariant- , gtoEncodingVariant- , gdeserialiserVariant- -- * Preset schema- , bootstrapSchema- )where--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.ByteString.Lazy as BL-import qualified Data.Winery.Internal.Builder as BB-import Data.Bits-import Data.Dynamic-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Foldable-import Data.Proxy-import Data.Scientific (Scientific, scientific, coefficient, base10Exponent)-import Data.Hashable (Hashable)-import qualified Data.HashMap.Strict as HM-import Data.Int-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import Data.List (elemIndex)-import qualified Data.Map as M-import Data.Monoid-import Data.Word-import Data.Winery.Internal-import qualified Data.Sequence as Seq-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector as V-import qualified Data.Vector.Storable as SV-import qualified Data.Vector.Unboxed as UV-import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)-import Data.Text.Prettyprint.Doc.Render.Terminal-import Data.Time.Clock-import Data.Time.Clock.POSIX-import Data.Typeable-import GHC.Generics-import System.IO-import Unsafe.Coerce--data Schema = SFix Schema -- ^ binds a fixpoint- | SSelf !Word8 -- ^ @SSelf n@ refers to the n-th innermost fixpoint- | SList !Schema- | SArray !(VarInt Int) !Schema -- fixed size- | SProduct [Schema]- | SProductFixed [(VarInt Int, Schema)] -- fixed size- | SRecord [(T.Text, Schema)]- | SVariant [(T.Text, [Schema])]- | SSchema !Word8- | SUnit- | SBool- | SChar- | SWord8- | SWord16- | SWord32- | SWord64- | SInt8- | SInt16- | SInt32- | SInt64- | SInteger- | SFloat- | SDouble- | SBytes- | SText- | SUTCTime- deriving (Show, Read, Eq, Generic)--instance Pretty Schema where- pretty = \case- SSchema v -> "Schema " <> pretty v- SUnit -> "()"- SBool -> "Bool"- SChar -> "Char"- SWord8 -> "Word8"- SWord16 -> "Word16"- SWord32 -> "Word32"- SWord64 -> "Word64"- SInt8 -> "Int8"- SInt16 -> "Int16"- SInt32 -> "Int32"- SInt64 -> "Int64"- SInteger -> "Integer"- SFloat -> "Float"- SDouble -> "Double"- SBytes -> "ByteString"- SText -> "Text"- SUTCTime -> "UTCTime"- SList s -> "[" <> pretty s <> "]"- SArray _ s -> "[" <> pretty s <> "]"- SProduct ss -> tupled $ map pretty ss- SProductFixed ss -> tupled $ map (pretty . snd) ss- SRecord ss -> align $ encloseSep "{ " " }" ", " [pretty k <+> "::" <+> pretty v | (k, v) <- ss]- SVariant ss -> align $ encloseSep "( " " )" (flatAlt "| " " | ")- [ if null vs- then pretty k- else nest 2 $ sep $ pretty k : map pretty vs | (k, vs) <- ss]- SFix sch -> group $ nest 2 $ sep ["μ", pretty sch]- SSelf i -> "Self" <+> pretty i---- | 'Deserialiser' is a 'Plan' that creates a 'Decoder'.-newtype Deserialiser a = Deserialiser { getDeserialiser :: Plan (Decoder a) }- deriving Functor--instance Applicative Deserialiser where- 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--instance Applicative Plan where- pure = return- (<*>) = ap--instance Monad Plan where- return = Plan . const . pure- m >>= k = Plan $ \sch -> Strategy $ \decs -> case unStrategy (unPlan m sch) decs of- Right a -> unStrategy (unPlan (k a) sch) decs- Left e -> Left e--instance Alternative Plan where- empty = Plan $ const empty- Plan a <|> Plan b = Plan $ \s -> a s <|> b s--unwrapDeserialiser :: Deserialiser a -> Schema -> Strategy (Decoder a)-unwrapDeserialiser (Deserialiser m) = unPlan m-{-# INLINE unwrapDeserialiser #-}---- | Serialisable datatype-class Typeable a => Serialise a where- -- | Obtain the schema of the datatype. @[TypeRep]@ is for handling recursion.- schemaVia :: Proxy a -> [TypeRep] -> Schema-- -- | Serialise a value.- toEncoding :: a -> Encoding-- -- | The 'Deserialiser'- deserialiser :: Deserialiser a-- -- | If this is @'Just' x@, the size of `toEncoding` must be @x@.- -- `deserialiser` must not depend on this value.- constantSize :: Proxy a -> Maybe Int- constantSize _ = Nothing-- default schemaVia :: (Generic a, GSerialiseVariant (Rep a)) => Proxy a -> [TypeRep] -> Schema- schemaVia = gschemaViaVariant- default toEncoding :: (Generic a, GSerialiseVariant (Rep a)) => a -> Encoding- toEncoding = gtoEncodingVariant- default deserialiser :: (Generic a, GSerialiseVariant (Rep a)) => Deserialiser a- deserialiser = gdeserialiserVariant---- | Obtain the schema of the datatype.-schema :: forall proxy a. Serialise a => proxy a -> Schema-schema _ = schemaVia (Proxy :: Proxy a) []-{-# INLINE schema #-}---- | Obtain a decoder from a schema.-getDecoder :: Serialise a => Schema -> Either StrategyError (Decoder a)-getDecoder = getDecoderBy deserialiser-{-# INLINE getDecoder #-}---- | Get a decoder from a `Deserialiser` and a schema.-getDecoderBy :: Deserialiser a -> Schema -> Either StrategyError (Decoder a)-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 $ toEncodingWithSchema a-{-# INLINE serialise #-}---- | Serialise a value along with its schema.-writeFileSerialise :: Serialise a => FilePath -> a -> IO ()-writeFileSerialise path a = withFile path WriteMode- $ \h -> BB.hPutEncoding h $ toEncodingWithSchema a-{-# INLINE writeFileSerialise #-}--toEncodingWithSchema :: Serialise a => a -> Encoding-toEncodingWithSchema a = mappend (BB.word8 currentSchemaVersion)- $ toEncoding (schema [a], a)-{-# INLINE toEncodingWithSchema #-}--splitSchema :: B.ByteString -> Either StrategyError (Schema, B.ByteString)-splitSchema bs_ = case B.uncons bs_ of- Just (ver, bs) -> do- m <- getDecoder $ SSchema ver- return $ ($bs) $ evalContT $ do- sizA <- decodeVarInt- sch <- lift $ m . B.take sizA- 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-{-# INLINE serialiseOnly #-}--substSchema :: Serialise a => Proxy a -> [TypeRep] -> Schema-substSchema p ts- | Just i <- elemIndex (typeRep p) ts = SSelf $ fromIntegral i- | otherwise = schemaVia p ts--currentSchemaVersion :: Word8-currentSchemaVersion = 2--bootstrapSchema :: Word8 -> Either StrategyError Schema-bootstrapSchema 1 = Right $ SFix $ SVariant [("SSchema",[SWord8])- ,("SUnit",[])- ,("SBool",[])- ,("SChar",[])- ,("SWord8",[])- ,("SWord16",[])- ,("SWord32",[])- ,("SWord64",[])- ,("SInt8",[])- ,("SInt16",[])- ,("SInt32",[])- ,("SInt64",[])- ,("SInteger",[])- ,("SFloat",[])- ,("SDouble",[])- ,("SBytes",[])- ,("SText",[])- ,("SList",[SSelf 0])- ,("SArray",[SInteger, SSelf 0])- ,("SProduct",[SList (SSelf 0)])- ,("SProductFixed",[SList $ SProduct [SInteger, SSelf 0]])- ,("SRecord",[SList (SProduct [SText,SSelf 0])])- ,("SVariant",[SList (SProduct [SText,SList (SSelf 0)])])- ,("SFix",[SSelf 0])- ,("SSelf",[SWord8])- ]-bootstrapSchema 2 = Right $ SFix $ SVariant [- ("SFix",[SSelf 0])- ,("SSelf",[SWord8])- ,("SList",[SSelf 0])- ,("SArray",[SInteger,SSelf 0])- ,("SProduct",[SList (SSelf 0)])- ,("SProductFixed",[SList (SProduct [SInteger,SSelf 0])])- ,("SRecord",[SList (SProduct [SText,SSelf 0])])- ,("SVariant",[SList (SProduct [SText,SList (SSelf 0)])])- ,("SSchema",[SWord8])- ,("SUnit",[]),("SBool",[]),("SChar",[]),("SWord8",[]),("SWord16",[])- ,("SWord32",[]),("SWord64",[]),("SInt8",[]),("SInt16",[]),("SInt32",[])- ,("SInt64",[]),("SInteger",[]),("SFloat",[]),("SDouble",[]),("SBytes",[])- ,("SText",[]),("SUTCTime",[])]-bootstrapSchema n = Left $ "Unsupported version: " <> pretty n--unexpectedSchema :: forall a. Serialise a => Doc AnsiStyle -> Schema -> Strategy (Decoder a)-unexpectedSchema subject actual = unexpectedSchema' subject- (pretty $ schema (Proxy :: Proxy a)) actual--unexpectedSchema' :: Doc AnsiStyle -> Doc AnsiStyle -> Schema -> Strategy a-unexpectedSchema' subject expected actual = errorStrategy- $ annotate bold subject- <+> "expects" <+> annotate (color Green <> bold) expected- <+> "but got " <+> pretty actual--instance Serialise Schema where- schemaVia _ _ = SSchema currentSchemaVersion- toEncoding = gtoEncodingVariant- deserialiser = Deserialiser $ Plan $ \case- SSchema n -> Strategy (const $ bootstrapSchema n)- >>= unwrapDeserialiser gdeserialiserVariant- s -> unwrapDeserialiser gdeserialiserVariant s--instance Serialise () where- schemaVia _ _ = SUnit- toEncoding = mempty- deserialiser = pure ()- constantSize _ = Just 0--instance Serialise Bool where- schemaVia _ _ = SBool- toEncoding False = BB.word8 0- toEncoding True = BB.word8 1- deserialiser = Deserialiser $ Plan $ \case- SBool -> pure $ (/=0) <$> evalContT getWord8- s -> unexpectedSchema "Serialise Bool" s- constantSize _ = Just 1--instance Serialise Word8 where- schemaVia _ _ = SWord8- toEncoding = BB.word8- deserialiser = Deserialiser $ Plan $ \case- SWord8 -> pure $ evalContT getWord8- s -> unexpectedSchema "Serialise Word8" s- constantSize _ = Just 1--instance Serialise Word16 where- schemaVia _ _ = SWord16- toEncoding = BB.word16- deserialiser = Deserialiser $ Plan $ \case- SWord16 -> pure $ evalContT $ do- a <- getWord8- b <- getWord8- return $! fromIntegral a `unsafeShiftL` 8 .|. fromIntegral b- s -> unexpectedSchema "Serialise Word16" s- constantSize _ = Just 2--instance Serialise Word32 where- schemaVia _ _ = SWord32- toEncoding = BB.word32- deserialiser = Deserialiser $ Plan $ \case- SWord32 -> pure word32be- s -> unexpectedSchema "Serialise Word32" s- constantSize _ = Just 4--instance Serialise Word64 where- schemaVia _ _ = SWord64- toEncoding = BB.word64- deserialiser = Deserialiser $ Plan $ \case- SWord64 -> pure word64be- s -> unexpectedSchema "Serialise Word64" s- constantSize _ = Just 8--instance Serialise Word where- schemaVia _ _ = SWord64- toEncoding = BB.word64 . fromIntegral- deserialiser = Deserialiser $ Plan $ \case- SWord64 -> pure $ fromIntegral <$> word64be- s -> unexpectedSchema "Serialise Word" s- constantSize _ = Just 8--instance Serialise Int8 where- schemaVia _ _ = SInt8- toEncoding = BB.word8 . fromIntegral- deserialiser = Deserialiser $ Plan $ \case- SInt8 -> pure $ fromIntegral <$> evalContT getWord8- s -> unexpectedSchema "Serialise Int8" s- constantSize _ = Just 1--instance Serialise Int16 where- schemaVia _ _ = SInt16- toEncoding = BB.word16 . fromIntegral- deserialiser = Deserialiser $ Plan $ \case- SInt16 -> pure $ fromIntegral <$> word16be- s -> unexpectedSchema "Serialise Int16" s- constantSize _ = Just 2--instance Serialise Int32 where- schemaVia _ _ = SInt32- toEncoding = BB.word32 . fromIntegral- deserialiser = Deserialiser $ Plan $ \case- SInt32 -> pure $ fromIntegral <$> word32be- s -> unexpectedSchema "Serialise Int32" s- constantSize _ = Just 4--instance Serialise Int64 where- schemaVia _ _ = SInt64- toEncoding = BB.word64 . fromIntegral- deserialiser = Deserialiser $ Plan $ \case- SInt64 -> pure $ fromIntegral <$> word64be- s -> unexpectedSchema "Serialise Int64" s- constantSize _ = Just 8--instance Serialise Int where- schemaVia _ _ = SInteger- toEncoding = toEncoding . VarInt- deserialiser = Deserialiser $ Plan $ \case- SInteger -> pure $ getVarInt . evalContT decodeVarInt- s -> unexpectedSchema "Serialise Int" s--instance Serialise Float where- schemaVia _ _ = SFloat- toEncoding = BB.word32 . unsafeCoerce- deserialiser = Deserialiser $ Plan $ \case- SFloat -> pure $ unsafeCoerce <$> word32be- s -> unexpectedSchema "Serialise Float" s- constantSize _ = Just 4--instance Serialise Double where- schemaVia _ _ = SDouble- toEncoding = BB.word64 . unsafeCoerce- deserialiser = Deserialiser $ Plan $ \case- SDouble -> pure $ unsafeCoerce <$> word64be- s -> unexpectedSchema "Serialise Double" s- constantSize _ = Just 8--instance Serialise T.Text where- schemaVia _ _ = SText- toEncoding = toEncoding . T.encodeUtf8- deserialiser = Deserialiser $ Plan $ \case- 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, Bits a, Integral a) => Serialise (VarInt a) where- schemaVia _ _ = SInteger- toEncoding = BB.varInt . getVarInt- {-# INLINE toEncoding #-}- deserialiser = Deserialiser $ Plan $ \case- SInteger -> pure $ evalContT decodeVarInt- s -> unexpectedSchema "Serialise (VarInt a)" s--instance Serialise Integer where- schemaVia _ _ = SInteger- toEncoding = toEncoding . VarInt- deserialiser = getVarInt <$> deserialiser--instance Serialise Char where- schemaVia _ _ = SChar- toEncoding = toEncoding . fromEnum- deserialiser = Deserialiser $ Plan $ \case- SChar -> pure $ toEnum . evalContT decodeVarInt- s -> unexpectedSchema "Serialise Char" s--instance Serialise a => Serialise (Maybe a) where- schemaVia _ ts = SVariant [("Nothing", [])- , ("Just", [substSchema (Proxy :: Proxy a) ts])]- 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- return $ evalContT $ do- t <- decodeVarInt- case t :: Word8 of- 0 -> pure Nothing- _ -> Just <$> lift dec- s -> unexpectedSchema "Serialise (Maybe a)" s- constantSize _ = (1+) <$> constantSize (Proxy :: Proxy a)--instance Serialise B.ByteString where- schemaVia _ _ = SBytes- toEncoding = BB.bytes- deserialiser = Deserialiser $ Plan $ \case- SBytes -> pure id- s -> unexpectedSchema "Serialise ByteString" s--instance Serialise BL.ByteString where- schemaVia _ _ = SBytes- toEncoding = foldMap BB.bytes . BL.toChunks- deserialiser = Deserialiser $ Plan $ \case- SBytes -> pure BL.fromStrict- 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 UTCTime where- schemaVia _ _ = SUTCTime- toEncoding = toEncoding . utcTimeToPOSIXSeconds- deserialiser = Deserialiser $ Plan $ \case- SUTCTime -> unwrapDeserialiser- (posixSecondsToUTCTime <$> deserialiser)- (schema (Proxy :: Proxy Double))- s -> unexpectedSchema "Serialise UTCTime" s--instance Serialise NominalDiffTime where- schemaVia _ = schemaVia (Proxy :: Proxy Double)- toEncoding = toEncoding . (realToFrac :: NominalDiffTime -> Double)- deserialiser = (realToFrac :: Double -> NominalDiffTime) <$> deserialiser--instance Serialise a => Serialise [a] where- schemaVia _ ts = case constantSize (Proxy :: Proxy a) of- 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 -> BB.varInt (length xs)- <> encodeMulti (\r -> foldr (encodeItem . toEncoding) r xs)- Just _ -> BB.varInt (length xs) <> foldMap toEncoding xs- deserialiser = extractListBy deserialiser--instance Serialise a => Serialise (V.Vector a) where- schemaVia _ = schemaVia (Proxy :: Proxy [a])- toEncoding = toEncoding . V.toList- deserialiser = V.fromList <$> deserialiser--instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where- schemaVia _ = schemaVia (Proxy :: Proxy [a])- toEncoding = toEncoding . SV.toList- deserialiser = SV.fromList <$> deserialiser--instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where- schemaVia _ = schemaVia (Proxy :: Proxy [a])- toEncoding = toEncoding . UV.toList- deserialiser = UV.fromList <$> deserialiser--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- n <- decodeVarInt- 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 -> (n, \i -> decodeAt (offsets UV.! i) getItem bs)- s -> unexpectedSchema' "extractListBy ..." "[a]" s---- | Extract a list or an array of values.-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)])- toEncoding = toEncoding . M.toList- deserialiser = M.fromList <$> deserialiser--instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where- schemaVia _ = schemaVia (Proxy :: Proxy [(k, v)])- toEncoding = toEncoding . HM.toList- deserialiser = HM.fromList <$> deserialiser--instance (Serialise v) => Serialise (IM.IntMap v) where- schemaVia _ = schemaVia (Proxy :: Proxy [(Int, v)])- toEncoding = toEncoding . IM.toList- deserialiser = IM.fromList <$> deserialiser--instance (Ord a, Serialise a) => Serialise (S.Set a) where- schemaVia _ = schemaVia (Proxy :: Proxy [a])- toEncoding = toEncoding . S.toList- deserialiser = S.fromList <$> deserialiser--instance Serialise IS.IntSet where- schemaVia _ = schemaVia (Proxy :: Proxy [Int])- toEncoding = toEncoding . IS.toList- deserialiser = IS.fromList <$> deserialiser--instance Serialise a => Serialise (Seq.Seq a) where- schemaVia _ = schemaVia (Proxy :: Proxy [a])- toEncoding = toEncoding . toList- deserialiser = Seq.fromList <$> 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-extractField = extractFieldBy deserialiser-{-# INLINE extractField #-}---- | Extract a field using the supplied 'Deserialiser'.-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- Just (i, sch) -> do- m <- unPlan g sch- return $ evalContT $ do- offsets <- decodeOffsets (length schs)- 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- 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` 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--instance (Serialise a, Serialise b) => Serialise (a, b) where- schemaVia _ ts = case (constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b)) of- (Just a, Just b) -> SProductFixed [(VarInt a, sa), (VarInt b, sb)]- _ -> SProduct [sa, sb]- where- sa = substSchema (Proxy :: Proxy a) ts- sb = substSchema (Proxy :: Proxy b) ts- toEncoding (a, b) = case constantSize (Proxy :: Proxy (a, b)) of- Nothing -> encodeMulti (encodeItem (toEncoding a) . encodeItem (toEncoding b))- Just _ -> toEncoding a <> toEncoding b- deserialiser = Deserialiser $ Plan $ \case- SProduct [sa, sb] -> do- getA <- unwrapDeserialiser deserialiser sa- getB <- unwrapDeserialiser deserialiser sb- return $ evalContT $ do- offA <- decodeVarInt- 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 -> (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)--instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where- schemaVia _ ts = case (constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c)) of- (Just a, Just b, Just c) -> SProductFixed [(VarInt a, sa), (VarInt b, sb), (VarInt c, sc)]- _ -> SProduct [sa, sb, sc]- where- sa = substSchema (Proxy :: Proxy a) ts- sb = substSchema (Proxy :: Proxy b) ts- sc = substSchema (Proxy :: Proxy c) ts- toEncoding (a, b, c) = case constantSize (Proxy :: Proxy (a, b, c)) of- Nothing -> encodeMulti $ encodeItem (toEncoding a) . encodeItem (toEncoding b) . encodeItem (toEncoding c)- Just _ -> toEncoding a <> toEncoding b <> toEncoding c- deserialiser = Deserialiser $ Plan $ \case- SProduct [sa, sb, sc] -> do- getA <- unwrapDeserialiser deserialiser sa- getB <- unwrapDeserialiser deserialiser sb- getC <- unwrapDeserialiser deserialiser sc- return $ evalContT $ do- offA <- decodeVarInt- offB <- decodeVarInt- 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 -> (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)]--instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where- schemaVia _ ts = case (constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c), constantSize (Proxy :: Proxy d)) of- (Just a, Just b, Just c, Just d) -> SProductFixed [(VarInt a, sa), (VarInt b, sb), (VarInt c, sc), (VarInt d, sd)]- _ -> SProduct [sa, sb, sc, sd]- where- sa = substSchema (Proxy :: Proxy a) ts- sb = substSchema (Proxy :: Proxy b) ts- sc = substSchema (Proxy :: Proxy c) ts- sd = substSchema (Proxy :: Proxy d) ts- toEncoding (a, b, c, d) = case constantSize (Proxy :: Proxy (a, b, c)) of- Nothing -> encodeMulti $ encodeItem (toEncoding a) . encodeItem (toEncoding b) . encodeItem (toEncoding c) . encodeItem (toEncoding d)- Just _ -> toEncoding a <> toEncoding b <> toEncoding c <> toEncoding d- deserialiser = Deserialiser $ Plan $ \case- SProduct [sa, sb, sc, sd] -> do- getA <- unwrapDeserialiser deserialiser sa- getB <- unwrapDeserialiser deserialiser sb- getC <- unwrapDeserialiser deserialiser sc- getD <- unwrapDeserialiser deserialiser sd- return $ evalContT $ do- offA <- decodeVarInt- offB <- decodeVarInt- offC <- decodeVarInt- 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 -> (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)]--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) = BB.word8 0 <> toEncoding a- toEncoding (Right b) = BB.word8 1 <> toEncoding b- deserialiser = Deserialiser $ Plan $ \case- SVariant [(_, [sa]), (_, [sb])] -> do- getA <- unwrapDeserialiser deserialiser sa- getB <- unwrapDeserialiser deserialiser sb- return $ evalContT $ do- t <- decodeVarInt- case t :: Word8 of- 0 -> Left <$> lift getA- _ -> Right <$> lift getB- s -> unexpectedSchema "Either (a, b)" s- constantSize _ = fmap (1+) $ max- <$> constantSize (Proxy :: Proxy a)- <*> constantSize (Proxy :: Proxy b)---- | Tries to extract a specific constructor of a variant. Useful for--- implementing backward-compatible deserialisers.-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- [(i, ss)] -> fmap ((,) i) $ unwrapDeserialiser d (SProduct ss) `unStrategy` decs- _ -> Left $ rep <> ": Schema not found in " <> pretty (map fst schs0)-- return $ evalContT $ do- i <- decodeVarInt- if i == j- then Just <$> lift dec- else pure Nothing- s -> unexpectedSchema' rep "a variant" s- where- rep = "extractConstructorBy ... " <> dquotes (pretty name)--extractConstructor :: (Serialise a) => T.Text -> Deserialiser (Maybe a)-extractConstructor = extractConstructorBy deserialiser-{-# INLINE extractConstructor #-}---- | 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 :: (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)- -> Deserialiser a-gdeserialiserRecord def = Deserialiser $ handleRecursion $ \case- SRecord schs -> Strategy $ \decs -> do- let schs' = [(k, (i, s)) | (i, (k, s)) <- zip [0..] schs]- 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) -> 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- s -> unexpectedSchema' rep "a record" s- where- rep = "gdeserialiserRecord :: Deserialiser "- <> viaShow (typeRep (Proxy :: Proxy a))-{-# INLINE gdeserialiserRecord #-}--class GEncodeRecord f where- recordEncoder :: f x -> EncodingMulti -> EncodingMulti--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)) = encodeItem (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)]- 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- 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)]- 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)- recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def)--instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where- recordSchema _ = recordSchema (Proxy :: Proxy f)- recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def)--class GSerialiseProduct f where- productSchema :: proxy f -> [TypeRep] -> [Schema]- productEncoder :: f x -> EncodingMulti -> EncodingMulti- productDecoder :: Compose (State Int) (TransFusion (FieldDecoder Int) Decoder) (Decoder (f x))--instance GSerialiseProduct U1 where- productSchema _ _ = []- productEncoder _ = id- productDecoder = pure (pure U1)--instance (Serialise a) => GSerialiseProduct (K1 i a) where- productSchema _ ts = [substSchema (Proxy :: Proxy a) ts]- productEncoder (K1 a) = encodeItem (toEncoding a)- 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- productEncoder (M1 a) = productEncoder a- productDecoder = fmap M1 <$> productDecoder--instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where- productSchema _ ts = productSchema (Proxy :: Proxy f) ts ++ productSchema (Proxy :: Proxy g) ts- productEncoder (f :*: g) = productEncoder f . productEncoder g- productDecoder = liftA2 (:*:) <$> productDecoder <*> productDecoder--deserialiserProduct' :: GSerialiseProduct f => [Schema] -> Strategy (Decoder (f x))-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 schs)- 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-gschemaViaVariant p ts = SFix $ SVariant $ variantSchema (Proxy :: Proxy (Rep a)) (typeRep p : ts)---- | Generic implementation of 'toEncoding' for an ADT.-gtoEncodingVariant :: (GSerialiseVariant (Rep a), Generic a) => a -> Encoding-gtoEncodingVariant = variantEncoder 0 . from-{-# INLINE gtoEncodingVariant #-}---- | Generic implementation of 'deserialiser' for an ADT.-gdeserialiserVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a)- => Deserialiser a-gdeserialiserVariant = Deserialiser $ handleRecursion $ \case- SVariant schs0 -> Strategy $ \decs -> do- 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 $ maybe (throw InvalidTag) id $ ds' V.!? i- s -> unexpectedSchema' rep "a variant" s- where- rep = "gdeserialiserVariant :: Deserialiser "- <> viaShow (typeRep (Proxy :: Proxy a))--class GSerialiseVariant f where- variantCount :: proxy f -> Int- variantSchema :: proxy f -> [TypeRep] -> [(T.Text, [Schema])]- variantEncoder :: Int -> f x -> Encoding- variantDecoder :: [(T.Text, [Schema] -> Strategy (Decoder (f x)))]--instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where- variantCount _ = variantCount (Proxy :: Proxy f) + variantCount (Proxy :: Proxy g)- variantSchema _ ts = variantSchema (Proxy :: Proxy f) ts ++ variantSchema (Proxy :: Proxy g) ts- variantEncoder i (L1 f) = variantEncoder i f- variantEncoder i (R1 g) = variantEncoder (i + variantCount (Proxy :: Proxy f)) g- variantDecoder = fmap (fmap (fmap (fmap (fmap L1)))) variantDecoder- ++ fmap (fmap (fmap (fmap (fmap R1)))) variantDecoder--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) = BB.varInt i <> encodeMulti (productEncoder a)- variantDecoder = [(T.pack $ conName (M1 undefined :: M1 i c f x)- , fmap (fmap M1) . deserialiserProduct') ]--instance (GSerialiseVariant f) => GSerialiseVariant (S1 c f) where- variantCount _ = variantCount (Proxy :: Proxy f)- variantSchema _ ts = variantSchema (Proxy :: Proxy f) ts- variantEncoder i (M1 a) = variantEncoder i a- variantDecoder = fmap (fmap (fmap (fmap M1))) <$> variantDecoder--instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where- variantCount _ = variantCount (Proxy :: Proxy f)- variantSchema _ ts = variantSchema (Proxy :: Proxy f) ts- variantEncoder i (M1 a) = variantEncoder i a- variantDecoder = fmap (fmap (fmap (fmap M1))) <$> variantDecoder--instance Serialise Ordering-deriving instance Serialise a => Serialise (Identity a)-deriving instance (Serialise a, Typeable b) => Serialise (Const a (b :: *))+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Provisional+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- The standard interface of winery serialisation library+--+-----------------------------------------------------------------------------+module Data.Winery+ ( Schema+ , SchemaP(..)+ , Tag(..)+ , Serialise(..)+ , testSerialise+ , DecodeException(..)+ , schema+ -- * Standalone serialisation+ , toBuilderWithSchema+ , serialise+ , deserialise+ , deserialiseBy+ , deserialiseTerm+ , splitSchema+ , writeFileSerialise+ -- * Separate serialisation+ , serialiseSchema+ , deserialiseSchema+ , Extractor(..)+ , unwrapExtractor+ , Decoder+ , evalDecoder+ , serialiseOnly+ , getDecoder+ , getDecoderBy+ -- * Decoding combinators+ , Term(..)+ , Subextractor(..)+ , buildExtractor+ , extractListBy+ , extractField+ , extractFieldBy+ , extractConstructor+ , extractConstructorBy+ , extractVoid+ , ExtractException(..)+ -- * Variable-length quantity+ , VarInt(..)+ -- * Internal+ , WineryException(..)+ , prettyWineryException+ , unexpectedSchema+ , SchemaGen+ , getSchema+ , Plan(..)+ , mkPlan+ -- * DerivingVia+ , WineryRecord(..)+ , WineryVariant(..)+ , WineryProduct(..)+ -- * Generic implementations (for old GHC / custom instances)+ , GSerialiseRecord+ , gschemaGenRecord+ , GEncodeProduct+ , gtoBuilderRecord+ , gextractorRecord+ , gdecodeCurrentRecord+ , GSerialiseVariant+ , gschemaGenVariant+ , gtoBuilderVariant+ , gextractorVariant+ , gschemaGenProduct+ , gtoBuilderProduct+ , gdecodeCurrentVariant+ , gextractorProduct+ , gdecodeCurrentProduct+ -- * Preset schema+ , bootstrapSchema+ )where++import Control.Applicative+import Control.Exception+import Control.Monad.Reader+import qualified Data.ByteString as B+import qualified Data.ByteString.FastBuilder as BB+import qualified Data.ByteString.Lazy as BL+import Data.Bits+import Data.Complex+import Data.Dynamic+import Data.Fixed+import Data.Functor.Compose+import Data.Functor.Identity+import Data.List (elemIndex)+import Data.Monoid as M+import Data.Proxy+import Data.Ratio+import Data.Scientific (Scientific, scientific, coefficient, base10Exponent)+import Data.Semigroup as S+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HM+import Data.Int+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import Data.Ord+import Data.Word+import Data.Winery.Base as W+import Data.Winery.Internal+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Unboxed as UV+import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)+import Data.Text.Prettyprint.Doc.Render.Terminal+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Typeable+import Data.Void+import Unsafe.Coerce+import GHC.Float (castWord32ToFloat, castWord64ToDouble)+import GHC.Natural+import GHC.Generics+import GHC.TypeLits+import System.IO+import qualified Test.QuickCheck as QC++-- | Deserialiser for a 'Term'.+--+-- /"I will read anything rather than work."/+decodeTerm :: Schema -> Decoder Term+decodeTerm = go [] where+ go points = \case+ SBool -> TBool <$> decodeCurrent+ W.SChar -> TChar <$> decodeCurrent+ SWord8 -> TWord8 <$> getWord8+ SWord16 -> TWord16 <$> getWord16+ SWord32 -> TWord32 <$> getWord32+ SWord64 -> TWord64 <$> getWord64+ SInt8 -> TInt8 <$> decodeCurrent+ SInt16 -> TInt16 <$> decodeCurrent+ SInt32 -> TInt32 <$> decodeCurrent+ SInt64 -> TInt64 <$> decodeCurrent+ SInteger -> TInteger <$> decodeVarInt+ SFloat -> TFloat <$> decodeCurrent+ SDouble -> TDouble <$> decodeCurrent+ SBytes -> TBytes <$> decodeCurrent+ W.SText -> TText <$> decodeCurrent+ SUTCTime -> TUTCTime <$> decodeCurrent+ SVector sch -> do+ n <- decodeVarInt+ TVector <$> V.replicateM n (go points sch)+ SProduct schs -> TProduct <$> traverse (go points) schs+ SRecord schs -> TRecord <$> traverse (\(k, s) -> (,) k <$> go points s) schs+ SVariant schs -> do+ let !decoders = V.map (\(name, sch) -> let !m = go points sch in (name, m)) schs+ tag <- decodeVarInt+ let (name, dec) = maybe (throw InvalidTag) id $ decoders V.!? tag+ TVariant tag name <$> dec+ SVar i -> indexDefault (throw InvalidTag) points i+ SFix s' -> fix $ \a -> go (a : points) s'+ STag _ s -> go points s+ SLet s t -> go (go points s : points) t++-- | Deserialise a 'serialise'd 'B.Bytestring'.+deserialiseTerm :: B.ByteString -> Either WineryException (Schema, Term)+deserialiseTerm bs_ = do+ (sch, bs) <- splitSchema bs_+ return (sch, decodeTerm sch `evalDecoder` bs)++-- | This may be thrown if illegal 'Term' is passed to an extractor.+data ExtractException = InvalidTerm !Term deriving Show+instance Exception ExtractException++-- | Serialisable datatype+--+class Typeable a => Serialise a where+ -- | Obtain the schema of the datatype.+ schemaGen :: Proxy a -> SchemaGen Schema++ -- | Serialise a value.+ toBuilder :: a -> BB.Builder++ -- | A value of 'Extractor a' interprets a schema and builds a function from+ -- 'Term' to @a@. This must be equivalent to 'decodeCurrent' when the schema+ -- is the current one.+ --+ -- If @'extractor' s@ returns a function, the function must return a+ -- non-bottom for any 'Term' @'decodeTerm' s@ returns.+ --+ -- It must not return a function if an unsupported schema is supplied.+ --+ -- @getDecoderBy extractor (schema (Proxy @ a))@ must be @Right d@+ -- where @d@ is equivalent to 'decodeCurrent'.+ --+ extractor :: Extractor a++ -- | Decode a value with the current schema.+ --+ -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x+ decodeCurrent :: Decoder a++-- | Check the integrity of a Serialise instance.+--+-- /"No tears in the writer, no tears in the reader. No surprise in the writer, no surprise in the reader."/+testSerialise :: forall a. (Eq a, Show a, Serialise a) => a -> QC.Property+testSerialise x = case getDecoderBy extractor (schema (Proxy @ a)) of+ Left e -> QC.counterexample (show e) False+ Right f -> QC.counterexample "extractor" (evalDecoder f b QC.=== x)+ QC..&&. QC.counterexample "decodeCurrent" (evalDecoder decodeCurrent b QC.=== x)+ where+ b = serialiseOnly x++decodeCurrentDefault :: forall a. Serialise a => Decoder a+decodeCurrentDefault = case getDecoderBy extractor (schema (Proxy @ a)) of+ Left err -> error $ "decodeCurrentDefault: failed to get a decoder from the current schema"+ ++ show err+ Right a -> a++-- | Schema generator+newtype SchemaGen a = SchemaGen { unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) }++instance Functor SchemaGen where+ fmap f m = SchemaGen $ \s -> case unSchemaGen m s of+ (rep, k) -> (rep, f . k)++instance Applicative SchemaGen where+ pure a = SchemaGen $ const (S.empty, const a)+ m <*> n = SchemaGen $ \s -> case unSchemaGen m s of+ (rep, f) -> case unSchemaGen n s of+ (rep', g) -> (mappend rep rep', f <*> g)++-- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary.+-- If you are hand-rolling a definition of 'schemaGen', you should call this+-- instead of 'schemaGen'.+getSchema :: forall proxy a. Serialise a => proxy a -> SchemaGen Schema+getSchema p = SchemaGen $ \seen -> if S.member rep seen+ then (S.singleton rep, \xs -> case elemIndex rep xs of+ Just i -> SVar i+ Nothing -> error $ "getSchema: impossible " ++ show (rep, seen, xs))+ -- request a fixpoint for rep when it detects a recursion+ else case unSchemaGen (schemaGen (Proxy @ a)) (S.insert rep seen) of+ (reps, f)+ | S.member rep reps -> (reps, \xs -> SFix $ f (rep : xs))+ | otherwise -> (reps, f)+ where+ rep = typeRep p++-- | Obtain the schema of the datatype.+--+-- /"Tell me what you drink, and I will tell you what you are."/+schema :: forall proxy a. Serialise a => proxy a -> Schema+schema p = case unSchemaGen (schemaGen (Proxy @ a)) (S.singleton rep) of+ (reps, f)+ | S.member rep reps -> SFix $ f [rep]+ | otherwise -> f []+ where+ rep = typeRep p++-- | Obtain a decoder from a schema.+--+-- /"A reader lives a thousand lives before he dies... The man who never reads lives only one."/+getDecoder :: forall a. Serialise a => Schema -> Either WineryException (Decoder a)+getDecoder sch+ | sch == schema (Proxy @ a) = Right decodeCurrent+ | otherwise = getDecoderBy extractor sch+{-# INLINE getDecoder #-}++-- | Get a decoder from a `Extractor` and a schema.+getDecoderBy :: Extractor a -> Schema -> Either WineryException (Decoder a)+getDecoderBy (Extractor plan) sch = (\f -> f <$> decodeTerm sch)+ <$> unPlan plan sch `unStrategy` StrategyEnv 0 []+{-# INLINE getDecoderBy #-}++-- | Serialise a value along with its schema.+--+-- /"Write the vision, and make it plain upon tables, that he may run that readeth it."/+serialise :: Serialise a => a -> B.ByteString+serialise = BL.toStrict . BB.toLazyByteString . toBuilderWithSchema+{-# INLINE serialise #-}++-- | Serialise a value along with its schema.+writeFileSerialise :: Serialise a => FilePath -> a -> IO ()+writeFileSerialise path a = withBinaryFile path WriteMode+ $ \h -> BB.hPutBuilder h $ toBuilderWithSchema a+{-# INLINE writeFileSerialise #-}++toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder+toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion)+ $ toBuilder (schema (Proxy @ a), a)+{-# INLINE toBuilderWithSchema #-}++splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString)+splitSchema bs_ = case B.uncons bs_ of+ Just (ver, bs) -> do+ m <- getDecoder $ bootstrapSchema ver+ return $ flip evalDecoder bs $ do+ sch <- m+ State $ \bs' -> ((sch, bs'), mempty)+ Nothing -> Left EmptyInput++-- | Serialise a schema.+serialiseSchema :: Schema -> B.ByteString+serialiseSchema = BL.toStrict . BB.toLazyByteString+ . mappend (BB.word8 currentSchemaVersion) . toBuilder++-- | Deserialise a 'serialise'd 'B.Bytestring'.+--+-- /"Old wood to burn! Old wine to drink! Old friends to trust! Old authors to read!"/+deserialise :: Serialise a => B.ByteString -> Either WineryException a+deserialise bs_ = do+ (sch, bs) <- splitSchema bs_+ dec <- getDecoder sch+ return $ evalDecoder dec bs+{-# INLINE deserialise #-}++-- | Deserialise a 'serialise'd 'B.Bytestring' using an 'Extractor'.+deserialiseBy :: Extractor a -> B.ByteString -> Either WineryException a+deserialiseBy e bs_ = do+ (sch, bs) <- splitSchema bs_+ dec <- getDecoderBy e sch+ return $ evalDecoder dec bs++-- | Serialise a schema.+deserialiseSchema :: B.ByteString -> Either WineryException Schema+deserialiseSchema bs_ = case B.uncons bs_ of+ Just (ver, bs) -> do+ m <- getDecoder $ bootstrapSchema ver+ return $ evalDecoder m bs+ Nothing -> Left EmptyInput++-- | Serialise a value without its schema.+--+-- /"Any unsaved progress will be lost."/+serialiseOnly :: Serialise a => a -> B.ByteString+serialiseOnly = BL.toStrict . BB.toLazyByteString . toBuilder+{-# INLINE serialiseOnly #-}++unexpectedSchema :: forall f a. Serialise a => Doc AnsiStyle -> Schema -> Strategy' (f a)+unexpectedSchema subject actual = throwStrategy+ $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual++instance Serialise Tag where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++instance Serialise Schema where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++instance Serialise () where+ schemaGen _ = pure $ SProduct []+ toBuilder = mempty+ {-# INLINE toBuilder #-}+ extractor = pure ()+ decodeCurrent = pure ()++instance Serialise Bool where+ schemaGen _ = pure SBool+ toBuilder False = BB.word8 0+ toBuilder True = BB.word8 1+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SBool -> pure $ \case+ TBool b -> b+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Bool" s+ decodeCurrent = (/=0) <$> getWord8++instance Serialise Word8 where+ schemaGen _ = pure SWord8+ toBuilder = BB.word8+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SWord8 -> pure $ \case+ TWord8 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Word8" s+ decodeCurrent = getWord8++instance Serialise Word16 where+ schemaGen _ = pure SWord16+ toBuilder = BB.word16LE+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SWord16 -> pure $ \case+ TWord16 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Word16" s+ decodeCurrent = getWord16++instance Serialise Word32 where+ schemaGen _ = pure SWord32+ toBuilder = BB.word32LE+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SWord32 -> pure $ \case+ TWord32 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Word32" s+ decodeCurrent = getWord32++instance Serialise Word64 where+ schemaGen _ = pure SWord64+ toBuilder = BB.word64LE+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SWord64 -> pure $ \case+ TWord64 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Word64" s+ decodeCurrent = getWord64++instance Serialise Word where+ schemaGen _ = pure SWord64+ toBuilder = BB.word64LE . fromIntegral+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SWord64 -> pure $ \case+ TWord64 i -> fromIntegral i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Word" s+ decodeCurrent = fromIntegral <$> getWord64++instance Serialise Int8 where+ schemaGen _ = pure SInt8+ toBuilder = BB.word8 . fromIntegral+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInt8 -> pure $ \case+ TInt8 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Int8" s+ decodeCurrent = fromIntegral <$> getWord8++instance Serialise Int16 where+ schemaGen _ = pure SInt16+ toBuilder = BB.word16LE . fromIntegral+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInt16 -> pure $ \case+ TInt16 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Int16" s+ decodeCurrent = fromIntegral <$> getWord16++instance Serialise Int32 where+ schemaGen _ = pure SInt32+ toBuilder = BB.word32LE . fromIntegral+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInt32 -> pure $ \case+ TInt32 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Int32" s+ decodeCurrent = fromIntegral <$> getWord32++instance Serialise Int64 where+ schemaGen _ = pure SInt64+ toBuilder = BB.word64LE . fromIntegral+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInt64 -> pure $ \case+ TInt64 i -> i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Int64" s+ decodeCurrent = fromIntegral <$> getWord64++instance Serialise Int where+ schemaGen _ = pure SInteger+ toBuilder = toBuilder . VarInt+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInteger -> pure $ \case+ TInteger i -> fromIntegral i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Int" s+ decodeCurrent = decodeVarIntFinite++instance Serialise Float where+ schemaGen _ = pure SFloat+ toBuilder = BB.floatLE+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SFloat -> pure $ \case+ TFloat x -> x+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Float" s+ decodeCurrent = castWord32ToFloat <$> getWord32++instance Serialise Double where+ schemaGen _ = pure SDouble+ toBuilder = BB.doubleLE+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SDouble -> pure $ \case+ TDouble x -> x+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Double" s+ decodeCurrent = castWord64ToDouble <$> getWord64++instance Serialise T.Text where+ schemaGen _ = pure SText+ toBuilder = toBuilder . T.encodeUtf8+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SText -> pure $ \case+ TText t -> t+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Text" s+ decodeCurrent = do+ len <- decodeVarInt+ T.decodeUtf8With T.lenientDecode <$> State (B.splitAt len)++-- | 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, Bits a, Integral a) => Serialise (VarInt a) where+ schemaGen _ = pure SInteger+ toBuilder = varInt . getVarInt+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SInteger -> pure $ \case+ TInteger i -> fromIntegral i+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise (VarInt a)" s+ decodeCurrent = VarInt <$> decodeVarInt++instance Serialise Integer where+ schemaGen _ = pure SInteger+ toBuilder = toBuilder . VarInt+ {-# INLINE toBuilder #-}+ extractor = getVarInt <$> extractor+ decodeCurrent = getVarInt <$> decodeCurrent++instance Serialise Natural where+ schemaGen _ = pure SInteger+ toBuilder = toBuilder . toInteger+ extractor = naturalFromInteger <$> extractor+ decodeCurrent = naturalFromInteger <$> decodeCurrent++instance Serialise Char where+ schemaGen _ = pure SChar+ toBuilder = toBuilder . fromEnum+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SChar -> pure $ \case+ TChar c -> c+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise Char" s+ decodeCurrent = toEnum <$> decodeVarInt++instance Serialise a => Serialise (Maybe a) where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++instance Serialise B.ByteString where+ schemaGen _ = pure SBytes+ toBuilder bs = varInt (B.length bs) <> BB.byteString bs+ {-# INLINE toBuilder #-}+ extractor = Extractor $ mkPlan $ \case+ SBytes -> pure $ \case+ TBytes bs -> bs+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise ByteString" s+ decodeCurrent = do+ len <- decodeVarInt+ State (B.splitAt len)++instance Serialise BL.ByteString where+ schemaGen _ = pure SBytes+ toBuilder = toBuilder . BL.toStrict+ {-# INLINE toBuilder #-}+ extractor = BL.fromStrict <$> extractor+ decodeCurrent = BL.fromStrict <$> decodeCurrent++-- | time-1.9.1+nanosecondsToNominalDiffTime :: Int64 -> NominalDiffTime+nanosecondsToNominalDiffTime = unsafeCoerce . MkFixed . (*1000) . fromIntegral++instance Serialise UTCTime where+ schemaGen _ = pure SUTCTime+ toBuilder = toBuilder . utcTimeToPOSIXSeconds+ {-# INLINE toBuilder #-}+ extractor = Extractor $ Plan $ \case+ SUTCTime -> pure $ \case+ TUTCTime bs -> bs+ t -> throw $ InvalidTerm t+ s -> unexpectedSchema "Serialise UTCTime" s+ decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent++instance Serialise NominalDiffTime where+ schemaGen _ = pure SInt64+ toBuilder x = case unsafeCoerce x of+ MkFixed p -> toBuilder (fromIntegral (p `div` 1000) :: Int64)+ {-# INLINE toBuilder #-}+ extractor = nanosecondsToNominalDiffTime <$> extractor+ decodeCurrent = nanosecondsToNominalDiffTime <$> decodeCurrent++instance Serialise a => Serialise [a] where+ schemaGen _ = SVector <$> getSchema (Proxy @ a)+ toBuilder xs = varInt (length xs)+ <> foldMap toBuilder xs+ {-# INLINE toBuilder #-}+ extractor = V.toList <$> extractListBy extractor+ decodeCurrent = do+ n <- decodeVarInt+ replicateM n decodeCurrent++instance Serialise a => Serialise (V.Vector a) where+ schemaGen _ = SVector <$> getSchema (Proxy @ a)+ toBuilder xs = varInt (V.length xs)+ <> foldMap toBuilder xs+ {-# INLINE toBuilder #-}+ extractor = extractListBy extractor+ decodeCurrent = do+ n <- decodeVarInt+ V.replicateM n decodeCurrent++instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where+ schemaGen _ = SVector <$> getSchema (Proxy @ a)+ toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a)+ {-# INLINE toBuilder #-}+ extractor = SV.convert <$> extractListBy extractor+ decodeCurrent = do+ n <- decodeVarInt+ SV.replicateM n decodeCurrent++instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where+ schemaGen _ = SVector <$> getSchema (Proxy @ a)+ toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a)+ {-# INLINE toBuilder #-}+ extractor = UV.convert <$> extractListBy extractor+ decodeCurrent = do+ n <- decodeVarInt+ UV.replicateM n decodeCurrent++-- | Extract a list or an array of values.+extractListBy :: Typeable a => Extractor a -> Extractor (V.Vector a)+extractListBy (Extractor plan) = Extractor $ mkPlan $ \case+ SVector s -> do+ getItem <- unPlan plan s+ return $ \case+ TVector xs -> V.map getItem xs+ t -> throw $ InvalidTerm t+ s -> throwStrategy $ UnexpectedSchema "extractListBy ..." "[a]" s+{-# INLINE extractListBy #-}++instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where+ schemaGen _ = schemaGen (Proxy @ [(k, v)])+ toBuilder m = toBuilder (M.size m)+ <> M.foldMapWithKey (curry toBuilder) m+ {-# INLINE toBuilder #-}+ extractor = M.fromList <$> extractor+ decodeCurrent = M.fromList <$> decodeCurrent++instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where+ schemaGen _ = schemaGen (Proxy @ [(k, v)])+ toBuilder m = toBuilder (HM.size m)+ <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m+ {-# INLINE toBuilder #-}+ extractor = HM.fromList <$> extractor+ decodeCurrent = HM.fromList <$> decodeCurrent++instance (Serialise v) => Serialise (IM.IntMap v) where+ schemaGen _ = schemaGen (Proxy @ [(Int, v)])+ toBuilder m = toBuilder (IM.size m)+ <> IM.foldMapWithKey (curry toBuilder) m+ {-# INLINE toBuilder #-}+ extractor = IM.fromList <$> extractor+ decodeCurrent = IM.fromList <$> decodeCurrent++instance (Ord a, Serialise a) => Serialise (S.Set a) where+ schemaGen _ = schemaGen (Proxy @ [a])+ toBuilder s = toBuilder (S.size s) <> foldMap toBuilder s+ {-# INLINE toBuilder #-}+ extractor = S.fromList <$> extractor+ decodeCurrent = S.fromList <$> decodeCurrent++instance Serialise IS.IntSet where+ schemaGen _ = schemaGen (Proxy @ [Int])+ toBuilder s = toBuilder (IS.size s) <> IS.foldr (mappend . toBuilder) mempty s+ {-# INLINE toBuilder #-}+ extractor = IS.fromList <$> extractor+ decodeCurrent = IS.fromList <$> decodeCurrent++instance Serialise a => Serialise (Seq.Seq a) where+ schemaGen _ = schemaGen (Proxy @ [a])+ toBuilder s = toBuilder (length s) <> foldMap toBuilder s+ {-# INLINE toBuilder #-}+ extractor = Seq.fromList <$> extractor+ decodeCurrent = Seq.fromList <$> decodeCurrent++instance (Integral a, Serialise a) => Serialise (Ratio a) where+ schemaGen _ = schemaGen (Proxy @ (a, a))+ toBuilder x = toBuilder (numerator x, denominator x)+ {-# INLINE toBuilder #-}+ extractor = uncurry (%) <$> extractor+ decodeCurrent = uncurry (%) <$> decodeCurrent++instance Serialise Scientific where+ schemaGen _ = schemaGen (Proxy @ (Integer, Int))+ toBuilder s = toBuilder (coefficient s, base10Exponent s)+ {-# INLINE toBuilder #-}+ extractor = Extractor $ 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 = unwrapExtractor (c <$> extractor)+ decodeCurrent = decodeCurrentDefault++buildExtractor :: Typeable a => Subextractor a -> Extractor a+buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e+{-# INLINE buildExtractor #-}++newtype Subextractor a = Subextractor { unSubextractor :: Extractor a }+ deriving (Functor, Applicative, Alternative)++-- | Extract a field of a record.+extractField :: Serialise a => T.Text -> Subextractor a+extractField = extractFieldBy extractor+{-# INLINE extractField #-}++-- | Extract a field using the supplied 'Extractor'.+extractFieldBy :: Extractor a -> T.Text -> Subextractor a+extractFieldBy (Extractor g) name = Subextractor $ Extractor $ Plan $ \case+ SRecord schs -> case lookupWithIndexV name schs of+ Just (i, sch) -> do+ m <- unPlan g sch+ return $ \case+ TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i+ t -> throw $ InvalidTerm t+ _ -> throwStrategy $ FieldNotFound rep name (map fst $ V.toList schs)+ s -> throwStrategy $ UnexpectedSchema rep "a record" s+ where+ rep = "extractFieldBy ... " <> dquotes (pretty name)+ msg = "Data.Winery.extractFieldBy ... " <> show name <> ": impossible"++-- | Construct a plan, expanding fixpoints and let bindings.+mkPlan :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Plan (Term -> a)+mkPlan k = Plan $ \sch -> Strategy $ \(StrategyEnv ofs decs) -> case sch of+ SVar i+ | point : _ <- drop i decs -> case point of+ BoundSchema ofs' sch' -> unPlan (mkPlan k) sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs)+ DynDecoder dyn -> case fromDynamic dyn of+ Nothing -> Left $ TypeMismatch i+ (typeRep (Proxy @ (Term -> a)))+ (dynTypeRep dyn)+ Just a -> Right a+ | otherwise -> Left $ UnboundVariable i+ SFix s -> mfix $ \a -> unPlan (mkPlan k) s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs)+ SLet s t -> unPlan (mkPlan k) t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs)+ s -> k s `unStrategy` StrategyEnv ofs decs++instance (Serialise a, Serialise b) => Serialise (a, b) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e) => Serialise (a, b, c, d, e) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e, Serialise f) => Serialise (a, b, c, d, e, f) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance (Serialise a, Serialise b) => Serialise (Either a b) where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++-- | Tries to extract a specific constructor of a variant. Useful for+-- implementing backward-compatible extractors.+extractConstructorBy :: Typeable a => (Extractor a, T.Text, a -> r) -> Subextractor r -> Subextractor r+extractConstructorBy (d, name, f) cont = Subextractor $ Extractor $ Plan $ \case+ SVariant schs0 -> Strategy $ \decs -> do+ let run :: Extractor x -> Schema -> Either WineryException (Term -> x)+ run e s = unwrapExtractor e s `unStrategy` decs+ case lookupWithIndexV name schs0 of+ Just (i, s) -> do+ (j, dec) <- fmap ((,) i) $ run d $ case s of+ SProduct [s'] -> s'+ s' -> s'+ let rest = SVariant $ V.filter ((/=name) . fst) schs0+ k <- run (unSubextractor cont) rest+ return $ \case+ TVariant tag _ v+ | tag == j -> f $ dec v+ t -> k t+ _ -> run (unSubextractor cont) (SVariant schs0)+ s -> throwStrategy $ UnexpectedSchema rep "a variant" s+ where+ rep = "extractConstructorBy ... " <> dquotes (pretty name)++-- | Tries to match on a constructor. If it doesn't match (or constructor+-- doesn't exist at all), leave it to the successor.+--+-- @extractor = ("Just", Just) `extractConstructor` ("Nothing", \() -> Nothing) `extractConstructor` extractVoid@+extractConstructor :: (Serialise a) => (T.Text, a -> r) -> Subextractor r -> Subextractor r+extractConstructor (name, f) = extractConstructorBy (extractor, name, f)+{-# INLINE extractConstructor #-}++extractVoid :: Typeable r => Subextractor r+extractVoid = Subextractor $ Extractor $ mkPlan $ \case+ SVariant schs0+ | V.null schs0 -> return $ throw . InvalidTerm+ s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s++infixr 1 `extractConstructorBy`+infixr 1 `extractConstructor`++-- | Generic implementation of 'schemaGen' for a record.+gschemaGenRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> SchemaGen Schema+gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @ (Rep a))++-- | Generic implementation of 'toBuilder' for a record.+gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder+gtoBuilderRecord = productEncoder . from+{-# INLINE gtoBuilderRecord #-}++data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (Term -> a))++-- | Generic implementation of 'extractor' for a record.+gextractorRecord :: forall a. (GSerialiseRecord (Rep a), Generic a, Typeable a)+ => Maybe a -- ^ default value (optional)+ -> Extractor a+gextractorRecord def = Extractor $ mkPlan+ $ fmap (fmap (to .)) $ extractorRecord'+ ("gextractorRecord :: Extractor " <> viaShow (typeRep (Proxy @ a)))+ (from <$> def)++-- | Generic implementation of 'extractor' for a record.+extractorRecord' :: (GSerialiseRecord f)+ => Doc AnsiStyle+ -> Maybe (f x) -- ^ default value (optional)+ -> Schema -> Strategy' (Term -> f x)+extractorRecord' rep def (SRecord schs) = Strategy $ \decs -> do+ let go :: FieldDecoder T.Text x -> Either WineryException (Term -> x)+ go (FieldDecoder name def' p) = case lookupWithIndexV name schs of+ Nothing -> case def' of+ Just d -> Right (const d)+ Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs)+ Just (i, sch) -> case p `unPlan` sch `unStrategy` decs of+ Right getItem -> Right $ \case+ TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i+ t -> throw $ InvalidTerm t+ Left e -> Left e+ unTransFusion (recordExtractor def) go+extractorRecord' rep _ s = throwStrategy $ UnexpectedSchema rep "a record" s+{-# INLINE gextractorRecord #-}++gdecodeCurrentRecord :: (GSerialiseRecord (Rep a), Generic a) => Decoder a+gdecodeCurrentRecord = to <$> recordDecoder+{-# INLINE gdecodeCurrentRecord #-}++-- | The 'Serialise' instance is generically defined for records.+--+-- /"Remember thee! Yea, from the table of my memory I'll wipe away all trivial+-- fond records."/+newtype WineryRecord a = WineryRecord { unWineryRecord :: a }++instance (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where+ schemaGen _ = gschemaGenRecord (Proxy @ a)+ toBuilder = gtoBuilderRecord . unWineryRecord+ extractor = WineryRecord <$> gextractorRecord Nothing+ decodeCurrent = WineryRecord <$> gdecodeCurrentRecord++class GEncodeProduct f where+ productEncoder :: f x -> BB.Builder++instance GEncodeProduct U1 where+ productEncoder _ = mempty+ {-# INLINE productEncoder #-}++instance (GEncodeProduct f, GEncodeProduct g) => GEncodeProduct (f :*: g) where+ productEncoder (f :*: g) = productEncoder f <> productEncoder g+ {-# INLINE productEncoder #-}++instance Serialise a => GEncodeProduct (S1 c (K1 i a)) where+ productEncoder (M1 (K1 a)) = toBuilder a+ {-# INLINE productEncoder #-}++instance GEncodeProduct f => GEncodeProduct (C1 c f) where+ productEncoder (M1 a) = productEncoder a+ {-# INLINE productEncoder #-}++instance GEncodeProduct f => GEncodeProduct (D1 c f) where+ productEncoder (M1 a) = productEncoder a+ {-# INLINE productEncoder #-}++class GSerialiseRecord f where+ recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)]+ recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> f x)+ recordDecoder :: Decoder (f x)++instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where+ recordSchema _ = (++) <$> recordSchema (Proxy @ f) <*> recordSchema (Proxy @ g)+ recordExtractor def = (\f g -> (:*:) <$> f <*> g)+ <$> recordExtractor ((\(x :*: _) -> x) <$> def)+ <*> recordExtractor ((\(_ :*: x) -> x) <$> def)+ {-# INLINE recordExtractor #-}+ recordDecoder = (:*:) <$> recordDecoder <*> recordDecoder+ {-# INLINE recordDecoder #-}++instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where+ recordSchema _ = do+ s <- getSchema (Proxy @ a)+ pure [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), s)]+ recordExtractor def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder+ (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x))+ (unK1 . unM1 <$> def)+ (getExtractor extractor)+ {-# INLINE recordExtractor #-}+ recordDecoder = M1 . K1 <$> decodeCurrent+ {-# INLINE recordDecoder #-}++instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where+ recordSchema _ = recordSchema (Proxy @ f)+ recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)+ recordDecoder = M1 <$> recordDecoder++instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where+ recordSchema _ = recordSchema (Proxy @ f)+ recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)+ recordDecoder = M1 <$> recordDecoder++class GSerialiseProduct f where+ productSchema :: proxy f -> SchemaGen [Schema]+ productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x)+ productDecoder :: Decoder (f x)++instance GSerialiseProduct U1 where+ productSchema _ = pure []+ productExtractor = pure (pure U1)+ productDecoder = pure U1++instance (Serialise a) => GSerialiseProduct (K1 i a) where+ productSchema _ = pure <$> getSchema (Proxy @ a)+ productExtractor = Compose $ State $ \i ->+ ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (getExtractor extractor)+ , i + 1)+ productDecoder = K1 <$> decodeCurrent++instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where+ productSchema _ = productSchema (Proxy @ f)+ productExtractor = fmap M1 <$> productExtractor+ productDecoder = M1 <$> productDecoder++instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where+ productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g)+ productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor+ productDecoder = (:*:) <$> productDecoder <*> productDecoder++-- | Serialise a value as a product (omits field names).+--+-- /"I get ideas about what's essential when packing my suitcase."/+newtype WineryProduct a = WineryProduct { unWineryProduct :: a }++instance (GEncodeProduct (Rep a), GSerialiseProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where+ schemaGen _ = gschemaGenProduct (Proxy @ a)+ toBuilder = gtoBuilderProduct . unWineryProduct+ extractor = WineryProduct <$> gextractorProduct+ decodeCurrent = WineryProduct <$> gdecodeCurrentProduct++gschemaGenProduct :: forall proxy a. (Generic a, GSerialiseProduct (Rep a)) => proxy a -> SchemaGen Schema+gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @ (Rep a))+{-# INLINE gschemaGenProduct #-}++gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder+gtoBuilderProduct = productEncoder . from+{-# INLINE gtoBuilderProduct #-}++-- | Generic implementation of 'extractor' for a record.+gextractorProduct :: forall a. (GSerialiseProduct (Rep a), Generic a, Typeable a)+ => Extractor a+gextractorProduct = Extractor $ mkPlan $ fmap (to .) . extractorProduct'+{-# INLINE gextractorProduct #-}++-- | Generic implementation of 'extractor' for a record.+gdecodeCurrentProduct :: forall a. (GSerialiseProduct (Rep a), Generic a)+ => Decoder a+gdecodeCurrentProduct = to <$> productDecoder+{-# INLINE gdecodeCurrentProduct #-}++extractorProduct' :: GSerialiseProduct f => Schema -> Strategy' (Term -> f x)+extractorProduct' sch+ | Just schs <- strip sch = Strategy $ \recs -> do+ let go :: FieldDecoder Int x -> Either WineryException (Term -> x)+ go (FieldDecoder i _ p) = do+ getItem <- if i < length schs+ then unPlan p (schs V.! i) `unStrategy` recs+ else Left $ ProductTooSmall $ length schs+ return $ \case+ TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id+ $ xs V.!? i+ t -> throw $ InvalidTerm t+ unTransFusion (getCompose productExtractor `evalState` 0) go+ where+ strip (SProduct xs) = Just xs+ strip (SRecord xs) = Just $ V.map snd xs+ strip _ = Nothing+extractorProduct' sch = throwStrategy $ UnexpectedSchema "extractorProduct'" "a product" sch++-- | The 'Serialise' instance is generically defined for variants.+--+-- /"The one so like the other as could not be distinguish'd but by names."/+newtype WineryVariant a = WineryVariant { unWineryVariant :: a }++instance (GSerialiseVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where+ schemaGen _ = gschemaGenVariant (Proxy @ a)+ toBuilder = gtoBuilderVariant . unWineryVariant+ extractor = WineryVariant <$> gextractorVariant+ decodeCurrent = WineryVariant <$> gdecodeCurrentVariant++-- | Generic implementation of 'schemaGen' for an ADT.+gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema+gschemaGenVariant _ = SVariant . V.fromList <$> variantSchema (Proxy @ (Rep a))++-- | Generic implementation of 'toBuilder' for an ADT.+gtoBuilderVariant :: (GSerialiseVariant (Rep a), Generic a) => a -> BB.Builder+gtoBuilderVariant = variantEncoder 0 . from+{-# INLINE gtoBuilderVariant #-}++-- | Generic implementation of 'extractor' for an ADT.+gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a)+ => Extractor a+gextractorVariant = Extractor $ mkPlan $ \case+ SVariant schs0 -> Strategy $ \decs -> do+ ds' <- traverse (\(name, sch) -> case lookup name variantExtractor of+ Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs0)+ Just f -> f sch `unStrategy` decs) schs0+ return $ \case+ TVariant i _ v -> to $ maybe (throw InvalidTag) ($ v) $ ds' V.!? i+ t -> throw $ InvalidTerm t+ s -> throwStrategy $ UnexpectedSchema rep "a variant" s+ where+ rep = "gextractorVariant :: Extractor "+ <> viaShow (typeRep (Proxy @ a))++gdecodeCurrentVariant :: (GSerialiseVariant (Rep a), Generic a) => Decoder a+gdecodeCurrentVariant = decodeVarInt >>= maybe (throw InvalidTag) (fmap to) . (decs V.!?)+ where+ decs = V.fromList variantDecoder++class GSerialiseVariant f where+ variantCount :: proxy f -> Int+ variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)]+ variantEncoder :: Int -> f x -> BB.Builder+ variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))]+ variantDecoder :: [Decoder (f x)]++instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where+ variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g)+ variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g)+ variantEncoder i (L1 f) = variantEncoder i f+ variantEncoder i (R1 g) = variantEncoder (i + variantCount (Proxy @ f)) g+ variantExtractor = fmap (fmap (fmap (fmap (fmap L1)))) variantExtractor+ ++ fmap (fmap (fmap (fmap (fmap R1)))) variantExtractor+ variantDecoder = fmap (fmap L1) variantDecoder ++ fmap (fmap R1) variantDecoder++instance (GSerialiseProduct f, GEncodeProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where+ variantCount _ = 1+ variantSchema _ = do+ s <- productSchema (Proxy @ f)+ return [(T.pack $ symbolVal (Proxy @ name), SProduct $ V.fromList s)]+ variantEncoder i (M1 a) = varInt i <> productEncoder a+ variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorProduct') ]+ variantDecoder = [M1 <$> productDecoder]++instance (GSerialiseRecord f, GEncodeProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where+ variantCount _ = 1+ variantSchema _ = do+ s <- recordSchema (Proxy @ f)+ return [(T.pack $ symbolVal (Proxy @ name), SRecord $ V.fromList s)]+ variantEncoder i (M1 a) = varInt i <> productEncoder a+ variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorRecord' "" Nothing) ]+ variantDecoder = [M1 <$> recordDecoder]++instance (GSerialiseVariant f) => GSerialiseVariant (S1 c f) where+ variantCount _ = variantCount (Proxy @ f)+ variantSchema _ = variantSchema (Proxy @ f)+ variantEncoder i (M1 a) = variantEncoder i a+ variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor+ variantDecoder = fmap M1 <$> variantDecoder++instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where+ variantCount _ = variantCount (Proxy @ f)+ variantSchema _ = variantSchema (Proxy @ f)+ variantEncoder i (M1 a) = variantEncoder i a+ variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor+ variantDecoder = fmap M1 <$> variantDecoder++instance Serialise Ordering where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++deriving instance Serialise a => Serialise (Identity a)+deriving instance (Serialise a, Typeable b, Typeable k) => Serialise (Const a (b :: k))++deriving instance Serialise Any+deriving instance Serialise All+deriving instance Serialise a => Serialise (Down a)+deriving instance Serialise a => Serialise (Product a)+deriving instance Serialise a => Serialise (Sum a)+deriving instance Serialise a => Serialise (Dual a)+deriving instance Serialise a => Serialise (M.Last a)+deriving instance Serialise a => Serialise (M.First a)+deriving instance Serialise a => Serialise (S.Last a)+deriving instance Serialise a => Serialise (S.First a)+deriving instance Serialise a => Serialise (ZipList a)+deriving instance Serialise a => Serialise (Option a)+deriving instance Serialise a => Serialise (Max a)+deriving instance Serialise a => Serialise (Min a)+deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Alt f (a :: k))+deriving instance (Typeable j, Typeable k, Typeable f, Typeable g, Typeable a, Serialise (f (g a))) => Serialise (Compose f (g :: j -> k) (a :: j))+#if MIN_VERSION_base(4,12,0)+deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Ap f (a :: k))+#endif++instance (Typeable k, Typeable a, Typeable b, a ~ b) => Serialise ((a :: k) :~: b) where+ schemaGen _ = pure $ SProduct []+ toBuilder = mempty+ extractor = pure Refl+ decodeCurrent = pure Refl++instance (Serialise a, Serialise b) => Serialise (Arg a b) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance Serialise a => Serialise (Complex a) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct++instance Serialise Void where+ schemaGen _ = pure $ SVariant V.empty+ toBuilder = mempty+ extractor = Extractor $ Plan $ const $ throwStrategy "No extractor for Void"+ decodeCurrent = error "No decodeCurrent for Void"
+ src/Data/Winery/Base.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveTraversable #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery.Base+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Provisional+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Basic types+--+-----------------------------------------------------------------------------+module Data.Winery.Base+ ( Tag(..)+ , Schema+ , SchemaP(..)+ , currentSchemaVersion+ , bootstrapSchema+ , Term(..)+ , Extractor(..)+ , Strategy'+ , StrategyBind(..)+ , StrategyEnv(..)+ , Plan(..)+ , unwrapExtractor+ , WineryException(..)+ , prettyWineryException)+ where++import Control.Applicative+import Control.Exception+import Data.Aeson as J+import qualified Data.ByteString as B+import Data.Dynamic+import qualified Data.HashMap.Strict as HM+import Data.Int+import Data.String+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)+import Data.Text.Prettyprint.Doc.Render.Terminal+import Data.Time+import Data.Typeable+import qualified Data.Vector as V+import Data.Winery.Internal+import Data.Word+import GHC.Generics (Generic)+import GHC.Exts (IsList(..))++-- | Tag is an extra value that can be attached to a schema.+data Tag = TagInt !Int+ | TagStr !T.Text+ | TagList ![Tag]+ deriving (Show, Read, Eq, Generic)++instance IsString Tag where+ fromString = TagStr . fromString++instance IsList Tag where+ type Item Tag = Tag+ fromList = TagList+ toList (TagList xs) = xs+ toList _ = []++instance Pretty Tag where+ pretty (TagInt i) = pretty i+ pretty (TagStr s) = pretty s+ pretty (TagList xs) = list (map pretty xs)++currentSchemaVersion :: Word8+currentSchemaVersion = 4++-- | A schema preserves structure of a datatype, allowing users to inspect+-- the data regardless of the current implementation.+--+-- /"Yeah, it’s just a memento. Just, you know, from the first time we met."/+type Schema = SchemaP Int++data SchemaP a = SFix !(SchemaP a) -- ^ binds a fixpoint+ | SVar !a -- ^ @SVar n@ refers to the n-th innermost fixpoint+ | SVector !(SchemaP a)+ | SProduct !(V.Vector (SchemaP a))+ | SRecord !(V.Vector (T.Text, SchemaP a))+ | SVariant !(V.Vector (T.Text, SchemaP a))+ | SBool+ | SChar+ | SWord8+ | SWord16+ | SWord32+ | SWord64+ | SInt8+ | SInt16+ | SInt32+ | SInt64+ | SInteger+ | SFloat+ | SDouble+ | SBytes+ | SText+ | SUTCTime -- ^ nanoseconds from POSIX epoch+ | STag !Tag !(SchemaP a)+ | SLet !(SchemaP a) !(SchemaP a)+ deriving (Show, Read, Eq, Generic, Functor, Foldable, Traversable)++instance Pretty a => Pretty (SchemaP a) where+ pretty = \case+ SProduct [] -> "()"+ SBool -> "Bool"+ SChar -> "Char"+ SWord8 -> "Word8"+ SWord16 -> "Word16"+ SWord32 -> "Word32"+ SWord64 -> "Word64"+ SInt8 -> "Int8"+ SInt16 -> "Int16"+ SInt32 -> "Int32"+ SInt64 -> "Int64"+ SInteger -> "Integer"+ SFloat -> "Float"+ SDouble -> "Double"+ SBytes -> "ByteString"+ SText -> "Text"+ SUTCTime -> "UTCTime"+ SVector s -> "[" <> pretty s <> "]"+ SProduct ss -> tupled $ map pretty (V.toList ss)+ SRecord ss -> align $ encloseSep "{ " " }" ", " [group $ nest 2 $ sep [pretty k, "::" <+> pretty v] | (k, v) <- V.toList ss]+ SVariant ss -> align $ encloseSep "" "" (flatAlt "| " " | ")+ [ nest 2 $ sep $ pretty k : case vs of+ SProduct xs -> map pretty $ V.toList xs+ SRecord xs -> [pretty (SRecord xs)]+ s -> [pretty s] | (k, vs) <- V.toList ss]+ SFix sch -> group $ nest 2 $ sep ["μ", enclose "{ " " }" $ pretty sch]+ SVar i -> "$" <> pretty i+ STag t s -> nest 2 $ sep [pretty t <> ":", pretty s]+ SLet s t -> sep ["let" <+> pretty s, pretty t]++bootstrapSchema :: Word8 -> Schema+bootstrapSchema 4 = SFix (SVariant [("SFix",SProduct [SVar 0]),("SVar",SProduct [SInteger]),("SVector",SProduct [SVar 0]),("SProduct",SProduct [SVector (SVar 0)]),("SRecord",SProduct [SVector (SProduct [SText,SVar 0])]),("SVariant",SProduct [SVector (SProduct [SText,SVar 0])]),("SBool",SProduct []),("SChar",SProduct []),("SWord8",SProduct []),("SWord16",SProduct []),("SWord32",SProduct []),("SWord64",SProduct []),("SInt8",SProduct []),("SInt16",SProduct []),("SInt32",SProduct []),("SInt64",SProduct []),("SInteger",SProduct []),("SFloat",SProduct []),("SDouble",SProduct []),("SBytes",SProduct []),("SText",SProduct []),("SUTCTime",SProduct []),("STag",SProduct [SFix (SVariant [("TagInt",SProduct [SInteger]),("TagStr",SProduct [SText]),("TagList",SProduct [SVector (SVar 0)])]),SVar 0]),("SLet",SProduct [SVar 0,SVar 0])])+bootstrapSchema n = error $ "Unsupported version: " <> show n++-- | Common representation for any winery data.+-- Handy for prettyprinting winery-serialised data.+data Term = TBool !Bool+ | TChar !Char+ | TWord8 !Word8+ | TWord16 !Word16+ | TWord32 !Word32+ | TWord64 !Word64+ | TInt8 !Int8+ | TInt16 !Int16+ | TInt32 !Int32+ | TInt64 !Int64+ | TInteger !Integer+ | TFloat !Float+ | TDouble !Double+ | TBytes !B.ByteString+ | TText !T.Text+ | TUTCTime !UTCTime+ | TVector !(V.Vector Term)+ | TProduct !(V.Vector Term)+ | TRecord !(V.Vector (T.Text, Term))+ | TVariant !Int !T.Text Term+ deriving Show++instance J.ToJSON Term where+ toJSON (TBool b) = J.toJSON b+ toJSON (TChar c) = J.toJSON c+ toJSON (TWord8 w) = J.toJSON w+ toJSON (TWord16 w) = J.toJSON w+ toJSON (TWord32 w) = J.toJSON w+ toJSON (TWord64 w) = J.toJSON w+ toJSON (TInt8 w) = J.toJSON w+ toJSON (TInt16 w) = J.toJSON w+ toJSON (TInt32 w) = J.toJSON w+ toJSON (TInt64 w) = J.toJSON w+ toJSON (TInteger w) = J.toJSON w+ toJSON (TFloat x) = J.toJSON x+ toJSON (TDouble x) = J.toJSON x+ toJSON (TBytes bs) = J.toJSON (B.unpack bs)+ toJSON (TText t) = J.toJSON t+ toJSON (TUTCTime t) = J.toJSON t+ toJSON (TVector xs) = J.toJSON xs+ toJSON (TProduct xs) = J.toJSON xs+ toJSON (TRecord xs) = J.toJSON $ HM.fromList $ V.toList xs+ toJSON (TVariant _ "Just" x) = J.toJSON x+ toJSON (TVariant _ "Nothing" _) = J.Null+ toJSON (TVariant _ t x) = J.object ["tag" J..= J.toJSON t, "contents" J..= J.toJSON x]++instance Pretty Term where+ pretty (TWord8 i) = pretty i+ pretty (TWord16 i) = pretty i+ pretty (TWord32 i) = pretty i+ pretty (TWord64 i) = pretty i+ pretty (TInt8 i) = pretty i+ pretty (TInt16 i) = pretty i+ pretty (TInt32 i) = pretty i+ pretty (TInt64 i) = pretty i+ pretty (TInteger i) = pretty i+ pretty (TBytes s) = pretty $ show s+ pretty (TText s) = pretty s+ pretty (TVector xs) = list $ map pretty (V.toList xs)+ pretty (TBool x) = pretty x+ pretty (TChar x) = pretty x+ pretty (TFloat x) = pretty x+ pretty (TDouble x) = pretty x+ pretty (TProduct xs) = tupled $ map pretty (V.toList xs)+ pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- V.toList xs]+ pretty (TVariant _ tag (TProduct xs)) = group $ nest 2 $ sep $ pretty tag : map pretty (V.toList xs)+ pretty (TVariant _ tag x) = group $ nest 2 $ sep [pretty tag, pretty x]+ pretty (TUTCTime t) = pretty (show t)++-- | 'Extractor' is a 'Plan' that creates a function to extract a value from Term.+--+-- The 'Applicative' instance can be used to build a user-defined extractor.+-- This is also 'Alternative', meaning that fallback plans may be added.+--+-- /"Don't get set into one form, adapt it and build your own, and let it grow, be like water."/+newtype Extractor a = Extractor { getExtractor :: Plan (Term -> a) }+ deriving Functor++instance Applicative Extractor where+ pure = Extractor . pure . pure+ Extractor f <*> Extractor x = Extractor $ (<*>) <$> f <*> x++instance Alternative Extractor where+ empty = Extractor empty+ Extractor f <|> Extractor g = Extractor $ f <|> g++data StrategyBind = DynDecoder !Dynamic -- ^ A fixpoint of a decoder+ | BoundSchema !Int !Schema+ -- ^ schema bound by 'SLet'. 'Int' is a basis of the variables++data StrategyEnv = StrategyEnv !Int ![StrategyBind]++type Strategy' = Strategy WineryException StrategyEnv++-- | Plan is a monad for computations which interpret 'Schema'.+newtype Plan a = Plan { unPlan :: Schema -> Strategy' a }+ deriving Functor++instance Applicative Plan where+ pure = Plan . const . pure+ m <*> k = Plan $ \sch -> Strategy $ \decs -> case unStrategy (unPlan m sch) decs of+ Right f -> f <$> unStrategy (unPlan k sch) decs+ Left e -> Left e++instance Monad Plan where+ m >>= k = Plan $ \sch -> Strategy $ \decs -> case unStrategy (unPlan m sch) decs of+ Right a -> unStrategy (unPlan (k a) sch) decs+ Left e -> Left e++instance Alternative Plan where+ empty = Plan $ const empty+ Plan a <|> Plan b = Plan $ \s -> a s <|> b s++unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)+unwrapExtractor (Extractor m) = unPlan m+{-# INLINE unwrapExtractor #-}++data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema+ | FieldNotFound !(Doc AnsiStyle) !T.Text ![T.Text]+ | TypeMismatch !Int !TypeRep !TypeRep+ | ProductTooSmall !Int+ | UnboundVariable !Int+ | EmptyInput+ | WineryMessage !(Doc AnsiStyle)+ deriving Show++instance Exception WineryException++instance IsString WineryException where+ fromString = WineryMessage . fromString++prettyWineryException :: WineryException -> Doc AnsiStyle+prettyWineryException = \case+ UnexpectedSchema subject expected actual -> annotate bold subject+ <+> "expects" <+> annotate (color Green <> bold) expected+ <+> "but got " <+> pretty actual+ FieldNotFound rep x xs -> rep <> ": field or constructor " <> pretty x <> " not found in " <> pretty xs+ TypeMismatch i s t -> "A type mismatch in variable"+ <+> pretty i <> ":"+ <+> "expected" <> viaShow s+ <+> "but got " <> viaShow t+ ProductTooSmall i -> "The product is too small; expecting " <> pretty i+ UnboundVariable i -> "Unbound variable: " <> pretty i+ EmptyInput -> "Unexpected empty string"+ WineryMessage a -> a
src/Data/Winery/Internal.hs view
@@ -5,28 +5,39 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery.Internal+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Experimental+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Internal functions and datatypes+--+----------------------------------------------------------------------------- module Data.Winery.Internal- ( Encoding- , EncodingMulti- , encodeMulti- , encodeItem+ ( unsignedVarInt+ , varInt , Decoder- , decodeAt+ , evalDecoder+ , State(..)+ , evalState , decodeVarInt- , Offsets- , decodeOffsets+ , decodeVarIntFinite , getWord8+ , getWord16+ , getWord32+ , getWord64 , DecodeException(..)- , word16be- , word32be- , word64be- , unsafeIndex+ , indexDefault , unsafeIndexV+ , lookupWithIndexV , Strategy(..)- , StrategyError- , errorStrategy+ , throwStrategy , TransFusion(..) )where @@ -34,48 +45,126 @@ 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.FastBuilder as BB import qualified Data.ByteString.Internal as B-import Data.Winery.Internal.Builder+import qualified Data.ByteString.Builder.Prim.Internal as BPI import Data.Bits-import Data.Dynamic-import Data.Text.Prettyprint.Doc (Doc)-import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+import Data.Monoid ((<>))+import Data.String import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as UM+import qualified Data.Vector as V import Data.Word import Foreign.ForeignPtr import Foreign.Storable+import Foreign.Ptr import System.Endian -type Decoder = (->) B.ByteString+unsignedVarInt :: (Bits a, Integral a) => a -> BB.Builder+unsignedVarInt n+ | n < 0x80 = BB.word8 (fromIntegral n)+ | otherwise = BB.word8 (fromIntegral n `setBit` 7) <> uvarInt (unsafeShiftR n 7)+{-# INLINE unsignedVarInt #-} -decodeAt :: (Int, Int) -> Decoder a -> Decoder a-decodeAt (i, l) m = m . B.take l . B.drop i-{-# INLINE decodeAt #-}+varInt :: (Bits a, Integral a) => a -> BB.Builder+varInt n+ | n < 0 = case negate n of+ n'+ | n' < 0x40 -> BB.word8 (fromIntegral n' `setBit` 6)+ | otherwise -> BB.word8 (0xc0 .|. fromIntegral n') <> uvarInt (unsafeShiftR n' 6)+ | n < 0x40 = BB.word8 (fromIntegral n)+ | otherwise = BB.word8 (fromIntegral n `setBit` 7 `clearBit` 6) <> uvarInt (unsafeShiftR n 6)+{-# RULES "varInt/Int" varInt = varIntFinite #-}+{-# INLINEABLE[1] varInt #-} -getWord8 :: ContT r Decoder Word8-getWord8 = ContT $ \k bs -> case B.uncons bs of+varIntFinite :: Int -> BB.Builder+varIntFinite = BB.primBounded (BPI.boudedPrim 10 writeIntFinite)++writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)+writeWord8 w p = do+ poke p w+ return $! plusPtr p 1++writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)+writeIntFinite !n+ | n < 0 = case negate n of+ n'+ | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6)+ | otherwise ->+ writeWord8 (0xc0 .|. fromIntegral n') >=>+ writeUnsignedFinite pure (unsafeShiftR n' 6)+ | n < 0x40 = writeWord8 (fromIntegral n)+ | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=>+ writeUnsignedFinite pure (unsafeShiftR n 6)+{-# INLINE writeIntFinite #-}++writeUnsignedFinite :: (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r+writeUnsignedFinite k = go+ where+ go m+ | m < 0x80 = writeWord8 (fromIntegral m) >=> k+ | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7)+{-# INLINE writeUnsignedFinite #-}++uvarInt :: (Bits a, Integral a) => a -> BB.Builder+uvarInt = go where+ go m+ | m < 0x80 = BB.word8 (fromIntegral m)+ | otherwise = BB.word8 (setBit (fromIntegral m) 7) <> go (unsafeShiftR m 7)+{-# INLINE uvarInt #-}++-- | A state monad. The reason being not @State@ from transformers is to+-- allow coercion for newtype deriving and DerivingVia.+newtype State s a = State { runState :: s -> (a, s) }+ deriving Functor++evalState :: State s a -> s -> a+evalState m = fst . runState m+{-# INLINE evalState #-}++instance Applicative (State s) where+ pure a = State $ \s -> (a, s)+ m <*> k = State $ \s -> case runState m s of+ (f, s') -> case runState k s' of+ (a, s'') -> (f a, s'')++instance Monad (State s) where+ m >>= k = State $ \s -> case runState m s of+ (a, s') -> runState (k a) s'++instance MonadFix (State s) where+ mfix f = State $ \s -> fix $ \ ~(a, _) -> runState (f a) s++type Decoder = State B.ByteString++evalDecoder :: Decoder a -> B.ByteString -> a+evalDecoder = evalState+{-# INLINE evalDecoder #-}++getWord8 :: Decoder Word8+getWord8 = State $ \bs -> case B.uncons bs of Nothing -> throw InsufficientInput- Just (x, bs') -> k x $! bs'+ Just (x, bs') -> (x, bs') {-# INLINE getWord8 #-} data DecodeException = InsufficientInput+ | IntegerOverflow | InvalidTag deriving (Eq, Show, Read) instance Exception DecodeException -decodeVarInt :: (Num a, Bits a) => ContT r Decoder a-decodeVarInt = getWord8 >>= \case+decodeVarIntBase :: (Num a, Bits a) => Decoder a -> Decoder a+decodeVarIntBase body = getWord8 >>= \case n | testBit n 7 -> do- m <- getWord8 >>= go+ m <- body if testBit n 6 then return $! negate $ unsafeShiftL m 6 .|. fromIntegral n .&. 0x3f else return $! unsafeShiftL m 6 .|. clearBit (fromIntegral n) 7 | testBit n 6 -> return $ negate $ fromIntegral $ clearBit n 6 | otherwise -> return $ fromIntegral n+{-# INLINE decodeVarIntBase #-}++decodeVarInt :: (Num a, Bits a) => Decoder a+decodeVarInt = decodeVarIntBase $ getWord8 >>= go where go n | testBit n 7 = do@@ -84,60 +173,35 @@ | otherwise = return $ fromIntegral n {-# INLINE decodeVarInt #-} -word16be :: B.ByteString -> Word16-word16be = \s -> if B.length s >= 2- then- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.- (fromIntegral (s `B.unsafeIndex` 1))- else throw InsufficientInput+decodeVarIntFinite :: forall a. (Num a, FiniteBits a) => Decoder a+decodeVarIntFinite = decodeVarIntBase $ getWord8 >>= go 7+ where+ go w n+ | testBit n 7 = do+ m <- getWord8 >>= go (w + 7)+ return $! unsafeShiftL m 7 .|. clearBit (fromIntegral n) 7+ | w + 7 - countLeadingZeros n < finiteBitSize (0 :: a) = return $ fromIntegral n+ | otherwise = throw IntegerOverflow+{-# INLINABLE[1] decodeVarIntFinite #-}+{-# SPECIALISE decodeVarIntFinite :: Decoder Int #-} -word32be :: B.ByteString -> Word32-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) )+getWord16 :: Decoder Word16+getWord16 = State $ \(B.PS fp ofs len) -> if len >= 2+ then (B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE16 <$> peekByteOff ptr ofs, B.PS fp (ofs + 2) (len - 2)) else throw InsufficientInput -word64be :: B.ByteString -> Word64-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--encodeMulti :: (EncodingMulti -> EncodingMulti) -> Encoding-encodeMulti f = case f EncodingMulti0 of- EncodingMulti0 -> mempty- EncodingMulti r s -> mappend r s-{-# INLINE encodeMulti #-}--encodeItem :: Encoding -> EncodingMulti -> EncodingMulti-encodeItem e EncodingMulti0 = EncodingMulti mempty e-encodeItem e (EncodingMulti a b) = EncodingMulti- (mappend (varInt (getSize e)) a) (mappend e b)-{-# INLINE encodeItem #-}--type Offsets = U.Vector (Int, Int)+getWord32 :: Decoder Word32+getWord32 = State $ \(B.PS fp ofs len) -> if len >= 4+ then (B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE32 <$> peekByteOff ptr ofs, B.PS fp (ofs + 4) (len - 4))+ else throw InsufficientInput -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.unsafeWrite r i (s, maxBound)- U.unsafeFreeze r- | otherwise = do- let x = U.unsafeIndex xs i- let s' = s + x- UM.unsafeWrite r i (s, x)- go s' (i + 1)- go 0 0+getWord64 :: Decoder Word64+getWord64 = State $ \(B.PS fp ofs len) -> if len >= 8+ then (B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE64 <$> peekByteOff ptr ofs, B.PS fp (ofs + 8) (len - 8))+ else throw InsufficientInput unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a unsafeIndexV err xs i@@ -145,37 +209,47 @@ | otherwise = U.unsafeIndex xs i {-# INLINE unsafeIndexV #-} -unsafeIndex :: String -> [a] -> Int -> a-unsafeIndex err xs i = (xs ++ repeat (error err)) !! i+lookupWithIndexV :: Eq k => k -> V.Vector (k, v) -> Maybe (Int, v)+lookupWithIndexV k v = (\i -> (i, snd $ V.unsafeIndex v i))+ <$> V.findIndex ((k==) . fst) v+{-# INLINE lookupWithIndexV #-} -type StrategyError = Doc AnsiStyle+indexDefault :: a -> [a] -> Int -> a+indexDefault err xs i = case drop i xs of+ x : _ -> x+ _ -> err -newtype Strategy a = Strategy { unStrategy :: [Decoder Dynamic] -> Either StrategyError a }+-- | A monad with @Reader [r]@ and @Either WineryException@ combined, used internally+-- to build an extractor.+-- @r@ is used to share environment such as extractors for fixpoints.+newtype Strategy e r a = Strategy { unStrategy :: r -> Either e a } deriving Functor -instance Applicative Strategy where+instance Applicative (Strategy e r) where pure = return (<*>) = ap -instance Monad Strategy where+instance Monad (Strategy e r) where return = Strategy . const . Right m >>= k = Strategy $ \decs -> case unStrategy m decs of Right a -> unStrategy (k a) decs Left e -> Left e -instance Alternative Strategy where+instance IsString e => Alternative (Strategy e r) where empty = Strategy $ const $ Left "empty" Strategy a <|> Strategy b = Strategy $ \decs -> case a decs of Left _ -> b decs Right x -> Right x -instance MonadFix Strategy where+instance MonadFix (Strategy e r) where mfix f = Strategy $ \r -> mfix $ \a -> unStrategy (f a) r {-# INLINE mfix #-} -errorStrategy :: Doc AnsiStyle -> Strategy a-errorStrategy = Strategy . const . Left+throwStrategy :: e -> Strategy e r a+throwStrategy = Strategy . const . Left +-- | A Bazaar (chain of indexed store comonad)-like structure which instead+-- works for natural transformations. newtype TransFusion f g a = TransFusion { unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a } instance Functor (TransFusion f g) where
− src/Data/Winery/Internal/Builder.hs
@@ -1,187 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-module Data.Winery.Internal.Builder- ( Encoding- , getSize- , toByteString- , hPutEncoding- , word8- , word16- , word32- , word64- , bytes- , varInt- , unsignedVarInt- ) where--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-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--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- a <> Empty = a- Encoding s a <> Encoding t b = Encoding (s + t) (Bin a b)--instance Monoid Encoding where- mempty = Empty- {-# INLINE mempty #-}- mappend = (<>)- {-# INLINE mappend #-}--getSize :: Encoding -> Int-getSize Empty = 0-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 -> rotateTree ptr a b--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-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- return (B.PS fp 0 len)--word8 :: Word8 -> Encoding-word8 = Encoding 1 . LWord8-{-# INLINE word8 #-}--word16 :: Word16 -> Encoding-word16 = Encoding 2 . LWord16-{-# INLINE word16 #-}--word32 :: Word32 -> Encoding-word32 = Encoding 4 . LWord32-{-# INLINE word32 #-}--word64 :: Word64 -> Encoding-word64 = Encoding 8 . LWord64-{-# INLINE word64 #-}--bytes :: B.ByteString -> Encoding-bytes bs = Encoding (B.length bs) $ LBytes bs-{-# INLINE bytes #-}--unsignedVarInt :: (Bits a, Integral a) => a -> Encoding-unsignedVarInt n- | n < 0x80 = word8 (fromIntegral n)- | otherwise = uvarInt 1 (LWord8 (fromIntegral n `setBit` 7)) (unsafeShiftR n 7)-{-# SPECIALISE unsignedVarInt :: Int -> Encoding #-}--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 #-}--hPutEncoding :: Handle -> Encoding -> IO ()-hPutEncoding _ Empty = return ()-hPutEncoding h (Encoding _ t0) = wantWritableHandle "Data.Winery.Intenal.Builder.hPutEncoding" 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
@@ -1,5 +1,16 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE OverloadedStrings #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery.Query+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Experimental+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Building blocks for winery queries.+--+----------------------------------------------------------------------------- module Data.Winery.Query (Query(..) , invalid , list@@ -15,13 +26,16 @@ import Data.Winery.Internal import Data.Typeable import qualified Data.Text as T+import qualified Data.Vector as V +-- | Query is a transformation between 'Extractor's.+-- Like jq, this returns a list of values. newtype Query a b = Query- { runQuery :: Deserialiser [a] -> Deserialiser [b] }+ { runQuery :: Extractor [a] -> Extractor [b] } deriving Functor instance Category Query where- id = Query $ fmap id+ id = Query id Query f . Query g = Query $ f . g instance Applicative (Query a) where@@ -32,24 +46,32 @@ 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+-- | Throw an error.+invalid :: WineryException -> Query a b+invalid = Query . const . Extractor . Plan . const . throwStrategy -list :: Query a a-list = Query $ \d -> concat <$> extractListBy d+-- | Takes a list and traverses on it.+list :: Typeable a => Query a a+list = Query $ fmap concat . extractListBy -range :: Int -> Int -> Query a a-range i j = Query $ \d -> (\(n, f) -> concatMap f [mod i n..mod j n])- <$> extractArrayBy d+-- | Takes a list and enumerates elements in the specified range.+-- Like Python's array slicing, negative numbers counts from the last element.+range :: Typeable a => Int -> Int -> Query a a+range i j = Query $ fmap (\v -> foldMap id+ $ V.backpermute v (V.enumFromTo (i `mod` V.length v) (j `mod` V.length v)))+ . extractListBy +-- | Takes a record and extracts the specified field. field :: Typeable a => T.Text -> Query a a-field name = Query $ \d -> extractFieldBy d name+field name = Query $ \d -> buildExtractor $ extractFieldBy d name +-- | Takes a variant and returns a value when the constructor matches. con :: Typeable a => T.Text -> Query a a-con name = Query $ \d -> maybe [] id <$> extractConstructorBy d name+con name = Query $ \d -> buildExtractor $ extractConstructorBy (d, name, id) (pure []) +-- | Propagate values if the supplied 'Query' doesn't return False. 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+select qp = Query $ \d -> Extractor $ Plan $ \sch -> do+ p <- unwrapExtractor (runQuery qp d) sch+ dec <- unwrapExtractor d sch return $ \bs -> [x | and $ p bs, x <- dec bs]
src/Data/Winery/Query/Parser.hs view
@@ -3,7 +3,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery.Query.Parser+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Experimental+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- The language for winery queries+--+-- See the Pretty-printing section of README.md for examples.+--+----------------------------------------------------------------------------- module Data.Winery.Query.Parser (parseQuery) where import Prelude hiding ((.), id)@@ -28,6 +41,8 @@ parseQuery :: Typeable a => Parser (Query (Doc a) (Doc a)) parseQuery = foldr (.) id <$> sepBy1 parseTerms (symbol "|") +-- | Space-separated list of terms translate to a tabular output, applying the+-- queries in parallel parseTerms :: Typeable a => Parser (Query (Doc a) (Doc a)) parseTerms = fmap hsep . sequenceA <$> sepBy1 parseTerm space
− src/Data/Winery/Term.hs
@@ -1,152 +0,0 @@-{-# 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-import Data.Int-import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Terminal-import Data.Winery-import Data.Winery.Internal-import Data.Word-import qualified Data.Vector.Unboxed as V-import qualified Data.HashMap.Strict as HM-import Data.Time.Clock---- | Common representation for any winery data.--- Handy for prettyprinting winery-serialised data.-data Term = TUnit- | TBool !Bool- | TChar !Char- | TWord8 !Word8- | TWord16 !Word16- | TWord32 !Word32- | TWord64 !Word64- | TInt8 !Int8- | TInt16 !Int16- | TInt32 !Int32- | TInt64 !Int64- | TInteger !Integer- | TFloat !Float- | TDouble !Double- | TBytes !B.ByteString- | TText !T.Text- | TUTCTime !UTCTime- | TList [Term]- | TProduct [Term]- | TRecord [(T.Text, Term)]- | 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 (TUTCTime 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- go points = Deserialiser $ Plan $ \s -> case s of- SSchema ver -> Strategy (const $ bootstrapSchema ver) >>= unwrapDeserialiser (go points)- SUnit -> pure (pure TUnit)- SBool -> p s TBool- Data.Winery.SChar -> p s TChar- SWord8 -> p s TWord8- SWord16 -> p s TWord16- SWord32 -> p s TWord32- SWord64 -> p s TWord64- SInt8 -> p s TInt8- SInt16 -> p s TInt16- SInt32 -> p s TInt32- SInt64 -> p s TInt64- SInteger -> p s TInteger- SFloat -> p s TFloat- SDouble -> p s TDouble- SBytes -> p s TBytes- Data.Winery.SText -> p s TText- SUTCTime -> p s TUTCTime- 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- 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- let f bs ((n, dec) : decs) = dec bs : f (B.drop n bs) decs- f _ [] = []- return $ \bs -> TProduct $ f bs decoders- SRecord schs -> do- decoders <- traverse (\(name, sch) -> (,) name <$> unwrapDeserialiser (go points) sch) schs- return $ evalContT $ do- 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 <- 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'-- p s f = fmap f <$> unwrapDeserialiser deserialiser s---- | Deserialise a 'serialise'd 'B.Bytestring'.-deserialiseTerm :: B.ByteString -> Either (Doc AnsiStyle) (Schema, Term)-deserialiseTerm bs_ = do- (sch, bs) <- splitSchema bs_- dec <- getDecoderBy decodeTerm sch- return (sch, dec bs)--instance Pretty Term where- pretty TUnit = "()"- pretty (TWord8 i) = pretty i- pretty (TWord16 i) = pretty i- pretty (TWord32 i) = pretty i- pretty (TWord64 i) = pretty i- pretty (TInt8 i) = pretty i- pretty (TInt16 i) = pretty i- pretty (TInt32 i) = pretty i- pretty (TInt64 i) = pretty i- pretty (TInteger i) = pretty i- pretty (TBytes s) = pretty $ show s- pretty (TText s) = pretty s- pretty (TList xs) = list $ map pretty xs- pretty (TBool x) = pretty x- pretty (TChar x) = pretty x- pretty (TFloat x) = pretty x- pretty (TDouble x) = pretty x- pretty (TProduct xs) = tupled $ map pretty xs- pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- xs]- pretty (TVariant tag []) = pretty tag- pretty (TVariant tag xs) = group $ nest 2 $ vsep $ pretty tag : map pretty xs- pretty (TUTCTime t) = pretty (show t)
+ src/Data/Winery/Test.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+----------------------------------------------------------------------------+-- |+-- Module : Data.Winery.Test+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Experimental+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- A test framework that allows you to test all related Serialise instances+-- with automatically-generated test cases+--+-----------------------------------------------------------------------------+module Data.Winery.Test+ ( -- * Generating tests+ TestGen(..)+ , printTests+ -- * Test cases+ , Tested(..)+ , testCase+ -- * Running tests+ , allTests+ , mergeTests+ ) where++import Test.HUnit+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM+import qualified Data.ByteString as B+import Data.Functor.Identity+import Data.Hashable+import Data.Proxy+import qualified Data.Sequence as S+import Data.Typeable+import Data.Winery+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as UV+import GHC.Generics+import Text.Show++-- | Construct a test case.+testCase :: (Show a, Eq a, Serialise a)+ => Schema -- ^ the schema+ -> B.ByteString -- ^ serialised+ -> a -- ^ expected+ -> Test+testCase sch bs expected = case getDecoder sch of+ Left err -> TestCase $ assertFailure (show err)+ Right f -> expected ~=? evalDecoder f bs++-- | Merge multiple tests into one.+mergeTests :: M.Map TypeRep [Test] -> Test+mergeTests = TestList . concatMap (\(k, v) -> map (show k ~:) v) . M.toList++-- | Gather all test cases involved in the specified type.+allTests :: forall a. (TestGen a, Tested a) => M.Map TypeRep [Test]+allTests = M.insertWith (++) (typeRep (Proxy @ a)) (testCases @ a) (inheritedTests (Proxy @ a))++-- | Types with concrete test cases.+--+-- /"Doubt is useful, it keeps faith a living thing. After all, you cannot know+-- the strength of your faith until it has been tested."/+class TestGen a => Tested a where+ -- | List of test cases for the type.+ testCases :: [Test]++-- these are already covered by the QuickCheck tests from winery+instance Tested Bool where testCases = []+instance Tested Int where testCases = []+instance Tested Double where testCases = []+instance Tested () where testCases = []+instance Tested Char where testCases = []+instance Tested a => Tested (Identity a) where+ testCases = testCases @ a+instance Tested a => Tested (S.Seq a) where testCases = []+instance Tested a => Tested [a] where testCases = []+instance (Tested a, Tested b) => Tested (Either a b) where testCases = []+instance (Tested a, Tested b) => Tested (a, b) where testCases = []+instance Tested a => Tested (V.Vector a) where testCases = []+instance (UV.Unbox a, Tested a) => Tested (UV.Vector a) where testCases = []+instance (Hashable k, Tested k, Tested a) => Tested (HM.HashMap k a) where testCases = []++-- | Generate test cases and print them to the standard output.+printTests :: forall a. (TestGen a, Serialise a, Show a) => IO ()+printTests = putStrLn $ showTests (genTestCases :: [a])++showTests :: (Serialise a, Show a) => [a] -> String+showTests xs = showListWith ppTest xs ""++ppTest :: (Serialise a, Show a) => a -> ShowS+ppTest a = showString "testCase "+ . showsPrec 11 (schema [a])+ . showChar ' '+ . showsPrec 11 (serialiseOnly a)+ . showChar ' '+ . showsPrec 11 a++-- | A class to provide test values and gather tests for its components.+-- It is recommended to use the generic default methods.+class Typeable a => TestGen a where+ -- | A list of values that can be used as test cases.+ -- It should contain at least one value as long as there is a non-bottom value+ -- in the type.+ genTestCases :: [a]++ -- | Inherited set of test cases for each type it involves.+ inheritedTests :: Proxy a -> M.Map TypeRep [Test]++ default genTestCases :: (Generic a, GTestGen (Rep a)) => [a]+ genTestCases = fmap to ggenTestCases++ default inheritedTests :: (GTestGen (Rep a)) => Proxy a -> M.Map TypeRep [Test]+ inheritedTests _ = ginheritedTests (Proxy @ (Rep a))++class GTestGen f where+ ggenTestCases :: [f x]+ ginheritedTests :: proxy f -> M.Map TypeRep [Test]++instance GTestGen V1 where+ ggenTestCases = mempty+ ginheritedTests _ = mempty++instance GTestGen U1 where+ ggenTestCases = [U1]+ ginheritedTests _ = mempty++instance GTestGen f => GTestGen (Rec1 f) where+ ggenTestCases = fmap Rec1 ggenTestCases+ ginheritedTests _ = ginheritedTests (Proxy @ f)++instance (Tested c, TestGen c) => GTestGen (K1 i c) where+ ggenTestCases = fmap K1 genTestCases+ ginheritedTests _ = allTests @ c++instance GTestGen f => GTestGen (M1 i c f) where+ ggenTestCases = fmap M1 ggenTestCases+ ginheritedTests _ = ginheritedTests (Proxy @ f)++instance (GTestGen f, GTestGen g) => GTestGen (f :+: g) where+ ggenTestCases = fmap L1 ggenTestCases ++ fmap R1 ggenTestCases+ ginheritedTests _ = ginheritedTests (Proxy @ f)+ `mappend` ginheritedTests (Proxy @ g)++instance (GTestGen f, GTestGen g) => GTestGen (f :*: g) where+ ggenTestCases = ((:*:) <$> ggenTestCases <*> xs)+ ++ ((:*:) <$> take 1 ggenTestCases <*> ys)+ where+ (xs, ys) = splitAt 1 ggenTestCases+ ginheritedTests _ = ginheritedTests (Proxy @ f)+ `mappend` ginheritedTests (Proxy @ g)++deriving instance TestGen a => TestGen (Identity a)+instance TestGen ()+instance TestGen Bool+instance (Tested a, Tested b) => TestGen (a, b)+instance (Tested a, Tested b, Tested c) => TestGen (a, b, c)+instance (Tested a, Tested b, Tested c, Tested d) => TestGen (a, b, c, d)+instance (Tested a, Tested b) => TestGen (Either a b)++instance Tested a => TestGen [a] where+ genTestCases = [[]]+ inheritedTests _ = allTests @ a++instance Tested a => TestGen (S.Seq a) where+ genTestCases = [mempty]+ inheritedTests _ = allTests @ a++instance Tested a => TestGen (V.Vector a) where+ genTestCases = [V.empty]+ inheritedTests _ = allTests @ a++instance (UV.Unbox a, Tested a) => TestGen (UV.Vector a) where+ genTestCases = [UV.empty]+ inheritedTests _ = allTests @ a++instance (Hashable k, Tested k, Tested a) => TestGen (HM.HashMap k a) where+ genTestCases = HM.singleton <$> genTestCases <*> genTestCases+ inheritedTests _ = allTests @ k `mappend` allTests @ a++instance TestGen Int where+ genTestCases = [42]+ inheritedTests = mempty++instance TestGen Double where+ genTestCases = [pi]+ inheritedTests = mempty++instance TestGen Char where+ genTestCases = ['X']+ inheritedTests = mempty
test/Spec.hs view
@@ -1,16 +1,145 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}-import Control.Monad.Fix-import qualified Data.ByteString as B+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-missing-signatures#-}+import Control.Monad+import Data.ByteString (ByteString)+import Data.Int+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Map (Map)+import Data.Scientific (Scientific)+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.Text (Text)+import Data.Time (UTCTime, NominalDiffTime) import Data.Winery-import qualified Data.Winery.Internal.Builder as WB+import Data.Winery.Internal+import Data.Word+import qualified Data.ByteString.FastBuilder as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Unboxed as UV+import GHC.Generics (Generic) import Test.QuickCheck-import Control.Monad+import qualified Test.QuickCheck.Gen as Gen+import Test.QuickCheck.Instances ()+import Control.Applicative ((<|>)) -prop_VarInt :: [Int] -> Property-prop_VarInt i = B.length bs === WB.getSize e .&&. decodeCurrent bs === i- where- bs = WB.toByteString e- e = toEncoding i+prop_VarInt :: Int -> Property+prop_VarInt i = evalDecoder decodeVarInt+ (B.toStrictByteString $ varInt i) === i++prop_Unit = testSerialise @ ()+prop_Bool = testSerialise @ Bool+prop_Word8 = testSerialise @ Word8+prop_Word16 = testSerialise @ Word16+prop_Word32 = testSerialise @ Word32+prop_Word64 = testSerialise @ Word64+prop_Word = testSerialise @ Word+prop_Int8 = testSerialise @ Int8+prop_Int16 = testSerialise @ Int16+prop_Int32 = testSerialise @ Int32+prop_Int64 = testSerialise @ Int64+prop_Int = testSerialise @ Int+prop_Float = testSerialise @ Float+prop_Double = testSerialise @ Double+prop_Text = testSerialise @ Text+prop_Integer = testSerialise @ Integer+prop_Char = testSerialise @ Char+prop_Maybe_Int = testSerialise @ (Maybe Int)+prop_ByteString = testSerialise @ ByteString+prop_ByteString_Lazy = testSerialise @ BL.ByteString+prop_UTCTime = testSerialise @ UTCTime+prop_NominalDiffTime = testSerialise @ NominalDiffTime+prop_List_Int = testSerialise @ [Int]+prop_Vector_Int = testSerialise @ (V.Vector Int) . V.fromList+prop_Vector_Storable_Int = testSerialise @ (SV.Vector Int) . SV.fromList+prop_Vector_Unboxed_Int = testSerialise @ (UV.Vector Int) . UV.fromList+prop_Map_Int_Int = testSerialise @ (Map Int Int)+prop_HashMap_String_Int = testSerialise @ (HM.HashMap String Int) . HM.fromList+prop_IntMap_Int = testSerialise @ (IntMap Int)+prop_Set_Int = testSerialise @ (Set Int)+prop_IntSet = testSerialise @ IntSet+prop_Seq_Int = testSerialise @ (Seq Int)+prop_Scientific = testSerialise @ Scientific+prop_Tuple2 = testSerialise @ (Bool, Int)+prop_Tuple3 = testSerialise @ (Bool, Int, Text)+prop_Tuple4 = testSerialise @ (Bool, Int, Text, Double)+prop_Either_String_Int = testSerialise @ (Either String Int)+prop_Ordering = testSerialise @ Ordering++data TRec = TRec+ { foo :: !Int+ , bar :: !Text+ } deriving (Show, Eq, Generic)++instance Arbitrary TRec where+ arbitrary = TRec <$> arbitrary <*> arbitrary++instance Serialise TRec where+ schemaGen = gschemaGenRecord+ toBuilder = gtoBuilderRecord+ extractor = gextractorRecord Nothing+ decodeCurrent = gdecodeCurrentRecord++prop_TRec = testSerialise @ TRec++data TList a = TCons a (TList a) | TNil deriving (Show, Eq, Generic)++instance Serialise a => Serialise (TList a) where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++instance Arbitrary a => Arbitrary (TList a) where+ arbitrary = sized $ \n -> if n <= 0+ then pure TNil+ else TCons <$> arbitrary <*> scale pred arbitrary++prop_TList_Int = testSerialise @ (TList Int)++data Tree+ = Leaf+ | Branch Node+ deriving (Show, Eq, Generic)++data Node = Node { left :: !Tree, value :: !Int, right :: !Tree }+ deriving (Show, Eq, Generic)++instance Arbitrary Tree where+ arbitrary = sized $ \n -> if n <= 0+ then pure Leaf+ else Branch <$> arbitrary++instance Arbitrary Node where+ arbitrary = sized $ \n -> do+ leftSize <- Gen.choose (0, max 0 $ n - 1)+ let rightSize = max 0 $ n - 1 - leftSize+ Node <$> resize leftSize arbitrary <*> arbitrary <*> resize rightSize arbitrary++instance Serialise Tree where+ schemaGen = gschemaGenVariant+ toBuilder = gtoBuilderVariant+ extractor = gextractorVariant+ decodeCurrent = gdecodeCurrentVariant++instance Serialise Node where+ schemaGen = gschemaGenRecord+ toBuilder = gtoBuilderRecord+ extractor = buildExtractor $ Node+ <$> (extractField "left" <|> extractField "leftChild")+ <*> extractField "value"+ <*> (extractField "right" <|> extractField "rightChild")+ --extractor = gextractorRecord Nothing+ decodeCurrent = gdecodeCurrentRecord++prop_tree = testSerialise @ Tree+prop_node = testSerialise @ Node return [] main = void $ $quickCheckAll
winery.cabal view
@@ -1,43 +1,49 @@--- This file has been generated from package.yaml by hpack version 0.28.2.------ see: https://github.com/sol/hpack------ hash: 3ff70b5fa2376a218f9a64788b8b4456cdf456bda04e35866d05ab985880148b+cabal-version: 1.12 name: winery-version: 0.3.1+version: 1 synopsis: Sustainable serialisation library-description: Please see the README on Github at <https://github.com/fumieval/winery#readme>+description: Please see the README on GitHub at <https://github.com/fumieval/winery#readme> category: Data, Codec, Parsing, Serialization homepage: https://github.com/fumieval/winery#readme bug-reports: https://github.com/fumieval/winery/issues author: Fumiaki Kinoshita maintainer: fumiexcel@gmail.com-copyright: Copyright (c) 2018 Fumiaki Kinoshita+copyright: Copyright (c) 2019 Fumiaki Kinoshita license: BSD3 license-file: LICENSE-tested-with: GHC == 7.10.1, GHC == 8.4.1, GHC == 8.6.1+tested-with: GHC == 8.4.4, GHC == 8.6.3 build-type: Simple-cabal-version: >= 1.10 extra-source-files:- ChangeLog.md README.md+ ChangeLog.md source-repository head type: git location: https://github.com/fumieval/winery library+ exposed-modules:+ Data.Winery+ Data.Winery.Base+ Data.Winery.Internal+ Data.Winery.Query+ Data.Winery.Query.Parser+ Data.Winery.Test+ other-modules:+ Paths_winery hs-source-dirs: src- ghc-options: -Wall -O2+ ghc-options: -Wall -O2 -Wcompat build-depends: aeson , base >=4.7 && <5 , bytestring , containers , cpu+ , fast-builder , hashable+ , HUnit , megaparsec >=6.0.0 , mtl , prettyprinter@@ -49,15 +55,7 @@ , transformers , unordered-containers , vector- exposed-modules:- Data.Winery- Data.Winery.Term- Data.Winery.Internal- Data.Winery.Internal.Builder- Data.Winery.Query- Data.Winery.Query.Parser- other-modules:- Paths_winery+ , QuickCheck default-language: Haskell2010 executable winery@@ -66,54 +64,39 @@ Paths_winery hs-source-dirs: app+ ghc-options: -Wall -O2 -Wcompat build-depends: aeson , base >=4.7 && <5- , bytestring- , containers- , cpu- , hashable- , megaparsec >=6.0.0- , mtl+ , winery+ , megaparsec+ , text , prettyprinter , prettyprinter-ansi-terminal- , scientific- , semigroups- , text- , time- , transformers- , unordered-containers- , vector- , winery+ , bytestring default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs+ ghc-options: -Wall -Wcompat+ other-modules:+ Paths_winery hs-source-dirs: test build-depends: QuickCheck- , aeson , base >=4.7 && <5- , bytestring+ , quickcheck-instances+ , winery+ , vector+ , unordered-containers+ , fast-builder+ , time+ , text , containers- , cpu- , hashable- , megaparsec >=6.0.0- , mtl- , prettyprinter- , prettyprinter-ansi-terminal , scientific- , semigroups- , text- , time- , transformers- , unordered-containers- , vector- , winery- other-modules:- Paths_winery+ , bytestring default-language: Haskell2010 benchmark bench-winery@@ -123,30 +106,17 @@ Paths_winery hs-source-dirs: benchmarks- ghc-options: -O2+ ghc-options: -O2 -Wall -Wcompat build-depends:- aeson- , base >=4.7 && <5+ base >=4.7 && <5+ , gauge+ , aeson+ , cereal+ , winery , binary+ , serialise+ , text , bytestring- , cassava- , containers- , cpu , deepseq , directory- , gauge- , hashable- , megaparsec >=6.0.0- , mtl- , prettyprinter- , prettyprinter-ansi-terminal- , scientific- , semigroups- , serialise- , text- , time- , transformers- , unordered-containers- , vector- , winery default-language: Haskell2010