Skip to content
Browse files

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

Fixes #68 and fixes #66.
  • Loading branch information...
1 parent 83a2433 commit 2dff7bee05f41ece56d8890c72f3497d7d51be3f @basvandijk committed Dec 8, 2012
Showing with 430 additions and 361 deletions.
  1. +430 −361 Data/Aeson/TH.hs
View
791 Data/Aeson/TH.hs
@@ -1,4 +1,11 @@
-{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}
+{-# LANGUAGE CPP
+ , NoImplicitPrelude
+ , TemplateHaskell
+ , NamedFieldPuns
+ , FlexibleInstances
+ , UndecidableInstances
+ , OverlappingInstances
+ #-}
{-|
Module: Data.Aeson.TH
@@ -30,91 +37,9 @@ change record field names. In this case we drop the first 4 characters of every
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.
@
@@ -132,13 +57,15 @@ Please note that you can derive instances for tuples using the following syntax:
@
-- FromJSON and ToJSON instances for 4-tuples.
-$('deriveJSON' id ''(,,,))
+$('deriveJSON' 'defaultOptions' ''(,,,))
@
-}
module Data.Aeson.TH
- ( deriveJSON
+ ( Options(..), SumEncoding(..), defaultOptions
+
+ , deriveJSON
, deriveToJSON
, deriveFromJSON
@@ -152,20 +79,22 @@ module Data.Aeson.TH
--------------------------------------------------------------------------------
-- from aeson:
-import Data.Aeson ( toJSON, Object, object, (.=)
+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
, ToJSON, toJSON
, FromJSON, parseJSON
)
import Data.Aeson.Types ( Value(..), Parser )
-- 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 )
@@ -176,17 +105,61 @@ import Control.Monad ( (>>=) )
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
--------------------------------------------------------------------------------
@@ -195,16 +168,16 @@ import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
--
-- 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)
--------------------------------------------------------------------------------
@@ -221,33 +194,13 @@ 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 -> '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
@@ -256,7 +209,7 @@ deriveToJSON withField name =
(classType `appT` instanceType)
[ funD 'toJSON
[ clause []
- (normalB $ consToJSON withField cons)
+ (normalB $ consToJSON opts cons)
[]
]
]
@@ -266,161 +219,159 @@ deriveToJSON withField name =
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
--------------------------------------------------------------------------------
-- 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 ->
--- 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
@@ -429,7 +380,7 @@ deriveFromJSON withField name =
(classType `appT` instanceType)
[ funD 'parseJSON
[ clause []
- (normalB $ consFromJSON name withField cons)
+ (normalB $ consFromJSON name opts cons)
[]
]
]
@@ -440,181 +391,280 @@ deriveFromJSON withField name =
-- | 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) (parseArgs tName opts con (Right value))
+
+consFromJSON tName opts cons = 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"
-
- 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)
- )
- []
- ]
-
- 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)
- )
- ]
-
- lam1E (varP value)
- $ caseE (varE value)
- [ match (conP 'Object [varP obj])
- (normalB caseLst)
- []
- , do other <- newName "other"
- match (varP other)
- ( normalB
- $ [|noObjectFail|]
+ lam1E (varP value) $ caseE (varE value) $
+ if nullaryToString opts && all isNullary cons
+ then allNullaryMatches
+ else mixedMatches
+
+ 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)
+ )
+ []
+ ]
+
+ 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)
+ )
+ []
+ ]
+
+ 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))
+ ]
--- | 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 []) =
+ 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.
@@ -678,29 +728,48 @@ parseTypeMismatch tName conName expected actual =
, 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
+
+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
-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
+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
@@ -753,10 +822,10 @@ conNameExp :: Con -> Q Exp
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

0 comments on commit 2dff7be

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