4f76a0f · streamly · git.iko.soy

103 | otherwise = error "Too many constructors"

104

105--------------------------------------------------------------------------------

106−-- Size

106+-- Constructor types

107--------------------------------------------------------------------------------

108

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+

109isUnitType :: [DataCon] -> Bool

131isUnitType :: [DataCon] -> Bool

110isUnitType [DataCon _ _ _ []] = True

132isUnitType [DataCon _ _ _ []] = True

111isUnitType _ = False

133isUnitType _ = False

112

134

135+--------------------------------------------------------------------------------

136+-- Size

137+--------------------------------------------------------------------------------

138+

113−mkSizeOfExpr :: Type -> [DataCon] -> Q Exp

139+mkSizeOfExpr :: TypeOfType -> Q Exp

114−mkSizeOfExpr headTy constructors =

140+mkSizeOfExpr tyOfTy =

115− case constructors of

141+ case tyOfTy 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 |]

142+ UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|]

126− -- Product type

143+ TheType con ->

127− _ ->

128− lamE

144+ lamE

129− [varP _acc, varP _x]

145+ [varP _acc, varP _x]

130− (caseE (varE _x)

131− [matchCons (varE _acc) constructor])

146+ (caseE (varE _x) [matchCons (varE _acc) con])

132− -- Sum type

133− _ -> sizeOfHeadDt

147+ MultiType constructors -> sizeOfHeadDt constructors

134

148

135 where

149 where

136

150

137− tagSizeExp =

151+ tagSizeExp numConstructors =

138− litE (IntegerL (fromIntegral (getTagSize (length constructors))))

152+ litE (IntegerL (fromIntegral (getTagSize numConstructors)))

139

153

140 -- XXX fields of the same type can be folded together, will reduce the code

154 -- XXX fields of the same type can be folded together, will reduce the code

141 -- size when there are many fields of the same type.

155 -- size when there are many fields of the same type.

148 sizeOfFields acc fields =

162 sizeOfFields acc fields =

149 foldl' exprGetSize acc $ zip [0..] fields

163 foldl' exprGetSize acc $ zip [0..] fields

150

164

151− matchCons acc (DataCon cname _ _ fields) =

165+ matchCons acc (SimpleDataCon cname fields) =

152 let expr = sizeOfFields acc (map snd fields)

166 let expr = sizeOfFields acc (map snd fields)

153 in matchConstructor cname (length fields) expr

167 in matchConstructor cname (length fields) expr

154

168

155 -- XXX We fix VarSize for simplicity. Should be changed later.

169 -- XXX We fix VarSize for simplicity. Should be changed later.

156− sizeOfHeadDt =

170+ sizeOfHeadDt cons =

171+ let numCons = length cons

157− let acc = [|$(varE _acc) + $(tagSizeExp)|]

172+ acc = [|$(varE _acc) + $(tagSizeExp numCons)|]

158 in lamE

173 in lamE

159 [varP _acc, varP _x]

174 [varP _acc, varP _x]

160− (caseE (varE _x) (fmap (matchCons acc) constructors))

175+ (caseE (varE _x) (fmap (matchCons acc) cons))

161

176

162--------------------------------------------------------------------------------

177--------------------------------------------------------------------------------

163-- Peek

178-- Peek

164--------------------------------------------------------------------------------

179--------------------------------------------------------------------------------

165

180

166−mkDeserializeExprOne :: DataCon -> Q Exp

181+mkDeserializeExprOne :: SimpleDataCon -> Q Exp

167−mkDeserializeExprOne (DataCon cname _ _ fields) =

182+mkDeserializeExprOne (SimpleDataCon cname fields) =

168 case fields of

183 case fields of

169 -- Only tag is serialized for unit fields, no actual value

184 -- Only tag is serialized for unit fields, no actual value

170 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]

185 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]

192 [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]

207 [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]

193

208

194

209

195−mkDeserializeExpr :: Type -> [DataCon] -> Q Exp

210+mkDeserializeExpr :: Type -> TypeOfType -> Q Exp

196−mkDeserializeExpr headTy cons =

211+mkDeserializeExpr headTy tyOfTy =

197− case cons of

212+ case tyOfTy of

198− [] ->

199− [|error

200− ("Attempting to peek type with no constructors (" ++

201− $(lift (pprint headTy)) ++ ")")|]

202 -- Unit constructor

213 -- Unit constructor

203− [(DataCon cname _ _ [])] ->

214+ UnitType cname ->

204 [|pure ($(varE _initialOffset) + 1, $(conE cname))|]

215 [|pure ($(varE _initialOffset) + 1, $(conE cname))|]

205 -- Product type

216 -- Product type

206− [con] ->

217+ TheType con ->

207 letE

218 letE

208 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]

219 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]

209 (mkDeserializeExprOne con)

220 (mkDeserializeExprOne con)

210 -- Sum type

221 -- Sum type

211− _ ->

222+ MultiType cons -> do

223+ let lenCons = length cons

224+ tagType = getTagType lenCons

212 doE

225 doE

213 [ bindS

226 [ bindS

214 (tupP [varP (mkName "i0"), varP _tag])

227 (tupP [varP (mkName "i0"), varP _tag])

219 (map peekMatch (zip [0 ..] cons) ++ [peekErr]))

232 (map peekMatch (zip [0 ..] cons) ++ [peekErr]))

220 ]

233 ]

221 where

234 where

222− lenCons = length cons

223− tagType = getTagType lenCons

224 peekMatch (i, con) =

235 peekMatch (i, con) =

225 match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []

236 match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []

226 peekErr =

237 peekErr =

260 (varP (makeI (i + 1)))

271 (varP (makeI (i + 1)))

261 [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]

272 [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]

262

273

263−mkSerializeExpr :: Type -> [DataCon] -> Q Exp

274+mkSerializeExpr :: TypeOfType -> Q Exp

264−mkSerializeExpr headTy cons =

275+mkSerializeExpr tyOfTy =

265− case cons of

276+ case tyOfTy of

266− [] ->

267− [|error

268− ("Attempting to poke type with no constructors (" ++

269− $(lift (pprint headTy)) ++ ")")|]

270 -- Unit type

277 -- Unit type

271− [(DataCon _ _ _ [])] -> [|pure ($(varE _initialOffset) + 1)|]

278+ UnitType _ -> [|pure ($(varE _initialOffset) + 1)|]

272 -- Product type

279 -- Product type

273− [(DataCon cname _ _ fields)] ->

280+ (TheType (SimpleDataCon cname fields)) ->

274 letE

281 letE

275 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]

282 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]

276 (caseE

283 (caseE

281 (mkSerializeExprFields fields)

288 (mkSerializeExprFields fields)

282 ])

289 ])

283 -- Sum type

290 -- Sum type

284− _ ->

291+ (MultiType cons) -> do

292+ let lenCons = length cons

293+ tagType = getTagType lenCons

285 caseE

294 caseE

286 (varE _val)

295 (varE _val)

287− (map (\(tagVal, (DataCon cname _ _ fields)) ->

296+ (map (\(tagVal, (SimpleDataCon cname fields)) ->

288 matchConstructor

297 matchConstructor

289 cname

298 cname

290 (length fields)

299 (length fields)

294 , noBindS (mkSerializeExprFields fields)

303 , noBindS (mkSerializeExprFields fields)

295 ]))

304 ]))

296 (zip [0 ..] cons))

305 (zip [0 ..] cons))

297− where

298− lenCons = length cons

299− tagType = getTagType lenCons

300

306

301--------------------------------------------------------------------------------

307--------------------------------------------------------------------------------

302-- Main

308-- Main

335deriveSerializeInternal ::

341deriveSerializeInternal ::

336 SerializeTHConfig -> Cxt -> Type -> [DataCon] -> Q [Dec]

342 SerializeTHConfig -> Cxt -> Type -> [DataCon] -> Q [Dec]

337deriveSerializeInternal (SerializeTHConfig{..}) preds headTy cons = do

343deriveSerializeInternal (SerializeTHConfig{..}) preds headTy cons = do

338− sizeOfMethod <- mkSizeOfExpr headTy cons

344+ sizeOfMethod <- mkSizeOfExpr (typeOfType headTy cons)

339− peekMethod <- mkDeserializeExpr headTy cons

345+ peekMethod <- mkDeserializeExpr headTy (typeOfType headTy cons)

340− pokeMethod <- mkSerializeExpr headTy cons

346+ pokeMethod <- mkSerializeExpr (typeOfType headTy cons)

341 let methods =

347 let methods =

342 -- INLINE on sizeOf actually worsens some benchmarks, and improves

348 -- INLINE on sizeOf actually worsens some benchmarks, and improves

343 -- none

349 -- none