Bryan O'Sullivan avatar Bryan O'Sullivan committed db6745f Merge

Merge pull request #97 from basvandijk/th-encoding

Add support for specifying how to encode datatypes in Data.Aeson.TH

Comments (0)

Files changed (1)

-{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , TemplateHaskell
+           , NamedFieldPuns
+           , FlexibleInstances
+           , UndecidableInstances
+           , OverlappingInstances
+  #-}
 
 {-|
 Module:      Data.Aeson.TH
 field name.
 
 @
-$('deriveJSON' ('drop' 4) ''D)
+$('deriveJSON' 'defaultOptions'{'fieldNameModifier' = '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.HashMap.Strict as H
-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\"
-                       .= ('Array' $ 'V.create' $ do
-                             mv <- 'VM.unsafeNew' 3
-                             'VM.unsafeWrite' mv 0 ('toJSON' arg1)
-                             'VM.unsafeWrite' mv 1 ('toJSON' arg2)
-                             'VM.unsafeWrite' mv 2 ('toJSON' arg3)
-                             return mv)
-                     ]
-          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 H.toList obj of
-              [(conKey, conVal)] ->
-                case conKey of
-                  _ | conKey == T.pack \"Nullary\" ->
-                        case conVal of
-                          'Array' arr ->
-                            if V.null arr
-                            then pure Nullary
-                            else fail \"\<error message\>\"
-                          _ -> fail \"\<error message\>\"
-                    | conKey == T.pack \"Unary\" ->
-                        case conVal of
-                          arg -> Unary \<$\> parseJSON arg
-                    | conKey == T.pack \"Product\" ->
-                        case conVal of
-                          'Array' arr ->
-                            if V.length arr == 3
-                            then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
-                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
-                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)
-                            else fail \"\<error message\>\"
-                          _ -> fail \"\<error message\>\"
-                    | conKey == T.pack \"Record\" ->
-                        case conVal of
-                          'Object' recObj ->
-                            if H.size recObj == 3
-                            then Record \<$\> recObj '.:' T.pack \"One\"
-                                        \<*\> recObj '.:' T.pack \"Two\"
-                                        \<*\> recObj '.:' T.pack \"Three\"
-                            else fail \"\<error message\>\"
-                          _ -> fail \"\<error message\>\"
-                    | otherwise -> fail \"\<error message\>\"
-              _ -> fail \"\<error message\>\"
-          _ -> fail \"\<error message\>\"
-@
-
-Note that every \"\<error message\>\" is in fact a descriptive message which
-provides as much information as is reasonable about the failed parse.
-
 Now we can use the newly created instances.
 
 @
 
 @
 -- FromJSON and ToJSON instances for 4-tuples.
-$('deriveJSON' id ''(,,,))
+$('deriveJSON' 'defaultOptions' ''(,,,))
 @
 
 -}
 
 module Data.Aeson.TH
-    ( deriveJSON
+    ( Options(..), SumEncoding(..), defaultOptions
+
+    , deriveJSON
 
     , deriveToJSON
     , deriveFromJSON
 --------------------------------------------------------------------------------
 
 -- from aeson:
-import Data.Aeson ( toJSON, Object, object, (.=)
+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
                   , ToJSON, toJSON
                   , FromJSON, parseJSON
                   )
 -- from base:
 import Control.Applicative ( pure, (<$>), (<*>) )
 import Control.Monad       ( return, mapM, liftM2, fail )
-import Data.Bool           ( otherwise )
+import Data.Bool           ( Bool(False, True), otherwise, (&&) )
 import Data.Eq             ( (==) )
-import Data.Function       ( ($), (.), id )
+import Data.Function       ( ($), (.), id, const )
 import Data.Functor        ( fmap )
+import Data.Int            ( Int )
+import Data.Either         ( Either(Left, Right), either )
 import Data.List           ( (++), foldl, foldl', intercalate
-                           , length, map, zip, genericLength
+                           , length, map, zip, genericLength, all
                            )
 import Data.Maybe          ( Maybe(Nothing, Just) )
 import Prelude             ( String, (-), Integer, fromIntegral, error )
 import Prelude             ( fromInteger )
 #endif
 -- from unordered-containers:
-import qualified Data.HashMap.Strict as H ( lookup, toList, size )
+import qualified Data.HashMap.Strict as H ( lookup )
 -- from template-haskell:
 import Language.Haskell.TH
+import Language.Haskell.TH.Syntax ( VarStrictType )
 -- from text:
 import qualified Data.Text as T ( Text, pack, unpack )
 -- from vector:
-import qualified Data.Vector as V ( unsafeIndex, null, length, create )
+import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
 import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
 
 
 --------------------------------------------------------------------------------
+-- Configuration
+--------------------------------------------------------------------------------
+
+-- | Options that specify how to encode your datatype to JSON.
+data Options = Options
+    { fieldNameModifier :: String -> String
+      -- ^ Function applied to field names.
+      -- Handy for removing common record prefixes for example.
+    , nullaryToString   :: Bool
+      -- ^ If 'True' the constructors of a datatypes, with all nullary
+      -- constructors, will be encoded to a string with the
+      -- constructor name. If 'False' the encoding will always follow
+      -- the `sumEncoding`.
+    , sumEncoding       :: SumEncoding
+      -- ^ Specifies how to encode constructors of a sum datatype.
+    }
+
+-- | Specifies how to encode constructors of a sum datatype.
+data SumEncoding =
+    TwoElemArray -- ^ A constructor will be encoded to a 2-element
+                 -- array where the first element is the name of the
+                 -- constructor and the second element the content of
+                 -- the constructor.
+  | ObjectWithType { typeFieldName  :: String
+                   , valueFieldName :: String
+                   }
+    -- ^ A constructor will be encoded to an object with a field
+    -- 'typeFieldName' which specifies the constructor name. If the
+    -- constructor is not a record the constructor content will be
+    -- stored under the 'valueFieldName' field.
+
+-- | Default encoding options which specify to not modify field names,
+-- encode the constructors of a datatype with all nullary constructors
+-- to just strings with the name of the constructor and use a
+-- 2-element array for other sum datatypes.
+defaultOptions :: Options
+defaultOptions = Options
+                 { fieldNameModifier = id
+                 , nullaryToString   = True
+                 , sumEncoding       = TwoElemArray
+                 }
+
+--------------------------------------------------------------------------------
 -- Convenience
 --------------------------------------------------------------------------------
 
 --
 -- This is a convienience function which is equivalent to calling both
 -- 'deriveToJSON' and 'deriveFromJSON'.
-deriveJSON :: (String -> String)
-           -- ^ Function to change field names.
+deriveJSON :: Options
+           -- ^ Encoding options.
            -> Name
            -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
            -- instances.
            -> Q [Dec]
-deriveJSON withField name =
+deriveJSON opts name =
     liftM2 (++)
-           (deriveToJSON   withField name)
-           (deriveFromJSON withField name)
+           (deriveToJSON   opts name)
+           (deriveFromJSON opts name)
 
 
 --------------------------------------------------------------------------------
 -}
 
 -- | 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 -> 'Array' $ 'V.create' $ do
---                        mv <- 'VM.unsafeNew' 2
---                        'VM.unsafeWrite' mv 0 ('toJSON' arg1)
---                        'VM.unsafeWrite' mv 1 ('toJSON' arg2)
---                        return mv
--- @
-deriveToJSON :: (String -> String)
-             -- ^ Function to change field names.
+deriveToJSON :: Options
+             -- ^ Encoding options.
              -> Name
              -- ^ Name of the type for which to generate a 'ToJSON' instance
              -- declaration.
              -> Q [Dec]
-deriveToJSON withField name =
+deriveToJSON opts name =
     withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
   where
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
                   (classType `appT` instanceType)
                   [ funD 'toJSON
                          [ clause []
-                                  (normalB $ consToJSON withField cons)
+                                  (normalB $ consToJSON opts cons)
                                   []
                          ]
                   ]
         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.
+mkToJSON :: Options -- ^ Encoding options.
          -> Name -- ^ Name of the type to encode.
          -> Q Exp
-mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
+mkToJSON opts name = withType name (\_ cons -> consToJSON opts 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.
+consToJSON :: Options
+           -- ^ Encoding options.
            -> [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
+consToJSON opts [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
+    lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con]
+
+consToJSON opts cons = do
     value <- newName "value"
-    lam1E (varP value)
-          $ caseE (varE value)
-                  [ encodeArgs (wrap $ getConName con) withField con
-                  | con <- cons
-                  ]
+    lam1E (varP value) $ caseE (varE value) matches
   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
-                                    ]
+    -- Constructors of a datatype with all nullary constructors are encoded to
+    -- just a string with the constructor name:
+    matches | nullaryToString opts && all isNullary cons =
+      [ match (conP conName []) (normalB $ conStr conName) []
+      | con <- cons
+      , let conName = getConName con
+      ]
+      -- Constructors of a datatype having some constructors with arity > 0 are
+      -- encoded to a 2-element array where the first element is a string with
+      -- the constructor name and the second element is the encoded argument or
+      -- arguments of the constructor.
+      | otherwise = [ encodeArgs opts True con
+                    | con <- cons
+                    ]
+
+conStr :: Name -> Q Exp
+conStr = appE [|String|] . appE [|T.pack|] . stringE . nameBase
+
+-- | If constructor is nullary.
+isNullary :: Con -> Bool
+isNullary (NormalC _ []) = True
+isNullary _ = False
+
+encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp
+encodeSum opts multiCons conName exp
+    | multiCons =
+        case sumEncoding opts of
+          TwoElemArray ->
+              [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr conName, exp])
+          ObjectWithType{typeFieldName, valueFieldName} ->
+              [|object|] `appE` listE
+                [ infixApp [|T.pack typeFieldName|]  [|(.=)|] (conStr conName)
+                , infixApp [|T.pack valueFieldName|] [|(.=)|] exp
+                ]
+    | otherwise = exp
 
 -- | Generates code to generate the JSON encoding of a single constructor.
-encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
+encodeArgs :: Options -> Bool -> 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 []) =
+encodeArgs  opts multiCons (NormalC conName []) =
     match (conP conName [])
-          (normalB $ withExp [e|toJSON ([] :: [()])|])
+          (normalB (encodeSum opts multiCons conName [e|toJSON ([] :: [()])|]))
           []
+
 -- Polyadic constructors with special case for unary constructors.
-encodeArgs withExp _ (NormalC conName ts) = do
+encodeArgs opts multiCons (NormalC conName ts) = do
     let len = length ts
     args <- mapM newName ["arg" ++ show n | n <- [1..len]]
-    js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
+    js <- case [[|toJSON|] `appE` varE arg | arg <- args] of
             -- Single argument is directly converted.
             [e] -> return e
             -- Multiple arguments are converted to a JSON array.
             es  -> do
               mv <- newName "mv"
               let newMV = bindS (varP mv)
-                                ([e|VM.unsafeNew|] `appE`
+                                ([|VM.unsafeNew|] `appE`
                                   litE (integerL $ fromIntegral len))
                   stmts = [ noBindS $
-                              [e|VM.unsafeWrite|] `appE`
+                              [|VM.unsafeWrite|] `appE`
                                 (varE mv) `appE`
                                   litE (integerL ix) `appE`
                                     e
                           | (ix, e) <- zip [(0::Integer)..] es
                           ]
-                  ret = noBindS $ [e|return|] `appE` varE mv
-              return $ [e|Array|] `appE`
+                  ret = noBindS $ [|return|] `appE` varE mv
+              return $ [|Array|] `appE`
                          (varE 'V.create `appE`
                            doE (newMV:stmts++[ret]))
     match (conP conName $ map varP args)
-          (normalB $ withExp js)
+          (normalB $ encodeSum opts multiCons conName js)
           []
+
 -- Records.
-encodeArgs withExp withField (RecC conName ts) = do
+encodeArgs opts multiCons (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|(.=)|]
+    let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
+                        [|(.=)|]
                         (varE arg)
              | (arg, (field, _, _)) <- zip args ts
              ]
+        exp = [|object|] `appE` listE js
     match (conP conName $ map varP args)
-          (normalB $ withExp $ [e|object|] `appE` listE js)
-          []
+          ( normalB
+          $ if multiCons
+            then case sumEncoding opts of
+                   TwoElemArray -> [|toJSON|] `appE` tupE [conStr conName, exp]
+                   ObjectWithType{typeFieldName} ->
+                       [|object|] `appE` listE
+                         ( infixApp [|T.pack typeFieldName|] [|(.=)|]
+                                    (conStr conName)
+                         : js
+                         )
+            else exp
+          ) []
+
 -- Infix constructors.
-encodeArgs withExp _ (InfixC _ conName _) = do
+encodeArgs opts multiCons (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]
-                                     ]
+          $ encodeSum opts multiCons conName
+          $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a
+                                    | a <- [al,ar]
+                                    ]
           )
           []
 -- Existentially quantified constructors.
-encodeArgs withExp withField (ForallC _ _ con) =
-    encodeArgs withExp withField con
+encodeArgs opts multiCons (ForallC _ _ con) =
+    encodeArgs opts multiCons con
 
 
 --------------------------------------------------------------------------------
 --------------------------------------------------------------------------------
 
 -- | 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 ->
---                       if (V.length arr == 2)
---                       then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
---                                \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
---                       else fail \"\<error message\>\"
---                     other -> fail \"\<error message\>\"
--- @
-deriveFromJSON :: (String -> String)
-               -- ^ Function to change field names.
+deriveFromJSON :: Options
+               -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate a 'FromJSON' instance
                -- declaration.
                -> Q [Dec]
-deriveFromJSON withField name =
+deriveFromJSON opts name =
     withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
   where
     fromCons :: [TyVarBndr] -> [Con] -> Q Dec
                   (classType `appT` instanceType)
                   [ funD 'parseJSON
                          [ clause []
-                                  (normalB $ consFromJSON name withField cons)
+                                  (normalB $ consFromJSON name opts cons)
                                   []
                          ]
                   ]
 
 -- | 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.
+mkParseJSON :: Options -- ^ Encoding options.
             -> Name -- ^ Name of the encoded type.
             -> Q Exp
-mkParseJSON withField name =
-    withType name (\_ cons -> consFromJSON name withField cons)
+mkParseJSON opts name =
+    withType name (\_ cons -> consFromJSON name opts 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 :: Name
              -- ^ Name of the type to which the constructors belong.
-             -> (String -> String)
-             -- ^ Function to change field names.
+             -> Options
+             -- ^ Encoding options
              -> [Con]
              -- ^ Constructors for which to generate JSON parsing code.
              -> Q Exp
+
 consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
                               ++ "Not a single constructor given!"
-consFromJSON tName withField [con] = do
+
+consFromJSON tName opts [con] = do
   value <- newName "value"
-  lam1E (varP value)
-        $ caseE (varE value)
-                (parseArgs tName withField con)
-consFromJSON tName withField cons = do
-  value  <- newName "value"
-  obj    <- newName "obj"
-  conKey <- newName "conKey"
-  conVal <- newName "conVal"
+  lam1E (varP value) (parseArgs tName opts con (Right value))
 
-  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|H.toList|] `appE` varE obj)
-                      [ match (listP [tupP [varP conKey, varP conVal]])
-                              (normalB caseKey)
-                              []
-                      , do other <- newName "other"
-                           match (varP other)
-                                 (normalB $ [|wrongPairCountFail|]
-                                            `appE` (litE $ stringL $ show tName)
-                                            `appE` ([|show . length|] `appE` varE other)
-                                 )
-                                 []
-                      ]
+consFromJSON tName opts cons = do
+  value <- newName "value"
+  lam1E (varP value) $ caseE (varE value) $
+    if nullaryToString opts && all isNullary cons
+    then allNullaryMatches
+    else mixedMatches
 
-      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 tName withField con)
-                    return (g, e)
-               | con <- cons
-               ]
-               ++
-               [ liftM2 (,)
-                        (normalG [e|otherwise|])
-                        ( [|conNotFoundFail|]
-                          `appE` (litE $ stringL $ show tName)
-                          `appE` listE (map (litE . stringL . nameBase . getConName) cons)
-                          `appE` ([|T.unpack|] `appE` varE conKey)
-                        )
-               ]
+  where
+    allNullaryMatches =
+      [ do txt <- newName "txt"
+           match (conP 'String [varP txt])
+                 (guardedB $
+                  [ liftM2 (,) (normalG $
+                                  infixApp (varE txt)
+                                           [|(==)|]
+                                           ([|T.pack|] `appE`
+                                              stringE (nameBase conName)))
+                               ([|pure|] `appE` conE conName)
+                  | con <- cons
+                  , let conName = getConName con
+                  ]
+                  ++
+                  [ liftM2 (,)
+                      (normalG [|otherwise|])
+                      ( [|noMatchFail|]
+                        `appE` (litE $ stringL $ show tName)
+                        `appE` ([|T.unpack|] `appE` varE txt)
+                      )
+                  ]
+                 )
+                 []
+      , do other <- newName "other"
+           match (varP other)
+                 (normalB $ [|noStringFail|]
+                    `appE` (litE $ stringL $ show tName)
+                    `appE` ([|valueConName|] `appE` varE other)
+                 )
+                 []
+      ]
 
-  lam1E (varP value)
-        $ caseE (varE value)
-                [ match (conP 'Object [varP obj])
-                        (normalB caseLst)
-                        []
-                , do other <- newName "other"
-                     match (varP other)
-                           ( normalB
-                           $ [|noObjectFail|]
+    mixedMatches =
+        case sumEncoding opts of
+          ObjectWithType {typeFieldName, valueFieldName} ->
+            [ do obj <- newName "obj"
+                 match (conP 'Object [varP obj])
+                       (normalB $ parseObject typeFieldName valueFieldName obj)
+                       []
+            , do other <- newName "other"
+                 match (varP other)
+                       ( normalB
+                         $ [|noObjectFail|]
                              `appE` (litE $ stringL $ show tName)
                              `appE` ([|valueConName|] `appE` varE other)
-                           )
-                           []
-                ]
+                       )
+                       []
+            ]
+          TwoElemArray ->
+            [ do arr <- newName "array"
+                 match (conP 'Array [varP arr])
+                       (guardedB $
+                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
+                                                         [|(==)|]
+                                                         (litE $ integerL 2))
+                                     (parse2ElemArray arr)
+                        , liftM2 (,) (normalG [|otherwise|])
+                                     (([|not2ElemArray|]
+                                       `appE` (litE $ stringL $ show tName)
+                                       `appE` ([|V.length|] `appE` varE arr)))
+                        ]
+                       )
+                       []
+            , do other <- newName "other"
+                 match (varP other)
+                       ( normalB
+                         $ [|noArrayFail|]
+                             `appE` (litE $ stringL $ show tName)
+                             `appE` ([|valueConName|] `appE` varE other)
+                       )
+                       []
+            ]
 
--- | Generates code to parse the JSON encoding of a single constructor.
-parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
-          -> (String -> String) -- ^ Function to change field names.
-          -> Con -- ^ Constructor for which to generate JSON parsing code.
-          -> [Q Match]
--- Nullary constructors.
-parseArgs tName _ (NormalC conName []) =
+    parseObject typFieldName valFieldName obj = do
+      conKey <- newName "conKey"
+      doE [ bindS (varP conKey)
+                  (infixApp (varE obj)
+                            [|(.:)|]
+                            ([|T.pack|] `appE` stringE typFieldName))
+          , noBindS $ parseContents conKey (Left (valFieldName, obj))
+          ]
+
+    parse2ElemArray arr = do
+      conKey <- newName "conKey"
+      conVal <- newName "conVal"
+      let letIx n ix =
+              valD (varP n)
+                   (normalB ([|V.unsafeIndex|] `appE`
+                               varE arr `appE`
+                               litE (integerL ix)))
+                   []
+      letE [ letIx conKey 0
+           , letIx conVal 1
+           ]
+           (parseContents conKey (Right conVal))
+
+    parseContents conKey contents =
+        caseE (varE conKey)
+              [ do txt <- newName "txt"
+                   match (conP 'String [varP txt])
+                         (guardedB $
+                          [ liftM2 (,) (normalG $
+                                          infixApp (varE txt)
+                                                   [|(==)|]
+                                                   ([|T.pack|] `appE`
+                                                     conNameExp con))
+                                       (parseArgs tName opts con contents)
+                          | con <- cons
+                          ]
+                          ++
+                          [ liftM2 (,)
+                              (normalG [|otherwise|])
+                              ( [|conNotFoundFail|]
+                                `appE` (litE $ stringL $ show tName)
+                                `appE` listE (map ( litE
+                                                  . stringL
+                                                  . nameBase
+                                                  . getConName
+                                                  )
+                                                  cons
+                                             )
+                                `appE` ([|T.unpack|] `appE` varE txt)
+                              )
+                          ]
+                         )
+                         []
+              , do other <- newName "other"
+                   match (varP other)
+                         ( normalB $
+                           (either (const [|typeNotString|])
+                                   (const [|firstElemNotString|])
+                                   contents)
+                             `appE` (litE $ stringL $ show tName)
+                             `appE` ([|valueConName|] `appE` varE other)
+                         )
+                         []
+              ]
+
+
+parseNullaryMatches :: Name -> Name -> [Q Match]
+parseNullaryMatches tName conName =
     [ do arr <- newName "arr"
          match (conP 'Array [varP arr])
-               ( normalB $ condE ([|V.null|] `appE` varE arr)
-                                 ([e|pure|] `appE` conE conName)
-                                 ( parseTypeMismatch tName conName
-                                     (litE $ stringL "an empty Array")
-                                     ( infixApp (litE $ stringL $ "Array of length ")
-                                                [|(++)|]
-                                                ([|show . V.length|] `appE` varE arr)
-                                     )
-                                 )
+               (guardedB $
+                [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
+                             ([|pure|] `appE` conE conName)
+                , liftM2 (,) (normalG [|otherwise|])
+                             (parseTypeMismatch tName conName
+                                (litE $ stringL "an empty Array")
+                                (infixApp (litE $ stringL $ "Array of length ")
+                                          [|(++)|]
+                                          ([|show . V.length|] `appE` varE arr)
+                                )
+                             )
+                ]
                )
                []
     , matchFailed tName conName "Array"
     ]
--- Unary constructors.
-parseArgs _ _ (NormalC conName [_]) =
+
+parseUnaryMatches :: Name -> [Q Match]
+parseUnaryMatches conName =
     [ do arg <- newName "arg"
          match (varP arg)
                ( normalB $ infixApp (conE conName)
-                                    [e|(<$>)|]
-                                    ([e|parseJSON|] `appE` varE arg)
+                                    [|(<$>)|]
+                                    ([|parseJSON|] `appE` varE arg)
                )
                []
     ]
+
+parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ
+parseRecord opts tName conName ts obj =
+    foldl' (\a b -> infixApp a [|(<*>)|] b)
+           (infixApp (conE conName) [|(<$>)|] x)
+           xs
+    where
+      x:xs = [ [|lookupField|]
+               `appE` (litE $ stringL $ show tName)
+               `appE` (litE $ stringL $ nameBase conName)
+               `appE` (varE obj)
+               `appE` ( [|T.pack|] `appE` fieldNameExp opts field
+                      )
+             | (field, _, _) <- ts
+             ]
+
+getValField :: Name -> String -> [MatchQ] -> Q Exp
+getValField obj valFieldName matches = do
+  val <- newName "val"
+  doE [ bindS (varP val) $ infixApp (varE obj)
+                                    [|(.:)|]
+                                    ([|T.pack|] `appE`
+                                       (litE $ stringL valFieldName))
+      , noBindS $ caseE (varE val) matches
+      ]
+
+-- | Generates code to parse the JSON encoding of a single constructor.
+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
+          -> Options -- ^ Encoding options.
+          -> Con -- ^ Constructor for which to generate JSON parsing code.
+          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
+                                        --   Right valName
+          -> Q Exp
+-- Nullary constructors.
+parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
+  getValField obj valFieldName $ parseNullaryMatches tName conName
+parseArgs tName _ (NormalC conName []) (Right valName) =
+  caseE (varE valName) $ parseNullaryMatches tName conName
+
+-- Unary constructors.
+parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =
+  getValField obj valFieldName $ parseUnaryMatches conName
+parseArgs _ _ (NormalC conName [_]) (Right valName) =
+  caseE (varE valName) $ parseUnaryMatches conName
+
 -- Polyadic constructors.
-parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts
+parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =
+    getValField obj valFieldName $ parseProduct tName conName $ genericLength ts
+parseArgs tName _ (NormalC conName ts) (Right valName) =
+    caseE (varE valName) $ parseProduct tName conName $ genericLength ts
+
 -- Records.
-parseArgs tName withField (RecC conName ts) =
-    [ do obj <- newName "recObj"
-         let x:xs = [ [|lookupField|]
-                      `appE` (litE $ stringL $ show tName)
-                      `appE` (litE $ stringL $ nameBase conName)
-                      `appE` (varE obj)
-                      `appE` ( [e|T.pack|]
-                               `appE`
-                               fieldNameExp withField field
-                             )
-                    | (field, _, _) <- ts
-                    ]
-         match (conP 'Object [varP obj])
-               ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)
-                                            [|(==)|]
-                                            (litE $ integerL $ genericLength ts)
-                                 )
-                                 ( foldl' (\a b -> infixApp a [|(<*>)|] b)
-                                          (infixApp (conE conName) [|(<$>)|] x)
-                                          xs
-                                 )
-                                 ( parseTypeMismatch tName conName
-                                     ( litE $ stringL $ "Object with "
-                                                        ++ show (length ts)
-                                                        ++ " name/value pairs"
-                                     )
-                                     ( infixApp ([|show . H.size|] `appE` varE obj)
-                                                [|(++)|]
-                                                (litE $ stringL $ " name/value pairs")
-                                     )
-                                 )
-               )
-               []
+parseArgs tName opts (RecC conName ts) (Left (_, obj)) =
+    parseRecord opts tName conName ts obj
+parseArgs tName opts (RecC conName ts) (Right valName) = do
+  obj <- newName "recObj"
+  caseE (varE valName)
+    [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []
     , matchFailed tName conName "Object"
     ]
+
 -- Infix constructors. Apart from syntax these are the same as
 -- polyadic constructors.
-parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2
+parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =
+    getValField obj valFieldName $ parseProduct tName conName 2
+parseArgs tName _ (InfixC _ conName _) (Right valName) =
+    caseE (varE valName) $ parseProduct tName conName 2
+
 -- Existentially quantified constructors. We ignore the quantifiers
 -- and proceed with the contained constructor.
-parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con
+parseArgs tName opts (ForallC _ _ con) contents =
+    parseArgs tName opts con contents
 
 -- | Generates code to parse the JSON encoding of an n-ary
 -- constructor.
           , actual
           ]
 
-lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
-lookupField tName rec obj key =
-    case H.lookup key obj of
-      Nothing -> unknownFieldFail tName rec (T.unpack key)
-      Just v  -> parseJSON v
+class (FromJSON a) => LookupField a where
+    lookupField :: String -> String -> Object -> T.Text -> Parser a
+
+instance (FromJSON a) => LookupField a where
+    lookupField tName rec obj key =
+        case H.lookup key obj of
+          Nothing -> unknownFieldFail tName rec (T.unpack key)
+          Just v  -> parseJSON v
+
+instance (FromJSON a) => LookupField (Maybe a) where
+    lookupField _ _ = (.:?)
 
 unknownFieldFail :: String -> String -> String -> Parser fail
 unknownFieldFail tName rec key =
     fail $ printf "When parsing the record %s of type %s the key %s was not present."
                   rec tName key
 
+noArrayFail :: String -> String -> Parser fail
+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o
+
 noObjectFail :: String -> String -> Parser fail
-noObjectFail t o =
-    fail $ printf "When parsing %s expected Object but got %s." t o
+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o
 
-wrongPairCountFail :: String -> String -> Parser fail
-wrongPairCountFail t n =
-    fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
-                  t n
+noStringFail :: String -> String -> Parser fail
+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
+
+noMatchFail :: String -> String -> Parser fail
+noMatchFail t o =
+    fail $ printf "When parsing %s expected a String with the name of a constructor but got %s." t o
+
+not2ElemArray :: String -> Int -> Parser fail
+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements"
+                                   t i
+typeNotString :: String -> String -> Parser fail
+typeNotString t o = fail $ printf "When parsing %s expected an Object where the type field is a String with the name of a constructor but got %s." t o
+
+firstElemNotString :: String -> String -> Parser fail
+firstElemNotString t o = fail $ printf "When parsing %s expected an Array where the first element is a String with the name of a constructor but got %s." t o
 
 conNotFoundFail :: String -> [String] -> String -> Parser fail
 conNotFoundFail t cs o =
-    fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
+    fail $ printf "When parsing %s expected a 2-element Array with a name and value element where the name is one of [%s], but got %s."
                   t (intercalate ", " cs) o
 
 parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
 conNameExp = litE . stringL . nameBase . getConName
 
 -- | Creates a string literal expression from a record field name.
-fieldNameExp :: (String -> String) -- ^ Function to change the field name.
+fieldNameExp :: Options -- ^ Encoding options
              -> Name
              -> Q Exp
-fieldNameExp f = litE . stringL . f . nameBase
+fieldNameExp opts = litE . stringL . fieldNameModifier opts . nameBase
 
 -- | The name of the outermost 'Value' constructor.
 valueConName :: Value -> String
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.