@@ -10,6 +10,8 @@
11module Streamly.Internal.Data.Serialize.TH
11module Streamly.Internal.Data.Serialize.TH
12 ( deriveSerialize
12 ( deriveSerialize
13+ , SerializeTHConfig(..)
14+ , defaultSerializeTHConfig
13 , deriveSerializeWith
15 , deriveSerializeWith
@@ -362,28 +364,72 @@ deriveSerializeInternal preds headTy cons = do
363 return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
365 return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
367+-- | Config to control how the 'Serialize' instance is generated.
368+data SerializeTHConfig =
370+ { unconstrainedTypeVars :: [String]
371+ -- ^ Type variables that should not have the 'Serialize' constraint.
374+ -- data CustomDataType a b c d = CustomDataType a c
378+ -- conf = defaultConf {unconstrainedTypeVars = ["b", "d"]}
379+ -- $(deriveSerializeWith conf ''CustomDataType)
383+ -- instance (Serialize a, Serialize c) => Serialize (CustomDataType a b c d) where
386+ , typeVarSubstitutions :: [(String, Type)]
387+ -- ^ Substitute the type variable with the given type. All type
388+ -- variables listed here will not have the 'Serialize' constriant as
389+ -- they are replaced.
392+ -- data CustomDataType f a = CustomDataType (f a)
396+ -- conf = defaultConf {typeVarSubstitutions = [("f", ''Identity)]}
397+ -- $(deriveSerializeWith conf ''CustomDataType)
401+ -- instance (Serialize a) => Serialize (CustomDataType Identity a) where
405+ -- @f@ is replaced with 'Identity' and becomes unconstrained.
407+ , inlineSize :: Inline
408+ -- ^ Inline value for 'size'.
409+ , inlineSerialize :: Inline
410+ -- ^ Inline value for 'serialize'.
411+ , inlineDeserialize :: Inline
412+ -- ^ Inline value for 'deserialize'.
413+ , constructorTagAsString :: Bool
414+ -- ^ If True, encode constructors as Latin-1 byte sequence. This
415+ -- allows addition, removal, and reordering of constructors. If False
416+ -- encode them as numbers. The default value is 'False'.
417+ , recordSyntaxWithHeader :: Bool
418+ -- ^ If True, constructors with record syntax will be encoded in a
419+ -- more compatible way. Allows addition, removal, and reordering of
420+ -- fields. The default value is 'False'.
424+defaultSerializeTHConfig :: SerializeTHConfig
425+defaultSerializeTHConfig = SerializeTHConfig {unconstrainedTypeVars = [], typeVarSubstitutions = []}
365−-- | Similar to 'deriveSerialize,' but with the ability to specify which type
427+-- | Similar to 'deriveSerialize,' but take a 'SerializeTHConfig' to control how
366−-- variables should not be subjected to the 'Serialize' constraint and how to
428+-- the instance is generated.
367−-- replace these variables when defining the 'Serialize' instance for the
368−-- primary data type.
370−-- Consider the datatype:
372−-- data CustomDataType a f c = CDT a (f Int)
375−-- Usage: @$(deriveSerializeWith ["c", "f"] [("f", ConT ''Identity)] ''CustomDataType)@
430+-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
378−-- instance (Serialize a) => Serialize (CustomDataType a Identity c) where
382−-- In the above example, 'Serialize' constraint is omitted for @f@ and @c@, and
383−-- @f@ is replaced with 'Identity' when defining the 'Serialize' instance for
384−-- the primary data type.
385−deriveSerializeWith :: [String] -> [(String, Type)] -> Name -> Q [Dec]
431+deriveSerializeWith :: SerializeTHConfig -> Name -> Q [Dec]
386−deriveSerializeWith ignoring substitutions name = do
432+deriveSerializeWith (SerializeTHConfig {..}) name = do
387 dt <- reifyDataType name
433 dt <- reifyDataType name
388 let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
434 let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
389 headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
435 headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
@@ -391,11 +437,14 @@ deriveSerializeWith ignoring substitutions name = do
391 deriveSerializeInternal preds headTy cons
437 deriveSerializeInternal preds headTy cons
394−
440+ allUnconstrainedTypeVars =
441+ unconstrainedTypeVars ++ map fst typeVarSubstitutions
395 filterOutVars vs =
442 filterOutVars vs =
444+ $ filter (not . flip elem allUnconstrainedTypeVars)
396− map mkName $ filter (not . flip elem ignoring) $ map nameBase vs
445+ $ map nameBase vs
397 substituteVar v =
446 substituteVar v =
398− case lookup (nameBase v) substitutions of
447+ case lookup (nameBase v) typeVarSubstitutions of
399 Nothing -> VarT v
448 Nothing -> VarT v
400 Just ty -> ty
449 Just ty -> ty
@@ -425,6 +474,6 @@ deriveSerializeWith ignoring substitutions name = do
425-- To control which type variables don't get the Serialize constraint, use
474-- To control which type variables don't get the Serialize constraint, use
426-- 'deriveSerializeWith'.
475-- 'deriveSerializeWith'.
428−-- >>> deriveSerialize = deriveSerializeWith [] []
477+-- >>> deriveSerialize = deriveSerializeWith 'defaultSerializeTHConfig'
429deriveSerialize :: Name -> Q [Dec]
478deriveSerialize :: Name -> Q [Dec]
430−deriveSerialize name = deriveSerializeWith [] [] name
479+deriveSerialize name = deriveSerializeWith defaultSerializeTHConfig name