@@ -0,0 +1,449 @@
1+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
6+Stability: experimental
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
13+An example shows how instances are generated for arbitrary data types. First we
19+> | Product String Char a
20+> | Record { testOne :: Double
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
31+>>> $(deriveJSON (drop 4) ''D)
34+This will result in the following (simplified) code to be spliced in your program:
36+> import Control.Applicative
37+> import Control.Monad
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
44+> instance ToJSON a => ToJSON (D a) where
49+> object [T.pack "Nullary" .= toJSON ([] :: [()])]
51+> object [T.pack "Unary" .= toJSON arg1]
52+> Product arg1 arg2 arg3 ->
53+> object [ T.pack "Product"
54+> .= toJSON [ toJSON arg1
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
67+> instance FromJSON a => FromJSON (D a) where
72+> case M.toList obj of
73+> [(conKey, conVal)] ->
75+> _ | (conKey == T.pack "Nullary") ->
77+> Array arr | V.null arr -> pure Nullary
79+> | (conKey == T.pack "Unary") ->
81+> arg -> Unary <$> parseJSON arg
82+> | (conKey == T.pack "Product") ->
84+> Array arr | V.length arr == 3 ->
85+> Product <$> parseJSON (arr V.! 0)
86+> <*> parseJSON (arr V.! 1)
87+> <*> parseJSON (arr V.! 2)
89+> | (conKey == T.pack "Record") ->
92+> Record <$> (obj .: T.pack "One")
93+> <*> (obj .: T.pack "Two")
94+> <*> (obj .: T.pack "Three")
96+> | otherwise -> mzero
100+Now we can use the newly created instances.
103+> d = Record { testOne = 3.14159
105+> , testThree = Product "test" 'A' 123
108+>>> fromJSON (toJSON d) == Success d
123+--------------------------------------------------------------------------------
125+--------------------------------------------------------------------------------
128+import Data.Aeson ( toJSON, object, (.=), (.:)
130+ , FromJSON, parseJSON
132+import Data.Aeson.Types ( Value(..) )
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 )
145+import qualified Data.Map as M ( toList )
146+-- from template-haskell:
147+import Language.Haskell.TH
149+import qualified Data.Text as T ( pack )
151+import qualified Data.Vector as V ( (!), null, length )
155+--------------------------------------------------------------------------------
157+--------------------------------------------------------------------------------
159+deriveJSON :: (String -> String) -> Name -> Q [Dec]
160+deriveJSON withField name =
162+ (deriveToJSON withField name)
163+ (deriveFromJSON withField name)
166+--------------------------------------------------------------------------------
168+--------------------------------------------------------------------------------
171+TODO: Don't constrain type variables that are not used in any constructor.
174+instance (ToJSON a) ⇒ ToJSON Foo where ...
176+The above (ToJSON a) constraint is not necessary.
178+deriveToJSON :: (String -> String) -> Name -> Q [Dec]
179+deriveToJSON withField name =
180+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
182+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
183+ fromCons tvbs cons =
184+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
185+ (classType `appT` instanceType)
188+ (normalB $ consToJSON withField cons)
193+ classType = conT ''ToJSON
194+ typeNames = map tvbName tvbs
195+ instanceType = foldl' appT (conT name) $ map varT typeNames
197+mkToJSON :: (String -> String) -> Name -> Q Exp
198+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
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"
206+ $ caseE (varE value)
207+ [encodeArgs id withField con]
208+consToJSON withField cons = do
209+ value <- newName "value"
211+ $ caseE (varE value)
212+ [ encodeArgs (wrap $ getConName con) withField con
216+ wrap :: Name -> Q Exp -> Q Exp
218+ let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
219+ in [e|object|] `appE` listE [ infixApp fieldName
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 ([] :: [()])|])
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.
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)
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)
247+ | (arg, (field, _, _)) <- zip args ts
249+ match (conP conName $ map varP args)
250+ (normalB $ withExp $ [e|object|] `appE` listE js)
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))
259+ $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
264+-- Existentially quantified constructors.
265+encodeArgs withExp withField (ForallC _ _ con) =
266+ encodeArgs withExp withField con
269+--------------------------------------------------------------------------------
271+--------------------------------------------------------------------------------
273+deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
274+deriveFromJSON withField name =
275+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
277+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
278+ fromCons tvbs cons =
279+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
280+ (classType `appT` instanceType)
283+ (normalB $ consFromJSON withField cons)
288+ classType = conT ''FromJSON
289+ typeNames = map tvbName tvbs
290+ instanceType = foldl' appT (conT name) $ map varT typeNames
292+mkParseJSON :: (String -> String) -> Name -> Q Exp
293+mkParseJSON withField name =
294+ withType name (\_ cons -> consFromJSON withField cons)
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"
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"
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
313+ caseLst = caseE ([e|M.toList|] `appE` varE obj)
314+ [ match (listP [tupP [varP conKey, varP conVal]])
319+ caseKey = caseE (varE conKey)
320+ [match wildP (guardedB guards) []]
321+ guards = [ do g <- normalG $ infixApp (varE conKey)
324+ `appE` conNameExp con
326+ e <- caseE (varE conVal)
327+ (parseArgs withField con)
332+ [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]
335+ $ caseE (varE value)
336+ [ match (conP 'Object [varP obj])
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)])
353+-- Unary constructors.
354+parseArgs _ (NormalC conName [_]) =
355+ [ do arg <- newName "arg"
357+ ( normalB $ infixApp (conE conName)
359+ ([e|parseJSON|] `appE` varE arg)
364+-- Polyadic constuctors.
365+parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
367+parseArgs withField (RecC conName ts) =
368+ [ do obj <- newName "obj"
369+ -- List of: "obj .: "<FIELD>""
370+ let x:xs = [ infixApp (varE obj)
374+ fieldNameExp withField field
376+ | (field, _, _) <- ts
378+ match (conP 'Object [varP obj])
379+ ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)
380+ (infixApp (conE conName) [|(<$>)|] x)
386+-- Infix constructors.
387+parseArgs _ (InfixC _ conName _) = parseProduct conName 2
388+-- Existentially quantified constructors.
389+parseArgs withField (ForallC _ _ con) = parseArgs withField con
391+parseProduct :: Name -> Integer -> [Q Match]
392+parseProduct conName numArgs =
393+ [ do arr <- newName "arr"
394+ g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
396+ (litE $ integerL numArgs)
397+ -- List of: "parseJSON (arr V.! <IX>)"
398+ let x:xs = [ [|parseJSON|]
402+ (litE $ integerL ix)
403+ | ix <- [0 .. numArgs - 1]
405+ e <- foldl' (\a b -> infixApp a [|(<*>)|] b)
406+ (infixApp (conE conName) [|(<$>)|] x)
408+ match (conP 'Array [varP arr])
409+ (guardedB [return (g, e)])
415+errorMatch :: Q Match
416+errorMatch = match wildP (normalB [|mzero|]) []
419+--------------------------------------------------------------------------------
421+--------------------------------------------------------------------------------
423+withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
429+ DataD _ _ tvbs cons _ -> f tvbs cons
430+ NewtypeD _ _ tvbs con _ -> f tvbs [con]
431+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
433+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."
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
441+tvbName :: TyVarBndr -> Name
442+tvbName (PlainTV name ) = name
443+tvbName (KindedTV name _) = name
445+fieldNameExp :: (String -> String) -> Name -> Q Exp
446+fieldNameExp f = litE . stringL . f . nameBase
448+conNameExp :: Con -> Q Exp
449+conNameExp = litE . stringL . nameBase . getConName