diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs --- a/src/Codec/Winery.hs +++ b/src/Codec/Winery.hs @@ -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) diff --git a/src/Codec/Winery/Base.hs b/src/Codec/Winery/Base.hs --- a/src/Codec/Winery/Base.hs +++ b/src/Codec/Winery/Base.hs @@ -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 diff --git a/src/Codec/Winery/Class.hs b/src/Codec/Winery/Class.hs --- a/src/Codec/Winery/Class.hs +++ b/src/Codec/Winery/Class.hs @@ -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 #-} diff --git a/src/Codec/Winery/Query/Parser.hs b/src/Codec/Winery/Query/Parser.hs --- a/src/Codec/Winery/Query/Parser.hs +++ b/src/Codec/Winery/Query/Parser.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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") diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -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: <> @@ -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