Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

Fixes #68 and fixes #66.
  • Loading branch information...
commit 2dff7bee05f41ece56d8890c72f3497d7d51be3f 1 parent 83a2433
@basvandijk basvandijk authored
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,7 +79,7 @@ module Data.Aeson.TH
--------------------------------------------------------------------------------
-- from aeson:
-import Data.Aeson ( toJSON, Object, object, (.=)
+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
, ToJSON, toJSON
, FromJSON, parseJSON
)
@@ -160,12 +87,14 @@ 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,126 +219,145 @@ 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
--------------------------------------------------------------------------------
@@ -393,34 +365,13 @@ encodeArgs withExp withField (ForallC _ _ 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
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.