{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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 <fumiexcel@gmail.com>
--
-----------------------------------------------------------------------------
module Codec.Winery
  ( Schema
  , SchemaP(..)
  , Tag(..)
  , Serialise(..)
  , testSerialise
  , DecodeException(..)
  , schema
  -- * Standalone serialisation
  , toBuilderWithSchema
  , serialise
  , deserialise
  , deserialiseBy
  , deserialiseTerm
  , splitSchema
  , writeFileSerialise
  , readFileDeserialise
  -- * Separate serialisation
  , serialiseSchema
  , schemaToBuilder
  , deserialiseSchema
  , Extractor(..)
  , mkExtractor
  , unwrapExtractor
  , Decoder
  , evalDecoder
  , serialiseOnly
  , getDecoder
  , getDecoderBy
  -- * Decoding combinators
  , Term(..)
  , encodeTerm
  , Subextractor(..)
  , buildExtractor
  , extractListBy
  , extractField
  , extractFieldBy
  , extractConstructor
  , extractConstructorBy
  , extractProductItemBy
  , extractVoid
  , buildVariantExtractor
  , buildRecordExtractor
  , bextractors
  , buildRecordExtractorF
  , bextractorsF
  , ExtractException(..)
  , SingleField(..)
  -- * Variable-length quantity
  , VarInt(..)
  -- * Internal
  , WineryException(..)
  , prettyWineryException
  , unexpectedSchema
  , SchemaGen
  , getSchema
  -- * DerivingVia
  , WineryRecord(..)
  , WineryVariant(..)
  , WineryProduct(..)
  -- * Generic implementations (for old GHC / custom instances)
  , GSerialiseRecord
  , gschemaGenRecord
  , gtoBuilderRecord
  , gextractorRecord
  , gdecodeCurrentRecord
  , GSerialiseVariant
  , GConstructorCount
  , GEncodeVariant
  , GDecodeVariant
  , gschemaGenVariant
  , gtoBuilderVariant
  , gextractorVariant
  , gdecodeCurrentVariant
  , gvariantExtractors
  , GEncodeProduct
  , GDecodeProduct
  , gschemaGenProduct
  , gtoBuilderProduct
  , gextractorProduct
  , gdecodeCurrentProduct
  , decodeCurrentDefault
  -- * Bundles
  , BundleSerialise(..)
  , bundleRecord
  , bundleRecordDefault
  , bundleVariant
  , bundleVia
  -- * Preset schema
  , bootstrapSchema
  ) where

import Codec.Winery.Base as W
import Codec.Winery.Class
import Codec.Winery.Internal
import Control.Exception (throw, throwIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.FastBuilder as BB
import Data.Coerce
import Data.Function (fix)
import qualified Data.Text as T
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 :: Schema -> Decoder Term
decodeTerm = [Decoder Term] -> Schema -> Decoder Term
go [] where
  go :: [Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points = \case
    Schema
SBool -> Bool -> Term
TBool (Bool -> Term) -> Decoder Bool -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Bool
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
W.SChar -> Char -> Term
TChar (Char -> Term) -> Decoder Char -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Char
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SWord8 -> Word8 -> Term
TWord8 (Word8 -> Term) -> Decoder Word8 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Word8
getWord8
    Schema
SWord16 -> Word16 -> Term
TWord16 (Word16 -> Term) -> Decoder Word16 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Word16
getWord16
    Schema
SWord32 -> Word32 -> Term
TWord32 (Word32 -> Term) -> Decoder Word32 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Word32
getWord32
    Schema
SWord64 -> Word64 -> Term
TWord64 (Word64 -> Term) -> Decoder Word64 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Word64
getWord64
    Schema
SInt8 -> Int8 -> Term
TInt8 (Int8 -> Term) -> Decoder Int8 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Int8
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SInt16 -> Int16 -> Term
TInt16 (Int16 -> Term) -> Decoder Int16 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Int16
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SInt32 -> Int32 -> Term
TInt32 (Int32 -> Term) -> Decoder Int32 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Int32
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SInt64 -> Int64 -> Term
TInt64 (Int64 -> Term) -> Decoder Int64 -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Int64
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SInteger -> Integer -> Term
TInteger (Integer -> Term) -> Decoder Integer -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Integer
forall a. (Num a, Bits a) => Decoder a
decodeVarInt
    Schema
SFloat -> Float -> Term
TFloat (Float -> Term) -> Decoder Float -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Float
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SDouble -> Double -> Term
TDouble (Double -> Term) -> Decoder Double -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Double
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SBytes -> ByteString -> Term
TBytes (ByteString -> Term) -> Decoder ByteString -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder ByteString
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
W.SText -> Text -> Term
TText (Text -> Term) -> Decoder Text -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Text
forall a. Serialise a => Decoder a
decodeCurrent
    Schema
SUTCTime -> UTCTime -> Term
TUTCTime (UTCTime -> Term) -> Decoder UTCTime -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder UTCTime
forall a. Serialise a => Decoder a
decodeCurrent
    SVector Schema
sch -> do
      Int
n <- Decoder Int
forall a. (Num a, Bits a) => Decoder a
decodeVarInt
      Vector Term -> Term
TVector (Vector Term -> Term) -> Decoder (Vector Term) -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder Term -> Decoder (Vector Term)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
n ([Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points Schema
sch)
    SProduct Vector Schema
schs -> Vector Term -> Term
TProduct (Vector Term -> Term) -> Decoder (Vector Term) -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Schema -> Decoder Term) -> Vector Schema -> Decoder (Vector Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points) Vector Schema
schs
    SRecord Vector (Text, Schema)
schs -> Vector (Text, Term) -> Term
TRecord (Vector (Text, Term) -> Term)
-> Decoder (Vector (Text, Term)) -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Schema) -> Decoder (Text, Term))
-> Vector (Text, Schema) -> Decoder (Vector (Text, Term))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Text
k, Schema
s) -> (,) Text
k (Term -> (Text, Term)) -> Decoder Term -> Decoder (Text, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points Schema
s) Vector (Text, Schema)
schs
    SVariant Vector (Text, Schema)
schs -> do
      let !decoders :: Vector (Text, Decoder Term)
decoders = ((Text, Schema) -> (Text, Decoder Term))
-> Vector (Text, Schema) -> Vector (Text, Decoder Term)
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\(Text
name, Schema
sch) -> let !m :: Decoder Term
m = [Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points Schema
sch in (Text
name, Decoder Term
m)) Vector (Text, Schema)
schs
      Int
tag <- Decoder Int
forall a. (Num a, Bits a) => Decoder a
decodeVarInt
      let (Text
name, Decoder Term
dec) = (Text, Decoder Term)
-> ((Text, Decoder Term) -> (Text, Decoder Term))
-> Maybe (Text, Decoder Term)
-> (Text, Decoder Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DecodeException -> (Text, Decoder Term)
forall a e. Exception e => e -> a
throw DecodeException
InvalidTag) (Text, Decoder Term) -> (Text, Decoder Term)
forall a. a -> a
id (Maybe (Text, Decoder Term) -> (Text, Decoder Term))
-> Maybe (Text, Decoder Term) -> (Text, Decoder Term)
forall a b. (a -> b) -> a -> b
$ Vector (Text, Decoder Term)
decoders Vector (Text, Decoder Term) -> Int -> Maybe (Text, Decoder Term)
forall a. Vector a -> Int -> Maybe a
V.!? Int
tag
      Int -> Text -> Term -> Term
TVariant Int
tag Text
name (Term -> Term) -> Decoder Term -> Decoder Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder Term
dec
    SVar Int
i -> Decoder Term -> [Decoder Term] -> Int -> Decoder Term
forall a. a -> [a] -> Int -> a
indexDefault (DecodeException -> Decoder Term
forall a e. Exception e => e -> a
throw DecodeException
InvalidTag) [Decoder Term]
points Int
i
    SFix Schema
s' -> (Decoder Term -> Decoder Term) -> Decoder Term
forall a. (a -> a) -> a
fix ((Decoder Term -> Decoder Term) -> Decoder Term)
-> (Decoder Term -> Decoder Term) -> Decoder Term
forall a b. (a -> b) -> a -> b
$ \Decoder Term
a -> [Decoder Term] -> Schema -> Decoder Term
go (Decoder Term
a Decoder Term -> [Decoder Term] -> [Decoder Term]
forall a. a -> [a] -> [a]
: [Decoder Term]
points) Schema
s'
    STag Tag
_ Schema
s -> [Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points Schema
s
    SLet Schema
s Schema
t -> [Decoder Term] -> Schema -> Decoder Term
go ([Decoder Term] -> Schema -> Decoder Term
go [Decoder Term]
points Schema
s Decoder Term -> [Decoder Term] -> [Decoder Term]
forall a. a -> [a] -> [a]
: [Decoder Term]
points) Schema
t

encodeTerm :: Term -> BB.Builder
encodeTerm :: Term -> Builder
encodeTerm = \case
  TBool Bool
b -> Bool -> Builder
forall a. Serialise a => a -> Builder
toBuilder Bool
b
  TChar Char
x -> Char -> Builder
forall a. Serialise a => a -> Builder
toBuilder Char
x
  TWord8 Word8
x -> Word8 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Word8
x
  TWord16 Word16
x -> Word16 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Word16
x
  TWord32 Word32
x -> Word32 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Word32
x
  TWord64 Word64
x -> Word64 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Word64
x
  TInt8 Int8
x -> Int8 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Int8
x
  TInt16 Int16
x -> Int16 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Int16
x
  TInt32 Int32
x -> Int32 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Int32
x
  TInt64 Int64
x -> Int64 -> Builder
forall a. Serialise a => a -> Builder
toBuilder Int64
x
  TInteger Integer
x -> Integer -> Builder
forall a. Serialise a => a -> Builder
toBuilder Integer
x
  TFloat Float
x -> Float -> Builder
forall a. Serialise a => a -> Builder
toBuilder Float
x
  TDouble Double
x -> Double -> Builder
forall a. Serialise a => a -> Builder
toBuilder Double
x
  TBytes ByteString
x -> ByteString -> Builder
forall a. Serialise a => a -> Builder
toBuilder ByteString
x
  TText Text
x -> Text -> Builder
forall a. Serialise a => a -> Builder
toBuilder Text
x
  TUTCTime UTCTime
x -> UTCTime -> Builder
forall a. Serialise a => a -> Builder
toBuilder UTCTime
x
  TVector Vector Term
xs -> (Term -> Builder) -> Vector Term -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term -> Builder
encodeTerm Vector Term
xs
  TProduct Vector Term
xs -> (Term -> Builder) -> Vector Term -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term -> Builder
encodeTerm Vector Term
xs
  TRecord Vector (Text, Term)
xs -> ((Text, Term) -> Builder) -> Vector (Text, Term) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Term -> Builder
encodeTerm (Term -> Builder)
-> ((Text, Term) -> Term) -> (Text, Term) -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Term) -> Term
forall a b. (a, b) -> b
snd) Vector (Text, Term)
xs
  TVariant Int
tag Text
_ Term
t -> Int -> Builder
forall a. Serialise a => a -> Builder
toBuilder Int
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Term -> Builder
encodeTerm Term
t

-- | Deserialise a 'serialise'd 'B.Bytestring'.
deserialiseTerm :: B.ByteString -> Either WineryException (Schema, Term)
deserialiseTerm :: ByteString -> Either WineryException (Schema, Term)
deserialiseTerm ByteString
bs_ = do
  (Schema
sch, ByteString
bs) <- ByteString -> Either WineryException (Schema, ByteString)
splitSchema ByteString
bs_
  (Schema, Term) -> Either WineryException (Schema, Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema
sch, Schema -> Decoder Term
decodeTerm Schema
sch Decoder Term -> ByteString -> Term
forall a. Decoder a -> ByteString -> a
`evalDecoder` ByteString
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 :: a -> Property
testSerialise a
x = case Extractor a -> Schema -> Either WineryException (Decoder a)
forall a.
Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy Extractor a
forall a. Serialise a => Extractor a
extractor (Proxy a -> Schema
forall (proxy :: * -> *) a. Serialise a => proxy a -> Schema
schema (Proxy a
forall k (t :: k). Proxy t
Proxy @ a)) of
  Left WineryException
e -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample (WineryException -> String
forall a. Show a => a -> String
show WineryException
e) Bool
False
  Right Decoder a
f -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample String
"extractor" (Decoder a -> ByteString -> a
forall a. Decoder a -> ByteString -> a
evalDecoder Decoder a
f ByteString
b a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== a
x)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample String
"decodeCurrent" (Decoder a -> ByteString -> a
forall a. Decoder a -> ByteString -> a
evalDecoder Decoder a
forall a. Serialise a => Decoder a
decodeCurrent ByteString
b a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== a
x)
  where
    b :: ByteString
b = a -> ByteString
forall a. Serialise a => a -> ByteString
serialiseOnly a
x

-- | 'decodeCurrent' in terms of 'extractor'; note that it's very slow.
decodeCurrentDefault :: forall a. Serialise a => Decoder a
decodeCurrentDefault :: Decoder a
decodeCurrentDefault = case Extractor a -> Schema -> Either WineryException (Decoder a)
forall a.
Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy Extractor a
forall a. Serialise a => Extractor a
extractor (Proxy a -> Schema
forall (proxy :: * -> *) a. Serialise a => proxy a -> Schema
schema (Proxy a
forall k (t :: k). Proxy t
Proxy @ a)) of
  Left WineryException
err -> String -> Decoder a
forall a. HasCallStack => String -> a
error (String -> Decoder a) -> String -> Decoder a
forall a b. (a -> b) -> a -> b
$ String
"decodeCurrentDefault: failed to get a decoder from the current schema"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ WineryException -> String
forall a. Show a => a -> String
show WineryException
err
  Right Decoder a
a -> Decoder 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 :: Schema -> Either WineryException (Decoder a)
getDecoder Schema
sch
  | Schema
sch Schema -> Schema -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy a -> Schema
forall (proxy :: * -> *) a. Serialise a => proxy a -> Schema
schema (Proxy a
forall k (t :: k). Proxy t
Proxy @ a) = Decoder a -> Either WineryException (Decoder a)
forall a b. b -> Either a b
Right Decoder a
forall a. Serialise a => Decoder a
decodeCurrent
  | Bool
otherwise = Extractor a -> Schema -> Either WineryException (Decoder a)
forall a.
Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy Extractor a
forall a. Serialise a => Extractor a
extractor Schema
sch
{-# INLINE getDecoder #-}

-- | Get a decoder from a `Extractor` and a schema.
getDecoderBy :: Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy :: Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy (Extractor Schema -> Strategy' (Term -> a)
plan) Schema
sch = (\Term -> a
f -> Term -> a
f (Term -> a) -> Decoder Term -> Decoder a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> Decoder Term
decodeTerm Schema
sch)
  ((Term -> a) -> Decoder a)
-> Either WineryException (Term -> a)
-> Either WineryException (Decoder a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> Strategy' (Term -> a)
plan Schema
sch Strategy' (Term -> a)
-> StrategyEnv -> Either WineryException (Term -> a)
forall e r a. Strategy e r a -> r -> Either e a
`unStrategy` Int -> [StrategyBind] -> StrategyEnv
StrategyEnv Int
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 :: a -> ByteString
serialise = Builder -> ByteString
BB.toStrictByteString (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Serialise a => a -> Builder
toBuilderWithSchema
{-# INLINE serialise #-}

-- | 'serialise' then write it to a file.
writeFileSerialise :: Serialise a => FilePath -> a -> IO ()
writeFileSerialise :: String -> a -> IO ()
writeFileSerialise String
path a
a = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
WriteMode
  ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Builder -> IO ()
BB.hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Builder
forall a. Serialise a => a -> Builder
toBuilderWithSchema a
a
{-# INLINE writeFileSerialise #-}

-- | Serialise a value with the schema.
toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder
toBuilderWithSchema :: a -> Builder
toBuilderWithSchema a
a = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Word8 -> Builder
BB.word8 Word8
currentSchemaVersion)
  (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ (Schema, a) -> Builder
forall a. Serialise a => a -> Builder
toBuilder (Proxy a -> Schema
forall (proxy :: * -> *) a. Serialise a => proxy a -> Schema
schema (Proxy a
forall k (t :: k). Proxy t
Proxy @ a), a
a)
{-# INLINE toBuilderWithSchema #-}

-- | Split a 'Schema' from a 'B.ByteString'.
splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString)
splitSchema :: ByteString -> Either WineryException (Schema, ByteString)
splitSchema ByteString
bs_ = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs_ of
  Just (Word8
ver, ByteString
bs) -> do
    Decoder Schema
m <- Word8 -> Either WineryException Schema
bootstrapSchema Word8
ver Either WineryException Schema
-> (Schema -> Either WineryException (Decoder Schema))
-> Either WineryException (Decoder Schema)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema -> Either WineryException (Decoder Schema)
forall a.
Serialise a =>
Schema -> Either WineryException (Decoder a)
getDecoder
    (Schema, ByteString) -> Either WineryException (Schema, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Schema, ByteString)
 -> Either WineryException (Schema, ByteString))
-> (Schema, ByteString)
-> Either WineryException (Schema, ByteString)
forall a b. (a -> b) -> a -> b
$ (Decoder (Schema, ByteString)
 -> ByteString -> (Schema, ByteString))
-> ByteString
-> Decoder (Schema, ByteString)
-> (Schema, ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Decoder (Schema, ByteString) -> ByteString -> (Schema, ByteString)
forall a. Decoder a -> ByteString -> a
evalDecoder ByteString
bs (Decoder (Schema, ByteString) -> (Schema, ByteString))
-> Decoder (Schema, ByteString) -> (Schema, ByteString)
forall a b. (a -> b) -> a -> b
$ do
      Schema
sch <- Decoder Schema
m
      (ByteString -> Int -> DecoderResult (Schema, ByteString))
-> Decoder (Schema, ByteString)
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult (Schema, ByteString))
 -> Decoder (Schema, ByteString))
-> (ByteString -> Int -> DecoderResult (Schema, ByteString))
-> Decoder (Schema, ByteString)
forall a b. (a -> b) -> a -> b
$ \ByteString
bs' Int
i -> Int -> (Schema, ByteString) -> DecoderResult (Schema, ByteString)
forall a. Int -> a -> DecoderResult a
DecoderResult (ByteString -> Int
B.length ByteString
bs') (Schema
sch, Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs')
  Maybe (Word8, ByteString)
Nothing -> WineryException -> Either WineryException (Schema, ByteString)
forall a b. a -> Either a b
Left WineryException
EmptyInput

-- | Serialise a schema (prefix with the version number only).
serialiseSchema :: Schema -> B.ByteString
serialiseSchema :: Schema -> ByteString
serialiseSchema = Builder -> ByteString
BB.toStrictByteString (Builder -> ByteString)
-> (Schema -> Builder) -> Schema -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Builder
schemaToBuilder

schemaToBuilder :: Schema -> BB.Builder
schemaToBuilder :: Schema -> Builder
schemaToBuilder = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Word8 -> Builder
BB.word8 Word8
currentSchemaVersion) (Builder -> Builder) -> (Schema -> Builder) -> Schema -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Builder
forall a. Serialise a => a -> Builder
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 :: ByteString -> Either WineryException a
deserialise ByteString
bs_ = do
  (Schema
sch, ByteString
bs) <- ByteString -> Either WineryException (Schema, ByteString)
splitSchema ByteString
bs_
  Decoder a
dec <- Schema -> Either WineryException (Decoder a)
forall a.
Serialise a =>
Schema -> Either WineryException (Decoder a)
getDecoder Schema
sch
  a -> Either WineryException a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either WineryException a) -> a -> Either WineryException a
forall a b. (a -> b) -> a -> b
$ Decoder a -> ByteString -> a
forall a. Decoder a -> ByteString -> a
evalDecoder Decoder a
dec ByteString
bs
{-# INLINE deserialise #-}

-- | Deserialise a 'serialise'd 'B.Bytestring' using an 'Extractor'.
deserialiseBy :: Extractor a -> B.ByteString -> Either WineryException a
deserialiseBy :: Extractor a -> ByteString -> Either WineryException a
deserialiseBy Extractor a
e ByteString
bs_ = do
  (Schema
sch, ByteString
bs) <- ByteString -> Either WineryException (Schema, ByteString)
splitSchema ByteString
bs_
  Decoder a
dec <- Extractor a -> Schema -> Either WineryException (Decoder a)
forall a.
Extractor a -> Schema -> Either WineryException (Decoder a)
getDecoderBy Extractor a
e Schema
sch
  a -> Either WineryException a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either WineryException a) -> a -> Either WineryException a
forall a b. (a -> b) -> a -> b
$ Decoder a -> ByteString -> a
forall a. Decoder a -> ByteString -> a
evalDecoder Decoder a
dec ByteString
bs

-- | Deserialise a file. Throws 'WineryException'
readFileDeserialise :: Serialise a => FilePath -> IO a
readFileDeserialise :: String -> IO a
readFileDeserialise String
path = String -> IO ByteString
B.readFile String
path IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WineryException -> IO a)
-> (a -> IO a) -> Either WineryException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either WineryException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WineryException a -> IO a)
-> (ByteString -> Either WineryException a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either WineryException a
forall a. Serialise a => ByteString -> Either WineryException a
deserialise

-- | Deserialise a schema.
deserialiseSchema :: B.ByteString -> Either WineryException Schema
deserialiseSchema :: ByteString -> Either WineryException Schema
deserialiseSchema ByteString
bs_ = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs_ of
  Just (Word8
ver, ByteString
bs) -> do
    Decoder Schema
m <- Word8 -> Either WineryException Schema
bootstrapSchema Word8
ver Either WineryException Schema
-> (Schema -> Either WineryException (Decoder Schema))
-> Either WineryException (Decoder Schema)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema -> Either WineryException (Decoder Schema)
forall a.
Serialise a =>
Schema -> Either WineryException (Decoder a)
getDecoder
    Schema -> Either WineryException Schema
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> Either WineryException Schema)
-> Schema -> Either WineryException Schema
forall a b. (a -> b) -> a -> b
$ Decoder Schema -> ByteString -> Schema
forall a. Decoder a -> ByteString -> a
evalDecoder Decoder Schema
m ByteString
bs
  Maybe (Word8, ByteString)
Nothing -> WineryException -> Either WineryException Schema
forall a b. a -> Either a b
Left WineryException
EmptyInput

-- | Serialise a value without its schema.
--
-- /"Any unsaved progress will be lost."/
serialiseOnly :: Serialise a => a -> B.ByteString
serialiseOnly :: a -> ByteString
serialiseOnly = Builder -> ByteString
BB.toStrictByteString (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Serialise a => a -> Builder
toBuilder
{-# INLINE serialiseOnly #-}

-- | Extract a field using the supplied 'Extractor'.
extractProductItemBy :: Extractor a -> Int -> Subextractor a
extractProductItemBy :: Extractor a -> Int -> Subextractor a
extractProductItemBy (Extractor Schema -> Strategy' (Term -> a)
g) Int
i = Extractor a -> Subextractor a
forall a. Extractor a -> Subextractor a
Subextractor (Extractor a -> Subextractor a) -> Extractor a -> Subextractor a
forall a b. (a -> b) -> a -> b
$ (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> a)) -> Extractor a)
-> (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a b. (a -> b) -> a -> b
$ \case
  SProduct Vector Schema
schs -> case Vector Schema
schs Vector Schema -> Int -> Maybe Schema
forall a. Vector a -> Int -> Maybe a
V.!? Int
i of
    Just Schema
sch -> do
      Term -> a
m <- Schema -> Strategy' (Term -> a)
g Schema
sch
      (Term -> a) -> Strategy' (Term -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> a) -> Strategy' (Term -> a))
-> (Term -> a) -> Strategy' (Term -> a)
forall a b. (a -> b) -> a -> b
$ \case
        t :: Term
t@(TProduct Vector Term
xs) -> a -> (Term -> a) -> Maybe Term -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExtractException -> a
forall a e. Exception e => e -> a
throw (ExtractException -> a) -> ExtractException -> a
forall a b. (a -> b) -> a -> b
$ Term -> ExtractException
InvalidTerm Term
t) Term -> a
m (Maybe Term -> a) -> Maybe Term -> a
forall a b. (a -> b) -> a -> b
$ Vector Term
xs Vector Term -> Int -> Maybe Term
forall a. Vector a -> Int -> Maybe a
V.!? Int
i
        Term
t -> ExtractException -> a
forall a e. Exception e => e -> a
throw (ExtractException -> a) -> ExtractException -> a
forall a b. (a -> b) -> a -> b
$ Term -> ExtractException
InvalidTerm Term
t
    Maybe Schema
_ -> WineryException -> Strategy' (Term -> a)
forall e r a. e -> Strategy e r a
throwStrategy (WineryException -> Strategy' (Term -> a))
-> WineryException -> Strategy' (Term -> a)
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> Int -> WineryException
ProductTooSmall [] Int
i
  Schema
s -> WineryException -> Strategy' (Term -> a)
forall e r a. e -> Strategy e r a
throwStrategy (WineryException -> Strategy' (Term -> a))
-> WineryException -> Strategy' (Term -> a)
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> Doc AnsiStyle -> Schema -> WineryException
UnexpectedSchema [] Doc AnsiStyle
"a record" Schema
s

-- | 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 :: (Extractor a, Text, a -> r) -> Subextractor r -> Subextractor r
extractConstructorBy (Extractor a
d, Text
name, a -> r
f) Subextractor r
cont = Extractor r -> Subextractor r
forall a. Extractor a -> Subextractor a
Subextractor (Extractor r -> Subextractor r) -> Extractor r -> Subextractor r
forall a b. (a -> b) -> a -> b
$ (Schema -> Strategy' (Term -> r)) -> Extractor r
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> r)) -> Extractor r)
-> (Schema -> Strategy' (Term -> r)) -> Extractor r
forall a b. (a -> b) -> a -> b
$ \case
  SVariant Vector (Text, Schema)
schs0 -> (StrategyEnv -> Either WineryException (Term -> r))
-> Strategy' (Term -> r)
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((StrategyEnv -> Either WineryException (Term -> r))
 -> Strategy' (Term -> r))
-> (StrategyEnv -> Either WineryException (Term -> r))
-> Strategy' (Term -> r)
forall a b. (a -> b) -> a -> b
$ \StrategyEnv
decs -> do
    let run :: Extractor x -> Schema -> Either WineryException (Term -> x)
        run :: Extractor x -> Schema -> Either WineryException (Term -> x)
run Extractor x
e Schema
s = Extractor x -> Schema -> Strategy' (Term -> x)
forall a. Extractor a -> Schema -> Strategy' (Term -> a)
runExtractor Extractor x
e Schema
s Strategy' (Term -> x)
-> StrategyEnv -> Either WineryException (Term -> x)
forall e r a. Strategy e r a -> r -> Either e a
`unStrategy` StrategyEnv
decs
    case Text -> Vector (Text, Schema) -> Maybe (Int, Schema)
forall k v. Eq k => k -> Vector (k, v) -> Maybe (Int, v)
lookupWithIndexV Text
name Vector (Text, Schema)
schs0 of
      Just (Int
i, Schema
s) -> do
        Term -> a
dec <- case Schema
s of
          -- Unwrap single-field constructor
          SProduct [Item (Vector Schema)
s'] -> do
            Term -> a
dec <- Extractor a -> Schema -> Strategy' (Term -> a)
forall a. Extractor a -> Schema -> Strategy' (Term -> a)
runExtractor Extractor a
d Item (Vector Schema)
Schema
s' Strategy' (Term -> a)
-> StrategyEnv -> Either WineryException (Term -> a)
forall e r a. Strategy e r a -> r -> Either e a
`unStrategy` StrategyEnv
decs
            (Term -> a) -> Either WineryException (Term -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Term -> a) -> Either WineryException (Term -> a))
-> (Term -> a) -> Either WineryException (Term -> a)
forall a b. (a -> b) -> a -> b
$ \case
              TProduct [Item (Vector Term)
v] -> Term -> a
dec Item (Vector Term)
Term
v
              Term
t -> ExtractException -> a
forall a e. Exception e => e -> a
throw (ExtractException -> a) -> ExtractException -> a
forall a b. (a -> b) -> a -> b
$ Term -> ExtractException
InvalidTerm Term
t
          Schema
_ -> Extractor a -> Schema -> Strategy' (Term -> a)
forall a. Extractor a -> Schema -> Strategy' (Term -> a)
runExtractor Extractor a
d Schema
s Strategy' (Term -> a)
-> StrategyEnv -> Either WineryException (Term -> a)
forall e r a. Strategy e r a -> r -> Either e a
`unStrategy` StrategyEnv
decs
        let rest :: Schema
rest = Vector (Text, Schema) -> Schema
forall a. Vector (Text, SchemaP a) -> SchemaP a
SVariant (Vector (Text, Schema) -> Schema)
-> Vector (Text, Schema) -> Schema
forall a b. (a -> b) -> a -> b
$ ((Text, Schema) -> Bool)
-> Vector (Text, Schema) -> Vector (Text, Schema)
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
name) (Text -> Bool)
-> ((Text, Schema) -> Text) -> (Text, Schema) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Schema) -> Text
forall a b. (a, b) -> a
fst) Vector (Text, Schema)
schs0
        Term -> r
k <- Extractor r -> Schema -> Either WineryException (Term -> r)
forall x.
Extractor x -> Schema -> Either WineryException (Term -> x)
run (Subextractor r -> Extractor r
forall a. Subextractor a -> Extractor a
unSubextractor Subextractor r
cont) Schema
rest
        (Term -> r) -> Either WineryException (Term -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> r) -> Either WineryException (Term -> r))
-> (Term -> r) -> Either WineryException (Term -> r)
forall a b. (a -> b) -> a -> b
$ \case
          TVariant Int
tag Text
name' Term
v
            | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i -> a -> r
f (a -> r) -> a -> r
forall a b. (a -> b) -> a -> b
$ Term -> a
dec Term
v
            -- rest has fewer constructors
            | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i -> Term -> r
k (Int -> Text -> Term -> Term
TVariant (Int
tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
name' Term
v)
          Term
t -> Term -> r
k Term
t
      Maybe (Int, Schema)
_ -> Extractor r -> Schema -> Either WineryException (Term -> r)
forall x.
Extractor x -> Schema -> Either WineryException (Term -> x)
run (Subextractor r -> Extractor r
forall a. Subextractor a -> Extractor a
unSubextractor Subextractor r
cont) (Vector (Text, Schema) -> Schema
forall a. Vector (Text, SchemaP a) -> SchemaP a
SVariant Vector (Text, Schema)
schs0)
  Schema
s -> WineryException -> Strategy' (Term -> r)
forall e r a. e -> Strategy e r a
throwStrategy (WineryException -> Strategy' (Term -> r))
-> WineryException -> Strategy' (Term -> r)
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> Doc AnsiStyle -> Schema -> WineryException
UnexpectedSchema [] Doc AnsiStyle
"a variant" Schema
s

-- | 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 :: (Text, a -> r) -> Subextractor r -> Subextractor r
extractConstructor (Text
name, a -> r
f) = (Extractor a, Text, a -> r) -> Subextractor r -> Subextractor r
forall a r.
Typeable a =>
(Extractor a, Text, a -> r) -> Subextractor r -> Subextractor r
extractConstructorBy (Extractor a
forall a. Serialise a => Extractor a
extractor, Text
name, a -> r
f)
{-# INLINE extractConstructor #-}

-- | No constructors remaining.
extractVoid :: Typeable r => Subextractor r
extractVoid :: Subextractor r
extractVoid = Extractor r -> Subextractor r
forall a. Extractor a -> Subextractor a
Subextractor (Extractor r -> Subextractor r) -> Extractor r -> Subextractor r
forall a b. (a -> b) -> a -> b
$ (Schema -> Strategy' (Term -> r)) -> Extractor r
forall a.
Typeable a =>
(Schema -> Strategy' (Term -> a)) -> Extractor a
mkExtractor ((Schema -> Strategy' (Term -> r)) -> Extractor r)
-> (Schema -> Strategy' (Term -> r)) -> Extractor r
forall a b. (a -> b) -> a -> b
$ \case
  SVariant Vector (Text, Schema)
schs0
    | Vector (Text, Schema) -> Bool
forall a. Vector a -> Bool
V.null Vector (Text, Schema)
schs0 -> (Term -> r) -> Strategy' (Term -> r)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> r) -> Strategy' (Term -> r))
-> (Term -> r) -> Strategy' (Term -> r)
forall a b. (a -> b) -> a -> b
$ ExtractException -> r
forall a e. Exception e => e -> a
throw (ExtractException -> r) -> (Term -> ExtractException) -> Term -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> ExtractException
InvalidTerm
  Schema
s -> WineryException -> Strategy' (Term -> r)
forall e r a. e -> Strategy e r a
throwStrategy (WineryException -> Strategy' (Term -> r))
-> WineryException -> Strategy' (Term -> r)
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> Doc AnsiStyle -> Schema -> WineryException
UnexpectedSchema [] Doc AnsiStyle
"no constructors" Schema
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 { WineryRecord a -> a
unWineryRecord :: a }

instance (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where
  schemaGen :: Proxy (WineryRecord a) -> SchemaGen Schema
schemaGen Proxy (WineryRecord a)
_ = Proxy a -> SchemaGen Schema
forall (proxy :: * -> *) a.
(GSerialiseRecord (Rep a), Generic a, Typeable a) =>
proxy a -> SchemaGen Schema
gschemaGenRecord (Proxy a
forall k (t :: k). Proxy t
Proxy @ a)
  toBuilder :: WineryRecord a -> Builder
toBuilder = a -> Builder
forall a. (GEncodeProduct (Rep a), Generic a) => a -> Builder
gtoBuilderRecord (a -> Builder)
-> (WineryRecord a -> a) -> WineryRecord a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WineryRecord a -> a
forall a. WineryRecord a -> a
unWineryRecord
  extractor :: Extractor (WineryRecord a)
extractor = a -> WineryRecord a
forall a. a -> WineryRecord a
WineryRecord (a -> WineryRecord a) -> Extractor a -> Extractor (WineryRecord a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a -> Extractor a
forall a.
(GSerialiseRecord (Rep a), Generic a, Typeable a) =>
Maybe a -> Extractor a
gextractorRecord Maybe a
forall a. Maybe a
Nothing
  decodeCurrent :: Decoder (WineryRecord a)
decodeCurrent = a -> WineryRecord a
forall a. a -> WineryRecord a
WineryRecord (a -> WineryRecord a) -> Decoder a -> Decoder (WineryRecord a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder a
forall a. (GDecodeProduct (Rep a), Generic a) => Decoder a
gdecodeCurrentRecord
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

-- | Serialise a value as a product (omits field names).
--
-- /"I get ideas about what's essential when packing my suitcase."/
newtype WineryProduct a = WineryProduct { WineryProduct a -> a
unWineryProduct :: a }

instance (GEncodeProduct (Rep a), GSerialiseProduct (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where
  schemaGen :: Proxy (WineryProduct a) -> SchemaGen Schema
schemaGen Proxy (WineryProduct a)
_ = Proxy a -> SchemaGen Schema
forall (proxy :: * -> *) a.
(Generic a, GSerialiseProduct (Rep a)) =>
proxy a -> SchemaGen Schema
gschemaGenProduct (Proxy a
forall k (t :: k). Proxy t
Proxy @ a)
  toBuilder :: WineryProduct a -> Builder
toBuilder = a -> Builder
forall a. (Generic a, GEncodeProduct (Rep a)) => a -> Builder
gtoBuilderProduct (a -> Builder)
-> (WineryProduct a -> a) -> WineryProduct a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WineryProduct a -> a
forall a. WineryProduct a -> a
unWineryProduct
  extractor :: Extractor (WineryProduct a)
extractor = a -> WineryProduct a
forall a. a -> WineryProduct a
WineryProduct (a -> WineryProduct a)
-> Extractor a -> Extractor (WineryProduct a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor a
forall a.
(GSerialiseProduct (Rep a), Generic a, Typeable a) =>
Extractor a
gextractorProduct
  decodeCurrent :: Decoder (WineryProduct a)
decodeCurrent = a -> WineryProduct a
forall a. a -> WineryProduct a
WineryProduct (a -> WineryProduct a) -> Decoder a -> Decoder (WineryProduct a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder a
forall a. (GDecodeProduct (Rep a), Generic a) => Decoder a
gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

-- | 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 { WineryVariant a -> a
unWineryVariant :: a }

instance (GConstructorCount (Rep a), GSerialiseVariant (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where
  schemaGen :: Proxy (WineryVariant a) -> SchemaGen Schema
schemaGen Proxy (WineryVariant a)
_ = Proxy a -> SchemaGen Schema
forall (proxy :: * -> *) a.
(GSerialiseVariant (Rep a), Typeable a, Generic a) =>
proxy a -> SchemaGen Schema
gschemaGenVariant (Proxy a
forall k (t :: k). Proxy t
Proxy @ a)
  toBuilder :: WineryVariant a -> Builder
toBuilder = a -> Builder
forall a.
(GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) =>
a -> Builder
gtoBuilderVariant (a -> Builder)
-> (WineryVariant a -> a) -> WineryVariant a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WineryVariant a -> a
forall a. WineryVariant a -> a
unWineryVariant
  extractor :: Extractor (WineryVariant a)
extractor = a -> WineryVariant a
forall a. a -> WineryVariant a
WineryVariant (a -> WineryVariant a)
-> Extractor a -> Extractor (WineryVariant a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor a
forall a.
(GSerialiseVariant (Rep a), Generic a, Typeable a) =>
Extractor a
gextractorVariant
  decodeCurrent :: Decoder (WineryVariant a)
decodeCurrent = a -> WineryVariant a
forall a. a -> WineryVariant a
WineryVariant (a -> WineryVariant a) -> Decoder a -> Decoder (WineryVariant a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder a
forall a.
(GConstructorCount (Rep a), GEncodeVariant (Rep a),
 GDecodeVariant (Rep a), Generic a) =>
Decoder a
gdecodeCurrentVariant
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

-- | A product with one field. Useful when creating a custom extractor for constructors.
newtype SingleField a = SingleField { SingleField a -> a
getSingleField :: a }
  deriving (Int -> SingleField a -> String -> String
[SingleField a] -> String -> String
SingleField a -> String
(Int -> SingleField a -> String -> String)
-> (SingleField a -> String)
-> ([SingleField a] -> String -> String)
-> Show (SingleField a)
forall a. Show a => Int -> SingleField a -> String -> String
forall a. Show a => [SingleField a] -> String -> String
forall a. Show a => SingleField a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SingleField a] -> String -> String
$cshowList :: forall a. Show a => [SingleField a] -> String -> String
show :: SingleField a -> String
$cshow :: forall a. Show a => SingleField a -> String
showsPrec :: Int -> SingleField a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> SingleField a -> String -> String
Show, SingleField a -> SingleField a -> Bool
(SingleField a -> SingleField a -> Bool)
-> (SingleField a -> SingleField a -> Bool) -> Eq (SingleField a)
forall a. Eq a => SingleField a -> SingleField a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SingleField a -> SingleField a -> Bool
$c/= :: forall a. Eq a => SingleField a -> SingleField a -> Bool
== :: SingleField a -> SingleField a -> Bool
$c== :: forall a. Eq a => SingleField a -> SingleField a -> Bool
Eq, Eq (SingleField a)
Eq (SingleField a)
-> (SingleField a -> SingleField a -> Ordering)
-> (SingleField a -> SingleField a -> Bool)
-> (SingleField a -> SingleField a -> Bool)
-> (SingleField a -> SingleField a -> Bool)
-> (SingleField a -> SingleField a -> Bool)
-> (SingleField a -> SingleField a -> SingleField a)
-> (SingleField a -> SingleField a -> SingleField a)
-> Ord (SingleField a)
SingleField a -> SingleField a -> Bool
SingleField a -> SingleField a -> Ordering
SingleField a -> SingleField a -> SingleField a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (SingleField a)
forall a. Ord a => SingleField a -> SingleField a -> Bool
forall a. Ord a => SingleField a -> SingleField a -> Ordering
forall a. Ord a => SingleField a -> SingleField a -> SingleField a
min :: SingleField a -> SingleField a -> SingleField a
$cmin :: forall a. Ord a => SingleField a -> SingleField a -> SingleField a
max :: SingleField a -> SingleField a -> SingleField a
$cmax :: forall a. Ord a => SingleField a -> SingleField a -> SingleField a
>= :: SingleField a -> SingleField a -> Bool
$c>= :: forall a. Ord a => SingleField a -> SingleField a -> Bool
> :: SingleField a -> SingleField a -> Bool
$c> :: forall a. Ord a => SingleField a -> SingleField a -> Bool
<= :: SingleField a -> SingleField a -> Bool
$c<= :: forall a. Ord a => SingleField a -> SingleField a -> Bool
< :: SingleField a -> SingleField a -> Bool
$c< :: forall a. Ord a => SingleField a -> SingleField a -> Bool
compare :: SingleField a -> SingleField a -> Ordering
$ccompare :: forall a. Ord a => SingleField a -> SingleField a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (SingleField a)
Ord, (forall x. SingleField a -> Rep (SingleField a) x)
-> (forall x. Rep (SingleField a) x -> SingleField a)
-> Generic (SingleField a)
forall x. Rep (SingleField a) x -> SingleField a
forall x. SingleField a -> Rep (SingleField a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (SingleField a) x -> SingleField a
forall a x. SingleField a -> Rep (SingleField a) x
$cto :: forall a x. Rep (SingleField a) x -> SingleField a
$cfrom :: forall a x. SingleField a -> Rep (SingleField a) x
Generic)

instance Serialise a => Serialise (SingleField a) where
  schemaGen :: Proxy (SingleField a) -> SchemaGen Schema
schemaGen = Proxy (SingleField a) -> SchemaGen Schema
forall (proxy :: * -> *) a.
(Generic a, GSerialiseProduct (Rep a)) =>
proxy a -> SchemaGen Schema
gschemaGenProduct
  toBuilder :: SingleField a -> Builder
toBuilder = SingleField a -> Builder
forall a. (Generic a, GEncodeProduct (Rep a)) => a -> Builder
gtoBuilderProduct
  extractor :: Extractor (SingleField a)
extractor = Extractor (SingleField a)
forall a.
(GSerialiseProduct (Rep a), Generic a, Typeable a) =>
Extractor a
gextractorProduct
  decodeCurrent :: Decoder (SingleField a)
decodeCurrent = Decoder (SingleField a)
forall a. (GDecodeProduct (Rep a), Generic a) => Decoder a
gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

-- | Create a 'BundleSerialise' where methods are defined via a wrapper.
bundleVia :: forall a t. (Coercible a t, Serialise t)
  => (a -> t) -- ^ wrapper constructor (e.g. 'WineryRecord')
  -> BundleSerialise a
bundleVia :: (a -> t) -> BundleSerialise a
bundleVia a -> t
_ = BundleSerialise :: forall a.
(Proxy a -> SchemaGen Schema)
-> (a -> Builder) -> Extractor a -> Decoder a -> BundleSerialise a
BundleSerialise
  { bundleSchemaGen :: Proxy a -> SchemaGen Schema
bundleSchemaGen = (Proxy t -> SchemaGen Schema) -> Proxy a -> SchemaGen Schema
coerce (Serialise t => Proxy t -> SchemaGen Schema
forall a. Serialise a => Proxy a -> SchemaGen Schema
schemaGen @t)
  , bundleToBuilder :: a -> Builder
bundleToBuilder = (t -> Builder) -> a -> Builder
coerce (Serialise t => t -> Builder
forall a. Serialise a => a -> Builder
toBuilder @t)
  , bundleExtractor :: Extractor a
bundleExtractor = Extractor t -> Extractor a
coerce (Serialise t => Extractor t
forall a. Serialise a => Extractor a
extractor @t)
  , bundleDecodeCurrent :: Decoder a
bundleDecodeCurrent = Decoder t -> Decoder a
coerce (Serialise t => Decoder t
forall a. Serialise a => Decoder a
decodeCurrent @t)
  }
{-# INLINE bundleVia #-}