60a71dc · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Use more expressive notation for deriveSerializeWith

60a71dcAdithya Kumar3 years ago

core/src/Streamly/Internal/Data/Serialize.hs+2−2

compare with master

unifiedsplit

@@ -61,8 +61,8 @@ import Streamly.Internal.Data.Serialize.Type

61$(Serialize.deriveSerialize ''Maybe)

62$(Serialize.deriveSerialize ''Either)

63$(Serialize.deriveSerializeWith

64− (Serialize.defaultConfig {Serialize.unconstrained = ["t"]})

64+ Serialize.defaultConfig

65− ''Proxy)

65+ [d|instance Serialize (Proxy a)|])

67--------------------------------------------------------------------------------

68-- Integer

core/src/Streamly/Internal/Data/Serialize/TH.hs+48−36

@@ -30,7 +30,6 @@ import Streamly.Internal.Data.Unbox.TH

30 ( DataCon(..)

31 , DataType(..)

32 , appsT

33− , plainInstanceD

34 , reifyDataType

33 , reifyDataType

35 )

34 )

@@ -381,44 +380,47 @@ mkSerializeDec (Config {..}) headTy cons = do

381-- ])

380-- ])

382-- @

381-- @

383deriveSerializeInternal ::

382deriveSerializeInternal ::

384− Config -> Cxt -> Type -> [DataCon] -> Q [Dec]

383+ Config -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]

385−deriveSerializeInternal conf preds headTy cons = do

384+deriveSerializeInternal conf headTy cons next = do

386 sizeDec <- mkSizeDec conf headTy cons

385 sizeDec <- mkSizeDec conf headTy cons

387 peekDec <- mkDeserializeDec conf headTy cons

386 peekDec <- mkDeserializeDec conf headTy cons

388 pokeDec <- mkSerializeDec conf headTy cons

387 pokeDec <- mkSerializeDec conf headTy cons

389 let methods = concat [sizeDec, peekDec, pokeDec]

388 let methods = concat [sizeDec, peekDec, pokeDec]

390− return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]

389+ next methods

391

390

392−-- | Similar to 'deriveSerialize,' but take a 'Config' to control how

391+-- | Similar to 'deriveSerialize' but take a 'Config' to control how the

393−-- the instance is generated.

392+-- instance is generated.

394--

393--

394+-- Usage:

395+-- @

395−-- Usage: @$(deriveSerializeWith config ''CustomDataType)@

396+-- $(deriveSerializeWith

397+-- config

398+-- [d|instance Serialize a => Serialize (Maybe a)|])

399+-- @

396−deriveSerializeWith :: Config -> Name -> Q [Dec]

400+deriveSerializeWith :: Config -> Q [Dec] -> Q [Dec]

397−deriveSerializeWith conf@(Config {..}) name = do

401+deriveSerializeWith conf mDecs = do

402+ dec <- mDecs

403+ case dec of

404+ [inst@(InstanceD _ _ headTy [])] -> do

398− dt <- reifyDataType name

405+ dt <- reifyDataType (getMainTypeName headTy)

399− let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))

400− headTy = appsT (ConT name) (map substituteVar (dtTvs dt))

401− cons = dtCons dt

406+ let cons = dtCons dt

402− deriveSerializeInternal conf preds headTy cons

407+ deriveSerializeInternal conf headTy cons (next inst)

408+ _ -> errorUnsupported

409+ where

410+

411+ next (InstanceD mo preds headTy []) methods =

412+ pure [InstanceD mo preds headTy methods]

413+ next _ _ = errorUnsupported

414+

415+ getMainTypeName = go . unwrap

416+

417+ unwrap (AppT (ConT _) r) = r

418+ unwrap _ = error "getMainTypeName.unwrap: Undefined instance declaration."

419+

420+ go (ConT nm) = nm

421+ go (AppT l _) = go l

422+ go _ = error "getMainTypeName.go: Undefined instance declaration."

403

423

404− where

405− allUnconstrainedTypeVars =

406− unconstrained ++ map fst specializations

407− filterOutVars vs =

408− map mkName

409− $ filter (not . flip elem allUnconstrainedTypeVars)

410− $ map nameBase vs

411− substituteVar v =

412− case lookup (nameBase v) specializations of

413− Nothing -> VarT v

414− Just ty -> ty

415−

416− unboxPred ty =

417−#if MIN_VERSION_template_haskell(2,10,0)

418− AppT (ConT ''Serialize) ty

419−#else

420− ClassP ''Serialize [ty]

421−#endif

422

424

423-- | Template haskell helper to create instances of 'Serialize' automatically.

425-- | Template haskell helper to create instances of 'Serialize' automatically.

424--

426--

@@ -438,8 +440,18 @@ deriveSerializeWith conf@(Config {..}) name = do

438--

440--

439-- To control which type variables don't get the Serialize constraint, use

441-- To control which type variables don't get the Serialize constraint, use

440-- 'deriveSerializeWith'.

442-- 'deriveSerializeWith'.

441−--

442−-- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize

443−-- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig

444deriveSerialize :: Name -> Q [Dec]

443deriveSerialize :: Name -> Q [Dec]

445−deriveSerialize name = deriveSerializeWith defaultConfig name

444+deriveSerialize name = do

445+ dt <- reifyDataType name

446+ let preds = map (unboxPred . VarT) (dtTvs dt)

447+ headTy = appsT (ConT name) (map VarT (dtTvs dt))

448+ cons = dtCons dt

449+ deriveSerializeInternal defaultConfig headTy cons (next preds headTy)

450+

451+

452+ where

453+

454+ next preds headTy methods =

455+ pure [InstanceD Nothing preds (AppT (ConT ''Serialize) headTy) methods]

456+

457+ unboxPred ty = AppT (ConT ''Serialize) ty

core/src/Streamly/Internal/Data/Unbox/TH.hs+3−12

@@ -17,7 +17,6 @@ module Streamly.Internal.Data.Unbox.TH

17 , DataType(..)

18 , reifyDataType

19 , appsT

20− , plainInstanceD

21 ) where

20 ) where

23--------------------------------------------------------------------------------

22--------------------------------------------------------------------------------

@@ -35,6 +34,8 @@ import Streamly.Internal.Data.Unbox

35-- th-utilities

34-- th-utilities

36--------------------------------------------------------------------------------

35--------------------------------------------------------------------------------

37+-- Note: We don't support template-haskell < 2.14 (GHC < 8.6)

38+

38-- The following are copied to remove the dependency on th-utilities.

39-- The following are copied to remove the dependency on th-utilities.

39-- The code has been copied from th-abstraction and th-utilities.

40-- The code has been copied from th-abstraction and th-utilities.

@@ -72,16 +73,6 @@ appsT :: Type -> [Type] -> Type

72appsT x [] = x

73appsT x [] = x

73appsT x (y:xs) = appsT (AppT x y) xs

74appsT x (y:xs) = appsT (AppT x y) xs

75−-- | Utility to conveniently handle change to 'InstanceD' API in

76−-- template-haskell-2.11.0

77−plainInstanceD :: Cxt -> Type -> [Dec] -> Dec

78−plainInstanceD =

79−#if MIN_VERSION_template_haskell(2,11,0)

80− InstanceD Nothing

81−#else

82− InstanceD

83−#endif

84−

85-- | Simplified info about a 'DataD'. Omits deriving, strictness,

76-- | Simplified info about a 'DataD'. Omits deriving, strictness,

86-- kind info, and whether it's @data@ or @newtype@.

77-- kind info, and whether it's @data@ or @newtype@.

87data DataType = DataType

78data DataType = DataType

@@ -437,7 +428,7 @@ deriveUnboxInternal preds headTy cons = do

437 []

428 []

438 ]

429 ]

439 ]

430 ]

440− return [plainInstanceD preds (AppT (ConT ''Unbox) headTy) methods]

431+ return [InstanceD Nothing preds (AppT (ConT ''Unbox) headTy) methods]

441

432

442-- | Template haskell helper to create instances of 'Unbox' automatically.

433-- | Template haskell helper to create instances of 'Unbox' automatically.

443--

434--

test/Streamly/Test/Data/Serialize.hs+17−12

@@ -24,18 +24,22 @@ module Streamly.Test.Data.Serialize (main) where

24import System.Random (randomRIO)

25import Streamly.Internal.Data.Unbox (MutableByteArray, newBytes)

26import GHC.Generics (Generic)

27+import Streamly.Data.Serialize (Serialize)

27import Streamly.Test.Data.Serialize.TH (genDatatype)

28import Streamly.Test.Data.Serialize.TH (genDatatype)

29+

28import qualified Streamly.Internal.Data.Serialize.TH as Serialize

30import qualified Streamly.Internal.Data.Serialize.TH as Serialize

31+ ( deriveSerializeWith

32+#ifdef ENABLE_constructorTagAsString

29− ( Config(..)

33+ , Config(..)

34+#endif

30 , defaultConfig

35 , defaultConfig

31− , deriveSerializeWith

32 )

36 )

37+

33import Data.Functor.Identity (Identity (..))

38import Data.Functor.Identity (Identity (..))

35import qualified Streamly.Internal.Data.Array as Array

40import qualified Streamly.Internal.Data.Array as Array

36import qualified Streamly.Internal.Data.Serialize as Serialize

41import qualified Streamly.Internal.Data.Serialize as Serialize

38−import Language.Haskell.TH

39import Test.Hspec.QuickCheck

43import Test.Hspec.QuickCheck

40import Test.QuickCheck

44import Test.QuickCheck

41import Test.Hspec as H

45import Test.Hspec as H

@@ -59,19 +63,19 @@ import Test.Hspec as H

59data Unit =

63data Unit =

60 Unit

64 Unit

61 deriving (Eq, Show)

65 deriving (Eq, Show)

62−$(Serialize.deriveSerializeWith CONF ''Unit)

66+$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|])

64data The =

68data The =

65 The Unit Int Char

69 The Unit Int Char

66 deriving (Eq, Show)

70 deriving (Eq, Show)

67−$(Serialize.deriveSerializeWith CONF ''The)

71+$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|])

69--------------------------------------------------------------------------------

73--------------------------------------------------------------------------------

70-- Generated types

74-- Generated types

71--------------------------------------------------------------------------------

75--------------------------------------------------------------------------------

73$(genDatatype "CustomDatatype" 15)

77$(genDatatype "CustomDatatype" 15)

74−$(Serialize.deriveSerializeWith CONF ''CustomDatatype)

78+$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|])

76--------------------------------------------------------------------------------

80--------------------------------------------------------------------------------

77-- Types with functional parameters

81-- Types with functional parameters

@@ -89,11 +93,10 @@ instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where

89instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where

93instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where

90 show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)

94 show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)

92−$(Serialize.deriveSerializeWith CONF ''Identity)

96+$(Serialize.deriveSerializeWith CONF

97+ [d|instance Serialize a => Serialize (Identity a)|])

93−$(Serialize.deriveSerializeWith

98+$(Serialize.deriveSerializeWith CONF

94− (CONF

95− {Serialize.specializations = [("f", ConT ''Identity)]})

96− ''HigherOrderType)

99+ [d|instance Serialize (HigherOrderType Identity)|])

100

98--------------------------------------------------------------------------------

101--------------------------------------------------------------------------------

99-- Recursive type

102-- Recursive type

@@ -105,7 +108,9 @@ data BinTree a

105 | Leaf a

108 | Leaf a

106 deriving (Show, Read, Eq, Generic)

109 deriving (Show, Read, Eq, Generic)

107

110

108−$(Serialize.deriveSerializeWith CONF ''BinTree)

111+$(Serialize.deriveSerializeWith

112+ CONF

113+ [d|instance Serialize a => Serialize (BinTree a)|])

109

114

110instance Arbitrary a => Arbitrary (BinTree a) where

115instance Arbitrary a => Arbitrary (BinTree a) where

111 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]

116 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]

test/Streamly/Test/Data/Unbox.hs+2−2

@@ -193,8 +193,8 @@ deriving instance Generic (Ratio Int)

193$(Serialize.deriveSerialize ''Complex)

194$(Serialize.deriveSerialize ''Ratio)

195$(Serialize.deriveSerializeWith

196− (Serialize.defaultConfig {Serialize.unconstrained = ["b"]})

196+ Serialize.defaultConfig

197− ''Const)

197+ [d|instance Serialize a => Serialize (Const a b)|])

198$(Serialize.deriveSerialize ''Identity)

199#endif

200