mirror of
https://github.com/composewell/streamly.git
synced 2024-08-17 07:20:36 +03:00
Use more expressive notation for deriveSerializeWith
This commit is contained in:
parent
4f00d1f54a
commit
60a71dcbb5
@ -61,8 +61,8 @@ import Streamly.Internal.Data.Serialize.Type
|
||||
$(Serialize.deriveSerialize ''Maybe)
|
||||
$(Serialize.deriveSerialize ''Either)
|
||||
$(Serialize.deriveSerializeWith
|
||||
(Serialize.defaultConfig {Serialize.unconstrained = ["t"]})
|
||||
''Proxy)
|
||||
Serialize.defaultConfig
|
||||
[d|instance Serialize (Proxy a)|])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Integer
|
||||
|
@ -30,7 +30,6 @@ import Streamly.Internal.Data.Unbox.TH
|
||||
( DataCon(..)
|
||||
, DataType(..)
|
||||
, appsT
|
||||
, plainInstanceD
|
||||
, reifyDataType
|
||||
)
|
||||
|
||||
@ -381,44 +380,47 @@ mkSerializeDec (Config {..}) headTy cons = do
|
||||
-- ])
|
||||
-- @
|
||||
deriveSerializeInternal ::
|
||||
Config -> Cxt -> Type -> [DataCon] -> Q [Dec]
|
||||
deriveSerializeInternal conf preds headTy cons = do
|
||||
Config -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
|
||||
deriveSerializeInternal conf headTy cons next = do
|
||||
sizeDec <- mkSizeDec conf headTy cons
|
||||
peekDec <- mkDeserializeDec conf headTy cons
|
||||
pokeDec <- mkSerializeDec conf headTy cons
|
||||
let methods = concat [sizeDec, peekDec, pokeDec]
|
||||
return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
|
||||
next methods
|
||||
|
||||
-- | Similar to 'deriveSerialize,' but take a 'Config' to control how
|
||||
-- the instance is generated.
|
||||
-- | Similar to 'deriveSerialize' but take a 'Config' to control how the
|
||||
-- instance is generated.
|
||||
--
|
||||
-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
|
||||
deriveSerializeWith :: Config -> Name -> Q [Dec]
|
||||
deriveSerializeWith conf@(Config {..}) name = do
|
||||
dt <- reifyDataType name
|
||||
let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
|
||||
headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
|
||||
cons = dtCons dt
|
||||
deriveSerializeInternal conf preds headTy cons
|
||||
-- Usage:
|
||||
-- @
|
||||
-- $(deriveSerializeWith
|
||||
-- config
|
||||
-- [d|instance Serialize a => Serialize (Maybe a)|])
|
||||
-- @
|
||||
deriveSerializeWith :: Config -> Q [Dec] -> Q [Dec]
|
||||
deriveSerializeWith conf mDecs = do
|
||||
dec <- mDecs
|
||||
case dec of
|
||||
[inst@(InstanceD _ _ headTy [])] -> do
|
||||
dt <- reifyDataType (getMainTypeName headTy)
|
||||
let cons = dtCons dt
|
||||
deriveSerializeInternal conf headTy cons (next inst)
|
||||
_ -> errorUnsupported
|
||||
where
|
||||
|
||||
where
|
||||
allUnconstrainedTypeVars =
|
||||
unconstrained ++ map fst specializations
|
||||
filterOutVars vs =
|
||||
map mkName
|
||||
$ filter (not . flip elem allUnconstrainedTypeVars)
|
||||
$ map nameBase vs
|
||||
substituteVar v =
|
||||
case lookup (nameBase v) specializations of
|
||||
Nothing -> VarT v
|
||||
Just ty -> ty
|
||||
next (InstanceD mo preds headTy []) methods =
|
||||
pure [InstanceD mo preds headTy methods]
|
||||
next _ _ = errorUnsupported
|
||||
|
||||
getMainTypeName = go . unwrap
|
||||
|
||||
unwrap (AppT (ConT _) r) = r
|
||||
unwrap _ = error "getMainTypeName.unwrap: Undefined instance declaration."
|
||||
|
||||
go (ConT nm) = nm
|
||||
go (AppT l _) = go l
|
||||
go _ = error "getMainTypeName.go: Undefined instance declaration."
|
||||
|
||||
unboxPred ty =
|
||||
#if MIN_VERSION_template_haskell(2,10,0)
|
||||
AppT (ConT ''Serialize) ty
|
||||
#else
|
||||
ClassP ''Serialize [ty]
|
||||
#endif
|
||||
|
||||
-- | Template haskell helper to create instances of 'Serialize' automatically.
|
||||
--
|
||||
@ -438,8 +440,18 @@ deriveSerializeWith conf@(Config {..}) name = do
|
||||
--
|
||||
-- To control which type variables don't get the Serialize constraint, use
|
||||
-- 'deriveSerializeWith'.
|
||||
--
|
||||
-- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize
|
||||
-- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig
|
||||
deriveSerialize :: Name -> Q [Dec]
|
||||
deriveSerialize name = deriveSerializeWith defaultConfig name
|
||||
deriveSerialize name = do
|
||||
dt <- reifyDataType name
|
||||
let preds = map (unboxPred . VarT) (dtTvs dt)
|
||||
headTy = appsT (ConT name) (map VarT (dtTvs dt))
|
||||
cons = dtCons dt
|
||||
deriveSerializeInternal defaultConfig headTy cons (next preds headTy)
|
||||
|
||||
|
||||
where
|
||||
|
||||
next preds headTy methods =
|
||||
pure [InstanceD Nothing preds (AppT (ConT ''Serialize) headTy) methods]
|
||||
|
||||
unboxPred ty = AppT (ConT ''Serialize) ty
|
||||
|
@ -17,7 +17,6 @@ module Streamly.Internal.Data.Unbox.TH
|
||||
, DataType(..)
|
||||
, reifyDataType
|
||||
, appsT
|
||||
, plainInstanceD
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -35,6 +34,8 @@ import Streamly.Internal.Data.Unbox
|
||||
-- th-utilities
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- Note: We don't support template-haskell < 2.14 (GHC < 8.6)
|
||||
|
||||
-- The following are copied to remove the dependency on th-utilities.
|
||||
-- The code has been copied from th-abstraction and th-utilities.
|
||||
|
||||
@ -72,16 +73,6 @@ appsT :: Type -> [Type] -> Type
|
||||
appsT x [] = x
|
||||
appsT x (y:xs) = appsT (AppT x y) xs
|
||||
|
||||
-- | Utility to conveniently handle change to 'InstanceD' API in
|
||||
-- template-haskell-2.11.0
|
||||
plainInstanceD :: Cxt -> Type -> [Dec] -> Dec
|
||||
plainInstanceD =
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
InstanceD Nothing
|
||||
#else
|
||||
InstanceD
|
||||
#endif
|
||||
|
||||
-- | Simplified info about a 'DataD'. Omits deriving, strictness,
|
||||
-- kind info, and whether it's @data@ or @newtype@.
|
||||
data DataType = DataType
|
||||
@ -437,7 +428,7 @@ deriveUnboxInternal preds headTy cons = do
|
||||
[]
|
||||
]
|
||||
]
|
||||
return [plainInstanceD preds (AppT (ConT ''Unbox) headTy) methods]
|
||||
return [InstanceD Nothing preds (AppT (ConT ''Unbox) headTy) methods]
|
||||
|
||||
-- | Template haskell helper to create instances of 'Unbox' automatically.
|
||||
--
|
||||
|
@ -24,18 +24,22 @@ module Streamly.Test.Data.Serialize (main) where
|
||||
import System.Random (randomRIO)
|
||||
import Streamly.Internal.Data.Unbox (MutableByteArray, newBytes)
|
||||
import GHC.Generics (Generic)
|
||||
import Streamly.Data.Serialize (Serialize)
|
||||
import Streamly.Test.Data.Serialize.TH (genDatatype)
|
||||
|
||||
import qualified Streamly.Internal.Data.Serialize.TH as Serialize
|
||||
( Config(..)
|
||||
( deriveSerializeWith
|
||||
#ifdef ENABLE_constructorTagAsString
|
||||
, Config(..)
|
||||
#endif
|
||||
, defaultConfig
|
||||
, deriveSerializeWith
|
||||
)
|
||||
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
|
||||
import qualified Streamly.Internal.Data.Array as Array
|
||||
import qualified Streamly.Internal.Data.Serialize as Serialize
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.QuickCheck
|
||||
import Test.Hspec as H
|
||||
@ -59,19 +63,19 @@ import Test.Hspec as H
|
||||
data Unit =
|
||||
Unit
|
||||
deriving (Eq, Show)
|
||||
$(Serialize.deriveSerializeWith CONF ''Unit)
|
||||
$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|])
|
||||
|
||||
data The =
|
||||
The Unit Int Char
|
||||
deriving (Eq, Show)
|
||||
$(Serialize.deriveSerializeWith CONF ''The)
|
||||
$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Generated types
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
$(genDatatype "CustomDatatype" 15)
|
||||
$(Serialize.deriveSerializeWith CONF ''CustomDatatype)
|
||||
$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Types with functional parameters
|
||||
@ -89,11 +93,10 @@ instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where
|
||||
instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
|
||||
show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)
|
||||
|
||||
$(Serialize.deriveSerializeWith CONF ''Identity)
|
||||
$(Serialize.deriveSerializeWith
|
||||
(CONF
|
||||
{Serialize.specializations = [("f", ConT ''Identity)]})
|
||||
''HigherOrderType)
|
||||
$(Serialize.deriveSerializeWith CONF
|
||||
[d|instance Serialize a => Serialize (Identity a)|])
|
||||
$(Serialize.deriveSerializeWith CONF
|
||||
[d|instance Serialize (HigherOrderType Identity)|])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Recursive type
|
||||
@ -105,7 +108,9 @@ data BinTree a
|
||||
| Leaf a
|
||||
deriving (Show, Read, Eq, Generic)
|
||||
|
||||
$(Serialize.deriveSerializeWith CONF ''BinTree)
|
||||
$(Serialize.deriveSerializeWith
|
||||
CONF
|
||||
[d|instance Serialize a => Serialize (BinTree a)|])
|
||||
|
||||
instance Arbitrary a => Arbitrary (BinTree a) where
|
||||
arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
|
||||
|
@ -193,8 +193,8 @@ deriving instance Generic (Ratio Int)
|
||||
$(Serialize.deriveSerialize ''Complex)
|
||||
$(Serialize.deriveSerialize ''Ratio)
|
||||
$(Serialize.deriveSerializeWith
|
||||
(Serialize.defaultConfig {Serialize.unconstrained = ["b"]})
|
||||
''Const)
|
||||
Serialize.defaultConfig
|
||||
[d|instance Serialize a => Serialize (Const a b)|])
|
||||
$(Serialize.deriveSerialize ''Identity)
|
||||
#endif
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user