Skip to content

Commit 26bba8f

Browse files
m-bockm-bock
committed
Add mapTag option
1 parent 368fc25 commit 26bba8f

File tree

2 files changed

+150
-18
lines changed

2 files changed

+150
-18
lines changed

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

Lines changed: 60 additions & 16 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 =
@@ -412,7 +423,7 @@ defaultFlatEncoding = { tag: Proxy }
412423
sumFlat ∷ ∀ r rep a. GFlatCases "tag" r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
413424
sumFlat = sumFlatWith defaultFlatEncoding
414425

415-
sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag -> String → Record r → JsonCodec a
426+
sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag → String → Record r → JsonCodec a
416427
sumFlatWith _ name r =
417428
dimap from to $ codec' dec enc
418429
where
@@ -529,6 +540,39 @@ instance gFlatCasesSum ∷
529540
rhs = gFlatCasesDecode @tag r2 tagged ∷ _ rhs
530541
(Inl <$> lhs) <|> (Inr <$> rhs)
531542

543+
--------------------------------------------------------------------------------
544+
545+
sumEnum ∷ ∀ r rep a. GEnumCases r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
546+
sumEnum = unsafeCoerce 1
547+
548+
class GEnumCases ∷ Row Type → Type → Constraint
549+
class
550+
GEnumCases r rep
551+
where
552+
gEnumCasesEncode ∷ Record r → rep → Json
553+
gEnumCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
554+
555+
instance gEnumCasesConstructorNoArg ∷
556+
( Row.Cons name Unit () rc
557+
, IsSymbol name
558+
) ⇒
559+
GEnumCases rc (Constructor name NoArguments) where
560+
gEnumCasesEncode ∷ Record rc → Constructor name NoArguments → Json
561+
gEnumCasesEncode _ _ =
562+
let
563+
name = reflectSymbol (Proxy @name) ∷ String
564+
in
565+
encodeSumCase defaultEncoding name []
566+
567+
gEnumCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
568+
gEnumCasesDecode _ json = do
569+
let name = reflectSymbol (Proxy @name) ∷ String
570+
571+
parseNoFields defaultEncoding json name
572+
pure $ Constructor NoArguments
573+
574+
--------------------------------------------------------------------------------
575+
532576
-- | Same as `Record.delete` but deleting only happens at the type level
533577
-- | and the value is left untouched.
534578
unsafeDelete ∷ ∀ r1 r2 l a. IsSymbol l ⇒ Row.Lacks l r1 ⇒ Row.Cons l a r1 r2 ⇒ Proxy l → Record r2 → Record r1

‎test/Test/Sum.purs

Lines changed: 90 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import Data.Codec (decode, encode)
1010
import Data.Codec.Argonaut (JsonCodec)
1111
import Data.Codec.Argonaut as C
1212
import Data.Codec.Argonaut.Record as CR
13-
import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlat, sumFlatWith, sumWith)
13+
import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlatWith, sumWith)
1414
import Data.Generic.Rep (class Generic)
1515
import Data.Show.Generic (genericShow)
1616
import Data.String as Str
@@ -22,7 +22,6 @@ import Test.QuickCheck (class Arbitrary, arbitrary, quickCheck)
2222
import Test.QuickCheck.Arbitrary (genericArbitrary)
2323
import Test.Util (propCodec)
2424
import Type.Prelude (Proxy(..))
25-
import Type.Proxy (Proxy)
2625

2726
--------------------------------------------------------------------------------
2827

@@ -146,6 +145,7 @@ main = do
146145
, valuesKey: "customValues"
147146
, omitEmptyArguments: false
148147
, unwrapSingleArguments: false
148+
, mapTag: identity
149149
}
150150

151151
check
@@ -192,6 +192,7 @@ main = do
192192
, valuesKey: "values"
193193
, omitEmptyArguments: true
194194
, unwrapSingleArguments: false
195+
, mapTag: identity
195196
}
196197

197198
check
@@ -237,6 +238,7 @@ main = do
237238
, valuesKey: "values"
238239
, omitEmptyArguments: false
239240
, unwrapSingleArguments: true
241+
, mapTag: identity
240242
}
241243

242244
check
@@ -273,13 +275,59 @@ main = do
273275
, "}"
274276
]
275277

278+
log " - Option: mapTag"
279+
do
280+
let
281+
opts = EncodeTagged
282+
{ tagKey: "tag"
283+
, valuesKey: "values"
284+
, omitEmptyArguments: false
285+
, unwrapSingleArguments: true
286+
, mapTag: Str.toLower
287+
}
288+
289+
check
290+
(codecSample opts)
291+
Foo
292+
$ Str.joinWith "\n"
293+
[ "{"
294+
, " \"tag\": \"foo\","
295+
, " \"values\": []"
296+
, "}"
297+
]
298+
299+
check
300+
(codecSample opts)
301+
(Bar 42)
302+
$ Str.joinWith "\n"
303+
[ "{"
304+
, " \"tag\": \"bar\","
305+
, " \"values\": 42"
306+
, "}"
307+
]
308+
309+
check
310+
(codecSample opts)
311+
(Baz true "hello" 42)
312+
$ Str.joinWith "\n"
313+
[ "{"
314+
, " \"tag\": \"baz\","
315+
, " \"values\": ["
316+
, " true,"
317+
, " \"hello\","
318+
, " 42"
319+
, " ]"
320+
, "}"
321+
]
322+
276323
log " - EncodeNested"
277324
do
278325
log " - default"
279326
do
280327
let
281328
opts = EncodeNested
282329
{ unwrapSingleArguments: false
330+
, mapTag: identity
283331
}
284332

285333
check
@@ -320,6 +368,7 @@ main = do
320368
let
321369
opts = EncodeNested
322370
{ unwrapSingleArguments: true
371+
, mapTag: identity
323372
}
324373

325374
check
@@ -353,6 +402,45 @@ main = do
353402
, "}"
354403
]
355404

405+
log " - Option: mapTag"
406+
do
407+
let
408+
opts = EncodeNested
409+
{ unwrapSingleArguments: true
410+
, mapTag: Str.toLower
411+
}
412+
413+
check
414+
(codecSample opts)
415+
Foo
416+
$ Str.joinWith "\n"
417+
[ "{"
418+
, " \"foo\": []"
419+
, "}"
420+
]
421+
422+
check
423+
(codecSample opts)
424+
(Bar 42)
425+
$ Str.joinWith "\n"
426+
[ "{"
427+
, " \"bar\": 42"
428+
, "}"
429+
]
430+
431+
check
432+
(codecSample opts)
433+
(Baz true "hello" 42)
434+
$ Str.joinWith "\n"
435+
[ "{"
436+
, " \"baz\": ["
437+
, " true,"
438+
, " \"hello\","
439+
, " 42"
440+
, " ]"
441+
, "}"
442+
]
443+
356444
quickCheck (propCodec arbitrary (codecSample defaultEncoding))
357445

358446
log "Check sum flat"

0 commit comments

Comments
 (0)