aeson 0.6.1.0 → 0.6.2.0
raw patch · 21 files changed
+1941/−711 lines, 21 filesdep ~unordered-containersdep ~vectorPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: unordered-containers, vector
API changes (from Hackage documentation)
+ Data.Aeson: class GFromJSON f
+ Data.Aeson: class GToJSON f
+ Data.Aeson: decodeStrict :: FromJSON a => ByteString -> Maybe a
+ Data.Aeson: decodeStrict' :: FromJSON a => ByteString -> Maybe a
+ Data.Aeson: eitherDecodeStrict :: FromJSON a => ByteString -> Either String a
+ Data.Aeson: eitherDecodeStrict' :: FromJSON a => ByteString -> Either String a
+ Data.Aeson: gParseJSON :: GFromJSON f => Options -> Value -> Parser (f a)
+ Data.Aeson: gToJSON :: GToJSON f => Options -> f a -> Value
+ Data.Aeson: genericParseJSON :: (Generic a, GFromJSON (Rep a)) => Options -> Value -> Parser a
+ Data.Aeson: genericToJSON :: (Generic a, GToJSON (Rep a)) => Options -> a -> Value
+ Data.Aeson.TH: ObjectWithSingleField :: SumEncoding
+ Data.Aeson.TH: Options :: (String -> String) -> (String -> String) -> Bool -> Bool -> SumEncoding -> Options
+ Data.Aeson.TH: TaggedObject :: String -> String -> SumEncoding
+ Data.Aeson.TH: TwoElemArray :: SumEncoding
+ Data.Aeson.TH: allNullaryToStringTag :: Options -> Bool
+ Data.Aeson.TH: constructorTagModifier :: Options -> String -> String
+ Data.Aeson.TH: contentsFieldName :: SumEncoding -> String
+ Data.Aeson.TH: data Options
+ Data.Aeson.TH: data SumEncoding
+ Data.Aeson.TH: defaultOptions :: Options
+ Data.Aeson.TH: defaultTaggedObject :: SumEncoding
+ Data.Aeson.TH: fieldLabelModifier :: Options -> String -> String
+ Data.Aeson.TH: instance [incoherent] FromJSON a => LookupField (Maybe a)
+ Data.Aeson.TH: instance [incoherent] FromJSON a => LookupField a
+ Data.Aeson.TH: omitNothingFields :: Options -> Bool
+ Data.Aeson.TH: sumEncoding :: Options -> SumEncoding
+ Data.Aeson.TH: tagFieldName :: SumEncoding -> String
+ Data.Aeson.Types: ObjectWithSingleField :: SumEncoding
+ Data.Aeson.Types: Options :: (String -> String) -> (String -> String) -> Bool -> Bool -> SumEncoding -> Options
+ Data.Aeson.Types: TaggedObject :: String -> String -> SumEncoding
+ Data.Aeson.Types: TwoElemArray :: SumEncoding
+ Data.Aeson.Types: allNullaryToStringTag :: Options -> Bool
+ Data.Aeson.Types: class GFromJSON f
+ Data.Aeson.Types: class GToJSON f
+ Data.Aeson.Types: constructorTagModifier :: Options -> String -> String
+ Data.Aeson.Types: contentsFieldName :: SumEncoding -> String
+ Data.Aeson.Types: data Options
+ Data.Aeson.Types: data SumEncoding
+ Data.Aeson.Types: defaultOptions :: Options
+ Data.Aeson.Types: defaultTaggedObject :: SumEncoding
+ Data.Aeson.Types: fieldLabelModifier :: Options -> String -> String
+ Data.Aeson.Types: gParseJSON :: GFromJSON f => Options -> Value -> Parser (f a)
+ Data.Aeson.Types: gToJSON :: GToJSON f => Options -> f a -> Value
+ Data.Aeson.Types: genericParseJSON :: (Generic a, GFromJSON (Rep a)) => Options -> Value -> Parser a
+ Data.Aeson.Types: genericToJSON :: (Generic a, GToJSON (Rep a)) => Options -> a -> Value
+ Data.Aeson.Types: modifyFailure :: (String -> String) -> Parser a -> Parser a
+ Data.Aeson.Types: omitNothingFields :: Options -> Bool
+ Data.Aeson.Types: sumEncoding :: Options -> SumEncoding
+ Data.Aeson.Types: tagFieldName :: SumEncoding -> String
- Data.Aeson: class FromJSON a where parseJSON = fmap to . gParseJSON
+ Data.Aeson: class FromJSON a where parseJSON = genericParseJSON defaultOptions
- Data.Aeson: class ToJSON a where toJSON = gToJSON . from
+ Data.Aeson: class ToJSON a where toJSON = genericToJSON defaultOptions
- Data.Aeson.TH: deriveFromJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: deriveFromJSON :: Options -> Name -> Q [Dec]
- Data.Aeson.TH: deriveJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: deriveJSON :: Options -> Name -> Q [Dec]
- Data.Aeson.TH: deriveToJSON :: (String -> String) -> Name -> Q [Dec]
+ Data.Aeson.TH: deriveToJSON :: Options -> Name -> Q [Dec]
- Data.Aeson.TH: mkParseJSON :: (String -> String) -> Name -> Q Exp
+ Data.Aeson.TH: mkParseJSON :: Options -> Name -> Q Exp
- Data.Aeson.TH: mkToJSON :: (String -> String) -> Name -> Q Exp
+ Data.Aeson.TH: mkToJSON :: Options -> Name -> Q Exp
- Data.Aeson.Types: class FromJSON a where parseJSON = fmap to . gParseJSON
+ Data.Aeson.Types: class FromJSON a where parseJSON = genericParseJSON defaultOptions
- Data.Aeson.Types: class ToJSON a where toJSON = gToJSON . from
+ Data.Aeson.Types: class ToJSON a where toJSON = genericToJSON defaultOptions
Files
- Data/Aeson.hs +79/−13
- Data/Aeson/Generic.hs +20/−3
- Data/Aeson/Parser/Internal.hs +48/−9
- Data/Aeson/TH.hs +477/−371
- Data/Aeson/Types.hs +15/−0
- Data/Aeson/Types/Class.hs +45/−5
- Data/Aeson/Types/Generic.hs +461/−130
- Data/Aeson/Types/Internal.hs +105/−2
- aeson.cabal +16/−4
- benchmarks/AesonCompareAutoInstances.hs +84/−51
- benchmarks/AesonEncode.hs +13/−12
- benchmarks/AesonParse.hs +3/−2
- benchmarks/CompareWithJSON.hs +9/−5
- benchmarks/Options.hs +8/−0
- tests/Encoders.hs +118/−0
- tests/Functions.hs +10/−0
- tests/Instances.hs +146/−0
- tests/Options.hs +26/−0
- tests/Properties.hs +131/−104
- tests/Properties/Deprecated.hs +57/−0
- tests/Types.hs +70/−0
Data/Aeson.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | -- Module: Data.Aeson -- Copyright: (c) 2011, 2012 Bryan O'Sullivan@@ -38,6 +40,11 @@ , eitherDecode , eitherDecode' , encode+ -- ** Variants for strict bytestrings+ , decodeStrict+ , decodeStrict'+ , eitherDecodeStrict+ , eitherDecodeStrict' -- * Core JSON types , Value(..) , Array@@ -49,6 +56,13 @@ , Result(..) , fromJSON , ToJSON(..)+#ifdef GENERICS+ -- ** Generic JSON classes+ , GFromJSON(..)+ , GToJSON(..)+ , genericToJSON+ , genericParseJSON+#endif -- * Inspecting @'Value's@ , withObject , withText@@ -67,40 +81,91 @@ ) where import Data.Aeson.Encode (encode)-import Data.Aeson.Parser.Internal (decodeWith, eitherDecodeWith, json, json')+import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith,+ eitherDecodeWith, eitherDecodeStrictWith,+ jsonEOF, json, jsonEOF', json') import Data.Aeson.Types+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. --+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace. This restriction is necessary to ensure+-- that if data is being lazily read from a file handle, the file+-- handle will be closed in a timely fashion once the document has+-- been parsed.+-- -- This function parses immediately, but defers conversion. See -- 'json' for details. decode :: (FromJSON a) => L.ByteString -> Maybe a-decode = decodeWith json fromJSON+decode = decodeWith jsonEOF fromJSON {-# INLINE decode #-} +-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses immediately, but defers conversion. See+-- 'json' for details.+decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a+decodeStrict = decodeStrictWith jsonEOF fromJSON+{-# INLINE decodeStrict #-}+ -- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. --+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace. This restriction is necessary to ensure+-- that if data is being lazily read from a file handle, the file+-- handle will be closed in a timely fashion once the document has+-- been parsed.+-- -- This function parses and performs conversion immediately. See -- 'json'' for details. decode' :: (FromJSON a) => L.ByteString -> Maybe a-decode' = decodeWith json' fromJSON+decode' = decodeWith jsonEOF' fromJSON {-# INLINE decode' #-} +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses and performs conversion immediately. See+-- 'json'' for details.+decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a+decodeStrict' = decodeStrictWith jsonEOF' fromJSON+{-# INLINE decodeStrict' #-}+ -- | Like 'decode' but returns an error message when decoding fails. eitherDecode :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode = eitherDecodeWith json fromJSON+eitherDecode = eitherDecodeWith jsonEOF fromJSON {-# INLINE eitherDecode #-} +-- | Like 'decodeStrict' but returns an error message when decoding fails.+eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict = eitherDecodeStrictWith jsonEOF fromJSON+{-# INLINE eitherDecodeStrict #-}+ -- | Like 'decode'' but returns an error message when decoding fails. eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode' = eitherDecodeWith json' fromJSON+eitherDecode' = eitherDecodeWith jsonEOF' fromJSON {-# INLINE eitherDecode' #-} +-- | Like 'decodeStrict'' but returns an error message when decoding fails.+eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict' = eitherDecodeStrictWith jsonEOF' fromJSON+{-# INLINE eitherDecodeStrict' #-}+ -- $use -- -- This section contains basic information on the different ways to@@ -119,13 +184,13 @@ -- > data Person = Person -- > { name :: Text -- > , age :: Int--- > } deriving Show-+-- > } deriving Show -- -- To decode data, we need to define a 'FromJSON' instance: -- -- > {-# LANGUAGE OverloadedStrings #-} -- >--- > instance FromJSON Coord where+-- > instance FromJSON Person where -- > parseJSON (Object v) = Person <$> -- > v .: "name" <*> -- > v .: "age"@@ -269,10 +334,11 @@ -- $pitfalls -- #pitfalls# ----- Note that the JSON standard only allows arrays or objects of things--- at the top-level. Since this library follows the standard, calling--- 'decode' on an unsupported result type will typecheck, but will--- always \"fail\":+-- Note that the JSON standard requires that the top-level value be+-- either an array or an object. If you try to use 'decode' with a+-- result type that is /not/ represented in JSON as an array or+-- object, your code will typecheck, but it will always \"fail\" at+-- runtime: -- -- > >>> decode "1" :: Maybe Int -- > Nothing@@ -314,5 +380,5 @@ -- converted to an AST, then the 'FromJSON' class is used to convert -- to the desired type. ----- For convenience, the 'encode' and--- 'decode' functions combine both steps for convenience.+-- For convenience, the 'encode' and 'decode' functions combine both+-- steps.
Data/Aeson/Generic.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE PatternGuards, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards, Rank2Types, ScopedTypeVariables, CPP #-} -- | -- Module: Data.Aeson.Generic--- Copyright: (c) 2011, 2012 Bryan O'Sullivan+-- Copyright: (c) 2011, 2012, 2013 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- (c) 2008, 2009 Lennart Augustsson -- License: BSD3 -- Maintainer: Bryan O'Sullivan <bos@serpentine.com>--- Stability: experimental+-- Stability: DEPRECATED -- Portability: portable -- -- JSON handling using 'Data.Generics'.@@ -16,6 +16,7 @@ -- by Lennart Augustsson. module Data.Aeson.Generic+{-# DEPRECATED "This module will be /REMOVED/ in version 0.7.0.0. Please switch to GHC generics or Data.Aeson.TH instead. These alternatives are less buggy, faster, and more configurable." #-} ( -- * Decoding and encoding decode@@ -84,6 +85,7 @@ toJSON :: (Data a) => a -> Value toJSON = toJSON_generic+ `ext1Q` maybe Null toJSON `ext1Q` list `ext1Q` vector `ext1Q` set@@ -187,6 +189,7 @@ parseJSON :: (Data a) => Value -> Parser a parseJSON j = parseJSON_generic j+ `ext1R` maybeP `ext1R` list `ext1R` vector `ext2R'` mapAny@@ -222,6 +225,8 @@ where value :: (T.FromJSON a) => Parser a value = T.parseJSON j+ maybeP :: (Data a) => Parser (Maybe a)+ maybeP = if j == Null then return Nothing else Just <$> parseJSON j list :: (Data a) => Parser [a] list = V.toList <$> parseJSON j vector :: (Data a) => Parser (V.Vector a)@@ -334,21 +339,33 @@ -- Type extension for binary type constructors. -- | Flexible type extension+#if MIN_VERSION_base(4,7,0)+ext2' :: (Data a, Typeable t)+#else ext2' :: (Data a, Typeable2 t)+#endif => c a -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) -> c a ext2' def ext = maybe def id (dataCast2 ext) -- | Type extension of queries for type constructors+#if MIN_VERSION_base(4,7,0)+ext2Q' :: (Data d, Typeable t)+#else ext2Q' :: (Data d, Typeable2 t)+#endif => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext)) -- | Type extension of readers for type constructors+#if MIN_VERSION_base(4,7,0)+ext2R' :: (Monad m, Data d, Typeable t)+#else ext2R' :: (Monad m, Data d, Typeable2 t)+#endif => m d -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) -> m d
Data/Aeson/Parser/Internal.hs view
@@ -15,15 +15,17 @@ module Data.Aeson.Parser.Internal ( -- * Lazy parsers- json+ json, jsonEOF , value , jstring -- * Strict parsers- , json'+ , json', jsonEOF' , value' -- * Helpers , decodeWith+ , decodeStrictWith , eitherDecodeWith+ , eitherDecodeStrictWith ) where import Blaze.ByteString.Builder (fromByteString, toByteString)@@ -37,7 +39,7 @@ import Data.Char (chr) import Data.Monoid (mappend, mempty) import Data.Text as T-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8') import Data.Vector as Vector hiding ((++)) import Data.Word (Word8) import qualified Data.Attoparsec as A@@ -175,11 +177,16 @@ then Nothing else Just (c == backslash) _ <- A.word8 doubleQuote- if backslash `B.elem` s- then case Z.parse unescape s of- Right r -> return (decodeUtf8 r)- Left err -> fail err- else return (decodeUtf8 s)+ s' <- if backslash `B.elem` s+ then case Z.parse unescape s of+ Right r -> return r+ Left err -> fail err+ else return s++ case decodeUtf8' s' of+ Right r -> return r+ Left err -> fail $ show err+ {-# INLINE jstring_ #-} unescape :: Z.Parser ByteString@@ -239,7 +246,18 @@ _ -> Nothing {-# INLINE decodeWith #-} -eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Either String a+decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+ -> Maybe a+decodeStrictWith p to s =+ case A.parse p s of+ A.Done _ v -> case to v of+ Success a -> Just a+ _ -> Nothing+ _ -> Nothing+{-# INLINE decodeStrictWith #-}++eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString+ -> Either String a eitherDecodeWith p to s = case L.parse p s of L.Done _ v -> case to v of@@ -248,6 +266,17 @@ L.Fail _ _ msg -> Left msg {-# INLINE eitherDecodeWith #-} +eitherDecodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+ -> Either String a+eitherDecodeStrictWith p to s =+ case A.parse p s of+ A.Done _ v -> case to v of+ Success a -> Right a+ Error msg -> Left msg+ A.Fail _ _ msg -> Left msg+ A.Partial _ -> Left "incomplete input"+{-# INLINE eitherDecodeStrictWith #-}+ -- $lazy -- -- The 'json' and 'value' parsers decouple identification from@@ -266,3 +295,13 @@ -- The 'json'' and 'value'' parsers combine identification with -- conversion. They consume more CPU cycles up front, but have a -- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json'.+jsonEOF :: Parser Value+jsonEOF = json <* skipSpace <* endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json''.+jsonEOF' :: Parser Value+jsonEOF' = json' <* skipSpace <* endOfInput
Data/Aeson/TH.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}+{-# LANGUAGE CPP, FlexibleInstances, NamedFieldPuns, NoImplicitPrelude,+ OverlappingInstances, TemplateHaskell, UndecidableInstances, IncoherentInstances+ #-} {-| Module: Data.Aeson.TH@@ -25,96 +27,15 @@ } deriving Eq @ -Next we derive the necessary instances. Note that we make use of the feature to-change record field names. In this case we drop the first 4 characters of every-field name.--@-$('deriveJSON' ('drop' 4) ''D)-@--This will result in the following (simplified) code to be spliced in your program:--@-import Control.Applicative-import Control.Monad-import Data.Aeson-import Data.Aeson.TH-import qualified Data.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- ]- ]-@+Next we derive the necessary instances. Note that we make use of the+feature to change record field names. In this case we drop the first 4+characters of every field name. We also modify constructor names by+lower-casing them: @-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\>\"+$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D) @ -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,14 +53,18 @@ @ -- FromJSON and ToJSON instances for 4-tuples.-$('deriveJSON' id ''(,,,))+$('deriveJSON' 'defaultOptions' ''(,,,)) @ -} module Data.Aeson.TH- ( deriveJSON+ ( -- * Encoding configuration+ Options(..), SumEncoding(..), defaultOptions, defaultTaggedObject + -- * FromJSON and ToJSON derivation+ , deriveJSON+ , deriveToJSON , deriveFromJSON @@ -152,37 +77,45 @@ -------------------------------------------------------------------------------- -- from aeson:-import Data.Aeson ( toJSON, Object, object, (.=)+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?) , ToJSON, toJSON , FromJSON, parseJSON )-import Data.Aeson.Types ( Value(..), Parser )+import Data.Aeson.Types ( Value(..), Parser+ , Options(..)+ , SumEncoding(..)+ , defaultOptions+ , defaultTaggedObject+ ) -- 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 ( ($), (.) ) import Data.Functor ( fmap )+import Data.Int ( Int )+import Data.Either ( Either(Left, Right) ) import Data.List ( (++), foldl, foldl', intercalate- , length, map, zip, genericLength+ , length, map, zip, genericLength, all, partition )-import Data.Maybe ( Maybe(Nothing, Just) )+import Data.Maybe ( Maybe(Nothing, Just), catMaybes ) import Prelude ( String, (-), Integer, fromIntegral, error ) import Text.Printf ( printf ) import Text.Show ( show ) #if __GLASGOW_HASKELL__ < 700-import Control.Monad ( (>>=) )+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, toList ) -- 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 ) @@ -195,16 +128,16 @@ -- -- 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 +154,13 @@ -} -- | 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 +169,7 @@ (classType `appT` instanceType) [ funD 'toJSON [ clause []- (normalB $ consToJSON withField cons)+ (normalB $ consToJSON opts cons) [] ] ]@@ -266,126 +179,181 @@ 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- ]+ matches+ | allNullaryToStringTag opts && all isNullary cons =+ [ match (conP conName []) (normalB $ conStr opts conName) []+ | con <- cons+ , let conName = getConName con+ ]+ | otherwise = [encodeArgs opts True con | con <- cons] +conStr :: Options -> Name -> Q Exp+conStr opts = appE [|String|] . conTxt opts++conTxt :: Options -> Name -> Q Exp+conTxt opts = appE [|T.pack|] . conStringE opts++conStringE :: Options -> Name -> Q Exp+conStringE opts = stringE . constructorTagModifier opts . 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 opts conName, exp])+ TaggedObject{tagFieldName, contentsFieldName} ->+ [|object|] `appE` listE+ [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)+ , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp+ ]+ ObjectWithSingleField ->+ [|object|] `appE` listE+ [ infixApp (conTxt opts conName) [|(.=)|] 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|(.=)|]- (varE arg)- | (arg, (field, _, _)) <- zip args ts- ]+ let exp = [|object|] `appE` pairs++ pairs | omitNothingFields opts = infixApp maybeFields+ [|(++)|]+ restFields+ | otherwise = listE $ map toPair argCons++ argCons = zip args ts++ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)++ restFields = listE $ map toPair rest++ (maybes, rest) = partition isMaybe argCons++ isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe+ isMaybe _ = False++ maybeToPair (arg, (field, _, _)) =+ infixApp (infixE (Just $ toFieldName field)+ [|(.=)|]+ Nothing)+ [|(<$>)|]+ (varE arg)++ toPair (arg, (field, _, _)) =+ infixApp (toFieldName field)+ [|(.=)|]+ (varE arg)++ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field+ 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 opts conName, exp]+ TaggedObject{tagFieldName} ->+ [|object|] `appE`+ -- TODO: Maybe throw an error in case+ -- tagFieldName overwrites a field in pairs.+ infixApp (infixApp [|T.pack tagFieldName|]+ [|(.=)|]+ (conStr opts conName))+ [|(:)|]+ pairs+ ObjectWithSingleField ->+ [|object|] `appE` listE+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]+ 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 +361,13 @@ -------------------------------------------------------------------------------- -- | 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 +376,7 @@ (classType `appT` instanceType) [ funD 'parseJSON [ clause []- (normalB $ consFromJSON name withField cons)+ (normalB $ consFromJSON name opts cons) [] ] ]@@ -440,181 +387,305 @@ -- | 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 allNullaryToStringTag 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`+ conStringE opts 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+ TaggedObject {tagFieldName, contentsFieldName} ->+ parseObject $ parseTaggedObject tagFieldName contentsFieldName+ ObjectWithSingleField ->+ parseObject $ parseObjectWithSingleField+ 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 f =+ [ do obj <- newName "obj"+ match (conP 'Object [varP obj]) (normalB $ f obj) []+ , do other <- newName "other"+ match (varP other)+ ( normalB+ $ [|noObjectFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]++ parseTaggedObject 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)) 'conNotFoundFailTaggedObject+ ]++ 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+ ]+ (caseE (varE conKey)+ [ do txt <- newName "txt"+ match (conP 'String [varP txt])+ (normalB $ parseContents txt+ (Right conVal)+ 'conNotFoundFail2ElemArray+ )+ []+ , do other <- newName "other"+ match (varP other)+ ( normalB+ $ [|firstElemNoStringFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|valueConName|] `appE` varE other)+ )+ []+ ]+ )++ parseObjectWithSingleField obj = do+ conKey <- newName "conKey"+ conVal <- newName "conVal"+ caseE ([e|H.toList|] `appE` varE obj)+ [ match (listP [tupP [varP conKey, varP conVal]])+ (normalB $ parseContents conKey (Right conVal) 'conNotFoundFailObjectSingleField)+ []+ , do other <- newName "other"+ match (varP other)+ (normalB $ [|wrongPairCountFail|]+ `appE` (litE $ stringL $ show tName)+ `appE` ([|show . length|] `appE` varE other)+ )+ []+ ]++ parseContents conKey contents errorFun =+ caseE (varE conKey)+ [ match wildP+ ( guardedB $+ [ do g <- normalG $ infixApp (varE conKey)+ [|(==)|]+ ([|T.pack|] `appE`+ conNameExp opts con)+ e <- parseArgs tName opts con contents+ return (g, e)+ | con <- cons+ ]+ +++ [ liftM2 (,)+ (normalG [e|otherwise|])+ ( varE errorFun+ `appE` (litE $ stringL $ show tName)+ `appE` listE (map ( litE+ . stringL+ . constructorTagModifier opts+ . nameBase+ . getConName+ ) cons+ )+ `appE` ([|T.unpack|] `appE` varE conKey)+ )+ ]+ )+ []+ ]++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 $ constructorTagModifier opts $ nameBase conName)+ `appE` (varE obj)+ `appE` ( [|T.pack|] `appE` fieldLabelExp 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,31 +749,62 @@ , 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 +firstElemNoStringFail :: String -> String -> Parser fail+firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." 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."+ fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs." t n -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."+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 tag 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++conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail+conNotFoundFail2ElemArray t cs o =+ fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s." t (intercalate ", " cs) o +conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail+conNotFoundFailObjectSingleField t cs o =+ fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."+ t (intercalate ", " cs) o++conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail+conNotFoundFailTaggedObject t cs o =+ fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."+ t (intercalate ", " cs) o+ parseTypeMismatch' :: String -> String -> String -> String -> Parser fail parseTypeMismatch' tName conName expected actual = fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."@@ -749,14 +851,18 @@ tvbName (KindedTV name _) = name -- | Makes a string literal expression from a constructor's name.-conNameExp :: Con -> Q Exp-conNameExp = litE . stringL . nameBase . getConName+conNameExp :: Options -> Con -> Q Exp+conNameExp opts = litE+ . stringL+ . constructorTagModifier opts+ . nameBase+ . getConName --- | Creates a string literal expression from a record field name.-fieldNameExp :: (String -> String) -- ^ Function to change the field name.- -> Name- -> Q Exp-fieldNameExp f = litE . stringL . f . nameBase+-- | Creates a string literal expression from a record field label.+fieldLabelExp :: Options -- ^ Encoding options+ -> Name+ -> Q Exp+fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase -- | The name of the outermost 'Value' constructor. valueConName :: Value -> String
Data/Aeson/Types.hs view
@@ -32,7 +32,16 @@ , parseEither , parseMaybe , ToJSON(..)+ , modifyFailure +#ifdef GENERICS+ -- ** Generic JSON classes+ , GFromJSON(..)+ , GToJSON(..)+ , genericToJSON+ , genericParseJSON+#endif+ -- * Inspecting @'Value's@ , withObject , withText@@ -46,6 +55,12 @@ , (.:?) , (.!=) , object++ -- * Generic and TH encoding configuration+ , Options(..)+ , SumEncoding(..)+ , defaultOptions+ , defaultTaggedObject ) where import Data.Aeson.Types.Class
Data/Aeson/Types/Class.hs view
@@ -28,6 +28,8 @@ -- ** Generic JSON classes , GFromJSON(..) , GToJSON(..)+ , genericToJSON+ , genericParseJSON #endif -- * Types , DotNetTime(..)@@ -67,7 +69,7 @@ import Data.Vector (Vector) import Data.Word (Word, Word8, Word16, Word32, Word64) import Foreign.Storable (Storable)-import System.Locale (defaultTimeLocale)+import System.Locale (defaultTimeLocale, dateTimeFmt) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import qualified Data.HashMap.Strict as H@@ -88,11 +90,29 @@ #ifdef GENERICS import GHC.Generics +-- | Class of generic representation types ('Rep') that can be converted to JSON. class GToJSON f where- gToJSON :: f a -> Value+ -- | This method (applied to 'defaultOptions') is used as the+ -- default generic implementation of 'toJSON'.+ gToJSON :: Options -> f a -> Value +-- | Class of generic representation types ('Rep') that can be converted from JSON. class GFromJSON f where- gParseJSON :: Value -> Parser (f a)+ -- | This method (applied to 'defaultOptions') is used as the+ -- default generic implementation of 'parseJSON'.+ gParseJSON :: Options -> Value -> Parser (f a)++-- | A configurable generic JSON encoder. This function applied to+-- 'defaultOptions' is used as the default for 'toJSON' when the type+-- is an instance of 'Generic'.+genericToJSON :: (Generic a, GToJSON (Rep a)) => Options -> a -> Value+genericToJSON opts = gToJSON opts . from++-- | A configurable generic JSON decoder. This function applied to+-- 'defaultOptions' is used as the default for 'parseJSON' when the+-- type is an instance of 'Generic'.+genericParseJSON :: (Generic a, GFromJSON (Rep a)) => Options -> Value -> Parser a+genericParseJSON opts = fmap to . gParseJSON opts #endif -- | A type that can be converted to JSON.@@ -138,12 +158,21 @@ -- -- instance ToJSON Coord -- @+--+-- Note that, instead of using @DefaultSignatures@, it's also possible+-- to parameterize the generic encoding using 'genericToJSON' applied+-- to your encoding/decoding 'Options':+--+-- @+-- instance ToJSON Coord where+-- toJSON = 'genericToJSON' 'defaultOptions'+-- @ class ToJSON a where toJSON :: a -> Value #ifdef GENERICS default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value- toJSON = gToJSON . from+ toJSON = genericToJSON defaultOptions #endif -- | A type that can be converted from JSON, with the possibility of@@ -199,12 +228,22 @@ -- -- instance FromJSON Coord -- @+--+-- Note that, instead of using @DefaultSignatures@, it's also possible+-- to parameterize the generic decoding using 'genericParseJSON' applied+-- to your encoding/decoding 'Options':+--+-- @+-- instance FromJSON Coord where+-- parseJSON = 'genericParseJSON' 'defaultOptions'+-- @+ class FromJSON a where parseJSON :: Value -> Parser a #ifdef GENERICS default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a- parseJSON = fmap to . gParseJSON+ parseJSON = genericParseJSON defaultOptions #endif instance (ToJSON a) => ToJSON (Maybe a) where@@ -643,6 +682,7 @@ Nothing -> empty tryFormats = foldr1 (<|>) . map tryFormat alternateFormats =+ dateTimeFmt defaultTimeLocale : distributeList ["%Y", "%Y-%m", "%F"] ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
Data/Aeson/Types/Generic.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,+{-# LANGUAGE CPP, DefaultSignatures, EmptyDataDecls, FlexibleInstances, FunctionalDependencies, KindSignatures, OverlappingInstances,- ScopedTypeVariables, TypeOperators, UndecidableInstances, ViewPatterns #-}+ ScopedTypeVariables, TypeOperators, UndecidableInstances,+ ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,+ RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- |@@ -18,16 +20,17 @@ module Data.Aeson.Types.Generic ( ) where import Control.Applicative ((<*>), (<$>), (<|>), pure)+import Control.Monad ((<=<)) import Control.Monad.ST (ST) import Data.Aeson.Types.Class import Data.Aeson.Types.Internal-import Data.Bits (shiftR)-import Data.DList (DList, toList)+import Data.Bits+import Data.DList (DList, toList, empty)+import Data.Maybe (fromMaybe) import Data.Monoid (mappend)-import Data.Text (pack, unpack)+import Data.Text (Text, pack, unpack) import GHC.Generics import qualified Data.HashMap.Strict as H-import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM @@ -35,242 +38,570 @@ -- Generic toJSON instance (GToJSON a) => GToJSON (M1 i c a) where- gToJSON = gToJSON . unM1+ -- Meta-information, which is not handled elsewhere, is ignored:+ gToJSON opts = gToJSON opts . unM1 {-# INLINE gToJSON #-} instance (ToJSON a) => GToJSON (K1 i a) where- gToJSON = toJSON . unK1+ -- Constant values are encoded using their ToJSON instance:+ gToJSON _opts = toJSON . unK1 {-# INLINE gToJSON #-} instance GToJSON U1 where- gToJSON _ = emptyArray+ -- Empty constructors are encoded to an empty array:+ gToJSON _opts _ = emptyArray {-# INLINE gToJSON #-} instance (ConsToJSON a) => GToJSON (C1 c a) where- gToJSON = consToJSON . unM1+ -- Constructors need to be encoded differently depending on whether they're+ -- a record or not. This distinction is made by 'constToJSON':+ gToJSON opts = consToJSON opts . unM1 {-# INLINE gToJSON #-} -instance ( GProductToValues a, GProductToValues b- , ProductSize a, ProductSize b) => GToJSON (a :*: b) where- gToJSON p = Array $ V.create $ do- mv <- VM.unsafeNew lenProduct- gProductToValues mv 0 lenProduct p- return mv+instance ( WriteProduct a, WriteProduct b+ , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where+ -- Products are encoded to an array. Here we allocate a mutable vector of+ -- the same size as the product and write the product's elements to it using+ -- 'writeProduct':+ gToJSON opts p =+ Array $ V.create $ do+ mv <- VM.unsafeNew lenProduct+ writeProduct opts mv 0 lenProduct p+ return mv where- lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+ productSize {-# INLINE gToJSON #-} -instance (GObject a, GObject b) => GToJSON (a :+: b) where- gToJSON (L1 x) = Object $ gObject x- gToJSON (R1 x) = Object $ gObject x+instance ( AllNullary (a :+: b) allNullary+ , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where+ -- If all constructors of a sum datatype are nullary and the+ -- 'allNullaryToStringTag' option is set they are encoded to+ -- strings. This distinction is made by 'sumToJSON':+ gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)+ . sumToJSON opts {-# INLINE gToJSON #-} -------------------------------------------------------------------------------- -class ConsToJSON f where consToJSON :: f a -> Value-class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)+class SumToJSON f allNullary where+ sumToJSON :: Options -> f a -> Tagged allNullary Value -newtype Tagged s b = Tagged {unTagged :: b}+instance ( GetConName f+ , TaggedObject f+ , ObjectWithSingleField f+ , TwoElemArray f ) => SumToJSON f True where+ sumToJSON opts+ | allNullaryToStringTag opts = Tagged . String . pack+ . constructorTagModifier opts . getConName+ | otherwise = Tagged . nonAllNullarySumToJSON opts+ {-# INLINE sumToJSON #-} -instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where- consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))+instance ( TwoElemArray f+ , TaggedObject f+ , ObjectWithSingleField f ) => SumToJSON f False where+ sumToJSON opts = Tagged . nonAllNullarySumToJSON opts+ {-# INLINE sumToJSON #-}++nonAllNullarySumToJSON :: ( TwoElemArray f+ , TaggedObject f+ , ObjectWithSingleField f+ ) => Options -> f a -> Value+nonAllNullarySumToJSON opts =+ case sumEncoding opts of+ TaggedObject{..} -> object . taggedObject opts tagFieldName+ contentsFieldName+ ObjectWithSingleField -> Object . objectWithSingleField opts+ TwoElemArray -> Array . twoElemArray opts+{-# INLINE nonAllNullarySumToJSON #-}++--------------------------------------------------------------------------------++class TaggedObject f where+ taggedObject :: Options -> String -> String -> f a -> [Pair]++instance ( TaggedObject a+ , TaggedObject b ) => TaggedObject (a :+: b) where+ taggedObject opts tagFieldName contentsFieldName (L1 x) =+ taggedObject opts tagFieldName contentsFieldName x+ taggedObject opts tagFieldName contentsFieldName (R1 x) =+ taggedObject opts tagFieldName contentsFieldName x+ {-# INLINE taggedObject #-}++instance ( IsRecord a isRecord+ , TaggedObject' a isRecord+ , Constructor c ) => TaggedObject (C1 c a) where+ taggedObject opts tagFieldName contentsFieldName =+ (pack tagFieldName .= constructorTagModifier opts+ (conName (undefined :: t c a p)) :) .+ (unTagged :: Tagged isRecord [Pair] -> [Pair]) .+ taggedObject' opts contentsFieldName . unM1+ {-# INLINE taggedObject #-}++class TaggedObject' f isRecord where+ taggedObject' :: Options -> String -> f a -> Tagged isRecord [Pair]++instance (RecordToPairs f) => TaggedObject' f True where+ taggedObject' opts _ = Tagged . toList . recordToPairs opts+ {-# INLINE taggedObject' #-}++instance (GToJSON f) => TaggedObject' f False where+ taggedObject' opts contentsFieldName =+ Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts+ {-# INLINE taggedObject' #-}++--------------------------------------------------------------------------------++-- | Get the name of the constructor of a sum datatype.+class GetConName f where+ getConName :: f a -> String++instance (GetConName a, GetConName b) => GetConName (a :+: b) where+ getConName (L1 x) = getConName x+ getConName (R1 x) = getConName x+ {-# INLINE getConName #-}++instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where+ getConName = conName+ {-# INLINE getConName #-}++--------------------------------------------------------------------------------++class TwoElemArray f where+ twoElemArray :: Options -> f a -> V.Vector Value++instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where+ twoElemArray opts (L1 x) = twoElemArray opts x+ twoElemArray opts (R1 x) = twoElemArray opts x+ {-# INLINE twoElemArray #-}++instance ( GToJSON a, ConsToJSON a+ , Constructor c ) => TwoElemArray (C1 c a) where+ twoElemArray opts x = V.create $ do+ mv <- VM.unsafeNew 2+ VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts+ $ conName (undefined :: t c a p)+ VM.unsafeWrite mv 1 $ gToJSON opts x+ return mv+ {-# INLINE twoElemArray #-}++--------------------------------------------------------------------------------++class ConsToJSON f where+ consToJSON :: Options -> f a -> Value++class ConsToJSON' f isRecord where+ consToJSON' :: Options -> f a -> Tagged isRecord Value++instance ( IsRecord f isRecord+ , ConsToJSON' f isRecord ) => ConsToJSON f where+ consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)+ . consToJSON' opts {-# INLINE consToJSON #-} -instance (GRecordToPairs f) => ConsToJSON' True f where- consToJSON' = Tagged (object . toList . gRecordToPairs)+instance (RecordToPairs f) => ConsToJSON' f True where+ consToJSON' opts = Tagged . object . toList . recordToPairs opts {-# INLINE consToJSON' #-} -instance GToJSON f => ConsToJSON' False f where- consToJSON' = Tagged gToJSON+instance GToJSON f => ConsToJSON' f False where+ consToJSON' opts = Tagged . gToJSON opts {-# INLINE consToJSON' #-} -------------------------------------------------------------------------------- -class GRecordToPairs f where- gRecordToPairs :: f a -> DList Pair+class RecordToPairs f where+ recordToPairs :: Options -> f a -> DList Pair -instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where- gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b- {-# INLINE gRecordToPairs #-}+instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where+ recordToPairs opts (a :*: b) = recordToPairs opts a `mappend`+ recordToPairs opts b+ {-# INLINE recordToPairs #-} -instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where- gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1))- {-# INLINE gRecordToPairs #-}+instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where+ recordToPairs = fieldToPair+ {-# INLINE recordToPairs #-} +instance (Selector s, ToJSON a) => RecordToPairs (S1 s (K1 i (Maybe a))) where+ recordToPairs opts (M1 k1) | omitNothingFields opts+ , K1 Nothing <- k1 = empty+ recordToPairs opts m1 = fieldToPair opts m1+ {-# INLINE recordToPairs #-}++fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair+fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1+ , gToJSON opts (unM1 m1)+ )+{-# INLINE fieldToPair #-}+ -------------------------------------------------------------------------------- -class GProductToValues f where- gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s ()+class WriteProduct f where+ writeProduct :: Options+ -> VM.MVector s Value+ -> Int -- ^ index+ -> Int -- ^ length+ -> f a+ -> ST s () -instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where- gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix lenL a- gProductToValues mv ixR lenR b+instance ( WriteProduct a+ , WriteProduct b ) => WriteProduct (a :*: b) where+ writeProduct opts mv ix len (a :*: b) = do+ writeProduct opts mv ix lenL a+ writeProduct opts mv ixR lenR b where+#if MIN_VERSION_base(4,5,0)+ lenL = len `unsafeShiftR` 1+#else lenL = len `shiftR` 1- ixR = ix + lenL+#endif lenR = len - lenL- {-# INLINE gProductToValues #-}+ ixR = ix + lenL+ {-# INLINE writeProduct #-} -instance (GToJSON a) => GProductToValues a where- gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON- {-# INLINE gProductToValues #-}+instance (GToJSON a) => WriteProduct a where+ writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts+ {-# INLINE writeProduct #-} -------------------------------------------------------------------------------- -class GObject f where- gObject :: f a -> Object+class ObjectWithSingleField f where+ objectWithSingleField :: Options -> f a -> Object -instance (GObject a, GObject b) => GObject (a :+: b) where- gObject (L1 x) = gObject x- gObject (R1 x) = gObject x- {-# INLINE gObject #-}+instance ( ObjectWithSingleField a+ , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where+ objectWithSingleField opts (L1 x) = objectWithSingleField opts x+ objectWithSingleField opts (R1 x) = objectWithSingleField opts x+ {-# INLINE objectWithSingleField #-} -instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where- gObject = H.singleton (pack $ conName (undefined :: t c a p)) . gToJSON- {-# INLINE gObject #-}+instance ( GToJSON a, ConsToJSON a+ , Constructor c ) => ObjectWithSingleField (C1 c a) where+ objectWithSingleField opts = H.singleton typ . gToJSON opts+ where+ typ = pack $ constructorTagModifier opts $+ conName (undefined :: t c a p)+ {-# INLINE objectWithSingleField #-} -------------------------------------------------------------------------------- -- Generic parseJSON instance (GFromJSON a) => GFromJSON (M1 i c a) where- gParseJSON = fmap M1 . gParseJSON+ -- Meta-information, which is not handled elsewhere, is just added to the+ -- parsed value:+ gParseJSON opts = fmap M1 . gParseJSON opts {-# INLINE gParseJSON #-} instance (FromJSON a) => GFromJSON (K1 i a) where- gParseJSON = fmap K1 . parseJSON+ -- Constant values are decoded using their FromJSON instance:+ gParseJSON _opts = fmap K1 . parseJSON {-# INLINE gParseJSON #-} instance GFromJSON U1 where- gParseJSON v+ -- Empty constructors are expected to be encoded as an empty array:+ gParseJSON _opts v | isEmptyArray v = pure U1 | otherwise = typeMismatch "unit constructor (U1)" v {-# INLINE gParseJSON #-} instance (ConsFromJSON a) => GFromJSON (C1 c a) where- gParseJSON = fmap M1 . consParseJSON+ -- Constructors need to be decoded differently depending on whether they're+ -- a record or not. This distinction is made by consParseJSON:+ gParseJSON opts = fmap M1 . consParseJSON opts {-# INLINE gParseJSON #-} -instance ( GFromProduct a, GFromProduct b- , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where- gParseJSON (Array arr)- | lenArray == lenProduct = gParseProduct arr 0 lenProduct- | otherwise =- fail $ "When expecting a product of " ++ show lenProduct ++- " values, encountered an Array of " ++ show lenArray ++- " elements instead"- where- lenArray = V.length arr- lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)-- gParseJSON v = typeMismatch "product (:*:)" v+instance ( FromProduct a, FromProduct b+ , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where+ -- Products are expected to be encoded to an array. Here we check whether we+ -- got an array of the same size as the product, then parse each of the+ -- product's elements using parseProduct:+ gParseJSON opts = withArray "product (:*:)" $ \arr ->+ let lenArray = V.length arr+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+ productSize in+ if lenArray == lenProduct+ then parseProduct opts arr 0 lenProduct+ else fail $ "When expecting a product of " ++ show lenProduct +++ " values, encountered an Array of " ++ show lenArray +++ " elements instead" {-# INLINE gParseJSON #-} -instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where- gParseJSON (Object (H.toList -> [keyVal@(key, _)])) =- case gParseSum keyVal of- Nothing -> notFound $ unpack key- Just p -> p- gParseJSON v = typeMismatch "sum (:+:)" v+instance ( AllNullary (a :+: b) allNullary+ , ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where+ -- If all constructors of a sum datatype are nullary and the+ -- 'allNullaryToStringTag' option is set they are expected to be+ -- encoded as strings. This distinction is made by 'parseSum':+ gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->+ (Parser ((a :+: b) d)))+ . parseSum opts {-# INLINE gParseJSON #-} -notFound :: String -> Parser a-notFound key = fail $ "The key \"" ++ key ++ "\" was not found"-{-# INLINE notFound #-}+-------------------------------------------------------------------------------- +class ParseSum f allNullary where+ parseSum :: Options -> Value -> Tagged allNullary (Parser (f a))++instance ( SumFromString (a :+: b)+ , FromPair (a :+: b)+ , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) True where+ parseSum opts+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts+ | otherwise = Tagged . parseNonAllNullarySum opts+ {-# INLINE parseSum #-}++instance ( FromPair (a :+: b)+ , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where+ parseSum opts = Tagged . parseNonAllNullarySum opts+ {-# INLINE parseSum #-}+ -------------------------------------------------------------------------------- -class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)-class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)+parseAllNullarySum opts = withText "Text" $ \key ->+ maybe (notFound $ unpack key) return $+ parseSumFromString opts key+{-# INLINE parseAllNullarySum #-} -instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where- consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))- {-# INLINE consParseJSON #-}+class SumFromString f where+ parseSumFromString :: Options -> Text -> Maybe (f a) -instance (GFromRecord f) => ConsFromJSON' True f where- consParseJSON' = Tagged parseRecord+instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where+ parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>+ (R1 <$> parseSumFromString opts key)+ {-# INLINE parseSumFromString #-}++instance (Constructor c) => SumFromString (C1 c U1) where+ parseSumFromString opts key | key == name = Just $ M1 U1+ | otherwise = Nothing where- parseRecord (Object obj) = gParseRecord obj- parseRecord v = typeMismatch "record (:*:)" v+ name = pack $ constructorTagModifier opts $+ conName (undefined :: t c U1 p)+ {-# INLINE parseSumFromString #-}++--------------------------------------------------------------------------------++parseNonAllNullarySum :: ( FromPair (a :+: b)+ , FromTaggedObject (a :+: b)+ ) => Options -> Value -> Parser ((a :+: b) c)+parseNonAllNullarySum opts =+ case sumEncoding opts of+ TaggedObject{..} ->+ withObject "Object" $ \obj -> do+ tag <- obj .: pack tagFieldName+ fromMaybe (notFound $ unpack tag) $+ parseFromTaggedObject opts contentsFieldName obj tag++ ObjectWithSingleField ->+ withObject "Object" $ \obj ->+ case H.toList obj of+ [pair@(tag, _)] -> fromMaybe (notFound $ unpack tag) $+ parsePair opts pair+ _ -> fail "Object doesn't have a single field"++ TwoElemArray ->+ withArray "Array" $ \arr ->+ if V.length arr == 2+ then case V.unsafeIndex arr 0 of+ String tag -> fromMaybe (notFound $ unpack tag) $+ parsePair opts (tag, V.unsafeIndex arr 1)+ _ -> fail "First element is not a String"+ else fail "Array doesn't have 2 elements"+{-# INLINE parseNonAllNullarySum #-}++--------------------------------------------------------------------------------++class FromTaggedObject f where+ parseFromTaggedObject :: Options -> String -> Object -> Text+ -> Maybe (Parser (f a))++instance (FromTaggedObject a, FromTaggedObject b) =>+ FromTaggedObject (a :+: b) where+ parseFromTaggedObject opts contentsFieldName obj tag =+ (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>+ (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)+ {-# INLINE parseFromTaggedObject #-}++instance ( FromTaggedObject' f+ , Constructor c ) => FromTaggedObject (C1 c f) where+ parseFromTaggedObject opts contentsFieldName obj tag+ | tag == name = Just $ M1 <$> parseFromTaggedObject'+ opts contentsFieldName obj+ | otherwise = Nothing+ where+ name = pack $ constructorTagModifier opts $+ conName (undefined :: t c f p)+ {-# INLINE parseFromTaggedObject #-}++--------------------------------------------------------------------------------++class FromTaggedObject' f where+ parseFromTaggedObject' :: Options -> String -> Object -> Parser (f a)++class FromTaggedObject'' f isRecord where+ parseFromTaggedObject'' :: Options -> String -> Object+ -> Tagged isRecord (Parser (f a))++instance ( IsRecord f isRecord+ , FromTaggedObject'' f isRecord+ ) => FromTaggedObject' f where+ parseFromTaggedObject' opts contentsFieldName =+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .+ parseFromTaggedObject'' opts contentsFieldName+ {-# INLINE parseFromTaggedObject' #-}++instance (FromRecord f) => FromTaggedObject'' f True where+ parseFromTaggedObject'' opts _ = Tagged . parseRecord opts+ {-# INLINE parseFromTaggedObject'' #-}++instance (GFromJSON f) => FromTaggedObject'' f False where+ parseFromTaggedObject'' opts contentsFieldName = Tagged .+ (gParseJSON opts <=< (.: pack contentsFieldName))+ {-# INLINE parseFromTaggedObject'' #-}++--------------------------------------------------------------------------------++class ConsFromJSON f where+ consParseJSON :: Options -> Value -> Parser (f a)++class ConsFromJSON' f isRecord where+ consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))++instance ( IsRecord f isRecord+ , ConsFromJSON' f isRecord+ ) => ConsFromJSON f where+ consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))+ . consParseJSON' opts+ {-# INLINE consParseJSON #-}++instance (FromRecord f) => ConsFromJSON' f True where+ consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts) {-# INLINE consParseJSON' #-} -instance (GFromJSON f) => ConsFromJSON' False f where- consParseJSON' = Tagged gParseJSON+instance (GFromJSON f) => ConsFromJSON' f False where+ consParseJSON' opts = Tagged . gParseJSON opts {-# INLINE consParseJSON' #-} -------------------------------------------------------------------------------- -class GFromRecord f where- gParseRecord :: Object -> Parser (f a)+class FromRecord f where+ parseRecord :: Options -> Object -> Parser (f a) -instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where- gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj- {-# INLINE gParseRecord #-}+instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where+ parseRecord opts obj = (:*:) <$> parseRecord opts obj+ <*> parseRecord opts obj+ {-# INLINE parseRecord #-} -instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where- gParseRecord = maybe (notFound key) gParseJSON . H.lookup (T.pack key)+instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where+ parseRecord opts = maybe (notFound label) (gParseJSON opts)+ . H.lookup (pack label) where- key = selName (undefined :: t s a p)- {-# INLINE gParseRecord #-}+ label = fieldLabelModifier opts $ selName (undefined :: t s a p)+ {-# INLINE parseRecord #-} +instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where+ parseRecord opts obj = (M1 . K1) <$> obj .:? pack label+ where+ label = fieldLabelModifier opts $+ selName (undefined :: t s (K1 i (Maybe a)) p)+ {-# INLINE parseRecord #-}+ -------------------------------------------------------------------------------- class ProductSize f where productSize :: Tagged2 f Int -newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}- instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) + unTagged2 (productSize :: Tagged2 b Int)+ {-# INLINE productSize #-} instance ProductSize (S1 s a) where productSize = Tagged2 1+ {-# INLINE productSize #-} -------------------------------------------------------------------------------- -class GFromProduct f where- gParseProduct :: Array -> Int -> Int -> Parser (f a)+class FromProduct f where+ parseProduct :: Options -> Array -> Int -> Int -> Parser (f a) -instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where- gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL- <*> gParseProduct arr ixR lenR+instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where+ parseProduct opts arr ix len =+ (:*:) <$> parseProduct opts arr ix lenL+ <*> parseProduct opts arr ixR lenR where+#if MIN_VERSION_base(4,5,0)+ lenL = len `unsafeShiftR` 1+#else lenL = len `shiftR` 1+#endif ixR = ix + lenL lenR = len - lenL- {-# INLINE gParseProduct #-}+ {-# INLINE parseProduct #-} -instance (GFromJSON a) => GFromProduct (S1 s a) where- gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix- {-# INLINE gParseProduct #-}+instance (GFromJSON a) => FromProduct (S1 s a) where+ parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix+ {-# INLINE parseProduct #-} -------------------------------------------------------------------------------- -class GFromSum f where- gParseSum :: Pair -> Maybe (Parser (f a))+class FromPair f where+ parsePair :: Options -> Pair -> Maybe (Parser (f a)) -instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where- gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>- (fmap R1 <$> gParseSum keyVal)- {-# INLINE gParseSum #-}+instance (FromPair a, FromPair b) => FromPair (a :+: b) where+ parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>+ (fmap R1 <$> parsePair opts pair)+ {-# INLINE parsePair #-} -instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where- gParseSum (key, value)- | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value- | otherwise = Nothing- {-# INLINE gParseSum #-}+instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where+ parsePair opts (tag, value)+ | tag == tag' = Just $ gParseJSON opts value+ | otherwise = Nothing+ where+ tag' = pack $ constructorTagModifier opts $+ conName (undefined :: t c a p)+ {-# INLINE parsePair #-} -------------------------------------------------------------------------------- -class IsRecord (f :: * -> *) b | f -> b--data True-data False+class IsRecord (f :: * -> *) isRecord | f -> isRecord -instance (IsRecord f b) => IsRecord (f :*: g) b+instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord instance IsRecord (M1 S NoSelector f) False-instance (IsRecord f b) => IsRecord (M1 S c f) b+instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord instance IsRecord (K1 i c) True instance IsRecord U1 False --------------------------------------------------------------------------------++class AllNullary (f :: * -> *) allNullary | f -> allNullary++instance ( AllNullary a allNullaryL+ , AllNullary b allNullaryR+ , And allNullaryL allNullaryR allNullary+ ) => AllNullary (a :+: b) allNullary+instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary+instance AllNullary (a :*: b) False+instance AllNullary (K1 i c) False+instance AllNullary U1 True++--------------------------------------------------------------------------------++data True+data False++class And bool1 bool2 bool3 | bool1 bool2 -> bool3++instance And True True True+instance And False False False+instance And False True False+instance And True False False++--------------------------------------------------------------------------------++newtype Tagged s b = Tagged {unTagged :: b}++newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}++--------------------------------------------------------------------------------++notFound :: String -> Parser a+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"+{-# INLINE notFound #-}
Data/Aeson/Types/Internal.hs view
@@ -26,13 +26,20 @@ , parse , parseEither , parseMaybe+ , modifyFailure -- * Constructors and accessors , object++ -- * Generic and TH encoding configuration+ , Options(..)+ , SumEncoding(..)+ , defaultOptions+ , defaultTaggedObject ) where import Control.Applicative+import Control.Monad import Control.DeepSeq (NFData(..))-import Control.Monad.State.Strict import Data.Attoparsec.Char8 (Number(..)) import Data.Hashable (Hashable(..)) import Data.HashMap.Strict (HashMap)@@ -215,13 +222,109 @@ -- | Run a 'Parser' with an 'Either' result type. parseEither :: (a -> Parser b) -> a -> Either String b parseEither m v = runParser (m v) Left Right+{-# INLINE parseEither #-} -- | A key\/value pair for an 'Object'. type Pair = (Text, Value) -{-# INLINE parseEither #-} -- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate -- keys arise, earlier keys and their associated values win. object :: [Pair] -> Value object = Object . H.fromList {-# INLINE object #-}++-- | If the inner @Parser@ failed, modify the failure message using the+-- provided function. This allows you to create more descriptive error messages.+-- For example:+--+-- > parseJSON (Object o) = modifyFailure+-- > ("Parsing of the Foo value failed: " ++)+-- > (Foo <$> o .: "someField")+--+-- Since 0.6.2.0+modifyFailure :: (String -> String) -> Parser a -> Parser a+modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)++--------------------------------------------------------------------------------+-- Generic and TH encoding configuration+--------------------------------------------------------------------------------++-- | Options that specify how to encode\/decode your datatype to\/from JSON.+data Options = Options+ { fieldLabelModifier :: String -> String+ -- ^ Function applied to field labels.+ -- Handy for removing common record prefixes for example.+ , constructorTagModifier :: String -> String+ -- ^ Function applied to constructor tags which could be handy+ -- for lower-casing them for example.+ , allNullaryToStringTag :: Bool+ -- ^ If 'True' the constructors of a datatype, with /all/+ -- nullary constructors, will be encoded to just a string with+ -- the constructor tag. If 'False' the encoding will always+ -- follow the `sumEncoding`.+ , omitNothingFields :: Bool+ -- ^ If 'True' record fields with a 'Nothing' value will be+ -- omitted from the resulting object. If 'False' the resulting+ -- object will include those fields mapping to @null@.+ , sumEncoding :: SumEncoding+ -- ^ Specifies how to encode constructors of a sum datatype.+ }++-- | Specifies how to encode constructors of a sum datatype.+data SumEncoding =+ TaggedObject { tagFieldName :: String+ , contentsFieldName :: String+ }+ -- ^ A constructor will be encoded to an object with a field+ -- 'tagFieldName' which specifies the constructor tag (modified by+ -- the 'constructorTagModifier'). If the constructor is a record+ -- the encoded record fields will be unpacked into this object. So+ -- make sure that your record doesn't have a field with the same+ -- label as the 'tagFieldName'. Otherwise the tag gets overwritten+ -- by the encoded value of that field! If the constructor is not a+ -- record the encoded constructor contents will be stored under+ -- the 'contentsFieldName' field.+ | ObjectWithSingleField+ -- ^ A constructor will be encoded to an object with a single+ -- field named after the constructor tag (modified by the+ -- 'constructorTagModifier') which maps to the encoded contents of+ -- the constructor.+ | TwoElemArray+ -- ^ A constructor will be encoded to a 2-element array where the+ -- first element is the tag of the constructor (modified by the+ -- 'constructorTagModifier') and the second element the encoded+ -- contents of the constructor.++-- | Default encoding 'Options':+--+-- @+-- 'Options'+-- { 'fieldLabelModifier' = id+-- , 'constructorTagModifier' = id+-- , 'allNullaryToStringTag' = True+-- , 'omitNothingFields' = False+-- , 'sumEncoding' = 'defaultTaggedObject'+-- }+-- @+defaultOptions :: Options+defaultOptions = Options+ { fieldLabelModifier = id+ , constructorTagModifier = id+ , allNullaryToStringTag = True+ , omitNothingFields = False+ , sumEncoding = defaultTaggedObject+ }++-- | Default 'TaggedObject' 'SumEncoding' options:+--+-- @+-- defaultTaggedObject = 'TaggedObject'+-- { 'tagFieldName' = \"tag\"+-- , 'contentsFieldName' = \"contents\"+-- }+-- @+defaultTaggedObject :: SumEncoding+defaultTaggedObject = TaggedObject+ { tagFieldName = "tag"+ , contentsFieldName = "contents"+ }
aeson.cabal view
@@ -1,9 +1,9 @@ name: aeson-version: 0.6.1.0+version: 0.6.2.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON-copyright: (c) 2011, 2012 Bryan O'Sullivan+copyright: (c) 2011, 2012, 2013 Bryan O'Sullivan (c) 2011 MailRank, Inc. author: Bryan O'Sullivan <bos@serpentine.com> maintainer: Bryan O'Sullivan <bos@serpentine.com>@@ -86,7 +86,6 @@ benchmarks/json-data/*.json examples/*.hs release-notes.markdown- tests/Properties.hs flag developer description: operate in developer mode@@ -140,9 +139,19 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Properties.hs+ other-modules: Functions+ Instances+ Types+ Options+ Encoders+ Properties.Deprecated ghc-options: -Wall -threaded -rtsopts+ if impl(ghc < 7.4)+ ghc-options: -fcontext-stack=40+ if impl(ghc >= 7.2)+ cpp-options: -DGHC_GENERICS build-depends: QuickCheck,@@ -155,7 +164,10 @@ test-framework, test-framework-quickcheck2, text,- time+ time,+ unordered-containers,+ vector,+ ghc-prim >= 0.2 source-repository head type: git
benchmarks/AesonCompareAutoInstances.hs view
@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -import Criterion.Main+import Criterion.Main hiding (defaultOptions) import Control.DeepSeq (NFData, rnf, deepseq) @@ -13,20 +13,26 @@ import GHC.Generics (Generic) import Data.Aeson.Types-import Data.Aeson.TH (mkToJSON, mkParseJSON)+import Data.Aeson.TH import qualified Data.Aeson.Generic as G (fromJSON, toJSON) +import Data.Aeson.Encode++import Options+ -------------------------------------------------------------------------------- --- Taken from the documentation of Data.Aeson.TH: data D a = Nullary | Unary Int | Product String Char a | Record { testOne :: Double , testTwo :: Bool , testThree :: D a- } deriving (Show, Eq, Generic, Data, Typeable)+ }+ deriving (Show, Eq, Data, Typeable) +deriveJSON opts ''D+ instance NFData a => NFData (D a) where rnf Nullary = () rnf (Unary n) = rnf n@@ -47,18 +53,43 @@ } } -instance ToJSON a => ToJSON (D a)-instance FromJSON a => FromJSON (D a)+-------------------------------------------------------------------------------- -thDToJSON :: ToJSON a => D a -> Value-thDToJSON = $(mkToJSON id ''D)+data D' a = Nullary'+ | Unary' Int+ | Product' String Char a+ | Record' { testOne' :: Double+ , testTwo' :: Bool+ , testThree' :: D' a+ }+ deriving (Show, Eq, Generic, Data, Typeable) -thDParseJSON :: FromJSON a => Value -> Parser (D a)-thDParseJSON = $(mkParseJSON id ''D)+instance ToJSON a => ToJSON (D' a) where+ toJSON = genericToJSON opts -thDFromJSON :: FromJSON a => Value -> Result (D a)-thDFromJSON = parse thDParseJSON+instance FromJSON a => FromJSON (D' a) where+ parseJSON = genericParseJSON opts +instance NFData a => NFData (D' a) where+ rnf Nullary' = ()+ rnf (Unary' n) = rnf n+ rnf (Product' s c x) = s `deepseq` c `deepseq` rnf x+ rnf (Record' d b y) = d `deepseq` b `deepseq` rnf y++type T' = D' (D' (D' ()))++d' :: T'+d' = Record'+ { testOne' = 1234.56789+ , testTwo' = True+ , testThree' = Product' "Hello World!" 'a' $+ Record'+ { testOne' = 9876.54321+ , testTwo' = False+ , testThree' = Product' "Yeehaa!!!" '\n' Nullary'+ }+ }+ -------------------------------------------------------------------------------- data BigRecord = BigRecord@@ -77,17 +108,17 @@ 16 17 18 19 20 21 22 23 24 25 -instance ToJSON BigRecord-instance FromJSON BigRecord+gBigRecordToJSON :: BigRecord -> Value+gBigRecordToJSON = genericToJSON opts -thBigRecordToJSON :: BigRecord -> Value-thBigRecordToJSON = $(mkToJSON id ''BigRecord)+gBigRecordFromJSON :: Value -> Result BigRecord+gBigRecordFromJSON = parse $ genericParseJSON opts -thBigRecordParseJSON :: Value -> Parser BigRecord-thBigRecordParseJSON = $(mkParseJSON id ''BigRecord)+thBigRecordToJSON :: BigRecord -> Value+thBigRecordToJSON = $(mkToJSON opts ''BigRecord) thBigRecordFromJSON :: Value -> Result BigRecord-thBigRecordFromJSON = parse thBigRecordParseJSON+thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord) -------------------------------------------------------------------------------- @@ -107,17 +138,17 @@ 16 17 18 19 20 21 22 23 24 25 -instance ToJSON BigProduct-instance FromJSON BigProduct+gBigProductToJSON :: BigProduct -> Value+gBigProductToJSON = genericToJSON opts -thBigProductToJSON :: BigProduct -> Value-thBigProductToJSON = $(mkToJSON id ''BigProduct)+gBigProductFromJSON :: Value -> Result BigProduct+gBigProductFromJSON = parse $ genericParseJSON opts -thBigProductParseJSON :: Value -> Parser BigProduct-thBigProductParseJSON = $(mkParseJSON id ''BigProduct)+thBigProductToJSON :: BigProduct -> Value+thBigProductToJSON = $(mkToJSON opts ''BigProduct) thBigProductFromJSON :: Value -> Result BigProduct-thBigProductFromJSON = parse thBigProductParseJSON+thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct) -------------------------------------------------------------------------------- @@ -132,17 +163,17 @@ bigSum = F25 -instance ToJSON BigSum-instance FromJSON BigSum+gBigSumToJSON :: BigSum -> Value+gBigSumToJSON = genericToJSON opts -thBigSumToJSON :: BigSum -> Value-thBigSumToJSON = $(mkToJSON id ''BigSum)+gBigSumFromJSON :: Value -> Result BigSum+gBigSumFromJSON = parse $ genericParseJSON opts -thBigSumParseJSON :: Value -> Parser BigSum-thBigSumParseJSON = $(mkParseJSON id ''BigSum)+thBigSumToJSON :: BigSum -> Value+thBigSumToJSON = $(mkToJSON opts ''BigSum) thBigSumFromJSON :: Value -> Result BigSum-thBigSumFromJSON = parse thBigSumParseJSON+thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum) -------------------------------------------------------------------------------- @@ -150,49 +181,51 @@ main :: IO () main = defaultMain- [ let v = thDToJSON d- in d `deepseq` v `deepseq`+ [ let v = toJSON d+ in (d, d', v) `deepseq` bgroup "D"- [ group "toJSON" (nf thDToJSON d)- (nf G.toJSON d)- (nf toJSON d)- , group "fromJSON" (nf (thDFromJSON :: FJ T) v)- (nf (G.fromJSON :: FJ T) v)- (nf (fromJSON :: FJ T) v)+ [ group "toJSON" (nf toJSON d)+ (nf G.toJSON d)+ (nf toJSON d')+ , group "fromJSON" (nf ( fromJSON :: FJ T ) v)+ (nf (G.fromJSON :: FJ T ) v)+ (nf ( fromJSON :: FJ T') v) ] , let v = thBigRecordToJSON bigRecord in bigRecord `deepseq` v `deepseq` bgroup "BigRecord" [ group "toJSON" (nf thBigRecordToJSON bigRecord) (nf G.toJSON bigRecord)- (nf toJSON bigRecord)+ (nf gBigRecordToJSON bigRecord) , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v) (nf (G.fromJSON :: FJ BigRecord) v)- (nf (fromJSON :: FJ BigRecord) v)+ (nf (gBigRecordFromJSON :: FJ BigRecord) v) ] , let v = thBigProductToJSON bigProduct in bigProduct `deepseq` v `deepseq` bgroup "BigProduct" [ group "toJSON" (nf thBigProductToJSON bigProduct) (nf G.toJSON bigProduct)- (nf toJSON bigProduct)+ (nf gBigProductToJSON bigProduct) , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v) (nf (G.fromJSON :: FJ BigProduct) v)- (nf (fromJSON :: FJ BigProduct) v)+ (nf (gBigProductFromJSON :: FJ BigProduct) v) ] , let v = thBigSumToJSON bigSum in bigSum `deepseq` v `deepseq` bgroup "BigSum" [ group "toJSON" (nf thBigSumToJSON bigSum) (nf G.toJSON bigSum)- (nf toJSON bigSum)+ (nf gBigSumToJSON bigSum) , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v) (nf (G.fromJSON :: FJ BigSum) v)- (nf (fromJSON :: FJ BigSum) v)+ (nf (gBigSumFromJSON :: FJ BigSum) v) ] ] -group n th syb gen = bgroup n [ bench "th" th- , bench "syb" syb- , bench "generic" gen- ]+group n th syb gen = bcompare+ [ bgroup n [ bench "th" th+ , bench "syb" syb+ , bench "generic" gen+ ]+ ]
benchmarks/AesonEncode.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} import Control.Exception import Control.Monad@@ -8,35 +8,36 @@ import System.Environment (getArgs) import System.IO import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L import Control.DeepSeq +#if !MIN_VERSION_bytestring(0,10,0)+import qualified Data.ByteString.Lazy.Internal as L+ instance NFData L.ByteString where rnf = go where go (L.Chunk _ cs) = go cs go L.Empty = () {-# INLINE rnf #-}+#endif +main :: IO () main = do (cnt:args) <- getArgs let count = read cnt :: Int forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do putStrLn $ arg ++ ":" let refill = B.hGet h 16384- result <- parseWith refill json =<< refill- r <- case result of- Done _ r -> return r- _ -> fail $ "failed to read " ++ show arg+ result0 <- parseWith refill json =<< refill+ r0 <- case result0 of+ Done _ r -> return r+ _ -> fail $ "failed to read " ++ show arg start <- getCurrentTime let loop !n r | n >= count = return () | otherwise = {-# SCC "loop" #-} do- case result of- Done _ r -> rnf (encode r) `seq` loop (n+1) r- _ -> error $ "failed to read " ++ show arg- loop 0 r+ rnf (encode r) `seq` loop (n+1) r+ loop 0 r0 delta <- flip diffUTCTime start `fmap` getCurrentTime let rate = fromIntegral count / realToFrac delta :: Double putStrLn $ " " ++ show delta- putStrLn $ " " ++ show (round rate) ++ " per second"+ putStrLn $ " " ++ show (round rate :: Int) ++ " per second"
benchmarks/AesonParse.hs view
@@ -10,8 +10,9 @@ import qualified Data.ByteString as B main = do- (cnt:args) <- getArgs+ (bs:cnt:args) <- getArgs let count = read cnt :: Int+ blkSize = read bs forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do putStrLn $ arg ++ ":" start <- getCurrentTime@@ -19,7 +20,7 @@ | good+bad >= count = return (good, bad) | otherwise = do hSeek h AbsoluteSeek 0- let refill = B.hGet h 16384+ let refill = B.hGet h blkSize result <- parseWith refill json =<< refill case result of Done _ r -> loop (good+1) bad
benchmarks/CompareWithJSON.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Blaze.ByteString.Builder (toLazyByteString)@@ -6,9 +7,16 @@ import Criterion.Main import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Internal as BL import qualified Text.JSON as J +#if !MIN_VERSION_bytestring(0,10,0)+import qualified Data.ByteString.Lazy.Internal as BL++instance NFData BL.ByteString where+ rnf (BL.Chunk _ bs) = rnf bs+ rnf BL.Empty = ()+#endif+ instance (NFData v) => NFData (J.JSObject v) where rnf o = rnf (J.fromJSObject o) @@ -19,10 +27,6 @@ rnf (J.JSString s) = rnf (J.fromJSString s) rnf (J.JSArray lst) = rnf lst rnf (J.JSObject o) = rnf o--instance NFData BL.ByteString where- rnf (BL.Chunk _ bs) = rnf bs- rnf BL.Empty = () decodeJ :: String -> J.JSValue decodeJ s =
+ benchmarks/Options.hs view
@@ -0,0 +1,8 @@+module Options where++import Data.Aeson.Types++opts :: Options+opts = defaultOptions+ { sumEncoding = ObjectWithSingleField+ }
+ tests/Encoders.hs view
@@ -0,0 +1,118 @@+{-# Language CPP, TemplateHaskell #-}++module Encoders where++import Data.Aeson.TH+import Data.Aeson.Types+import Options+import Types++--------------------------------------------------------------------------------+-- Nullary encoders/decoders+--------------------------------------------------------------------------------++thNullaryToJSONString :: Nullary -> Value+thNullaryToJSONString = $(mkToJSON defaultOptions ''Nullary)++thNullaryParseJSONString :: Value -> Parser Nullary+thNullaryParseJSONString = $(mkParseJSON defaultOptions ''Nullary)+++thNullaryToJSON2ElemArray :: Nullary -> Value+thNullaryToJSON2ElemArray = $(mkToJSON opts2ElemArray ''Nullary)++thNullaryParseJSON2ElemArray :: Value -> Parser Nullary+thNullaryParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''Nullary)+++thNullaryToJSONTaggedObject :: Nullary -> Value+thNullaryToJSONTaggedObject = $(mkToJSON optsTaggedObject ''Nullary)++thNullaryParseJSONTaggedObject :: Value -> Parser Nullary+thNullaryParseJSONTaggedObject = $(mkParseJSON optsTaggedObject ''Nullary)+++thNullaryToJSONObjectWithSingleField :: Nullary -> Value+thNullaryToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''Nullary)++thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary+thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)++#ifdef GHC_GENERICS+gNullaryToJSONString :: Nullary -> Value+gNullaryToJSONString = genericToJSON defaultOptions++gNullaryParseJSONString :: Value -> Parser Nullary+gNullaryParseJSONString = genericParseJSON defaultOptions+++gNullaryToJSON2ElemArray :: Nullary -> Value+gNullaryToJSON2ElemArray = genericToJSON opts2ElemArray++gNullaryParseJSON2ElemArray :: Value -> Parser Nullary+gNullaryParseJSON2ElemArray = genericParseJSON opts2ElemArray+++gNullaryToJSONTaggedObject :: Nullary -> Value+gNullaryToJSONTaggedObject = genericToJSON optsTaggedObject++gNullaryParseJSONTaggedObject :: Value -> Parser Nullary+gNullaryParseJSONTaggedObject = genericParseJSON optsTaggedObject+++gNullaryToJSONObjectWithSingleField :: Nullary -> Value+gNullaryToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField++gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary+gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField+#endif+++--------------------------------------------------------------------------------+-- SomeType encoders/decoders+--------------------------------------------------------------------------------++type SomeTypeToJSON = SomeType Int -> Value++thSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value+thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType)++thSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)+thSomeTypeParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''SomeType)+++thSomeTypeToJSONTaggedObject :: ToJSON a => SomeType a -> Value+thSomeTypeToJSONTaggedObject = $(mkToJSON optsTaggedObject ''SomeType)++thSomeTypeParseJSONTaggedObject :: FromJSON a => Value -> Parser (SomeType a)+thSomeTypeParseJSONTaggedObject = $(mkParseJSON optsTaggedObject ''SomeType)+++thSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value+thSomeTypeToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''SomeType)++thSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)+thSomeTypeParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''SomeType)+++#ifdef GHC_GENERICS+gSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value+gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray++gSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)+gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray+++gSomeTypeToJSONTaggedObject :: ToJSON a => SomeType a -> Value+gSomeTypeToJSONTaggedObject = genericToJSON optsTaggedObject++gSomeTypeParseJSONTaggedObject :: FromJSON a => Value -> Parser (SomeType a)+gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject+++gSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value+gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField++gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)+gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField+#endif
+ tests/Functions.hs view
@@ -0,0 +1,10 @@+module Functions where++approxEq :: (Fractional a, Ord a) => a -> a -> Bool+approxEq = approxEqWith 1e-15 1e-15++approxEqWith :: (Fractional a, Ord a) => a -> a -> a -> a -> Bool+approxEqWith maxAbsoluteError maxRelativeError a b =+ a == b || d < maxAbsoluteError ||+ d / max (abs b) (abs a) <= maxRelativeError+ where d = abs (a - b)
+ tests/Instances.hs view
@@ -0,0 +1,146 @@+{-# Language CPP, OverloadedStrings, RecordWildCards, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ < 702+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+#endif++module Instances where++import Types+import Data.Function (on)+import Control.Monad+import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof, elements)+import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)+import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),+ hoursToTimeZone, Day(..), TimeOfDay(..))+import qualified Data.Text as T+import qualified Data.Map as Map+import Data.Text (Text)+import Data.Aeson.Types+import Control.Applicative+import Functions++-- "System" types.++instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary++instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where+ arbitrary = Map.fromList <$> arbitrary++instance Arbitrary LocalTime where+ arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)++instance Arbitrary TimeZone where+ arbitrary = do+ offset <- choose (0,2) :: Gen Int+ return $ hoursToTimeZone offset++instance Arbitrary Day where+ arbitrary = ModifiedJulianDay `liftM` arbitrary++instance Arbitrary DiffTime where+ arbitrary = picosecondsToDiffTime `liftM` choose (0, 86400000000000000)++instance Arbitrary UTCTime where+ arbitrary = liftM2 UTCTime arbitrary arbitrary++instance Arbitrary DotNetTime where+ arbitrary = DotNetTime `liftM` arbitrary++instance Arbitrary ZonedTime where+ arbitrary = liftM2 ZonedTime arbitrary arbitrary++deriving instance Eq ZonedTime++-- Compare equality to within a millisecond, allowing for rounding+-- error (ECMA 262 requires milliseconds to rounded to zero, not+-- rounded to nearest).+instance ApproxEq UTCTime where+ a =~ b = ((==) `on` utctDay) a b &&+ (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b++instance ApproxEq DotNetTime where+ (=~) = (=~) `on` fromDotNetTime++instance ApproxEq Double where+ (=~) = approxEq++-- Test-related types.++instance Arbitrary Foo where+ arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary++instance Eq Foo where+ a == b = fooInt a == fooInt b &&+ fooDouble a `approxEq` fooDouble b &&+ fooTuple a == fooTuple b++instance ToJSON Foo where+ toJSON Foo{..} = object [ "fooInt" .= fooInt+ , "fooDouble" .= fooDouble+ , "fooTuple" .= fooTuple+ , "fooMap" .= fooMap+ ]++instance FromJSON Foo where+ parseJSON (Object v) = Foo <$>+ v .: "fooInt" <*>+ v .: "fooDouble" <*>+ v .: "fooTuple" <*>+ v .: "fooMap"+ parseJSON _ = empty++instance Arbitrary UFoo where+ arbitrary = UFoo <$> arbitrary <*> arbitrary+ where _ = uFooInt++instance Arbitrary OneConstructor where+ arbitrary = return OneConstructor++instance FromJSON OneConstructor+instance ToJSON OneConstructor++instance (Arbitrary a, Arbitrary b) => Arbitrary (Product2 a b) where+ arbitrary = liftM2 Product2 arbitrary arbitrary++instance (FromJSON a, FromJSON b) => FromJSON (Product2 a b)+instance (ToJSON a, ToJSON b) => ToJSON (Product2 a b)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+ Arbitrary f) => Arbitrary (Product6 a b c d e f) where+ arbitrary = Product6 <$> arbitrary <*> arbitrary <*> arbitrary <*>+ arbitrary <*> arbitrary <*> arbitrary++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f) => FromJSON (Product6 a b c d e f)+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e,+ ToJSON f) => ToJSON (Product6 a b c d e f)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)+ => Arbitrary (Sum4 a b c d) where+ arbitrary = oneof [Alt1 <$> arbitrary, Alt2 <$> arbitrary,+ Alt3 <$> arbitrary, Alt4 <$> arbitrary]++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d)+ => FromJSON (Sum4 a b c d)+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (Sum4 a b c d)++instance (Arbitrary a) => Arbitrary (Approx a) where+ arbitrary = Approx <$> arbitrary++instance (FromJSON a) => FromJSON (Approx a) where+ parseJSON a = Approx <$> parseJSON a++instance (ToJSON a) => ToJSON (Approx a) where+ toJSON = toJSON . fromApprox++instance Arbitrary Nullary where+ arbitrary = elements [C1, C2, C3]++instance Arbitrary a => Arbitrary (SomeType a) where+ arbitrary = oneof [ pure Nullary+ , Unary <$> arbitrary+ , Product <$> arbitrary <*> arbitrary <*> arbitrary+ , Record <$> arbitrary <*> arbitrary <*> arbitrary+ ]
+ tests/Options.hs view
@@ -0,0 +1,26 @@+module Options where++import Data.Aeson.Types+import Data.Char++optsDefault :: Options+optsDefault = defaultOptions+ { fieldLabelModifier = map toLower+ , constructorTagModifier = map toLower+ }++opts2ElemArray :: Options+opts2ElemArray = optsDefault+ { allNullaryToStringTag = False+ , sumEncoding = TwoElemArray+ }++optsTaggedObject :: Options+optsTaggedObject = optsDefault+ { allNullaryToStringTag = False }++optsObjectWithSingleField :: Options+optsObjectWithSingleField = optsDefault+ { allNullaryToStringTag = False+ , sumEncoding = ObjectWithSingleField+ }
tests/Properties.hs view
@@ -1,25 +1,29 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,- ScopedTypeVariables, StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} -import Control.Monad-import Control.Applicative import Data.Aeson.Encode import Data.Aeson.Parser (value) import Data.Aeson.Types import Data.Attoparsec.Number-import Data.Data (Typeable, Data)-import Data.Text (Text) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(..), choose, Gen)-import qualified Data.Aeson.Generic as G+import Test.QuickCheck (Arbitrary(..))+import qualified Data.Vector as V import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Text as T+import qualified Data.HashMap.Strict as H+import Data.Time.Clock (UTCTime(..))+import Data.Time (ZonedTime(..))+import Instances ()+import Types+import Encoders+import Properties.Deprecated (deprecatedTests)+#ifdef GHC_GENERICS+import Data.Int import qualified Data.Map as Map-import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), hoursToTimeZone, Day(..), TimeOfDay(..))+#endif + encodeDouble :: Double -> Double -> Bool encodeDouble num denom | isInfinite d || isNaN d = encode (Number (D d)) == "null"@@ -29,6 +33,12 @@ encodeInteger :: Integer -> Bool encodeInteger i = encode (Number (I i)) == L.pack (show i) +toParseJSON :: (Arbitrary a, Eq a) => (Value -> Parser a) -> (a -> Value) -> a -> Bool+toParseJSON parsejson tojson x =+ case parse parsejson . tojson $ x of+ Error _ -> False+ Success x' -> x == x'+ roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool roundTrip eq _ i = case fmap fromJSON . L.parse value . encode . toJSON $ i of@@ -38,127 +48,79 @@ roundTripEq :: (Eq a, FromJSON a, ToJSON a) => a -> a -> Bool roundTripEq x y = roundTrip (==) x y -genericTo :: (Data a, ToJSON a) => a -> a -> Bool-genericTo _ v = G.toJSON v == toJSON v--genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool-genericFrom _ v = G.fromJSON (toJSON v) == Success v--approxEq :: Double -> Double -> Bool-approxEq a b = a == b ||- d < maxAbsoluteError ||- d / max (abs b) (abs a) <= maxRelativeError- where d = abs (a - b)- maxAbsoluteError = 1e-15- maxRelativeError = 1e-15- toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool toFromJSON x = case fromJSON . toJSON $ x of Error _ -> False Success x' -> x == x' -genericToFromJSON :: (Arbitrary a, Eq a, Data a) => a -> Bool-genericToFromJSON x = case G.fromJSON . G.toJSON $ x of- Error _ -> False- Success x' -> x == x'--regress_gh72 :: [(String, Maybe String)] -> Bool-regress_gh72 ys = G.decode (G.encode m) == Just m- where m = Map.fromList ys--data Foo = Foo {- fooInt :: Int- , fooDouble :: Double- , fooTuple :: (String, Text, Int)- -- This definition causes an infinite loop in genericTo and genericFrom!- -- , fooMap :: Map.Map String Foo- , fooMap :: Map.Map String (Text,Int)- } deriving (Show, Typeable, Data)--instance Eq Foo where- a == b = fooInt a == fooInt b &&- fooDouble a `approxEq` fooDouble b &&- fooTuple a == fooTuple b--instance ToJSON Foo where- toJSON Foo{..} = object [ "fooInt" .= fooInt- , "fooDouble" .= fooDouble- , "fooTuple" .= fooTuple- , "fooMap" .= fooMap- ]--instance FromJSON Foo where- parseJSON (Object v) = Foo <$>- v .: "fooInt" <*>- v .: "fooDouble" <*>- v .: "fooTuple" <*>- v .: "fooMap"- parseJSON _ = empty--instance Arbitrary Text where- arbitrary = T.pack <$> arbitrary+modifyFailureProp :: String -> String -> Bool+modifyFailureProp orig added =+ result == Error (added ++ orig)+ where+ parser = const $ modifyFailure (added ++) $ fail orig+ result :: Result ()+ result = parse parser () -instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where- arbitrary = Map.fromList <$> arbitrary+main :: IO ()+main = defaultMain tests -instance Arbitrary Foo where- arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary+#ifdef GHC_GENERICS+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)+#endif -instance Arbitrary LocalTime where- arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)+--------------------------------------------------------------------------------+-- Value properties+-------------------------------------------------------------------------------- -instance Arbitrary TimeZone where- arbitrary = do- offset <- choose (0,2) :: Gen Int- return $ hoursToTimeZone offset+isString :: Value -> Bool+isString (String _) = True+isString _ = False -instance Arbitrary ZonedTime where- arbitrary = liftM2 ZonedTime arbitrary arbitrary+is2ElemArray :: Value -> Bool+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)+is2ElemArray _ = False -data UFoo = UFoo {- _UFooInt :: Int- , uFooInt :: Int- } deriving (Show, Eq, Data, Typeable)+isTaggedObjectValue :: Value -> Bool+isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&+ "contents" `H.member` obj+isTaggedObjectValue _ = False -instance Arbitrary UFoo where- arbitrary = UFoo <$> arbitrary <*> arbitrary- where _ = uFooInt+isTaggedObject :: Value -> Bool+isTaggedObject (Object obj) = "tag" `H.member` obj+isTaggedObject _ = False -main :: IO ()-main = defaultMain tests+isObjectWithSingleField :: Value -> Bool+isObjectWithSingleField (Object obj) = H.size obj == 1+isObjectWithSingleField _ = False -deriving instance Eq ZonedTime+-------------------------------------------------------------------------------- tests :: [Test] tests = [- testGroup "regression" [- testProperty "gh-72" regress_gh72- ], testGroup "encode" [ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger ],- testGroup "genericFrom" [- testProperty "Bool" $ genericFrom True- , testProperty "Double" $ genericFrom (1::Double)- , testProperty "Int" $ genericFrom (1::Int)- , testProperty "Foo" $ genericFrom (undefined::Foo)- ],- testGroup "genericTo" [- testProperty "Bool" $ genericTo True- , testProperty "Double" $ genericTo (1::Double)- , testProperty "Int" $ genericTo (1::Int)- , testProperty "Foo" $ genericTo (undefined::Foo)- ], testGroup "roundTrip" [ testProperty "Bool" $ roundTripEq True- , testProperty "Double" $ roundTrip approxEq (1::Double)+ , testProperty "Double" $ roundTripEq (1 :: Approx Double) , testProperty "Int" $ roundTripEq (1::Int) , testProperty "Integer" $ roundTripEq (1::Integer) , testProperty "String" $ roundTripEq (""::String) , testProperty "Text" $ roundTripEq T.empty , testProperty "Foo" $ roundTripEq (undefined::Foo)+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)+ , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime) , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)+#ifdef GHC_GENERICS+ , testGroup "ghcGenerics" [+ testProperty "OneConstructor" $ roundTripEq OneConstructor+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)+ , testProperty "Product6" $ roundTripEq (undefined :: P6)+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)+ ]+#endif ], testGroup "toFromJSON" [ testProperty "Integer" (toFromJSON :: Integer -> Bool)@@ -167,7 +129,72 @@ , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Bool) , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Bool) ],- testGroup "genericToFromJSON" [- testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool)+ testGroup "deprecated" deprecatedTests,+ testGroup "failure messages" [+ testProperty "modify failure" modifyFailureProp+ ],+ testGroup "template-haskell" [+ testGroup "Nullary" [+ testProperty "string" (isString . thNullaryToJSONString)+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)++ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)+ ]+ ]+ , testGroup "SomeType" [+ testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))+ , testProperty "TaggedObject" (isTaggedObject . (thSomeTypeToJSONTaggedObject :: SomeTypeToJSON))+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))++ , testGroup "roundTrip" [+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))+ , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject (thSomeTypeToJSONTaggedObject :: SomeTypeToJSON))+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))+ ]+ ] ]+#ifdef GHC_GENERICS+ , testGroup "GHC-generics" [+ testGroup "Nullary" [+ testProperty "string" (isString . gNullaryToJSONString)+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (isTaggedObjectValue . gNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)+ , testGroup "eq" [+ testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)+ , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)+ , testProperty "TaggedObject" (\n -> gNullaryToJSONTaggedObject n == thNullaryToJSONTaggedObject n)+ , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)+ ]+ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)+ ]+ ]+ , testGroup "SomeType" [+ testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))+ , testProperty "TaggedObject" (isTaggedObject . (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON))+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))++ , testGroup "eq" [+ testProperty "2ElemArray" (\n -> (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON) n == thSomeTypeToJSON2ElemArray n)+ , testProperty "TaggedObject" (\n -> (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON) n == thSomeTypeToJSONTaggedObject n)+ , testProperty "ObjectWithSingleField" (\n -> (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithSingleField n)+ ]+ , testGroup "roundTrip" [+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))+ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject (gSomeTypeToJSONTaggedObject :: SomeTypeToJSON))+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))+ ]+ ]+ ]+#endif ]
+ tests/Properties/Deprecated.hs view
@@ -0,0 +1,57 @@+-- This module is only for testing deprecated features, so we can+-- silence compiler warnings selectively.++{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++module Properties.Deprecated (deprecatedTests) where++import Data.Aeson.Types+import Data.Data (Data)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(..))+import qualified Data.Aeson.Generic as G+import qualified Data.Map as Map+import Types (Foo(..), UFoo(..))+import Instances ()+++genericTo :: (Data a, ToJSON a) => a -> a -> Bool+genericTo _ v = G.toJSON v == toJSON v++genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool+genericFrom _ v = G.fromJSON (toJSON v) == Success v++genericToFromJSON :: (Arbitrary a, Eq a, Data a) => a -> Bool+genericToFromJSON x = case G.fromJSON . G.toJSON $ x of+ Error _ -> False+ Success x' -> x == x'++regress_gh72 :: [(String, Maybe String)] -> Bool+regress_gh72 ys = G.decode (G.encode m) == Just m+ where m = Map.fromList ys++deprecatedTests :: [Test]+deprecatedTests = [+ testGroup "regression" [+ testProperty "gh-72" regress_gh72+ ],+ testGroup "genericFrom" [+ testProperty "Bool" $ genericFrom True+ , testProperty "Double" $ genericFrom (1::Double)+ , testProperty "Int" $ genericFrom (1::Int)+ , testProperty "Foo" $ genericFrom (undefined::Foo)+ , testProperty "Maybe" $ genericFrom (Just 1 :: Maybe Int)+ ],+ testGroup "genericTo" [+ testProperty "Bool" $ genericTo True+ , testProperty "Double" $ genericTo (1::Double)+ , testProperty "Int" $ genericTo (1::Int)+ , testProperty "Foo" $ genericTo (undefined::Foo)+ , testProperty "Maybe" $ genericTo (Just 1 :: Maybe Int)+ ],+ testGroup "genericToFromJSON" [+ testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool)+ ]+ ]
+ tests/Types.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+#ifdef GHC_GENERICS+{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+#endif++module Types where++import qualified Data.Map as Map+import Data.Data+import Data.Text+#ifdef GHC_GENERICS+import GHC.Generics+#endif++data Foo = Foo {+ fooInt :: Int+ , fooDouble :: Double+ , fooTuple :: (String, Text, Int)+ -- This definition causes an infinite loop in genericTo and genericFrom!+ -- , fooMap :: Map.Map String Foo+ , fooMap :: Map.Map String (Text,Int)+ } deriving (Show, Typeable, Data)++data UFoo = UFoo {+ _UFooInt :: Int+ , uFooInt :: Int+ } deriving (Show, Eq, Data, Typeable)++data OneConstructor = OneConstructor+ deriving (Show, Eq, Typeable, Data)++data Product2 a b = Product2 a b+ deriving (Show, Eq, Typeable, Data)++data Product6 a b c d e f = Product6 a b c d e f+ deriving (Show, Eq, Typeable, Data)++data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d+ deriving (Show, Eq, Typeable, Data)++class ApproxEq a where+ (=~) :: a -> a -> Bool++newtype Approx a = Approx { fromApprox :: a }+ deriving (Show, Data, Typeable, ApproxEq, Num)++instance (ApproxEq a) => Eq (Approx a) where+ Approx a == Approx b = a =~ b++data Nullary = C1 | C2 | C3 deriving (Eq, Show)++data SomeType a = Nullary+ | Unary Int+ | Product String (Maybe Char) a+ | Record { testOne :: Double+ , testTwo :: Maybe Bool+ , testThree :: Maybe a+ } deriving (Eq, Show)++#ifdef GHC_GENERICS+deriving instance Generic Foo+deriving instance Generic UFoo+deriving instance Generic OneConstructor+deriving instance Generic (Product2 a b)+deriving instance Generic (Product6 a b c d e f)+deriving instance Generic (Sum4 a b c d)+deriving instance Generic (Approx a)+deriving instance Generic Nullary+deriving instance Generic (SomeType a)+#endif