@@ -13,97 +13,103 @@ module.
1313An example shows how instances are generated for arbitrary data types. First we
1414define a data type:
1515
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−
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+@
2525
2626Next 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
27+change record field names. In this case we drop the first 4 characters of every
2828field name.
2929
30−
31−>>> $(deriveJSON (drop 4) ''D)
32−
30+@
31+$('deriveJSON' ('drop' 4) ''D)
32+@
3333
3434This will result in the following (simplified) code to be spliced in your program:
3535
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
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+@
99103
100104Now we can use the newly created instances.
101105
102−> d :: D Int
103−> d = Record { testOne = 3.14159
104−> , testTwo = True
105−> , testThree = Product "test" 'A' 123
106−> }
106+@
107+d :: D 'Int'
108+d = Record { testOne = 3.14159
109+ , testTwo = 'True'
110+ , testThree = Product \"test\" \'A\' 123
111+ }
112+@
107113
108114>>> fromJSON (toJSON d) == Success d
109115> True
@@ -156,7 +162,17 @@ import qualified Data.Vector as V ( (!), null, length )
156162-- Convenience
157163--------------------------------------------------------------------------------
158164
159−deriveJSON :: (String -> String) -> Name -> Q [Dec]
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]
160176deriveJSON withField name =
161177 liftM2 (++)
162178 (deriveToJSON withField name)
@@ -168,14 +184,37 @@ deriveJSON withField name =
168184--------------------------------------------------------------------------------
169185
170186{-
171−TODO: Don't constrain type variables that are not used in any constructor.
187+TODO: Don't constrain phantom type variables.
172188
173189data Foo a = Foo Int
174190instance (ToJSON a) ⇒ ToJSON Foo where ...
175191
176−The above (ToJSON a) constraint is not necessary.
192+The above (ToJSON a) constraint is not necessary and perhaps undesirable.
177193-}
178−deriveToJSON :: (String -> String) -> Name -> Q [Dec]
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]
179218deriveToJSON withField name =
180219 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
181220 where
@@ -194,17 +233,49 @@ deriveToJSON withField name =
194233 typeNames = map tvbName tvbs
195234 instanceType = foldl' appT (conT name) $ map varT typeNames
196235
197−mkToJSON :: (String -> String) -> Name -> Q Exp
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
198257mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
199258
200−consToJSON :: (String -> String) -> [Con] -> Q Exp
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
201267consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
202268 ++ "Not a single constructor given!"
269+-- A single constructor is directly encoded. The constructor itself may be
270+-- forgotten.
203271consToJSON withField [con] = do
204272 value <- newName "value"
205273 lam1E (varP value)
206274 $ caseE (varE value)
207275 [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.
208279consToJSON withField cons = do
209280 value <- newName "value"
210281 lam1E (varP value)
@@ -221,8 +292,11 @@ consToJSON withField cons = do
221292 exp
222293 ]
223294
295+-- | Generates code to generate the JSON encoding of a single constructor.
224296encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
225−-- Nullary constructors.
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.
226300encodeArgs withExp _ (NormalC conName []) =
227301 match (conP conName [])
228302 (normalB $ withExp [e|toJSON ([] :: [()])|])
@@ -270,7 +344,32 @@ encodeArgs withExp withField (ForallC _ _ con) =
270344-- FromJSON
271345--------------------------------------------------------------------------------
272346
273−deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
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]
274373deriveFromJSON withField name =
275374 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
276375 where
@@ -289,11 +388,39 @@ deriveFromJSON withField name =
289388 typeNames = map tvbName tvbs
290389 instanceType = foldl' appT (conT name) $ map varT typeNames
291390
292−mkParseJSON :: (String -> String) -> Name -> Q Exp
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
293413mkParseJSON withField name =
294414 withType name (\_ cons -> consFromJSON withField cons)
295415
296−consFromJSON :: (String -> String) -> [Con] -> Q Exp
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
297424consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "
298425 ++ "Not a single constructor given!"
299426consFromJSON withField [con] = do
@@ -338,13 +465,23 @@ consFromJSON withField cons = do
338465 []
339466 , errorMatch
340467 ]
341−
342−parseArgs :: (String -> String) -> Con -> [Q Match]
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]
343478-- Nullary constructors.
344479parseArgs _ (NormalC conName []) =
345480 [ do arr <- newName "arr"
346481 g <- normalG $ [|V.null|] `appE` varE arr
347482 e <- [e|pure|] `appE` conE conName
483+ -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']
484+ -- But first need to have "instance Applicative Q".
348485 match (conP 'Array [varP arr])
349486 (guardedB [return (g, e)])
350487 []
@@ -361,7 +498,7 @@ parseArgs _ (NormalC conName [_]) =
361498 []
362499 ]
363500
364−-- Polyadic constuctors.
501+-- Polyadic constructors.
365502parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
366503-- Records.
367504parseArgs withField (RecC conName ts) =
@@ -383,12 +520,18 @@ parseArgs withField (RecC conName ts) =
383520 []
384521 , errorMatch
385522 ]
386−-- Infix constructors.
523+-- Infix constructors. Apart from syntax these are the same as
524+-- polyadic constructors.
387525parseArgs _ (InfixC _ conName _) = parseProduct conName 2
388−-- Existentially quantified constructors.
526+-- Existentially quantified constructors. We ignore the quantifiers
527+-- and proceed with the contained constructor.
389528parseArgs withField (ForallC _ _ con) = parseArgs withField con
390529
391−parseProduct :: Name -> Integer -> [Q Match]
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]
392535parseProduct conName numArgs =
393536 [ do arr <- newName "arr"
394537 g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
@@ -411,7 +554,10 @@ parseProduct conName numArgs =
411554 , errorMatch
412555 ]
413556
414−-- "_ -> mzero"
557+-- |
558+-- @
559+-- _ -> 'mzero'
560+-- @
415561errorMatch :: Q Match
416562errorMatch = match wildP (normalB [|mzero|]) []
417563
@@ -420,7 +566,18 @@ errorMatch = match wildP (normalB [|mzero|]) []
420566-- Utility functions
421567--------------------------------------------------------------------------------
422568
423−withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
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.
424581withType name f = do
425582 info <- reify name
426583 case info of
@@ -432,18 +589,20 @@ withType name f = do
432589 ++ show other
433590 _ -> error "Data.Aeson.TH.withType: I need the name of a type."
434591
592+-- | Extracts the name from a constructor.
435593getConName :: Con -> Name
436594getConName (NormalC name _) = name
437595getConName (RecC name _) = name
438596getConName (InfixC _ name _) = name
439597getConName (ForallC _ _ con) = getConName con
440598
599+-- | Extracts the name from a type variable binder.
441600tvbName :: TyVarBndr -> Name
442601tvbName (PlainTV name ) = name
443602tvbName (KindedTV name _) = name
444603
445−fieldNameExp :: (String -> String) -> Name -> Q Exp
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
446608fieldNameExp f = litE . stringL . f . nameBase
447−
448−conNameExp :: Con -> Q Exp
449−conNameExp = litE . stringL . nameBase . getConName