Skip to content

Commit 78b0171

Browse files
garybgaryb
authored
Merge pull request #69 from m-bock/error-improvements
Error improvements
2 parents b192e34 + b2b6559 commit 78b0171

File tree

2 files changed

+160
-72
lines changed

2 files changed

+160
-72
lines changed

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

Lines changed: 84 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module Data.Codec.Argonaut.Sum
22
( Encoding(..)
33
, FlatEncoding
4+
, Err
45
, class GCases
56
, class GFields
67
, class GFlatCases
@@ -22,7 +23,6 @@ module Data.Codec.Argonaut.Sum
2223

2324
import Prelude
2425

25-
import Control.Alt ((<|>))
2626
import Data.Argonaut.Core (Json)
2727
import Data.Argonaut.Core (Json, fromString) as J
2828
import Data.Array (catMaybes)
@@ -138,17 +138,26 @@ sumWith ∷ ∀ r rep a. GCases r rep ⇒ Generic a rep ⇒ Encoding → String
138138
sumWith encoding name r =
139139
dimap from to $ codec' decode encode
140140
where
141-
decode = gCasesDecode encoding r >>> (lmap $ Named name)
141+
decode = gCasesDecode encoding r >>> lmap (finalizeError name)
142142
encode = gCasesEncode encoding r
143143

144+
finalizeError ∷ String → Err → JsonDecodeError
145+
finalizeError name err =
146+
Named name $
147+
case err of
148+
UnmatchedCase → TypeMismatch "No case matched"
149+
JErr jerr → jerr
150+
151+
data Err = UnmatchedCase | JErr JsonDecodeError
152+
144153
--------------------------------------------------------------------------------
145154

146155
class GCases ∷ Row Type → Type → Constraint
147156
class
148157
GCases r rep
149158
where
150159
gCasesEncode ∷ Encoding → Record r → rep → Json
151-
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError rep
160+
gCasesDecode ∷ Encoding → Record r → Json → Either Err rep
152161

153162
instance gCasesConstructorNoArgs ∷
154163
( Row.Cons name Unit () r
@@ -162,7 +171,7 @@ instance gCasesConstructorNoArgs ∷
162171
in
163172
encodeSumCase encoding name []
164173

165-
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name NoArguments)
174+
gCasesDecode ∷ Encoding → Record r → Json → Either Err (Constructor name NoArguments)
166175
gCasesDecode encoding _ json = do
167176
let name = reflectSymbol @name Proxy ∷ String
168177

@@ -182,13 +191,13 @@ else instance gCasesConstructorSingleArg ∷
182191
in
183192
encodeSumCase encoding name [ CA.encode codec x ]
184193

185-
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name (Argument a))
194+
gCasesDecode ∷ Encoding → Record r → Json → Either Err (Constructor name (Argument a))
186195
gCasesDecode encoding r json = do
187196
let name = reflectSymbol @name Proxy ∷ String
188197

189198
field ← parseSingleField encoding json name ∷ _ Json
190199
let codec = Record.get (Proxy @name) r ∷ JsonCodec a
191-
result ← CA.decode codec field ∷ _ a
200+
result ← lmap JErr $ CA.decode codec field ∷ _ a
192201
pure $ Constructor (Argument result)
193202

194203
else instance gCasesConstructorManyArgs ∷
@@ -206,13 +215,13 @@ else instance gCasesConstructorManyArgs ∷
206215
in
207216
encodeSumCase encoding name jsons
208217

209-
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name args)
218+
gCasesDecode ∷ Encoding → Record r → Json → Either Err (Constructor name args)
210219
gCasesDecode encoding r json = do
211220
let name = reflectSymbol @name Proxy ∷ String
212221

213222
jsons ← parseManyFields encoding json name ∷ _ (Array Json)
214223
let codecs = Record.get (Proxy @name) r ∷ codecs
215-
result ← gFieldsDecode encoding codecs jsons ∷ _ args
224+
result ← lmap JErr $ gFieldsDecode encoding codecs jsons ∷ _ args
216225
pure $ Constructor result
217226

218227
instance gCasesSum ∷
@@ -236,16 +245,19 @@ instance gCasesSum ∷
236245
Inl lhs → gCasesEncode encoding r1 lhs
237246
Inr rhs → gCasesEncode encoding r2 rhs
238247

239-
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
248+
gCasesDecode ∷ Encoding → Record r → Json → Either Err (Sum (Constructor name lhs) rhs)
240249
gCasesDecode encoding r tagged = do
241250
let
242251
codec = Record.get (Proxy @name) r ∷ codec
243252
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
244253
r2 = Record.delete (Proxy @name) r ∷ Record r2
245254
let
246-
lhs = gCasesDecode encoding r1 tagged ∷ _ (Constructor name lhs)
247-
rhs = gCasesDecode encoding r2 tagged ∷ _ rhs
248-
(Inl <$> lhs) <|> (Inr <$> rhs)
255+
lhs _ = gCasesDecode encoding r1 tagged ∷ _ (Constructor name lhs)
256+
rhs _ = gCasesDecode encoding r2 tagged ∷ _ rhs
257+
case lhs unit of
258+
Left UnmatchedCase → Inr <$> (rhs unit)
259+
Left (JErr err) → Left (JErr err)
260+
Right val → Right (Inl val)
249261

250262
--------------------------------------------------------------------------------
251263

@@ -292,97 +304,99 @@ instance gFieldsProduct ∷
292304

293305
--------------------------------------------------------------------------------
294306

295-
checkTag ∷ String → Object Json → String → Either JsonDecodeError Unit
307+
checkTag ∷ String → Object Json → String → Either Err Unit
296308
checkTag tagKey obj expectedTag = do
297309
val ←
298310
( Obj.lookup tagKey obj
299311
# note (TypeMismatch ("Expecting a tag property `" <> tagKey <> "`"))
312+
# lmap JErr
300313
) ∷ _ Json
301-
tag ← CA.decode CA.string val ∷ _ String
302-
unless (tag == expectedTag)
303-
$ Left
304-
$ TypeMismatch ("Expecting tag `" <> expectedTag <> "`, got `" <> tag <> "`")
314+
tag ← CA.decode CA.string val # lmap JErr ∷ _ String
315+
when (tag /= expectedTag)
316+
(Left UnmatchedCase)
305317

306-
parseNoFields ∷ Encoding → Json → String → Either JsonDecodeError Unit
318+
parseNoFields ∷ Encoding → Json → String → Either Err Unit
307319
parseNoFields encoding json expectedTagRaw =
308320
case encoding of
309321
EncodeNested { mapTag } → do
310322
let expectedTag = mapTag expectedTagRaw ∷ String
311-
obj ← CA.decode jobject json
323+
obj ← lmap JErr $ CA.decode jobject json
312324
val ←
313-
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
325+
( Obj.lookup expectedTag obj # note UnmatchedCase
314326
) ∷ _ Json
315-
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
327+
fields ← lmap JErr $ CA.decode CA.jarray val ∷ _ (Array Json)
316328
when (fields /= [])
317329
$ Left
318-
$ TypeMismatch "Expecting an empty array"
330+
(JErr $ TypeMismatch "Expecting an empty array")
331+
pure unit
319332

320333
EncodeTagged { tagKey, valuesKey, omitEmptyArguments, mapTag } → do
321334
let expectedTag = mapTag expectedTagRaw ∷ String
322-
obj ← CA.decode jobject json
335+
obj ← lmap JErr $ CA.decode jobject json
323336
checkTag tagKey obj expectedTag
324337
when (not omitEmptyArguments) do
325338
val ←
326339
( Obj.lookup valuesKey obj
327-
# note (TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
340+
# note (JErr $ TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
328341
) ∷ _ Json
329-
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
342+
fields ← lmap JErr $ CA.decode CA.jarray val ∷ _ (Array Json)
330343
when (fields /= [])
331344
$ Left
332-
$ TypeMismatch "Expecting an empty array"
345+
(JErr $ TypeMismatch "Expecting an empty array")
346+
pure unit
333347

334-
parseSingleField ∷ Encoding → Json → String → Either JsonDecodeError Json
348+
parseSingleField ∷ Encoding → Json → String → Either Err Json
335349
parseSingleField encoding json expectedTagRaw = case encoding of
336350
EncodeNested { unwrapSingleArguments, mapTag } → do
337351
let expectedTag = mapTag expectedTagRaw ∷ String
338-
obj ← CA.decode jobject json
352+
obj ← lmap JErr $ CA.decode jobject json
339353
val ←
340-
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
354+
( Obj.lookup expectedTag obj # note UnmatchedCase
341355
) ∷ _ Json
342356
if unwrapSingleArguments then
343357
pure val
344358
else do
345-
fields ← CA.decode CA.jarray val
359+
fields ← lmap JErr $ CA.decode CA.jarray val
346360
case fields of
347361
[ head ] → pure head
348-
_ → Left $ TypeMismatch "Expecting exactly one element"
362+
_ → Left $ JErr $ TypeMismatch "Expecting exactly one element"
349363

350364
EncodeTagged { tagKey, valuesKey, unwrapSingleArguments, mapTag } → do
351365
let expectedTag = mapTag expectedTagRaw ∷ String
352-
obj ← CA.decode jobject json
366+
obj ← lmap JErr $ CA.decode jobject json
353367
checkTag tagKey obj expectedTag
354368
val ←
355369
( Obj.lookup valuesKey obj
356-
# note (TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
370+
# note (JErr $ TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
357371
) ∷ _ Json
358372
if unwrapSingleArguments then
359373
pure val
360374
else do
361-
fields ← CA.decode CA.jarray val
375+
fields ← lmap JErr $ CA.decode CA.jarray val
362376
case fields of
363377
[ head ] → pure head
364-
_ → Left $ TypeMismatch "Expecting exactly one element"
378+
_ → Left $ JErr $ TypeMismatch "Expecting exactly one element"
365379

366-
parseManyFields ∷ Encoding → Json → String → Either JsonDecodeError (Array Json)
380+
parseManyFields ∷ Encoding → Json → String → Either Err (Array Json)
367381
parseManyFields encoding json expectedTagRaw =
368382
case encoding of
369383
EncodeNested { mapTag } → do
370384
let expectedTag = mapTag expectedTagRaw ∷ String
371-
obj ← CA.decode jobject json
385+
obj ← lmap JErr $ CA.decode jobject json
372386
val ←
373-
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
387+
( Obj.lookup expectedTag obj # note UnmatchedCase
374388
) ∷ _ Json
375-
CA.decode CA.jarray val
389+
lmap JErr $ CA.decode CA.jarray val
376390

377391
EncodeTagged { tagKey, valuesKey, mapTag } → do
378392
let expectedTag = mapTag expectedTagRaw ∷ String
379-
obj ← CA.decode jobject json
393+
obj ← lmap JErr $ CA.decode jobject json
380394
checkTag tagKey obj expectedTag
381395
val ←
382396
( Obj.lookup valuesKey obj
383-
# note (TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
397+
# note (JErr $ TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
384398
) ∷ _ Json
385-
CA.decode CA.jarray val
399+
lmap JErr $ CA.decode CA.jarray val
386400

387401
encodeSumCase ∷ Encoding → String → Array Json → Json
388402
encodeSumCase encoding rawTag jsons =
@@ -431,15 +445,15 @@ sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ Fla
431445
sumFlatWith encoding name r =
432446
dimap from to $ codec' dec enc
433447
where
434-
dec = gFlatCasesDecode @tag encoding r >>> (lmap $ Named name)
448+
dec = gFlatCasesDecode @tag encoding r >>> (lmap $ finalizeError name)
435449
enc = gFlatCasesEncode @tag encoding r
436450

437451
class GFlatCases ∷ Symbol → Row Type → Type → Constraint
438452
class
439453
GFlatCases tag r rep
440454
where
441455
gFlatCasesEncode ∷ FlatEncoding tag → Record r → rep → Json
442-
gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError rep
456+
gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either Err rep
443457

444458
instance gFlatCasesConstructorNoArg ∷
445459
( Row.Cons name Unit () rc
@@ -460,23 +474,20 @@ instance gFlatCasesConstructorNoArg ∷
460474
in
461475
CA.encode codecWithTag rcWithTag
462476

463-
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
477+
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either Err (Constructor name NoArguments)
464478
gFlatCasesDecode { mapTag } _ json = do
465479
let
466480
nameRaw = reflectSymbol (Proxy @name) ∷ String
467481
name = mapTag nameRaw ∷ String
468-
propCodec = CAR.record {} ∷ JPropCodec {}
469-
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
470-
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
471-
r ← CA.decode codecWithTag json ∷ _ (Record rf)
472-
let actualTag = Record.get (Proxy @tag) r ∷ String
482+
tag = reflectSymbol (Proxy @tag) ∷ String
483+
484+
obj ← lmap JErr $ CA.decode jobject json
473485

474-
when (actualTag /= name)
475-
$ Left
476-
$ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
486+
checkTag tag obj name
477487

478488
pure (Constructor NoArguments)
479489

490+
480491
instance gFlatCasesConstructorSingleArg ∷
481492
( Row.Cons name (JPropCodec (Record rf)) () rc
482493
, Row.Lacks tag rf
@@ -497,23 +508,26 @@ instance gFlatCasesConstructorSingleArg ∷
497508
in
498509
CA.encode codecWithTag rcWithTag
499510

500-
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
511+
512+
gFlatCasesDecode ∷ FlatEncoding tag → Record rc → Json → Either Err (Constructor name (Argument (Record rf)))
501513
gFlatCasesDecode { mapTag } rc json = do
502514
let
503515
nameRaw = reflectSymbol (Proxy @name) ∷ String
504516
name = mapTag nameRaw ∷ String
517+
tag = reflectSymbol (Proxy @tag) ∷ String
518+
519+
520+
obj ← lmap JErr $ CA.decode jobject json
521+
522+
checkTag tag obj name
523+
524+
let
505525
propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
506-
propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
507-
codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
508-
r ← CA.decode codecWithTag json ∷ _ (Record rf')
526+
codec = CA.object ("case " <> name) propCodec ∷ JsonCodec (Record rf)
509527

510-
let actualTag = Record.get (Proxy @tag) r ∷ String
511-
when (actualTag /= name)
512-
$ Left
513-
$ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
528+
r ← lmap JErr $ CA.decode codec json ∷ _ (Record rf)
514529

515-
let r' = Record.delete (Proxy @tag) r ∷ Record rf
516-
pure (Constructor (Argument r'))
530+
pure (Constructor (Argument r))
517531

518532
instance gFlatCasesSum ∷
519533
( GFlatCases tag r1 (Constructor name lhs)
@@ -536,16 +550,19 @@ instance gFlatCasesSum ∷
536550
Inl lhs → gFlatCasesEncode @tag encoding r1 lhs
537551
Inr rhs → gFlatCasesEncode @tag encoding r2 rhs
538552

539-
gFlatCasesDecode ∷ FlatEncoding tag → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
553+
gFlatCasesDecode ∷ FlatEncoding tag -> Record r → Json → Either Err (Sum (Constructor name lhs) rhs)
540554
gFlatCasesDecode encoding r tagged = do
541555
let
542556
codec = Record.get (Proxy @name) r ∷ codec
543557
r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
544558
r2 = Record.delete (Proxy @name) r ∷ Record r2
545559
let
546-
lhs = gFlatCasesDecode @tag encoding r1 tagged ∷ _ (Constructor name lhs)
547-
rhs = gFlatCasesDecode @tag encoding r2 tagged ∷ _ rhs
548-
(Inl <$> lhs) <|> (Inr <$> rhs)
560+
lhs _ = gFlatCasesDecode @tag encoding r1 tagged ∷ _ (Constructor name lhs)
561+
rhs _ = gFlatCasesDecode @tag encoding r2 tagged ∷ _ rhs
562+
case lhs unit of
563+
Left UnmatchedCase → Inr <$> rhs unit
564+
Left (JErr err) → Left (JErr err)
565+
Right val → Right (Inl val)
549566

550567
--------------------------------------------------------------------------------
551568

0 commit comments

Comments
 (0)