git.iko.soy/typeable/aeson
on master help sign in
Parameterize the gParseJSON and gToJSON with encoding Options
2e9f2faBas van Dijk
Data/Aeson.hs+7
compare with master
unifiedsplit
@@ -1,3 +1,5 @@
1+{-# LANGUAGE CPP #-}
2+
1-- |
3-- |
2-- Module: Data.Aeson
4-- Module: Data.Aeson
3-- Copyright: (c) 2011, 2012 Bryan O'Sullivan
5-- Copyright: (c) 2011, 2012 Bryan O'Sullivan
@@ -49,6 +51,11 @@ module Data.Aeson
49 , Result(..)
51 , Result(..)
50 , fromJSON
52 , fromJSON
51 , ToJSON(..)
53 , ToJSON(..)
54+#ifdef GENERICS
55+ -- ** Generic JSON classes
56+ , GFromJSON(..)
57+ , GToJSON(..)
58+#endif
52 -- * Inspecting @'Value's@
59 -- * Inspecting @'Value's@
53 , withObject
60 , withObject
54 , withText
61 , withText
Data/Aeson/TH.hs+10−71
@@ -59,8 +59,10 @@ $('deriveJSON' 'defaultOptions' ''(,,,))
59-}
59-}
60
60
61module Data.Aeson.TH
61module Data.Aeson.TH
62+ ( -- * Encoding configuration
62− ( Options(..), SumEncoding(..), defaultOptions, defaultObjectWithType
63+ Options(..), SumEncoding(..), defaultOptions, defaultObjectWithType
63
64
65+ -- * FromJSON and ToJSON derivation
64 , deriveJSON
66 , deriveJSON
65
67
66 , deriveToJSON
68 , deriveToJSON
@@ -79,13 +81,18 @@ import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
79 , ToJSON, toJSON
81 , ToJSON, toJSON
80 , FromJSON, parseJSON
82 , FromJSON, parseJSON
81 )
83 )
82−import Data.Aeson.Types ( Value(..), Parser )
84+import Data.Aeson.Types ( Value(..), Parser
85+ , Options(..)
86+ , SumEncoding(..)
87+ , defaultOptions
88+ , defaultObjectWithType
89+ )
83-- from base:
90-- from base:
84import Control.Applicative ( pure, (<$>), (<*>) )
91import Control.Applicative ( pure, (<$>), (<*>) )
85import Control.Monad ( return, mapM, liftM2, fail )
92import Control.Monad ( return, mapM, liftM2, fail )
86import Data.Bool ( Bool(False, True), otherwise, (&&) )
93import Data.Bool ( Bool(False, True), otherwise, (&&) )
87import Data.Eq ( (==) )
94import Data.Eq ( (==) )
88−import Data.Function ( ($), (.), id )
95+import Data.Function ( ($), (.) )
89import Data.Functor ( fmap )
96import Data.Functor ( fmap )
90import Data.Int ( Int )
97import Data.Int ( Int )
91import Data.Either ( Either(Left, Right) )
98import Data.Either ( Either(Left, Right) )
@@ -112,74 +119,6 @@ import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList
112import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
119import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
113
120
114
121
115−--------------------------------------------------------------------------------
116−-- Configuration
117−--------------------------------------------------------------------------------
118−
119−-- | Options that specify how to encode your datatype to JSON.
120−data Options = Options
121− { fieldNameModifier :: String -> String
122− -- ^ Function applied to field names.
123− -- Handy for removing common record prefixes for example.
124− , constructorNameModifier :: String -> String
125− -- ^ Function applied to constructor names.
126− -- Handy for lower-casing constructor names for example.
127− , nullaryToString :: Bool
128− -- ^ If 'True' the constructors of a datatypes, with all nullary
129− -- constructors, will be encoded to a string with the
130− -- constructor name. If 'False' the encoding will always follow
131− -- the `sumEncoding`.
132− , sumEncoding :: SumEncoding
133− -- ^ Specifies how to encode constructors of a sum datatype.
134− }
135−
136−-- | Specifies how to encode constructors of a sum datatype.
137−data SumEncoding =
138− TwoElemArray -- ^ A constructor will be encoded to a 2-element
139− -- array where the first element is the name of the
140− -- constructor (modified by the
141− -- 'constructorNameModifier') and the second element
142− -- the content of the constructor.
143− | ObjectWithType { typeFieldName :: String
144− , valueFieldName :: String
145− }
146− -- ^ A constructor will be encoded to an object with a field
147− -- 'typeFieldName' which specifies the constructor name (modified
148− -- by the 'constructorNameModifier'). If the constructor is not a
149− -- record the constructor content will be stored under the
150− -- 'valueFieldName' field.
151− | ObjectWithSingleField
152− -- ^ A constructor will be encoded to an object with a single
153− -- field named after the constructor (modified by the
154− -- 'constructorNameModifier') and the value will be the contents
155− -- of the constructor.
156−
157−-- | Default encoding options which specify to not modify field and
158−-- constructor names, encode the constructors of a datatype with all
159−-- nullary constructors to just strings with the name of the
160−-- constructor and use a 2-element array for other sum datatypes.
161−defaultOptions :: Options
162−defaultOptions = Options
163− { fieldNameModifier = id
164− , constructorNameModifier = id
165− , nullaryToString = True
166− , sumEncoding = TwoElemArray
167− }
168−
169−-- | Note that:
170−--
171−-- @
172−-- defaultObjectWithType = 'ObjectWithType'
173−-- { 'typeFieldName' = \"type\"
174−-- , 'valueFieldName' = \"value\"
175−-- }
176−-- @
177−defaultObjectWithType :: SumEncoding
178−defaultObjectWithType = ObjectWithType
179− { typeFieldName = "type"
180− , valueFieldName = "value"
181− }
182−
183--------------------------------------------------------------------------------
122--------------------------------------------------------------------------------
184-- Convenience
123-- Convenience
185--------------------------------------------------------------------------------
124--------------------------------------------------------------------------------
Data/Aeson/Types.hs+12
@@ -34,6 +34,12 @@ module Data.Aeson.Types
34 , ToJSON(..)
34 , ToJSON(..)
35 , modifyFailure
35 , modifyFailure
36
36
37+#ifdef GENERICS
38+ -- ** Generic JSON classes
39+ , GFromJSON(..)
40+ , GToJSON(..)
41+#endif
42+
37 -- * Inspecting @'Value's@
43 -- * Inspecting @'Value's@
38 , withObject
44 , withObject
39 , withText
45 , withText
@@ -47,6 +53,12 @@ module Data.Aeson.Types
47 , (.:?)
53 , (.:?)
48 , (.!=)
54 , (.!=)
49 , object
55 , object
56+
57+ -- * Generic and TH encoding configuration
58+ , Options(..)
59+ , SumEncoding(..)
60+ , defaultOptions
61+ , defaultObjectWithType
50 ) where
62 ) where
51
63
52import Data.Aeson.Types.Class
64import Data.Aeson.Types.Class
Data/Aeson/Types/Class.hs+10−4
@@ -88,11 +88,17 @@ import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
88#ifdef GENERICS
88#ifdef GENERICS
89import GHC.Generics
89import GHC.Generics
90
90
91+-- | Class of generic representation types ('Rep') that can be converted to JSON.
91class GToJSON f where
92class GToJSON f where
93+ -- | This method (applied to 'defaultOptions') is used as the
94+ -- default generic implementation of 'toJSON'.
92− gToJSON :: f a -> Value
95+ gToJSON :: Options -> f a -> Value
93
96
97+-- | Class of generic representation types ('Rep') that can be converted from JSON.
94class GFromJSON f where
98class GFromJSON f where
99+ -- | This method (applied to 'defaultOptions') is used as the
100+ -- default generic implementation of 'parseJSON'.
95− gParseJSON :: Value -> Parser (f a)
101+ gParseJSON :: Options -> Value -> Parser (f a)
96#endif
102#endif
97
103
98-- | A type that can be converted to JSON.
104-- | A type that can be converted to JSON.
@@ -143,7 +149,7 @@ class ToJSON a where
143
149
144#ifdef GENERICS
150#ifdef GENERICS
145 default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
151 default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
146− toJSON = gToJSON . from
152+ toJSON = gToJSON defaultOptions . from
147#endif
153#endif
148
154
149-- | A type that can be converted from JSON, with the possibility of
155-- | A type that can be converted from JSON, with the possibility of
@@ -204,7 +210,7 @@ class FromJSON a where
204
210
205#ifdef GENERICS
211#ifdef GENERICS
206 default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
212 default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
207− parseJSON = fmap to . gParseJSON
213+ parseJSON = fmap to . gParseJSON defaultOptions
208#endif
214#endif
209
215
210instance (ToJSON a) => ToJSON (Maybe a) where
216instance (ToJSON a) => ToJSON (Maybe a) where
Data/Aeson/Types/Generic.hs+74−53
@@ -35,49 +35,50 @@ import qualified Data.Vector.Mutable as VM
35-- Generic toJSON
35-- Generic toJSON
36
36
37instance (GToJSON a) => GToJSON (M1 i c a) where
37instance (GToJSON a) => GToJSON (M1 i c a) where
38− gToJSON = gToJSON . unM1
38+ gToJSON opts = gToJSON opts . unM1
39 {-# INLINE gToJSON #-}
39 {-# INLINE gToJSON #-}
40
40
41instance (ToJSON a) => GToJSON (K1 i a) where
41instance (ToJSON a) => GToJSON (K1 i a) where
42− gToJSON = toJSON . unK1
42+ gToJSON _opts = toJSON . unK1
43 {-# INLINE gToJSON #-}
43 {-# INLINE gToJSON #-}
44
44
45instance GToJSON U1 where
45instance GToJSON U1 where
46− gToJSON _ = emptyArray
46+ gToJSON _opts _ = emptyArray
47 {-# INLINE gToJSON #-}
47 {-# INLINE gToJSON #-}
48
48
49instance (ConsToJSON a) => GToJSON (C1 c a) where
49instance (ConsToJSON a) => GToJSON (C1 c a) where
50− gToJSON = consToJSON . unM1
50+ gToJSON opts = consToJSON opts . unM1
51 {-# INLINE gToJSON #-}
51 {-# INLINE gToJSON #-}
52
52
53instance ( GProductToValues a, GProductToValues b
53instance ( GProductToValues a, GProductToValues b
54 , ProductSize a, ProductSize b) => GToJSON (a :*: b) where
54 , ProductSize a, ProductSize b) => GToJSON (a :*: b) where
55+ gToJSON opts p =
55− gToJSON p = Array $ V.create $ do
56+ Array $ V.create $ do
56− mv <- VM.unsafeNew lenProduct
57+ mv <- VM.unsafeNew lenProduct
57− gProductToValues mv 0 lenProduct p
58+ gProductToValues opts mv 0 lenProduct p
58− return mv
59+ return mv
59 where
60 where
60 lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
61 lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
61 {-# INLINE gToJSON #-}
62 {-# INLINE gToJSON #-}
62
63
63instance (GObject a, GObject b) => GToJSON (a :+: b) where
64instance (GObject a, GObject b) => GToJSON (a :+: b) where
64− gToJSON (L1 x) = Object $ gObject x
65+ gToJSON opts (L1 x) = Object $ gObject opts x
65− gToJSON (R1 x) = Object $ gObject x
66+ gToJSON opts (R1 x) = Object $ gObject opts x
66 {-# INLINE gToJSON #-}
67 {-# INLINE gToJSON #-}
67
68
68--------------------------------------------------------------------------------
69--------------------------------------------------------------------------------
69
70
70−class ConsToJSON f where consToJSON :: f a -> Value
71+class ConsToJSON f where consToJSON :: Options -> f a -> Value
71−class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
72+class ConsToJSON' b f where consToJSON' :: Tagged b (Options -> f a -> Value)
72
73
73newtype Tagged s b = Tagged {unTagged :: b}
74newtype Tagged s b = Tagged {unTagged :: b}
74
75
75instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
76instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
76− consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
77+ consToJSON = unTagged (consToJSON' :: Tagged b (Options -> f a -> Value))
77 {-# INLINE consToJSON #-}
78 {-# INLINE consToJSON #-}
78
79
79instance (GRecordToPairs f) => ConsToJSON' True f where
80instance (GRecordToPairs f) => ConsToJSON' True f where
80− consToJSON' = Tagged (object . toList . gRecordToPairs)
81+ consToJSON' = Tagged (\opts -> object . toList . gRecordToPairs opts)
81 {-# INLINE consToJSON' #-}
82 {-# INLINE consToJSON' #-}
82
83
83instance GToJSON f => ConsToJSON' False f where
84instance GToJSON f => ConsToJSON' False f where
@@ -87,24 +88,33 @@ instance GToJSON f => ConsToJSON' False f where
87--------------------------------------------------------------------------------
88--------------------------------------------------------------------------------
88
89
89class GRecordToPairs f where
90class GRecordToPairs f where
90− gRecordToPairs :: f a -> DList Pair
91+ gRecordToPairs :: Options -> f a -> DList Pair
91
92
92instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
93instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
93− gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b
94+ gRecordToPairs opts (a :*: b) = gRecordToPairs opts a `mappend`
95+ gRecordToPairs opts b
94 {-# INLINE gRecordToPairs #-}
96 {-# INLINE gRecordToPairs #-}
95
97
96instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
98instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
97− gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1))
99+ gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
100+ , gToJSON opts (unM1 m1)
101+ )
98 {-# INLINE gRecordToPairs #-}
102 {-# INLINE gRecordToPairs #-}
99
103
100--------------------------------------------------------------------------------
104--------------------------------------------------------------------------------
101
105
102class GProductToValues f where
106class GProductToValues f where
107+ gProductToValues :: Options
103− gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s ()
108+ -> VM.MVector s Value
109+ -> Int -- ^ index
110+ -> Int -- ^ length
111+ -> f a
112+ -> ST s ()
104
113
105instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
114instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
106− gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix lenL a
115+ gProductToValues opts mv ix len (a :*: b) = do
116+ gProductToValues opts mv ix lenL a
107− gProductToValues mv ixR lenR b
117+ gProductToValues opts mv ixR lenR b
108 where
118 where
109 lenL = len `shiftR` 1
119 lenL = len `shiftR` 1
110 ixR = ix + lenL
120 ixR = ix + lenL
@@ -112,48 +122,50 @@ instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b)
112 {-# INLINE gProductToValues #-}
122 {-# INLINE gProductToValues #-}
113
123
114instance (GToJSON a) => GProductToValues a where
124instance (GToJSON a) => GProductToValues a where
115− gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON
125+ gProductToValues opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
116 {-# INLINE gProductToValues #-}
126 {-# INLINE gProductToValues #-}
117
127
118--------------------------------------------------------------------------------
128--------------------------------------------------------------------------------
119
129
120class GObject f where
130class GObject f where
121− gObject :: f a -> Object
131+ gObject :: Options -> f a -> Object
122
132
123instance (GObject a, GObject b) => GObject (a :+: b) where
133instance (GObject a, GObject b) => GObject (a :+: b) where
124− gObject (L1 x) = gObject x
134+ gObject opts (L1 x) = gObject opts x
125− gObject (R1 x) = gObject x
135+ gObject opts (R1 x) = gObject opts x
126 {-# INLINE gObject #-}
136 {-# INLINE gObject #-}
127
137
128instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
138instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
139+ gObject opts = H.singleton (pack $ constructorNameModifier opts
129− gObject = H.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
140+ $ conName (undefined :: t c a p))
141+ . gToJSON opts
130 {-# INLINE gObject #-}
142 {-# INLINE gObject #-}
131
143
132--------------------------------------------------------------------------------
144--------------------------------------------------------------------------------
133-- Generic parseJSON
145-- Generic parseJSON
134
146
135instance (GFromJSON a) => GFromJSON (M1 i c a) where
147instance (GFromJSON a) => GFromJSON (M1 i c a) where
136− gParseJSON = fmap M1 . gParseJSON
148+ gParseJSON opts = fmap M1 . gParseJSON opts
137 {-# INLINE gParseJSON #-}
149 {-# INLINE gParseJSON #-}
138
150
139instance (FromJSON a) => GFromJSON (K1 i a) where
151instance (FromJSON a) => GFromJSON (K1 i a) where
140− gParseJSON = fmap K1 . parseJSON
152+ gParseJSON _opts = fmap K1 . parseJSON
141 {-# INLINE gParseJSON #-}
153 {-# INLINE gParseJSON #-}
142
154
143instance GFromJSON U1 where
155instance GFromJSON U1 where
144− gParseJSON v
156+ gParseJSON _opts v
145 | isEmptyArray v = pure U1
157 | isEmptyArray v = pure U1
146 | otherwise = typeMismatch "unit constructor (U1)" v
158 | otherwise = typeMismatch "unit constructor (U1)" v
147 {-# INLINE gParseJSON #-}
159 {-# INLINE gParseJSON #-}
148
160
149instance (ConsFromJSON a) => GFromJSON (C1 c a) where
161instance (ConsFromJSON a) => GFromJSON (C1 c a) where
150− gParseJSON = fmap M1 . consParseJSON
162+ gParseJSON opts = fmap M1 . consParseJSON opts
151 {-# INLINE gParseJSON #-}
163 {-# INLINE gParseJSON #-}
152
164
153instance ( GFromProduct a, GFromProduct b
165instance ( GFromProduct a, GFromProduct b
154 , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
166 , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
155− gParseJSON (Array arr)
167+ gParseJSON opts (Array arr)
156− | lenArray == lenProduct = gParseProduct arr 0 lenProduct
168+ | lenArray == lenProduct = gParseProduct opts arr 0 lenProduct
157 | otherwise =
169 | otherwise =
158 fail $ "When expecting a product of " ++ show lenProduct ++
170 fail $ "When expecting a product of " ++ show lenProduct ++
159 " values, encountered an Array of " ++ show lenArray ++
171 " values, encountered an Array of " ++ show lenArray ++
@@ -162,15 +174,15 @@ instance ( GFromProduct a, GFromProduct b
162 lenArray = V.length arr
174 lenArray = V.length arr
163 lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
175 lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
164
176
165− gParseJSON v = typeMismatch "product (:*:)" v
177+ gParseJSON _opts v = typeMismatch "product (:*:)" v
166 {-# INLINE gParseJSON #-}
178 {-# INLINE gParseJSON #-}
167
179
168instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
180instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
169− gParseJSON (Object (H.toList -> [keyVal@(key, _)])) =
181+ gParseJSON opts (Object (H.toList -> [keyVal@(key, _)])) =
170− case gParseSum keyVal of
182+ case gParseSum opts keyVal of
171 Nothing -> notFound $ unpack key
183 Nothing -> notFound $ unpack key
172 Just p -> p
184 Just p -> p
173− gParseJSON v = typeMismatch "sum (:+:)" v
185+ gParseJSON _opts v = typeMismatch "sum (:+:)" v
174 {-# INLINE gParseJSON #-}
186 {-# INLINE gParseJSON #-}
175
187
176notFound :: String -> Parser a
188notFound :: String -> Parser a
@@ -179,18 +191,21 @@ notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
179
191
180--------------------------------------------------------------------------------
192--------------------------------------------------------------------------------
181
193
182−class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
194+class ConsFromJSON f where
195+ consParseJSON :: Options -> Value -> Parser (f a)
196+class ConsFromJSON' b f where
183−class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
197+ consParseJSON' :: Tagged b (Options -> Value -> Parser (f a))
184
198
185instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
199instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
200+ consParseJSON =
186− consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
201+ unTagged (consParseJSON' :: Tagged b (Options -> Value -> Parser (f a)))
187 {-# INLINE consParseJSON #-}
202 {-# INLINE consParseJSON #-}
188
203
189instance (GFromRecord f) => ConsFromJSON' True f where
204instance (GFromRecord f) => ConsFromJSON' True f where
190 consParseJSON' = Tagged parseRecord
205 consParseJSON' = Tagged parseRecord
191 where
206 where
192− parseRecord (Object obj) = gParseRecord obj
207+ parseRecord opts (Object obj) = gParseRecord opts obj
193− parseRecord v = typeMismatch "record (:*:)" v
208+ parseRecord _opts v = typeMismatch "record (:*:)" v
194 {-# INLINE consParseJSON' #-}
209 {-# INLINE consParseJSON' #-}
195
210
196instance (GFromJSON f) => ConsFromJSON' False f where
211instance (GFromJSON f) => ConsFromJSON' False f where
@@ -200,16 +215,18 @@ instance (GFromJSON f) => ConsFromJSON' False f where
200--------------------------------------------------------------------------------
215--------------------------------------------------------------------------------
201
216
202class GFromRecord f where
217class GFromRecord f where
203− gParseRecord :: Object -> Parser (f a)
218+ gParseRecord :: Options -> Object -> Parser (f a)
204
219
205instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
220instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
206− gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
221+ gParseRecord opts obj = (:*:) <$> gParseRecord opts obj
222+ <*> gParseRecord opts obj
207 {-# INLINE gParseRecord #-}
223 {-# INLINE gParseRecord #-}
208
224
209instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
225instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
210− gParseRecord = maybe (notFound key) gParseJSON . H.lookup (T.pack key)
226+ gParseRecord opts = maybe (notFound key) (gParseJSON opts)
227+ . H.lookup (T.pack key)
211 where
228 where
212− key = selName (undefined :: t s a p)
229+ key = fieldNameModifier opts $ selName (undefined :: t s a p)
213 {-# INLINE gParseRecord #-}
230 {-# INLINE gParseRecord #-}
214
231
215--------------------------------------------------------------------------------
232--------------------------------------------------------------------------------
@@ -229,11 +246,12 @@ instance ProductSize (S1 s a) where
229--------------------------------------------------------------------------------
246--------------------------------------------------------------------------------
230
247
231class GFromProduct f where
248class GFromProduct f where
232− gParseProduct :: Array -> Int -> Int -> Parser (f a)
249+ gParseProduct :: Options -> Array -> Int -> Int -> Parser (f a)
233
250
234instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
251instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
252+ gParseProduct opts arr ix len =
235− gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL
253+ (:*:) <$> gParseProduct opts arr ix lenL
236− <*> gParseProduct arr ixR lenR
254+ <*> gParseProduct opts arr ixR lenR
237 where
255 where
238 lenL = len `shiftR` 1
256 lenL = len `shiftR` 1
239 ixR = ix + lenL
257 ixR = ix + lenL
@@ -241,22 +259,25 @@ instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
241 {-# INLINE gParseProduct #-}
259 {-# INLINE gParseProduct #-}
242
260
243instance (GFromJSON a) => GFromProduct (S1 s a) where
261instance (GFromJSON a) => GFromProduct (S1 s a) where
244− gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix
262+ gParseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
245 {-# INLINE gParseProduct #-}
263 {-# INLINE gParseProduct #-}
246
264
247--------------------------------------------------------------------------------
265--------------------------------------------------------------------------------
248
266
249class GFromSum f where
267class GFromSum f where
250− gParseSum :: Pair -> Maybe (Parser (f a))
268+ gParseSum :: Options -> Pair -> Maybe (Parser (f a))
251
269
252instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
270instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
253− gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>
271+ gParseSum opts keyVal = (fmap L1 <$> gParseSum opts keyVal) <|>
254− (fmap R1 <$> gParseSum keyVal)
272+ (fmap R1 <$> gParseSum opts keyVal)
255 {-# INLINE gParseSum #-}
273 {-# INLINE gParseSum #-}
256
274
257instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
275instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
258− gParseSum (key, value)
276+ gParseSum opts (key, value)
277+ | key == pack ( constructorNameModifier opts
259− | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value
278+ $ conName (undefined :: t c a p)
279+ )
280+ = Just $ gParseJSON opts value
260 | otherwise = Nothing
281 | otherwise = Nothing
261 {-# INLINE gParseSum #-}
282 {-# INLINE gParseSum #-}
262
283
Data/Aeson/Types/Internal.hs+74
@@ -29,6 +29,12 @@ module Data.Aeson.Types.Internal
29 , modifyFailure
29 , modifyFailure
30 -- * Constructors and accessors
30 -- * Constructors and accessors
31 , object
31 , object
32+
33+ -- * Generic and TH encoding configuration
34+ , Options(..)
35+ , SumEncoding(..)
36+ , defaultOptions
37+ , defaultObjectWithType
32 ) where
38 ) where
33
39
34import Control.Applicative
40import Control.Applicative
@@ -238,3 +244,71 @@ object = Object . H.fromList
238-- Since 0.6.2.0
244-- Since 0.6.2.0
239modifyFailure :: (String -> String) -> Parser a -> Parser a
245modifyFailure :: (String -> String) -> Parser a -> Parser a
240modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
246modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
247+
248+--------------------------------------------------------------------------------
249+-- Generic and TH encoding configuration
250+--------------------------------------------------------------------------------
251+
252+-- | Options that specify how to encode your datatype to JSON.
253+data Options = Options
254+ { fieldNameModifier :: String -> String
255+ -- ^ Function applied to field names.
256+ -- Handy for removing common record prefixes for example.
257+ , constructorNameModifier :: String -> String
258+ -- ^ Function applied to constructor names.
259+ -- Handy for lower-casing constructor names for example.
260+ , nullaryToString :: Bool
261+ -- ^ If 'True' the constructors of a datatypes, with all nullary
262+ -- constructors, will be encoded to a string with the
263+ -- constructor name. If 'False' the encoding will always follow
264+ -- the `sumEncoding`.
265+ , sumEncoding :: SumEncoding
266+ -- ^ Specifies how to encode constructors of a sum datatype.
267+ }
268+
269+-- | Specifies how to encode constructors of a sum datatype.
270+data SumEncoding =
271+ TwoElemArray -- ^ A constructor will be encoded to a 2-element
272+ -- array where the first element is the name of the
273+ -- constructor (modified by the
274+ -- 'constructorNameModifier') and the second element
275+ -- the content of the constructor.
276+ | ObjectWithType { typeFieldName :: String
277+ , valueFieldName :: String
278+ }
279+ -- ^ A constructor will be encoded to an object with a field
280+ -- 'typeFieldName' which specifies the constructor name (modified
281+ -- by the 'constructorNameModifier'). If the constructor is not a
282+ -- record the constructor content will be stored under the
283+ -- 'valueFieldName' field.
284+ | ObjectWithSingleField
285+ -- ^ A constructor will be encoded to an object with a single
286+ -- field named after the constructor (modified by the
287+ -- 'constructorNameModifier') and the value will be the contents
288+ -- of the constructor.
289+
290+-- | Default encoding options which specify to not modify field and
291+-- constructor names, encode the constructors of a datatype with all
292+-- nullary constructors to just strings with the name of the
293+-- constructor and use a 2-element array for other sum datatypes.
294+defaultOptions :: Options
295+defaultOptions = Options
296+ { fieldNameModifier = id
297+ , constructorNameModifier = id
298+ , nullaryToString = True
299+ , sumEncoding = TwoElemArray
300+ }
301+
302+-- | Note that:
303+--
304+-- @
305+-- defaultObjectWithType = 'ObjectWithType'
306+-- { 'typeFieldName' = \"type\"
307+-- , 'valueFieldName' = \"value\"
308+-- }
309+-- @
310+defaultObjectWithType :: SumEncoding
311+defaultObjectWithType = ObjectWithType
312+ { typeFieldName = "type"
313+ , valueFieldName = "value"
314+ }