Commits

Bryan O'Sullivan committed 27a5e99 Merge

Merge TH code

  • Participants
  • Parent commits c472733, af4ae09

Comments (0)

Files changed (2)

File Data/Aeson/TH.hs

+{-# 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
+change record field names. 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
+--------------------------------------------------------------------------------
+
+-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given
+-- data type.
+--
+-- This is a convienience function which is equivalent to calling both
+-- 'deriveToJSON' and 'deriveFromJSON'.
+deriveJSON :: (String -> String)
+           -- ^ Function to change field names.
+           -> Name
+           -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
+           -- instances.
+           -> Q [Dec]
+deriveJSON withField name =
+    liftM2 (++)
+           (deriveToJSON   withField name)
+           (deriveFromJSON withField name)
+
+
+--------------------------------------------------------------------------------
+-- ToJSON
+--------------------------------------------------------------------------------
+
+{-
+TODO: Don't constrain phantom type variables.
+
+data Foo a = Foo Int
+instance (ToJSON a) ⇒ ToJSON Foo where ...
+
+The above (ToJSON a) constraint is not necessary and perhaps undesirable.
+-}
+
+-- | Generates a 'ToJSON' instance declaration for the given data type.
+--
+-- Example:
+--
+-- @
+-- data Foo = Foo 'Char' 'Int'
+-- $('deriveToJSON' 'id' ''Foo)
+-- @
+--
+-- This will splice in the following code:
+--
+-- @
+-- instance 'ToJSON' Foo where
+--      'toJSON' =
+--          \value -> case value of
+--                      Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]
+-- @
+deriveToJSON :: (String -> String)
+             -- ^ Function to change field names.
+             -> Name
+             -- ^ Name of the type for which to generate a 'ToJSON' instance
+             -- declaration.
+             -> 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
+
+-- | Generates a lambda expression which encodes the given data type as JSON.
+--
+-- Example:
+--
+-- @
+-- data Foo = Foo 'Int'
+-- @
+--
+-- @
+-- encodeFoo :: Foo -> 'Value'
+-- encodeFoo = $('mkToJSON' 'id' ''Foo)
+-- @
+--
+-- This will splice in the following code:
+--
+-- @
+-- \value -> case value of Foo arg1 -> 'toJSON' arg1
+-- @
+mkToJSON :: (String -> String) -- ^ Function to change field names.
+         -> Name -- ^ Name of the type to encode.
+         -> Q Exp
+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
+
+-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code
+-- to generate the JSON encoding of a number of constructors. All constructors
+-- must be from the same type.
+consToJSON :: (String -> String)
+           -- ^ Function to change field names.
+           -> [Con]
+           -- ^ Constructors for which to generate JSON generating code.
+           -> Q Exp
+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
+                          ++ "Not a single constructor given!"
+-- A single constructor is directly encoded. The constructor itself may be
+-- forgotten.
+consToJSON withField [con] = do
+    value <- newName "value"
+    lam1E (varP value)
+          $ caseE (varE value)
+                  [encodeArgs id withField con]
+-- With multiple constructors we need to remember which constructor is
+-- encoded. This is done by generating a JSON object which maps to constructor's
+-- name to the JSON encoding of its contents.
+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
+                                    ]
+
+-- | Generates code to generate the JSON encoding of a single constructor.
+encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
+-- Nullary constructors. Generates code that explicitly matches against the
+-- constructor even though it doesn't contain data. This is useful to prevent
+-- type errors.
+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
+--------------------------------------------------------------------------------
+
+-- | Generates a 'FromJSON' instance declaration for the given data type.
+--
+-- Example:
+--
+-- @
+-- data Foo = Foo 'Char' 'Int'
+-- $('deriveFromJSON' 'id' ''Foo)
+-- @
+--
+-- This will splice in the following code:
+--
+-- @
+-- instance 'FromJSON' Foo where
+--     'parseJSON' =
+--         \value -> case value of
+--                     'Array' arr | ('V.length' arr '==' 2) ->
+--                        Foo '<$>' 'parseJSON' (arr 'V.!' 0)
+--                            '<*>' 'parseJSON' (arr 'V.!' 1)
+--                     _ -> 'mzero'
+-- @
+deriveFromJSON :: (String -> String)
+               -- ^ Function to change field names.
+               -> Name
+               -- ^ Name of the type for which to generate a 'FromJSON' instance
+               -- declaration.
+               -> 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
+
+-- | Generates a lambda expression which parses the JSON encoding of the given
+-- data type.
+--
+-- Example:
+--
+-- @
+-- data Foo = Foo 'Int'
+-- @
+--
+-- @
+-- parseFoo :: 'Value' -> 'Parser' Foo
+-- parseFoo = $('mkParseJSON' 'id' ''Foo)
+-- @
+--
+-- This will splice in the following code:
+--
+-- @
+-- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg
+-- @
+mkParseJSON :: (String -> String) -- ^ Function to change field names.
+            -> Name -- ^ Name of the encoded type.
+            -> Q Exp
+mkParseJSON withField name =
+    withType name (\_ cons -> consFromJSON withField cons)
+
+-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
+-- code to parse the JSON encoding of a number of constructors. All constructors
+-- must be from the same type.
+consFromJSON :: (String -> String)
+             -- ^ Function to change field names.
+             -> [Con]
+             -- ^ Constructors for which to generate JSON parsing code.
+             -> 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
+                ]
+  where
+    -- Makes a string literal expression from a constructor's name.
+    conNameExp :: Con -> Q Exp
+    conNameExp = litE . stringL . nameBase . getConName
+
+-- | Generates code to parse the JSON encoding of a single
+-- constructor.
+parseArgs :: (String -> String) -- ^ Function to change field names.
+          -> Con -- ^ Constructor for which to generate JSON parsing code.
+          -> [Q Match]
+-- Nullary constructors.
+parseArgs _ (NormalC conName []) =
+    [ do arr <- newName "arr"
+         g <- normalG $ [|V.null|] `appE` varE arr
+         e <- [e|pure|] `appE` conE conName
+         -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']
+         -- But first need to have "instance Applicative Q".
+         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 constructors.
+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. Apart from syntax these are the same as
+-- polyadic constructors.
+parseArgs _ (InfixC _ conName _) = parseProduct conName 2
+-- Existentially quantified constructors. We ignore the quantifiers
+-- and proceed with the contained constructor.
+parseArgs withField (ForallC _ _ con) = parseArgs withField con
+
+-- | Generates code to parse the JSON encoding of an n-ary
+-- constructor.
+parseProduct :: Name -- ^ 'Con'structor name.
+             -> Integer -- ^ 'Con'structor arity.
+             -> [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
+--------------------------------------------------------------------------------
+
+-- | Boilerplate for top level splices.
+--
+-- The given 'Name' must be from a type constructor. Furthermore, the
+-- type constructor must be either a data type or a newtype. Any other
+-- value will result in an exception.
+withType :: Name
+         -> ([TyVarBndr] -> [Con] -> Q a)
+         -- ^ Function that generates the actual code. Will be applied
+         -- to the type variable binders and constructors extracted
+         -- from the given 'Name'.
+         -> Q a
+         -- ^ Resulting value in the 'Q'uasi monad.
+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."
+
+-- | Extracts the name from a constructor.
+getConName :: Con -> Name
+getConName (NormalC name _)  = name
+getConName (RecC name _)     = name
+getConName (InfixC _ name _) = name
+getConName (ForallC _ _ con) = getConName con
+
+-- | Extracts the name from a type variable binder.
+tvbName :: TyVarBndr -> Name
+tvbName (PlainTV  name  ) = name
+tvbName (KindedTV name _) = name
+
+-- | Creates a string literal expression from a record field name.
+fieldNameExp :: (String -> String) -- ^ Function to change the field name.
+             -> Name
+             -> Q Exp
+fieldNameExp f = litE . stringL . f . nameBase
     Data.Aeson.Generic
     Data.Aeson.Parser
     Data.Aeson.Types
+    Data.Aeson.TH
 
   other-modules:
     Data.Aeson.Functions
     old-locale,
     syb,
     text >= 0.11.0.2,
+    template-haskell >= 2.5,
     time,
     unordered-containers >= 0.1.3.0,
     vector >= 0.7