git.iko.soy/streamly
on master help sign in
Add a dumb usage of recordSyntaxWithHeader option in Serialize.TH
de89f36Adithya Kumar
core/src/Streamly/Internal/Data/Serialize/TH.hs+29−12
compare with master
unifiedsplit
@@ -79,8 +79,8 @@ conEncLen cname = getNameBaseLen cname + 1
79-- Size
79-- Size
80--------------------------------------------------------------------------------
80--------------------------------------------------------------------------------
81
81
82−mkSizeOfExpr :: Bool -> TypeOfType -> Q Exp
82+mkSizeOfExpr :: Bool -> Bool -> TypeOfType -> Q Exp
83−mkSizeOfExpr True tyOfTy =
83+mkSizeOfExpr True False tyOfTy =
84 case tyOfTy of
84 case tyOfTy of
85 UnitType cname ->
85 UnitType cname ->
86 lamE
86 lamE
@@ -109,7 +109,7 @@ mkSizeOfExpr True tyOfTy =
109 [varP _acc, varP _x]
109 [varP _acc, varP _x]
110 (caseE (varE _x) (fmap (matchCons acc) cons))
110 (caseE (varE _x) (fmap (matchCons acc) cons))
111
111
112−mkSizeOfExpr False tyOfTy =
112+mkSizeOfExpr False False tyOfTy =
113 case tyOfTy of
113 case tyOfTy of
114 UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|]
114 UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|]
115 TheType con ->
115 TheType con ->
@@ -146,10 +146,16 @@ mkSizeOfExpr False tyOfTy =
146 [varP _acc, varP _x]
146 [varP _acc, varP _x]
147 (caseE (varE _x) (fmap (matchCons acc) cons))
147 (caseE (varE _x) (fmap (matchCons acc) cons))
148
148
149+mkSizeOfExpr _ _ _ = errorUnimplemented
150+
149mkSizeDec :: Config -> Type -> [DataCon] -> Q [Dec]
151mkSizeDec :: Config -> Type -> [DataCon] -> Q [Dec]
150mkSizeDec (Config {..}) headTy cons = do
152mkSizeDec (Config {..}) headTy cons = do
151 -- INLINE on sizeOf actually worsens some benchmarks, and improves none
153 -- INLINE on sizeOf actually worsens some benchmarks, and improves none
154+ sizeOfMethod <-
155+ mkSizeOfExpr
152− sizeOfMethod <- mkSizeOfExpr constructorTagAsString (typeOfType headTy cons)
156+ constructorTagAsString
157+ recordSyntaxWithHeader
158+ (typeOfType headTy cons)
153 pure
159 pure
154 [ PragmaD (InlineP 'size inlineSize FunLike AllPhases)
160 [ PragmaD (InlineP 'size inlineSize FunLike AllPhases)
155 , FunD 'size [Clause [] (NormalB sizeOfMethod) []]
161 , FunD 'size [Clause [] (NormalB sizeOfMethod) []]
@@ -159,8 +165,8 @@ mkSizeDec (Config {..}) headTy cons = do
159-- Peek
165-- Peek
160--------------------------------------------------------------------------------
166--------------------------------------------------------------------------------
161
167
162−mkDeserializeExpr :: Bool -> Type -> TypeOfType -> Q Exp
168+mkDeserializeExpr :: Bool -> Bool -> Type -> TypeOfType -> Q Exp
163−mkDeserializeExpr True headTy tyOfTy =
169+mkDeserializeExpr True False headTy tyOfTy =
164 case tyOfTy of
170 case tyOfTy of
165 UnitType cname -> deserializeConsExpr [SimpleDataCon cname []]
171 UnitType cname -> deserializeConsExpr [SimpleDataCon cname []]
166 TheType con -> deserializeConsExpr [con]
172 TheType con -> deserializeConsExpr [con]
@@ -194,7 +200,7 @@ mkDeserializeExpr True headTy tyOfTy =
194 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
200 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
195 in $(mkDeserializeExprOne 'deserialize con)|]
201 in $(mkDeserializeExprOne 'deserialize con)|]
196
202
197−mkDeserializeExpr False headTy tyOfTy =
203+mkDeserializeExpr False False headTy tyOfTy =
198 case tyOfTy of
204 case tyOfTy of
199 -- Unit constructor
205 -- Unit constructor
200 UnitType cname ->
206 UnitType cname ->
@@ -232,10 +238,16 @@ mkDeserializeExpr False headTy tyOfTy =
232 $(lift (pprint headTy)) ++ ")")|])
238 $(lift (pprint headTy)) ++ ")")|])
233 []
239 []
234
240
241+mkDeserializeExpr _ _ _ _ = errorUnimplemented
242+
235mkDeserializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
243mkDeserializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
236mkDeserializeDec (Config {..}) headTy cons = do
244mkDeserializeDec (Config {..}) headTy cons = do
237 peekMethod <-
245 peekMethod <-
246+ mkDeserializeExpr
238− mkDeserializeExpr constructorTagAsString headTy (typeOfType headTy cons)
247+ constructorTagAsString
248+ recordSyntaxWithHeader
249+ headTy
250+ (typeOfType headTy cons)
239 pure
251 pure
240 [ PragmaD (InlineP 'deserialize inlineDeserialize FunLike AllPhases)
252 [ PragmaD (InlineP 'deserialize inlineDeserialize FunLike AllPhases)
241 , FunD
253 , FunD
@@ -260,8 +272,8 @@ mkSerializeExprTag tagType tagVal =
260 $(varE _arr)
272 $(varE _arr)
261 $((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
273 $((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
262
274
263−mkSerializeExpr :: Bool -> TypeOfType -> Q Exp
275+mkSerializeExpr :: Bool -> Bool -> TypeOfType -> Q Exp
264−mkSerializeExpr True tyOfTy =
276+mkSerializeExpr True False tyOfTy =
265 case tyOfTy of
277 case tyOfTy of
266 -- Unit type
278 -- Unit type
267 UnitType cname ->
279 UnitType cname ->
@@ -293,7 +305,7 @@ mkSerializeExpr True tyOfTy =
293 , noBindS (mkSerializeExprFields 'serialize fields)
305 , noBindS (mkSerializeExprFields 'serialize fields)
294 ])
306 ])
295
307
296−mkSerializeExpr False tyOfTy =
308+mkSerializeExpr False False tyOfTy =
297 case tyOfTy of
309 case tyOfTy of
298 -- Unit type
310 -- Unit type
299 UnitType _ -> [|pure ($(varE _initialOffset) + 1)|]
311 UnitType _ -> [|pure ($(varE _initialOffset) + 1)|]
@@ -328,10 +340,15 @@ mkSerializeExpr False tyOfTy =
328 ]))
340 ]))
329 (zip [0 ..] cons))
341 (zip [0 ..] cons))
330
342
343+mkSerializeExpr _ _ _ = errorUnimplemented
344+
331mkSerializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
345mkSerializeDec :: Config -> Type -> [DataCon] -> Q [Dec]
332mkSerializeDec (Config {..}) headTy cons = do
346mkSerializeDec (Config {..}) headTy cons = do
333 pokeMethod <-
347 pokeMethod <-
348+ mkSerializeExpr
334− mkSerializeExpr constructorTagAsString (typeOfType headTy cons)
349+ constructorTagAsString
350+ recordSyntaxWithHeader
351+ (typeOfType headTy cons)
335 pure
352 pure
336 [ PragmaD (InlineP 'serialize inlineSerialize FunLike AllPhases)
353 [ PragmaD (InlineP 'serialize inlineSerialize FunLike AllPhases)
337 , FunD
354 , FunD