winery 1.2 → 1.3
raw patch · 6 files changed
+161/−88 lines, 6 files
Files
- ChangeLog.md +7/−0
- src/Codec/Winery.hs +35/−22
- src/Codec/Winery/Base.hs +26/−11
- src/Codec/Winery/Class.hs +62/−52
- test/Spec.hs +28/−0
- winery.cabal +3/−3
ChangeLog.md view
@@ -1,3 +1,10 @@+## 1.3++* Fixed an incorrect behaviour of `extractConstructor`+* `WineryException` now contains a hierarchy of `TypeRep`s+* Added `gvariantExtractors` and `buildVariantExtractor`+* Added `SingleField`+ ## 1.2 * Removed `Plan` and `mkPlan`
src/Codec/Winery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -40,6 +41,7 @@ , schemaToBuilder , deserialiseSchema , Extractor(..)+ , mkExtractor , unwrapExtractor , Decoder , evalDecoder@@ -58,7 +60,9 @@ , extractConstructorBy , extractProductItemBy , extractVoid+ , buildVariantExtractor , ExtractException(..)+ , SingleField(..) -- * Variable-length quantity , VarInt(..) -- * Internal@@ -85,6 +89,7 @@ , gtoBuilderVariant , gextractorVariant , gdecodeCurrentVariant+ , gvariantExtractors , GEncodeProduct , GDecodeProduct , gschemaGenProduct@@ -110,7 +115,6 @@ import qualified Data.ByteString.FastBuilder as BB 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)@@ -312,13 +316,10 @@ Just (i, sch) -> do m <- g sch return $ \case- TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i+ TRecord xs -> maybe (throw $ InvalidTerm (TRecord xs)) (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"+ _ -> throwStrategy $ FieldNotFound [] name (map fst $ V.toList schs)+ s -> throwStrategy $ UnexpectedSchema [] "a record" s -- | Extract a field using the supplied 'Extractor'. extractProductItemBy :: Extractor a -> Int -> Subextractor a@@ -327,13 +328,10 @@ Just sch -> do m <- g sch return $ \case- TProduct xs -> maybe (error msg) m $ xs V.!? i+ t@(TProduct xs) -> maybe (throw $ InvalidTerm t) m $ xs V.!? i t -> throw $ InvalidTerm t- _ -> throwStrategy $ ProductTooSmall i- s -> throwStrategy $ UnexpectedSchema rep "a record" s- where- rep = "extractProductItemBy ... " <> dquotes (pretty i)- msg = "Codec.Winery.extractProductItemBy ... " <> show i <> ": impossible"+ _ -> throwStrategy $ ProductTooSmall [] i+ s -> throwStrategy $ UnexpectedSchema [] "a record" s -- | Tries to extract a specific constructor of a variant. Useful for -- implementing backward-compatible extractors.@@ -344,19 +342,24 @@ run e s = runExtractor 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'+ dec <- case s of+ -- Unwrap single-field constructor+ SProduct [s'] -> do+ dec <- runExtractor d s' `unStrategy` decs+ pure $ \case+ TProduct [v] -> dec v+ t -> throw $ InvalidTerm t+ _ -> runExtractor d s `unStrategy` decs let rest = SVariant $ V.filter ((/=name) . fst) schs0 k <- run (unSubextractor cont) rest return $ \case- TVariant tag _ v- | tag == j -> f $ dec v+ TVariant tag name' v+ | tag == i -> f $ dec v+ -- rest has fewer constructors+ | tag > i -> k (TVariant (tag - 1) name' v) t -> k t _ -> run (unSubextractor cont) (SVariant schs0)- s -> throwStrategy $ UnexpectedSchema rep "a variant" s- where- rep = "extractConstructorBy ... " <> dquotes (pretty name)+ s -> throwStrategy $ UnexpectedSchema [] "a variant" s -- | Tries to match on a constructor. If it doesn't match (or constructor -- doesn't exist at all), leave it to the successor.@@ -371,7 +374,7 @@ extractVoid = Subextractor $ mkExtractor $ \case SVariant schs0 | V.null schs0 -> return $ throw . InvalidTerm- s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s+ s -> throwStrategy $ UnexpectedSchema [] "no constructors" s infixr 1 `extractConstructorBy` infixr 1 `extractConstructor`@@ -408,3 +411,13 @@ toBuilder = gtoBuilderVariant . unWineryVariant extractor = WineryVariant <$> gextractorVariant decodeCurrent = WineryVariant <$> gdecodeCurrentVariant++-- | A product with one field. Useful when creating a custom extractor for constructors.+newtype SingleField a = SingleField { getSingleField :: a }+ deriving (Show, Eq, Ord, Generic)++instance Serialise a => Serialise (SingleField a) where+ schemaGen = gschemaGenProduct+ toBuilder = gtoBuilderProduct+ extractor = gextractorProduct+ decodeCurrent = gdecodeCurrentProduct
src/Codec/Winery/Base.hs view
@@ -32,6 +32,7 @@ , StrategyEnv(..) , unwrapExtractor , WineryException(..)+ , pushTrace , prettyWineryException ) where@@ -270,12 +271,23 @@ {-# INLINE unwrapExtractor #-} {-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-} --- | Exceptions thrown when by an extractor-data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema- | FieldNotFound !(Doc AnsiStyle) !T.Text ![T.Text]- | TypeMismatch !Int !TypeRep !TypeRep- | ProductTooSmall !Int- | UnboundVariable !Int+pushTrace :: TypeRep -> WineryException -> WineryException+pushTrace t (UnexpectedSchema xs d s) = UnexpectedSchema (t : xs) d s+pushTrace t (FieldNotFound xs f fs) = FieldNotFound (t : xs) f fs+pushTrace t (TypeMismatch xs i u v) = TypeMismatch (t : xs) i u v+pushTrace t (ProductTooSmall xs i) = ProductTooSmall (t : xs) i+pushTrace t (UnboundVariable xs i) = UnboundVariable (t : xs) i+pushTrace _ x = x++prettyTraces :: [TypeRep] -> Doc AnsiStyle+prettyTraces = annotate (color Blue <> bold) . concatWith (\x y -> x <+> "/" <+> y) . map viaShow++-- | Exceptions thrown by an extractor+data WineryException = UnexpectedSchema ![TypeRep] !(Doc AnsiStyle) !Schema+ | FieldNotFound ![TypeRep] !T.Text ![T.Text]+ | TypeMismatch ![TypeRep] !Int !TypeRep !TypeRep+ | ProductTooSmall ![TypeRep] !Int+ | UnboundVariable ![TypeRep] !Int | EmptyInput | WineryMessage !(Doc AnsiStyle) | UnsupportedSchemaVersion !Word8@@ -289,16 +301,19 @@ -- | Pretty-print 'WineryException' prettyWineryException :: WineryException -> Doc AnsiStyle prettyWineryException = \case- UnexpectedSchema subject expected actual -> annotate bold subject+ UnexpectedSchema subject expected actual -> prettyTraces subject <+> "expects" <+> annotate (color Green <> bold) expected <+> "but got " <+> pretty actual- FieldNotFound rep x xs -> rep <> ": field or constructor " <> pretty x <> " not found in " <> pretty xs- TypeMismatch i s t -> "A type mismatch in variable"+ FieldNotFound rep x xs -> prettyTraces rep+ <> ": field or constructor"+ <+> annotate bold (pretty x)+ <+> "not found in " <> pretty xs+ TypeMismatch trace i s t -> prettyTraces trace <> ": A type mismatch in variable" <+> pretty i <> ":" <+> "expected" <> viaShow s <+> "but got " <> viaShow t- ProductTooSmall i -> "The product is too small; expecting " <> pretty i- UnboundVariable i -> "Unbound variable: " <> pretty i+ ProductTooSmall trace i -> prettyTraces trace <> ": The product is too small; expecting " <> pretty i+ UnboundVariable trace i -> prettyTraces trace <> ": Unbound variable: " <> pretty i EmptyInput -> "Unexpected empty string" UnsupportedSchemaVersion i -> "Unsupported schema version: " <> pretty i WineryMessage a -> a
src/Codec/Winery/Class.hs view
@@ -29,6 +29,7 @@ , unexpectedSchema , mkExtractor , extractListBy+ , buildVariantExtractor , gschemaGenRecord , gtoBuilderRecord , gextractorRecord@@ -51,6 +52,7 @@ , gtoBuilderVariant , gextractorVariant , gdecodeCurrentVariant+ , gvariantExtractors ) where import Control.Applicative@@ -90,7 +92,6 @@ 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@@ -220,12 +221,15 @@ 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+unexpectedSchema :: forall f a. Serialise a => Schema -> Strategy' (f a)+unexpectedSchema actual = throwStrategy+ $ UnexpectedSchema [] (pretty $ schema (Proxy @ a)) actual -mkExtractor :: Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a-mkExtractor = Extractor . recursiveStrategy+mkExtractor :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a+mkExtractor = Extractor . fmap addTrail . recursiveStrategy where+ addTrail (Strategy f) = Strategy $ \env -> case f env of+ Left e -> Left $! pushTrace (typeRep (Proxy @ a)) e+ Right a -> Right a {-# INLINE mkExtractor #-} -- | Handle (recursive) schema bindings.@@ -235,11 +239,11 @@ | point : _ <- drop i decs -> case point of BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs) DynDecoder dyn -> case fromDynamic dyn of- Nothing -> Left $ TypeMismatch i+ Nothing -> Left $ TypeMismatch [] i (typeRep (Proxy @ (Term -> a))) (dynTypeRep dyn) Just a -> Right a- | otherwise -> Left $ UnboundVariable i+ | otherwise -> Left $ UnboundVariable [] i SFix s -> mfix $ \a -> recursiveStrategy k s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs) SLet s t -> recursiveStrategy k t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs) s -> k s `unStrategy` StrategyEnv ofs decs@@ -272,7 +276,7 @@ SBool -> pure $ \case TBool b -> b t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Bool" s+ s -> unexpectedSchema s decodeCurrent = (/=0) <$> getWord8 instance Serialise Word8 where@@ -283,7 +287,7 @@ SWord8 -> pure $ \case TWord8 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Word8" s+ s -> unexpectedSchema s decodeCurrent = getWord8 instance Serialise Word16 where@@ -294,7 +298,7 @@ SWord16 -> pure $ \case TWord16 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Word16" s+ s -> unexpectedSchema s decodeCurrent = getWord16 instance Serialise Word32 where@@ -305,7 +309,7 @@ SWord32 -> pure $ \case TWord32 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Word32" s+ s -> unexpectedSchema s decodeCurrent = getWord32 instance Serialise Word64 where@@ -316,7 +320,7 @@ SWord64 -> pure $ \case TWord64 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Word64" s+ s -> unexpectedSchema s decodeCurrent = getWord64 instance Serialise Word where@@ -327,7 +331,7 @@ SWord64 -> pure $ \case TWord64 i -> fromIntegral i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Word" s+ s -> unexpectedSchema s decodeCurrent = fromIntegral <$> getWord64 instance Serialise Int8 where@@ -338,7 +342,7 @@ SInt8 -> pure $ \case TInt8 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Int8" s+ s -> unexpectedSchema s decodeCurrent = fromIntegral <$> getWord8 instance Serialise Int16 where@@ -349,7 +353,7 @@ SInt16 -> pure $ \case TInt16 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Int16" s+ s -> unexpectedSchema s decodeCurrent = fromIntegral <$> getWord16 instance Serialise Int32 where@@ -360,7 +364,7 @@ SInt32 -> pure $ \case TInt32 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Int32" s+ s -> unexpectedSchema s decodeCurrent = fromIntegral <$> getWord32 instance Serialise Int64 where@@ -371,7 +375,7 @@ SInt64 -> pure $ \case TInt64 i -> i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Int64" s+ s -> unexpectedSchema s decodeCurrent = fromIntegral <$> getWord64 instance Serialise Int where@@ -382,7 +386,7 @@ SInteger -> pure $ \case TInteger i -> fromIntegral i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Int" s+ s -> unexpectedSchema s decodeCurrent = decodeVarIntFinite instance Serialise Float where@@ -393,7 +397,7 @@ SFloat -> pure $ \case TFloat x -> x t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Float" s+ s -> unexpectedSchema s decodeCurrent = castWord32ToFloat <$> getWord32 instance Serialise Double where@@ -404,7 +408,7 @@ SDouble -> pure $ \case TDouble x -> x t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Double" s+ s -> unexpectedSchema s decodeCurrent = castWord64ToDouble <$> getWord64 instance Serialise T.Text where@@ -415,7 +419,7 @@ SText -> pure $ \case TText t -> t t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Text" s+ s -> unexpectedSchema s decodeCurrent = do len <- decodeVarInt T.decodeUtf8With T.lenientDecode <$> getBytes len@@ -432,7 +436,7 @@ SInteger -> pure $ \case TInteger i -> fromIntegral i t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise (VarInt a)" s+ s -> unexpectedSchema s decodeCurrent = VarInt <$> decodeVarInt instance Serialise Integer where@@ -456,7 +460,7 @@ SChar -> pure $ \case TChar c -> c t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise Char" s+ s -> unexpectedSchema s decodeCurrent = toEnum <$> decodeVarInt instance Serialise a => Serialise (Maybe a) where@@ -473,7 +477,7 @@ SBytes -> pure $ \case TBytes bs -> bs t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise ByteString" s+ s -> unexpectedSchema s decodeCurrent = decodeVarInt >>= getBytes instance Serialise BL.ByteString where@@ -495,7 +499,7 @@ SUTCTime -> pure $ \case TUTCTime bs -> bs t -> throw $ InvalidTerm t- s -> unexpectedSchema "Serialise UTCTime" s+ s -> unexpectedSchema s decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent instance Serialise NominalDiffTime where@@ -514,7 +518,7 @@ return $ \case TVector xs -> V.map getItem xs t -> throw $ InvalidTerm t- s -> throwStrategy $ UnexpectedSchema "extractListBy ..." "[a]" s+ s -> throwStrategy $ UnexpectedSchema [] "SVector" s {-# INLINE extractListBy #-} instance Serialise a => Serialise [a] where@@ -737,27 +741,25 @@ -> Extractor a gextractorRecord def = mkExtractor $ 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)+ => Maybe (f x) -- ^ default value (optional) -> Schema -> Strategy' (Term -> f x)-extractorRecord' rep def (SRecord schs) = Strategy $ \decs -> do+extractorRecord' 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)+ Nothing -> Left $ FieldNotFound [] name (map fst $ V.toList schs) Just (i, sch) -> case p sch `unStrategy` decs of Right getItem -> Right $ \case- TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i+ t@(TRecord xs) -> maybe (throw $ InvalidTerm t) (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+extractorRecord' _ s = throwStrategy $ UnexpectedSchema [] "a record" s {-# INLINE gextractorRecord #-} -- | Synonym for 'gdecodeCurrentProduct'@@ -885,7 +887,7 @@ go (FieldDecoder i _ p) = do getItem <- if i < length schs then p (schs V.! i) `unStrategy` recs- else Left $ ProductTooSmall $ length schs+ else Left $ ProductTooSmall [] $ length schs return $ \case TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id $ xs V.!? i@@ -895,7 +897,7 @@ strip (SProduct xs) = Just xs strip (SRecord xs) = Just $ V.map snd xs strip _ = Nothing-extractorProduct' sch = throwStrategy $ UnexpectedSchema "extractorProduct'" "a product" sch+extractorProduct' sch = throwStrategy $ UnexpectedSchema [] "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@@ -907,20 +909,28 @@ {-# INLINE gtoBuilderVariant #-} -- | Generic implementation of 'extractor' for an ADT.-gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a)+gextractorVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a) => Extractor a-gextractorVariant = mkExtractor $ \case+gextractorVariant = buildVariantExtractor gvariantExtractors+{-# INLINE gextractorVariant #-}++gvariantExtractors :: (GSerialiseVariant (Rep a), Generic a) => HM.HashMap T.Text (Extractor a)+gvariantExtractors = fmap to <$> variantExtractor+{-# INLINE gvariantExtractors #-}++-- | Bundle a 'HM.HashMap' of 'Extractor's into an extractor of a variant.+buildVariantExtractor :: (Generic a, Typeable a)+ => HM.HashMap T.Text (Extractor a)+ -> Extractor a+buildVariantExtractor extractors = mkExtractor $ \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+ ds' <- traverse (\(name, sch) -> case HM.lookup name extractors of+ Nothing -> Left $ FieldNotFound [] name (HM.keys extractors)+ Just f -> runExtractor f sch `unStrategy` decs) schs0 return $ \case- TVariant i _ v -> to $ maybe (throw InvalidTag) ($ v) $ ds' V.!? i+ TVariant i _ v -> 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))+ s -> throwStrategy $ UnexpectedSchema [] "a variant" s 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)))@@ -984,25 +994,25 @@ class GSerialiseVariant f where variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)]- variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))]+ variantExtractor :: HM.HashMap T.Text (Extractor (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+ variantExtractor = fmap (fmap L1) variantExtractor+ <> 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') ]+ variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor 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) ]+ variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor (extractorRecord' Nothing)) instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where variantSchema _ = variantSchema (Proxy @ f)- variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor+ variantExtractor = fmap M1 <$> variantExtractor
test/Spec.hs view
@@ -138,5 +138,33 @@ prop_Foo = testSerialise @ Foo +data Soup = Shoyu | Miso | Tonkotsu deriving (Generic, Eq, Show, Enum)++instance Arbitrary Soup where+ arbitrary = toEnum <$> Gen.choose (0, 2)++instance Serialise Soup where+ bundleSerialise = bundleVariant id++data Food = Rice | Ramen Soup | Pasta Text Text deriving (Generic, Eq, Show)++instance Arbitrary Food where+ arbitrary = Gen.oneof+ [ pure Rice+ , Ramen <$> arbitrary+ , Pasta+ <$> Gen.elements ["Spaghetti", "Rigatoni", "Linguine"]+ <*> Gen.elements ["Aglio e olio", "L'amatriciana", "Carbonara"]+ ]++instance Serialise Food where+ bundleSerialise = bundleVariant $ const $ buildExtractor+ $ ("Rice", \() -> Rice)+ `extractConstructor` ("Ramen", Ramen)+ `extractConstructor` ("Pasta", uncurry Pasta)+ `extractConstructor` extractVoid++prop_Food = testSerialise @ Food+ return [] main = void $ $quickCheckAll
winery.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: winery-version: 1.2+version: 1.3 synopsis: A compact, well-typed seralisation format for Haskell values description: <<https://i.imgur.com/lTosHnE.png>>@@ -11,10 +11,10 @@ bug-reports: https://github.com/fumieval/winery/issues author: Fumiaki Kinoshita maintainer: fumiexcel@gmail.com-copyright: Copyright (c) 2019 Fumiaki Kinoshita+copyright: Copyright (c) 2020 Fumiaki Kinoshita license: BSD3 license-file: LICENSE-tested-with: GHC == 8.4.4, GHC == 8.6.3, GHC ==8.8.1+tested-with: GHC == 8.4.4, GHC == 8.6.4, GHC ==8.8.3, GHC ==8.10.2 build-type: Simple extra-source-files: README.md