/
Class.purs
459 lines (380 loc) · 15.9 KB
/
Class.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
module Codec.Json.Bidirectional.Class
( class CodecJson
, codecJson
, ExistentialCodecJson0
, mkExistentialCodecJson0
, ExistentialCodecJson1
, mkExistentialCodecJson1
, ExistentialCodecJson2
, mkExistentialCodecJson2
, ExistentialCodecJson3
, mkExistentialCodecJson3
, CJPropFn
, class CodecJsonRecord
, codecJsonRecord
, CJVariantFn
, class CodecJsonVariant
, codecJsonVariant
) where
import Prelude
import Codec.Codec (Codec(..), decoder, encoder, mapDecodeError)
import Codec.Decoder (DecoderFn(..), altAccumulate)
import Codec.Json.Bidirectional.Value (array, boolean, codePoint, either, int, json, list, mapCodec, maybe, nonEmpty', nonEmptyArray, nonEmptyList, nonEmptySet, nonEmptyString, nullable, number, object, recordPrim, requiredProp, set, string, these, tuple, unitCodec, variantCase, variantPrim, voidCodec)
import Codec.Json.JsonCodec (JPropCodec, JsonCodec', JsonCodec, addCtorHintC, addTypeHintC)
import Codec.Json.JsonDecoder (DecodeErrorAccumulatorFn)
import Codec.Json.Newtypes (K0(..), K1(..), K2(..), K3(..), Optional(..))
import Codec.Json.Unidirectional.Decode.Class (class VCTypeHint, VCHint(..), vcTypeHint)
import Codec.Json.Unidirectional.Decode.Value (decodeField')
import Data.Argonaut.Core (Json)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Either (Either(..))
import Data.Function.Uncurried (Fn2, mkFn2, mkFn5, runFn2, runFn5)
import Data.Generic.Rep (Argument(..), Constructor(..), NoArguments(..), Product(..), Sum(..))
import Data.List (List)
import Data.List as List
import Data.List.Types (NonEmptyList)
import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Data.Maybe as Maybe
import Data.Newtype (class Newtype, unwrap)
import Data.NonEmpty (NonEmpty)
import Data.Nullable (Nullable)
import Data.Profunctor (dimap)
import Data.Set (Set)
import Data.Set.NonEmpty (NonEmptySet)
import Data.String (CodePoint)
import Data.String.NonEmpty.Internal (NonEmptyString)
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.These (These)
import Data.Tuple (Tuple(..), fst)
import Data.Validation.Semigroup (V)
import Data.Variant (Variant)
import Data.Variant as V
import Foreign.Object (Object)
import Prim.Row as Row
import Prim.RowList as RL
import Record as Record
import Record.Unsafe (unsafeGet, unsafeSet)
import Safe.Coerce (coerce)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)
class CodecJson e extra a where
codecJson :: JsonCodec e extra a
instance CodecJson e extra Json where
codecJson = json
instance CodecJson e extra Void where
codecJson = voidCodec
instance CodecJson e extra Unit where
codecJson = unitCodec
instance CodecJson e extra Boolean where
codecJson = boolean
instance CodecJson e extra Number where
codecJson = number
instance CodecJson e extra String where
codecJson = string
instance CodecJson e extra Int where
codecJson = int
instance CodecJson e extra NonEmptyString where
codecJson = nonEmptyString
instance CodecJson e extra CodePoint where
codecJson = codePoint
instance CodecJson e extra a => CodecJson e extra (Array a) where
codecJson = array codecJson
instance CodecJson e extra a => CodecJson e extra (NonEmptyArray a) where
codecJson = nonEmptyArray codecJson
instance CodecJson e extra a => CodecJson e extra (Object a) where
codecJson = object codecJson
instance CodecJson e extra a => CodecJson e extra (Nullable a) where
codecJson = nullable codecJson
instance CodecJson e extra a => CodecJson e extra (Maybe a) where
codecJson = maybe codecJson
instance (CodecJson e extra a, CodecJson e extra b) => CodecJson e extra (Either a b) where
codecJson = either codecJson codecJson
instance (CodecJson e extra a, CodecJson e extra b) => CodecJson e extra (Tuple a b) where
codecJson = tuple codecJson codecJson
instance (CodecJson e extra a, CodecJson e extra b) => CodecJson e extra (These a b) where
codecJson = these codecJson codecJson
instance (CodecJson e extra a, CodecJson e extra (f a)) => CodecJson e extra (NonEmpty f a) where
codecJson = nonEmpty' codecJson codecJson
instance (CodecJson e extra a) => CodecJson e extra (List a) where
codecJson = list codecJson
instance (CodecJson e extra a) => CodecJson e extra (NonEmptyList a) where
codecJson = nonEmptyList codecJson
instance (Ord k, CodecJson e extra k, CodecJson e extra v) => CodecJson e extra (Map k v) where
codecJson = mapCodec codecJson codecJson
instance (Ord a, CodecJson e extra a) => CodecJson e extra (Set a) where
codecJson = set codecJson
instance (Ord a, CodecJson e extra a) => CodecJson e extra (NonEmptySet a) where
codecJson = nonEmptySet codecJson
instance
( RL.RowToList row rl
, CodecJsonRecord e extra rl row
) =>
CodecJson e extra { | row } where
codecJson = recordPrim (unCJPropFn (codecJsonRecord :: CJPropFn e extra rl row))
instance
( RL.RowToList row rl
, CodecJsonVariant e extra rl row
) =>
CodecJson e extra (Variant row) where
codecJson = variantPrim altAccumulate (unCJVariantFn (codecJsonVariant :: CJVariantFn e extra rl row))
foreign import data ExistentialCodecJson0 :: Type -> Type
mkExistentialCodecJson0 :: forall e extra a. JsonCodec e extra a -> ExistentialCodecJson0 a
mkExistentialCodecJson0 = unsafeCoerce
unExistentialCodecJson0 :: forall e extra a. ExistentialCodecJson0 a -> JsonCodec e extra a
unExistentialCodecJson0 = unsafeCoerce
instance
( Newtype extra { | rows }
, Row.Cons sym (ExistentialCodecJson0 a) tail rows
, IsSymbol sym
) =>
CodecJson e extra (K0 sym a) where
codecJson = Codec dec enc
where
_sym = Proxy :: Proxy sym
dec = DecoderFn $ mkFn5 \pathSoFar appendFn handlers extra json -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
(DecoderFn f) = decoder $ unExistentialCodecJson0 $ Record.get _sym localOverrides
reAddNewtype :: V e a -> V e (K0 sym a)
reAddNewtype = coerce
reAddNewtype $ runFn5 f pathSoFar appendFn handlers extra json
enc = mkFn2 \extra k0a -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
f = encoder $ unExistentialCodecJson0 $ Record.get _sym localOverrides
a :: a
a = coerce k0a
k0a <$ runFn2 f extra a
foreign import data ExistentialCodecJson1 :: (Type -> Type) -> Type
mkExistentialCodecJson1 :: forall e extra f a. (JsonCodec e extra a -> JsonCodec e extra (f a)) -> ExistentialCodecJson1 f
mkExistentialCodecJson1 = unsafeCoerce
unExistentialCodecJson1 :: forall e extra f a. ExistentialCodecJson1 f -> (JsonCodec e extra a -> JsonCodec e extra (f a))
unExistentialCodecJson1 = unsafeCoerce
instance
( Newtype extra { | rows }
, CodecJson e extra a
, Row.Cons sym (ExistentialCodecJson1 f) tail rows
, IsSymbol sym
) =>
CodecJson e extra (K1 sym (f a)) where
codecJson = Codec dec enc
where
_sym = Proxy :: Proxy sym
codecJsonA = codecJson :: JsonCodec e extra a
dec = DecoderFn $ mkFn5 \pathSoFar appendFn handlers extra json -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildDecoder = unExistentialCodecJson1 $ Record.get _sym localOverrides
(DecoderFn f) = decoder $ buildDecoder codecJsonA
reAddNewtype :: V e (f a) -> V e (K1 sym (f a))
reAddNewtype = coerce
reAddNewtype $ runFn5 f pathSoFar appendFn handlers extra json
enc = mkFn2 \extra k1fa -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildEncoder = unExistentialCodecJson1 $ Record.get _sym localOverrides
f = encoder $ buildEncoder codecJsonA
fa :: f a
fa = coerce k1fa
k1fa <$ runFn2 f extra fa
foreign import data ExistentialCodecJson2 :: (Type -> Type -> Type) -> Type
mkExistentialCodecJson2 :: forall e extra f a b. (JsonCodec e extra a -> JsonCodec e extra b -> JsonCodec e extra (f a b)) -> ExistentialCodecJson2 f
mkExistentialCodecJson2 = unsafeCoerce
unExistentialCodecJson2 :: forall e extra f a b. ExistentialCodecJson2 f -> (JsonCodec e extra a -> JsonCodec e extra b -> JsonCodec e extra (f a b))
unExistentialCodecJson2 = unsafeCoerce
instance
( Newtype extra { | rows }
, CodecJson e extra a
, CodecJson e extra b
, Row.Cons sym (ExistentialCodecJson2 f) tail rows
, IsSymbol sym
) =>
CodecJson e extra (K2 sym (f a b)) where
codecJson = Codec dec enc
where
_sym = Proxy :: Proxy sym
codecJsonA = codecJson :: JsonCodec e extra a
codecJsonB = codecJson :: JsonCodec e extra b
dec = DecoderFn $ mkFn5 \pathSoFar appendFn handlers extra json -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildDecoder = unExistentialCodecJson2 $ Record.get _sym localOverrides
(DecoderFn f) = decoder $ buildDecoder codecJsonA codecJsonB
reAddNewtype :: V e (f a b) -> V e (K2 sym (f a b))
reAddNewtype = coerce
reAddNewtype $ runFn5 f pathSoFar appendFn handlers extra json
enc = mkFn2 \extra k2fab -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildEncoder = unExistentialCodecJson2 $ Record.get _sym localOverrides
f = encoder $ buildEncoder codecJsonA codecJsonB
fab :: f a b
fab = coerce k2fab
k2fab <$ runFn2 f extra fab
foreign import data ExistentialCodecJson3 :: (Type -> Type -> Type -> Type) -> Type
mkExistentialCodecJson3 :: forall e extra f a b c. (JsonCodec e extra a -> JsonCodec e extra b -> JsonCodec e extra c -> JsonCodec e extra (f a b c)) -> ExistentialCodecJson3 f
mkExistentialCodecJson3 = unsafeCoerce
unExistentialCodecJson3 :: forall e extra f a b c. ExistentialCodecJson3 f -> (JsonCodec e extra a -> JsonCodec e extra b -> JsonCodec e extra c -> JsonCodec e extra (f a b c))
unExistentialCodecJson3 = unsafeCoerce
instance
( Newtype extra { | rows }
, CodecJson e extra a
, CodecJson e extra b
, CodecJson e extra c
, Row.Cons sym (ExistentialCodecJson3 f) tail rows
, IsSymbol sym
) =>
CodecJson e extra (K3 sym (f a b c)) where
codecJson = Codec dec enc
where
_sym = Proxy :: Proxy sym
codecJsonA = codecJson :: JsonCodec e extra a
codecJsonB = codecJson :: JsonCodec e extra b
codecJsonC = codecJson :: JsonCodec e extra c
dec = DecoderFn $ mkFn5 \pathSoFar appendFn handlers extra json -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildDecoder = unExistentialCodecJson3 $ Record.get _sym localOverrides
(DecoderFn f) = decoder $ buildDecoder codecJsonA codecJsonB codecJsonC
reAddNewtype :: V e (f a b c) -> V e (K3 sym (f a b c))
reAddNewtype = coerce
reAddNewtype $ runFn5 f pathSoFar appendFn handlers extra json
enc = mkFn2 \extra k3fabc -> do
let
localOverrides :: { | rows }
localOverrides = unwrap extra
buildEncoder = unExistentialCodecJson3 $ Record.get _sym localOverrides
f = encoder $ buildEncoder codecJsonA codecJsonB codecJsonC
fabc :: f a b c
fabc = coerce k3fabc
k3fabc <$ runFn2 f extra fabc
instance CodecJson e extra NoArguments where
codecJson = dimap (const unit) (const NoArguments) unitCodec
instance (CodecJson e extra a, CodecJson e extra b) => CodecJson e extra (Sum a b) where
codecJson = addTypeHintC "Sum"
$ dimap toVariant fromVariant
$ variantPrim altAccumulate
$ variantCase _inl (Tuple (addCtorHintC "Inl") $ Right codecJson)
>>> variantCase _inr (Tuple (addCtorHintC "Inr") $ Right codecJson)
where
toVariant = case _ of
Inl l -> V.inj _inl l
Inr r -> V.inj _inr r
fromVariant = V.case_
# V.on _inl Inl
# V.on _inr Inr
_inl = Proxy :: Proxy "Inl"
_inr = Proxy :: Proxy "Inr"
instance (CodecJson e extra a, CodecJson e extra b) => CodecJson e extra (Product a b) where
codecJson = addTypeHintC "Product"
$ dimap (\(Product a b) -> Tuple a b) (\(Tuple a b) -> Product a b)
$ tuple codecJson codecJson
instance (CodecJson e extra a, IsSymbol sym) => CodecJson e extra (Constructor sym a) where
codecJson = addTypeHintC ("Constructor (" <> (reflectSymbol (Proxy :: _ sym)) <> ")")
$ (coerce :: JsonCodec e extra a -> JsonCodec e extra (Constructor sym a)) codecJson
instance (CodecJson e extra a) => CodecJson e extra (Argument a) where
codecJson = addTypeHintC "Argument"
$ (coerce :: JsonCodec e extra a -> JsonCodec e extra (Argument a)) codecJson
newtype CJPropFn :: Type -> Type -> RL.RowList Type -> Row Type -> Type
newtype CJPropFn e extra rl to =
CJPropFn (JPropCodec e extra {} -> JPropCodec e extra { | to })
unCJPropFn
:: forall e extra rl to
. CJPropFn e extra rl to
-> (JPropCodec e extra {} -> JPropCodec e extra { | to })
unCJPropFn (CJPropFn fn) = fn
class CodecJsonRecord e extra rl row | e extra rl -> row where
codecJsonRecord :: CJPropFn e extra rl row
instance CodecJsonRecord e extra RL.Nil () where
codecJsonRecord = CJPropFn identity
else instance
( Row.Cons sym (Optional (Maybe a)) row' row
, CodecJson e extra a
, CodecJsonRecord e extra tail row'
, IsSymbol sym
) =>
CodecJsonRecord e extra (RL.Cons sym (Optional (Maybe a)) tail) row where
codecJsonRecord = CJPropFn
( optionalProp' (Proxy :: Proxy sym) codecJson
<<< (unCJPropFn (codecJsonRecord :: CJPropFn e extra tail row'))
)
else instance
( Row.Cons sym a row' row
, CodecJson e extra a
, CodecJsonRecord e extra tail row'
, IsSymbol sym
) =>
CodecJsonRecord e extra (RL.Cons sym a tail) row where
codecJsonRecord = CJPropFn
( requiredProp (Proxy :: Proxy sym) codecJson
<<< (unCJPropFn (codecJsonRecord :: CJPropFn e extra tail row'))
)
optionalProp'
:: forall e extra sym a r r'
. IsSymbol sym
=> Row.Cons sym (Optional (Maybe a)) r r'
=> Proxy sym
-> JsonCodec e extra a
-> JPropCodec e extra { | r }
-> JPropCodec e extra { | r' }
optionalProp' _sym codecA codecR = Codec dec enc
where
key = reflectSymbol _sym
dec = ado
r <- decoder codecR
a <- decodeField' key (pure Nothing) (Just <$> decoder codecA)
in unsafeSet key (Optional a) r
enc :: Fn2 extra { | r' } (Tuple (List (Tuple String Json)) { | r' })
enc = mkFn2 \extra val -> do
let tail = fst $ runFn2 (encoder codecR) extra (unsafeForget val)
let mbHead = map (\a -> Tuple key (fst $ runFn2 (encoder codecA) extra a)) $ unsafeGet key val
Tuple (Maybe.maybe tail (\h -> h List.: tail) mbHead) val
unsafeForget :: Record r' → Record r
unsafeForget = unsafeCoerce
newtype CJVariantFn :: Type -> Type -> RL.RowList Type -> Row Type -> Type
newtype CJVariantFn e extra rl rows = CJVariantFn
( ( DecodeErrorAccumulatorFn e extra (Object Json) (Variant ())
-> JsonCodec' e extra (Object Json) (Variant ())
)
-> ( DecodeErrorAccumulatorFn e extra (Object Json) (Variant rows)
-> JsonCodec' e extra (Object Json) (Variant rows)
)
)
unCJVariantFn
:: forall e extra rl rows
. CJVariantFn e extra rl rows
-> ( ( DecodeErrorAccumulatorFn e extra (Object Json) (Variant ())
-> JsonCodec' e extra (Object Json) (Variant ())
)
-> ( DecodeErrorAccumulatorFn e extra (Object Json) (Variant rows)
-> JsonCodec' e extra (Object Json) (Variant rows)
)
)
unCJVariantFn (CJVariantFn fn) = fn
class CodecJsonVariant e extra rl row | e extra rl -> row where
codecJsonVariant :: CJVariantFn e extra rl row
instance CodecJsonVariant e extra RL.Nil () where
codecJsonVariant = CJVariantFn \buildTailCodec errorAccumulator ->
buildTailCodec errorAccumulator
instance
( Row.Cons sym a row' row
, CodecJson e extra a
, CodecJsonVariant e extra tail row'
, IsSymbol sym
, VCTypeHint e extra (RL.Cons sym a tail) row a
) =>
CodecJsonVariant e extra (RL.Cons sym a tail) row where
codecJsonVariant = CJVariantFn
( variantCase (Proxy :: Proxy sym) (Tuple (mapDecodeError addHint) $ Right codecJson)
<<< (unCJVariantFn (codecJsonVariant :: CJVariantFn e extra tail row'))
)
where
addHint = vcTypeHint (VCHint :: VCHint e extra (RL.Cons sym a tail) row a)