git.iko.soy/streamly
on master help sign in
Make the common serialization routines abstract & add TH helpers
64940c6Adithya Kumar
core/src/Streamly/Internal/Data/Serialize/TH.hs+11−6
compare with master
unifiedsplit
@@ -193,7 +193,7 @@ mkDeserializeExpr True headTy tyOfTy =
193 [|($(litIntegral lenCname) == $(varE conLen))
193 [|($(litIntegral lenCname) == $(varE conLen))
194 && $(xorCmp tag off _arr)|]
194 && $(xorCmp tag off _arr)|]
195 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
195 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
196− in $(mkDeserializeExprOne con)|]
196+ in $(mkDeserializeExprOne 'deserialize con)|]
197
197
198mkDeserializeExpr False headTy tyOfTy =
198mkDeserializeExpr False headTy tyOfTy =
199 case tyOfTy of
199 case tyOfTy of
@@ -204,7 +204,7 @@ mkDeserializeExpr False headTy tyOfTy =
204 TheType con ->
204 TheType con ->
205 letE
205 letE
206 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
206 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
207− (mkDeserializeExprOne con)
207+ (mkDeserializeExprOne 'deserialize con)
208 -- Sum type
208 -- Sum type
209 MultiType cons -> do
209 MultiType cons -> do
210 let lenCons = length cons
210 let lenCons = length cons
@@ -220,7 +220,9 @@ mkDeserializeExpr False headTy tyOfTy =
220 ]
220 ]
221 where
221 where
222 peekMatch (i, con) =
222 peekMatch (i, con) =
223+ match
224+ (litP (IntegerL i))
223− match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []
225+ (normalB (mkDeserializeExprOne 'deserialize con)) []
224 peekErr =
226 peekErr =
225 match
227 match
226 wildP
228 wildP
@@ -289,7 +291,7 @@ mkSerializeExpr True tyOfTy =
289 (doE [ bindS
291 (doE [ bindS
290 (varP (mkName "i0"))
292 (varP (mkName "i0"))
291 (serializeW8List _initialOffset _arr conEnc)
293 (serializeW8List _initialOffset _arr conEnc)
292− , noBindS (mkSerializeExprFields fields)
294+ , noBindS (mkSerializeExprFields 'serialize fields)
293 ])
295 ])
294
296
295mkSerializeExpr False tyOfTy =
297mkSerializeExpr False tyOfTy =
@@ -305,7 +307,7 @@ mkSerializeExpr False tyOfTy =
305 [ matchConstructor
307 [ matchConstructor
306 cname
308 cname
307 (length fields)
309 (length fields)
308− (mkSerializeExprFields fields)
310+ (mkSerializeExprFields 'serialize fields)
309 ])
311 ])
310 -- Sum type
312 -- Sum type
311 (MultiType cons) -> do
313 (MultiType cons) -> do
@@ -320,7 +322,10 @@ mkSerializeExpr False tyOfTy =
320 (doE [ bindS
322 (doE [ bindS
321 (varP (mkName "i0"))
323 (varP (mkName "i0"))
322 (mkSerializeExprTag tagType tagVal)
324 (mkSerializeExprTag tagType tagVal)
325+ , noBindS
323− , noBindS (mkSerializeExprFields fields)
326+ (mkSerializeExprFields
327+ 'serialize
328+ fields)
324 ]))
329 ]))
325 (zip [0 ..] cons))
330 (zip [0 ..] cons))
326
331
core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs+7−4
@@ -14,6 +14,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
14 , TypeOfType(..)
14 , TypeOfType(..)
15 , typeOfType
15 , typeOfType
16 , SimpleDataCon(..)
16 , SimpleDataCon(..)
17+ , simplifyDataCon
17 , Field
18 , Field
18 , mkFieldName
19 , mkFieldName
19 , isUnitType
20 , isUnitType
@@ -22,6 +23,7 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
22 , serializeW8List
23 , serializeW8List
23 , litIntegral
24 , litIntegral
24 , matchConstructor
25 , matchConstructor
26+ , openConstructor
25 , makeI
27 , makeI
26 , makeA
28 , makeA
27 , int_w8
29 , int_w8
@@ -164,12 +166,13 @@ makeA i = mkName $ "a" ++ show i
164-- Domain specific helpers
166-- Domain specific helpers
165--------------------------------------------------------------------------------
167--------------------------------------------------------------------------------
166
168
169+openConstructor :: Name -> Int -> Q Pat
170+openConstructor cname numFields =
171+ conP cname (map varP (map mkFieldName [0 .. (numFields - 1)]))
172+
167matchConstructor :: Name -> Int -> Q Exp -> Q Match
173matchConstructor :: Name -> Int -> Q Exp -> Q Match
168matchConstructor cname numFields exp0 =
174matchConstructor cname numFields exp0 =
169− match
175+ match (openConstructor cname numFields) (normalB exp0) []
170− (conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
171− (normalB exp0)
172− []
173
176
174--------------------------------------------------------------------------------
177--------------------------------------------------------------------------------
175-- Constructor types
178-- Constructor types
core/src/Streamly/Internal/Data/Serialize/TH/Common.hs+7−7
@@ -18,15 +18,14 @@ module Streamly.Internal.Data.Serialize.TH.Common
18--------------------------------------------------------------------------------
18--------------------------------------------------------------------------------
19
19
20import Language.Haskell.TH
20import Language.Haskell.TH
21−import Streamly.Internal.Data.Serialize.Type
22import Streamly.Internal.Data.Serialize.TH.Bottom
21import Streamly.Internal.Data.Serialize.TH.Bottom
23
22
24--------------------------------------------------------------------------------
23--------------------------------------------------------------------------------
25-- Code
24-- Code
26--------------------------------------------------------------------------------
25--------------------------------------------------------------------------------
27
26
28−mkDeserializeExprOne :: SimpleDataCon -> Q Exp
27+mkDeserializeExprOne :: Name -> SimpleDataCon -> Q Exp
29−mkDeserializeExprOne (SimpleDataCon cname fields) =
28+mkDeserializeExprOne peeker (SimpleDataCon cname fields) =
30 case fields of
29 case fields of
31 -- Only tag is serialized for unit fields, no actual value
30 -- Only tag is serialized for unit fields, no actual value
32 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
31 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
@@ -51,10 +50,10 @@ mkDeserializeExprOne (SimpleDataCon cname fields) =
51 makeBind i =
50 makeBind i =
52 bindS
51 bindS
53 (tupP [varP (makeI (i + 1)), varP (makeA i)])
52 (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)|]
55
54
56−mkSerializeExprFields :: [Field] -> Q Exp
55+mkSerializeExprFields :: Name -> [Field] -> Q Exp
57−mkSerializeExprFields fields =
56+mkSerializeExprFields poker fields =
58 case fields of
57 case fields of
59 -- Unit constructor, do nothing just tag is enough
58 -- Unit constructor, do nothing just tag is enough
60 [] -> [|pure ($(varE (mkName "i0")))|]
59 [] -> [|pure ($(varE (mkName "i0")))|]
@@ -67,4 +66,5 @@ mkSerializeExprFields fields =
67 makeBind i =
66 makeBind i =
68 bindS
67 bindS
69 (varP (makeI (i + 1)))
68 (varP (makeI (i + 1)))
69+ [|$(varE poker)
70− [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]
70+ $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]