diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 | diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -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 ] ] diff --git a/src/Data/Winery.hs b/src/Data/Winery.hs --- a/src/Data/Winery.hs +++ b/src/Data/Winery.hs @@ -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 +-- +-- 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" diff --git a/src/Data/Winery/Base.hs b/src/Data/Winery/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Winery/Base.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Winery/Internal.hs b/src/Data/Winery/Internal.hs --- a/src/Data/Winery/Internal.hs +++ b/src/Data/Winery/Internal.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Winery/Internal/Builder.hs b/src/Data/Winery/Internal/Builder.hs deleted file mode 100644 --- a/src/Data/Winery/Internal/Builder.hs +++ /dev/null @@ -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' diff --git a/src/Data/Winery/Query.hs b/src/Data/Winery/Query.hs --- a/src/Data/Winery/Query.hs +++ b/src/Data/Winery/Query.hs @@ -1,5 +1,16 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE OverloadedStrings #-} +---------------------------------------------------------------------------- +-- | +-- Module : Data.Winery.Query +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Experimental +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- 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] diff --git a/src/Data/Winery/Query/Parser.hs b/src/Data/Winery/Query/Parser.hs --- a/src/Data/Winery/Query/Parser.hs +++ b/src/Data/Winery/Query/Parser.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Winery/Term.hs b/src/Data/Winery/Term.hs deleted file mode 100644 --- a/src/Data/Winery/Term.hs +++ /dev/null @@ -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) diff --git a/src/Data/Winery/Test.hs b/src/Data/Winery/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/Winery/Test.hs @@ -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 +-- +-- 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -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 +description: Please see the README on GitHub at 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