From f13ccb0dba2e491233dc796048ec934472630383 Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Tue, 12 Sep 2023 20:53:43 +0530 Subject: [PATCH] Make the common serialization routines abstract & add TH helpers --- core/src/Streamly/Internal/Data/Serialize/TH.hs | 17 +++++++++++------ .../Internal/Data/Serialize/TH/Bottom.hs | 11 +++++++---- .../Internal/Data/Serialize/TH/Common.hs | 14 +++++++------- 3 files changed, 25 insertions(+), 17 deletions(-) diff --git a/core/src/Streamly/Internal/Data/Serialize/TH.hs b/core/src/Streamly/Internal/Data/Serialize/TH.hs index bf89b62a14..37df1622ba 100644 --- 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 index 4fab1e7379..b6cdc366d1 100644 --- 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 index 91ec6e38f5..822176bcb0 100644 --- 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))|]