winery 1.3.2 → 1.4
raw patch · 9 files changed
+225/−167 lines, 9 filesdep ~prettyprinter
Dependency ranges changed: prettyprinter
Files
- ChangeLog.md +8/−0
- src/Codec/Winery.hs +11/−11
- src/Codec/Winery/Base.hs +1/−8
- src/Codec/Winery/Class.hs +71/−80
- src/Codec/Winery/Internal.hs +2/−4
- src/Codec/Winery/Test.hs +19/−19
- test/Schema.hs +55/−0
- test/Spec.hs +44/−44
- winery.cabal +14/−1
ChangeLog.md view
@@ -1,3 +1,11 @@+## 1.4++* Added an instance for `NonEmpty`+* Removed the instance for `Option`+* Added `withSchema`+* Added `alterSchemaGen` and `alterExtractor`+* Removed long-deprecated `unwrapExtractor`, `bundleRecord`, `bundleRecordDefault`, `bundleVariant`+ ## 1.3.2 * Inlined methods of various `Serialise` instances
src/Codec/Winery.hs view
@@ -42,7 +42,6 @@ , deserialiseSchema , Extractor(..) , mkExtractor- , unwrapExtractor , Decoder , evalDecoder , serialiseOnly@@ -51,6 +50,7 @@ -- * Decoding combinators , Term(..) , encodeTerm+ , decodeTerm , Subextractor(..) , buildExtractor , extractListBy@@ -75,6 +75,7 @@ , unexpectedSchema , SchemaGen , getSchema+ , withSchema -- * DerivingVia , WineryRecord(..) , WineryVariant(..)@@ -103,10 +104,9 @@ , decodeCurrentDefault -- * Bundles , BundleSerialise(..)- , bundleRecord- , bundleRecordDefault- , bundleVariant , bundleVia+ , alterExtractor+ , alterSchemaGen -- * Preset schema , bootstrapSchema ) where@@ -196,7 +196,7 @@ -- -- /"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+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)@@ -205,7 +205,7 @@ -- | '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+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@@ -215,7 +215,7 @@ -- /"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+ | sch == schema (Proxy @a) = Right decodeCurrent | otherwise = getDecoderBy extractor sch {-# INLINE getDecoder #-} @@ -241,7 +241,7 @@ -- | 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)+ $ toBuilder (schema (Proxy @a), a) {-# INLINE toBuilderWithSchema #-} -- | Split a 'Schema' from a 'B.ByteString'.@@ -361,7 +361,7 @@ 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)+ schemaGen _ = gschemaGenRecord (Proxy @a) toBuilder = gtoBuilderRecord . unWineryRecord extractor = WineryRecord <$> gextractorRecord Nothing decodeCurrent = WineryRecord <$> gdecodeCurrentRecord@@ -374,7 +374,7 @@ 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)+ schemaGen _ = gschemaGenProduct (Proxy @a) toBuilder = gtoBuilderProduct . unWineryProduct extractor = WineryProduct <$> gextractorProduct decodeCurrent = WineryProduct <$> gdecodeCurrentProduct@@ -387,7 +387,7 @@ 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)+ schemaGen _ = gschemaGenVariant (Proxy @a) toBuilder = gtoBuilderVariant . unWineryVariant extractor = WineryVariant <$> gextractorVariant decodeCurrent = WineryVariant <$> gdecodeCurrentVariant
src/Codec/Winery/Base.hs view
@@ -30,7 +30,6 @@ , Strategy' , StrategyBind(..) , StrategyEnv(..)- , unwrapExtractor , WineryException(..) , pushTrace , prettyWineryException@@ -144,7 +143,7 @@ SFix sch -> group $ nest 2 $ sep ["μ", enclose "{ " " }" $ pretty sch] SVar i -> "$" <> pretty i STag t s -> nest 2 $ sep [pretty t <> ":", pretty s]- SLet s t -> sep ["let" <+> pretty s, pretty t]+ SLet s t -> group $ nest 2 $ sep ["let" <+> pretty s, pretty t] -- | Schema generator newtype SchemaGen a = SchemaGen { unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) }@@ -264,12 +263,6 @@ data StrategyEnv = StrategyEnv !Int ![StrategyBind] type Strategy' = Strategy WineryException StrategyEnv---- | Run an 'Extractor'.-unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)-unwrapExtractor (Extractor m) = m-{-# INLINE unwrapExtractor #-}-{-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-} pushTrace :: TypeRep -> WineryException -> WineryException pushTrace t (UnexpectedSchema xs d s) = UnexpectedSchema (t : xs) d s
src/Codec/Winery/Class.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}@@ -22,11 +23,11 @@ module Codec.Winery.Class (Serialise(..) , VarInt(..) , BundleSerialise(..)- , bundleRecord- , bundleRecordDefault- , bundleVariant+ , alterSchemaGen+ , alterExtractor , getSchema , schema+ , withSchema , unexpectedSchema , mkExtractor , extractListBy@@ -81,6 +82,7 @@ import Data.Functor.Identity import qualified Data.Functor.Product as F import Data.List (elemIndex)+import qualified Data.List.NonEmpty as NE import Data.Monoid as M import Data.Kind (Type) import Data.Proxy@@ -138,7 +140,7 @@ -- -- It must not return a function if an unsupported schema is supplied. --- -- @getDecoderBy extractor (schema (Proxy @ a))@ must be @Right d@+ -- @getDecoderBy extractor (schema (Proxy @a))@ must be @Right d@ -- where @d@ is equivalent to 'decodeCurrent'. -- extractor :: Extractor a@@ -171,45 +173,28 @@ , 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 #-}-{-# DEPRECATED bundleRecord "Use bundleVia instead" #-}+-- | Modify 'bundleSchemaGen'+alterSchemaGen :: (SchemaGen Schema -> SchemaGen Schema)+ -> BundleSerialise a -> BundleSerialise a+alterSchemaGen f bundle = bundle { bundleSchemaGen = f . bundleSchemaGen bundle } --- | 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 #-}-{-# DEPRECATED bundleRecordDefault "Use bundleVia instead" #-}+-- | Modify 'bundleExtractor'+alterExtractor :: (Extractor a -> Extractor a)+ -> BundleSerialise a -> BundleSerialise a+alterExtractor f bundle = bundle { bundleExtractor = f (bundleExtractor bundle) } --- | 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 #-}-{-# DEPRECATED bundleVariant "Use bundleVia instead" #-}+-- | Bind a schema. While this does not change the semantics, it helps reducing the schema size+-- when it has multiple children with the specified type (use TypeApplications to specify a type).+withSchema :: forall a. Serialise a => SchemaGen Schema -> SchemaGen Schema+withSchema gen = SchemaGen $ \seen -> if S.member rep seen+ then unSchemaGen gen seen+ else do+ let seen' = S.insert rep seen+ let (reps', g) = unSchemaGen (getSchema (Proxy @a)) seen+ let (reps, f) = unSchemaGen gen seen'+ (reps <> reps', \xs -> SLet (g xs) $ f $ rep : xs)+ where+ rep = typeRep (Proxy @a) -- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary. -- If you are hand-rolling a definition of 'schemaGen', you should call this@@ -220,7 +205,7 @@ 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+ 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)@@ -231,7 +216,7 @@ -- -- /"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+schema p = case unSchemaGen (schemaGen (Proxy @a)) (S.singleton rep) of (reps, f) | S.member rep reps -> SFix $ f [rep] | otherwise -> f []@@ -240,12 +225,12 @@ unexpectedSchema :: forall f a. Serialise a => Schema -> Strategy' (f a) unexpectedSchema actual = throwStrategy- $ UnexpectedSchema [] (pretty $ schema (Proxy @ a)) actual+ $ UnexpectedSchema [] (pretty $ schema (Proxy @a)) actual 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+ Left e -> Left $! pushTrace (typeRep (Proxy @a)) e Right a -> Right a {-# INLINE mkExtractor #-} @@ -257,7 +242,7 @@ BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs) DynDecoder dyn -> case fromDynamic dyn of Nothing -> Left $ TypeMismatch [] i- (typeRep (Proxy @ (Term -> a)))+ (typeRep (Proxy @(Term -> a))) (dynTypeRep dyn) Just a -> Right a | otherwise -> Left $ UnboundVariable [] i@@ -539,7 +524,7 @@ {-# INLINE extractListBy #-} instance Serialise a => Serialise [a] where- schemaGen _ = SVector <$> getSchema (Proxy @ a)+ schemaGen _ = SVector <$> getSchema (Proxy @a) toBuilder xs = varInt (length xs) <> foldMap toBuilder xs {-# INLINE toBuilder #-}@@ -548,8 +533,15 @@ n <- decodeVarInt replicateM n decodeCurrent +instance Serialise a => Serialise (NE.NonEmpty a) where+ schemaGen _ = SVector <$> getSchema (Proxy @a)+ toBuilder = toBuilder . NE.toList+ {-# INLINE toBuilder #-}+ extractor = NE.fromList . V.toList <$> extractListBy extractor+ decodeCurrent = NE.fromList <$> decodeCurrent+ instance Serialise a => Serialise (V.Vector a) where- schemaGen _ = SVector <$> getSchema (Proxy @ a)+ schemaGen _ = SVector <$> getSchema (Proxy @a) toBuilder xs = varInt (V.length xs) <> foldMap toBuilder xs {-# INLINE toBuilder #-}@@ -559,7 +551,7 @@ V.replicateM n decodeCurrent instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where- schemaGen _ = SVector <$> getSchema (Proxy @ a)+ schemaGen _ = SVector <$> getSchema (Proxy @a) toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a) {-# INLINE toBuilder #-} extractor = SV.convert <$> extractListBy extractor@@ -568,7 +560,7 @@ SV.replicateM n decodeCurrent instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where- schemaGen _ = SVector <$> getSchema (Proxy @ a)+ schemaGen _ = SVector <$> getSchema (Proxy @a) toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a) {-# INLINE toBuilder #-} extractor = UV.convert <$> extractListBy extractor@@ -577,7 +569,7 @@ UV.replicateM n decodeCurrent instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where- schemaGen _ = schemaGen (Proxy @ [(k, v)])+ schemaGen _ = schemaGen (Proxy @[(k, v)]) toBuilder m = toBuilder (M.size m) <> M.foldMapWithKey (curry toBuilder) m {-# INLINE toBuilder #-}@@ -585,7 +577,7 @@ decodeCurrent = M.fromList <$> decodeCurrent instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where- schemaGen _ = schemaGen (Proxy @ [(k, v)])+ schemaGen _ = schemaGen (Proxy @[(k, v)]) toBuilder m = toBuilder (HM.size m) <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m {-# INLINE toBuilder #-}@@ -593,7 +585,7 @@ decodeCurrent = HM.fromList <$> decodeCurrent instance (Serialise v) => Serialise (IM.IntMap v) where- schemaGen _ = schemaGen (Proxy @ [(Int, v)])+ schemaGen _ = schemaGen (Proxy @[(Int, v)]) toBuilder m = toBuilder (IM.size m) <> IM.foldMapWithKey (curry toBuilder) m {-# INLINE toBuilder #-}@@ -601,35 +593,35 @@ decodeCurrent = IM.fromList <$> decodeCurrent instance (Ord a, Serialise a) => Serialise (S.Set a) where- schemaGen _ = schemaGen (Proxy @ [a])+ 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])+ 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])+ 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))+ 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))+ schemaGen _ = schemaGen (Proxy @(Integer, Int)) toBuilder s = toBuilder (coefficient s, base10Exponent s) {-# INLINE toBuilder #-} extractor = mkExtractor $ \s -> case s of@@ -720,7 +712,6 @@ 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))@@ -765,7 +756,7 @@ -- | 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))+gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @(Rep a)) -- | Generic implementation of 'toBuilder' for a record. gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder@@ -853,7 +844,7 @@ 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)+ recordSchema _ = (++) <$> recordSchema (Proxy @f) <*> recordSchema (Proxy @g) recordExtractor def = (\f g -> (:*:) <$> f <*> g) <$> recordExtractor ((\(x :*: _) -> x) <$> def) <*> recordExtractor ((\(_ :*: x) -> x) <$> def)@@ -861,7 +852,7 @@ instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where recordSchema _ = do- s <- getSchema (Proxy @ a)+ 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))@@ -870,11 +861,11 @@ {-# INLINE recordExtractor #-} instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where- recordSchema _ = recordSchema (Proxy @ f)+ recordSchema _ = recordSchema (Proxy @f) recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where- recordSchema _ = recordSchema (Proxy @ f)+ recordSchema _ = recordSchema (Proxy @f) recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) class GSerialiseProduct f where@@ -886,21 +877,21 @@ productExtractor = pure (pure U1) instance (Serialise a) => GSerialiseProduct (K1 i a) where- productSchema _ = pure <$> getSchema (Proxy @ a)+ productSchema _ = pure <$> getSchema (Proxy @a) productExtractor = Compose $ State $ \i -> ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (runExtractor extractor) , i + 1) instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where- productSchema _ = productSchema (Proxy @ f)+ productSchema _ = productSchema (Proxy @f) productExtractor = fmap M1 <$> productExtractor instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where- productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g)+ 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))+gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @(Rep a)) {-# INLINE gschemaGenProduct #-} gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder@@ -940,7 +931,7 @@ -- | 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))+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@@ -980,7 +971,7 @@ variantCount :: proxy f -> Int instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where- variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g)+ variantCount _ = variantCount (Proxy @f) + variantCount (Proxy @g) {-# INLINE variantCount #-} instance GConstructorCount (C1 i f) where@@ -988,7 +979,7 @@ {-# INLINE variantCount #-} instance GConstructorCount f => GConstructorCount (D1 i f) where- variantCount _ = variantCount (Proxy @ f)+ variantCount _ = variantCount (Proxy @f) {-# INLINE variantCount #-} class GDecodeVariant f where@@ -1037,24 +1028,24 @@ variantExtractor :: HM.HashMap T.Text (Extractor (f x)) instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where- variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g)+ variantSchema _ = (++) <$> variantSchema (Proxy @f) <*> variantSchema (Proxy @g) 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 = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor extractorProduct')+ s <- productSchema (Proxy @f)+ return [(T.pack $ symbolVal (Proxy @name), SProduct $ V.fromList s)]+ 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 = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor (extractorRecord' Nothing))+ s <- recordSchema (Proxy @f)+ return [(T.pack $ symbolVal (Proxy @name), SRecord $ V.fromList s)]+ variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @name)) (M1 <$> Extractor (extractorRecord' Nothing)) instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where- variantSchema _ = variantSchema (Proxy @ f)+ variantSchema _ = variantSchema (Proxy @f) variantExtractor = fmap M1 <$> variantExtractor -- | An extractor for individual fields. This distinction is required for@@ -1089,7 +1080,7 @@ instance (Typeable k, Typeable b, Typeable h, ApplicativeB b, ConstraintsB b, TraversableB b, AllBF Serialise h b, FieldNamesB b) => Serialise (Barbie b (h :: k -> Type)) where schemaGen _ = fmap (SRecord . V.fromList . (`appEndo`[]) . bfoldMap getConst) $ btraverse (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) (Const k))- -> Const . Endo . (:) . (,) k <$> schemaGen (Proxy @ (h a)))+ -> Const . Endo . (:) . (,) k <$> schemaGen (Proxy @(h a))) $ baddDicts (bfieldNames :: b (Const T.Text)) toBuilder = bfoldMap (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) x) -> toBuilder x) . baddDicts {-# INLINE toBuilder #-}
src/Codec/Winery/Internal.hs view
@@ -52,7 +52,6 @@ import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder.Prim.Internal as BPI import Data.Bits-import Data.Monoid ((<>)) import Data.String import qualified Data.Vector.Unboxed as U import qualified Data.Vector as V@@ -80,7 +79,7 @@ {-# INLINEABLE[1] varInt #-} varIntFinite :: Int -> BB.Builder-varIntFinite = BB.primBounded (BPI.boudedPrim 10 writeIntFinite)+varIntFinite = BB.primBounded (BPI.boundedPrim 10 writeIntFinite) writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8) writeWord8 w p = do@@ -258,11 +257,10 @@ deriving Functor instance Applicative (Strategy e r) where- pure = return+ pure = Strategy . const . Right (<*>) = ap instance Monad (Strategy e r) where- return = Strategy . const . Right m >>= k = Strategy $ \decs -> case unStrategy m decs of Right a -> unStrategy (k a) decs Left e -> Left e
src/Codec/Winery/Test.hs view
@@ -69,7 +69,7 @@ -- | Gather all test cases involved in the specified type. allTests :: forall a. (TestGen a, Tested a) => M.Map TypeRep [Test]-allTests = M.insertWith (++) (typeRep (Proxy @ a)) (testCases @ a) (inheritedTests (Proxy @ a))+allTests = M.insertWith (++) (typeRep (Proxy @a)) (testCases @a) (inheritedTests (Proxy @a)) -- | Types with concrete test cases. --@@ -80,7 +80,7 @@ testCases :: [Test] default testCases :: (Serialise a, Eq a, Show a) => [Test]- testCases = [testCase sch b a | (sch, xs) <- testGroups @ a, (b, a) <- xs]+ testCases = [testCase sch b a | (sch, xs) <- testGroups @a, (b, a) <- xs] testGroups :: [(Schema, [(B.ByteString, a)])] testGroups = []@@ -101,7 +101,7 @@ instance Tested T.Text where testCases = [] instance Tested B.ByteString where testCases = [] instance Tested a => Tested (Identity a) where- testCases = testCases @ a+ testCases = testCases @a instance Tested a => Tested (S.Seq a) where testCases = [] instance (Ord a, Tested a) => Tested (Set.Set a) where testCases = [] instance Tested a => Tested [a] where testCases = []@@ -121,7 +121,7 @@ printTests = putStrLn $ showTests (genTestCases :: [a]) buildTestGroups :: forall a. (TestGen a, Serialise a) => [(Schema, [(B.ByteString, a)])]-buildTestGroups = [(schema (Proxy @ a), [(serialiseOnly a, a) | a <- genTestCases :: [a]])]+buildTestGroups = [(schema (Proxy @a), [(serialiseOnly a, a) | a <- genTestCases :: [a]])] showTests :: (Serialise a, Show a) => [a] -> String showTests xs = showListWith ppTest xs ""@@ -149,7 +149,7 @@ genTestCases = fmap to ggenTestCases default inheritedTests :: (GTestGen (Rep a)) => Proxy a -> M.Map TypeRep [Test]- inheritedTests _ = ginheritedTests (Proxy @ (Rep a))+ inheritedTests _ = ginheritedTests (Proxy @(Rep a)) class GTestGen f where ggenTestCases :: [f x]@@ -165,28 +165,28 @@ instance GTestGen f => GTestGen (Rec1 f) where ggenTestCases = fmap Rec1 ggenTestCases- ginheritedTests _ = ginheritedTests (Proxy @ f)+ ginheritedTests _ = ginheritedTests (Proxy @f) instance (Tested c, TestGen c) => GTestGen (K1 i c) where ggenTestCases = fmap K1 genTestCases- ginheritedTests _ = allTests @ c+ ginheritedTests _ = allTests @c instance GTestGen f => GTestGen (M1 i c f) where ggenTestCases = fmap M1 ggenTestCases- ginheritedTests _ = ginheritedTests (Proxy @ f)+ ginheritedTests _ = ginheritedTests (Proxy @f) instance (GTestGen f, GTestGen g) => GTestGen (f :+: g) where ggenTestCases = fmap L1 ggenTestCases ++ fmap R1 ggenTestCases- ginheritedTests _ = ginheritedTests (Proxy @ f)- `mappend` ginheritedTests (Proxy @ g)+ ginheritedTests _ = ginheritedTests (Proxy @f)+ `mappend` ginheritedTests (Proxy @g) instance (GTestGen f, GTestGen g) => GTestGen (f :*: g) where ggenTestCases = ((:*:) <$> ggenTestCases <*> xs) ++ ((:*:) <$> take 1 ggenTestCases <*> ys) where (xs, ys) = splitAt 1 ggenTestCases- ginheritedTests _ = ginheritedTests (Proxy @ f)- `mappend` ginheritedTests (Proxy @ g)+ ginheritedTests _ = ginheritedTests (Proxy @f)+ `mappend` ginheritedTests (Proxy @g) deriving instance TestGen a => TestGen (Identity a) instance TestGen ()@@ -198,31 +198,31 @@ instance Tested a => TestGen [a] where genTestCases = [[]]- inheritedTests _ = allTests @ a+ inheritedTests _ = allTests @a instance (Ord a, Tested a) => TestGen (Set.Set a) where genTestCases = [mempty]- inheritedTests _ = allTests @ a+ inheritedTests _ = allTests @a instance Tested a => TestGen (S.Seq a) where genTestCases = [mempty]- inheritedTests _ = allTests @ a+ inheritedTests _ = allTests @a instance Tested a => TestGen (V.Vector a) where genTestCases = [V.empty]- inheritedTests _ = allTests @ a+ inheritedTests _ = allTests @a instance (UV.Unbox a, Tested a) => TestGen (UV.Vector a) where genTestCases = [UV.empty]- inheritedTests _ = allTests @ a+ inheritedTests _ = allTests @a instance (Hashable k, Tested k, Tested a) => TestGen (HM.HashMap k a) where genTestCases = HM.singleton <$> genTestCases <*> genTestCases- inheritedTests _ = allTests @ k `mappend` allTests @ a+ inheritedTests _ = allTests @k `mappend` allTests @a instance (Ord k, Tested k, Tested a) => TestGen (M.Map k a) where genTestCases = [M.empty]- inheritedTests _ = allTests @ k `mappend` allTests @ a+ inheritedTests _ = allTests @k `mappend` allTests @a instance TestGen Void where genTestCases = []
+ test/Schema.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TypeApplications, DeriveGeneric #-}++import Codec.Winery+import Data.List (intercalate)+import Data.Proxy+import GHC.Generics+import Prettyprinter+import Test.QuickCheck+import qualified Test.QuickCheck.Gen as Gen++data BigUnion = BU0 | BU1 | BU2 | BU3 | BU4 deriving (Show, Eq, Generic, Enum)+instance Serialise BigUnion where+ bundleSerialise = bundleVia WineryVariant++instance Arbitrary BigUnion where+ arbitrary = toEnum <$> Gen.choose (0, 4)++data BigRecord = BigRecord+ { foo :: BigUnion+ , bar :: BigUnion+ , baz :: BigUnion+ , qux :: BigUnion+ } deriving (Show, Eq, Generic)++instance Arbitrary BigRecord where+ arbitrary = BigRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++data BiggerRecord = BiggerRecord+ { union :: BigUnion+ , alpha :: BigRecord+ , bravo :: BigRecord+ } deriving (Show, Eq, Generic)++instance Arbitrary BiggerRecord where+ arbitrary = BiggerRecord <$> arbitrary <*> arbitrary <*> arbitrary++instance Serialise BigRecord where+ bundleSerialise = alterSchemaGen (withSchema @BigUnion)+ $ bundleVia WineryRecord++instance Serialise BiggerRecord where+ bundleSerialise = alterSchemaGen (withSchema @BigUnion . withSchema @BigRecord)+ $ bundleVia WineryRecord++main :: IO ()+main = do+ let expected = intercalate "\n"+ [ "let BU0 | BU1 | BU2 | BU3 | BU4"+ , " let { foo :: $0, bar :: $0, baz :: $0, qux :: $0 }"+ , " { union :: $1, alpha :: $0, bravo :: $0 }"+ ]+ let actual = show $ pretty $ schema (Proxy @BiggerRecord)+ if expected == actual+ then quickCheck $ testSerialise @BiggerRecord+ else fail $ "Schema mismatch: \n" <> actual
test/Spec.hs view
@@ -46,44 +46,44 @@ instance Arbitrary Nano where arbitrary = Nano . realToFrac . (1000*) <$> (arbitrary :: Gen Pico) -prop_Unit = testSerialise @ ()-prop_Bool = testSerialise @ Bool-prop_Word8 = testSerialise @ Word8-prop_Word16 = testSerialise @ Word16-prop_Word32 = testSerialise @ Word32-prop_Word64 = testSerialise @ Word64-prop_Word = testSerialise @ Word-prop_Int8 = testSerialise @ Int8-prop_Int16 = testSerialise @ Int16-prop_Int32 = testSerialise @ Int32-prop_Int64 = testSerialise @ Int64-prop_Int = testSerialise @ Int-prop_Float = testSerialise @ Float-prop_Double = testSerialise @ Double-prop_Text = testSerialise @ Text-prop_Integer = testSerialise @ Integer-prop_Char = testSerialise @ Char-prop_Maybe_Int = testSerialise @ (Maybe Int)-prop_ByteString = testSerialise @ ByteString-prop_ByteString_Lazy = testSerialise @ BL.ByteString+prop_Unit = testSerialise @()+prop_Bool = testSerialise @Bool+prop_Word8 = testSerialise @Word8+prop_Word16 = testSerialise @Word16+prop_Word32 = testSerialise @Word32+prop_Word64 = testSerialise @Word64+prop_Word = testSerialise @Word+prop_Int8 = testSerialise @Int8+prop_Int16 = testSerialise @Int16+prop_Int32 = testSerialise @Int32+prop_Int64 = testSerialise @Int64+prop_Int = testSerialise @Int+prop_Float = testSerialise @Float+prop_Double = testSerialise @Double+prop_Text = testSerialise @Text+prop_Integer = testSerialise @Integer+prop_Char = testSerialise @Char+prop_Maybe_Int = testSerialise @(Maybe Int)+prop_ByteString = testSerialise @ByteString+prop_ByteString_Lazy = testSerialise @BL.ByteString -- prop_UTCTime = testSerialise @ UTCTime-prop_NominalDiffTime = testSerialise @ Nano-prop_List_Int = testSerialise @ [Int]-prop_Vector_Int = testSerialise @ (V.Vector Int) . V.fromList-prop_Vector_Storable_Int = testSerialise @ (SV.Vector Int) . SV.fromList-prop_Vector_Unboxed_Int = testSerialise @ (UV.Vector Int) . UV.fromList-prop_Map_Int_Int = testSerialise @ (Map Int Int)-prop_HashMap_String_Int = testSerialise @ (HM.HashMap String Int) . HM.fromList-prop_IntMap_Int = testSerialise @ (IntMap Int)-prop_Set_Int = testSerialise @ (Set Int)-prop_IntSet = testSerialise @ IntSet-prop_Seq_Int = testSerialise @ (Seq Int)-prop_Scientific = testSerialise @ Scientific-prop_Tuple2 = testSerialise @ (Bool, Int)-prop_Tuple3 = testSerialise @ (Bool, Int, Text)-prop_Tuple4 = testSerialise @ (Bool, Int, Text, Double)-prop_Either_String_Int = testSerialise @ (Either String Int)-prop_Ordering = testSerialise @ Ordering+prop_NominalDiffTime = testSerialise @Nano+prop_List_Int = testSerialise @[Int]+prop_Vector_Int = testSerialise @(V.Vector Int) . V.fromList+prop_Vector_Storable_Int = testSerialise @(SV.Vector Int) . SV.fromList+prop_Vector_Unboxed_Int = testSerialise @(UV.Vector Int) . UV.fromList+prop_Map_Int_Int = testSerialise @(Map Int Int)+prop_HashMap_String_Int = testSerialise @(HM.HashMap String Int) . HM.fromList+prop_IntMap_Int = testSerialise @(IntMap Int)+prop_Set_Int = testSerialise @(Set Int)+prop_IntSet = testSerialise @IntSet+prop_Seq_Int = testSerialise @(Seq Int)+prop_Scientific = testSerialise @Scientific+prop_Tuple2 = testSerialise @(Bool, Int)+prop_Tuple3 = testSerialise @(Bool, Int, Text)+prop_Tuple4 = testSerialise @(Bool, Int, Text, Double)+prop_Either_String_Int = testSerialise @(Either String Int)+prop_Ordering = testSerialise @Ordering data TRec = TRec { foo :: !Int@@ -96,7 +96,7 @@ instance Serialise TRec where bundleSerialise = bundleVia WineryRecord -prop_TRec = testSerialise @ TRec+prop_TRec = testSerialise @TRec data TList a = TCons a (TList a) | TNil deriving (Show, Eq, Generic) @@ -108,7 +108,7 @@ then pure TNil else TCons <$> arbitrary <*> scale pred arbitrary -prop_TList_Int = testSerialise @ (TList Int)+prop_TList_Int = testSerialise @(TList Int) data Tree = Leaf@@ -140,8 +140,8 @@ <*> (extractField "right" <|> extractField "rightChild") } -prop_tree = testSerialise @ Tree-prop_node = testSerialise @ Node+prop_tree = testSerialise @Tree+prop_node = testSerialise @Node data Foo = Foo | Bar | Baz | Qux | FooBar | FooBaz | FooQux deriving (Generic, Eq, Show, Enum) @@ -151,7 +151,7 @@ instance Serialise Foo where bundleSerialise = bundleVia WineryVariant -prop_Foo = testSerialise @ Foo+prop_Foo = testSerialise @Foo data Soup = Shoyu | Miso | Tonkotsu deriving (Generic, Eq, Show, Enum) @@ -180,7 +180,7 @@ `extractConstructor` ("Pasta", uncurry Pasta) `extractConstructor` extractVoid -prop_Food = testSerialise @ Food+prop_Food = testSerialise @Food declareBareB [d| data HRecB = HRec@@ -200,6 +200,6 @@ instance Arbitrary HRec where arbitrary = HRec <$> arbitrary <*> arbitrary-prop_HRec = testSerialise @ HRec+prop_HRec = testSerialise @HRec return [] main = $quickCheckAll >>= flip unless (error "Failed")
winery.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: winery-version: 1.3.2+version: 1.4 synopsis: A compact, well-typed seralisation format for Haskell values description: <<https://i.imgur.com/lTosHnE.png>>@@ -100,6 +100,19 @@ , bytestring , barbies , barbies-th >= 0.1.5+ default-language: Haskell2010++test-suite schema+ type: exitcode-stdio-1.0+ main-is: Schema.hs+ ghc-options: -Wall -Wcompat+ hs-source-dirs:+ test+ build-depends:+ base >=4.7 && <5+ , winery+ , prettyprinter+ , QuickCheck default-language: Haskell2010 benchmark bench-winery