diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -167,4 +167,5 @@ | cereal | 0.82 μs | 0.78 ms | 0.90 ms | 91709 | | binary | 1.7 μs | 1.7 ms | 2.0 ms | 125709 | | serialise | 0.61 μs | 0.50 ms | 1.4 ms | 65437 | +| store | 54 ns | 56 μs | 0.13 ms | 126410 | | aeson | 9.9 μs | 9.7 ms | 17 ms | 160558 | diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,6 +7,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Word (Word64) import qualified Codec.Winery.Query as Q import Codec.Winery.Query.Parser import Codec.Winery @@ -35,8 +36,8 @@ options :: [OptDescr (Options -> Options)] options = - [ Option "s" ["stream"] (NoArg $ \o -> o { streamInput = True }) "stream input" - , Option "S" ["separate-schema"] (OptArg (\s o -> o { separateSchema = Just s }) "PATH") "the schema is separated" + [ Option "s" ["stream"] (NoArg $ \o -> o { streamInput = True }) "streaming input: each payload is prefixed by little-endian Word64" + , Option "S" ["separate-schema"] (OptArg (\s o -> o { separateSchema = Just s }) "PATH") "the schema is stored separately on PATH" , Option "" ["print-schema"] (NoArg $ \o -> o { printSchema = True }) "print the schema" , Option "J" ["JSON"] (NoArg $ \o -> o { outputJSON = True }) "print as JSON" ] @@ -50,6 +51,11 @@ putTerm :: Doc AnsiStyle -> IO () putTerm t = putDoc $ t <> hardline +getLengthPrefixed :: Handle -> IO B.ByteString +getLengthPrefixed h = do + str <- B.hGet h 8 + B.hGet h (fromIntegral (evalDecoder decodeCurrent str :: Word64)) + app :: Options -> Q.Query (Doc AnsiStyle) (Doc AnsiStyle) -> Handle -> IO () app o q h = do let p @@ -59,7 +65,7 @@ printer <- case separateSchema o of Just mpath -> do - bs <- maybe (readLn >>= B.hGet h) B.readFile mpath + bs <- maybe (getLengthPrefixed h) B.readFile mpath sch <- getRight $ deserialise bs when (printSchema o) $ putDoc $ pretty sch <> hardline dec <- getDec sch @@ -72,9 +78,7 @@ case streamInput o of False -> B.hGetContents h >>= printer - True -> forever $ do - n <- readLn - B.hGet h n >>= printer + True -> forever $ getLengthPrefixed h >>= printer main :: IO () main = getOpt Permute options <$> getArgs >>= \case diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B import qualified Data.Binary as B +import qualified Data.Store as S import Data.Either import Codec.Winery import Data.Text (Text) @@ -24,6 +25,7 @@ instance C.Serialize Gender instance J.FromJSON Gender instance J.ToJSON Gender +instance S.Store Gender data TestRec = TestRec { id_ :: !Int @@ -47,6 +49,7 @@ instance CBOR.Serialise TestRec instance J.FromJSON TestRec instance J.ToJSON TestRec +instance S.Store TestRec instance C.Serialize Text where put = C.put . TE.encodeUtf8 @@ -61,6 +64,9 @@ json <- B.readFile "benchmarks/data.json" values :: [TestRec] <- return $ B.decode $ BL.fromStrict binary let aValue = head values + B.writeFile "benchmarks/data.store" $ S.encode values + + store <- B.readFile "benchmarks/data.store" let serialisedInts = serialiseOnly [floor (2**x) :: Int | x <- [0 :: Double, 0.5..62]] deepseq values $ defaultMain [ bgroup "serialise/list" @@ -68,6 +74,7 @@ , bench "binary" $ nf (BL.toStrict . B.encode) values , bench "cereal" $ nf C.encode values , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) values + , bench "store" $ nf S.encode values , bench "aeson" $ nf (BL.toStrict . J.encode) values ] , bgroup "serialise/item" @@ -75,6 +82,7 @@ , bench "binary" $ nf (BL.toStrict . B.encode) aValue , bench "cereal" $ nf C.encode aValue , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) aValue + , bench "store" $ nf S.encode aValue , bench "aeson" $ nf (BL.toStrict . J.encode) aValue ] , bgroup "deserialise" @@ -82,6 +90,7 @@ , 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 "store" $ nf (S.decodeEx :: B.ByteString -> [TestRec]) store , bench "aeson" $ nf (J.decode . BL.fromStrict :: B.ByteString -> Maybe [TestRec]) json ] , bgroup "deserialise/Int" diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs --- a/src/Codec/Winery.hs +++ b/src/Codec/Winery.hs @@ -1,1321 +1,394 @@ -{-# 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 : Codec.Winery --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Provisional --- --- Maintainer : Fumiaki Kinoshita --- ------------------------------------------------------------------------------ -module Codec.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 - , gtoBuilderRecord - , gextractorRecord - , gdecodeCurrentRecord - , GSerialiseVariant - , GConstructorCount - , GEncodeVariant - , GDecodeVariant - , gschemaGenVariant - , gtoBuilderVariant - , gextractorVariant - , gdecodeCurrentVariant - , GEncodeProduct - , GDecodeProduct - , gschemaGenProduct - , gtoBuilderProduct - , gextractorProduct - , gdecodeCurrentProduct - , decodeCurrentDefault - -- * Bundles - , BundleSerialise(..) - , bundleRecord - , bundleRecordDefault - , bundleVariant - -- * 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 Codec.Winery.Base as W -import Codec.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 - schemaGen = bundleSchemaGen bundleSerialise - {-# INLINE schemaGen #-} - - -- | Serialise a value. - toBuilder :: a -> BB.Builder - toBuilder = bundleToBuilder bundleSerialise - {-# INLINE toBuilder #-} - - -- | 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 - extractor = bundleExtractor bundleSerialise - {-# INLINE extractor #-} - - -- | Decode a value with the current schema. - -- - -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x - decodeCurrent :: Decoder a - decodeCurrent = bundleDecodeCurrent bundleSerialise - {-# INLINE decodeCurrent #-} - - -- | Instead of the four methods above, you can supply a bundle. - bundleSerialise :: BundleSerialise a - bundleSerialise = BundleSerialise - { bundleSchemaGen = schemaGen - , bundleToBuilder = toBuilder - , bundleExtractor = extractor - , bundleDecodeCurrent = decodeCurrent - } - - {-# MINIMAL schemaGen, toBuilder, extractor, decodeCurrent | bundleSerialise #-} - --- | A bundle of 'Serialise' methods -data BundleSerialise a = BundleSerialise - { bundleSchemaGen :: Proxy a -> SchemaGen Schema - , bundleToBuilder :: a -> BB.Builder - , bundleExtractor :: Extractor a - , bundleDecodeCurrent :: Decoder a - } - --- | A bundle of generic implementations for records -bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) - => (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleRecord f = BundleSerialise - { bundleSchemaGen = gschemaGenRecord - , bundleToBuilder = gtoBuilderRecord - , bundleExtractor = f $ gextractorRecord Nothing - , bundleDecodeCurrent = gdecodeCurrentRecord - } -{-# INLINE bundleRecord #-} - --- | A bundle of generic implementations for records, with a default value -bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) - => a -- default value - -> (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleRecordDefault def f = BundleSerialise - { bundleSchemaGen = gschemaGenRecord - , bundleToBuilder = gtoBuilderRecord - , bundleExtractor = f $ gextractorRecord $ Just def - , bundleDecodeCurrent = gdecodeCurrentRecord - } -{-# INLINE bundleRecordDefault #-} - --- | A bundle of generic implementations for variants -bundleVariant :: (GSerialiseVariant (Rep a), GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) - => (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleVariant f = BundleSerialise - { bundleSchemaGen = gschemaGenVariant - , bundleToBuilder = gtoBuilderVariant - , bundleExtractor = f $ gextractorVariant - , bundleDecodeCurrent = gdecodeCurrentVariant - } -{-# INLINE bundleVariant #-} - --- | 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 - --- | 'decodeCurrent' in terms of 'extractor'; note that it's very slow. -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' then write it to a file. -writeFileSerialise :: Serialise a => FilePath -> a -> IO () -writeFileSerialise path a = withBinaryFile path WriteMode - $ \h -> BB.hPutBuilder h $ toBuilderWithSchema a -{-# INLINE writeFileSerialise #-} - --- | Serialise a value with the schema. -toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder -toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion) - $ toBuilder (schema (Proxy @ a), a) -{-# INLINE toBuilderWithSchema #-} - --- | Split a 'Schema' from a 'B.ByteString'. -splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString) -splitSchema bs_ = case B.uncons bs_ of - Just (ver, bs) -> do - m <- bootstrapSchema ver >>= getDecoder - return $ flip evalDecoder bs $ do - sch <- m - Decoder $ \bs' i -> DecoderResult (B.length bs') (sch, B.drop i bs') - 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 - --- | Deserialise a schema. -deserialiseSchema :: B.ByteString -> Either WineryException Schema -deserialiseSchema bs_ = case B.uncons bs_ of - Just (ver, bs) -> do - m <- bootstrapSchema ver >>= getDecoder - 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 <$> getBytes 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 = decodeVarInt >>= getBytes - -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 - --- | Build an extractor from a 'Subextractor'. -buildExtractor :: Typeable a => Subextractor a -> Extractor a -buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e -{-# INLINE buildExtractor #-} - --- | An extractor for individual fields. This distinction is required for --- handling recursions correctly. --- --- Recommended extension: ApplicativeDo -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 = "Codec.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 #-} - --- | No constructors remaining. -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 #-} - --- | Synonym for 'gdecodeCurrentProduct' -gdecodeCurrentRecord :: (GDecodeProduct (Rep a), Generic a) => Decoder a -gdecodeCurrentRecord = to <$> productDecoder -{-# 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), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where - schemaGen _ = gschemaGenRecord (Proxy @ a) - toBuilder = gtoBuilderRecord . unWineryRecord - extractor = WineryRecord <$> gextractorRecord Nothing - decodeCurrent = WineryRecord <$> gdecodeCurrentRecord - --- | Encode all the fields -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 GDecodeProduct f where - productDecoder :: Decoder (f x) - -instance GDecodeProduct U1 where - productDecoder = pure U1 - -instance Serialise a => GDecodeProduct (K1 i a) where - productDecoder = K1 <$> decodeCurrent - {-# INLINE productDecoder #-} - -instance GDecodeProduct f => GDecodeProduct (M1 i c f) where - productDecoder = M1 <$> productDecoder - {-# INLINE productDecoder #-} - -instance (GDecodeProduct f, GDecodeProduct g) => GDecodeProduct (f :*: g) where - productDecoder = (:*:) <$> productDecoder <*> productDecoder - {-# INLINE productDecoder #-} - -class GSerialiseRecord f where - recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)] - recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> 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 #-} - -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 #-} - -instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where - recordSchema _ = recordSchema (Proxy @ f) - recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) - -instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where - recordSchema _ = recordSchema (Proxy @ f) - recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) - -class GSerialiseProduct f where - productSchema :: proxy f -> SchemaGen [Schema] - productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x) - -instance GSerialiseProduct U1 where - productSchema _ = pure [] - productExtractor = pure (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) - -instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where - productSchema _ = productSchema (Proxy @ f) - productExtractor = fmap M1 <$> productExtractor - -instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where - productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g) - productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor - --- | 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), GDecodeProduct (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. (GDecodeProduct (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 (GConstructorCount (Rep a), GSerialiseVariant (Rep a), GEncodeVariant (Rep a), GDecodeVariant (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 :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) => a -> BB.Builder -gtoBuilderVariant = variantEncoder (variantCount (Proxy :: Proxy (Rep a))) 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 :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a) => Decoder a -gdecodeCurrentVariant = decodeVarInt >>= fmap to . variantDecoder (variantCount (Proxy :: Proxy (Rep a))) -{-# INLINE gdecodeCurrentVariant #-} - -class GConstructorCount f where - variantCount :: proxy f -> Int - -instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where - variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g) - {-# INLINE variantCount #-} - -instance GConstructorCount (C1 i f) where - variantCount _ = 1 - {-# INLINE variantCount #-} - -instance GConstructorCount f => GConstructorCount (D1 i f) where - variantCount _ = variantCount (Proxy @ f) - {-# INLINE variantCount #-} - -class GDecodeVariant f where - variantDecoder :: Int -> Int -> Decoder (f x) - -instance (GDecodeVariant f, GDecodeVariant g) => GDecodeVariant (f :+: g) where - variantDecoder len i - | i < len' = L1 <$> variantDecoder len' i - | otherwise = R1 <$> variantDecoder (len - len') (i - len') - where - len' = unsafeShiftR len 1 - {-# INLINE variantDecoder #-} - -instance GDecodeProduct f => GDecodeVariant (C1 i f) where - variantDecoder _ _ = M1 <$> productDecoder - {-# INLINE variantDecoder #-} - -instance GDecodeVariant f => GDecodeVariant (D1 i f) where - variantDecoder len i = M1 <$> variantDecoder len i - {-# INLINE variantDecoder #-} - -class GEncodeVariant f where - variantEncoder :: Int -> Int -> f x -> BB.Builder - -instance (GEncodeVariant f, GEncodeVariant g) => GEncodeVariant (f :+: g) where - variantEncoder len i (L1 f) = variantEncoder (unsafeShiftR len 1) i f - variantEncoder len i (R1 g) = variantEncoder (len - len') (i + len') g - where - len' = unsafeShiftR len 1 - {-# INLINE variantEncoder #-} - -instance (GEncodeProduct f) => GEncodeVariant (C1 i f) where - variantEncoder _ !i (M1 a) = varInt i <> productEncoder a - {-# INLINE variantEncoder #-} - -instance GEncodeVariant f => GEncodeVariant (D1 i f) where - variantEncoder len i (M1 a) = variantEncoder len i a - {-# INLINE variantEncoder #-} - -class GSerialiseVariant f where - variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)] - variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))] - -instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where - variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g) - variantExtractor = fmap (fmap (fmap (fmap (fmap L1)))) variantExtractor - ++ fmap (fmap (fmap (fmap (fmap R1)))) variantExtractor - -instance (GSerialiseProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where - variantSchema _ = do - s <- productSchema (Proxy @ f) - return [(T.pack $ symbolVal (Proxy @ name), SProduct $ V.fromList s)] - variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorProduct') ] - -instance (GSerialiseRecord f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where - variantSchema _ = do - s <- recordSchema (Proxy @ f) - return [(T.pack $ symbolVal (Proxy @ name), SRecord $ V.fromList s)] - variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorRecord' "" Nothing) ] - -instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where - variantSchema _ = variantSchema (Proxy @ f) - variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor - -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" +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Provisional +-- +-- Maintainer : Fumiaki Kinoshita +-- +----------------------------------------------------------------------------- +module Codec.Winery + ( Schema + , SchemaP(..) + , Tag(..) + , Serialise(..) + , testSerialise + , DecodeException(..) + , schema + -- * Standalone serialisation + , toBuilderWithSchema + , serialise + , deserialise + , deserialiseBy + , deserialiseTerm + , splitSchema + , writeFileSerialise + , readFileDeserialise + -- * Separate serialisation + , serialiseSchema + , deserialiseSchema + , Extractor(..) + , unwrapExtractor + , Decoder + , evalDecoder + , serialiseOnly + , getDecoder + , getDecoderBy + -- * Decoding combinators + , Term(..) + , encodeTerm + , 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 + , gtoBuilderRecord + , gextractorRecord + , gdecodeCurrentRecord + , GSerialiseVariant + , GConstructorCount + , GEncodeVariant + , GDecodeVariant + , gschemaGenVariant + , gtoBuilderVariant + , gextractorVariant + , gdecodeCurrentVariant + , GEncodeProduct + , GDecodeProduct + , gschemaGenProduct + , gtoBuilderProduct + , gextractorProduct + , gdecodeCurrentProduct + , decodeCurrentDefault + -- * Bundles + , BundleSerialise(..) + , bundleRecord + , bundleRecordDefault + , bundleVariant + -- * Preset schema + , bootstrapSchema + ) where + +import Codec.Winery.Base as W +import Codec.Winery.Class +import Codec.Winery.Internal +import Control.Applicative +import Control.Exception (throw, throwIO) +import qualified Data.ByteString as B +import qualified Data.ByteString.FastBuilder as BB +import qualified Data.ByteString.Lazy as BL +import Data.Function (fix) +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc (pretty, dquotes) +import Data.Typeable +import qualified Data.Vector as V +import GHC.Generics (Generic, Rep) +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 + +encodeTerm :: Term -> BB.Builder +encodeTerm = \case + TBool b -> toBuilder b + TChar x -> toBuilder x + TWord8 x -> toBuilder x + TWord16 x -> toBuilder x + TWord32 x -> toBuilder x + TWord64 x -> toBuilder x + TInt8 x -> toBuilder x + TInt16 x -> toBuilder x + TInt32 x -> toBuilder x + TInt64 x -> toBuilder x + TInteger x -> toBuilder x + TFloat x -> toBuilder x + TDouble x -> toBuilder x + TBytes x -> toBuilder x + TText x -> toBuilder x + TUTCTime x -> toBuilder x + TVector xs -> foldMap encodeTerm xs + TProduct xs -> foldMap encodeTerm xs + TRecord xs -> foldMap (encodeTerm . snd) xs + TVariant tag _ t -> toBuilder tag <> encodeTerm 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) + +-- | 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 + +-- | 'decodeCurrent' in terms of 'extractor'; note that it's very slow. +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 + +-- | 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' then write it to a file. +writeFileSerialise :: Serialise a => FilePath -> a -> IO () +writeFileSerialise path a = withBinaryFile path WriteMode + $ \h -> BB.hPutBuilder h $ toBuilderWithSchema a +{-# INLINE writeFileSerialise #-} + +-- | Serialise a value with the schema. +toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder +toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion) + $ toBuilder (schema (Proxy @ a), a) +{-# INLINE toBuilderWithSchema #-} + +-- | Split a 'Schema' from a 'B.ByteString'. +splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString) +splitSchema bs_ = case B.uncons bs_ of + Just (ver, bs) -> do + m <- bootstrapSchema ver >>= getDecoder + return $ flip evalDecoder bs $ do + sch <- m + Decoder $ \bs' i -> DecoderResult (B.length bs') (sch, B.drop i bs') + 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 + +-- | Deserialise a file. Throws 'WineryException' +readFileDeserialise :: Serialise a => FilePath -> IO a +readFileDeserialise path = B.readFile path >>= either throwIO pure . deserialise + +-- | Deserialise a schema. +deserialiseSchema :: B.ByteString -> Either WineryException Schema +deserialiseSchema bs_ = case B.uncons bs_ of + Just (ver, bs) -> do + m <- bootstrapSchema ver >>= getDecoder + 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 #-} + +-- | Build an extractor from a 'Subextractor'. +buildExtractor :: Typeable a => Subextractor a -> Extractor a +buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e +{-# INLINE buildExtractor #-} + +-- | An extractor for individual fields. This distinction is required for +-- handling recursions correctly. +-- +-- Recommended extension: ApplicativeDo +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 = "Codec.Winery.extractFieldBy ... " <> show name <> ": impossible" + +-- | 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 #-} + +-- | No constructors remaining. +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` + +-- | 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), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where + schemaGen _ = gschemaGenRecord (Proxy @ a) + toBuilder = gtoBuilderRecord . unWineryRecord + extractor = WineryRecord <$> gextractorRecord Nothing + decodeCurrent = WineryRecord <$> gdecodeCurrentRecord + +-- | 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), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where + schemaGen _ = gschemaGenProduct (Proxy @ a) + toBuilder = gtoBuilderProduct . unWineryProduct + extractor = WineryProduct <$> gextractorProduct + decodeCurrent = WineryProduct <$> gdecodeCurrentProduct + +-- | 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 (GConstructorCount (Rep a), GSerialiseVariant (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where + schemaGen _ = gschemaGenVariant (Proxy @ a) + toBuilder = gtoBuilderVariant . unWineryVariant + extractor = WineryVariant <$> gextractorVariant + decodeCurrent = WineryVariant <$> gdecodeCurrentVariant diff --git a/src/Codec/Winery/Base.hs b/src/Codec/Winery/Base.hs --- a/src/Codec/Winery/Base.hs +++ b/src/Codec/Winery/Base.hs @@ -21,9 +21,11 @@ ( Tag(..) , Schema , SchemaP(..) + , SchemaGen(..) , currentSchemaVersion , bootstrapSchema , Term(..) + , ExtractException(..) , Extractor(..) , Strategy' , StrategyBind(..) @@ -31,7 +33,8 @@ , Plan(..) , unwrapExtractor , WineryException(..) - , prettyWineryException) + , prettyWineryException + ) where import Control.Applicative @@ -46,6 +49,7 @@ import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar) import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Time +import qualified Data.Set as S import Data.Typeable import qualified Data.Vector as V import Codec.Winery.Internal @@ -142,6 +146,19 @@ STag t s -> nest 2 $ sep [pretty t <> ":", pretty s] SLet s t -> sep ["let" <+> pretty s, pretty t] +-- | 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 the schema of the schema corresponding to the specified version. bootstrapSchema :: Word8 -> Either WineryException Schema bootstrapSchema 4 = Right @@ -218,6 +235,10 @@ 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) + +-- | This may be thrown if illegal 'Term' is passed to an extractor. +data ExtractException = InvalidTerm !Term deriving Show +instance Exception ExtractException -- | 'Extractor' is a 'Plan' that creates a function to extract a value from Term. -- diff --git a/src/Codec/Winery/Class.hs b/src/Codec/Winery/Class.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Class.hs @@ -0,0 +1,1000 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module Codec.Winery.Class (Serialise(..) + , VarInt(..) + , BundleSerialise(..) + , bundleRecord + , bundleRecordDefault + , bundleVariant + , getSchema + , schema + , unexpectedSchema + , mkPlan + , extractListBy + , gschemaGenRecord + , gtoBuilderRecord + , gextractorRecord + , extractorRecord' + , gdecodeCurrentRecord + , GEncodeProduct(..) + , GDecodeProduct(..) + , GSerialiseRecord(..) + , GSerialiseProduct(..) + , gschemaGenProduct + , gtoBuilderProduct + , gextractorProduct + , gdecodeCurrentProduct + , extractorProduct' + , GConstructorCount(..) + , GDecodeVariant(..) + , GEncodeVariant(..) + , GSerialiseVariant(..) + , gschemaGenVariant + , gtoBuilderVariant + , gextractorVariant + , gdecodeCurrentVariant + ) 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 (Ratio, (%), numerator, denominator) +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 (Down(..)) +import Data.Word +import Codec.Winery.Base as W +import Codec.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 (Void) +import Unsafe.Coerce +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import GHC.Natural +import GHC.Generics +import GHC.TypeLits + +-- | Serialisable datatype +-- +class Typeable a => Serialise a where + -- | Obtain the schema of the datatype. + schemaGen :: Proxy a -> SchemaGen Schema + schemaGen = bundleSchemaGen bundleSerialise + {-# INLINE schemaGen #-} + + -- | Serialise a value. + toBuilder :: a -> BB.Builder + toBuilder = bundleToBuilder bundleSerialise + {-# INLINE toBuilder #-} + + -- | 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 + extractor = bundleExtractor bundleSerialise + {-# INLINE extractor #-} + + -- | Decode a value with the current schema. + -- + -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x + decodeCurrent :: Decoder a + decodeCurrent = bundleDecodeCurrent bundleSerialise + {-# INLINE decodeCurrent #-} + + -- | Instead of the four methods above, you can supply a bundle. + bundleSerialise :: BundleSerialise a + bundleSerialise = BundleSerialise + { bundleSchemaGen = schemaGen + , bundleToBuilder = toBuilder + , bundleExtractor = extractor + , bundleDecodeCurrent = decodeCurrent + } + + {-# MINIMAL schemaGen, toBuilder, extractor, decodeCurrent | bundleSerialise #-} + +-- | A bundle of 'Serialise' methods +data BundleSerialise a = BundleSerialise + { bundleSchemaGen :: Proxy a -> SchemaGen Schema + , bundleToBuilder :: a -> BB.Builder + , bundleExtractor :: Extractor a + , bundleDecodeCurrent :: Decoder a + } + +-- | A bundle of generic implementations for records +bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) + => (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleRecord f = BundleSerialise + { bundleSchemaGen = gschemaGenRecord + , bundleToBuilder = gtoBuilderRecord + , bundleExtractor = f $ gextractorRecord Nothing + , bundleDecodeCurrent = gdecodeCurrentRecord + } +{-# INLINE bundleRecord #-} + +-- | A bundle of generic implementations for records, with a default value +bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) + => a -- default value + -> (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleRecordDefault def f = BundleSerialise + { bundleSchemaGen = gschemaGenRecord + , bundleToBuilder = gtoBuilderRecord + , bundleExtractor = f $ gextractorRecord $ Just def + , bundleDecodeCurrent = gdecodeCurrentRecord + } +{-# INLINE bundleRecordDefault #-} + +-- | A bundle of generic implementations for variants +bundleVariant :: (GSerialiseVariant (Rep a), GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) + => (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleVariant f = BundleSerialise + { bundleSchemaGen = gschemaGenVariant + , bundleToBuilder = gtoBuilderVariant + , bundleExtractor = f $ gextractorVariant + , bundleDecodeCurrent = gdecodeCurrentVariant + } +{-# INLINE bundleVariant #-} + +-- | 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 + +unexpectedSchema :: forall f a. Serialise a => Doc AnsiStyle -> Schema -> Strategy' (f a) +unexpectedSchema subject actual = throwStrategy + $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual + +-- | 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 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 mempty + 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 <$> getBytes 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 = decodeVarInt >>= getBytes + +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 + +-- | 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 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 + +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 = scientific <$> decodeCurrent <*> decodeCurrent + +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 + + +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 mempty + 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" + +-------------------------------------------------------------------------------- + +-- | 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 #-} + +-- | Synonym for 'gdecodeCurrentProduct' +gdecodeCurrentRecord :: (GDecodeProduct (Rep a), Generic a) => Decoder a +gdecodeCurrentRecord = to <$> productDecoder +{-# INLINE gdecodeCurrentRecord #-} + +-- | Encode all the fields +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 GDecodeProduct f where + productDecoder :: Decoder (f x) + +instance GDecodeProduct U1 where + productDecoder = pure U1 + +instance Serialise a => GDecodeProduct (K1 i a) where + productDecoder = K1 <$> decodeCurrent + {-# INLINE productDecoder #-} + +instance GDecodeProduct f => GDecodeProduct (M1 i c f) where + productDecoder = M1 <$> productDecoder + {-# INLINE productDecoder #-} + +instance (GDecodeProduct f, GDecodeProduct g) => GDecodeProduct (f :*: g) where + productDecoder = (:*:) <$> productDecoder <*> productDecoder + {-# INLINE productDecoder #-} + +class GSerialiseRecord f where + recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)] + recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> 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 #-} + +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 #-} + +instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where + recordSchema _ = recordSchema (Proxy @ f) + recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) + +instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where + recordSchema _ = recordSchema (Proxy @ f) + recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) + +class GSerialiseProduct f where + productSchema :: proxy f -> SchemaGen [Schema] + productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x) + +instance GSerialiseProduct U1 where + productSchema _ = pure [] + productExtractor = pure (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) + +instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where + productSchema _ = productSchema (Proxy @ f) + productExtractor = fmap M1 <$> productExtractor + +instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where + productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g) + productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor + +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. (GDecodeProduct (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 + +-- | 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 :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) => a -> BB.Builder +gtoBuilderVariant = variantEncoder (variantCount (Proxy :: Proxy (Rep a))) 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 :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a) => Decoder a +gdecodeCurrentVariant = decodeVarInt >>= fmap to . variantDecoder (variantCount (Proxy :: Proxy (Rep a))) +{-# INLINE gdecodeCurrentVariant #-} + +class GConstructorCount f where + variantCount :: proxy f -> Int + +instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where + variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g) + {-# INLINE variantCount #-} + +instance GConstructorCount (C1 i f) where + variantCount _ = 1 + {-# INLINE variantCount #-} + +instance GConstructorCount f => GConstructorCount (D1 i f) where + variantCount _ = variantCount (Proxy @ f) + {-# INLINE variantCount #-} + +class GDecodeVariant f where + variantDecoder :: Int -> Int -> Decoder (f x) + +instance (GDecodeVariant f, GDecodeVariant g) => GDecodeVariant (f :+: g) where + variantDecoder len i + | i < len' = L1 <$> variantDecoder len' i + | otherwise = R1 <$> variantDecoder (len - len') (i - len') + where + len' = unsafeShiftR len 1 + {-# INLINE variantDecoder #-} + +instance GDecodeProduct f => GDecodeVariant (C1 i f) where + variantDecoder _ _ = M1 <$> productDecoder + {-# INLINE variantDecoder #-} + +instance GDecodeVariant f => GDecodeVariant (D1 i f) where + variantDecoder len i = M1 <$> variantDecoder len i + {-# INLINE variantDecoder #-} + +class GEncodeVariant f where + variantEncoder :: Int -> Int -> f x -> BB.Builder + +instance (GEncodeVariant f, GEncodeVariant g) => GEncodeVariant (f :+: g) where + variantEncoder len i (L1 f) = variantEncoder (unsafeShiftR len 1) i f + variantEncoder len i (R1 g) = variantEncoder (len - len') (i + len') g + where + len' = unsafeShiftR len 1 + {-# INLINE variantEncoder #-} + +instance (GEncodeProduct f) => GEncodeVariant (C1 i f) where + variantEncoder _ !i (M1 a) = varInt i <> productEncoder a + {-# INLINE variantEncoder #-} + +instance GEncodeVariant f => GEncodeVariant (D1 i f) where + variantEncoder len i (M1 a) = variantEncoder len i a + {-# INLINE variantEncoder #-} + +class GSerialiseVariant f where + variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)] + variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))] + +instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where + variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g) + variantExtractor = fmap (fmap (fmap (fmap (fmap L1)))) variantExtractor + ++ fmap (fmap (fmap (fmap (fmap R1)))) variantExtractor + +instance (GSerialiseProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where + variantSchema _ = do + s <- productSchema (Proxy @ f) + return [(T.pack $ symbolVal (Proxy @ name), SProduct $ V.fromList s)] + variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorProduct') ] + +instance (GSerialiseRecord f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where + variantSchema _ = do + s <- recordSchema (Proxy @ f) + return [(T.pack $ symbolVal (Proxy @ name), SRecord $ V.fromList s)] + variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorRecord' "" Nothing) ] + +instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where + variantSchema _ = variantSchema (Proxy @ f) + variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -81,20 +81,14 @@ arbitrary = TRec <$> arbitrary <*> arbitrary instance Serialise TRec where - schemaGen = gschemaGenRecord - toBuilder = gtoBuilderRecord - extractor = gextractorRecord Nothing - decodeCurrent = gdecodeCurrentRecord + bundleSerialise = bundleRecord id 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 + bundleSerialise = bundleVariant id instance Arbitrary a => Arbitrary (TList a) where arbitrary = sized $ \n -> if n <= 0 @@ -123,23 +117,26 @@ Node <$> resize leftSize arbitrary <*> arbitrary <*> resize rightSize arbitrary instance Serialise Tree where - schemaGen = gschemaGenVariant - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant + bundleSerialise = bundleVariant id instance Serialise Node where - schemaGen = gschemaGenRecord - toBuilder = gtoBuilderRecord - extractor = buildExtractor $ Node + bundleSerialise = bundleRecord $ const $ 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 + +data Foo = Foo | Bar | Baz | Qux | FooBar | FooBaz | FooQux deriving (Generic, Eq, Show, Enum) + +instance Arbitrary Foo where + arbitrary = toEnum <$> Gen.choose (0, 6) + +instance Serialise Foo where + bundleSerialise = bundleVariant id + +prop_Foo = testSerialise @ Foo return [] main = void $ $quickCheckAll diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: winery -version: 1.1.1 +version: 1.1.2 synopsis: A compact, well-typed seralisation format for Haskell values description: <> @@ -32,6 +32,7 @@ exposed-modules: Codec.Winery Codec.Winery.Base + Codec.Winery.Class Codec.Winery.Internal Codec.Winery.Query Codec.Winery.Query.Parser @@ -123,6 +124,7 @@ , winery , binary , serialise + , store , text , bytestring , deepseq