@@ -0,0 +1,608 @@
1+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
2+
3+{-|
4+Module: Data.Aeson.TH
5+License: Apache
6+Stability: experimental
7+Portability: portable
8+
9+Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that
10+you need to enable the @TemplateHaskell@ language extension in order to use this
11+module.
12+
13+An example shows how instances are generated for arbitrary data types. First we
14+define a data type:
15+
16+@
17+data D a = Nullary
18+ | Unary Int
19+ | Product String Char a
20+ | Record { testOne :: Double
21+ , testTwo :: Bool
22+ , testThree :: D a
23+ } deriving Eq
24+@
25+
26+Next we derive the necessary instances. Note that we make use of the feature to
27+change record field names. In this case we drop the first 4 characters of every
28+field name.
29+
30+@
31+$('deriveJSON' ('drop' 4) ''D)
32+@
33+
34+This will result in the following (simplified) code to be spliced in your program:
35+
36+@
37+import Control.Applicative
38+import Control.Monad
39+import Data.Aeson
40+import Data.Aeson.TH
41+import qualified Data.Map as M
42+import qualified Data.Text as T
43+import qualified Data.Vector as V
44+
45+instance 'ToJSON' a => 'ToJSON' (D a) where
46+ 'toJSON' =
47+ \value ->
48+ case value of
49+ Nullary ->
50+ 'object' ['T.pack' \"Nullary\" .= 'toJSON' ([] :: [()])]
51+ Unary arg1 ->
52+ 'object' ['T.pack' \"Unary\" .= 'toJSON' arg1]
53+ Product arg1 arg2 arg3 ->
54+ 'object' [ 'T.pack' \"Product\"
55+ .= 'toJSON' [ 'toJSON' arg1
56+ , 'toJSON' arg2
57+ , 'toJSON' arg3
58+ ]
59+ ]
60+ Record arg1 arg2 arg3 ->
61+ 'object' [ 'T.pack' \"Record\"
62+ .= 'object' [ 'T.pack' \"One\" '.=' arg1
63+ , 'T.pack' \"Two\" '.=' arg2
64+ , 'T.pack' \"Three\" '.=' arg3
65+ ]
66+ ]
67+@
68+
69+@
70+instance 'FromJSON' a => 'FromJSON' (D a) where
71+ 'parseJSON' =
72+ \value ->
73+ case value of
74+ 'Object' obj ->
75+ case 'M.toList' obj of
76+ [(conKey, conVal)] ->
77+ case conKey of
78+ _ | (conKey '==' 'T.pack' \"Nullary\") ->
79+ case conVal of
80+ 'Array' arr | 'V.null' arr -> 'pure' Nullary
81+ _ -> 'mzero'
82+ | (conKey '==' 'T.pack' \"Unary\") ->
83+ case conVal of
84+ arg -> Unary '<$>' 'parseJSON' arg
85+ | (conKey '==' 'T.pack' \"Product\") ->
86+ case conVal of
87+ 'Array' arr | 'V.length' arr '==' 3 ->
88+ 'Product' '<$>' 'parseJSON' (arr 'V.!' 0)
89+ '<*>' 'parseJSON' (arr 'V.!' 1)
90+ '<*>' 'parseJSON' (arr 'V.!' 2)
91+ _ -> 'mzero'
92+ | (conKey '==' 'T.pack' \"Record\") ->
93+ case conVal of
94+ 'Object' obj ->
95+ Record '<$>' (obj '.:' 'T.pack' \"One\")
96+ '<*>' (obj '.:' 'T.pack' \"Two\")
97+ '<*>' (obj '.:' 'T.pack' \"Three\")
98+ _ -> 'mzero'
99+ | 'otherwise' -> 'mzero'
100+ _ -> 'mzero'
101+ _ -> 'mzero'
102+@
103+
104+Now we can use the newly created instances.
105+
106+@
107+d :: D 'Int'
108+d = Record { testOne = 3.14159
109+ , testTwo = 'True'
110+ , testThree = Product \"test\" \'A\' 123
111+ }
112+@
113+
114+>>> fromJSON (toJSON d) == Success d
115+> True
116+
117+-}
118+
119+module Data.Aeson.TH
120+ ( deriveJSON
121+
122+ , deriveToJSON
123+ , deriveFromJSON
124+
125+ , mkToJSON
126+ , mkParseJSON
127+ ) where
128+
129+--------------------------------------------------------------------------------
130+-- Imports
131+--------------------------------------------------------------------------------
132+
133+-- from aeson:
134+import Data.Aeson ( toJSON, object, (.=), (.:)
135+ , ToJSON, toJSON
136+ , FromJSON, parseJSON
137+ )
138+import Data.Aeson.Types ( Value(..) )
139+-- from base:
140+import Control.Applicative ( pure, (<$>), (<*>) )
141+import Control.Monad ( return, mapM, mzero, liftM2 )
142+import Data.Bool ( otherwise )
143+import Data.Char ( String )
144+import Data.Eq ( (==) )
145+import Data.Function ( ($), (.), id )
146+import Data.Functor ( fmap )
147+import Data.List ( (++), foldl', map, zip, genericLength )
148+import Prelude ( (-), Integer, error )
149+import Text.Show ( show )
150+-- from containers:
151+import qualified Data.Map as M ( toList )
152+-- from template-haskell:
153+import Language.Haskell.TH
154+-- from text:
155+import qualified Data.Text as T ( pack )
156+-- from vector:
157+import qualified Data.Vector as V ( (!), null, length )
158+
159+
160+
161+--------------------------------------------------------------------------------
162+-- Convenience
163+--------------------------------------------------------------------------------
164+
165+-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given
166+-- data type.
167+--
168+-- This is a convienience function which is equivalent to calling both
169+-- 'deriveToJSON' and 'deriveFromJSON'.
170+deriveJSON :: (String -> String)
171+ -- ^ Function to change field names.
172+ -> Name
173+ -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
174+ -- instances.
175+ -> Q [Dec]
176+deriveJSON withField name =
177+ liftM2 (++)
178+ (deriveToJSON withField name)
179+ (deriveFromJSON withField name)
180+
181+
182+--------------------------------------------------------------------------------
183+-- ToJSON
184+--------------------------------------------------------------------------------
185+
186+{-
187+TODO: Don't constrain phantom type variables.
188+
189+data Foo a = Foo Int
190+instance (ToJSON a) ⇒ ToJSON Foo where ...
191+
192+The above (ToJSON a) constraint is not necessary and perhaps undesirable.
193+-}
194+
195+-- | Generates a 'ToJSON' instance declaration for the given data type.
196+--
197+-- Example:
198+--
199+-- @
200+-- data Foo = Foo 'Char' 'Int'
201+-- $('deriveToJSON' 'id' ''Foo)
202+-- @
203+--
204+-- This will splice in the following code:
205+--
206+-- @
207+-- instance 'ToJSON' Foo where
208+-- 'toJSON' =
209+-- \value -> case value of
210+-- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]
211+-- @
212+deriveToJSON :: (String -> String)
213+ -- ^ Function to change field names.
214+ -> Name
215+ -- ^ Name of the type for which to generate a 'ToJSON' instance
216+ -- declaration.
217+ -> Q [Dec]
218+deriveToJSON withField name =
219+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
220+ where
221+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
222+ fromCons tvbs cons =
223+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
224+ (classType `appT` instanceType)
225+ [ funD 'toJSON
226+ [ clause []
227+ (normalB $ consToJSON withField cons)
228+ []
229+ ]
230+ ]
231+ where
232+ classType = conT ''ToJSON
233+ typeNames = map tvbName tvbs
234+ instanceType = foldl' appT (conT name) $ map varT typeNames
235+
236+-- | Generates a lambda expression which encodes the given data type as JSON.
237+--
238+-- Example:
239+--
240+-- @
241+-- data Foo = Foo 'Int'
242+-- @
243+--
244+-- @
245+-- encodeFoo :: Foo -> 'Value'
246+-- encodeFoo = $('mkToJSON' 'id' ''Foo)
247+-- @
248+--
249+-- This will splice in the following code:
250+--
251+-- @
252+-- \value -> case value of Foo arg1 -> 'toJSON' arg1
253+-- @
254+mkToJSON :: (String -> String) -- ^ Function to change field names.
255+ -> Name -- ^ Name of the type to encode.
256+ -> Q Exp
257+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
258+
259+-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code
260+-- to generate the JSON encoding of a number of constructors. All constructors
261+-- must be from the same type.
262+consToJSON :: (String -> String)
263+ -- ^ Function to change field names.
264+ -> [Con]
265+ -- ^ Constructors for which to generate JSON generating code.
266+ -> Q Exp
267+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
268+ ++ "Not a single constructor given!"
269+-- A single constructor is directly encoded. The constructor itself may be
270+-- forgotten.
271+consToJSON withField [con] = do
272+ value <- newName "value"
273+ lam1E (varP value)
274+ $ caseE (varE value)
275+ [encodeArgs id withField con]
276+-- With multiple constructors we need to remember which constructor is
277+-- encoded. This is done by generating a JSON object which maps to constructor's
278+-- name to the JSON encoding of its contents.
279+consToJSON withField cons = do
280+ value <- newName "value"
281+ lam1E (varP value)
282+ $ caseE (varE value)
283+ [ encodeArgs (wrap $ getConName con) withField con
284+ | con <- cons
285+ ]
286+ where
287+ wrap :: Name -> Q Exp -> Q Exp
288+ wrap name exp =
289+ let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
290+ in [e|object|] `appE` listE [ infixApp fieldName
291+ [e|(.=)|]
292+ exp
293+ ]
294+
295+-- | Generates code to generate the JSON encoding of a single constructor.
296+encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
297+-- Nullary constructors. Generates code that explicitly matches against the
298+-- constructor even though it doesn't contain data. This is useful to prevent
299+-- type errors.
300+encodeArgs withExp _ (NormalC conName []) =
301+ match (conP conName [])
302+ (normalB $ withExp [e|toJSON ([] :: [()])|])
303+ []
304+-- Polyadic constructors with special case for unary constructors.
305+encodeArgs withExp _ (NormalC conName ts) = do
306+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
307+ let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
308+ -- Single argument is directly converted.
309+ [e] -> e
310+ -- Multiple arguments are converted to a JSON array.
311+ es -> [e|toJSON|] `appE` listE es
312+ match (conP conName $ map varP args)
313+ (normalB $ withExp js)
314+ []
315+-- Records.
316+encodeArgs withExp withField (RecC conName ts) = do
317+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
318+ let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
319+ [e|(.=)|]
320+ (varE arg)
321+ | (arg, (field, _, _)) <- zip args ts
322+ ]
323+ match (conP conName $ map varP args)
324+ (normalB $ withExp $ [e|object|] `appE` listE js)
325+ []
326+-- Infix constructors.
327+encodeArgs withExp _ (InfixC _ conName _) = do
328+ al <- newName "argL"
329+ ar <- newName "argR"
330+ match (infixP (varP al) conName (varP ar))
331+ ( normalB
332+ $ withExp
333+ $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
334+ | a <- [al,ar]
335+ ]
336+ )
337+ []
338+-- Existentially quantified constructors.
339+encodeArgs withExp withField (ForallC _ _ con) =
340+ encodeArgs withExp withField con
341+
342+
343+--------------------------------------------------------------------------------
344+-- FromJSON
345+--------------------------------------------------------------------------------
346+
347+-- | Generates a 'FromJSON' instance declaration for the given data type.
348+--
349+-- Example:
350+--
351+-- @
352+-- data Foo = Foo 'Char' 'Int'
353+-- $('deriveFromJSON' 'id' ''Foo)
354+-- @
355+--
356+-- This will splice in the following code:
357+--
358+-- @
359+-- instance 'FromJSON' Foo where
360+-- 'parseJSON' =
361+-- \value -> case value of
362+-- 'Array' arr | ('V.length' arr '==' 2) ->
363+-- Foo '<$>' 'parseJSON' (arr 'V.!' 0)
364+-- '<*>' 'parseJSON' (arr 'V.!' 1)
365+-- _ -> 'mzero'
366+-- @
367+deriveFromJSON :: (String -> String)
368+ -- ^ Function to change field names.
369+ -> Name
370+ -- ^ Name of the type for which to generate a 'FromJSON' instance
371+ -- declaration.
372+ -> Q [Dec]
373+deriveFromJSON withField name =
374+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
375+ where
376+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
377+ fromCons tvbs cons =
378+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
379+ (classType `appT` instanceType)
380+ [ funD 'parseJSON
381+ [ clause []
382+ (normalB $ consFromJSON withField cons)
383+ []
384+ ]
385+ ]
386+ where
387+ classType = conT ''FromJSON
388+ typeNames = map tvbName tvbs
389+ instanceType = foldl' appT (conT name) $ map varT typeNames
390+
391+-- | Generates a lambda expression which parses the JSON encoding of the given
392+-- data type.
393+--
394+-- Example:
395+--
396+-- @
397+-- data Foo = Foo 'Int'
398+-- @
399+--
400+-- @
401+-- parseFoo :: 'Value' -> 'Parser' Foo
402+-- parseFoo = $('mkParseJSON' 'id' ''Foo)
403+-- @
404+--
405+-- This will splice in the following code:
406+--
407+-- @
408+-- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg
409+-- @
410+mkParseJSON :: (String -> String) -- ^ Function to change field names.
411+ -> Name -- ^ Name of the encoded type.
412+ -> Q Exp
413+mkParseJSON withField name =
414+ withType name (\_ cons -> consFromJSON withField cons)
415+
416+-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
417+-- code to parse the JSON encoding of a number of constructors. All constructors
418+-- must be from the same type.
419+consFromJSON :: (String -> String)
420+ -- ^ Function to change field names.
421+ -> [Con]
422+ -- ^ Constructors for which to generate JSON parsing code.
423+ -> Q Exp
424+consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "
425+ ++ "Not a single constructor given!"
426+consFromJSON withField [con] = do
427+ value <- newName "value"
428+ lam1E (varP value)
429+ $ caseE (varE value)
430+ (parseArgs withField con)
431+consFromJSON withField cons = do
432+ value <- newName "value"
433+ obj <- newName "obj"
434+ conKey <- newName "conKey"
435+ conVal <- newName "conVal"
436+
437+ let -- Convert the Data.Map inside the Object to a list and pattern match
438+ -- against it. It must contain a single element otherwise the parse will
439+ -- fail.
440+ caseLst = caseE ([e|M.toList|] `appE` varE obj)
441+ [ match (listP [tupP [varP conKey, varP conVal]])
442+ (normalB caseKey)
443+ []
444+ , errorMatch
445+ ]
446+ caseKey = caseE (varE conKey)
447+ [match wildP (guardedB guards) []]
448+ guards = [ do g <- normalG $ infixApp (varE conKey)
449+ [|(==)|]
450+ ( [|T.pack|]
451+ `appE` conNameExp con
452+ )
453+ e <- caseE (varE conVal)
454+ (parseArgs withField con)
455+ return (g, e)
456+ | con <- cons
457+ ]
458+ ++
459+ [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]
460+
461+ lam1E (varP value)
462+ $ caseE (varE value)
463+ [ match (conP 'Object [varP obj])
464+ (normalB caseLst)
465+ []
466+ , errorMatch
467+ ]
468+ where
469+ -- Makes a string literal expression from a constructor's name.
470+ conNameExp :: Con -> Q Exp
471+ conNameExp = litE . stringL . nameBase . getConName
472+
473+-- | Generates code to parse the JSON encoding of a single
474+-- constructor.
475+parseArgs :: (String -> String) -- ^ Function to change field names.
476+ -> Con -- ^ Constructor for which to generate JSON parsing code.
477+ -> [Q Match]
478+-- Nullary constructors.
479+parseArgs _ (NormalC conName []) =
480+ [ do arr <- newName "arr"
481+ g <- normalG $ [|V.null|] `appE` varE arr
482+ e <- [e|pure|] `appE` conE conName
483+ -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']
484+ -- But first need to have "instance Applicative Q".
485+ match (conP 'Array [varP arr])
486+ (guardedB [return (g, e)])
487+ []
488+ , errorMatch
489+ ]
490+-- Unary constructors.
491+parseArgs _ (NormalC conName [_]) =
492+ [ do arg <- newName "arg"
493+ match (varP arg)
494+ ( normalB $ infixApp (conE conName)
495+ [e|(<$>)|]
496+ ([e|parseJSON|] `appE` varE arg)
497+ )
498+ []
499+ ]
500+
501+-- Polyadic constructors.
502+parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
503+-- Records.
504+parseArgs withField (RecC conName ts) =
505+ [ do obj <- newName "obj"
506+ -- List of: "obj .: "<FIELD>""
507+ let x:xs = [ infixApp (varE obj)
508+ [|(.:)|]
509+ ( [e|T.pack|]
510+ `appE`
511+ fieldNameExp withField field
512+ )
513+ | (field, _, _) <- ts
514+ ]
515+ match (conP 'Object [varP obj])
516+ ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)
517+ (infixApp (conE conName) [|(<$>)|] x)
518+ xs
519+ )
520+ []
521+ , errorMatch
522+ ]
523+-- Infix constructors. Apart from syntax these are the same as
524+-- polyadic constructors.
525+parseArgs _ (InfixC _ conName _) = parseProduct conName 2
526+-- Existentially quantified constructors. We ignore the quantifiers
527+-- and proceed with the contained constructor.
528+parseArgs withField (ForallC _ _ con) = parseArgs withField con
529+
530+-- | Generates code to parse the JSON encoding of an n-ary
531+-- constructor.
532+parseProduct :: Name -- ^ 'Con'structor name.
533+ -> Integer -- ^ 'Con'structor arity.
534+ -> [Q Match]
535+parseProduct conName numArgs =
536+ [ do arr <- newName "arr"
537+ g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
538+ [|(==)|]
539+ (litE $ integerL numArgs)
540+ -- List of: "parseJSON (arr V.! <IX>)"
541+ let x:xs = [ [|parseJSON|]
542+ `appE`
543+ infixApp (varE arr)
544+ [|(V.!)|]
545+ (litE $ integerL ix)
546+ | ix <- [0 .. numArgs - 1]
547+ ]
548+ e <- foldl' (\a b -> infixApp a [|(<*>)|] b)
549+ (infixApp (conE conName) [|(<$>)|] x)
550+ xs
551+ match (conP 'Array [varP arr])
552+ (guardedB [return (g, e)])
553+ []
554+ , errorMatch
555+ ]
556+
557+-- |
558+-- @
559+-- _ -> 'mzero'
560+-- @
561+errorMatch :: Q Match
562+errorMatch = match wildP (normalB [|mzero|]) []
563+
564+
565+--------------------------------------------------------------------------------
566+-- Utility functions
567+--------------------------------------------------------------------------------
568+
569+-- | Boilerplate for top level splices.
570+--
571+-- The given 'Name' must be from a type constructor. Furthermore, the
572+-- type constructor must be either a data type or a newtype. Any other
573+-- value will result in an exception.
574+withType :: Name
575+ -> ([TyVarBndr] -> [Con] -> Q a)
576+ -- ^ Function that generates the actual code. Will be applied
577+ -- to the type variable binders and constructors extracted
578+ -- from the given 'Name'.
579+ -> Q a
580+ -- ^ Resulting value in the 'Q'uasi monad.
581+withType name f = do
582+ info <- reify name
583+ case info of
584+ TyConI dec ->
585+ case dec of
586+ DataD _ _ tvbs cons _ -> f tvbs cons
587+ NewtypeD _ _ tvbs con _ -> f tvbs [con]
588+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
589+ ++ show other
590+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."
591+
592+-- | Extracts the name from a constructor.
593+getConName :: Con -> Name
594+getConName (NormalC name _) = name
595+getConName (RecC name _) = name
596+getConName (InfixC _ name _) = name
597+getConName (ForallC _ _ con) = getConName con
598+
599+-- | Extracts the name from a type variable binder.
600+tvbName :: TyVarBndr -> Name
601+tvbName (PlainTV name ) = name
602+tvbName (KindedTV name _) = name
603+
604+-- | Creates a string literal expression from a record field name.
605+fieldNameExp :: (String -> String) -- ^ Function to change the field name.
606+ -> Name
607+ -> Q Exp
608+fieldNameExp f = litE . stringL . f . nameBase