Make the common serialization routines abstract & add TH helpers

composewell · Sep 12, 2023 · f13ccb0 · f13ccb0
1 parent eb7fd76
commit f13ccb0
Show file tree

Hide file tree

Showing 3 changed files with 25 additions and 17 deletions.
diff --git a/core/src/Streamly/Internal/Data/Serialize/TH.hs b/core/src/Streamly/Internal/Data/Serialize/TH.hs
@@ -193,7 +193,7 @@ mkDeserializeExpr True headTy tyOfTy =
             [|($(litIntegral lenCname) == $(varE conLen))
                    && $(xorCmp tag off _arr)|]
             [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
-               in $(mkDeserializeExprOne con)|]
+               in $(mkDeserializeExprOne 'deserialize con)|]
 
 mkDeserializeExpr False headTy tyOfTy =
     case tyOfTy of
@@ -204,7 +204,7 @@ mkDeserializeExpr False headTy tyOfTy =
         TheType con ->
             letE
                 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
-                (mkDeserializeExprOne con)
+                (mkDeserializeExprOne 'deserialize con)
         -- Sum type
         MultiType cons -> do
             let lenCons = length cons
@@ -220,7 +220,9 @@ mkDeserializeExpr False headTy tyOfTy =
                 ]
   where
     peekMatch (i, con) =
-        match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []
+        match
+            (litP (IntegerL i))
+            (normalB (mkDeserializeExprOne 'deserialize con)) []
     peekErr =
         match
             wildP
@@ -289,7 +291,7 @@ mkSerializeExpr True tyOfTy =
             (doE [ bindS
                        (varP (mkName "i0"))
                        (serializeW8List _initialOffset _arr conEnc)
-                 , noBindS (mkSerializeExprFields fields)
+                 , noBindS (mkSerializeExprFields 'serialize fields)
                  ])
 
 mkSerializeExpr False tyOfTy =
@@ -305,7 +307,7 @@ mkSerializeExpr False tyOfTy =
                      [ matchConstructor
                            cname
                            (length fields)
-                           (mkSerializeExprFields fields)
+                           (mkSerializeExprFields 'serialize fields)
                      ])
         -- Sum type
         (MultiType cons) -> do
@@ -320,7 +322,10 @@ mkSerializeExpr False tyOfTy =
                               (doE [ bindS
                                          (varP (mkName "i0"))
                                          (mkSerializeExprTag tagType tagVal)
-                                   , noBindS (mkSerializeExprFields fields)
+                                   , noBindS
+                                         (mkSerializeExprFields
+                                              'serialize
+                                              fields)
                                    ]))
                      (zip [0 ..] cons))
 

diff --git a/core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs b/core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs
@@ -14,6 +14,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
     , TypeOfType(..)
     , typeOfType
     , SimpleDataCon(..)
+    , simplifyDataCon
     , Field
     , mkFieldName
     , isUnitType
@@ -22,6 +23,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
     , serializeW8List
     , litIntegral
     , matchConstructor
+    , openConstructor
     , makeI
     , makeA
     , int_w8
@@ -164,12 +166,13 @@ makeA i = mkName $ "a" ++ show i
 -- Domain specific helpers
 --------------------------------------------------------------------------------
 
+openConstructor :: Name -> Int -> Q Pat
+openConstructor cname numFields =
+    conP cname (map varP (map mkFieldName [0 .. (numFields - 1)]))
+
 matchConstructor :: Name -> Int -> Q Exp -> Q Match
 matchConstructor cname numFields exp0 =
-    match
-        (conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
-        (normalB exp0)
-        []
+    match (openConstructor cname numFields) (normalB exp0) []
 
 --------------------------------------------------------------------------------
 -- Constructor types

diff --git a/core/src/Streamly/Internal/Data/Serialize/TH/Common.hs b/core/src/Streamly/Internal/Data/Serialize/TH/Common.hs
@@ -18,15 +18,14 @@ module Streamly.Internal.Data.Serialize.TH.Common
 --------------------------------------------------------------------------------
 
 import Language.Haskell.TH
-import Streamly.Internal.Data.Serialize.Type
 import Streamly.Internal.Data.Serialize.TH.Bottom
 
 --------------------------------------------------------------------------------
 -- Code
 --------------------------------------------------------------------------------
 
-mkDeserializeExprOne :: SimpleDataCon -> Q Exp
-mkDeserializeExprOne (SimpleDataCon cname fields) =
+mkDeserializeExprOne :: Name -> SimpleDataCon -> Q Exp
+mkDeserializeExprOne peeker (SimpleDataCon cname fields) =
     case fields of
         -- Only tag is serialized for unit fields, no actual value
         [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
@@ -51,10 +50,10 @@ mkDeserializeExprOne (SimpleDataCon cname fields) =
     makeBind i =
         bindS
             (tupP [varP (makeI (i + 1)), varP (makeA i)])
-            [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
+            [|$(varE peeker) $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
 
-mkSerializeExprFields :: [Field] -> Q Exp
-mkSerializeExprFields fields =
+mkSerializeExprFields :: Name -> [Field] -> Q Exp
+mkSerializeExprFields poker fields =
     case fields of
         -- Unit constructor, do nothing just tag is enough
         [] -> [|pure ($(varE (mkName "i0")))|]
@@ -67,4 +66,5 @@ mkSerializeExprFields fields =
     makeBind i =
         bindS
             (varP (makeI (i + 1)))
-            [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]
+            [|$(varE poker)
+                   $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]