git.iko.soy/streamly
on master help sign in
Make the common serialization routines abstract & add TH helpers
commit64940c6d36e108025cd0bf986d96e7ffa416b41d authorAdithya Kumar <adithya@composewell.com> dateTue 12 Sep 2023, 20:53 (3 years ago) parent8f3f3f7
3 files changed+25−17
compare with master
unifiedsplit
core/src/Streamly/Internal/Data/Serialize/TH.hs+11−6 core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs+7−4 core/src/Streamly/Internal/Data/Serialize/TH/Common.hs+7−7
core/src/Streamly/Internal/Data/Serialize/TH.hs+11−6
@@ -193,7 +193,7 @@ mkDeserializeExpr True headTy tyOfTy =
193193 [|($(litIntegral lenCname) == $(varE conLen))
194194 && $(xorCmp tag off _arr)|]
195195 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
196− in $(mkDeserializeExprOne con)|]
196+ in $(mkDeserializeExprOne 'deserialize con)|]
197197
198198mkDeserializeExpr False headTy tyOfTy =
199199 case tyOfTy of
@@ -204,7 +204,7 @@ mkDeserializeExpr False headTy tyOfTy =
204204 TheType con ->
205205 letE
206206 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
207− (mkDeserializeExprOne con)
207+ (mkDeserializeExprOne 'deserialize con)
208208 -- Sum type
209209 MultiType cons -> do
210210 let lenCons = length cons
@@ -220,7 +220,9 @@ mkDeserializeExpr False headTy tyOfTy =
220220 ]
221221 where
222222 peekMatch (i, con) =
223− match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []
223+ match
224+ (litP (IntegerL i))
225+ (normalB (mkDeserializeExprOne 'deserialize con)) []
224226 peekErr =
225227 match
226228 wildP
@@ -289,7 +291,7 @@ mkSerializeExpr True tyOfTy =
289291 (doE [ bindS
290292 (varP (mkName "i0"))
291293 (serializeW8List _initialOffset _arr conEnc)
292− , noBindS (mkSerializeExprFields fields)
294+ , noBindS (mkSerializeExprFields 'serialize fields)
293295 ])
294296
295297mkSerializeExpr False tyOfTy =
@@ -305,7 +307,7 @@ mkSerializeExpr False tyOfTy =
305307 [ matchConstructor
306308 cname
307309 (length fields)
308− (mkSerializeExprFields fields)
310+ (mkSerializeExprFields 'serialize fields)
309311 ])
310312 -- Sum type
311313 (MultiType cons) -> do
@@ -320,7 +322,10 @@ mkSerializeExpr False tyOfTy =
320322 (doE [ bindS
321323 (varP (mkName "i0"))
322324 (mkSerializeExprTag tagType tagVal)
323− , noBindS (mkSerializeExprFields fields)
325+ , noBindS
326+ (mkSerializeExprFields
327+ 'serialize
328+ fields)
324329 ]))
325330 (zip [0 ..] cons))
326331
core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs+7−4
@@ -14,6 +14,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
1414 , TypeOfType(..)
1515 , typeOfType
1616 , SimpleDataCon(..)
17+ , simplifyDataCon
1718 , Field
1819 , mkFieldName
1920 , isUnitType
@@ -22,6 +23,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
2223 , serializeW8List
2324 , litIntegral
2425 , matchConstructor
26+ , openConstructor
2527 , makeI
2628 , makeA
2729 , int_w8
@@ -164,12 +166,13 @@ makeA i = mkName $ "a" ++ show i
164166-- Domain specific helpers
165167--------------------------------------------------------------------------------
166168
169+openConstructor :: Name -> Int -> Q Pat
170+openConstructor cname numFields =
171+ conP cname (map varP (map mkFieldName [0 .. (numFields - 1)]))
172+
167173matchConstructor :: Name -> Int -> Q Exp -> Q Match
168174matchConstructor cname numFields exp0 =
169− match
170− (conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
171− (normalB exp0)
172− []
175+ match (openConstructor cname numFields) (normalB exp0) []
173176
174177--------------------------------------------------------------------------------
175178-- Constructor types
core/src/Streamly/Internal/Data/Serialize/TH/Common.hs+7−7
@@ -18,15 +18,14 @@ module Streamly.Internal.Data.Serialize.TH.Common
1818--------------------------------------------------------------------------------
1919
2020import Language.Haskell.TH
21−import Streamly.Internal.Data.Serialize.Type
2221import Streamly.Internal.Data.Serialize.TH.Bottom
2322
2423--------------------------------------------------------------------------------
2524-- Code
2625--------------------------------------------------------------------------------
2726
28−mkDeserializeExprOne :: SimpleDataCon -> Q Exp
29−mkDeserializeExprOne (SimpleDataCon cname fields) =
27+mkDeserializeExprOne :: Name -> SimpleDataCon -> Q Exp
28+mkDeserializeExprOne peeker (SimpleDataCon cname fields) =
3029 case fields of
3130 -- Only tag is serialized for unit fields, no actual value
3231 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
@@ -51,10 +50,10 @@ mkDeserializeExprOne (SimpleDataCon cname fields) =
5150 makeBind i =
5251 bindS
5352 (tupP [varP (makeI (i + 1)), varP (makeA i)])
54− [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
53+ [|$(varE peeker) $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
5554
56−mkSerializeExprFields :: [Field] -> Q Exp
57−mkSerializeExprFields fields =
55+mkSerializeExprFields :: Name -> [Field] -> Q Exp
56+mkSerializeExprFields poker fields =
5857 case fields of
5958 -- Unit constructor, do nothing just tag is enough
6059 [] -> [|pure ($(varE (mkName "i0")))|]
@@ -67,4 +66,5 @@ mkSerializeExprFields fields =
6766 makeBind i =
6867 bindS
6968 (varP (makeI (i + 1)))
70− [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]
69+ [|$(varE poker)
70+ $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]