Skip to content

Commit b192e34

Browse files
garybgaryb
authored
Merge pull request #71 from m-bock/mapTag
New option for sum codecs: `mapTag`
2 parents 368fc25 + 56583cb commit b192e34

File tree

2 files changed

+202
-51
lines changed

2 files changed

+202
-51
lines changed

‎src/Data/Codec/Argonaut/Sum.purs

Lines changed: 63 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,7 @@ module Data.Codec.Argonaut.Sum
1818
, sumFlatWith
1919
, sumWith
2020
, taggedSum
21-
)
22-
where
21+
) where
2322

2423
import Prelude
2524

@@ -110,12 +109,15 @@ taggedSum name printTag parseTag f g = Codec.codec decodeCase encodeCase
110109

111110
data Encoding
112111
= EncodeNested
113-
{ unwrapSingleArguments ∷ Boolean }
112+
{ unwrapSingleArguments ∷ Boolean
113+
, mapTag ∷ String → String
114+
}
114115
| EncodeTagged
115116
{ tagKey ∷ String
116117
, valuesKey ∷ String
117118
, omitEmptyArguments ∷ Boolean
118119
, unwrapSingleArguments ∷ Boolean
120+
, mapTag ∷ String → String
119121
}
120122

121123
defaultEncoding ∷ Encoding
@@ -124,6 +126,7 @@ defaultEncoding = EncodeTagged
124126
, valuesKey: "values"
125127
, unwrapSingleArguments: false
126128
, omitEmptyArguments: false
129+
, mapTag: identity
127130
}
128131

129132
--------------------------------------------------------------------------------
@@ -301,9 +304,10 @@ checkTag tagKey obj expectedTag = do
301304
$ TypeMismatch ("Expecting tag `" <> expectedTag <> "`, got `" <> tag <> "`")
302305

303306
parseNoFields ∷ Encoding → Json → String → Either JsonDecodeError Unit
304-
parseNoFields encoding json expectedTag =
307+
parseNoFields encoding json expectedTagRaw =
305308
case encoding of
306-
EncodeNested {} → do
309+
EncodeNested { mapTag } → do
310+
let expectedTag = mapTag expectedTagRaw ∷ String
307311
obj ← CA.decode jobject json
308312
val ←
309313
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
@@ -313,7 +317,8 @@ parseNoFields encoding json expectedTag =
313317
$ Left
314318
$ TypeMismatch "Expecting an empty array"
315319

316-
EncodeTagged { tagKey, valuesKey, omitEmptyArguments } → do
320+
EncodeTagged { tagKey, valuesKey, omitEmptyArguments, mapTag } → do
321+
let expectedTag = mapTag expectedTagRaw ∷ String
317322
obj ← CA.decode jobject json
318323
checkTag tagKey obj expectedTag
319324
when (not omitEmptyArguments) do
@@ -327,8 +332,9 @@ parseNoFields encoding json expectedTag =
327332
$ TypeMismatch "Expecting an empty array"
328333

329334
parseSingleField ∷ Encoding → Json → String → Either JsonDecodeError Json
330-
parseSingleField encoding json expectedTag = case encoding of
331-
EncodeNested { unwrapSingleArguments } → do
335+
parseSingleField encoding json expectedTagRaw = case encoding of
336+
EncodeNested { unwrapSingleArguments, mapTag } → do
337+
let expectedTag = mapTag expectedTagRaw ∷ String
332338
obj ← CA.decode jobject json
333339
val ←
334340
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
@@ -341,7 +347,8 @@ parseSingleField encoding json expectedTag = case encoding of
341347
[ head ] → pure head
342348
_ → Left $ TypeMismatch "Expecting exactly one element"
343349

344-
EncodeTagged { tagKey, valuesKey, unwrapSingleArguments } → do
350+
EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, mapTag } → do
351+
let expectedTag = mapTag expectedTagRaw ∷ String
345352
obj ← CA.decode jobject json
346353
checkTag tagKey obj expectedTag
347354
val ←
@@ -357,16 +364,18 @@ parseSingleField encoding json expectedTag = case encoding of
357364
_ → Left $ TypeMismatch "Expecting exactly one element"
358365

359366
parseManyFields ∷ Encoding → Json → String → Either JsonDecodeError (Array Json)
360-
parseManyFields encoding json expectedTag =
367+
parseManyFields encoding json expectedTagRaw =
361368
case encoding of
362-
EncodeNested {} → do
369+
EncodeNested { mapTag } → do
370+
let expectedTag = mapTag expectedTagRaw ∷ String
363371
obj ← CA.decode jobject json
364372
val ←
365373
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
366374
) ∷ _ Json
367375
CA.decode CA.jarray val
368376

369-
EncodeTagged { tagKey, valuesKey } → do
377+
EncodeTagged { tagKey, valuesKey, mapTag } → do
378+
let expectedTag = mapTag expectedTagRaw ∷ String
370379
obj ← CA.decode jobject json
371380
checkTag tagKey obj expectedTag
372381
val ←
@@ -376,10 +385,11 @@ parseManyFields encoding json expectedTag =
376385
CA.decode CA.jarray val
377386

378387
encodeSumCase ∷ Encoding → String → Array Json → Json
379-
encodeSumCase encoding tag jsons =
388+
encodeSumCase encoding rawTag jsons =
380389
case encoding of
381-
EncodeNested { unwrapSingleArguments } →
390+
EncodeNested { unwrapSingleArguments, mapTag } →
382391
let
392+
tag = mapTag rawTag ∷ String
383393
val = case jsons of
384394
[] → CA.encode CA.jarray []
385395
[ json ] | unwrapSingleArguments → json
@@ -389,8 +399,9 @@ encodeSumCase encoding tag jsons =
389399
[ tag /\ val
390400
]
391401

392-
EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, omitEmptyArguments } →
402+
EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, omitEmptyArguments, mapTag } →
393403
let
404+
tag = mapTag rawTag ∷ String
394405
tagEntry =
395406
Just (tagKey /\ CA.encode CA.string tag) ∷ Maybe (String /\ Json)
396407
valEntry =
@@ -404,27 +415,31 @@ encodeSumCase encoding tag jsons =
404415

405416
type FlatEncoding (tag ∷ Symbol) =
406417
{ tag ∷ Proxy tag
418+
, mapTag ∷ String → String
407419
}
408420

409421
defaultFlatEncoding ∷ FlatEncoding "tag"
410-
defaultFlatEncoding = { tag: Proxy }
422+
defaultFlatEncoding =
423+
{ tag: Proxy
424+
, mapTag: identity
425+
}
411426

412427
sumFlat ∷ ∀ r rep a. GFlatCases "tag" r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
413428
sumFlat = sumFlatWith defaultFlatEncoding
414429

415-
sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag -> String → Record r → JsonCodec a
416-
sumFlatWith _ name r =
430+
sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag → String → Record r → JsonCodec a
431+
sumFlatWith encoding name r =
417432
dimap from to $ codec' dec enc
418433
where
419-
dec = gFlatCasesDecode @tag r >>> (lmap $ Named name)
420-
enc = gFlatCasesEncode @tag r
434+
dec = gFlatCasesDecode @tag encoding r >>> (lmap $ Named name)
435+
enc = gFlatCasesEncode @tag encoding r
421436

422437
class GFlatCases ∷ Symbol → Row Type → Type → Constraint
423438
class
424439
GFlatCases tag r rep
425440
where
426-
gFlatCasesEncode ∷ Record r → rep → Json
427-
gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
441+
gFlatCasesEncode ∷ FlatEncoding tag → Record r → rep → Json
442+
gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError rep
428443

429444
instance gFlatCasesConstructorNoArg ∷
430445
( Row.Cons name Unit () rc
@@ -433,22 +448,23 @@ instance gFlatCasesConstructorNoArg ∷
433448
, IsSymbol tag
434449
) ⇒
435450
GFlatCases tag rc (Constructor name NoArguments) where
436-
gFlatCasesEncode ∷ Record rc → Constructor name NoArguments → Json
437-
gFlatCasesEncode _ (Constructor NoArguments) =
451+
gFlatCasesEncode ∷ FlatEncoding tag → Record rc → Constructor name NoArguments → Json
452+
gFlatCasesEncode { mapTag } _ (Constructor NoArguments) =
438453
let
439-
name = reflectSymbol (Proxy @name) ∷ String
454+
nameRaw = reflectSymbol (Proxy @name) ∷ String
455+
name = mapTag nameRaw ∷ String
440456
propCodec = CAR.record {} ∷ JPropCodec {}
441457
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
442458
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
443459
rcWithTag = Record.insert (Proxy @tag) name {} ∷ Record rf
444460
in
445461
CA.encode codecWithTag rcWithTag
446462

447-
gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
448-
gFlatCasesDecode _ json = do
463+
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
464+
gFlatCasesDecode { mapTag } _ json = do
449465
let
450-
name = reflectSymbol (Proxy @name) ∷ String
451-
466+
nameRaw = reflectSymbol (Proxy @name) ∷ String
467+
name = mapTag nameRaw ∷ String
452468
propCodec = CAR.record {} ∷ JPropCodec {}
453469
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
454470
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
@@ -469,21 +485,23 @@ instance gFlatCasesConstructorSingleArg ∷
469485
, IsSymbol tag
470486
) ⇒
471487
GFlatCases tag rc (Constructor name (Argument (Record rf))) where
472-
gFlatCasesEncode ∷ Record rc → Constructor name (Argument (Record rf)) → Json
473-
gFlatCasesEncode rc (Constructor (Argument rf)) =
488+
gFlatCasesEncode ∷ FlatEncoding tag → Record rc → Constructor name (Argument (Record rf)) → Json
489+
gFlatCasesEncode { mapTag } rc (Constructor (Argument rf)) =
474490
let
475-
name = reflectSymbol (Proxy @name) ∷ String
491+
nameRaw = reflectSymbol (Proxy @name) ∷ String
492+
name = mapTag nameRaw ∷ String
476493
propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
477494
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
478495
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
479496
rcWithTag = Record.insert (Proxy @tag) name rf ∷ Record rf'
480497
in
481498
CA.encode codecWithTag rcWithTag
482499

483-
gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
484-
gFlatCasesDecode rc json = do
500+
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
501+
gFlatCasesDecode { mapTag } rc json = do
485502
let
486-
name = reflectSymbol (Proxy @name) ∷ String
503+
nameRaw = reflectSymbol (Proxy @name) ∷ String
504+
name = mapTag nameRaw ∷ String
487505
propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
488506
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
489507
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
@@ -507,28 +525,30 @@ instance gFlatCasesSum ∷
507525
, IsSymbol name
508526
) ⇒
509527
GFlatCases tag r (Sum (Constructor name lhs) rhs) where
510-
gFlatCasesEncode ∷ Record r → Sum (Constructor name lhs) rhs → Json
511-
gFlatCasesEncode r =
528+
gFlatCasesEncode ∷ FlatEncoding tag → Record r → Sum (Constructor name lhs) rhs → Json
529+
gFlatCasesEncode encoding r =
512530
let
513531
codec = Record.get (Proxy @name) r ∷ codec
514532
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
515533
r2 = unsafeDelete (Proxy @name) r ∷ Record r2
516534
in
517535
case _ of
518-
Inl lhs → gFlatCasesEncode @tag r1 lhs
519-
Inr rhs → gFlatCasesEncode @tag r2 rhs
536+
Inl lhs → gFlatCasesEncode @tag encoding r1 lhs
537+
Inr rhs → gFlatCasesEncode @tag encoding r2 rhs
520538

521-
gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
522-
gFlatCasesDecode r tagged = do
539+
gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
540+
gFlatCasesDecode encoding r tagged = do
523541
let
524542
codec = Record.get (Proxy @name) r ∷ codec
525543
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
526544
r2 = Record.delete (Proxy @name) r ∷ Record r2
527545
let
528-
lhs = gFlatCasesDecode @tag r1 tagged ∷ _ (Constructor name lhs)
529-
rhs = gFlatCasesDecode @tag r2 tagged ∷ _ rhs
546+
lhs = gFlatCasesDecode @tag encoding r1 tagged ∷ _ (Constructor name lhs)
547+
rhs = gFlatCasesDecode @tag encoding r2 tagged ∷ _ rhs
530548
(Inl <$> lhs) <|> (Inr <$> rhs)
531549

550+
--------------------------------------------------------------------------------
551+
532552
-- | Same as `Record.delete` but deleting only happens at the type level
533553
-- | and the value is left untouched.
534554
unsafeDelete ∷ ∀ r1 r2 l a. IsSymbol l ⇒ Row.Lacks l r1 ⇒ Row.Cons l a r1 r2 ⇒ Proxy l → Record r2 → Record r1

0 commit comments

Comments
 (0)