eaf313d · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Remove the use of record update syntax in Serialize.TH

eaf313dAdithya Kumar3 years ago

core/src/Streamly/Internal/Data/Serialize/TH.hs+2−2

compare with master

unifiedsplit

@@ -242,10 +242,10 @@ mkDeserializeExpr False False headTy tyOfTy =

242 $(lift (pprint headTy)) ++ ")")|])

243 []

244

245−mkDeserializeExpr False True headTy (TheType con@(SimpleDataCon _ fields)) = do

245+mkDeserializeExpr False True _ (TheType con@(SimpleDataCon _ fields)) = do

246 deserializeWithKeys <- newName "deserializeWithKeys"

247 updateFunc <- newName "updateFunc"

248− updateFuncDec <- RecHeader.conUpdateFuncDec updateFunc headTy fields

248+ updateFuncDec <- RecHeader.conUpdateFuncDec updateFunc fields

249 deserializeWithKeysDec <-

250 RecHeader.mkDeserializeKeysDec deserializeWithKeys updateFunc con

251 letE

core/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs+44−25

@@ -83,6 +83,12 @@ import Streamly.Internal.Data.Serialize.TH.Common

83-- parse the value.

84-- * Construct @T@ after parsing all the data.

86+-- Developer Notes

87+-- ===============

88+--

89+-- * Record update syntax is not robust across language extensions and common

90+-- record plugins (like record-dot-processor, large-records, etc.).

91+

86--------------------------------------------------------------------------------

92--------------------------------------------------------------------------------

87-- Compact lists

93-- Compact lists

88--------------------------------------------------------------------------------

94--------------------------------------------------------------------------------

@@ -255,9 +261,9 @@ deserializeWithSize ::

255 Serialize a => Int -> MutableByteArray -> Int -> IO (Int, a)

261 Serialize a => Int -> MutableByteArray -> Int -> IO (Int, a)

256deserializeWithSize off arr endOff = deserialize (off + 4) arr endOff

262deserializeWithSize off arr endOff = deserialize (off + 4) arr endOff

257

263

258−conUpdateFuncDec :: Name -> Type -> [Field] -> Q [Dec]

264+conUpdateFuncDec :: Name -> [Field] -> Q [Dec]

259−conUpdateFuncDec funcName headTy fields = do

265+conUpdateFuncDec funcName fields = do

260− prevRec <- newName "prevRec"

266+ prevAcc <- newName "prevAcc"

261 curOff <- newName "curOff"

267 curOff <- newName "curOff"

262 endOff <- newName "endOff"

268 endOff <- newName "endOff"

263 arr <- newName "arr"

269 arr <- newName "arr"

@@ -266,7 +272,7 @@ conUpdateFuncDec funcName headTy fields = do

266 (caseE

272 (caseE

267 (varE key)

273 (varE key)

268 (concat

274 (concat

269− [ map (matchField arr endOff (prevRec, curOff)) fnames

275+ [ map (matchField arr endOff (prevAcc, curOff)) fnames

270 , [ match

276 , [ match

271 wildP

277 wildP

272 (normalB

278 (normalB

@@ -276,7 +282,7 @@ conUpdateFuncDec funcName headTy fields = do

276 $(varE arr)

282 $(varE arr)

277 $(varE endOff)

283 $(varE endOff)

278 pure

284 pure

279− ( $(varE prevRec)

285+ ( $(varE prevAcc)

280 , valOff + w32_int valLen)|])

286 , valOff + w32_int valLen)|])

281 []

287 []

282 ]

288 ]

@@ -288,7 +294,7 @@ conUpdateFuncDec funcName headTy fields = do

288 [ Clause

294 [ Clause

289 [ VarP arr

295 [ VarP arr

290 , VarP endOff

296 , VarP endOff

291− , TupP [VarP prevRec, VarP curOff]

297+ , TupP [VarP prevAcc, VarP curOff]

292 , VarP key

298 , VarP key

293 ]

299 ]

294 (NormalB method)

300 (NormalB method)

@@ -300,21 +306,19 @@ conUpdateFuncDec funcName headTy fields = do

300

306

301 fnames = fmap (fromJust . fst) fields

307 fnames = fmap (fromJust . fst) fields

302 matchField :: Name -> Name -> (Name, Name) -> Name -> Q Match

308 matchField :: Name -> Name -> (Name, Name) -> Name -> Q Match

303− matchField arr endOff (prevRec, currOff) fname = do

309+ matchField arr endOff (acc, currOff) fname = do

304− val <- newName "val"

310+ let fnameLit = StringL (nameBase fname)

305− newOff <- newName "newOff"

306 match

311 match

307− (litP (StringL (nameBase fname)))

312+ (litP fnameLit)

308 (normalB

313 (normalB

309− [|do ($(varP newOff), $(varP val)) <-

314+ [|do (valOff, valLen :: Word32) <-

310− deserializeWithSize

315+ deserialize

311− $(varE currOff)

316+ $(varE currOff)

312− $(varE arr)

317+ $(varE arr)

313− $(varE endOff)

318+ $(varE endOff)

314 pure

319 pure

315− ( $(recUpdE (varE prevRec) [pure (fname, VarE val)])

320+ ( ($(litE fnameLit), $(varE currOff)) : $(varE acc)

316− :: $(pure headTy)

321+ , valOff + w32_int valLen)|])

317− , $(varE newOff))|])

318 []

322 []

319

323

320mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec]

324mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec]

@@ -323,16 +327,33 @@ mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do

323 finalOff <- newName "finalOff"

327 finalOff <- newName "finalOff"

324 arr <- newName "arr"

328 arr <- newName "arr"

325 endOff <- newName "endOff"

329 endOff <- newName "endOff"

330+ kvEncoded <- newName "kvEncoded"

331+ finalRec <- newName "finalRec"

332+ let deserializeFieldExpr (Just name, ty) = do

333+ let nameLit = litE (StringL (nameBase name))

334+ [|case lookup $(nameLit) $(varE kvEncoded) of

335+ Nothing -> $(emptyTy name ty)

336+ Just off -> do

337+ val <- deserializeWithSize off $(varE arr) $(varE endOff)

338+ pure $ snd val|]

339+ deserializeFieldExpr _ = errorUnsupported

326 method <-

340 method <-

327 [|do (dataOff, hlist :: CompactList (CompactList Word8)) <-

341 [|do (dataOff, hlist :: CompactList (CompactList Word8)) <-

328 deserialize $(varE hOff) $(varE arr) $(varE endOff)

342 deserialize $(varE hOff) $(varE arr) $(varE endOff)

329 let keys = wListToString . unCompactList <$> unCompactList hlist

343 let keys = wListToString . unCompactList <$> unCompactList hlist

330− (finalRec, _) <-

344+ ($(varP kvEncoded), _) <-

331 foldlM

345 foldlM

332 ($(varE updateFunc) $(varE arr) $(varE endOff))

346 ($(varE updateFunc) $(varE arr) $(varE endOff))

333− ($(emptyConExpr), dataOff)

347+ ([], dataOff)

334 keys

348 keys

349+ $(varP finalRec) <-

350+ $(foldl

351+ (\acc i ->

352+ [|$(acc) <*>

353+ $(deserializeFieldExpr i)|])

354+ [|pure $(conE cname)|]

355+ fields)

335− pure ($(varE finalOff), finalRec)|]

356+ pure ($(varE finalOff), $(varE finalRec))|]

336 pure

357 pure

337 [ PragmaD (InlineP funcName NoInline FunLike AllPhases)

358 [ PragmaD (InlineP funcName NoInline FunLike AllPhases)

338 , FunD

359 , FunD

@@ -352,11 +373,9 @@ mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do

352

373

353 emptyTy k ty =

374 emptyTy k ty =

354 if isMaybeType ty

375 if isMaybeType ty

355− then [|Nothing|]

376+ then [|pure Nothing|]

356 else [|error $(litE (StringL (nameBase k ++ " is not found.")))|]

377 else [|error $(litE (StringL (nameBase k ++ " is not found.")))|]

357− fieldToEmptyRecC (Just name, ty) = (name, ) <$> emptyTy name ty

378+

358− fieldToEmptyRecC _ = errorUnsupported

359− emptyConExpr = recConE cname (fmap fieldToEmptyRecC fields)

360

379

361mkDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp

380mkDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp

362mkDeserializeExpr initialOff endOff deserializeWithKeys con = do

381mkDeserializeExpr initialOff endOff deserializeWithKeys con = do