@@ -103,39 +103,53 @@ getTagType numConstructors
103103 | otherwise = error "Too many constructors"
104104
105105--------------------------------------------------------------------------------
106−-- Size
106+-- Constructor types
107107--------------------------------------------------------------------------------
108108
109+data SimpleDataCon =
110+ SimpleDataCon Name [Field]
111+ deriving (Eq)
112+
113+simplifyDataCon :: DataCon -> SimpleDataCon
114+simplifyDataCon (DataCon cname _ _ fields) = SimpleDataCon cname fields
115+
116+data TypeOfType
117+ = UnitType Name -- 1 constructor and 1 field
118+ | TheType SimpleDataCon -- 1 constructor and 1+ fields
119+ | MultiType [SimpleDataCon] -- 1+ constructors
120+ deriving (Eq)
121+
122+typeOfType :: Type -> [DataCon] -> TypeOfType
123+typeOfType headTy [] =
124+ error
125+ ("Attempting to get size with no constructors (" ++
126+ (pprint headTy) ++ ")")
127+typeOfType _ [DataCon cname _ _ []] = UnitType cname
128+typeOfType _ [con@(DataCon _ _ _ _)] = TheType $ simplifyDataCon con
129+typeOfType _ cons = MultiType $ map simplifyDataCon cons
130+
109131isUnitType :: [DataCon] -> Bool
110132isUnitType [DataCon _ _ _ []] = True
111133isUnitType _ = False
112134
113−mkSizeOfExpr :: Type -> [DataCon] -> Q Exp
114−mkSizeOfExpr headTy constructors =
115− case constructors of
116− [] ->
117− [|error
118− ("Attempting to get size with no constructors (" ++
119− $(lift (pprint headTy)) ++ ")")|]
120− -- One constructor with no fields is a unit type. Size of a unit type is
121− -- 1. XXX Use isUnitType?
122− [constructor@(DataCon _ _ _ fields)] ->
123− case fields of
124− -- Unit type
125− [] -> lamE [varP _acc, wildP] [| $(varE _acc) + 1 |]
126− -- Product type
127− _ ->
128− lamE
129− [varP _acc, varP _x]
130− (caseE (varE _x)
131− [matchCons (varE _acc) constructor])
132− -- Sum type
133− _ -> sizeOfHeadDt
135+--------------------------------------------------------------------------------
136+-- Size
137+--------------------------------------------------------------------------------
138+
139+mkSizeOfExpr :: TypeOfType -> Q Exp
140+mkSizeOfExpr tyOfTy =
141+ case tyOfTy of
142+ UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|]
143+ TheType con ->
144+ lamE
145+ [varP _acc, varP _x]
146+ (caseE (varE _x) [matchCons (varE _acc) con])
147+ MultiType constructors -> sizeOfHeadDt constructors
134148
135149 where
136150
137− tagSizeExp =
138− litE (IntegerL (fromIntegral (getTagSize (length constructors))))
151+ tagSizeExp numConstructors =
152+ litE (IntegerL (fromIntegral (getTagSize numConstructors)))
139153
140154 -- XXX fields of the same type can be folded together, will reduce the code
141155 -- size when there are many fields of the same type.
@@ -148,23 +162,24 @@ mkSizeOfExpr headTy constructors =
148162 sizeOfFields acc fields =
149163 foldl' exprGetSize acc $ zip [0..] fields
150164
151− matchCons acc (DataCon cname _ _ fields) =
165+ matchCons acc (SimpleDataCon cname fields) =
152166 let expr = sizeOfFields acc (map snd fields)
153167 in matchConstructor cname (length fields) expr
154168
155169 -- XXX We fix VarSize for simplicity. Should be changed later.
156− sizeOfHeadDt =
157− let acc = [|$(varE _acc) + $(tagSizeExp)|]
170+ sizeOfHeadDt cons =
171+ let numCons = length cons
172+ acc = [|$(varE _acc) + $(tagSizeExp numCons)|]
158173 in lamE
159174 [varP _acc, varP _x]
160− (caseE (varE _x) (fmap (matchCons acc) constructors))
175+ (caseE (varE _x) (fmap (matchCons acc) cons))
161176
162177--------------------------------------------------------------------------------
163178-- Peek
164179--------------------------------------------------------------------------------
165180
166−mkDeserializeExprOne :: DataCon -> Q Exp
167−mkDeserializeExprOne (DataCon cname _ _ fields) =
181+mkDeserializeExprOne :: SimpleDataCon -> Q Exp
182+mkDeserializeExprOne (SimpleDataCon cname fields) =
168183 case fields of
169184 -- Only tag is serialized for unit fields, no actual value
170185 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
@@ -192,23 +207,21 @@ mkDeserializeExprOne (DataCon cname _ _ fields) =
192207 [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
193208
194209
195−mkDeserializeExpr :: Type -> [DataCon] -> Q Exp
196−mkDeserializeExpr headTy cons =
197− case cons of
198− [] ->
199− [|error
200− ("Attempting to peek type with no constructors (" ++
201− $(lift (pprint headTy)) ++ ")")|]
210+mkDeserializeExpr :: Type -> TypeOfType -> Q Exp
211+mkDeserializeExpr headTy tyOfTy =
212+ case tyOfTy of
202213 -- Unit constructor
203− [(DataCon cname _ _ [])] ->
214+ UnitType cname ->
204215 [|pure ($(varE _initialOffset) + 1, $(conE cname))|]
205216 -- Product type
206− [con] ->
217+ TheType con ->
207218 letE
208219 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
209220 (mkDeserializeExprOne con)
210221 -- Sum type
211− _ ->
222+ MultiType cons -> do
223+ let lenCons = length cons
224+ tagType = getTagType lenCons
212225 doE
213226 [ bindS
214227 (tupP [varP (mkName "i0"), varP _tag])
@@ -219,8 +232,6 @@ mkDeserializeExpr headTy cons =
219232 (map peekMatch (zip [0 ..] cons) ++ [peekErr]))
220233 ]
221234 where
222− lenCons = length cons
223− tagType = getTagType lenCons
224235 peekMatch (i, con) =
225236 match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []
226237 peekErr =
@@ -260,17 +271,13 @@ mkSerializeExprFields fields =
260271 (varP (makeI (i + 1)))
261272 [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]
262273
263−mkSerializeExpr :: Type -> [DataCon] -> Q Exp
264−mkSerializeExpr headTy cons =
265− case cons of
266− [] ->
267− [|error
268− ("Attempting to poke type with no constructors (" ++
269− $(lift (pprint headTy)) ++ ")")|]
274+mkSerializeExpr :: TypeOfType -> Q Exp
275+mkSerializeExpr tyOfTy =
276+ case tyOfTy of
270277 -- Unit type
271− [(DataCon _ _ _ [])] -> [|pure ($(varE _initialOffset) + 1)|]
278+ UnitType _ -> [|pure ($(varE _initialOffset) + 1)|]
272279 -- Product type
273− [(DataCon cname _ _ fields)] ->
280+ (TheType (SimpleDataCon cname fields)) ->
274281 letE
275282 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
276283 (caseE
@@ -281,10 +288,12 @@ mkSerializeExpr headTy cons =
281288 (mkSerializeExprFields fields)
282289 ])
283290 -- Sum type
284− _ ->
291+ (MultiType cons) -> do
292+ let lenCons = length cons
293+ tagType = getTagType lenCons
285294 caseE
286295 (varE _val)
287− (map (\(tagVal, (DataCon cname _ _ fields)) ->
296+ (map (\(tagVal, (SimpleDataCon cname fields)) ->
288297 matchConstructor
289298 cname
290299 (length fields)
@@ -294,9 +303,6 @@ mkSerializeExpr headTy cons =
294303 , noBindS (mkSerializeExprFields fields)
295304 ]))
296305 (zip [0 ..] cons))
297− where
298− lenCons = length cons
299− tagType = getTagType lenCons
300306
301307--------------------------------------------------------------------------------
302308-- Main
@@ -335,9 +341,9 @@ mkSerializeExpr headTy cons =
335341deriveSerializeInternal ::
336342 SerializeTHConfig -> Cxt -> Type -> [DataCon] -> Q [Dec]
337343deriveSerializeInternal (SerializeTHConfig{..}) preds headTy cons = do
338− sizeOfMethod <- mkSizeOfExpr headTy cons
339− peekMethod <- mkDeserializeExpr headTy cons
340− pokeMethod <- mkSerializeExpr headTy cons
344+ sizeOfMethod <- mkSizeOfExpr (typeOfType headTy cons)
345+ peekMethod <- mkDeserializeExpr headTy (typeOfType headTy cons)
346+ pokeMethod <- mkSerializeExpr (typeOfType headTy cons)
341347 let methods =
342348 -- INLINE on sizeOf actually worsens some benchmarks, and improves
343349 -- none