Skip to content

Commit 2ddfb1a

Browse files
m-bockm-bock
committed
Add sumFlat
1 parent 9dab273 commit 2ddfb1a

File tree

3 files changed

+194
-14
lines changed

3 files changed

+194
-14
lines changed

‎package.json

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@
99
"pulp": "^16.0.0",
1010
"purescript": "^0.15.0",
1111
"purescript-psa": "^0.8.2",
12-
"purs-tidy": "^0.9.2",
12+
"purs-tidy": "^0.11.0",
1313
"rimraf": "^3.0.0"
1414
}
1515
}

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

Lines changed: 131 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,10 @@ module Data.Codec.Argonaut.Sum
1111
, sum
1212
, sumWith
1313
, taggedSum
14+
, sumFlat
15+
, class GFlatCases
16+
, gFlatCasesEncode
17+
, gFlatCasesDecode
1418
) where
1519

1620
import Prelude
@@ -23,8 +27,9 @@ import Data.Array as Array
2327
import Data.Bifunctor (lmap)
2428
import Data.Codec (codec', encode)
2529
import Data.Codec as Codec
26-
import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..), jobject)
30+
import Data.Codec.Argonaut (JPropCodec, JsonCodec, JsonDecodeError(..), jobject)
2731
import Data.Codec.Argonaut as CA
32+
import Data.Codec.Argonaut.Record as CAR
2833
import Data.Either (Either(..), note)
2934
import Data.Generic.Rep (class Generic, Argument(..), Constructor(..), NoArguments(..), Product(..), Sum(..), from, to)
3035
import Data.Maybe (Maybe(..), maybe)
@@ -206,8 +211,8 @@ else instance gCasesConstructorManyArgs ∷
206211
instance gCasesSum ∷
207212
( GCases r1 (Constructor name lhs)
208213
, GCases r2 rhs
209-
, Row.Cons name codecs1 () r1
210-
, Row.Cons name codecs1 r2 r
214+
, Row.Cons name codec () r1
215+
, Row.Cons name codec r2 r
211216
, Row.Union r1 r2 r
212217
, Row.Lacks name r2
213218
, IsSymbol name
@@ -216,8 +221,8 @@ instance gCasesSum ∷
216221
gCasesEncode ∷ Encoding → Record r → Sum (Constructor name lhs) rhs → Json
217222
gCasesEncode encoding r =
218223
let
219-
codecs1 = Record.get (Proxy @name) r ∷ codecs1
220-
r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
224+
codec = Record.get (Proxy @name) r ∷ codec
225+
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
221226
r2 = unsafeDelete (Proxy @name) r ∷ Record r2
222227
in
223228
case _ of
@@ -227,8 +232,8 @@ instance gCasesSum ∷
227232
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
228233
gCasesDecode encoding r tagged = do
229234
let
230-
codecs1 = Record.get (Proxy @name) r ∷ codecs1
231-
r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
235+
codec = Record.get (Proxy @name) r ∷ codec
236+
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
232237
r2 = Record.delete (Proxy @name) r ∷ Record r2
233238
let
234239
lhs = gCasesDecode encoding r1 tagged ∷ _ (Constructor name lhs)
@@ -393,7 +398,125 @@ encodeSumCase encoding tag jsons =
393398
encode jobject $ Obj.fromFoldable $ catMaybes
394399
[ tagEntry, valEntry ]
395400

401+
sumFlat ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
402+
sumFlat name r =
403+
dimap from to $ codec' dec enc
404+
where
405+
dec = gFlatCasesDecode @tag r >>> (lmap $ Named name)
406+
enc = gFlatCasesEncode @tag r
407+
408+
class GFlatCases ∷ Symbol → Row Type → Type → Constraint
409+
class
410+
GFlatCases tag r rep
411+
where
412+
gFlatCasesEncode ∷ Record r → rep → Json
413+
gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
414+
415+
instance gFlatCasesConstructorNoArg ∷
416+
( Row.Cons name Unit () rc
417+
, Row.Cons tag String () rf
418+
, IsSymbol name
419+
, IsSymbol tag
420+
) ⇒
421+
GFlatCases tag rc (Constructor name NoArguments) where
422+
gFlatCasesEncode ∷ Record rc → Constructor name NoArguments → Json
423+
gFlatCasesEncode _ (Constructor NoArguments) =
424+
let
425+
name = reflectSymbol (Proxy @name) ∷ String
426+
propCodec = CAR.record {} ∷ JPropCodec {}
427+
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
428+
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
429+
rcWithTag = Record.insert (Proxy @tag) name {} ∷ Record rf
430+
in
431+
CA.encode codecWithTag rcWithTag
432+
433+
gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
434+
gFlatCasesDecode _ json = do
435+
let
436+
name = reflectSymbol (Proxy @name) ∷ String
437+
438+
propCodec = CAR.record {} ∷ JPropCodec {}
439+
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
440+
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
441+
r ← CA.decode codecWithTag json ∷ _ (Record rf)
442+
let actualTag = Record.get (Proxy @tag) r ∷ String
443+
444+
when (actualTag /= name)
445+
$ Left
446+
$ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
447+
448+
pure (Constructor NoArguments)
449+
450+
instance gFlatCasesConstructorSingleArg ∷
451+
( Row.Cons name (JPropCodec (Record rf)) () rc
452+
, Row.Lacks tag rf
453+
, Row.Cons tag String rf rf'
454+
, IsSymbol name
455+
, IsSymbol tag
456+
) ⇒
457+
GFlatCases tag rc (Constructor name (Argument (Record rf))) where
458+
gFlatCasesEncode ∷ Record rc → Constructor name (Argument (Record rf)) → Json
459+
gFlatCasesEncode rc (Constructor (Argument rf)) =
460+
let
461+
name = reflectSymbol (Proxy @name) ∷ String
462+
propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
463+
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
464+
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
465+
rcWithTag = Record.insert (Proxy @tag) name rf ∷ Record rf'
466+
in
467+
CA.encode codecWithTag rcWithTag
468+
469+
gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
470+
gFlatCasesDecode rc json = do
471+
let
472+
name = reflectSymbol (Proxy @name) ∷ String
473+
propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
474+
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
475+
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
476+
r ← CA.decode codecWithTag json ∷ _ (Record rf')
477+
478+
let actualTag = Record.get (Proxy @tag) r ∷ String
479+
when (actualTag /= name)
480+
$ Left
481+
$ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
482+
483+
let r' = Record.delete (Proxy @tag) r ∷ Record rf
484+
pure (Constructor (Argument r'))
485+
486+
instance gFlatCasesSum ∷
487+
( GFlatCases tag r1 (Constructor name lhs)
488+
, GFlatCases tag r2 rhs
489+
, Row.Cons name codec () r1
490+
, Row.Cons name codec r2 r
491+
, Row.Union r1 r2 r
492+
, Row.Lacks name r2
493+
, IsSymbol name
494+
) ⇒
495+
GFlatCases tag r (Sum (Constructor name lhs) rhs) where
496+
gFlatCasesEncode ∷ Record r → Sum (Constructor name lhs) rhs → Json
497+
gFlatCasesEncode r =
498+
let
499+
codec = Record.get (Proxy @name) r ∷ codec
500+
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
501+
r2 = unsafeDelete (Proxy @name) r ∷ Record r2
502+
in
503+
case _ of
504+
Inl lhs → gFlatCasesEncode @tag r1 lhs
505+
Inr rhs → gFlatCasesEncode @tag r2 rhs
506+
507+
gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
508+
gFlatCasesDecode r tagged = do
509+
let
510+
codec = Record.get (Proxy @name) r ∷ codec
511+
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
512+
r2 = Record.delete (Proxy @name) r ∷ Record r2
513+
let
514+
lhs = gFlatCasesDecode @tag r1 tagged ∷ _ (Constructor name lhs)
515+
rhs = gFlatCasesDecode @tag r2 tagged ∷ _ rhs
516+
(Inl <$> lhs) <|> (Inr <$> rhs)
517+
396518
-- | Same as `Record.delete` but deleting only happens at the type level
397519
-- | and the value is left untouched.
398520
unsafeDelete ∷ ∀ r1 r2 l a. IsSymbol l ⇒ Row.Lacks l r1 ⇒ Row.Cons l a r1 r2 ⇒ Proxy l → Record r2 → Record r1
399-
unsafeDelete _ r = unsafeCoerce r
521+
unsafeDelete _ r = unsafeCoerce r
522+

‎test/Test/Sum.purs

Lines changed: 62 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -9,19 +9,22 @@ import Data.Bifunctor (lmap)
99
import Data.Codec (decode, encode)
1010
import Data.Codec.Argonaut (JsonCodec)
1111
import Data.Codec.Argonaut as C
12-
import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumWith)
12+
import Data.Codec.Argonaut.Record as CR
13+
import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlat, sumWith)
1314
import Data.Generic.Rep (class Generic)
1415
import Data.Show.Generic (genericShow)
1516
import Data.String as Str
1617
import Data.Tuple.Nested ((/\))
1718
import Effect (Effect)
1819
import Effect.Console (log)
1920
import Effect.Exception (error, throw)
20-
import Test.QuickCheck (quickCheck)
21+
import Test.QuickCheck (class Arbitrary, arbitrary, quickCheck)
2122
import Test.QuickCheck.Arbitrary (genericArbitrary)
2223
import Test.QuickCheck.Gen (Gen)
2324
import Test.Util (propCodec)
2425

26+
--------------------------------------------------------------------------------
27+
2528
data Sample
2629
= Foo
2730
| Bar Int
@@ -30,8 +33,8 @@ data Sample
3033
derive instance Generic Sample _
3134
derive instance Eq Sample
3235

33-
genMySum ∷ Gen Sample
34-
genMySum = genericArbitrary
36+
instance Arbitrary Sample where
37+
arbitrary = genericArbitrary
3538

3639
instance Show Sample where
3740
show = genericShow
@@ -43,6 +46,31 @@ codecSample encoding = sumWith encoding "Sample"
4346
, "Baz": C.boolean /\ C.string /\ C.int
4447
}
4548

49+
--------------------------------------------------------------------------------
50+
51+
data SampleFlat
52+
= FlatFoo
53+
| FlatBar { errors ∷ Int }
54+
| FlatBaz { active ∷ Boolean, name ∷ String, count ∷ Int }
55+
56+
derive instance Generic SampleFlat _
57+
derive instance Eq SampleFlat
58+
59+
instance Arbitrary SampleFlat where
60+
arbitrary = genericArbitrary
61+
62+
instance Show SampleFlat where
63+
show = genericShow
64+
65+
codecSampleFlat ∷ JsonCodec SampleFlat
66+
codecSampleFlat = sumFlat @"tag" "Sample"
67+
{ "FlatFoo": unit
68+
, "FlatBar": CR.record { errors: C.int }
69+
, "FlatBaz": CR.record { active: C.boolean, name: C.string, count: C.int }
70+
}
71+
72+
--------------------------------------------------------------------------------
73+
4674
check ∷ ∀ a. Show a ⇒ Eq a ⇒ JsonCodec a → a → String → Effect Unit
4775
check codec val expectEncoded = do
4876
let encodedStr = stringifyWithIndent 2 $ encode codec val
@@ -313,5 +341,34 @@ main = do
313341
, "}"
314342
]
315343

316-
quickCheck (propCodec genMySum (codecSample defaultEncoding))
344+
quickCheck (propCodec arbitrary (codecSample defaultEncoding))
345+
346+
log "Check sum flat"
347+
do
348+
check codecSampleFlat FlatFoo
349+
$ Str.joinWith "\n"
350+
[ "{"
351+
, " \"tag\": \"FlatFoo\""
352+
, "}"
353+
]
354+
355+
check codecSampleFlat (FlatBar { errors: 42 })
356+
$ Str.joinWith "\n"
357+
[ "{"
358+
, " \"tag\": \"FlatBar\","
359+
, " \"errors\": 42"
360+
, "}"
361+
]
362+
363+
check codecSampleFlat (FlatBaz { active: true, name: "hello", count: 42 })
364+
$ Str.joinWith "\n"
365+
[ "{"
366+
, " \"tag\": \"FlatBaz\","
367+
, " \"active\": true,"
368+
, " \"count\": 42,"
369+
, " \"name\": \"hello\""
370+
, "}"
371+
]
372+
373+
quickCheck (propCodec arbitrary codecSampleFlat)
317374

0 commit comments

Comments
 (0)