Skip to content

Commit 9dadffd

Browse files
m-bockm-bock
committed
Implement encodings
1 parent 019b2f7 commit 9dadffd

File tree

2 files changed

+237
-27
lines changed

2 files changed

+237
-27
lines changed

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

Lines changed: 88 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,6 @@ import Foreign.Object.ST as FOST
4040
import Prim.Row as Row
4141
import Record as Record
4242
import Type.Proxy (Proxy(..))
43-
import Unsafe.Coerce (unsafeCoerce)
4443

4544
-- | A helper for defining JSON codecs for "enum" sum types, where every
4645
-- | constructor is nullary, and the type will be encoded as a string.
@@ -109,6 +108,8 @@ data Encoding
109108
, omitEmptyArguments ∷ Boolean
110109
, unwrapSingleArguments ∷ Boolean
111110
}
111+
| EncodeUntagged
112+
{ unwrapSingleArguments ∷ Boolean }
112113

113114
defaultEncoding ∷ Encoding
114115
defaultEncoding = EncodeTagValue
@@ -149,7 +150,7 @@ instance gCasesConstructorNoArgs ∷
149150
let
150151
name = reflectSymbol @name Proxy ∷ String
151152
in
152-
encodeCase encoding name []
153+
encodeSumCase encoding name []
153154

154155
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name NoArguments)
155156
gCasesDecode encoding _ json = do
@@ -169,7 +170,7 @@ else instance gCasesConstructorSingleArg ∷
169170
codec = Record.get (Proxy @name) r ∷ JsonCodec a
170171
name = reflectSymbol @name Proxy ∷ String
171172
in
172-
encodeCase encoding name [ CA.encode codec x ]
173+
encodeSumCase encoding name [ CA.encode codec x ]
173174

174175
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name (Argument a))
175176
gCasesDecode encoding r json = do
@@ -193,7 +194,7 @@ else instance gCasesConstructorManyArgs ∷
193194
name = reflectSymbol @name Proxy ∷ String
194195
jsons = gFieldsEncode encoding codecs rep ∷ Array Json
195196
in
196-
encodeCase encoding name jsons
197+
encodeSumCase encoding name jsons
197198

198199
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name args)
199200
gCasesDecode encoding r json = do
@@ -292,9 +293,53 @@ checkTag tagKey obj expectedTag = do
292293
$ throwError
293294
$ TypeMismatch ("Expecting tag `" <> expectedTag <> "`, got `" <> tag <> "`")
294295

296+
parseNoFields ∷ Encoding → Json → String → Either JsonDecodeError Unit
297+
parseNoFields encoding json expectedTag =
298+
case encoding of
299+
EncodeCtorAsTag {} → do
300+
obj ← CA.decode jobject json
301+
val ←
302+
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
303+
) ∷ _ Json
304+
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
305+
when (fields /= [])
306+
$ throwError
307+
$ TypeMismatch "Expecting an empty array"
308+
309+
EncodeTagValue { tagKey, valuesKey, omitEmptyArguments } → do
310+
obj ← CA.decode jobject json
311+
checkTag tagKey obj expectedTag
312+
when (not omitEmptyArguments) do
313+
val ←
314+
( Obj.lookup valuesKey obj
315+
# note (TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
316+
) ∷ _ Json
317+
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
318+
when (fields /= [])
319+
$ throwError
320+
$ TypeMismatch "Expecting an empty array"
321+
322+
EncodeUntagged {} → do
323+
fields ← CA.decode CA.jarray json ∷ _ (Array Json)
324+
when (fields /= [])
325+
$ throwError
326+
$ TypeMismatch "Expecting an empty array"
327+
295328
parseSingleField ∷ Encoding → Json → String → Either JsonDecodeError Json
296329
parseSingleField encoding json expectedTag = case encoding of
297-
EncodeCtorAsTag { unwrapSingleArguments } → unsafeCoerce "todo"
330+
EncodeCtorAsTag { unwrapSingleArguments } → do
331+
obj ← CA.decode jobject json
332+
val ←
333+
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
334+
) ∷ _ Json
335+
if unwrapSingleArguments then
336+
pure val
337+
else do
338+
fields ← CA.decode CA.jarray val
339+
case fields of
340+
[ head ] → pure head
341+
_ → throwError $ TypeMismatch "Expecting exactly one element"
342+
298343
EncodeTagValue { tagKey, valuesKey, unwrapSingleArguments } → do
299344
obj ← CA.decode jobject json
300345
checkTag tagKey obj expectedTag
@@ -310,28 +355,25 @@ parseSingleField encoding json expectedTag = case encoding of
310355
[ head ] → pure head
311356
_ → throwError $ TypeMismatch "Expecting exactly one element"
312357

313-
parseNoFields ∷ Encoding → Json → String → Either JsonDecodeError Unit
314-
parseNoFields encoding json expectedTag =
315-
case encoding of
316-
EncodeCtorAsTag { unwrapSingleArguments } → unsafeCoerce "todo"
317-
EncodeTagValue { tagKey, valuesKey, omitEmptyArguments } →
318-
do
319-
obj ← CA.decode jobject json
320-
checkTag tagKey obj expectedTag
321-
when (not omitEmptyArguments) do
322-
val ←
323-
( Obj.lookup valuesKey obj
324-
# note (TypeMismatch ("Expecting a value property `" <> valuesKey <> "`"))
325-
) ∷ _ Json
326-
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
327-
when (fields /= [])
328-
$ throwError
329-
$ TypeMismatch "Expecting an empty array"
358+
EncodeUntagged { unwrapSingleArguments } → do
359+
if unwrapSingleArguments then
360+
pure json
361+
else do
362+
fields ← CA.decode CA.jarray json
363+
case fields of
364+
[ head ] → pure head
365+
_ → throwError $ TypeMismatch "Expecting exactly one element"
330366

331367
parseManyFields ∷ Encoding → Json → String → Either JsonDecodeError (Array Json)
332368
parseManyFields encoding json expectedTag =
333369
case encoding of
334-
EncodeCtorAsTag { unwrapSingleArguments } → unsafeCoerce "todo"
370+
EncodeCtorAsTag {} → do
371+
obj ← CA.decode jobject json
372+
val ←
373+
( Obj.lookup expectedTag obj # note (TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
374+
) ∷ _ Json
375+
CA.decode CA.jarray val
376+
335377
EncodeTagValue { tagKey, valuesKey } → do
336378
obj ← CA.decode jobject json
337379
checkTag tagKey obj expectedTag
@@ -341,10 +383,23 @@ parseManyFields encoding json expectedTag =
341383
) ∷ _ Json
342384
CA.decode CA.jarray val
343385

344-
encodeCase ∷ Encoding → String → Array Json → Json
345-
encodeCase encoding tag jsons =
386+
EncodeUntagged {} →
387+
CA.decode CA.jarray json
388+
389+
encodeSumCase ∷ Encoding → String → Array Json → Json
390+
encodeSumCase encoding tag jsons =
346391
case encoding of
347-
EncodeCtorAsTag { unwrapSingleArguments } → unsafeCoerce "todo"
392+
EncodeCtorAsTag { unwrapSingleArguments } →
393+
let
394+
val = case jsons of
395+
[] → CA.encode CA.jarray []
396+
[ json ] | unwrapSingleArguments → json
397+
manyJsons → CA.encode CA.jarray manyJsons
398+
in
399+
encode jobject $ Obj.fromFoldable
400+
[ tag /\ val
401+
]
402+
348403
EncodeTagValue { tagKey, valuesKey, unwrapSingleArguments, omitEmptyArguments } →
349404
let
350405
tagEntry =
@@ -356,4 +411,10 @@ encodeCase encoding tag jsons =
356411
manyJsons → Just (valuesKey /\ CA.encode CA.jarray manyJsons)
357412
in
358413
encode jobject $ Obj.fromFoldable $ catMaybes
359-
[ tagEntry, valEntry ]
414+
[ tagEntry, valEntry ]
415+
416+
EncodeUntagged { unwrapSingleArguments } →
417+
case jsons of
418+
[] → CA.encode CA.jarray []
419+
[ json ] | unwrapSingleArguments → json
420+
manyJsons → CA.encode CA.jarray manyJsons

‎test/Test/Sum.purs‎

Lines changed: 149 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,7 @@ main = do
107107
, omitEmptyArguments: false
108108
, unwrapSingleArguments: false
109109
}
110+
110111
check
111112
(codecSample opts)
112113
Foo
@@ -152,6 +153,7 @@ main = do
152153
, omitEmptyArguments: true
153154
, unwrapSingleArguments: false
154155
}
156+
155157
check
156158
(codecSample opts)
157159
Foo
@@ -196,6 +198,7 @@ main = do
196198
, omitEmptyArguments: false
197199
, unwrapSingleArguments: true
198200
}
201+
199202
check
200203
(codecSample opts)
201204
Foo
@@ -230,5 +233,151 @@ main = do
230233
, "}"
231234
]
232235

236+
log " - EncodeCtorAsTag"
237+
do
238+
log " - default"
239+
do
240+
let
241+
opts = EncodeCtorAsTag
242+
{ unwrapSingleArguments: false
243+
}
244+
245+
check
246+
(codecSample opts)
247+
Foo
248+
$ Str.joinWith "\n"
249+
[ "{"
250+
, " \"Foo\": []"
251+
, "}"
252+
]
253+
254+
check
255+
(codecSample opts)
256+
(Bar 42)
257+
$ Str.joinWith "\n"
258+
[ "{"
259+
, " \"Bar\": ["
260+
, " 42"
261+
, " ]"
262+
, "}"
263+
]
264+
265+
check
266+
(codecSample opts)
267+
(Baz true "hello" 42)
268+
$ Str.joinWith "\n"
269+
[ "{"
270+
, " \"Baz\": ["
271+
, " true,"
272+
, " \"hello\","
273+
, " 42"
274+
, " ]"
275+
, "}"
276+
]
277+
278+
log " - Option: Unwrap single arguments"
279+
do
280+
let
281+
opts = EncodeCtorAsTag
282+
{ unwrapSingleArguments: true
283+
}
284+
285+
check
286+
(codecSample opts)
287+
Foo
288+
$ Str.joinWith "\n"
289+
[ "{"
290+
, " \"Foo\": []"
291+
, "}"
292+
]
293+
294+
check
295+
(codecSample opts)
296+
(Bar 42)
297+
$ Str.joinWith "\n"
298+
[ "{"
299+
, " \"Bar\": 42"
300+
, "}"
301+
]
302+
303+
check
304+
(codecSample opts)
305+
(Baz true "hello" 42)
306+
$ Str.joinWith "\n"
307+
[ "{"
308+
, " \"Baz\": ["
309+
, " true,"
310+
, " \"hello\","
311+
, " 42"
312+
, " ]"
313+
, "}"
314+
]
315+
316+
log " - EncodeUntagged"
317+
do
318+
log " - default"
319+
do
320+
let
321+
opts = EncodeUntagged
322+
{ unwrapSingleArguments: false
323+
}
324+
check
325+
(codecSample opts)
326+
Foo
327+
$ Str.joinWith "\n"
328+
[ "[]"
329+
]
330+
331+
check
332+
(codecSample opts)
333+
(Bar 42)
334+
$ Str.joinWith "\n"
335+
[ "["
336+
, " 42"
337+
, "]"
338+
]
339+
340+
check
341+
(codecSample opts)
342+
(Baz true "hello" 42)
343+
$ Str.joinWith "\n"
344+
[ "["
345+
, " true,"
346+
, " \"hello\","
347+
, " 42"
348+
, "]"
349+
]
350+
351+
log " - Option: Unwrap single arguments"
352+
do
353+
let
354+
opts = EncodeUntagged
355+
{ unwrapSingleArguments: true
356+
}
357+
check
358+
(codecSample opts)
359+
Foo
360+
$ Str.joinWith "\n"
361+
[ "[]"
362+
]
363+
364+
check
365+
(codecSample opts)
366+
(Bar 42)
367+
$ Str.joinWith "\n"
368+
[ "42"
369+
]
370+
371+
check
372+
(codecSample opts)
373+
(Baz true "hello" 42)
374+
$ Str.joinWith "\n"
375+
[ "["
376+
, " true,"
377+
, " \"hello\","
378+
, " 42"
379+
, "]"
380+
]
381+
233382
quickCheck (propCodec genMySum (codecSample defaultEncoding))
234383

0 commit comments

Comments
 (0)