@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE GADTs #-}
@@ -8,6 +9,9 @@ module Data.Swagger.Internal.AesonUtils (
89 -- * Generic functions
910 AesonDefaultValue(..),
1011 sopSwaggerGenericToJSON,
12+#if MIN_VERSION_aeson(0,10,0)
13+ sopSwaggerGenericToEncoding,
14+#endif
1115 sopSwaggerGenericToJSONWithOpts,
1216 sopSwaggerGenericParseJSON,
1317 -- * Options
@@ -26,7 +30,7 @@ import Control.Applicative ((<|>))
2630import Control.Lens (makeLenses, (^.))
2731import Control.Monad (unless)
2832import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
29−import Data.Aeson.Types (Parser)
33+import Data.Aeson.Types (Parser, Pair)
3034import Data.Char (toLower, isUpper)
3135import Data.Text (Text)
3236
@@ -37,6 +41,12 @@ import qualified Data.HashMap.Strict as HM
3741import qualified Data.Set as Set
3842import qualified Data.HashMap.Strict.InsOrd as InsOrd
3943
44+#if MIN_VERSION_aeson(0,10,0)
45+import Data.Aeson (Encoding, pairs, (.=), Series)
46+import Data.Monoid ((<>))
47+import Data.Foldable (foldMap)
48+#endif
49+
4050-------------------------------------------------------------------------------
4151-- SwaggerAesonOptions
4252-------------------------------------------------------------------------------
@@ -132,7 +142,7 @@ sopSwaggerGenericToJSON'
132142 -> SOP I '[xs]
133143 -> DatatypeInfo '[xs]
134144 -> POP Maybe '[xs]
135− -> [(Text, Value)]
145+ -> [Pair]
136146sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
137147 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
138148
@@ -142,10 +152,10 @@ sopSwaggerGenericToJSON''
142152 -> NP I xs
143153 -> NP FieldInfo xs
144154 -> NP Maybe xs
145− -> [(Text, Value)]
155+ -> [Pair]
146156sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
147157 where
148− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [(Text, Value)]
158+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
149159 go Nil Nil Nil = []
150160 go (I x :* xs) (FieldInfo name :* names) (def :* defs)
151161 | Just name' == sub = case json of
@@ -240,3 +250,72 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
240250 modifier = lowerFirstUppers . drop (length prefix)
241251 lowerFirstUppers s = map toLower x ++ y
242252 where (x, y) = span isUpper s
253+
254+-------------------------------------------------------------------------------
255+-- ToEncoding
256+-------------------------------------------------------------------------------
257+
258+#if MIN_VERSION_aeson(0,10,0)
259+
260+sopSwaggerGenericToEncoding
261+ :: forall a xs.
262+ ( Generic a
263+ , HasDatatypeInfo a
264+ , HasSwaggerAesonOptions a
265+ , All2 ToJSON (Code a)
266+ , All2 Eq (Code a)
267+ , Code a ~ '[xs]
268+ )
269+ => a
270+ -> Encoding
271+sopSwaggerGenericToEncoding x =
272+ let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
273+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
274+ where
275+ proxy = Proxy :: Proxy a
276+ opts = swaggerAesonOptions proxy
277+
278+pairsToSeries :: [Pair] -> Series
279+pairsToSeries = foldMap (\(k, v) -> (k .= v))
280+
281+sopSwaggerGenericToEncoding'
282+ :: (All2 ToJSON '[xs], All2 Eq '[xs])
283+ => SwaggerAesonOptions
284+ -> SOP I '[xs]
285+ -> DatatypeInfo '[xs]
286+ -> POP Maybe '[xs]
287+ -> Series
288+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
289+ sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
290+
291+sopSwaggerGenericToEncoding''
292+ :: (All ToJSON xs, All Eq xs)
293+ => SwaggerAesonOptions
294+ -> NP I xs
295+ -> NP FieldInfo xs
296+ -> NP Maybe xs
297+ -> Series
298+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
299+ where
300+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
301+ go Nil Nil Nil = mempty
302+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)
303+ | Just name' == sub = case toJSON x of
304+ Object m -> pairsToSeries (HM.toList m) <> rest
305+ Null -> rest
306+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
307+ -- If default value: omit it.
308+ | Just x == def =
309+ rest
310+ | otherwise =
311+ (T.pack name' .= x) <> rest
312+ where
313+ name' = fieldNameModifier name
314+ rest = go xs names defs
315+
316+ fieldNameModifier = modifier . drop 1
317+ modifier = lowerFirstUppers . drop (length prefix)
318+ lowerFirstUppers s = map toLower x ++ y
319+ where (x, y) = span isUpper s
320+
321+#endif