Skip to content
Browse files

Added Data.Aeson.TH, mechanically derived instances

  • Loading branch information...
1 parent b100d34 commit 5b4d3841e6272506b2ee48b373a39df5cc69895c @roelvandijk roelvandijk committed Jul 8, 2011
Showing with 451 additions and 0 deletions.
  1. +449 −0 Data/Aeson/TH.hs
  2. +2 −0 aeson.cabal
View
449 Data/Aeson/TH.hs
@@ -0,0 +1,449 @@
+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
+
+{-|
+Module: Data.Aeson.TH
+License: Apache
+Stability: experimental
+Portability: portable
+
+Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that
+you need to enable the @TemplateHaskell@ language extension in order to use this
+module.
+
+An example shows how instances are generated for arbitrary data types. First we
+define a data type:
+
+
+> data D a = Nullary
+> | Unary Int
+> | Product String Char a
+> | Record { testOne :: Double
+> , testTwo :: Bool
+> , testThree :: D a
+> } deriving Eq
+
+
+Next we derive the necessary instances. Note that we make use of the feature to
+rewrite record fields. In this case we drop the first 4 characters of every
+field name.
+
+
+>>> $(deriveJSON (drop 4) ''D)
+
+
+This will result in the following (simplified) code to be spliced in your program:
+
+> import Control.Applicative
+> import Control.Monad
+> import Data.Aeson
+> import Data.Aeson.TH
+> import qualified Data.Map as M
+> import qualified Data.Text as T
+> import qualified Data.Vector as V
+>
+> instance ToJSON a => ToJSON (D a) where
+> toJSON =
+> \value ->
+> case value of
+> Nullary ->
+> object [T.pack "Nullary" .= toJSON ([] :: [()])]
+> Unary arg1 ->
+> object [T.pack "Unary" .= toJSON arg1]
+> Product arg1 arg2 arg3 ->
+> object [ T.pack "Product"
+> .= toJSON [ toJSON arg1
+> , toJSON arg2
+> , toJSON arg3
+> ]
+> ]
+> Record arg1 arg2 arg3 ->
+> object [ T.pack "Record"
+> .= object [ T.pack "One" .= arg1
+> , T.pack "Two" .= arg2
+> , T.pack "Three" .= arg3
+> ]
+> ]
+>
+> instance FromJSON a => FromJSON (D a) where
+> parseJSON =
+> \value ->
+> case value of
+> Object obj ->
+> case M.toList obj of
+> [(conKey, conVal)] ->
+> case conKey of
+> _ | (conKey == T.pack "Nullary") ->
+> case conVal of
+> Array arr | V.null arr -> pure Nullary
+> _ -> mzero
+> | (conKey == T.pack "Unary") ->
+> case conVal of
+> arg -> Unary <$> parseJSON arg
+> | (conKey == T.pack "Product") ->
+> case conVal of
+> Array arr | V.length arr == 3 ->
+> Product <$> parseJSON (arr V.! 0)
+> <*> parseJSON (arr V.! 1)
+> <*> parseJSON (arr V.! 2)
+> _ -> mzero
+> | (conKey == T.pack "Record") ->
+> case conVal of
+> Object obj ->
+> Record <$> (obj .: T.pack "One")
+> <*> (obj .: T.pack "Two")
+> <*> (obj .: T.pack "Three")
+> _ -> mzero
+> | otherwise -> mzero
+> _ -> mzero
+> _ -> mzero
+
+Now we can use the newly created instances.
+
+> d :: D Int
+> d = Record { testOne = 3.14159
+> , testTwo = True
+> , testThree = Product "test" 'A' 123
+> }
+
+>>> fromJSON (toJSON d) == Success d
+> True
+
+-}
+
+module Data.Aeson.TH
+ ( deriveJSON
+
+ , deriveToJSON
+ , deriveFromJSON
+
+ , mkToJSON
+ , mkParseJSON
+ ) where
+
+--------------------------------------------------------------------------------
+-- Imports
+--------------------------------------------------------------------------------
+
+-- from aeson:
+import Data.Aeson ( toJSON, object, (.=), (.:)
+ , ToJSON, toJSON
+ , FromJSON, parseJSON
+ )
+import Data.Aeson.Types ( Value(..) )
+-- from base:
+import Control.Applicative ( pure, (<$>), (<*>) )
+import Control.Monad ( return, mapM, mzero, liftM2 )
+import Data.Bool ( otherwise )
+import Data.Char ( String )
+import Data.Eq ( (==) )
+import Data.Function ( ($), (.), id )
+import Data.Functor ( fmap )
+import Data.List ( (++), foldl', map, zip, genericLength )
+import Prelude ( (-), Integer, error )
+import Text.Show ( show )
+-- from containers:
+import qualified Data.Map as M ( toList )
+-- from template-haskell:
+import Language.Haskell.TH
+-- from text:
+import qualified Data.Text as T ( pack )
+-- from vector:
+import qualified Data.Vector as V ( (!), null, length )
+
+
+
+--------------------------------------------------------------------------------
+-- Convenience
+--------------------------------------------------------------------------------
+
+deriveJSON :: (String -> String) -> Name -> Q [Dec]
+deriveJSON withField name =
+ liftM2 (++)
+ (deriveToJSON withField name)
+ (deriveFromJSON withField name)
+
+
+--------------------------------------------------------------------------------
+-- ToJSON
+--------------------------------------------------------------------------------
+
+{-
+TODO: Don't constrain type variables that are not used in any constructor.
+
+data Foo a = Foo Int
+instance (ToJSON a) ⇒ ToJSON Foo where ...
+
+The above (ToJSON a) constraint is not necessary.
+-}
+deriveToJSON :: (String -> String) -> Name -> Q [Dec]
+deriveToJSON withField name =
+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
+ where
+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
+ fromCons tvbs cons =
+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
+ (classType `appT` instanceType)
+ [ funD 'toJSON
+ [ clause []
+ (normalB $ consToJSON withField cons)
+ []
+ ]
+ ]
+ where
+ classType = conT ''ToJSON
+ typeNames = map tvbName tvbs
+ instanceType = foldl' appT (conT name) $ map varT typeNames
+
+mkToJSON :: (String -> String) -> Name -> Q Exp
+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
+
+consToJSON :: (String -> String) -> [Con] -> Q Exp
+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
+ ++ "Not a single constructor given!"
+consToJSON withField [con] = do
+ value <- newName "value"
+ lam1E (varP value)
+ $ caseE (varE value)
+ [encodeArgs id withField con]
+consToJSON withField cons = do
+ value <- newName "value"
+ lam1E (varP value)
+ $ caseE (varE value)
+ [ encodeArgs (wrap $ getConName con) withField con
+ | con <- cons
+ ]
+ where
+ wrap :: Name -> Q Exp -> Q Exp
+ wrap name exp =
+ let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
+ in [e|object|] `appE` listE [ infixApp fieldName
+ [e|(.=)|]
+ exp
+ ]
+
+encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
+-- Nullary constructors.
+encodeArgs withExp _ (NormalC conName []) =
+ match (conP conName [])
+ (normalB $ withExp [e|toJSON ([] :: [()])|])
+ []
+-- Polyadic constructors with special case for unary constructors.
+encodeArgs withExp _ (NormalC conName ts) = do
+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
+ let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
+ -- Single argument is directly converted.
+ [e] -> e
+ -- Multiple arguments are converted to a JSON array.
+ es -> [e|toJSON|] `appE` listE es
+ match (conP conName $ map varP args)
+ (normalB $ withExp js)
+ []
+-- Records.
+encodeArgs withExp withField (RecC conName ts) = do
+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
+ let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
+ [e|(.=)|]
+ (varE arg)
+ | (arg, (field, _, _)) <- zip args ts
+ ]
+ match (conP conName $ map varP args)
+ (normalB $ withExp $ [e|object|] `appE` listE js)
+ []
+-- Infix constructors.
+encodeArgs withExp _ (InfixC _ conName _) = do
+ al <- newName "argL"
+ ar <- newName "argR"
+ match (infixP (varP al) conName (varP ar))
+ ( normalB
+ $ withExp
+ $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
+ | a <- [al,ar]
+ ]
+ )
+ []
+-- Existentially quantified constructors.
+encodeArgs withExp withField (ForallC _ _ con) =
+ encodeArgs withExp withField con
+
+
+--------------------------------------------------------------------------------
+-- FromJSON
+--------------------------------------------------------------------------------
+
+deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
+deriveFromJSON withField name =
+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
+ where
+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec
+ fromCons tvbs cons =
+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
+ (classType `appT` instanceType)
+ [ funD 'parseJSON
+ [ clause []
+ (normalB $ consFromJSON withField cons)
+ []
+ ]
+ ]
+ where
+ classType = conT ''FromJSON
+ typeNames = map tvbName tvbs
+ instanceType = foldl' appT (conT name) $ map varT typeNames
+
+mkParseJSON :: (String -> String) -> Name -> Q Exp
+mkParseJSON withField name =
+ withType name (\_ cons -> consFromJSON withField cons)
+
+consFromJSON :: (String -> String) -> [Con] -> Q Exp
+consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "
+ ++ "Not a single constructor given!"
+consFromJSON withField [con] = do
+ value <- newName "value"
+ lam1E (varP value)
+ $ caseE (varE value)
+ (parseArgs withField con)
+consFromJSON withField cons = do
+ value <- newName "value"
+ obj <- newName "obj"
+ conKey <- newName "conKey"
+ conVal <- newName "conVal"
+
+ let -- Convert the Data.Map inside the Object to a list and pattern match
+ -- against it. It must contain a single element otherwise the parse will
+ -- fail.
+ caseLst = caseE ([e|M.toList|] `appE` varE obj)
+ [ match (listP [tupP [varP conKey, varP conVal]])
+ (normalB caseKey)
+ []
+ , errorMatch
+ ]
+ caseKey = caseE (varE conKey)
+ [match wildP (guardedB guards) []]
+ guards = [ do g <- normalG $ infixApp (varE conKey)
+ [|(==)|]
+ ( [|T.pack|]
+ `appE` conNameExp con
+ )
+ e <- caseE (varE conVal)
+ (parseArgs withField con)
+ return (g, e)
+ | con <- cons
+ ]
+ ++
+ [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]
+
+ lam1E (varP value)
+ $ caseE (varE value)
+ [ match (conP 'Object [varP obj])
+ (normalB caseLst)
+ []
+ , errorMatch
+ ]
+
+parseArgs :: (String -> String) -> Con -> [Q Match]
+-- Nullary constructors.
+parseArgs _ (NormalC conName []) =
+ [ do arr <- newName "arr"
+ g <- normalG $ [|V.null|] `appE` varE arr
+ e <- [e|pure|] `appE` conE conName
+ match (conP 'Array [varP arr])
+ (guardedB [return (g, e)])
+ []
+ , errorMatch
+ ]
+-- Unary constructors.
+parseArgs _ (NormalC conName [_]) =
+ [ do arg <- newName "arg"
+ match (varP arg)
+ ( normalB $ infixApp (conE conName)
+ [e|(<$>)|]
+ ([e|parseJSON|] `appE` varE arg)
+ )
+ []
+ ]
+
+-- Polyadic constuctors.
+parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
+-- Records.
+parseArgs withField (RecC conName ts) =
+ [ do obj <- newName "obj"
+ -- List of: "obj .: "<FIELD>""
+ let x:xs = [ infixApp (varE obj)
+ [|(.:)|]
+ ( [e|T.pack|]
+ `appE`
+ fieldNameExp withField field
+ )
+ | (field, _, _) <- ts
+ ]
+ match (conP 'Object [varP obj])
+ ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)
+ (infixApp (conE conName) [|(<$>)|] x)
+ xs
+ )
+ []
+ , errorMatch
+ ]
+-- Infix constructors.
+parseArgs _ (InfixC _ conName _) = parseProduct conName 2
+-- Existentially quantified constructors.
+parseArgs withField (ForallC _ _ con) = parseArgs withField con
+
+parseProduct :: Name -> Integer -> [Q Match]
+parseProduct conName numArgs =
+ [ do arr <- newName "arr"
+ g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
+ [|(==)|]
+ (litE $ integerL numArgs)
+ -- List of: "parseJSON (arr V.! <IX>)"
+ let x:xs = [ [|parseJSON|]
+ `appE`
+ infixApp (varE arr)
+ [|(V.!)|]
+ (litE $ integerL ix)
+ | ix <- [0 .. numArgs - 1]
+ ]
+ e <- foldl' (\a b -> infixApp a [|(<*>)|] b)
+ (infixApp (conE conName) [|(<$>)|] x)
+ xs
+ match (conP 'Array [varP arr])
+ (guardedB [return (g, e)])
+ []
+ , errorMatch
+ ]
+
+-- "_ -> mzero"
+errorMatch :: Q Match
+errorMatch = match wildP (normalB [|mzero|]) []
+
+
+--------------------------------------------------------------------------------
+-- Utility functions
+--------------------------------------------------------------------------------
+
+withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
+withType name f = do
+ info <- reify name
+ case info of
+ TyConI dec ->
+ case dec of
+ DataD _ _ tvbs cons _ -> f tvbs cons
+ NewtypeD _ _ tvbs con _ -> f tvbs [con]
+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
+ ++ show other
+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."
+
+getConName :: Con -> Name
+getConName (NormalC name _) = name
+getConName (RecC name _) = name
+getConName (InfixC _ name _) = name
+getConName (ForallC _ _ con) = getConName con
+
+tvbName :: TyVarBndr -> Name
+tvbName (PlainTV name ) = name
+tvbName (KindedTV name _) = name
+
+fieldNameExp :: (String -> String) -> Name -> Q Exp
+fieldNameExp f = litE . stringL . f . nameBase
+
+conNameExp :: Con -> Q Exp
+conNameExp = litE . stringL . nameBase . getConName
View
2 aeson.cabal
@@ -103,6 +103,7 @@ library
Data.Aeson.Generic
Data.Aeson.Parser
Data.Aeson.Types
+ Data.Aeson.TH
other-modules:
Data.Aeson.Functions
@@ -120,6 +121,7 @@ library
old-locale,
syb,
text >= 0.11.0.2,
+ template-haskell >= 2.5,
time,
unordered-containers >= 0.1.3.0,
vector >= 0.7

0 comments on commit 5b4d384

Please sign in to comment.
Something went wrong with that request. Please try again.