@@ -0,0 +1,449 @@
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+rewrite record fields. 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+> import Control.Applicative
37+> import Control.Monad
38+> import Data.Aeson
39+> import Data.Aeson.TH
40+> import qualified Data.Map as M
41+> import qualified Data.Text as T
42+> import qualified Data.Vector as V
43+>
44+> instance ToJSON a => ToJSON (D a) where
45+> toJSON =
46+> \value ->
47+> case value of
48+> Nullary ->
49+> object [T.pack "Nullary" .= toJSON ([] :: [()])]
50+> Unary arg1 ->
51+> object [T.pack "Unary" .= toJSON arg1]
52+> Product arg1 arg2 arg3 ->
53+> object [ T.pack "Product"
54+> .= toJSON [ toJSON arg1
55+> , toJSON arg2
56+> , toJSON arg3
57+> ]
58+> ]
59+> Record arg1 arg2 arg3 ->
60+> object [ T.pack "Record"
61+> .= object [ T.pack "One" .= arg1
62+> , T.pack "Two" .= arg2
63+> , T.pack "Three" .= arg3
64+> ]
65+> ]
66+>
67+> instance FromJSON a => FromJSON (D a) where
68+> parseJSON =
69+> \value ->
70+> case value of
71+> Object obj ->
72+> case M.toList obj of
73+> [(conKey, conVal)] ->
74+> case conKey of
75+> _ | (conKey == T.pack "Nullary") ->
76+> case conVal of
77+> Array arr | V.null arr -> pure Nullary
78+> _ -> mzero
79+> | (conKey == T.pack "Unary") ->
80+> case conVal of
81+> arg -> Unary <$> parseJSON arg
82+> | (conKey == T.pack "Product") ->
83+> case conVal of
84+> Array arr | V.length arr == 3 ->
85+> Product <$> parseJSON (arr V.! 0)
86+> <*> parseJSON (arr V.! 1)
87+> <*> parseJSON (arr V.! 2)
88+> _ -> mzero
89+> | (conKey == T.pack "Record") ->
90+> case conVal of
91+> Object obj ->
92+> Record <$> (obj .: T.pack "One")
93+> <*> (obj .: T.pack "Two")
94+> <*> (obj .: T.pack "Three")
95+> _ -> mzero
96+> | otherwise -> mzero
97+> _ -> mzero
98+> _ -> mzero
99+
100+Now we can use the newly created instances.
101+
102+> d :: D Int
103+> d = Record { testOne = 3.14159
104+> , testTwo = True
105+> , testThree = Product "test" 'A' 123
106+> }
107+
108+>>> fromJSON (toJSON d) == Success d
109+> True
110+
111+-}
112+
113+module Data.Aeson.TH
114+ ( deriveJSON
115+
116+ , deriveToJSON
117+ , deriveFromJSON
118+
119+ , mkToJSON
120+ , mkParseJSON
121+ ) where
122+
123+--------------------------------------------------------------------------------
124+-- Imports
125+--------------------------------------------------------------------------------
126+
127+-- from aeson:
128+import Data.Aeson ( toJSON, object, (.=), (.:)
129+ , ToJSON, toJSON
130+ , FromJSON, parseJSON
131+ )
132+import Data.Aeson.Types ( Value(..) )
133+-- from base:
134+import Control.Applicative ( pure, (<$>), (<*>) )
135+import Control.Monad ( return, mapM, mzero, liftM2 )
136+import Data.Bool ( otherwise )
137+import Data.Char ( String )
138+import Data.Eq ( (==) )
139+import Data.Function ( ($), (.), id )
140+import Data.Functor ( fmap )
141+import Data.List ( (++), foldl', map, zip, genericLength )
142+import Prelude ( (-), Integer, error )
143+import Text.Show ( show )
144+-- from containers:
145+import qualified Data.Map as M ( toList )
146+-- from template-haskell:
147+import Language.Haskell.TH
148+-- from text:
149+import qualified Data.Text as T ( pack )
150+-- from vector:
151+import qualified Data.Vector as V ( (!), null, length )
152+
153+
154+
155+--------------------------------------------------------------------------------
156+-- Convenience
157+--------------------------------------------------------------------------------
158+
159+deriveJSON :: (String -> String) -> Name -> Q [Dec]
160+deriveJSON withField name =
161+ liftM2 (++)
162+ (deriveToJSON withField name)
163+ (deriveFromJSON withField name)
164+
165+
166+--------------------------------------------------------------------------------
167+-- ToJSON
168+--------------------------------------------------------------------------------
169+
170+{-
171+TODO: Don't constrain type variables that are not used in any constructor.
172+
173+data Foo a = Foo Int
174+instance (ToJSON a) ⇒ ToJSON Foo where ...
175+
176+The above (ToJSON a) constraint is not necessary.
177+-}
178+deriveToJSON :: (String -> String) -> Name -> Q [Dec]
179+deriveToJSON withField name =
180+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
181+ where
182+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
183+ fromCons tvbs cons =
184+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
185+ (classType `appT` instanceType)
186+ [ funD 'toJSON
187+ [ clause []
188+ (normalB $ consToJSON withField cons)
189+ []
190+ ]
191+ ]
192+ where
193+ classType = conT ''ToJSON
194+ typeNames = map tvbName tvbs
195+ instanceType = foldl' appT (conT name) $ map varT typeNames
196+
197+mkToJSON :: (String -> String) -> Name -> Q Exp
198+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
199+
200+consToJSON :: (String -> String) -> [Con] -> Q Exp
201+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
202+ ++ "Not a single constructor given!"
203+consToJSON withField [con] = do
204+ value <- newName "value"
205+ lam1E (varP value)
206+ $ caseE (varE value)
207+ [encodeArgs id withField con]
208+consToJSON withField cons = do
209+ value <- newName "value"
210+ lam1E (varP value)
211+ $ caseE (varE value)
212+ [ encodeArgs (wrap $ getConName con) withField con
213+ | con <- cons
214+ ]
215+ where
216+ wrap :: Name -> Q Exp -> Q Exp
217+ wrap name exp =
218+ let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
219+ in [e|object|] `appE` listE [ infixApp fieldName
220+ [e|(.=)|]
221+ exp
222+ ]
223+
224+encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
225+-- Nullary constructors.
226+encodeArgs withExp _ (NormalC conName []) =
227+ match (conP conName [])
228+ (normalB $ withExp [e|toJSON ([] :: [()])|])
229+ []
230+-- Polyadic constructors with special case for unary constructors.
231+encodeArgs withExp _ (NormalC conName ts) = do
232+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
233+ let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
234+ -- Single argument is directly converted.
235+ [e] -> e
236+ -- Multiple arguments are converted to a JSON array.
237+ es -> [e|toJSON|] `appE` listE es
238+ match (conP conName $ map varP args)
239+ (normalB $ withExp js)
240+ []
241+-- Records.
242+encodeArgs withExp withField (RecC conName ts) = do
243+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
244+ let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
245+ [e|(.=)|]
246+ (varE arg)
247+ | (arg, (field, _, _)) <- zip args ts
248+ ]
249+ match (conP conName $ map varP args)
250+ (normalB $ withExp $ [e|object|] `appE` listE js)
251+ []
252+-- Infix constructors.
253+encodeArgs withExp _ (InfixC _ conName _) = do
254+ al <- newName "argL"
255+ ar <- newName "argR"
256+ match (infixP (varP al) conName (varP ar))
257+ ( normalB
258+ $ withExp
259+ $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
260+ | a <- [al,ar]
261+ ]
262+ )
263+ []
264+-- Existentially quantified constructors.
265+encodeArgs withExp withField (ForallC _ _ con) =
266+ encodeArgs withExp withField con
267+
268+
269+--------------------------------------------------------------------------------
270+-- FromJSON
271+--------------------------------------------------------------------------------
272+
273+deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
274+deriveFromJSON withField name =
275+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
276+ where
277+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
278+ fromCons tvbs cons =
279+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
280+ (classType `appT` instanceType)
281+ [ funD 'parseJSON
282+ [ clause []
283+ (normalB $ consFromJSON withField cons)
284+ []
285+ ]
286+ ]
287+ where
288+ classType = conT ''FromJSON
289+ typeNames = map tvbName tvbs
290+ instanceType = foldl' appT (conT name) $ map varT typeNames
291+
292+mkParseJSON :: (String -> String) -> Name -> Q Exp
293+mkParseJSON withField name =
294+ withType name (\_ cons -> consFromJSON withField cons)
295+
296+consFromJSON :: (String -> String) -> [Con] -> Q Exp
297+consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "
298+ ++ "Not a single constructor given!"
299+consFromJSON withField [con] = do
300+ value <- newName "value"
301+ lam1E (varP value)
302+ $ caseE (varE value)
303+ (parseArgs withField con)
304+consFromJSON withField cons = do
305+ value <- newName "value"
306+ obj <- newName "obj"
307+ conKey <- newName "conKey"
308+ conVal <- newName "conVal"
309+
310+ let -- Convert the Data.Map inside the Object to a list and pattern match
311+ -- against it. It must contain a single element otherwise the parse will
312+ -- fail.
313+ caseLst = caseE ([e|M.toList|] `appE` varE obj)
314+ [ match (listP [tupP [varP conKey, varP conVal]])
315+ (normalB caseKey)
316+ []
317+ , errorMatch
318+ ]
319+ caseKey = caseE (varE conKey)
320+ [match wildP (guardedB guards) []]
321+ guards = [ do g <- normalG $ infixApp (varE conKey)
322+ [|(==)|]
323+ ( [|T.pack|]
324+ `appE` conNameExp con
325+ )
326+ e <- caseE (varE conVal)
327+ (parseArgs withField con)
328+ return (g, e)
329+ | con <- cons
330+ ]
331+ ++
332+ [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]
333+
334+ lam1E (varP value)
335+ $ caseE (varE value)
336+ [ match (conP 'Object [varP obj])
337+ (normalB caseLst)
338+ []
339+ , errorMatch
340+ ]
341+
342+parseArgs :: (String -> String) -> Con -> [Q Match]
343+-- Nullary constructors.
344+parseArgs _ (NormalC conName []) =
345+ [ do arr <- newName "arr"
346+ g <- normalG $ [|V.null|] `appE` varE arr
347+ e <- [e|pure|] `appE` conE conName
348+ match (conP 'Array [varP arr])
349+ (guardedB [return (g, e)])
350+ []
351+ , errorMatch
352+ ]
353+-- Unary constructors.
354+parseArgs _ (NormalC conName [_]) =
355+ [ do arg <- newName "arg"
356+ match (varP arg)
357+ ( normalB $ infixApp (conE conName)
358+ [e|(<$>)|]
359+ ([e|parseJSON|] `appE` varE arg)
360+ )
361+ []
362+ ]
363+
364+-- Polyadic constuctors.
365+parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
366+-- Records.
367+parseArgs withField (RecC conName ts) =
368+ [ do obj <- newName "obj"
369+ -- List of: "obj .: "<FIELD>""
370+ let x:xs = [ infixApp (varE obj)
371+ [|(.:)|]
372+ ( [e|T.pack|]
373+ `appE`
374+ fieldNameExp withField field
375+ )
376+ | (field, _, _) <- ts
377+ ]
378+ match (conP 'Object [varP obj])
379+ ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)
380+ (infixApp (conE conName) [|(<$>)|] x)
381+ xs
382+ )
383+ []
384+ , errorMatch
385+ ]
386+-- Infix constructors.
387+parseArgs _ (InfixC _ conName _) = parseProduct conName 2
388+-- Existentially quantified constructors.
389+parseArgs withField (ForallC _ _ con) = parseArgs withField con
390+
391+parseProduct :: Name -> Integer -> [Q Match]
392+parseProduct conName numArgs =
393+ [ do arr <- newName "arr"
394+ g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
395+ [|(==)|]
396+ (litE $ integerL numArgs)
397+ -- List of: "parseJSON (arr V.! <IX>)"
398+ let x:xs = [ [|parseJSON|]
399+ `appE`
400+ infixApp (varE arr)
401+ [|(V.!)|]
402+ (litE $ integerL ix)
403+ | ix <- [0 .. numArgs - 1]
404+ ]
405+ e <- foldl' (\a b -> infixApp a [|(<*>)|] b)
406+ (infixApp (conE conName) [|(<$>)|] x)
407+ xs
408+ match (conP 'Array [varP arr])
409+ (guardedB [return (g, e)])
410+ []
411+ , errorMatch
412+ ]
413+
414+-- "_ -> mzero"
415+errorMatch :: Q Match
416+errorMatch = match wildP (normalB [|mzero|]) []
417+
418+
419+--------------------------------------------------------------------------------
420+-- Utility functions
421+--------------------------------------------------------------------------------
422+
423+withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
424+withType name f = do
425+ info <- reify name
426+ case info of
427+ TyConI dec ->
428+ case dec of
429+ DataD _ _ tvbs cons _ -> f tvbs cons
430+ NewtypeD _ _ tvbs con _ -> f tvbs [con]
431+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
432+ ++ show other
433+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."
434+
435+getConName :: Con -> Name
436+getConName (NormalC name _) = name
437+getConName (RecC name _) = name
438+getConName (InfixC _ name _) = name
439+getConName (ForallC _ _ con) = getConName con
440+
441+tvbName :: TyVarBndr -> Name
442+tvbName (PlainTV name ) = name
443+tvbName (KindedTV name _) = name
444+
445+fieldNameExp :: (String -> String) -> Name -> Q Exp
446+fieldNameExp f = litE . stringL . f . nameBase
447+
448+conNameExp :: Con -> Q Exp
449+conNameExp = litE . stringL . nameBase . getConName