mirror of
https://github.com/composewell/streamly.git
synced 2024-08-17 07:20:36 +03:00
Add Config setter functions for Serialize derivation
This commit is contained in:
parent
db06710987
commit
e7f6e7e9eb
@ -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|])
|
||||
|
@ -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
|
||||
|
||||
|
@ -23,14 +23,14 @@ module Streamly.Internal.Data.IORef.Unboxed
|
||||
(
|
||||
IORef
|
||||
|
||||
-- * Construction
|
||||
-- Construction
|
||||
, newIORef
|
||||
|
||||
-- * Write
|
||||
-- Write
|
||||
, writeIORef
|
||||
, modifyIORef'
|
||||
|
||||
-- * Read
|
||||
-- Read
|
||||
, readIORef
|
||||
, toStreamD
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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|])
|
||||
|
@ -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|])
|
||||
|
Loading…
Reference in New Issue
Block a user