@@ -1,6 +1,7 @@
11{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,
22 FunctionalDependencies, KindSignatures, OverlappingInstances,
3− ScopedTypeVariables, TypeOperators, UndecidableInstances, ViewPatterns #-}
3+ ScopedTypeVariables, TypeOperators, UndecidableInstances,
4+ ViewPatterns, NamedFieldPuns #-}
45{-# OPTIONS_GHC -fno-warn-orphans #-}
56
67-- |
@@ -61,11 +62,108 @@ instance ( GProductToValues a, GProductToValues b
6162 lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
6263 {-# INLINE gToJSON #-}
6364
64−instance (GObject a, GObject b) => GToJSON (a :+: b) where
65− gToJSON opts (L1 x) = Object $ gObject opts x
66− gToJSON opts (R1 x) = Object $ gObject opts x
65+instance (AllNullary (a :+: b) c, GSumToJSON' c (a :+: b)) => GToJSON (a :+: b) where
66+ gToJSON = unTagged (gSumToJSON' :: Tagged c (Options -> (a :+: b) d -> Value))
6767 {-# INLINE gToJSON #-}
6868
69+class GSumToJSON' b f where
70+ gSumToJSON' :: Tagged b (Options -> f a -> Value)
71+
72+instance ( GSumToString f
73+ , GExtractSum f
74+ , GObjectWithType f
75+ , GObjectWithSingleField f
76+ ) => GSumToJSON' True f where
77+ gSumToJSON' = Tagged $ \opts x ->
78+ if nullaryToString opts
79+ then gSumToString opts x
80+ else sumToJSON opts x
81+ {-# INLINE gSumToJSON' #-}
82+
83+instance (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => GSumToJSON' False f where
84+ gSumToJSON' = Tagged sumToJSON
85+ {-# INLINE gSumToJSON' #-}
86+
87+sumToJSON :: (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => Options -> f a -> Value
88+sumToJSON opts x =
89+ case sumEncoding opts of
90+ TwoElemArray ->
91+ Array $ V.create $ do
92+ let (typ, val) = gExtractSum x opts
93+ mv <- VM.unsafeNew 2
94+ VM.unsafeWrite mv 0 typ
95+ VM.unsafeWrite mv 1 val
96+ return mv
97+ ObjectWithType{typeFieldName,valueFieldName} ->
98+ object $ gObjectWithType opts typeFieldName valueFieldName x
99+ ObjectWithSingleField ->
100+ Object $ gObjectWithSingleField opts x
101+{-# INLINE sumToJSON #-}
102+
103+--------------------------------------------------------------------------------
104+
105+class GObjectWithType f where
106+ gObjectWithType :: Options -> String -> String -> f a -> [Pair]
107+
108+instance (GObjectWithType a, GObjectWithType b) => GObjectWithType (a :+: b) where
109+ gObjectWithType opts typeFieldName valueFieldName (L1 x) =
110+ gObjectWithType opts typeFieldName valueFieldName x
111+ gObjectWithType opts typeFieldName valueFieldName (R1 x) =
112+ gObjectWithType opts typeFieldName valueFieldName x
113+ {-# INLINE gObjectWithType #-}
114+
115+instance (IsRecord a b, Constructor c, GObjectWithType' b a) =>
116+ GObjectWithType (C1 c a) where
117+ gObjectWithType opts typeFieldName valueFieldName x =
118+ (pack typeFieldName .= constructorNameModifier opts
119+ (conName (undefined :: t c a p))) :
120+ unTagged (gObjectWithType' opts valueFieldName (unM1 x) :: Tagged b [Pair])
121+ {-# INLINE gObjectWithType #-}
122+
123+class GObjectWithType' b f where
124+ gObjectWithType' :: Options -> String -> f a -> Tagged b [Pair]
125+
126+instance (GRecordToPairs f) => GObjectWithType' True f where
127+ gObjectWithType' opts _ x = Tagged $ toList $ gRecordToPairs opts x
128+ {-# INLINE gObjectWithType' #-}
129+
130+instance (GToJSON f) => GObjectWithType' False f where
131+ gObjectWithType' opts valueFieldName x =
132+ Tagged [pack valueFieldName .= gToJSON opts x]
133+ {-# INLINE gObjectWithType' #-}
134+
135+--------------------------------------------------------------------------------
136+
137+class GSumToString f where
138+ gSumToString :: Options -> f a -> Value
139+
140+instance (GSumToString a, GSumToString b) => GSumToString (a :+: b) where
141+ gSumToString opts (L1 x) = gSumToString opts x
142+ gSumToString opts (R1 x) = gSumToString opts x
143+ {-# INLINE gSumToString #-}
144+
145+instance (Constructor c, GToJSON a, ConsToJSON a) => GSumToString (C1 c a) where
146+ gSumToString opts _ = String $ pack $ constructorNameModifier opts
147+ $ conName (undefined :: t c a p)
148+ {-# INLINE gSumToString #-}
149+
150+--------------------------------------------------------------------------------
151+
152+class GExtractSum f where
153+ gExtractSum :: f a -> Options -> (Value, Value)
154+
155+instance (GExtractSum a, GExtractSum b) => GExtractSum (a :+: b) where
156+ gExtractSum (L1 x) = gExtractSum x
157+ gExtractSum (R1 x) = gExtractSum x
158+ {-# INLINE gExtractSum #-}
159+
160+instance (Constructor c, GToJSON a, ConsToJSON a) => GExtractSum (C1 c a) where
161+ gExtractSum x opts = ( String $ pack $ constructorNameModifier opts
162+ $ conName (undefined :: t c a p)
163+ , gToJSON opts x
164+ )
165+ {-# INLINE gExtractSum #-}
166+
69167--------------------------------------------------------------------------------
70168
71169class ConsToJSON f where consToJSON :: Options -> f a -> Value
@@ -127,19 +225,22 @@ instance (GToJSON a) => GProductToValues a where
127225
128226--------------------------------------------------------------------------------
129227
130−class GObject f where
131− gObject :: Options -> f a -> Object
228+class GObjectWithSingleField f where
229+ gObjectWithSingleField :: Options -> f a -> Object
132230
133−instance (GObject a, GObject b) => GObject (a :+: b) where
134− gObject opts (L1 x) = gObject opts x
135− gObject opts (R1 x) = gObject opts x
136− {-# INLINE gObject #-}
231+instance (GObjectWithSingleField a, GObjectWithSingleField b) =>
232+ GObjectWithSingleField (a :+: b) where
233+ gObjectWithSingleField opts (L1 x) = gObjectWithSingleField opts x
234+ gObjectWithSingleField opts (R1 x) = gObjectWithSingleField opts x
235+ {-# INLINE gObjectWithSingleField #-}
137236
138−instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
139− gObject opts = H.singleton (pack $ constructorNameModifier opts
140− $ conName (undefined :: t c a p))
141− . gToJSON opts
142− {-# INLINE gObject #-}
237+instance (Constructor c, GToJSON a, ConsToJSON a) =>
238+ GObjectWithSingleField (C1 c a) where
239+ gObjectWithSingleField opts x =
240+ H.singleton ( pack $ constructorNameModifier opts
241+ $ conName (undefined :: t c a p)
242+ ) $ gToJSON opts x
243+ {-# INLINE gObjectWithSingleField #-}
143244
144245--------------------------------------------------------------------------------
145246-- Generic parseJSON
@@ -295,3 +396,22 @@ instance IsRecord (K1 i c) True
295396instance IsRecord U1 False
296397
297398--------------------------------------------------------------------------------
399+
400+class AllNullary (f :: * -> *) b | f -> b
401+
402+instance (AllNullary a b1, AllNullary c b2, And b1 b2 b3) =>
403+ AllNullary (a :+: c) b3
404+instance AllNullary a b => AllNullary (M1 i c a) b
405+instance AllNullary (a :*: c) False
406+instance AllNullary (K1 i c) False
407+instance AllNullary U1 True
408+
409+class And b1 b2 b3 | b1 b2 -> b3
410+
411+instance And True True True
412+
413+instance And False False False
414+instance And False True False
415+instance And True False False
416+
417+--------------------------------------------------------------------------------