mirror of
https://github.com/composewell/streamly.git
synced 2024-09-11 11:37:22 +03:00
Change the API and update doc of a few APIs in Serialize.TH
This commit is contained in:
parent
023c3c965a
commit
9393f55e7d
@ -10,8 +10,8 @@
|
|||||||
--
|
--
|
||||||
module Streamly.Internal.Data.Serialize.TH
|
module Streamly.Internal.Data.Serialize.TH
|
||||||
( deriveSerialize
|
( deriveSerialize
|
||||||
, SerializeTHConfig(..)
|
, Config(..)
|
||||||
, defaultSerializeTHConfig
|
, defaultConfig
|
||||||
, deriveSerializeWith
|
, deriveSerializeWith
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -324,7 +324,7 @@ mkSerializeExpr tyOfTy =
|
|||||||
-- Usage:
|
-- Usage:
|
||||||
-- @
|
-- @
|
||||||
-- $(deriveSerializeInternal
|
-- $(deriveSerializeInternal
|
||||||
-- defaultSerializeTHConfig
|
-- defaultConfig
|
||||||
-- [AppT (ConT ''Serialize) (VarT (mkName "b"))]
|
-- [AppT (ConT ''Serialize) (VarT (mkName "b"))]
|
||||||
-- (AppT
|
-- (AppT
|
||||||
-- (AppT (ConT ''CustomDataType) (VarT (mkName "a")))
|
-- (AppT (ConT ''CustomDataType) (VarT (mkName "a")))
|
||||||
@ -339,8 +339,8 @@ mkSerializeExpr tyOfTy =
|
|||||||
-- ])
|
-- ])
|
||||||
-- @
|
-- @
|
||||||
deriveSerializeInternal ::
|
deriveSerializeInternal ::
|
||||||
SerializeTHConfig -> Cxt -> Type -> [DataCon] -> Q [Dec]
|
Config -> Cxt -> Type -> [DataCon] -> Q [Dec]
|
||||||
deriveSerializeInternal (SerializeTHConfig{..}) preds headTy cons = do
|
deriveSerializeInternal (Config{..}) preds headTy cons = do
|
||||||
sizeOfMethod <- mkSizeOfExpr (typeOfType headTy cons)
|
sizeOfMethod <- mkSizeOfExpr (typeOfType headTy cons)
|
||||||
peekMethod <- mkDeserializeExpr headTy (typeOfType headTy cons)
|
peekMethod <- mkDeserializeExpr headTy (typeOfType headTy cons)
|
||||||
pokeMethod <- mkSerializeExpr (typeOfType headTy cons)
|
pokeMethod <- mkSerializeExpr (typeOfType headTy cons)
|
||||||
@ -373,9 +373,9 @@ deriveSerializeInternal (SerializeTHConfig{..}) preds headTy cons = do
|
|||||||
return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
|
return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
|
||||||
|
|
||||||
-- | Config to control how the 'Serialize' instance is generated.
|
-- | Config to control how the 'Serialize' instance is generated.
|
||||||
data SerializeTHConfig =
|
data Config =
|
||||||
SerializeTHConfig
|
Config
|
||||||
{ unconstrainedTypeVars :: [String]
|
{ unconstrained :: [String]
|
||||||
-- ^ Type variables that should not have the 'Serialize' constraint.
|
-- ^ Type variables that should not have the 'Serialize' constraint.
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
@ -383,26 +383,26 @@ data SerializeTHConfig =
|
|||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
-- conf = defaultConf {unconstrainedTypeVars = ["b", "d"]}
|
-- conf = defaultConf {unconstrained = ["b", "d"]}
|
||||||
-- $(deriveSerializeWith conf ''CustomDataType)
|
-- \$(deriveSerializeWith conf ''CustomDataType)
|
||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
-- instance (Serialize a, Serialize c) => Serialize (CustomDataType a b c d) where
|
-- instance (Serialize a, Serialize c) => Serialize (CustomDataType a b c d) where
|
||||||
-- ...
|
-- ...
|
||||||
-- @
|
-- @
|
||||||
, typeVarSubstitutions :: [(String, Type)]
|
, specializations :: [(String, Type)]
|
||||||
-- ^ Substitute the type variable with the given type. All type
|
-- ^ Specialize the type variable with the given type. All type
|
||||||
-- variables listed here will not have the 'Serialize' constriant as
|
-- variables listed here will not have the 'Serialize' constriant as
|
||||||
-- they are replaced.
|
-- they are specialized.
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
-- data CustomDataType f a = CustomDataType (f a)
|
-- data CustomDataType f a = CustomDataType (f a)
|
||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
-- conf = defaultConf {typeVarSubstitutions = [("f", ''Identity)]}
|
-- conf = defaultConf {specializations = [("f", ''Identity)]}
|
||||||
-- $(deriveSerializeWith conf ''CustomDataType)
|
-- \$(deriveSerializeWith conf ''CustomDataType)
|
||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
@ -418,20 +418,22 @@ data SerializeTHConfig =
|
|||||||
, inlineDeserialize :: Inline
|
, inlineDeserialize :: Inline
|
||||||
-- ^ Inline value for 'deserialize'. Default is Inline.
|
-- ^ Inline value for 'deserialize'. Default is Inline.
|
||||||
, constructorTagAsString :: Bool
|
, constructorTagAsString :: Bool
|
||||||
-- ^ If True, encode constructors as Latin-1 byte sequence. This
|
-- ^ __Experimental__
|
||||||
-- allows addition, removal, and reordering of constructors. If False
|
--
|
||||||
-- encode them as numbers. The default value is 'False'.
|
-- If True, encode constructors using the constructor names as Latin-1
|
||||||
|
-- byte sequence.
|
||||||
, recordSyntaxWithHeader :: Bool
|
, recordSyntaxWithHeader :: Bool
|
||||||
-- ^ If True, constructors with record syntax will be encoded in a
|
-- ^ __Experimental__
|
||||||
-- more compatible way. Allows addition, removal, and reordering of
|
--
|
||||||
-- fields. The default value is 'False'.
|
-- If True, encode the keys of the record as a header and then
|
||||||
|
-- serialize the data.
|
||||||
}
|
}
|
||||||
|
|
||||||
defaultSerializeTHConfig :: SerializeTHConfig
|
defaultConfig :: Config
|
||||||
defaultSerializeTHConfig =
|
defaultConfig =
|
||||||
SerializeTHConfig
|
Config
|
||||||
{ unconstrainedTypeVars = []
|
{ unconstrained = []
|
||||||
, typeVarSubstitutions = []
|
, specializations = []
|
||||||
, inlineSize = Inline
|
, inlineSize = Inline
|
||||||
, inlineSerialize = Inline
|
, inlineSerialize = Inline
|
||||||
, inlineDeserialize = Inline
|
, inlineDeserialize = Inline
|
||||||
@ -439,12 +441,12 @@ defaultSerializeTHConfig =
|
|||||||
, recordSyntaxWithHeader = False
|
, recordSyntaxWithHeader = False
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Similar to 'deriveSerialize,' but take a 'SerializeTHConfig' to control how
|
-- | Similar to 'deriveSerialize,' but take a 'Config' to control how
|
||||||
-- the instance is generated.
|
-- the instance is generated.
|
||||||
--
|
--
|
||||||
-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
|
-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
|
||||||
deriveSerializeWith :: SerializeTHConfig -> Name -> Q [Dec]
|
deriveSerializeWith :: Config -> Name -> Q [Dec]
|
||||||
deriveSerializeWith conf@(SerializeTHConfig {..}) name = do
|
deriveSerializeWith conf@(Config {..}) name = do
|
||||||
dt <- reifyDataType name
|
dt <- reifyDataType name
|
||||||
let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
|
let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
|
||||||
headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
|
headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
|
||||||
@ -453,13 +455,13 @@ deriveSerializeWith conf@(SerializeTHConfig {..}) name = do
|
|||||||
|
|
||||||
where
|
where
|
||||||
allUnconstrainedTypeVars =
|
allUnconstrainedTypeVars =
|
||||||
unconstrainedTypeVars ++ map fst typeVarSubstitutions
|
unconstrained ++ map fst specializations
|
||||||
filterOutVars vs =
|
filterOutVars vs =
|
||||||
map mkName
|
map mkName
|
||||||
$ filter (not . flip elem allUnconstrainedTypeVars)
|
$ filter (not . flip elem allUnconstrainedTypeVars)
|
||||||
$ map nameBase vs
|
$ map nameBase vs
|
||||||
substituteVar v =
|
substituteVar v =
|
||||||
case lookup (nameBase v) typeVarSubstitutions of
|
case lookup (nameBase v) specializations of
|
||||||
Nothing -> VarT v
|
Nothing -> VarT v
|
||||||
Just ty -> ty
|
Just ty -> ty
|
||||||
|
|
||||||
@ -489,6 +491,7 @@ deriveSerializeWith conf@(SerializeTHConfig {..}) name = do
|
|||||||
-- To control which type variables don't get the Serialize constraint, use
|
-- To control which type variables don't get the Serialize constraint, use
|
||||||
-- 'deriveSerializeWith'.
|
-- 'deriveSerializeWith'.
|
||||||
--
|
--
|
||||||
-- >>> deriveSerialize = deriveSerializeWith 'defaultSerializeTHConfig'
|
-- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize
|
||||||
|
-- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig
|
||||||
deriveSerialize :: Name -> Q [Dec]
|
deriveSerialize :: Name -> Q [Dec]
|
||||||
deriveSerialize name = deriveSerializeWith defaultSerializeTHConfig name
|
deriveSerialize name = deriveSerializeWith defaultConfig name
|
||||||
|
@ -23,11 +23,11 @@ module Streamly.Test.Data.Serialize (main) where
|
|||||||
import Streamly.Internal.Data.Unbox (newBytes)
|
import Streamly.Internal.Data.Unbox (newBytes)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Streamly.Test.Data.Serialize.TH (genDatatype)
|
import Streamly.Test.Data.Serialize.TH (genDatatype)
|
||||||
import Streamly.Internal.Data.Serialize.TH
|
import qualified Streamly.Internal.Data.Serialize.TH as Serialize
|
||||||
( deriveSerialize
|
( deriveSerialize
|
||||||
, deriveSerializeWith
|
, deriveSerializeWith
|
||||||
, defaultSerializeTHConfig
|
, defaultConfig
|
||||||
, SerializeTHConfig(..)
|
, Config(..)
|
||||||
)
|
)
|
||||||
import Data.Functor.Identity (Identity (..))
|
import Data.Functor.Identity (Identity (..))
|
||||||
|
|
||||||
@ -43,7 +43,7 @@ import Test.Hspec as H
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
$(genDatatype "CustomDatatype" 15)
|
$(genDatatype "CustomDatatype" 15)
|
||||||
$(deriveSerialize ''CustomDatatype)
|
$(Serialize.deriveSerialize ''CustomDatatype)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Types with functional parameters
|
-- Types with functional parameters
|
||||||
@ -61,10 +61,10 @@ instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where
|
|||||||
instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
|
instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
|
||||||
show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)
|
show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)
|
||||||
|
|
||||||
$(deriveSerialize ''Identity)
|
$(Serialize.deriveSerialize ''Identity)
|
||||||
$(deriveSerializeWith
|
$(Serialize.deriveSerializeWith
|
||||||
(defaultSerializeTHConfig
|
(Serialize.defaultConfig
|
||||||
{typeVarSubstitutions = [("f", ConT ''Identity)]})
|
{Serialize.specializations = [("f", ConT ''Identity)]})
|
||||||
''HigherOrderType)
|
''HigherOrderType)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
@ -77,7 +77,7 @@ data BinTree a
|
|||||||
| Leaf a
|
| Leaf a
|
||||||
deriving (Show, Read, Eq, Generic)
|
deriving (Show, Read, Eq, Generic)
|
||||||
|
|
||||||
$(deriveSerialize ''BinTree)
|
$(Serialize.deriveSerialize ''BinTree)
|
||||||
|
|
||||||
instance Arbitrary a => Arbitrary (BinTree a) where
|
instance Arbitrary a => Arbitrary (BinTree a) where
|
||||||
arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
|
arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
|
||||||
|
@ -30,7 +30,7 @@ import GHC.Real (Ratio(..))
|
|||||||
#ifdef USE_SERIALIZE
|
#ifdef USE_SERIALIZE
|
||||||
|
|
||||||
import Streamly.Internal.Data.Serialize (Serialize(..))
|
import Streamly.Internal.Data.Serialize (Serialize(..))
|
||||||
import Streamly.Internal.Data.Serialize.TH
|
import qualified Streamly.Internal.Data.Serialize.TH as Serialize
|
||||||
|
|
||||||
#else
|
#else
|
||||||
|
|
||||||
@ -63,7 +63,7 @@ import Test.Hspec as H
|
|||||||
#ifdef USE_SERIALIZE
|
#ifdef USE_SERIALIZE
|
||||||
|
|
||||||
#define MODULE_NAME "Data.Serialize.Deriving.TH"
|
#define MODULE_NAME "Data.Serialize.Deriving.TH"
|
||||||
#define DERIVE_UNBOX(typ) $(deriveSerialize ''typ)
|
#define DERIVE_UNBOX(typ) $(Serialize.deriveSerialize ''typ)
|
||||||
#define PEEK(i, arr, sz) (deserialize i arr sz)
|
#define PEEK(i, arr, sz) (deserialize i arr sz)
|
||||||
#define POKE(i, arr, val) (serialize i arr val)
|
#define POKE(i, arr, val) (serialize i arr val)
|
||||||
#define TYPE_CLASS Serialize
|
#define TYPE_CLASS Serialize
|
||||||
@ -190,12 +190,12 @@ DERIVE_UNBOX(NestedSOP)
|
|||||||
deriving instance Generic (Ratio Int)
|
deriving instance Generic (Ratio Int)
|
||||||
|
|
||||||
#if defined(USE_SERIALIZE)
|
#if defined(USE_SERIALIZE)
|
||||||
$(deriveSerialize ''Complex)
|
$(Serialize.deriveSerialize ''Complex)
|
||||||
$(deriveSerialize ''Ratio)
|
$(Serialize.deriveSerialize ''Ratio)
|
||||||
$(deriveSerializeWith
|
$(Serialize.deriveSerializeWith
|
||||||
(defaultSerializeTHConfig {unconstrainedTypeVars = ["b"]})
|
(Serialize.defaultConfig {Serialize.unconstrained = ["b"]})
|
||||||
''Const)
|
''Const)
|
||||||
$(deriveSerialize ''Identity)
|
$(Serialize.deriveSerialize ''Identity)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
Loading…
Reference in New Issue
Block a user