-
Notifications
You must be signed in to change notification settings - Fork 322
/
TH.hs
2040 lines (1792 loc) · 78.2 KB
/
TH.hs
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
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
-- a) THQ works on cross-compilers and unregisterised GHCs
-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)
-- c) removes one hindrance to have code inferred as SafeHaskell safe
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#include "incoherent-compat.h"
#include "overlapping-compat.h"
{-|
Module: Data.Aeson.TH
Copyright: (c) 2011-2016 Bryan O'Sullivan
(c) 2011 MailRank, Inc.
License: BSD3
Stability: experimental
Portability: portable
Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that
you need to enable the @TemplateHaskell@ language extension in order to use this
module.
An example shows how instances are generated for arbitrary data types. First we
define a data type:
@
data D a = Nullary
| Unary Int
| Product String Char a
| Record { testOne :: Double
, testTwo :: Bool
, testThree :: D a
} deriving Eq
@
Next we derive the necessary instances. Note that we make use of the
feature to change record field names. In this case we drop the first 4
characters of every field name. We also modify constructor names by
lower-casing them:
@
$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)
@
Now we can use the newly created instances.
@
d :: D 'Int'
d = Record { testOne = 3.14159
, testTwo = 'True'
, testThree = Product \"test\" \'A\' 123
}
@
>>> fromJSON (toJSON d) == Success d
> True
This also works for data family instances, but instead of passing in the data
family name (with double quotes), we pass in a data family instance
constructor (with a single quote):
@
data family DF a
data instance DF Int = DF1 Int
| DF2 Int Int
deriving Eq
$('deriveJSON' 'defaultOptions' 'DF1)
-- Alternatively, one could pass 'DF2 instead
@
Please note that you can derive instances for tuples using the following syntax:
@
-- FromJSON and ToJSON instances for 4-tuples.
$('deriveJSON' 'defaultOptions' ''(,,,))
@
-}
module Data.Aeson.TH
(
-- * Encoding configuration
Options(..)
, SumEncoding(..)
, defaultOptions
, defaultTaggedObject
-- * FromJSON and ToJSON derivation
, deriveJSON
, deriveJSON1
, deriveJSON2
, deriveToJSON
, deriveToJSON1
, deriveToJSON2
, deriveFromJSON
, deriveFromJSON1
, deriveFromJSON2
, mkToJSON
, mkLiftToJSON
, mkLiftToJSON2
, mkToEncoding
, mkLiftToEncoding
, mkLiftToEncoding2
, mkParseJSON
, mkLiftParseJSON
, mkLiftParseJSON2
) where
import Prelude ()
import Prelude.Compat hiding (exp)
import Control.Applicative ((<|>))
import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
import Control.Monad (liftM2, unless, when)
import Data.Foldable (foldr')
#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
import Data.List (nub)
#endif
import Data.List (foldl', genericLength, intercalate, partition, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Set (Set)
#if MIN_VERSION_template_haskell(2,8,0)
import Language.Haskell.TH hiding (Arity)
#else
import Language.Haskell.TH
#endif
import Language.Haskell.TH.Datatype
#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
import Language.Haskell.TH.Lib (starK)
#endif
#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
import Language.Haskell.TH.Syntax (mkNameG_tc)
#endif
import Text.Printf (printf)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.Foldable as F (all)
import qualified Data.HashMap.Strict as H (lookup, toList)
import qualified Data.List.NonEmpty as NE (length, reverse)
import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
import qualified Data.Semigroup as Semigroup (Option(..))
import qualified Data.Set as Set (empty, insert, member)
import qualified Data.Text as T (Text, pack, unpack)
import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
{-# ANN module "Hlint: ignore Reduce duplication" #-}
--------------------------------------------------------------------------------
-- Convenience
--------------------------------------------------------------------------------
-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convienience function which is equivalent to calling both
-- 'deriveToJSON' and 'deriveFromJSON'.
deriveJSON :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
-- instances.
-> Q [Dec]
deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON
-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convienience function which is equivalent to calling both
-- 'deriveToJSON1' and 'deriveFromJSON1'.
deriveJSON1 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'
-- instances.
-> Q [Dec]
deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1
-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convienience function which is equivalent to calling both
-- 'deriveToJSON2' and 'deriveFromJSON2'.
deriveJSON2 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'
-- instances.
-> Q [Dec]
deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2
--------------------------------------------------------------------------------
-- ToJSON
--------------------------------------------------------------------------------
{-
TODO: Don't constrain phantom type variables.
data Foo a = Foo Int
instance (ToJSON a) ⇒ ToJSON Foo where ...
The above (ToJSON a) constraint is not necessary and perhaps undesirable.
-}
-- | Generates a 'ToJSON' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'ToJSON' instance
-- declaration.
-> Q [Dec]
deriveToJSON = deriveToJSONCommon toJSONClass
-- | Generates a 'ToJSON1' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON1 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'ToJSON1' instance
-- declaration.
-> Q [Dec]
deriveToJSON1 = deriveToJSONCommon toJSON1Class
-- | Generates a 'ToJSON2' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON2 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'ToJSON2' instance
-- declaration.
-> Q [Dec]
deriveToJSON2 = deriveToJSONCommon toJSON2Class
deriveToJSONCommon :: JSONClass
-- ^ The ToJSON variant being derived.
-> Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate an instance.
-> Q [Dec]
deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue Value jc)
, (ToEncoding, \jc _ -> consToValue Encoding jc)
]
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value'.
mkToJSON :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkToJSON = mkToJSONCommon toJSONClass
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value' by using the given encoding
-- function on occurrences of the last type parameter.
mkLiftToJSON :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkLiftToJSON = mkToJSONCommon toJSON1Class
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value' by using the given encoding
-- functions on occurrences of the last two type parameters.
mkLiftToJSON2 :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkLiftToJSON2 = mkToJSONCommon toJSON2Class
mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.
-> Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string.
mkToEncoding :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkToEncoding = mkToEncodingCommon toJSONClass
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string by using the given encoding
-- function on occurrences of the last type parameter.
mkLiftToEncoding :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkLiftToEncoding = mkToEncodingCommon toJSON1Class
-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string by using the given encoding
-- functions on occurrences of the last two type parameters.
mkLiftToEncoding2 :: Options -- ^ Encoding options.
-> Name -- ^ Name of the type to encode.
-> Q Exp
mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class
mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.
-> Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)
-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
-- code to generate a 'Value' or 'Encoding' of a number of constructors. All
-- constructors must be from the same type.
consToValue :: ToJSONFun
-- ^ The method ('toJSON' or 'toEncoding') being derived.
-> JSONClass
-- ^ The ToJSON variant being derived.
-> Options
-- ^ Encoding options.
-> [Type]
-- ^ The types from the data type/data family instance declaration
-> [ConstructorInfo]
-- ^ Constructors for which to generate JSON generating code.
-> Q Exp
consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
++ "Not a single constructor given!"
consToValue target jc opts vars cons = do
value <- newName "value"
tjs <- newNameList "_tj" $ arityInt jc
tjls <- newNameList "_tjl" $ arityInt jc
let zippedTJs = zip tjs tjls
interleavedTJs = interleave tjs tjls
lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
tvMap = M.fromList $ zip lastTyVars zippedTJs
lamE (map varP $ interleavedTJs ++ [value]) $
caseE (varE value) (matches tvMap)
where
matches tvMap = case cons of
-- A single constructor is directly encoded. The constructor itself may be
-- forgotten.
[con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]
_ | allNullaryToStringTag opts && all isNullary cons ->
[ match (conP conName []) (normalB $ conStr target opts conName) []
| con <- cons
, let conName = constructorName con
]
| otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]
-- | Name of the constructor as a quoted 'Value' or 'Encoding'.
conStr :: ToJSONFun -> Options -> Name -> Q Exp
conStr Value opts = appE [|String|] . conTxt opts
conStr Encoding opts = appE [|E.text|] . conTxt opts
-- | Name of the constructor as a quoted 'Text'.
conTxt :: Options -> Name -> Q Exp
conTxt opts = appE [|T.pack|] . stringE . conString opts
-- | Name of the constructor.
conString :: Options -> Name -> String
conString opts = constructorTagModifier opts . nameBase
-- | If constructor is nullary.
isNullary :: ConstructorInfo -> Bool
isNullary ConstructorInfo { constructorVariant = NormalConstructor
, constructorFields = tys } = null tys
isNullary _ = False
-- | Wrap fields of a non-record constructor. See 'sumToValue'.
opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
opaqueSumToValue target opts multiCons nullary conName value =
sumToValue target opts multiCons nullary conName
value
pairs
where
pairs contentsFieldName = listE [toPair target contentsFieldName value]
-- | Wrap fields of a record constructor. See 'sumToValue'.
recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
recordSumToValue target opts multiCons nullary conName pairs =
sumToValue target opts multiCons nullary conName
(objectExp target pairs)
(const pairs)
-- | Wrap fields of a constructor.
sumToValue
:: ToJSONFun
-- ^ The method being derived.
-> Options
-- ^ Deriving options.
-> Bool
-- ^ Does this type have multiple constructors.
-> Bool
-- ^ Is this constructor nullary.
-> Name
-- ^ Constructor name.
-> ExpQ
-- ^ Fields of the constructor as a 'Value' or 'Encoding'.
-> (String -> ExpQ)
-- ^ Representation of an 'Object' fragment used for the 'TaggedObject'
-- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method
-- being derived.
--
-- - For non-records, produces a pair @"contentsFieldName":value@,
-- given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.
-- - For records, produces the list of pairs corresponding to fields of the
-- encoded value (ignores the argument). See 'recordSumToValue'.
-> ExpQ
sumToValue target opts multiCons nullary conName value pairs
| multiCons =
case sumEncoding opts of
TwoElemArray ->
array target [conStr target opts conName, value]
TaggedObject{tagFieldName, contentsFieldName} ->
-- TODO: Maybe throw an error in case
-- tagFieldName overwrites a field in pairs.
let tag = toPair target tagFieldName (conStr target opts conName)
content = pairs contentsFieldName
in objectExp target $
if nullary then listE [tag] else infixApp tag [|(:)|] content
ObjectWithSingleField ->
object target [(conString opts conName, value)]
UntaggedValue | nullary -> conStr target opts conName
UntaggedValue -> value
| otherwise = value
-- | Generates code to generate the JSON encoding of a single constructor.
argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
-- Polyadic constructors with special case for unary constructors.
argsToValue target jc tvMap opts multiCons
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = argTys } = do
argTys' <- mapM resolveTypeSynonyms argTys
let len = length argTys'
args <- newNameList "arg" len
let js = case [ dispatchToJSON target jc conName tvMap argTy
`appE` varE arg
| (arg, argTy) <- zip args argTys'
] of
-- Single argument is directly converted.
[e] -> e
-- Zero and multiple arguments are converted to a JSON array.
es -> array target es
match (conP conName $ map varP args)
(normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)
[]
-- Records.
argsToValue target jc tvMap opts multiCons
info@ConstructorInfo { constructorName = conName
, constructorVariant = RecordConstructor fields
, constructorFields = argTys } =
case (unwrapUnaryRecords opts, not multiCons, argTys) of
(True,True,[_]) -> argsToValue target jc tvMap opts multiCons
(info{constructorVariant = NormalConstructor})
_ -> do
argTys' <- mapM resolveTypeSynonyms argTys
args <- newNameList "arg" $ length argTys'
let pairs | omitNothingFields opts = infixApp maybeFields
[|(++)|]
restFields
| otherwise = listE $ map pureToPair argCons
argCons = zip3 (map varE args) argTys' fields
maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
restFields = listE $ map pureToPair rest
(maybes0, rest0) = partition isMaybe argCons
(options, rest) = partition isOption rest0
maybes = maybes0 ++ map optionToMaybe options
maybeToPair = toPairLifted True
pureToPair = toPairLifted False
toPairLifted lifted (arg, argTy, field) =
let toValue = dispatchToJSON target jc conName tvMap argTy
fieldName = fieldLabel opts field
e arg' = toPair target fieldName (toValue `appE` arg')
in if lifted
then do
x <- newName "x"
infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg
else e arg
match (conP conName $ map varP args)
(normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)
[]
-- Infix constructors.
argsToValue target jc tvMap opts multiCons
ConstructorInfo { constructorName = conName
, constructorVariant = InfixConstructor
, constructorFields = argTys } = do
[alTy, arTy] <- mapM resolveTypeSynonyms argTys
al <- newName "argL"
ar <- newName "argR"
match (infixP (varP al) conName (varP ar))
( normalB
$ opaqueSumToValue target opts multiCons False conName
$ array target
[ dispatchToJSON target jc conName tvMap aTy
`appE` varE a
| (a, aTy) <- [(al,alTy), (ar,arTy)]
]
)
[]
isMaybe :: (a, Type, b) -> Bool
isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
isMaybe _ = False
isOption :: (a, Type, b) -> Bool
isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
isOption _ = False
optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
(<^>) :: ExpQ -> ExpQ -> ExpQ
(<^>) a b = infixApp a [|(E.><)|] b
infixr 6 <^>
(<:>) :: ExpQ -> ExpQ -> ExpQ
(<:>) a b = a <^> [|E.colon|] <^> b
infixr 5 <:>
(<%>) :: ExpQ -> ExpQ -> ExpQ
(<%>) a b = a <^> [|E.comma|] <^> b
infixr 4 <%>
-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
array :: ToJSONFun -> [ExpQ] -> ExpQ
array Encoding [] = [|E.emptyArray_|]
array Value [] = [|Array V.empty|]
array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es
array Value es = do
mv <- newName "mv"
let newMV = bindS (varP mv)
([|VM.unsafeNew|] `appE`
litE (integerL $ fromIntegral (length es)))
stmts = [ noBindS $
[|VM.unsafeWrite|] `appE`
varE mv `appE`
litE (integerL ix) `appE`
e
| (ix, e) <- zip [(0::Integer)..] es
]
ret = noBindS $ [|return|] `appE` varE mv
[|Array|] `appE`
(varE 'V.create `appE`
doE (newMV:stmts++[ret]))
-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ
object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))
-- |
-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an
-- expression of the list of pairs.
-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing
-- key-value pairs to a comma-separated 'Encoding' of them.
--
-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]
-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]
catPairs :: ToJSONFun -> [ExpQ] -> ExpQ
catPairs Value = listE
catPairs Encoding = foldr1 (<%>)
-- |
-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.
-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs
-- in an encoded 'Object'.
--
-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]
objectExp :: ToJSONFun -> ExpQ -> ExpQ
objectExp target = wrapObject target . catPairsExp target
-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.
--
-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]
-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]
catPairsExp :: ToJSONFun -> ExpQ -> ExpQ
catPairsExp Value e = e
catPairsExp Encoding e = [|commaSep|] `appE` e
-- | Create (an encoding of) a key-value pair.
--
-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.
-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]
toPair :: ToJSONFun -> String -> ExpQ -> ExpQ
toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v
toPair Encoding k v = [|E.string k|] <:> v
-- | Map an associative list in an 'Object'.
--
-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]
wrapObject :: ToJSONFun -> ExpQ -> ExpQ
wrapObject Value e = [|A.object|] `appE` e
wrapObject Encoding e = [|E.wrapObject|] `appE` e
-- | Separate 'Encoding's by commas.
--
-- > commaSep ["a","b","c"] = "a,b,c"
commaSep :: [E.Encoding] -> E.Encoding
commaSep [] = E.empty
commaSep [x] = x
commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs
--------------------------------------------------------------------------------
-- FromJSON
--------------------------------------------------------------------------------
-- | Generates a 'FromJSON' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'FromJSON' instance
-- declaration.
-> Q [Dec]
deriveFromJSON = deriveFromJSONCommon fromJSONClass
-- | Generates a 'FromJSON1' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON1 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'FromJSON1' instance
-- declaration.
-> Q [Dec]
deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class
-- | Generates a 'FromJSON2' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON2 :: Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate a 'FromJSON3' instance
-- declaration.
-> Q [Dec]
deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class
deriveFromJSONCommon :: JSONClass
-- ^ The FromJSON variant being derived.
-> Options
-- ^ Encoding options.
-> Name
-- ^ Name of the type for which to generate an instance.
-- declaration.
-> Q [Dec]
deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]
-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor.
mkParseJSON :: Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkParseJSON = mkParseJSONCommon fromJSONClass
-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor by using the given parsing
-- function on occurrences of the last type parameter.
mkLiftParseJSON :: Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkLiftParseJSON = mkParseJSONCommon fromJSON1Class
-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor by using the given parsing
-- functions on occurrences of the last two type parameters.
mkLiftParseJSON2 :: Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class
mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.
-> Options -- ^ Encoding options.
-> Name -- ^ Name of the encoded type.
-> Q Exp
mkParseJSONCommon = mkFunCommon consFromJSON
-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
-- code to parse the JSON encoding of a number of constructors. All constructors
-- must be from the same type.
consFromJSON :: JSONClass
-- ^ The FromJSON variant being derived.
-> Name
-- ^ Name of the type to which the constructors belong.
-> Options
-- ^ Encoding options
-> [Type]
-- ^ The types from the data type/data family instance declaration
-> [ConstructorInfo]
-- ^ Constructors for which to generate JSON parsing code.
-> Q Exp
consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
++ "Not a single constructor given!"
consFromJSON jc tName opts vars cons = do
value <- newName "value"
pjs <- newNameList "_pj" $ arityInt jc
pjls <- newNameList "_pjl" $ arityInt jc
let zippedPJs = zip pjs pjls
interleavedPJs = interleave pjs pjls
lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
tvMap = M.fromList $ zip lastTyVars zippedPJs
lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
where
checkExi tvMap con = checkExistentialContext jc tvMap
(constructorContext con)
(constructorName con)
lamExpr value tvMap = case cons of
[con]
| not (tagSingleConstructors opts)
-> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)
_ | sumEncoding opts == UntaggedValue
-> parseUntaggedValue tvMap cons value
| otherwise
-> caseE (varE value) $
if allNullaryToStringTag opts && all isNullary cons
then allNullaryMatches
else mixedMatches tvMap
allNullaryMatches =
[ do txt <- newName "txt"
match (conP 'String [varP txt])
(guardedB $
[ liftM2 (,) (normalG $
infixApp (varE txt)
[|(==)|]
(conTxt opts conName)
)
([|pure|] `appE` conE conName)
| con <- cons
, let conName = constructorName con
]
++
[ liftM2 (,)
(normalG [|otherwise|])
( [|noMatchFail|]
`appE` litE (stringL $ show tName)
`appE` ([|T.unpack|] `appE` varE txt)
)
]
)
[]
, do other <- newName "other"
match (varP other)
(normalB $ [|noStringFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
mixedMatches tvMap =
case sumEncoding opts of
TaggedObject {tagFieldName, contentsFieldName} ->
parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
UntaggedValue -> error "UntaggedValue: Should be handled already"
ObjectWithSingleField ->
parseObject $ parseObjectWithSingleField tvMap
TwoElemArray ->
[ do arr <- newName "array"
match (conP 'Array [varP arr])
(guardedB
[ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
[|(==)|]
(litE $ integerL 2))
(parse2ElemArray tvMap arr)
, liftM2 (,) (normalG [|otherwise|])
([|not2ElemArray|]
`appE` litE (stringL $ show tName)
`appE` ([|V.length|] `appE` varE arr))
]
)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|noArrayFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
parseObject f =
[ do obj <- newName "obj"
match (conP 'Object [varP obj]) (normalB $ f obj) []
, do other <- newName "other"
match (varP other)
( normalB
$ [|noObjectFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
parseTaggedObject tvMap typFieldName valFieldName obj = do
conKey <- newName "conKey"
doE [ bindS (varP conKey)
(infixApp (varE obj)
[|(.:)|]
([|T.pack|] `appE` stringE typFieldName))
, noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
]
parseUntaggedValue tvMap cons' conVal =
foldr1 (\e e' -> infixApp e [|(<|>)|] e')
(map (\x -> parseValue tvMap x conVal) cons')
parseValue _tvMap
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [] }
conVal = do
str <- newName "str"
caseE (varE conVal)
[ match (conP 'String [varP str])
(guardedB
[ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)
)
([|pure|] `appE` conE conName)
]
)
[]
, matchFailed tName conName "String"
]
parseValue tvMap con conVal =
checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)
parse2ElemArray tvMap arr = do
conKey <- newName "conKey"
conVal <- newName "conVal"
let letIx n ix =
valD (varP n)
(normalB ([|V.unsafeIndex|] `appE`
varE arr `appE`
litE (integerL ix)))
[]
letE [ letIx conKey 0
, letIx conVal 1
]
(caseE (varE conKey)
[ do txt <- newName "txt"
match (conP 'String [varP txt])
(normalB $ parseContents tvMap
txt
(Right conVal)
'conNotFoundFail2ElemArray
)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|firstElemNoStringFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
)
parseObjectWithSingleField tvMap obj = do
conKey <- newName "conKey"
conVal <- newName "conVal"
caseE ([e|H.toList|] `appE` varE obj)
[ match (listP [tupP [varP conKey, varP conVal]])
(normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)
[]
, do other <- newName "other"
match (varP other)
(normalB $ [|wrongPairCountFail|]
`appE` litE (stringL $ show tName)
`appE` ([|show . length|] `appE` varE other)
)
[]
]
parseContents tvMap conKey contents errorFun =
caseE (varE conKey)
[ match wildP
( guardedB $
[ do g <- normalG $ infixApp (varE conKey)
[|(==)|]
([|T.pack|] `appE`
conNameExp opts con)
e <- checkExi tvMap con $
parseArgs jc tvMap tName opts con contents
return (g, e)
| con <- cons
]
++
[ liftM2 (,)
(normalG [e|otherwise|])
( varE errorFun
`appE` litE (stringL $ show tName)
`appE` listE (map ( litE
. stringL
. constructorTagModifier opts
. nameBase
. constructorName
) cons
)
`appE` ([|T.unpack|] `appE` varE conKey)
)
]
)
[]
]
parseNullaryMatches :: Name -> Name -> [Q Match]
parseNullaryMatches tName conName =
[ do arr <- newName "arr"
match (conP 'Array [varP arr])
(guardedB
[ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
([|pure|] `appE` conE conName)
, liftM2 (,) (normalG [|otherwise|])
(parseTypeMismatch tName conName
(litE $ stringL "an empty Array")
(infixApp (litE $ stringL "Array of length ")
[|(++)|]
([|show . V.length|] `appE` varE arr)
)
)
]
)
[]
, matchFailed tName conName "Array"
]
parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
parseUnaryMatches jc tvMap argTy conName =
[ do arg <- newName "arg"
match (varP arg)
( normalB $ infixApp (conE conName)
[|(<$>)|]
(dispatchParseJSON jc conName tvMap argTy
`appE` varE arg)
)
[]
]
parseRecord :: JSONClass
-> TyVarMap
-> [Type]
-> Options
-> Name
-> Name
-> [Name]
-> Name
-> ExpQ
parseRecord jc tvMap argTys opts tName conName fields obj =
foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
where
x:xs = [ [|lookupField|]
`appE` dispatchParseJSON jc conName tvMap argTy
`appE` litE (stringL $ show tName)
`appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
`appE` varE obj
`appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)
)
| (field, argTy) <- zip fields argTys
]
getValField :: Name -> String -> [MatchQ] -> Q Exp
getValField obj valFieldName matches = do
val <- newName "val"
doE [ bindS (varP val) $ infixApp (varE obj)
[|(.:)|]
([|T.pack|] `appE`
litE (stringL valFieldName))
, noBindS $ caseE (varE val) matches
]