composewell/streamly
1
1
Fork 0
mirror of https://github.com/composewell/streamly.git synced 2024-08-17 07:20:36 +03:00
Code Issues Packages Projects Releases Wiki Activity

Add Config setter functions for Serialize derivation

Browse Source
This commit is contained in:
Harendra Kumar 2023-11-21 23:14:46 +05:30 committed by Adithya Kumar
parent db06710987
commit e7f6e7e9eb
10 changed files with 169 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
benchmark/Streamly/Benchmark/Data/Serialize/RecCompatible.hs
View File

@ -20,5 +20,5 @@ import qualified Streamly.Internal.Data.Serialize as Serialize
$(genLargeRecord "RecCompatible" 50)
$(Serialize.deriveSerializeWith
(Serialize.defaultConfig {Serialize.recordSyntaxWithHeader = True})
(Serialize.encodeRecordFields True Serialize.defaultConfig)
[d|instance Serialize RecCompatible|])

12
core/src/Streamly/Data/Serialize.hs
View File

@ -51,14 +51,20 @@ module Streamly.Data.Serialize
-- * Serialize
, Serialize(..)
-- XXX Need to export the config setters as well.
, defaultConfig
-- Deriving instances
, Config -- XXX rename to SerializeConfig
, defaultConfig -- XXX rename to defaultSerializeConfig
, inlineSize
, inlineSerialize
, inlineDeserialize
, deriveSerialize
, deriveSerializeWith
-- Encoding and Decoding
-- , encode
, pinnedEncode
, decode
) where

6
core/src/Streamly/Internal/Data/IORef/Unboxed.hs
View File

@ -23,14 +23,14 @@ module Streamly.Internal.Data.IORef.Unboxed
(
IORef
-- * Construction
-- Construction
, newIORef
-- * Write
-- Write
, writeIORef
, modifyIORef'
-- * Read
-- Read
, readIORef
, toStreamD
)

10
core/src/Streamly/Internal/Data/Serialize.hs
View File

@ -22,9 +22,6 @@ module Streamly.Internal.Data.Serialize
, module Streamly.Internal.Data.Serialize.Type
-- * Serialize TH
, module Streamly.Internal.Data.Serialize.TH
, module Streamly.Internal.Data.Serialize.TH.RecHeader
, module Streamly.Internal.Data.Serialize.TH.Common
, module Streamly.Internal.Data.Serialize.TH.Bottom
) where
--------------------------------------------------------------------------------
@ -42,14 +39,11 @@ import GHC.Num.Integer (Integer(..))
import GHC.Integer.GMP.Internals (Integer(..), BigNat(..))
#endif
import Streamly.Internal.Data.IORef.Unboxed
import Streamly.Internal.Data.Serialize.TH
import Streamly.Internal.Data.Serialize.Type
import Streamly.Internal.Data.Unbox
import Streamly.Internal.Data.Unbox.TH
import Streamly.Internal.Data.Serialize.TH
import Streamly.Internal.Data.Serialize.TH.RecHeader
import Streamly.Internal.Data.Serialize.TH.Common
import Streamly.Internal.Data.Serialize.TH.Bottom
import Streamly.Internal.Data.IORef.Unboxed
--------------------------------------------------------------------------------
-- Common instances

42
core/src/Streamly/Internal/Data/Serialize/TH.hs
View File

@ -9,10 +9,17 @@
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH
( deriveSerialize
, Config(..)
, defaultConfig
(
-- Deriving
deriveSerialize
, deriveSerializeWith
-- Utilities
, module Streamly.Internal.Data.Serialize.TH.Bottom
-- ** Common
, module Streamly.Internal.Data.Serialize.TH.Common
-- ** RecHeader
, module Streamly.Internal.Data.Serialize.TH.RecHeader
) where
--------------------------------------------------------------------------------
@ -37,6 +44,7 @@ import qualified Streamly.Internal.Data.Serialize.TH.RecHeader as RecHeader
import Streamly.Internal.Data.Serialize.TH.Bottom
import Streamly.Internal.Data.Serialize.TH.Common
import Streamly.Internal.Data.Serialize.TH.RecHeader
--------------------------------------------------------------------------------
-- Domain specific helpers
@ -148,7 +156,7 @@ mkSizeOfExpr False False tyOfTy =
[varP _acc, varP _x]
(caseE (varE _x) (fmap (matchCons acc) cons))
mkSizeOfExpr False True (TheType con) = RecHeader.mkSizeOfExpr con
mkSizeOfExpr False True (TheType con) = RecHeader.mkRecSizeOfExpr con
mkSizeOfExpr _ _ _ = errorUnimplemented
@ -157,11 +165,11 @@ mkSizeDec (Config {..}) headTy cons = do
-- INLINE on sizeOf actually worsens some benchmarks, and improves none
sizeOfMethod <-
mkSizeOfExpr
constructorTagAsString
recordSyntaxWithHeader
cfgConstructorTagAsString
cfgRecordSyntaxWithHeader
(typeOfType headTy cons)
pure
[ PragmaD (InlineP 'size inlineSize FunLike AllPhases)
[ PragmaD (InlineP 'size cfgInlineSize FunLike AllPhases)
, FunD 'size [Clause [] (NormalB sizeOfMethod) []]
]
@ -250,7 +258,7 @@ mkDeserializeExpr False True _ (TheType con@(SimpleDataCon _ fields)) = do
RecHeader.mkDeserializeKeysDec deserializeWithKeys updateFunc con
letE
(pure <$> (deserializeWithKeysDec ++ updateFuncDec))
(RecHeader.mkDeserializeExpr
(RecHeader.mkRecDeserializeExpr
_initialOffset
_endOffset
deserializeWithKeys
@ -262,16 +270,16 @@ mkDeserializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
mkDeserializeDec (Config {..}) headTy cons = do
peekMethod <-
mkDeserializeExpr
constructorTagAsString
recordSyntaxWithHeader
cfgConstructorTagAsString
cfgRecordSyntaxWithHeader
headTy
(typeOfType headTy cons)
pure
[ PragmaD (InlineP 'deserialize inlineDeserialize FunLike AllPhases)
[ PragmaD (InlineP 'deserialize cfgInlineDeserialize FunLike AllPhases)
, FunD
'deserialize
[ Clause
(if isUnitType cons && not constructorTagAsString
(if isUnitType cons && not cfgConstructorTagAsString
then [VarP _initialOffset, WildP, WildP]
else [VarP _initialOffset, VarP _arr, VarP _endOffset])
(NormalB peekMethod)
@ -359,7 +367,7 @@ mkSerializeExpr False False tyOfTy =
(zip [0 ..] cons))
mkSerializeExpr False True (TheType con) =
RecHeader.mkSerializeExpr _initialOffset con
RecHeader.mkRecSerializeExpr _initialOffset con
mkSerializeExpr _ _ _ = errorUnimplemented
@ -367,15 +375,15 @@ mkSerializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
mkSerializeDec (Config {..}) headTy cons = do
pokeMethod <-
mkSerializeExpr
constructorTagAsString
recordSyntaxWithHeader
cfgConstructorTagAsString
cfgRecordSyntaxWithHeader
(typeOfType headTy cons)
pure
[ PragmaD (InlineP 'serialize inlineSerialize FunLike AllPhases)
[ PragmaD (InlineP 'serialize cfgInlineSerialize FunLike AllPhases)
, FunD
'serialize
[ Clause
(if isUnitType cons && not constructorTagAsString
(if isUnitType cons && not cfgConstructorTagAsString
then [VarP _initialOffset, WildP, WildP]
else [VarP _initialOffset, VarP _arr, VarP _val])
(NormalB pokeMethod)

151
core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs
View File

@ -9,8 +9,17 @@
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH.Bottom
( Config(..)
(
-- ** Config
Config(..)
, defaultConfig
, inlineSize
, inlineSerialize
, inlineDeserialize
, encodeConstrNames
, encodeRecordFields
-- ** Other Utilities
, TypeOfType(..)
, typeOfType
, SimpleDataCon(..)
@ -65,48 +74,118 @@ import Streamly.Internal.Data.Unbox.TH (DataCon(..))
-- Config
--------------------------------------------------------------------------------
-- | Config to control how the 'Serialize' instance is generated.
-- XXX Need to make it (Maybe Inline) so that we can use Nothing as default.
-- | Configuration to control how the 'Serialize' instance is generated. Use
-- 'defaultConfig' and config setter functions to generate desired Config. For
-- example:
--
-- >>> (inlineSize Inline) . (inlineSerialize Inlinable) defaultConfig
--
data Config =
Config
{ inlineSize :: Inline
-- ^ Inline value for 'size'. Default is Inline.
, inlineSerialize :: Inline
-- ^ Inline value for 'serialize'. Default is Inline.
, inlineDeserialize :: Inline
-- ^ Inline value for 'deserialize'. Default is Inline.
, constructorTagAsString :: Bool
-- ^ __Experimental__
--
-- If True, encode constructors using the constructor names as Latin-1
-- byte sequence.
, recordSyntaxWithHeader :: Bool
-- ^ __Experimental__
--
-- If True, encode the keys of the record as a header and then
-- serialize the data. Multiple constructors are not supported with
-- @recordSyntaxWithHeader@ enabled.
--
-- __Performance Notes:__
--
-- There is a constant regression proportional to
-- @sum (map length keyList) + length keyList@ where @keyList@ is the
-- list of keys of that record as strings.
--
-- As an example, @keyList@ of,
-- @
-- data RecordType = RecordType { field0 :: Int, field2 :: Char }
-- @
-- is @["field0", "field1"]@
{ cfgInlineSize :: Inline
, cfgInlineSerialize :: Inline
, cfgInlineDeserialize :: Inline
, cfgConstructorTagAsString :: Bool
, cfgRecordSyntaxWithHeader :: Bool
}
-- | How should we inline the 'size' function? The default in 'defaultConfig'
-- is 'Inline'. However, aggressive inlining can bloat the code and increase
-- compilation times in when there are big functions and too many nesting
-- levels so you can change it accordingly.
inlineSize :: Inline -> Config -> Config
inlineSize v cfg = cfg {cfgInlineSize = v}
-- | How should we inline the 'serialize' function? See guidelines in
-- 'inlineSize'.
inlineSerialize :: Inline -> Config -> Config
inlineSerialize v cfg = cfg {cfgInlineSerialize = v}
-- | How should we inline the 'deserialize' function? See guidelines in
-- 'inlineSize'.
inlineDeserialize :: Inline -> Config -> Config
inlineDeserialize v cfg = cfg {cfgInlineDeserialize = v}
-- | __Experimental__
--
-- In sum types, use Latin-1 encoded original constructor names rather than
-- binary values to identify constructors. This option is not useful on a
-- product type.
--
-- This option enables the following backward compatible behavior:
--
-- * __Reordering__: Order of the fields can be changed without affecting
-- serialization.
-- * __Addition__: If a field is added in the new version, the old version of
-- the data type can still be deserialized by the new version. The new value
-- would never occur in the old one.
-- * __Deletion__: If a field is deleted in the new version and deserialization
-- of the old version will result in an error. TBD: We can possibly designate a
-- catch-all field to handle this case.
--
-- Note that if you change a type, change the semantics of a type, or delete a
-- field and add a new field with the same name, deserialization of old data
-- may result in silent unexpected behavior.
--
-- This option has to be the same on both encoding and decoding side.
-- The default is 'False'.
--
encodeConstrNames :: Bool -> Config -> Config
encodeConstrNames v cfg = cfg {cfgConstructorTagAsString = v}
-- XXX We can deserialize each field to Either, so if there is a
-- deserialization error in any field it can handled independently. Also, a
-- unique type/version identifier of the field (based on the versions of the
-- packages, full module name space + type identifier) can be serialized along
-- with the value for stricter compatibility, semantics checking. Or we can
-- store a type hash.
-- | __Experimental__
--
-- In explicit record types, use Latin-1 encoded record field names rather than
-- binary values to identify the record fields. Note that this option cannot be
-- used on a sum type. Also, it does not work on a product type which is not a
-- record, because there are no field names to begin with.
--
-- This option enables the following backward compatible behavior:
--
-- * __Reordering__: Order of the fields can be changed without affecting
-- serialization.
-- * __Addition__: If a 'Maybe' type field is added in the new version, the old
-- version of the data type can still be deserialized by the new version, the
-- field value in the older version is assumed to be 'Nothing'. If any other
-- type of field is added, deserialization of the older version results in an
-- error but only when that field is accessed in the deserialized record.
-- * __Deletion__: If a field is deleted in the new version and it is
-- encountered in a previously serialized version then the field is discarded.
-- TBD: We can possibly designate a catch-all field to handle this case.
--
-- This option has to be the same on both encoding and decoding side.
--
-- There is a constant performance overhead proportional to the total length of
-- the record field names and the number of record fields.
--
-- The default is 'False'.
--
encodeRecordFields :: Bool -> Config -> Config
encodeRecordFields v cfg = cfg {cfgRecordSyntaxWithHeader = v}
-- | The default configuration settings are:
--
-- * 'inlineSize' 'Inline'
-- * 'inlineSerialize' 'Inline'
-- * 'inlineDeserialize' 'Inline'
--
defaultConfig :: Config
defaultConfig =
Config
{ inlineSize = Inline
, inlineSerialize = Inline
, inlineDeserialize = Inline
, constructorTagAsString = False
, recordSyntaxWithHeader = False
{ cfgInlineSize = Inline
, cfgInlineSerialize = Inline
, cfgInlineDeserialize = Inline
, cfgConstructorTagAsString = False
, cfgRecordSyntaxWithHeader = False
}
--------------------------------------------------------------------------------

18
core/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs
View File

@ -9,9 +9,9 @@
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH.RecHeader
( mkSerializeExpr
, mkDeserializeExpr
, mkSizeOfExpr
( mkRecSerializeExpr
, mkRecDeserializeExpr
, mkRecSizeOfExpr
, conUpdateFuncDec
, mkDeserializeKeysDec
) where
@ -171,8 +171,8 @@ sizeOfHeader (SimpleDataCon _ fields) =
sizeForNumFields = 1 -- At max 255 fields in the record constructor
sizeForFieldLen = 1 -- At max 255 letters in the key
mkSizeOfExpr :: SimpleDataCon -> Q Exp
mkSizeOfExpr con = do
mkRecSizeOfExpr :: SimpleDataCon -> Q Exp
mkRecSizeOfExpr con = do
n_acc <- newName "acc"
n_x <- newName "x"
(lamE
@ -231,8 +231,8 @@ serializeWithSize off arr val = do
Unbox.pokeByteIndex off arr (int_w32 (off1 - off - 4) :: Word32)
pure off1
mkSerializeExpr :: Name -> SimpleDataCon -> Q Exp
mkSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp
mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
afterHLen <- newName "afterHLen"
-- Encoding the header length is required.
-- We first compare the header length encoded and the current header
@ -383,8 +383,8 @@ mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do
else [|error $(litE (StringL (nameBase k ++ " is not found.")))|]
mkDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp
mkDeserializeExpr initialOff endOff deserializeWithKeys con = do
mkRecDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp
mkRecDeserializeExpr initialOff endOff deserializeWithKeys con = do
hOff <- newName "hOff"
let sizeForFinalOff = 4 -- Word32
sizeForHeaderLength = 4 -- Word32

2
test/Streamly/Test/Data/Serialize.hs
View File

@ -45,7 +45,7 @@ import Test.Hspec as H
#ifdef ENABLE_constructorTagAsString
#define CONF_NAME "ENABLE_constructorTagAsString"
#define CONF (Serialize.defaultConfig {Serialize.constructorTagAsString = True})
#define CONF (Serialize.encodeConstrNames True Serialize.defaultConfig)
#else
#define CONF_NAME "DEFAULT"
#define CONF Serialize.defaultConfig

4
test/Streamly/Test/Data/Serialize/CompatV0.hs
View File

@ -29,7 +29,7 @@ instance Arbitrary a => Arbitrary (Rec a) where
arbitrary = Rec <$> arbitrary <*> arbitrary <*> arbitrary
$(Serialize.deriveSerializeWith
(Serialize.defaultConfig {Serialize.recordSyntaxWithHeader = True})
(Serialize.encodeRecordFields True Serialize.defaultConfig)
[d|instance Serialize a => Serialize (Rec a)|])
data River
@ -42,5 +42,5 @@ instance Arbitrary River where
arbitrary = elements [Ganga, Yamuna, Godavari]
$(Serialize.deriveSerializeWith
(Serialize.defaultConfig {Serialize.constructorTagAsString = True})
(Serialize.encodeConstrNames True Serialize.defaultConfig)
[d|instance Serialize River|])

4
test/Streamly/Test/Data/Serialize/CompatV1.hs
View File

@ -30,7 +30,7 @@ instance Arbitrary a => Arbitrary (Rec a) where
arbitrary = Rec <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
$(Serialize.deriveSerializeWith
(Serialize.defaultConfig {Serialize.recordSyntaxWithHeader = True})
(Serialize.encodeRecordFields True Serialize.defaultConfig)
[d|instance Serialize a => Serialize (Rec a)|])
data River
@ -44,5 +44,5 @@ instance Arbitrary River where
arbitrary = elements [Ganga, Yamuna, Godavari]
$(Serialize.deriveSerializeWith
(Serialize.defaultConfig {Serialize.constructorTagAsString = True})
(Serialize.encodeConstrNames True Serialize.defaultConfig)
[d|instance Serialize River|])