Skip to content
This repository

Add support for specifying how to encode datatypes in Data.Aeson.TH #97

Merged
merged 1 commit into from over 1 year ago

2 participants

Bas van Dijk Bryan O'Sullivan
Bas van Dijk
Collaborator

Fixes #68 and #66.

I've been using this module for some time now at Erudify.

@roelvandijk since you wrote the original TH code can you take a look at this. I removed the examples of the generated ToJSON and FromJSON instances from the documentation since they were not correct anymore. I don't have time right now to fix them but maybe you have.

Bryan O'Sullivan bos merged commit 4607d7d into from January 02, 2013
Bryan O'Sullivan bos closed this January 02, 2013
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment

Showing 1 unique commit by 1 author.

Dec 08, 2012
Bas van Dijk Add support for specifying how to encode datatypes in Data.Aeson.TH
Fixes #68 and fixes #66.
2dff7be
This page is out of date. Refresh to see the latest.

Showing 1 changed file with 430 additions and 361 deletions. Show diff stats Hide diff stats

  1. 791  Data/Aeson/TH.hs
791  Data/Aeson/TH.hs
... ...
@@ -1,4 +1,11 @@
1  
-{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}
  1
+{-# LANGUAGE CPP
  2
+           , NoImplicitPrelude
  3
+           , TemplateHaskell
  4
+           , NamedFieldPuns
  5
+           , FlexibleInstances
  6
+           , UndecidableInstances
  7
+           , OverlappingInstances
  8
+  #-}
2 9
 
3 10
 {-|
4 11
 Module:      Data.Aeson.TH
@@ -30,91 +37,9 @@ change record field names. In this case we drop the first 4 characters of every
30 37
 field name.
31 38
 
32 39
 @
33  
-$('deriveJSON' ('drop' 4) ''D)
  40
+$('deriveJSON' 'defaultOptions'{'fieldNameModifier' = 'drop' 4} ''D)
34 41
 @
35 42
 
36  
-This will result in the following (simplified) code to be spliced in your program:
37  
-
38  
-@
39  
-import Control.Applicative
40  
-import Control.Monad
41  
-import Data.Aeson
42  
-import Data.Aeson.TH
43  
-import qualified Data.HashMap.Strict as H
44  
-import qualified Data.Text as T
45  
-import qualified Data.Vector as V
46  
-
47  
-instance 'ToJSON' a => 'ToJSON' (D a) where
48  
-    'toJSON' =
49  
-      \\value ->
50  
-        case value of
51  
-          Nullary ->
52  
-              'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])]
53  
-          Unary arg1 ->
54  
-              'object' [T.pack \"Unary\" .= 'toJSON' arg1]
55  
-          Product arg1 arg2 arg3 ->
56  
-              'object' [ T.pack \"Product\"
57  
-                       .= ('Array' $ 'V.create' $ do
58  
-                             mv <- 'VM.unsafeNew' 3
59  
-                             'VM.unsafeWrite' mv 0 ('toJSON' arg1)
60  
-                             'VM.unsafeWrite' mv 1 ('toJSON' arg2)
61  
-                             'VM.unsafeWrite' mv 2 ('toJSON' arg3)
62  
-                             return mv)
63  
-                     ]
64  
-          Record arg1 arg2 arg3 ->
65  
-              'object' [ T.pack \"Record\"
66  
-                       .= 'object' [ T.pack \"One\"   '.=' arg1
67  
-                                 , T.pack \"Two\"   '.=' arg2
68  
-                                 , T.pack \"Three\" '.=' arg3
69  
-                                 ]
70  
-                     ]
71  
-@
72  
-
73  
-@
74  
-instance 'FromJSON' a => 'FromJSON' (D a) where
75  
-    'parseJSON' =
76  
-      \\value ->
77  
-        case value of
78  
-          'Object' obj ->
79  
-            case H.toList obj of
80  
-              [(conKey, conVal)] ->
81  
-                case conKey of
82  
-                  _ | conKey == T.pack \"Nullary\" ->
83  
-                        case conVal of
84  
-                          'Array' arr ->
85  
-                            if V.null arr
86  
-                            then pure Nullary
87  
-                            else fail \"\<error message\>\"
88  
-                          _ -> fail \"\<error message\>\"
89  
-                    | conKey == T.pack \"Unary\" ->
90  
-                        case conVal of
91  
-                          arg -> Unary \<$\> parseJSON arg
92  
-                    | conKey == T.pack \"Product\" ->
93  
-                        case conVal of
94  
-                          'Array' arr ->
95  
-                            if V.length arr == 3
96  
-                            then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
97  
-                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
98  
-                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)
99  
-                            else fail \"\<error message\>\"
100  
-                          _ -> fail \"\<error message\>\"
101  
-                    | conKey == T.pack \"Record\" ->
102  
-                        case conVal of
103  
-                          'Object' recObj ->
104  
-                            if H.size recObj == 3
105  
-                            then Record \<$\> recObj '.:' T.pack \"One\"
106  
-                                        \<*\> recObj '.:' T.pack \"Two\"
107  
-                                        \<*\> recObj '.:' T.pack \"Three\"
108  
-                            else fail \"\<error message\>\"
109  
-                          _ -> fail \"\<error message\>\"
110  
-                    | otherwise -> fail \"\<error message\>\"
111  
-              _ -> fail \"\<error message\>\"
112  
-          _ -> fail \"\<error message\>\"
113  
-@
114  
-
115  
-Note that every \"\<error message\>\" is in fact a descriptive message which
116  
-provides as much information as is reasonable about the failed parse.
117  
-
118 43
 Now we can use the newly created instances.
119 44
 
120 45
 @
@@ -132,13 +57,15 @@ Please note that you can derive instances for tuples using the following syntax:
132 57
 
133 58
 @
134 59
 -- FromJSON and ToJSON instances for 4-tuples.
135  
-$('deriveJSON' id ''(,,,))
  60
+$('deriveJSON' 'defaultOptions' ''(,,,))
136 61
 @
137 62
 
138 63
 -}
139 64
 
140 65
 module Data.Aeson.TH
141  
-    ( deriveJSON
  66
+    ( Options(..), SumEncoding(..), defaultOptions
  67
+
  68
+    , deriveJSON
142 69
 
143 70
     , deriveToJSON
144 71
     , deriveFromJSON
@@ -152,7 +79,7 @@ module Data.Aeson.TH
152 79
 --------------------------------------------------------------------------------
153 80
 
154 81
 -- from aeson:
155  
-import Data.Aeson ( toJSON, Object, object, (.=)
  82
+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
156 83
                   , ToJSON, toJSON
157 84
                   , FromJSON, parseJSON
158 85
                   )
@@ -160,12 +87,14 @@ import Data.Aeson.Types ( Value(..), Parser )
160 87
 -- from base:
161 88
 import Control.Applicative ( pure, (<$>), (<*>) )
162 89
 import Control.Monad       ( return, mapM, liftM2, fail )
163  
-import Data.Bool           ( otherwise )
  90
+import Data.Bool           ( Bool(False, True), otherwise, (&&) )
164 91
 import Data.Eq             ( (==) )
165  
-import Data.Function       ( ($), (.), id )
  92
+import Data.Function       ( ($), (.), id, const )
166 93
 import Data.Functor        ( fmap )
  94
+import Data.Int            ( Int )
  95
+import Data.Either         ( Either(Left, Right), either )
167 96
 import Data.List           ( (++), foldl, foldl', intercalate
168  
-                           , length, map, zip, genericLength
  97
+                           , length, map, zip, genericLength, all
169 98
                            )
170 99
 import Data.Maybe          ( Maybe(Nothing, Just) )
171 100
 import Prelude             ( String, (-), Integer, fromIntegral, error )
@@ -176,17 +105,61 @@ import Control.Monad       ( (>>=) )
176 105
 import Prelude             ( fromInteger )
177 106
 #endif
178 107
 -- from unordered-containers:
179  
-import qualified Data.HashMap.Strict as H ( lookup, toList, size )
  108
+import qualified Data.HashMap.Strict as H ( lookup )
180 109
 -- from template-haskell:
181 110
 import Language.Haskell.TH
  111
+import Language.Haskell.TH.Syntax ( VarStrictType )
182 112
 -- from text:
183 113
 import qualified Data.Text as T ( Text, pack, unpack )
184 114
 -- from vector:
185  
-import qualified Data.Vector as V ( unsafeIndex, null, length, create )
  115
+import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
186 116
 import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
187 117
 
188 118
 
189 119
 --------------------------------------------------------------------------------
  120
+-- Configuration
  121
+--------------------------------------------------------------------------------
  122
+
  123
+-- | Options that specify how to encode your datatype to JSON.
  124
+data Options = Options
  125
+    { fieldNameModifier :: String -> String
  126
+      -- ^ Function applied to field names.
  127
+      -- Handy for removing common record prefixes for example.
  128
+    , nullaryToString   :: Bool
  129
+      -- ^ If 'True' the constructors of a datatypes, with all nullary
  130
+      -- constructors, will be encoded to a string with the
  131
+      -- constructor name. If 'False' the encoding will always follow
  132
+      -- the `sumEncoding`.
  133
+    , sumEncoding       :: SumEncoding
  134
+      -- ^ Specifies how to encode constructors of a sum datatype.
  135
+    }
  136
+
  137
+-- | Specifies how to encode constructors of a sum datatype.
  138
+data SumEncoding =
  139
+    TwoElemArray -- ^ A constructor will be encoded to a 2-element
  140
+                 -- array where the first element is the name of the
  141
+                 -- constructor and the second element the content of
  142
+                 -- 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. If the
  148
+    -- constructor is not a record the constructor content will be
  149
+    -- stored under the 'valueFieldName' field.
  150
+
  151
+-- | Default encoding options which specify to not modify field names,
  152
+-- encode the constructors of a datatype with all nullary constructors
  153
+-- to just strings with the name of the constructor and use a
  154
+-- 2-element array for other sum datatypes.
  155
+defaultOptions :: Options
  156
+defaultOptions = Options
  157
+                 { fieldNameModifier = id
  158
+                 , nullaryToString   = True
  159
+                 , sumEncoding       = TwoElemArray
  160
+                 }
  161
+
  162
+--------------------------------------------------------------------------------
190 163
 -- Convenience
191 164
 --------------------------------------------------------------------------------
192 165
 
@@ -195,16 +168,16 @@ import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
195 168
 --
196 169
 -- This is a convienience function which is equivalent to calling both
197 170
 -- 'deriveToJSON' and 'deriveFromJSON'.
198  
-deriveJSON :: (String -> String)
199  
-           -- ^ Function to change field names.
  171
+deriveJSON :: Options
  172
+           -- ^ Encoding options.
200 173
            -> Name
201 174
            -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
202 175
            -- instances.
203 176
            -> Q [Dec]
204  
-deriveJSON withField name =
  177
+deriveJSON opts name =
205 178
     liftM2 (++)
206  
-           (deriveToJSON   withField name)
207  
-           (deriveFromJSON withField name)
  179
+           (deriveToJSON   opts name)
  180
+           (deriveFromJSON opts name)
208 181
 
209 182
 
210 183
 --------------------------------------------------------------------------------
@@ -221,33 +194,13 @@ The above (ToJSON a) constraint is not necessary and perhaps undesirable.
221 194
 -}
222 195
 
223 196
 -- | Generates a 'ToJSON' instance declaration for the given data type.
224  
---
225  
--- Example:
226  
---
227  
--- @
228  
--- data Foo = Foo 'Char' 'Int'
229  
--- $('deriveToJSON' 'id' ''Foo)
230  
--- @
231  
---
232  
--- This will splice in the following code:
233  
---
234  
--- @
235  
--- instance 'ToJSON' Foo where
236  
---      'toJSON' =
237  
---          \\value -> case value of
238  
---                      Foo arg1 arg2 -> 'Array' $ 'V.create' $ do
239  
---                        mv <- 'VM.unsafeNew' 2
240  
---                        'VM.unsafeWrite' mv 0 ('toJSON' arg1)
241  
---                        'VM.unsafeWrite' mv 1 ('toJSON' arg2)
242  
---                        return mv
243  
--- @
244  
-deriveToJSON :: (String -> String)
245  
-             -- ^ Function to change field names.
  197
+deriveToJSON :: Options
  198
+             -- ^ Encoding options.
246 199
              -> Name
247 200
              -- ^ Name of the type for which to generate a 'ToJSON' instance
248 201
              -- declaration.
249 202
              -> Q [Dec]
250  
-deriveToJSON withField name =
  203
+deriveToJSON opts name =
251 204
     withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
252 205
   where
253 206
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
@@ -256,7 +209,7 @@ deriveToJSON withField name =
256 209
                   (classType `appT` instanceType)
257 210
                   [ funD 'toJSON
258 211
                          [ clause []
259  
-                                  (normalB $ consToJSON withField cons)
  212
+                                  (normalB $ consToJSON opts cons)
260 213
                                   []
261 214
                          ]
262 215
                   ]
@@ -266,126 +219,145 @@ deriveToJSON withField name =
266 219
         instanceType = foldl' appT (conT name) $ map varT typeNames
267 220
 
268 221
 -- | Generates a lambda expression which encodes the given data type as JSON.
269  
---
270  
--- Example:
271  
---
272  
--- @
273  
--- data Foo = Foo Int
274  
--- @
275  
---
276  
--- @
277  
--- encodeFoo :: Foo -> 'Value'
278  
--- encodeFoo = $('mkToJSON' id ''Foo)
279  
--- @
280  
---
281  
--- This will splice in the following code:
282  
---
283  
--- @
284  
--- \\value -> case value of Foo arg1 -> 'toJSON' arg1
285  
--- @
286  
-mkToJSON :: (String -> String) -- ^ Function to change field names.
  222
+mkToJSON :: Options -- ^ Encoding options.
287 223
          -> Name -- ^ Name of the type to encode.
288 224
          -> Q Exp
289  
-mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
  225
+mkToJSON opts name = withType name (\_ cons -> consToJSON opts cons)
290 226
 
291 227
 -- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code
292 228
 -- to generate the JSON encoding of a number of constructors. All constructors
293 229
 -- must be from the same type.
294  
-consToJSON :: (String -> String)
295  
-           -- ^ Function to change field names.
  230
+consToJSON :: Options
  231
+           -- ^ Encoding options.
296 232
            -> [Con]
297 233
            -- ^ Constructors for which to generate JSON generating code.
298 234
            -> Q Exp
  235
+
299 236
 consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
300 237
                           ++ "Not a single constructor given!"
  238
+
301 239
 -- A single constructor is directly encoded. The constructor itself may be
302 240
 -- forgotten.
303  
-consToJSON withField [con] = do
  241
+consToJSON opts [con] = do
304 242
     value <- newName "value"
305  
-    lam1E (varP value)
306  
-          $ caseE (varE value)
307  
-                  [encodeArgs id withField con]
308  
--- With multiple constructors we need to remember which constructor is
309  
--- encoded. This is done by generating a JSON object which maps to constructor's
310  
--- name to the JSON encoding of its contents.
311  
-consToJSON withField cons = do
  243
+    lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con]
  244
+
  245
+consToJSON opts cons = do
312 246
     value <- newName "value"
313  
-    lam1E (varP value)
314  
-          $ caseE (varE value)
315  
-                  [ encodeArgs (wrap $ getConName con) withField con
316  
-                  | con <- cons
317  
-                  ]
  247
+    lam1E (varP value) $ caseE (varE value) matches
318 248
   where
319  
-    wrap :: Name -> Q Exp -> Q Exp
320  
-    wrap name exp =
321  
-        let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
322  
-        in [e|object|] `appE` listE [ infixApp fieldName
323  
-                                               [e|(.=)|]
324  
-                                               exp
325  
-                                    ]
  249
+    -- Constructors of a datatype with all nullary constructors are encoded to
  250
+    -- just a string with the constructor name:
  251
+    matches | nullaryToString opts && all isNullary cons =
  252
+      [ match (conP conName []) (normalB $ conStr conName) []
  253
+      | con <- cons
  254
+      , let conName = getConName con
  255
+      ]
  256
+      -- Constructors of a datatype having some constructors with arity > 0 are
  257
+      -- encoded to a 2-element array where the first element is a string with
  258
+      -- the constructor name and the second element is the encoded argument or
  259
+      -- arguments of the constructor.
  260
+      | otherwise = [ encodeArgs opts True con
  261
+                    | con <- cons
  262
+                    ]
  263
+
  264
+conStr :: Name -> Q Exp
  265
+conStr = appE [|String|] . appE [|T.pack|] . stringE . nameBase
  266
+
  267
+-- | If constructor is nullary.
  268
+isNullary :: Con -> Bool
  269
+isNullary (NormalC _ []) = True
  270
+isNullary _ = False
  271
+
  272
+encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp
  273
+encodeSum opts multiCons conName exp
  274
+    | multiCons =
  275
+        case sumEncoding opts of
  276
+          TwoElemArray ->
  277
+              [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr conName, exp])
  278
+          ObjectWithType{typeFieldName, valueFieldName} ->
  279
+              [|object|] `appE` listE
  280
+                [ infixApp [|T.pack typeFieldName|]  [|(.=)|] (conStr conName)
  281
+                , infixApp [|T.pack valueFieldName|] [|(.=)|] exp
  282
+                ]
  283
+    | otherwise = exp
326 284
 
327 285
 -- | Generates code to generate the JSON encoding of a single constructor.
328  
-encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
  286
+encodeArgs :: Options -> Bool -> Con -> Q Match
329 287
 -- Nullary constructors. Generates code that explicitly matches against the
330 288
 -- constructor even though it doesn't contain data. This is useful to prevent
331 289
 -- type errors.
332  
-encodeArgs withExp _ (NormalC conName []) =
  290
+encodeArgs  opts multiCons (NormalC conName []) =
333 291
     match (conP conName [])
334  
-          (normalB $ withExp [e|toJSON ([] :: [()])|])
  292
+          (normalB (encodeSum opts multiCons conName [e|toJSON ([] :: [()])|]))
335 293
           []
  294
+
336 295
 -- Polyadic constructors with special case for unary constructors.
337  
-encodeArgs withExp _ (NormalC conName ts) = do
  296
+encodeArgs opts multiCons (NormalC conName ts) = do
338 297
     let len = length ts
339 298
     args <- mapM newName ["arg" ++ show n | n <- [1..len]]
340  
-    js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
  299
+    js <- case [[|toJSON|] `appE` varE arg | arg <- args] of
341 300
             -- Single argument is directly converted.
342 301
             [e] -> return e
343 302
             -- Multiple arguments are converted to a JSON array.
344 303
             es  -> do
345 304
               mv <- newName "mv"
346 305
               let newMV = bindS (varP mv)
347  
-                                ([e|VM.unsafeNew|] `appE`
  306
+                                ([|VM.unsafeNew|] `appE`
348 307
                                   litE (integerL $ fromIntegral len))
349 308
                   stmts = [ noBindS $
350  
-                              [e|VM.unsafeWrite|] `appE`
  309
+                              [|VM.unsafeWrite|] `appE`
351 310
                                 (varE mv) `appE`
352 311
                                   litE (integerL ix) `appE`
353 312
                                     e
354 313
                           | (ix, e) <- zip [(0::Integer)..] es
355 314
                           ]
356  
-                  ret = noBindS $ [e|return|] `appE` varE mv
357  
-              return $ [e|Array|] `appE`
  315
+                  ret = noBindS $ [|return|] `appE` varE mv
  316
+              return $ [|Array|] `appE`
358 317
                          (varE 'V.create `appE`
359 318
                            doE (newMV:stmts++[ret]))
360 319
     match (conP conName $ map varP args)
361  
-          (normalB $ withExp js)
  320
+          (normalB $ encodeSum opts multiCons conName js)
362 321
           []
  322
+
363 323
 -- Records.
364  
-encodeArgs withExp withField (RecC conName ts) = do
  324
+encodeArgs opts multiCons (RecC conName ts) = do
365 325
     args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
366  
-    let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
367  
-                        [e|(.=)|]
  326
+    let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
  327
+                        [|(.=)|]
368 328
                         (varE arg)
369 329
              | (arg, (field, _, _)) <- zip args ts
370 330
              ]
  331
+        exp = [|object|] `appE` listE js
371 332
     match (conP conName $ map varP args)
372  
-          (normalB $ withExp $ [e|object|] `appE` listE js)
373  
-          []
  333
+          ( normalB
  334
+          $ if multiCons
  335
+            then case sumEncoding opts of
  336
+                   TwoElemArray -> [|toJSON|] `appE` tupE [conStr conName, exp]
  337
+                   ObjectWithType{typeFieldName} ->
  338
+                       [|object|] `appE` listE
  339
+                         ( infixApp [|T.pack typeFieldName|] [|(.=)|]
  340
+                                    (conStr conName)
  341
+                         : js
  342
+                         )
  343
+            else exp
  344
+          ) []
  345
+
374 346
 -- Infix constructors.
375  
-encodeArgs withExp _ (InfixC _ conName _) = do
  347
+encodeArgs opts multiCons (InfixC _ conName _) = do
376 348
     al <- newName "argL"
377 349
     ar <- newName "argR"
378 350
     match (infixP (varP al) conName (varP ar))
379 351
           ( normalB
380  
-          $ withExp
381  
-          $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
382  
-                                     | a <- [al,ar]
383  
-                                     ]
  352
+          $ encodeSum opts multiCons conName
  353
+          $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a
  354
+                                    | a <- [al,ar]
  355
+                                    ]
384 356
           )
385 357
           []
386 358
 -- Existentially quantified constructors.
387  
-encodeArgs withExp withField (ForallC _ _ con) =
388  
-    encodeArgs withExp withField con
  359
+encodeArgs opts multiCons (ForallC _ _ con) =
  360
+    encodeArgs opts multiCons con
389 361
 
390 362
 
391 363
 --------------------------------------------------------------------------------
@@ -393,34 +365,13 @@ encodeArgs withExp withField (ForallC _ _ con) =
393 365
 --------------------------------------------------------------------------------
394 366
 
395 367
 -- | Generates a 'FromJSON' instance declaration for the given data type.
396  
---
397  
--- Example:
398  
---
399  
--- @
400  
--- data Foo = Foo Char Int
401  
--- $('deriveFromJSON' id ''Foo)
402  
--- @
403  
---
404  
--- This will splice in the following code:
405  
---
406  
--- @
407  
--- instance 'FromJSON' Foo where
408  
---     'parseJSON' =
409  
---         \\value -> case value of
410  
---                     'Array' arr ->
411  
---                       if (V.length arr == 2)
412  
---                       then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
413  
---                                \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
414  
---                       else fail \"\<error message\>\"
415  
---                     other -> fail \"\<error message\>\"
416  
--- @
417  
-deriveFromJSON :: (String -> String)
418  
-               -- ^ Function to change field names.
  368
+deriveFromJSON :: Options
  369
+               -- ^ Encoding options.
419 370
                -> Name
420 371
                -- ^ Name of the type for which to generate a 'FromJSON' instance
421 372
                -- declaration.
422 373
                -> Q [Dec]
423  
-deriveFromJSON withField name =
  374
+deriveFromJSON opts name =
424 375
     withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
425 376
   where
426 377
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
@@ -429,7 +380,7 @@ deriveFromJSON withField name =
429 380
                   (classType `appT` instanceType)
430 381
                   [ funD 'parseJSON
431 382
                          [ clause []
432  
-                                  (normalB $ consFromJSON name withField cons)
  383
+                                  (normalB $ consFromJSON name opts cons)
433 384
                                   []
434 385
                          ]
435 386
                   ]
@@ -440,181 +391,280 @@ deriveFromJSON withField name =
440 391
 
441 392
 -- | Generates a lambda expression which parses the JSON encoding of the given
442 393
 -- data type.
443  
---
444  
--- Example:
445  
---
446  
--- @
447  
--- data Foo = Foo 'Int'
448  
--- @
449  
---
450  
--- @
451  
--- parseFoo :: 'Value' -> 'Parser' Foo
452  
--- parseFoo = $('mkParseJSON' id ''Foo)
453  
--- @
454  
---
455  
--- This will splice in the following code:
456  
---
457  
--- @
458  
--- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg
459  
--- @
460  
-mkParseJSON :: (String -> String) -- ^ Function to change field names.
  394
+mkParseJSON :: Options -- ^ Encoding options.
461 395
             -> Name -- ^ Name of the encoded type.
462 396
             -> Q Exp
463  
-mkParseJSON withField name =
464  
-    withType name (\_ cons -> consFromJSON name withField cons)
  397
+mkParseJSON opts name =
  398
+    withType name (\_ cons -> consFromJSON name opts cons)
465 399
 
466 400
 -- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
467 401
 -- code to parse the JSON encoding of a number of constructors. All constructors
468 402
 -- must be from the same type.
469 403
 consFromJSON :: Name
470 404
              -- ^ Name of the type to which the constructors belong.
471  
-             -> (String -> String)
472  
-             -- ^ Function to change field names.
  405
+             -> Options
  406
+             -- ^ Encoding options
473 407
              -> [Con]
474 408
              -- ^ Constructors for which to generate JSON parsing code.
475 409
              -> Q Exp
  410
+
476 411
 consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
477 412
                               ++ "Not a single constructor given!"
478  
-consFromJSON tName withField [con] = do
  413
+
  414
+consFromJSON tName opts [con] = do
  415
+  value <- newName "value"
  416
+  lam1E (varP value) (parseArgs tName opts con (Right value))
  417
+
  418
+consFromJSON tName opts cons = do
479 419
   value <- newName "value"
480  
-  lam1E (varP value)
481  
-        $ caseE (varE value)
482  
-                (parseArgs tName withField con)
483  
-consFromJSON tName withField cons = do
484  
-  value  <- newName "value"
485  
-  obj    <- newName "obj"
486  
-  conKey <- newName "conKey"
487  
-  conVal <- newName "conVal"
488  
-
489  
-  let -- Convert the Data.Map inside the Object to a list and pattern match
490  
-      -- against it. It must contain a single element otherwise the parse will
491  
-      -- fail.
492  
-      caseLst = caseE ([e|H.toList|] `appE` varE obj)
493  
-                      [ match (listP [tupP [varP conKey, varP conVal]])
494  
-                              (normalB caseKey)
495  
-                              []
496  
-                      , do other <- newName "other"
497  
-                           match (varP other)
498  
-                                 (normalB $ [|wrongPairCountFail|]
499  
-                                            `appE` (litE $ stringL $ show tName)
500  
-                                            `appE` ([|show . length|] `appE` varE other)
501  
-                                 )
502  
-                                 []
503  
-                      ]
504  
-
505  
-      caseKey = caseE (varE conKey)
506  
-                      [match wildP (guardedB guards) []]
507  
-      guards = [ do g <- normalG $ infixApp (varE conKey)
508  
-                                            [|(==)|]
509  
-                                            ( [|T.pack|]
510  
-                                              `appE` conNameExp con
511  
-                                            )
512  
-                    e <- caseE (varE conVal)
513  
-                               (parseArgs tName withField con)
514  
-                    return (g, e)
515  
-               | con <- cons
516  
-               ]
517  
-               ++
518  
-               [ liftM2 (,)
519  
-                        (normalG [e|otherwise|])
520  
-                        ( [|conNotFoundFail|]
521  
-                          `appE` (litE $ stringL $ show tName)
522  
-                          `appE` listE (map (litE . stringL . nameBase . getConName) cons)
523  
-                          `appE` ([|T.unpack|] `appE` varE conKey)
524  
-                        )
525  
-               ]
526  
-
527  
-  lam1E (varP value)
528  
-        $ caseE (varE value)
529  
-                [ match (conP 'Object [varP obj])
530  
-                        (normalB caseLst)
531  
-                        []
532  
-                , do other <- newName "other"
533  
-                     match (varP other)
534  
-                           ( normalB
535  
-                           $ [|noObjectFail|]
  420
+  lam1E (varP value) $ caseE (varE value) $
  421
+    if nullaryToString opts && all isNullary cons
  422
+    then allNullaryMatches
  423
+    else mixedMatches
  424
+
  425
+  where
  426
+    allNullaryMatches =
  427
+      [ do txt <- newName "txt"
  428
+           match (conP 'String [varP txt])
  429
+                 (guardedB $
  430
+                  [ liftM2 (,) (normalG $
  431
+                                  infixApp (varE txt)
  432
+                                           [|(==)|]
  433
+                                           ([|T.pack|] `appE`
  434
+                                              stringE (nameBase conName)))
  435
+                               ([|pure|] `appE` conE conName)
  436
+                  | con <- cons
  437
+                  , let conName = getConName con
  438
+                  ]
  439
+                  ++
  440
+                  [ liftM2 (,)
  441
+                      (normalG [|otherwise|])
  442
+                      ( [|noMatchFail|]
  443
+                        `appE` (litE $ stringL $ show tName)
  444
+                        `appE` ([|T.unpack|] `appE` varE txt)
  445
+                      )
  446
+                  ]
  447
+                 )
  448
+                 []
  449
+      , do other <- newName "other"
  450
+           match (varP other)
  451
+                 (normalB $ [|noStringFail|]
  452
+                    `appE` (litE $ stringL $ show tName)
  453
+                    `appE` ([|valueConName|] `appE` varE other)
  454
+                 )
  455
+                 []
  456
+      ]
  457
+
  458
+    mixedMatches =
  459
+        case sumEncoding opts of
  460
+          ObjectWithType {typeFieldName, valueFieldName} ->
  461
+            [ do obj <- newName "obj"
  462
+                 match (conP 'Object [varP obj])
  463
+                       (normalB $ parseObject typeFieldName valueFieldName obj)
  464
+                       []
  465
+            , do other <- newName "other"
  466
+                 match (varP other)
  467
+                       ( normalB
  468
+                         $ [|noObjectFail|]
536 469
                              `appE` (litE $ stringL $ show tName)
537 470
                              `appE` ([|valueConName|] `appE` varE other)
538  
-                           )
539  
-                           []
540  
-                ]
  471
+                       )
  472
+                       []
  473
+            ]
  474
+          TwoElemArray ->
  475
+            [ do arr <- newName "array"
  476
+                 match (conP 'Array [varP arr])
  477
+                       (guardedB $
  478
+                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
  479
+                                                         [|(==)|]
  480
+                                                         (litE $ integerL 2))
  481
+                                     (parse2ElemArray arr)
  482
+                        , liftM2 (,) (normalG [|otherwise|])
  483
+                                     (([|not2ElemArray|]
  484
+                                       `appE` (litE $ stringL $ show tName)
  485
+                                       `appE` ([|V.length|] `appE` varE arr)))
  486
+                        ]
  487
+                       )
  488
+                       []
  489
+            , do other <- newName "other"
  490
+                 match (varP other)
  491
+                       ( normalB
  492
+                         $ [|noArrayFail|]
  493
+                             `appE` (litE $ stringL $ show tName)
  494
+                             `appE` ([|valueConName|] `appE` varE other)
  495
+                       )
  496
+                       []
  497
+            ]
  498
+
  499
+    parseObject typFieldName valFieldName obj = do
  500
+      conKey <- newName "conKey"
  501
+      doE [ bindS (varP conKey)
  502
+                  (infixApp (varE obj)
  503
+                            [|(.:)|]
  504
+                            ([|T.pack|] `appE` stringE typFieldName))
  505
+          , noBindS $ parseContents conKey (Left (valFieldName, obj))
  506
+          ]
541 507
 
542  
--- | Generates code to parse the JSON encoding of a single constructor.
543  
-parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
544  
-          -> (String -> String) -- ^ Function to change field names.
545  
-          -> Con -- ^ Constructor for which to generate JSON parsing code.
546  
-          -> [Q Match]
547  
--- Nullary constructors.
548  
-parseArgs tName _ (NormalC conName []) =
  508
+    parse2ElemArray arr = do
  509
+      conKey <- newName "conKey"
  510
+      conVal <- newName "conVal"
  511
+      let letIx n ix =
  512
+              valD (varP n)
  513
+                   (normalB ([|V.unsafeIndex|] `appE`
  514
+                               varE arr `appE`
  515
+                               litE (integerL ix)))
  516
+                   []
  517
+      letE [ letIx conKey 0
  518
+           , letIx conVal 1
  519
+           ]
  520
+           (parseContents conKey (Right conVal))
  521
+
  522
+    parseContents conKey contents =
  523
+        caseE (varE conKey)
  524
+              [ do txt <- newName "txt"
  525
+                   match (conP 'String [varP txt])
  526
+                         (guardedB $
  527
+                          [ liftM2 (,) (normalG $
  528
+                                          infixApp (varE txt)
  529
+                                                   [|(==)|]
  530
+                                                   ([|T.pack|] `appE`
  531
+                                                     conNameExp con))
  532
+                                       (parseArgs tName opts con contents)
  533
+                          | con <- cons
  534
+                          ]
  535
+                          ++
  536
+                          [ liftM2 (,)
  537
+                              (normalG [|otherwise|])
  538
+                              ( [|conNotFoundFail|]
  539
+                                `appE` (litE $ stringL $ show tName)
  540
+                                `appE` listE (map ( litE
  541
+                                                  . stringL
  542
+                                                  . nameBase
  543
+                                                  . getConName
  544
+                                                  )
  545
+                                                  cons
  546
+                                             )
  547
+                                `appE` ([|T.unpack|] `appE` varE txt)
  548
+                              )
  549
+                          ]
  550
+                         )
  551
+                         []
  552
+              , do other <- newName "other"
  553
+                   match (varP other)
  554
+                         ( normalB $
  555
+                           (either (const [|typeNotString|])
  556
+                                   (const [|firstElemNotString|])
  557
+                                   contents)
  558
+                             `appE` (litE $ stringL $ show tName)
  559
+                             `appE` ([|valueConName|] `appE` varE other)
  560
+                         )
  561
+                         []
  562
+              ]
  563
+
  564
+
  565
+parseNullaryMatches :: Name -> Name -> [Q Match]
  566
+parseNullaryMatches tName conName =
549 567
     [ do arr <- newName "arr"
550 568
          match (conP 'Array [varP arr])
551  
-               ( normalB $ condE ([|V.null|] `appE` varE arr)
552  
-                                 ([e|pure|] `appE` conE conName)
553  
-                                 ( parseTypeMismatch tName conName
554  
-                                     (litE $ stringL "an empty Array")
555  
-                                     ( infixApp (litE $ stringL $ "Array of length ")
556  
-                                                [|(++)|]
557  
-                                                ([|show . V.length|] `appE` varE arr)
558  
-                                     )
559  
-                                 )
  569
+               (guardedB $
  570
+                [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
  571
+                             ([|pure|] `appE` conE conName)
  572
+                , liftM2 (,) (normalG [|otherwise|])
  573
+                             (parseTypeMismatch tName conName
  574
+                                (litE $ stringL "an empty Array")
  575
+                                (infixApp (litE $ stringL $ "Array of length ")
  576
+                                          [|(++)|]
  577
+                                          ([|show . V.length|] `appE` varE arr)
  578
+                                )
  579
+                             )
  580
+                ]
560 581
                )
561 582
                []
562 583
     , matchFailed tName conName "Array"
563 584
     ]
564  
--- Unary constructors.
565  
-parseArgs _ _ (NormalC conName [_]) =
  585
+
  586
+parseUnaryMatches :: Name -> [Q Match]
  587
+parseUnaryMatches conName =
566 588
     [ do arg <- newName "arg"
567 589
          match (varP arg)
568 590
                ( normalB $ infixApp (conE conName)
569  
-                                    [e|(<$>)|]
570  
-                                    ([e|parseJSON|] `appE` varE arg)
  591
+                                    [|(<$>)|]
  592
+                                    ([|parseJSON|] `appE` varE arg)
571 593
                )
572 594
                []
573 595
     ]
  596
+
  597
+parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ
  598
+parseRecord opts tName conName ts obj =
  599
+    foldl' (\a b -> infixApp a [|(<*>)|] b)
  600
+           (infixApp (conE conName) [|(<$>)|] x)
  601
+           xs
  602
+    where
  603
+      x:xs = [ [|lookupField|]
  604
+               `appE` (litE $ stringL $ show tName)
  605
+               `appE` (litE $ stringL $ nameBase conName)
  606
+               `appE` (varE obj)
  607
+               `appE` ( [|T.pack|] `appE` fieldNameExp opts field
  608
+                      )
  609
+             | (field, _, _) <- ts
  610
+             ]
  611
+
  612
+getValField :: Name -> String -> [MatchQ] -> Q Exp
  613
+getValField obj valFieldName matches = do
  614
+  val <- newName "val"
  615
+  doE [ bindS (varP val) $ infixApp (varE obj)
  616
+                                    [|(.:)|]
  617
+                                    ([|T.pack|] `appE`
  618
+                                       (litE $ stringL valFieldName))
  619
+      , noBindS $ caseE (varE val) matches
  620
+      ]
  621
+
  622
+-- | Generates code to parse the JSON encoding of a single constructor.
  623
+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
  624
+          -> Options -- ^ Encoding options.
  625
+          -> Con -- ^ Constructor for which to generate JSON parsing code.
  626
+          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
  627
+                                        --   Right valName
  628
+          -> Q Exp
  629
+-- Nullary constructors.
  630
+parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
  631
+  getValField obj valFieldName $ parseNullaryMatches tName conName
  632
+parseArgs tName _ (NormalC conName []) (Right valName) =
  633
+  caseE (varE valName) $ parseNullaryMatches tName conName
  634
+
  635
+-- Unary constructors.
  636
+parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =
  637
+  getValField obj valFieldName $ parseUnaryMatches conName
  638
+parseArgs _ _ (NormalC conName [_]) (Right valName) =
  639
+  caseE (varE valName) $ parseUnaryMatches conName
  640
+
574 641
 -- Polyadic constructors.
575  
-parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts
  642
+parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =
  643
+    getValField obj valFieldName $ parseProduct tName conName $ genericLength ts
  644
+parseArgs tName _ (NormalC conName ts) (Right valName) =
  645
+    caseE (varE valName) $ parseProduct tName conName $ genericLength ts
  646
+
576 647
 -- Records.
577  
-parseArgs tName withField (RecC conName ts) =
578  
-    [ do obj <- newName "recObj"
579  
-         let x:xs = [ [|lookupField|]
580  
-                      `appE` (litE $ stringL $ show tName)
581  
-                      `appE` (litE $ stringL $ nameBase conName)
582  
-                      `appE` (varE obj)
583  
-                      `appE` ( [e|T.pack|]
584  
-                               `appE`
585  
-                               fieldNameExp withField field
586  
-                             )
587  
-                    | (field, _, _) <- ts
588  
-                    ]
589  
-         match (conP 'Object [varP obj])
590  
-               ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)
591  
-                                            [|(==)|]
592  
-                                            (litE $ integerL $ genericLength ts)
593  
-                                 )
594  
-                                 ( foldl' (\a b -> infixApp a [|(<*>)|] b)
595  
-                                          (infixApp (conE conName) [|(<$>)|] x)
596  
-                                          xs
597  
-                                 )
598  
-                                 ( parseTypeMismatch tName conName
599  
-                                     ( litE $ stringL $ "Object with "
600  
-                                                        ++ show (length ts)
601  
-                                                        ++ " name/value pairs"
602  
-                                     )
603  
-                                     ( infixApp ([|show . H.size|] `appE` varE obj)
604  
-                                                [|(++)|]
605  
-                                                (litE $ stringL $ " name/value pairs")
606  
-                                     )
607  
-                                 )
608  
-               )
609  
-               []
  648
+parseArgs tName opts (RecC conName ts) (Left (_, obj)) =
  649
+    parseRecord opts tName conName ts obj
  650
+parseArgs tName opts (RecC conName ts) (Right valName) = do
  651
+  obj <- newName "recObj"
  652
+  caseE (varE valName)
  653
+    [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []
610 654
     , matchFailed tName conName "Object"
611 655
     ]
  656
+
612 657
 -- Infix constructors. Apart from syntax these are the same as
613 658
 -- polyadic constructors.
614  
-parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2
  659
+parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =
  660
+    getValField obj valFieldName $ parseProduct tName conName 2
  661
+parseArgs tName _ (InfixC _ conName _) (Right valName) =
  662
+    caseE (varE valName) $ parseProduct tName conName 2
  663
+
615 664
 -- Existentially quantified constructors. We ignore the quantifiers
616 665
 -- and proceed with the contained constructor.
617  
-parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con
  666
+parseArgs tName opts (ForallC _ _ con) contents =
  667
+    parseArgs tName opts con contents
618 668
 
619 669
 -- | Generates code to parse the JSON encoding of an n-ary
620 670
 -- constructor.
@@ -678,29 +728,48 @@ parseTypeMismatch tName conName expected actual =
678 728
           , actual
679 729
           ]
680 730
 
681  
-lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
682  
-lookupField tName rec obj key =
683  
-    case H.lookup key obj of
684  
-      Nothing -> unknownFieldFail tName rec (T.unpack key)
685  
-      Just v  -> parseJSON v
  731
+class (FromJSON a) => LookupField a where
  732
+    lookupField :: String -> String -> Object -> T.Text -> Parser a
  733
+
  734
+instance (FromJSON a) => LookupField a where
  735
+    lookupField tName rec obj key =
  736
+        case H.lookup key obj of
  737
+          Nothing -> unknownFieldFail tName rec (T.unpack key)
  738
+          Just v  -> parseJSON v
  739
+
  740
+instance (FromJSON a) => LookupField (Maybe a) where
  741
+    lookupField _ _ = (.:?)
686 742
 
687 743
 unknownFieldFail :: String -> String -> String -> Parser fail
688 744
 unknownFieldFail tName rec key =
689 745
     fail $ printf "When parsing the record %s of type %s the key %s was not present."
690 746
                   rec tName key
691 747
 
  748
+noArrayFail :: String -> String -> Parser fail
  749
+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o
  750
+
692 751
 noObjectFail :: String -> String -> Parser fail
693  
-noObjectFail t o =
694  
-    fail $ printf "When parsing %s expected Object but got %s." t o
  752
+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o
  753
+
  754
+noStringFail :: String -> String -> Parser fail
  755
+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
  756
+
  757
+noMatchFail :: String -> String -> Parser fail
  758
+noMatchFail t o =
  759
+    fail $ printf "When parsing %s expected a String with the name of a constructor but got %s." t o
  760
+
  761
+not2ElemArray :: String -> Int -> Parser fail
  762
+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements"
  763
+                                   t i
  764
+typeNotString :: String -> String -> Parser fail
  765
+typeNotString t o = fail $ printf "When parsing %s expected an Object where the type field is a String with the name of a constructor but got %s." t o
695 766
 
696  
-wrongPairCountFail :: String -> String -> Parser fail
697  
-wrongPairCountFail t n =
698  
-    fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
699  
-                  t n
  767
+firstElemNotString :: String -> String -> Parser fail
  768
+firstElemNotString t o = fail $ printf "When parsing %s expected an Array where the first element is a String with the name of a constructor but got %s." t o
700 769
 
701 770
 conNotFoundFail :: String -> [String] -> String -> Parser fail
702 771
 conNotFoundFail t cs o =
703  
-    fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
  772
+    fail $ printf "When parsing %s expected a 2-element Array with a name and value element where the name is one of [%s], but got %s."
704 773
                   t (intercalate ", " cs) o
705 774
 
706 775
 parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
@@ -753,10 +822,10 @@ conNameExp :: Con -> Q Exp
753 822
 conNameExp = litE . stringL . nameBase . getConName
754 823
 
755 824
 -- | Creates a string literal expression from a record field name.
756  
-fieldNameExp :: (String -> String) -- ^ Function to change the field name.
  825
+fieldNameExp :: Options -- ^ Encoding options
757 826
              -> Name
758 827
              -> Q Exp
759  
-fieldNameExp f = litE . stringL . f . nameBase
  828
+fieldNameExp opts = litE . stringL . fieldNameModifier opts . nameBase
760 829
 
761 830
 -- | The name of the outermost 'Value' constructor.
762 831
 valueConName :: Value -> String
Commit_comment_tip

Tip: You can add notes to lines in a file. Hover to the left of a line to make a note

Something went wrong with that request. Please try again.