winery 1.3.1 → 1.3.2
raw patch · 9 files changed
+221/−57 lines, 9 filesdep +barbiesdep +barbies-thdep ~megaparsecdep ~prettyprinter
Dependencies added: barbies, barbies-th
Dependency ranges changed: megaparsec, prettyprinter
Files
- ChangeLog.md +6/−0
- README.md +54/−8
- app/Main.hs +2/−6
- src/Codec/Winery.hs +16/−31
- src/Codec/Winery/Base.hs +2/−2
- src/Codec/Winery/Class.hs +96/−1
- src/Codec/Winery/Query/Parser.hs +1/−1
- test/Spec.hs +37/−5
- winery.cabal +7/−3
ChangeLog.md view
@@ -1,3 +1,9 @@+## 1.3.2++* Inlined methods of various `Serialise` instances+* Added `buildRecordExtractor` and `bextractors`+* Added a `Serialise` instance for `Barbie`+ ## 1.3.1 * Added `bundleVia`, deprecating `bundleRecord` and `bundleVariant`
README.md view
@@ -74,6 +74,16 @@ for any ADT. The former explicitly describes field names in the schema, and the latter does constructor names. +If you want to customise one of the methods, you can use `bundleVia` to supply the rest of definitions.++```haskell+instance Serialise Foo where+ bundleSerialise = bundleVia WineryRecord+ extractor = buildExtractor $ Foo+ <$> extractField "foo"+ <*> extractField "bar"+```+ ## Backward compatibility If the representation is not the same as the current version (i.e. the schema@@ -83,14 +93,7 @@ `Extractor` parses a schema and returns a function which gives a value back from a `Term`. -If having default values for missing fields is sufficient, you can pass a-default value to `gextractorRecord`:--```haskell- extractor = gextractorRecord $ Just $ Foo "" 42 0-```--You can also build an extractor using combinators such as `extractField`, `extractConstructor`, etc.+You can build an extractor using combinators such as `extractField`, `extractConstructor`, etc. ```haskell buildExtractor@@ -100,8 +103,51 @@ :: Extractor (Maybe a) ``` +If you want to customise the extractor, the pair of `gvariantExtractors` and `buildVariantExtractors` is handy.++```haskell+gvariantExtractors :: (GSerialiseVariant (Rep a), Generic a) => HM.HashMap T.Text (Extractor a)+buildVariantExtractor :: (Generic a, Typeable a) => HM.HashMap T.Text (Extractor a) -> Extractor a+```+ `Extractor` is Alternative, meaning that multiple extractors (such as a default generic implementation and fallback plans) can be combined into one.++Altering an instance for a record type is a little bit tricky.+HKD can represent a record where each field is `Subextractor` instead of the orignal type.+The [barbies-th](http://hackage.haskell.org/package/barbies-th) allows us to derive it from a plain declaration.++```haskell+import Barbies.Bare+import Barbies.TH++declareBareB [d|+ data HRecB = HRec+ { baz :: !Int+ , qux :: !Text+ }+ |]+type HRec = HRecB Bare Identity+```++Obtain a record of extractors using `bextractors :: forall b. (AllB Serialise b, ...) => b Subextractor`, update it as necessary,+then build an extractor for an entire record by `buildRecordExtractor`.++```haskell+instance Serialise HRec where+ bundleSerialise = bundleVia WineryRecord+ extractor = fmap bstrip $ buildRecordExtractor bextractors+ { qux = extractField "qux" <|> extractField "oldQux" }+```++More generic instance (for covered types) can be defined as below:++```haskell+instance (Typeable h, AllBF Serialise h (HRecB Covered)) => Serialise (HRecB Covered h) where+ bundleSerialise = bundleVia Barbie+ extractor = buildRecordExtractorF bextractorsF+ { qux = Compose $ extractField "qux" <|> extractField "oldQux" }+``` ## Pretty-printing
app/Main.hs view
@@ -5,8 +5,8 @@ import qualified Data.Aeson as JSON import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Terminal+import Prettyprinter+import Prettyprinter.Render.Terminal import Data.Word (Word64) import qualified Codec.Winery.Query as Q import Codec.Winery.Query.Parser@@ -86,11 +86,7 @@ let o = foldl (flip id) defaultOptions fs q <- case parse (parseQuery <* eof) "argument" $ T.pack qs of Left e -> do-#if MIN_VERSION_megaparsec(7,0,0) hPutStrLn stderr $ errorBundlePretty e-#else- hPutStrLn stderr $ parseErrorPretty e-#endif exitWith (ExitFailure 2) Right a -> pure a forM_ paths $ \case
src/Codec/Winery.hs view
@@ -61,6 +61,10 @@ , extractProductItemBy , extractVoid , buildVariantExtractor+ , buildRecordExtractor+ , bextractors+ , buildRecordExtractorF+ , bextractorsF , ExtractException(..) , SingleField(..) -- * Variable-length quantity@@ -110,7 +114,6 @@ import Codec.Winery.Base as W import Codec.Winery.Class import Codec.Winery.Internal-import Control.Applicative import Control.Exception (throw, throwIO) import qualified Data.ByteString as B import qualified Data.ByteString.FastBuilder as BB@@ -294,36 +297,7 @@ serialiseOnly = BB.toStrictByteString . toBuilder {-# INLINE serialiseOnly #-} --- | Build an extractor from a 'Subextractor'.-buildExtractor :: Typeable a => Subextractor a -> Extractor a-buildExtractor (Subextractor e) = mkExtractor $ runExtractor e-{-# INLINE buildExtractor #-}---- | An extractor for individual fields. This distinction is required for--- handling recursions correctly.------ Recommended extension: ApplicativeDo-newtype Subextractor a = Subextractor { unSubextractor :: Extractor a }- deriving (Functor, Applicative, Alternative)---- | Extract a field of a record.-extractField :: Serialise a => T.Text -> Subextractor a-extractField = extractFieldBy extractor-{-# INLINE extractField #-}- -- | Extract a field using the supplied 'Extractor'.-extractFieldBy :: Extractor a -> T.Text -> Subextractor a-extractFieldBy (Extractor g) name = Subextractor $ Extractor $ \case- SRecord schs -> case lookupWithIndexV name schs of- Just (i, sch) -> do- m <- g sch- return $ \case- TRecord xs -> maybe (throw $ InvalidTerm (TRecord xs)) (m . snd) $ xs V.!? i- t -> throw $ InvalidTerm t- _ -> 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 extractProductItemBy (Extractor g) i = Subextractor $ Extractor $ \case SProduct schs -> case schs V.!? i of@@ -391,6 +365,8 @@ toBuilder = gtoBuilderRecord . unWineryRecord extractor = WineryRecord <$> gextractorRecord Nothing decodeCurrent = WineryRecord <$> gdecodeCurrentRecord+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} -- | Serialise a value as a product (omits field names). --@@ -402,6 +378,8 @@ toBuilder = gtoBuilderProduct . unWineryProduct extractor = WineryProduct <$> gextractorProduct decodeCurrent = WineryProduct <$> gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} -- | The 'Serialise' instance is generically defined for variants. --@@ -413,6 +391,8 @@ toBuilder = gtoBuilderVariant . unWineryVariant extractor = WineryVariant <$> gextractorVariant decodeCurrent = WineryVariant <$> gdecodeCurrentVariant+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} -- | A product with one field. Useful when creating a custom extractor for constructors. newtype SingleField a = SingleField { getSingleField :: a }@@ -423,8 +403,13 @@ toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} -bundleVia :: forall a t. (Coercible a t, Serialise t) => (a -> t) -> BundleSerialise a+-- | 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 _ = BundleSerialise { bundleSchemaGen = coerce (schemaGen @t) , bundleToBuilder = coerce (toBuilder @t)
src/Codec/Winery/Base.hs view
@@ -46,8 +46,8 @@ import Data.Int import Data.String import qualified Data.Text as T-import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)-import Data.Text.Prettyprint.Doc.Render.Terminal+import Prettyprinter hiding ((<>), SText, SChar)+import Prettyprinter.Render.Terminal import Data.Time import qualified Data.Set as S import Data.Typeable
src/Codec/Winery/Class.hs view
@@ -15,6 +15,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif@@ -53,8 +54,19 @@ , gextractorVariant , gdecodeCurrentVariant , gvariantExtractors+ , Subextractor(..)+ , extractField+ , extractFieldBy+ , buildExtractor+ , buildRecordExtractor+ , bextractors+ , buildRecordExtractorF+ , bextractorsF ) where +import Barbies hiding (Void)+import Barbies.Constraints+import Barbies.TH import Control.Applicative import Control.Exception import Control.Monad.Reader@@ -67,8 +79,10 @@ import Data.Fixed import Data.Functor.Compose import Data.Functor.Identity+import qualified Data.Functor.Product as F import Data.List (elemIndex) import Data.Monoid as M+import Data.Kind (Type) import Data.Proxy import Data.Ratio (Ratio, (%), numerator, denominator) import Data.Scientific (Scientific, scientific, coefficient, base10Exponent)@@ -91,7 +105,7 @@ import qualified Data.Vector as V import qualified Data.Vector.Storable as SV import qualified Data.Vector.Unboxed as UV-import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)+import Prettyprinter hiding ((<>), SText, SChar) import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Typeable@@ -640,36 +654,48 @@ toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e) => Serialise (a, b, c, d, e) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e, Serialise f) => Serialise (a, b, c, d, e, f) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b) => Serialise (Either a b) where schemaGen = gschemaGenVariant toBuilder = gtoBuilderVariant extractor = gextractorVariant decodeCurrent = gdecodeCurrentVariant+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance Serialise Ordering where@@ -677,6 +703,8 @@ toBuilder = gtoBuilderVariant extractor = gextractorVariant decodeCurrent = gdecodeCurrentVariant+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} deriving instance Serialise a => Serialise (Identity a) deriving instance (Serialise a, Typeable b, Typeable k) => Serialise (Const a (b :: k))@@ -706,24 +734,32 @@ toBuilder = mempty extractor = pure Refl decodeCurrent = pure Refl+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance (Serialise a, Serialise b) => Serialise (Arg a b) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance Serialise a => Serialise (Complex a) where schemaGen = gschemaGenProduct toBuilder = gtoBuilderProduct extractor = gextractorProduct decodeCurrent = gdecodeCurrentProduct+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} instance Serialise Void where schemaGen _ = pure $ SVariant V.empty toBuilder = mempty extractor = Extractor $ const $ throwStrategy "No extractor for Void" decodeCurrent = error "No decodeCurrent for Void"+ {-# INLINE toBuilder #-}+ {-# INLINE decodeCurrent #-} -------------------------------------------------------------------------------- @@ -917,6 +953,7 @@ gextractorVariant = buildVariantExtractor gvariantExtractors {-# INLINE gextractorVariant #-} +-- | Collect extractors as a 'HM.HashMap' keyed by constructor names gvariantExtractors :: (GSerialiseVariant (Rep a), Generic a) => HM.HashMap T.Text (Extractor a) gvariantExtractors = fmap to <$> variantExtractor {-# INLINE gvariantExtractors #-}@@ -1019,3 +1056,61 @@ instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where variantSchema _ = variantSchema (Proxy @ f) variantExtractor = fmap M1 <$> variantExtractor++-- | An extractor for individual fields. This distinction is required for+-- handling recursions correctly.+--+-- Recommended extension: ApplicativeDo+newtype Subextractor a = Subextractor { unSubextractor :: Extractor a }+ deriving (Functor, Applicative, Alternative)++-- | Extract a field of a record.+extractField :: Serialise a => T.Text -> Subextractor a+extractField = extractFieldBy extractor+{-# INLINE extractField #-}++-- | Extract a field using the supplied 'Extractor'.+extractFieldBy :: Extractor a -> T.Text -> Subextractor a+extractFieldBy (Extractor g) name = Subextractor $ Extractor $ \case+ SRecord schs -> case lookupWithIndexV name schs of+ Just (i, sch) -> do+ m <- g sch+ return $ \case+ TRecord xs -> maybe (throw $ InvalidTerm (TRecord xs)) (m . snd) $ xs V.!? i+ t -> throw $ InvalidTerm t+ _ -> throwStrategy $ FieldNotFound [] name (map fst $ V.toList schs)+ s -> throwStrategy $ UnexpectedSchema [] "a record" s++-- | Build an extractor from a 'Subextractor'.+buildExtractor :: Typeable a => Subextractor a -> Extractor a+buildExtractor (Subextractor e) = mkExtractor $ runExtractor e+{-# INLINE buildExtractor #-}++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)))+ $ baddDicts (bfieldNames :: b (Const T.Text))+ toBuilder = bfoldMap (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) x) -> toBuilder x) . baddDicts+ {-# INLINE toBuilder #-}+ decodeCurrent = fmap Barbie $ btraverse (\Dict -> decodeCurrent) (bdicts :: b (Dict (ClassF Serialise h)))+ {-# INLINE decodeCurrent #-}+ extractor = fmap Barbie $ buildRecordExtractorF bextractorsF++buildRecordExtractorF :: (Typeable b, Typeable h, TraversableB b) => b (Compose Subextractor h) -> Extractor (b h)+buildRecordExtractorF = buildExtractor . btraverse getCompose+{-# INLINE buildRecordExtractorF #-}++-- | Collect extractors for record fields+bextractorsF :: forall b h. (ConstraintsB b, AllBF Serialise h b, FieldNamesB b) => b (Compose Subextractor h)+bextractorsF = bmapC @(ClassF Serialise h) (Compose . extractField . getConst) bfieldNames+{-# INLINABLE bextractorsF #-}++buildRecordExtractor :: (Typeable b, TraversableB b) => b Subextractor -> Extractor (b Identity)+buildRecordExtractor = buildExtractor . btraverse (fmap Identity)+{-# INLINE buildRecordExtractor #-}++-- | Collect extractors for record fields+bextractors :: forall b. (ConstraintsB b, AllB Serialise b, FieldNamesB b) => b Subextractor+bextractors = bmapC @Serialise (extractField . getConst) bfieldNames+{-# INLINABLE bextractors #-}
src/Codec/Winery/Query/Parser.hs view
@@ -26,7 +26,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import qualified Data.Text as T-import Data.Text.Prettyprint.Doc (Doc, hsep)+import Prettyprinter (Doc, hsep) import Data.Typeable import Data.Void
test/Spec.hs view
@@ -1,10 +1,18 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-missing-signatures#-} import Control.Monad+import Barbies.Bare+import Barbies.TH import Data.ByteString (ByteString)+import Data.Fixed (Pico)+import Data.Functor.Identity import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet)@@ -13,7 +21,7 @@ import Data.Sequence (Seq) import Data.Set (Set) import Data.Text (Text)-import Data.Time (UTCTime, NominalDiffTime)+import Data.Time (NominalDiffTime) import Codec.Winery import Codec.Winery.Internal import Data.Word@@ -23,7 +31,7 @@ import qualified Data.Vector as V import qualified Data.Vector.Storable as SV import qualified Data.Vector.Unboxed as UV-import GHC.Generics (Generic)+import GHC.Generics import Test.QuickCheck import qualified Test.QuickCheck.Gen as Gen import Test.QuickCheck.Instances ()@@ -33,6 +41,11 @@ prop_VarInt i = evalDecoder decodeVarInt (B.toStrictByteString $ varInt i) === i +newtype Nano = Nano NominalDiffTime deriving (Show, Eq, Serialise)++instance Arbitrary Nano where+ arbitrary = Nano . realToFrac . (1000*) <$> (arbitrary :: Gen Pico)+ prop_Unit = testSerialise @ () prop_Bool = testSerialise @ Bool prop_Word8 = testSerialise @ Word8@@ -53,8 +66,8 @@ prop_Maybe_Int = testSerialise @ (Maybe Int) prop_ByteString = testSerialise @ ByteString prop_ByteString_Lazy = testSerialise @ BL.ByteString-prop_UTCTime = testSerialise @ UTCTime-prop_NominalDiffTime = testSerialise @ NominalDiffTime+-- prop_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@@ -169,5 +182,24 @@ prop_Food = testSerialise @ Food +declareBareB [d|+ data HRecB = HRec+ { baz :: !Int+ , qux :: !Text+ } deriving Generic+ |]+type HRec = HRecB Bare Identity++instance Serialise HRec where+ bundleSerialise = bundleVia WineryRecord+ extractor = fmap bstrip $ buildRecordExtractor bextractors+ { qux = extractField "qux" <|> extractField "oldQux" }++deriving instance Show HRec+deriving instance Eq HRec++instance Arbitrary HRec where+ arbitrary = HRec <$> arbitrary <*> arbitrary+prop_HRec = testSerialise @ HRec return []-main = void $ $quickCheckAll+main = $quickCheckAll >>= flip unless (error "Failed")
winery.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: winery-version: 1.3.1+version: 1.3.2 synopsis: A compact, well-typed seralisation format for Haskell values description: <<https://i.imgur.com/lTosHnE.png>>@@ -41,15 +41,17 @@ build-depends: aeson , base >=4.7 && <5+ , barbies ^>= 2.0+ , barbies-th ^>= 0.1 , bytestring , containers , cpu , fast-builder , hashable , HUnit- , megaparsec >=6.0.0+ , megaparsec >=7.0.0 , mtl- , prettyprinter+ , prettyprinter ^>= 1.7 , prettyprinter-ansi-terminal , scientific , semigroups@@ -96,6 +98,8 @@ , containers , scientific , bytestring+ , barbies+ , barbies-th >= 0.1.5 default-language: Haskell2010 benchmark bench-winery