Skip to content

Commit ea7d3bf

Browse files
m-bockm-bock
committed
Cleanup
1 parent db11d77 commit ea7d3bf

File tree

3 files changed

+187
-177
lines changed

3 files changed

+187
-177
lines changed

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

Lines changed: 124 additions & 121 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,16 @@
11
module Data.Codec.Argonaut.Sum
22
( Encoding
3-
, class GProduct
4-
, class GSum
3+
, class GFields
4+
, class GCases
55
, defaultEncoding
66
, enumSum
7-
, gSumDecode
8-
, gSumEncode
7+
, gCasesDecode
8+
, gCasesEncode
99
, sum
1010
, sumWith
1111
, taggedSum
12-
, gProductDecode
13-
, gProductEncode
12+
, gFieldsDecode
13+
, gFieldsEncode
1414
) where
1515

1616
import Prelude
@@ -116,180 +116,178 @@ defaultEncoding =
116116

117117
--------------------------------------------------------------------------------
118118

119-
sum ∷ ∀ r rep a. Generic a rep ⇒ GSum r rep ⇒ String → Record r → JsonCodec a
119+
sum ∷ ∀ r rep a. Generic a rep ⇒ GCases r rep ⇒ String → Record r → JsonCodec a
120120
sum = sumWith defaultEncoding
121121

122-
sumWith ∷ ∀ r rep a. GSum r rep ⇒ Generic a rep ⇒ Encoding → String → Record r → JsonCodec a
122+
sumWith ∷ ∀ r rep a. GCases r rep ⇒ Generic a rep ⇒ Encoding → String → Record r → JsonCodec a
123123
sumWith encoding name r =
124124
dimap from to $ codec' decode encode
125125
where
126-
decode = gSumDecode encoding r >>> (lmap $ Named name)
127-
encode = gSumEncode encoding r
126+
decode = gCasesDecode encoding r >>> (lmap $ Named name)
127+
encode = gCasesEncode encoding r
128128

129129
--------------------------------------------------------------------------------
130130

131-
class GSum ∷ Row Type → Type → Constraint
131+
class GCases ∷ Row Type → Type → Constraint
132132
class
133-
GSum r rep
133+
GCases r rep
134134
where
135-
gSumEncode ∷ Encoding → Record r → rep → Json
136-
gSumDecode ∷ Encoding → Record r → Json → Either JsonDecodeError rep
135+
gCasesEncode ∷ Encoding → Record r → rep → Json
136+
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError rep
137137

138-
instance gSumConstructorNoArgs ∷
138+
instance gCasesConstructorNoArgs ∷
139139
( Row.Cons name Unit () r
140140
, IsSymbol name
141141
) ⇒
142-
GSum r (Constructor name NoArguments) where
143-
gSumEncode ∷ Encoding → Record r → Constructor name NoArguments → Json
144-
gSumEncode encoding _ _ =
145-
encodeTagged encoding (reflectSymbol (Proxy ∷ Proxy name))
146-
( if encoding.omitEmptyArguments then
147-
Nothing
148-
else
149-
Just $ CA.encode CA.jarray []
150-
)
151-
152-
gSumDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name NoArguments)
153-
gSumDecode encoding _ json = do
154-
obj ← CA.decode jobject json ∷ _ (Object Json)
142+
GCases r (Constructor name NoArguments) where
143+
gCasesEncode ∷ Encoding → Record r → Constructor name NoArguments → Json
144+
gCasesEncode encoding _ _ =
145+
let
146+
name = reflectSymbol @name Proxy ∷ String
147+
value =
148+
( if encoding.omitEmptyArguments then Nothing
149+
else Just $ CA.encode CA.jarray []
150+
) ∷ Maybe Json
151+
in
152+
encodeTagged encoding name value
155153

156-
checkTag encoding obj (reflectSymbol (Proxy ∷ Proxy name))
154+
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name NoArguments)
155+
gCasesDecode encoding _ json = do
156+
obj ← CA.decode jobject json ∷ _ (Object Json)
157+
let name = reflectSymbol @name Proxy ∷ String
157158

159+
checkTag encoding obj name
158160
parseNoFields encoding obj
159-
160161
pure $ Constructor NoArguments
161162

162-
else instance gSumConstructorSingleArg ∷
163+
else instance gCasesConstructorSingleArg ∷
163164
( Row.Cons name (JsonCodec a) () r
164165
, IsSymbol name
165166
) ⇒
166-
GSum r (Constructor name (Argument a)) where
167-
gSumEncode ∷ Encoding → Record r → Constructor name (Argument a) → Json
168-
gSumEncode encoding r (Constructor (Argument x)) =
167+
GCases r (Constructor name (Argument a)) where
168+
gCasesEncode ∷ Encoding → Record r → Constructor name (Argument a) → Json
169+
gCasesEncode encoding r (Constructor (Argument x)) =
169170
let
170-
codec = Record.get (Proxy ∷ Proxy name) r ∷ JsonCodec a
171+
codec = Record.get (Proxy @name) r ∷ JsonCodec a
172+
name = reflectSymbol @name Proxy ∷ String
173+
value =
174+
( if encoding.unwrapSingleArguments then CA.encode codec x
175+
else CA.encode CA.jarray [ CA.encode codec x ]
176+
) ∷ Json
171177
in
172-
encodeTagged encoding (reflectSymbol (Proxy ∷ Proxy name))
173-
( Just $
174-
if encoding.unwrapSingleArguments then
175-
CA.encode codec x
176-
else
177-
CA.encode CA.jarray [ CA.encode codec x ]
178-
)
179-
180-
gSumDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name (Argument a))
181-
gSumDecode encoding r json = do
178+
encodeTagged encoding name (Just value)
179+
180+
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name (Argument a))
181+
gCasesDecode encoding r json = do
182182
obj ← CA.decode jobject json ∷ _ (Object Json)
183-
checkTag encoding obj (reflectSymbol (Proxy ∷ Proxy name))
183+
let name = reflectSymbol @name Proxy ∷ String
184+
checkTag encoding obj name
184185

185186
field ← parseSingleField encoding obj ∷ _ Json
186-
187-
let codec = Record.get (Proxy ∷ Proxy name) r ∷ JsonCodec a
188-
187+
let codec = Record.get (Proxy @name) r ∷ JsonCodec a
189188
result ← CA.decode codec field ∷ _ a
190-
191189
pure $ Constructor (Argument result)
192190

193-
else instance gSumConstructorManyArgs ∷
191+
else instance gCasesConstructorManyArgs ∷
194192
( Row.Cons name codecs () r
195-
, GProduct codecs args
193+
, GFields codecs args
196194
, IsSymbol name
197195
) ⇒
198-
GSum r (Constructor name args) where
199-
gSumEncode ∷ Encoding → Record r → Constructor name args → Json
200-
gSumEncode encoding r (Constructor rep) =
196+
GCases r (Constructor name args) where
197+
gCasesEncode ∷ Encoding → Record r → Constructor name args → Json
198+
gCasesEncode encoding r (Constructor rep) =
201199
let
202-
codecs = Record.get (Proxy ∷ Proxy name) r ∷ codecs
203-
204-
jsons = gProductEncode encoding codecs rep ∷ Array Json
200+
codecs = Record.get (Proxy @name) r ∷ codecs
201+
name = reflectSymbol @name Proxy ∷ String
202+
jsons = gFieldsEncode encoding codecs rep ∷ Array Json
203+
value = CA.encode CA.jarray jsons ∷ Json
205204
in
206-
encodeTagged encoding (reflectSymbol (Proxy ∷ Proxy name))
207-
(Just $ CA.encode CA.jarray jsons)
205+
encodeTagged encoding name (Just value)
208206

209-
gSumDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name args)
210-
gSumDecode encoding r json = do
207+
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Constructor name args)
208+
gCasesDecode encoding r json = do
211209
obj ← CA.decode jobject json ∷ _ (Object Json)
212-
checkTag encoding obj (reflectSymbol (Proxy ∷ Proxy name))
210+
let name = reflectSymbol @name Proxy ∷ String
211+
checkTag encoding obj name
213212

214213
jsons ← parseManyFields encoding obj ∷ _ (Array Json)
215-
216-
let codecs = Record.get (Proxy ∷ Proxy name) r ∷ codecs
217-
218-
result ← gProductDecode encoding codecs jsons ∷ _ args
219-
214+
let codecs = Record.get (Proxy @name) r ∷ codecs
215+
result ← gFieldsDecode encoding codecs jsons ∷ _ args
220216
pure $ Constructor result
221217

222-
instance gSumSum ∷
223-
( GSum r1 (Constructor name lhs)
224-
, GSum r2 rhs
218+
instance gCasesSum ∷
219+
( GCases r1 (Constructor name lhs)
220+
, GCases r2 rhs
225221
, Row.Cons name codecs1 () r1
226222
, Row.Cons name codecs1 r2 r
227223
, Row.Union r1 r2 r
228224
, Row.Lacks name r2
229225
, IsSymbol name
230226
) ⇒
231-
GSum r (Sum (Constructor name lhs) rhs) where
232-
gSumEncode ∷ Encoding → Record r → Sum (Constructor name lhs) rhs → Json
233-
gSumEncode encoding r =
227+
GCases r (Sum (Constructor name lhs) rhs) where
228+
gCasesEncode ∷ Encoding → Record r → Sum (Constructor name lhs) rhs → Json
229+
gCasesEncode encoding r =
234230
let
235-
codecs1 = Record.get (Proxy ∷ Proxy name) r ∷ codecs1
236-
r1 = Record.insert (Proxy ∷ Proxy name) codecs1 {} ∷ Record r1
237-
r2 = Record.delete (Proxy ∷ Proxy name) r ∷ Record r2
231+
codecs1 = Record.get (Proxy @name) r ∷ codecs1
232+
r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
233+
r2 = Record.delete (Proxy @name) r ∷ Record r2
238234
in
239235
case _ of
240-
Inl lhs → gSumEncode encoding r1 lhs
241-
Inr rhs → gSumEncode encoding r2 rhs
236+
Inl lhs → gCasesEncode encoding r1 lhs
237+
Inr rhs → gCasesEncode encoding r2 rhs
242238

243-
gSumDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
244-
gSumDecode encoding r tagged = do
239+
gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
240+
gCasesDecode encoding r tagged = do
245241
let
246-
codecs1 = Record.get (Proxy ∷ Proxy name) r ∷ codecs1
247-
r1 = Record.insert (Proxy ∷ Proxy name) codecs1 {} ∷ Record r1
248-
r2 = Record.delete (Proxy ∷ Proxy name) r ∷ Record r2
249-
250-
lhs = gSumDecode encoding r1 tagged ∷ _ (Constructor name lhs)
251-
rhs = gSumDecode encoding r2 tagged ∷ _ rhs
242+
codecs1 = Record.get (Proxy @name) r ∷ codecs1
243+
r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
244+
r2 = Record.delete (Proxy @name) r ∷ Record r2
245+
let
246+
lhs = gCasesDecode encoding r1 tagged ∷ _ (Constructor name lhs)
247+
rhs = gCasesDecode encoding r2 tagged ∷ _ rhs
252248
(Inl <$> lhs) <|> (Inr <$> rhs)
253249

254250
--------------------------------------------------------------------------------
255251

256-
class GProduct ∷ Type → Type → Constraint
257-
class GProduct codecs rep where
258-
gProductEncode ∷ Encoding → codecs → rep → Array Json
259-
gProductDecode ∷ Encoding → codecs → Array Json → Either JsonDecodeError rep
260-
261-
instance gProductArgument ∷ GProduct (JsonCodec a) (Argument a) where
262-
gProductEncode ∷ Encoding → JsonCodec a → Argument a → Array Json
263-
gProductEncode _ codec (Argument val) = [ CA.encode codec val ]
264-
265-
gProductDecode ∷ Encoding → JsonCodec a → Array Json → Either JsonDecodeError (Argument a)
266-
gProductDecode _ codec jsons = do
267-
json ← case jsons of
268-
[ head ] → pure head
269-
_ → Left $ TypeMismatch "Expecting exactly one element"
270-
252+
class GFields ∷ Type → Type → Constraint
253+
class GFields codecs rep where
254+
gFieldsEncode ∷ Encoding → codecs → rep → Array Json
255+
gFieldsDecode ∷ Encoding → codecs → Array Json → Either JsonDecodeError rep
256+
257+
instance gFieldsArgument ∷ GFields (JsonCodec a) (Argument a) where
258+
gFieldsEncode ∷ Encoding → JsonCodec a → Argument a → Array Json
259+
gFieldsEncode _ codec (Argument val) = [ CA.encode codec val ]
260+
261+
gFieldsDecode ∷ Encoding → JsonCodec a → Array Json → Either JsonDecodeError (Argument a)
262+
gFieldsDecode _ codec jsons = do
263+
json ←
264+
( case jsons of
265+
[ head ] → pure head
266+
_ → Left $ TypeMismatch "Expecting exactly one element"
267+
) ∷ _ Json
271268
res ← CA.decode codec json ∷ _ a
272-
273269
pure $ Argument res
274270

275-
instance gProductProduct ∷
276-
( GProduct codec rep
277-
, GProduct codecs reps
271+
instance gFieldsProduct ∷
272+
( GFields codec rep
273+
, GFields codecs reps
278274
) ⇒
279-
GProduct (codec /\ codecs) (Product rep reps) where
280-
gProductEncode ∷ Encoding → (codec /\ codecs) → Product rep reps → Array Json
281-
gProductEncode encoding (codec /\ codecs) (Product rep reps) =
275+
GFields (codec /\ codecs) (Product rep reps) where
276+
gFieldsEncode ∷ Encoding → (codec /\ codecs) → Product rep reps → Array Json
277+
gFieldsEncode encoding (codec /\ codecs) (Product rep reps) =
282278
let
283-
r1 = gProductEncode encoding codec rep ∷ Array Json
284-
r2 = gProductEncode encoding codecs reps ∷ Array Json
279+
r1 = gFieldsEncode encoding codec rep ∷ Array Json
280+
r2 = gFieldsEncode encoding codecs reps ∷ Array Json
285281
in
286282
r1 <> r2
287283

288-
gProductDecode ∷ Encoding → (codec /\ codecs) → Array Json → Either JsonDecodeError (Product rep reps)
289-
gProductDecode encoding (codec /\ codecs) jsons = do
290-
{ head, tail } ← Array.uncons jsons # note (TypeMismatch "Expecting at least one element") ∷ _ { head ∷ Json, tail ∷ Array Json }
291-
rep ← gProductDecode encoding codec [ head ] ∷ _ rep
292-
reps ← gProductDecode encoding codecs tail ∷ _ reps
284+
gFieldsDecode ∷ Encoding → (codec /\ codecs) → Array Json → Either JsonDecodeError (Product rep reps)
285+
gFieldsDecode encoding (codec /\ codecs) jsons = do
286+
{ head, tail } ←
287+
(Array.uncons jsons # note (TypeMismatch "Expecting at least one element"))
288+
∷ _ { head ∷ Json, tail ∷ Array Json }
289+
rep ← gFieldsDecode encoding codec [ head ] ∷ _ rep
290+
reps ← gFieldsDecode encoding codecs tail ∷ _ reps
293291
pure $ Product rep reps
294292

295293
--------------------------------------------------------------------------------
@@ -326,7 +324,7 @@ parseNoFields encoding obj = do
326324
( Obj.lookup encoding.valuesKey obj
327325
# note (TypeMismatch ("Expecting a value property `" <> encoding.valuesKey <> "`"))
328326
) ∷ _ Json
329-
fields ← CA.decode CA.jarray val
327+
fields ← CA.decode CA.jarray val ∷ _ (Array Json)
330328
when (fields /= [])
331329
$ throwError
332330
$ TypeMismatch "Expecting an empty array"
@@ -340,7 +338,12 @@ parseManyFields encoding obj = do
340338
CA.decode CA.jarray val
341339

342340
encodeTagged ∷ Encoding → String → Maybe Json → Json
343-
encodeTagged encoding tag maybeJson = encode jobject $ Obj.fromFoldable $ catMaybes
344-
[ Just (encoding.tagKey /\ CA.encode CA.string tag)
345-
, map (\json → encoding.valuesKey /\ json) maybeJson
346-
]
341+
encodeTagged encoding tag maybeJson =
342+
let
343+
tagEntry =
344+
Just (encoding.tagKey /\ CA.encode CA.string tag) ∷ Maybe (String /\ Json)
345+
valEntry =
346+
map (\json → (encoding.valuesKey /\ json)) maybeJson ∷ Maybe (String /\ Json)
347+
in
348+
encode jobject $ Obj.fromFoldable $ catMaybes
349+
[ tagEntry, valEntry ]

‎test/Test/Main.purs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ import Test.Generic as Generic
1010
import Test.Migration as Migration
1111
import Test.Prim as TestPrim
1212
import Test.Record as Record
13+
import Test.Sum as Sum
1314
import Test.Variant as Variant
1415

1516
main ∷ Effect Unit
@@ -32,6 +33,10 @@ main = do
3233
log ""
3334
log "Checking Record codecs"
3435
log "------------------------------------------------------------"
36+
Sum.main
37+
log ""
38+
log "Checking Sume codecs"
39+
log "------------------------------------------------------------"
3540
Record.main
3641
log ""
3742
log "Checking Migration codecs"

0 commit comments

Comments
 (0)