33bffd6 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Change deriveUnbox to use instance splice

33bffd6Harendra Kumar3 years ago

benchmark/Streamly/Benchmark/Data/Serialize.hs+1−1

compare with master

unifiedsplit

@@ -42,7 +42,7 @@ import Streamly.Benchmark.Data.Serialize.RecNonCompatible

43#ifdef USE_UNBOX

44#define SERIALIZE_CLASS Unbox

45−#define DERIVE_CLASS(typ) $(deriveUnbox ''typ)

45+#define DERIVE_CLASS(typ) $(deriveUnbox [d|instance Unbox typ|])

46#define SERIALIZE_OP pokeByteIndex

47#define DESERIALIZE_OP peekByteIndex

48#else

core/src/Streamly/Data/Serialize.hs−1

@@ -47,7 +47,6 @@ module Streamly.Data.Serialize

47 -- * Unbox

48 , Unbox(..)

49 , deriveUnbox

50− , deriveUnboxWith

52 -- * Serialize

51 -- * Serialize

53 , Serialize(..)

52 , Serialize(..)

core/src/Streamly/Internal/Data/Serialize/TH.hs+8−9

@@ -464,17 +464,16 @@ deriveSerializeWith :: SerializeConfig -> Q [Dec] -> Q [Dec]

464deriveSerializeWith conf mDecs = do

465 dec <- mDecs

466 case dec of

467− [inst@(InstanceD _ _ headTyWC [])] -> do

467+ [InstanceD mo preds headTyWC []] -> do

468 let headTy = unwrap dec headTyWC

469 dt <- reifyDataType (getMainTypeName dec headTy)

470 let cons = dtCons dt

471− deriveSerializeInternal conf headTy cons (next inst)

471+ deriveSerializeInternal conf headTy cons (next mo preds headTyWC)

472− _ -> errorUnsupported (errorMessage dec)

472+ _ -> errorMessage dec

473+

473− where

474+ where

474

475

475− next (InstanceD mo preds headTyWC []) methods =

476− pure [InstanceD mo preds headTyWC methods]

476+ next mo preds headTyWC methods = pure [InstanceD mo preds headTyWC methods]

477− next dec _ = errorUnsupported (errorMessage dec)

478

477

479 errorMessage dec =

478 errorMessage dec =

480 error $ unlines

479 error $ unlines

@@ -482,8 +481,8 @@ deriveSerializeWith conf mDecs = do

482 , ""

481 , ""

483 , ">> " ++ pprint dec

482 , ">> " ++ pprint dec

484 , ""

483 , ""

485− , "The above is not a valid instance declaration."

484+ , "The supplied declaration is not a valid instance declaration."

486− , "Any haskell instance declaration without a body is valid."

485+ , "Provide a valid Haskell instance declaration without a body."

487 , ""

486 , ""

488 , "Examples:"

487 , "Examples:"

489 , "instance Serialize (Proxy a)"

488 , "instance Serialize (Proxy a)"

core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs+1−1

@@ -450,7 +450,7 @@ errorUnsupported err =

450 $ unlines

451 [ "Unsupported"

452 , "==========="

453− , "There is improper use of the library."

453+ , "This is improper use of the library."

454 , "This case is unsupported."

455 , "Please contact the developer if this case is of interest."

456 , ""

core/src/Streamly/Internal/Data/Unbox/TH.hs+42−71

@@ -10,13 +10,11 @@

10--

11module Streamly.Internal.Data.Unbox.TH

12 ( deriveUnbox

13− , deriveUnboxWith

15 -- th-helpers

14 -- th-helpers

16 , DataCon(..)

15 , DataCon(..)

17 , DataType(..)

16 , DataType(..)

18 , reifyDataType

17 , reifyDataType

19− , appsT

20 ) where

18 ) where

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

20--------------------------------------------------------------------------------

@@ -69,10 +67,6 @@ tvName = elimTV id (\n _ -> n)

69tyVarBndrName :: TyVarBndr_ flag -> Name

67tyVarBndrName :: TyVarBndr_ flag -> Name

70tyVarBndrName = tvName

68tyVarBndrName = tvName

72−appsT :: Type -> [Type] -> Type

73−appsT x [] = x

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

75−

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

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

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

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

78data DataType = DataType

72data DataType = DataType

@@ -397,8 +391,8 @@ mkPokeExpr headTy cons =

397-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))]

391-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))]

398-- ])

392-- ])

399-- @

393-- @

400−deriveUnboxInternal :: Cxt -> Type -> [DataCon] -> Q [Dec]

394+deriveUnboxInternal :: Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]

401−deriveUnboxInternal preds headTy cons = do

395+deriveUnboxInternal headTy cons mkDec = do

402 sizeOfMethod <- mkSizeOfExpr headTy cons

396 sizeOfMethod <- mkSizeOfExpr headTy cons

403 peekMethod <- mkPeekExpr headTy cons

397 peekMethod <- mkPeekExpr headTy cons

404 pokeMethod <- mkPokeExpr headTy cons

398 pokeMethod <- mkPokeExpr headTy cons

@@ -428,77 +422,54 @@ deriveUnboxInternal preds headTy cons = do

428 []

422 []

429 ]

423 ]

430 ]

424 ]

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

425+ mkDec methods

432

426

433−-- | @deriveUnbox dataTypeName@ generates a template Haskell splice consisting

427+-- | Given an 'Unbox' instance declaration splice without the methods,

434−-- of a declaration of the 'Unbox' instance for the given dataTypeName, all type

428+-- generate a full instance declaration including all the type class methods.

435−-- parameters of dataTypeName are required to have the 'Unbox' constraint.

436−--

437−-- For example,

438−--

439−-- @

440−-- data CustomDataType a b c = ...

441−-- \$(deriveUnbox ''CustomDataType)

442−-- @

443--

429--

444−-- Generates the following code:

430+-- Usage:

445--

431--

446-- @

432-- @

447−-- instance (Unbox a, Unbox b, Unbox c) => Unbox (CustomDataType a b c) where

433+-- \$(deriveUnbox [d|instance Unbox a => Unbox (Maybe a)|])

448−-- ...

449-- @

434-- @

450−--

451−-- To control which type parameters get the Unbox constraint, use

452−-- 'deriveUnboxWith'.

453−deriveUnbox :: Name -> Q [Dec]

435+deriveUnbox :: Q [Dec] -> Q [Dec]

454−deriveUnbox name = do

436+deriveUnbox mDecs = do

437+ dec <- mDecs

438+ case dec of

439+ [InstanceD mo preds headTyWC []] -> do

440+ let headTy = unwrap dec headTyWC

455− dt <- reifyDataType name

441+ dt <- reifyDataType (getMainTypeName dec headTy)

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

457− headTy = appsT (ConT name) (map VarT (dtTvs dt))

458− cons = dtCons dt

442+ let cons = dtCons dt

459− deriveUnboxInternal preds headTy cons

443+ deriveUnboxInternal headTy cons (mkInst mo preds headTyWC)

444+ _ -> errorMessage dec

460

445

461 where

446 where

462

447

463− unboxPred ty =

448+ mkInst mo preds headTyWC methods =

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

449+ pure [InstanceD mo preds headTyWC methods]

465− AppT (ConT ''Unbox) ty

450+

466−#else

451+ errorMessage dec =

467− ClassP ''Unbox [ty]

452+ error $ unlines

468−#endif

453+ [ "Error: deriveUnbox:"

454+ , ""

455+ , ">> " ++ pprint dec

456+ , ""

457+ , "The supplied declaration not a valid instance declaration."

458+ , "Provide a valid Haskell instance declaration without a body."

459+ , ""

460+ , "Examples:"

461+ , "instance Unbox (Proxy a)"

462+ , "instance Unbox a => Unbox (Identity a)"

463+ , "instance Unbox (TableT Identity)"

464+ ]

469

465

470−-- | @deriveUnbox dataTypeName@ generates a template Haskell splice consisting

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

471−-- of a declaration of the 'Unbox' instance for the given dataTypeName,

467+ unwrap dec _ = errorMessage dec

472−-- varNames is a list of parameter names of dataTypeName that are required

473−-- to have the 'Unbox' constraint.

474−--

475−-- For example,

476−--

477−-- @

478−-- data CustomDataType a b c = ...

479−-- \$(deriveUnboxWith ["a", "c"] ''CustomDataType)

480−-- @

481−--

482−-- Generates the following code:

483−--

484−-- @

485−-- instance (Unbox a, Unbox c) => Unbox (CustomDataType a b c) where

486−-- ...

487−-- @

488−--

489−deriveUnboxWith :: [String] -> Name -> Q [Dec]

490−deriveUnboxWith vars name = do

491− dt <- reifyDataType name

492− let preds = map (unboxPred . VarT) (fmap mkName vars)

493− headTy = appsT (ConT name) (map VarT (dtTvs dt))

494− cons = dtCons dt

495− deriveUnboxInternal preds headTy cons

496

468

497− where

469+ getMainTypeName dec = go

498

470

499− unboxPred ty =

471+ where

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

472+

501− AppT (ConT ''Unbox) ty

473+ go (ConT nm) = nm

502−#else

474+ go (AppT l _) = go l

503− ClassP ''Unbox [ty]

475+ go _ = errorMessage dec

504−#endif

test/Streamly/Test/Data/Unbox.hs+6−9

@@ -28,9 +28,6 @@ import GHC.Generics (Generic, Rep(..))

28import GHC.Real (Ratio(..))

30import Streamly.Internal.Data.Serialize

31−#ifdef USE_SERIALIZE

32−import qualified Streamly.Internal.Data.Serialize as Serialize

33−#endif

35import Test.Hspec as H

32import Test.Hspec as H

@@ -41,7 +38,7 @@ import Test.Hspec as H

41#ifdef USE_SERIALIZE

38#ifdef USE_SERIALIZE

43#define MODULE_NAME "Data.Serialize.Deriving.TH"

40#define MODULE_NAME "Data.Serialize.Deriving.TH"

44−#define DERIVE_UNBOX(typ) $(Serialize.deriveSerialize [d|instance Serialize typ|])

41+#define DERIVE_UNBOX(typ) $(deriveSerialize [d|instance Serialize typ|])

45#define PEEK(i, arr, sz) (deserialize i arr sz)

42#define PEEK(i, arr, sz) (deserialize i arr sz)

46#define POKE(i, arr, val) (serialize i arr val)

43#define POKE(i, arr, val) (serialize i arr val)

47#define TYPE_CLASS Serialize

44#define TYPE_CLASS Serialize

@@ -55,7 +52,7 @@ import Test.Hspec as H

55#ifdef USE_TH

52#ifdef USE_TH

57#define MODULE_NAME "Data.Unbox.Deriving.TH"

54#define MODULE_NAME "Data.Unbox.Deriving.TH"

58−#define DERIVE_UNBOX(typ) $(deriveUnbox ''typ)

55+#define DERIVE_UNBOX(typ) $(deriveUnbox [d|instance Unbox typ|])

60#else

57#else

@@ -168,13 +165,13 @@ DERIVE_UNBOX(NestedSOP)

168deriving instance Generic (Ratio Int)

165deriving instance Generic (Ratio Int)

169

166

170#if defined(USE_SERIALIZE)

167#if defined(USE_SERIALIZE)

171−$(Serialize.deriveSerialize

168+$(deriveSerialize

172 [d|instance Serialize a => Serialize (Complex a)|])

169 [d|instance Serialize a => Serialize (Complex a)|])

173−$(Serialize.deriveSerialize

170+$(deriveSerialize

174 [d|instance Serialize a => Serialize (Ratio a)|])

171 [d|instance Serialize a => Serialize (Ratio a)|])

175−$(Serialize.deriveSerialize

172+$(deriveSerialize

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

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

177−$(Serialize.deriveSerialize

174+$(deriveSerialize

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

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

179#endif

176#endif

180

177

test/Streamly/Test/Data/Unbox/TH.hs+5−4

@@ -62,10 +62,11 @@ data CustomDataType4 a b

62 | CDT4Constructor3 Bool b

63 deriving (Show, Eq)

65−$(deriveUnbox ''CustomDataType1)

65+$(deriveUnbox [d|instance Unbox CustomDataType1|])

66−$(deriveUnbox ''CustomDataType2)

66+$(deriveUnbox [d|instance Unbox CustomDataType2|])

67−$(deriveUnbox ''CustomDataType3)

67+$(deriveUnbox

68+ [d|instance (Unbox a, Unbox b, Unbox c) => Unbox (CustomDataType3 a b c)|])

68−$(deriveUnboxWith ["b"] ''CustomDataType4)

69+$(deriveUnbox [d|instance Unbox b => Unbox (CustomDataType4 a b)|])

70--------------------------------------------------------------------------------

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

71-- CPP helpers

72-- CPP helpers