diff --git a/Data/Aeson.hs b/Data/Aeson.hs --- a/Data/Aeson.hs +++ b/Data/Aeson.hs @@ -38,11 +38,16 @@ , eitherDecode , eitherDecode' , encode + , encodeFile -- ** Variants for strict bytestrings , decodeStrict + , decodeFileStrict , decodeStrict' + , decodeFileStrict' , eitherDecodeStrict + , eitherDecodeFileStrict , eitherDecodeStrict' + , eitherDecodeFileStrict' -- * Core JSON types , Value(..) , Encoding @@ -143,6 +148,10 @@ encode :: (ToJSON a) => a -> L.ByteString encode = encodingToLazyByteString . toEncoding +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. +encodeFile :: (ToJSON a) => FilePath -> a -> IO () +encodeFile fp = L.writeFile fp . encode + -- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. @@ -169,6 +178,18 @@ decodeStrict = decodeStrictWith jsonEOF fromJSON {-# INLINE decodeStrict #-} +-- | Efficiently deserialize a JSON value from a file. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- The input file's content 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. +decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) +decodeFileStrict = fmap decodeStrict . B.readFile + -- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. @@ -195,6 +216,18 @@ decodeStrict' = decodeStrictWith jsonEOF' fromJSON {-# INLINE decodeStrict' #-} +-- | Efficiently deserialize a JSON value from a file. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- The input file's content 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. +decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a) +decodeFileStrict' = fmap decodeStrict' . B.readFile + eitherFormatError :: Either (JSONPath, String) a -> Either String a eitherFormatError = either (Left . uncurry formatError) Right {-# INLINE eitherFormatError #-} @@ -210,6 +243,12 @@ eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON {-# INLINE eitherDecodeStrict #-} +-- | Like 'decodeFileStrict' but returns an error message when decoding fails. +eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) +eitherDecodeFileStrict = + fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON) . B.readFile +{-# INLINE eitherDecodeFileStrict #-} + -- | Like 'decode'' but returns an error message when decoding fails. eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON @@ -220,6 +259,12 @@ eitherDecodeStrict' = eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON {-# INLINE eitherDecodeStrict' #-} + +-- | Like 'decodeFileStrict'' but returns an error message when decoding fails. +eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) +eitherDecodeFileStrict' = + fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON) . B.readFile +{-# INLINE eitherDecodeFileStrict' #-} -- $use -- diff --git a/Data/Aeson/Encoding/Builder.hs b/Data/Aeson/Encoding/Builder.hs --- a/Data/Aeson/Encoding/Builder.hs +++ b/Data/Aeson/Encoding/Builder.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -- | -- Module: Data.Aeson.Encoding.Builder @@ -47,6 +46,7 @@ import Data.Char (chr, ord) import Data.Monoid ((<>)) import Data.Scientific (Scientific, base10Exponent, coefficient) +import Data.Text.Encoding (encodeUtf8BuilderEscaped) import Data.Time (UTCTime(..)) import Data.Time.Calendar (Day(..), toGregorian) import Data.Time.LocalTime @@ -55,20 +55,6 @@ import qualified Data.Text as T import qualified Data.Vector as V -#if MIN_VERSION_bytestring(0,10,4) -import Data.Text.Encoding (encodeUtf8BuilderEscaped) -#else -import Data.Bits ((.&.)) -import Data.Text.Internal (Text(..)) -import Data.Text.Internal.Unsafe.Shift (shiftR) -import Foreign.Ptr (minusPtr, plusPtr) -import Foreign.Storable (poke) -import qualified Data.ByteString.Builder.Internal as B -import qualified Data.ByteString.Builder.Prim.Internal as BP -import qualified Data.Text.Array as A -import qualified Data.Text.Internal.Encoding.Utf16 as U16 -#endif - -- | Encode a JSON value to a "Data.ByteString" 'B.Builder'. -- -- Use this function if you are encoding over the wire, or need to @@ -268,62 +254,3 @@ digit :: Int -> Char digit x = chr (x + 48) - -#if !(MIN_VERSION_bytestring(0,10,4)) --- | Encode text using UTF-8 encoding and escape the ASCII characters using --- a 'BP.BoundedPrim'. --- --- Use this function is to implement efficient encoders for text-based formats --- like JSON or HTML. -{-# INLINE encodeUtf8BuilderEscaped #-} --- TODO: Extend documentation with references to source code in @blaze-html@ --- or @aeson@ that uses this function. -encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder -encodeUtf8BuilderEscaped be = - -- manual eta-expansion to ensure inlining works as expected - \txt -> B.builder (mkBuildstep txt) - where - bound = max 4 $ BP.sizeBound be - - mkBuildstep (Text arr off len) !k = - outerLoop off - where - iend = off + len - - outerLoop !i0 br@(B.BufferRange op0 ope) - | i0 >= iend = k br - | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining) - -- TODO: Use a loop with an integrated bound's check if outRemaining - -- is smaller than 8, as this will save on divisions. - | otherwise = return $ B.bufferFull bound op0 (outerLoop i0) - where - outRemaining = (ope `minusPtr` op0) `div` bound - inpRemaining = iend - i0 - - goPartial !iendTmp = go i0 op0 - where - go !i !op - | i < iendTmp = case A.unsafeIndex arr i of - w | w <= 0x7F -> - BP.runB be (fromIntegral w) op >>= go (i + 1) - | w <= 0x7FF -> do - poke8 0 $ (w `shiftR` 6) + 0xC0 - poke8 1 $ (w .&. 0x3f) + 0x80 - go (i + 1) (op `plusPtr` 2) - | 0xD800 <= w && w <= 0xDBFF -> do - let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1)) - poke8 0 $ (c `shiftR` 18) + 0xF0 - poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80 - poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80 - poke8 3 $ (c .&. 0x3F) + 0x80 - go (i + 2) (op `plusPtr` 4) - | otherwise -> do - poke8 0 $ (w `shiftR` 12) + 0xE0 - poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80 - poke8 2 $ (w .&. 0x3F) + 0x80 - go (i + 1) (op `plusPtr` 3) - | otherwise = - outerLoop i (B.BufferRange op ope) - where - poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8) -#endif diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -117,13 +117,14 @@ ) where import Prelude () -import Prelude.Compat hiding (exp) +import Prelude.Compat import Control.Applicative ((<|>)) -import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) +import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject) import Data.Aeson.Types.Internal ((), JSONPathElement(Key)) import Data.Aeson.Types.FromJSON (parseOptionalFieldWith) +import Data.Aeson.Types.ToJSON (fromPairs, pair) import Control.Monad (liftM2, unless, when) import Data.Foldable (foldr') #if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0) @@ -133,6 +134,7 @@ import Data.List.NonEmpty ((<|), NonEmpty((:|))) import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import qualified Data.Monoid as Monoid import Data.Set (Set) #if MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH hiding (Arity) @@ -147,7 +149,6 @@ import Language.Haskell.TH.Syntax (mkNameG_tc) #endif import Text.Printf (printf) -import qualified Data.Aeson as A import qualified Data.Aeson.Encoding.Internal as E import qualified Data.Foldable as F (all) import qualified Data.HashMap.Strict as H (lookup, toList) @@ -382,13 +383,13 @@ value pairs where - pairs contentsFieldName = listE [toPair target contentsFieldName value] + pairs contentsFieldName = pairE contentsFieldName value -- | Wrap fields of a record constructor. See 'sumToValue'. recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ recordSumToValue target opts multiCons nullary conName pairs = sumToValue target opts multiCons nullary conName - (objectExp target pairs) + (fromPairsE pairs) (const pairs) -- | Wrap fields of a constructor. @@ -423,12 +424,12 @@ TaggedObject{tagFieldName, contentsFieldName} -> -- TODO: Maybe throw an error in case -- tagFieldName overwrites a field in pairs. - let tag = toPair target tagFieldName (conStr target opts conName) + let tag = pairE tagFieldName (conStr target opts conName) content = pairs contentsFieldName - in objectExp target $ - if nullary then listE [tag] else infixApp tag [|(:)|] content + in fromPairsE $ + if nullary then tag else infixApp tag [|(Monoid.<>)|] content ObjectWithSingleField -> - object target [(conString opts conName, value)] + objectE [(conString opts conName, value)] UntaggedValue | nullary -> conStr target opts conName UntaggedValue -> value | otherwise = value @@ -469,15 +470,15 @@ argTys' <- mapM resolveTypeSynonyms argTys args <- newNameList "arg" $ length argTys' let pairs | omitNothingFields opts = infixApp maybeFields - [|(++)|] + [|(Monoid.<>)|] restFields - | otherwise = listE $ map pureToPair argCons + | otherwise = mconcatE (map pureToPair argCons) argCons = zip3 (map varE args) argTys' fields - maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes) + maybeFields = mconcatE (map maybeToPair maybes) - restFields = listE $ map pureToPair rest + restFields = mconcatE (map pureToPair rest) (maybes0, rest0) = partition isMaybe argCons (options, rest) = partition isOption rest0 @@ -489,11 +490,11 @@ toPairLifted lifted (arg, argTy, field) = let toValue = dispatchToJSON target jc conName tvMap argTy fieldName = fieldLabel opts field - e arg' = toPair target fieldName (toValue `appE` arg') + e arg' = pairE fieldName (toValue `appE` arg') in if lifted then do x <- newName "x" - infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg + [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg else e arg match (conP conName $ map varP args) @@ -534,10 +535,6 @@ (<^>) a b = infixApp a [|(E.><)|] b infixr 6 <^> -(<:>) :: ExpQ -> ExpQ -> ExpQ -(<:>) a b = a <^> [|E.colon|] <^> b -infixr 5 <:> - (<%>) :: ExpQ -> ExpQ -> ExpQ (<%>) a b = a <^> [|E.comma|] <^> b infixr 4 <%> @@ -565,62 +562,25 @@ doE (newMV:stmts++[ret])) -- | Wrap an associative list of keys and quoted values in a quoted 'Object'. -object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ -object target = wrapObject target . catPairs target . fmap (uncurry (toPair target)) - --- | --- - When deriving 'ToJSON', map a list of quoted key-value pairs to an --- expression of the list of pairs. --- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing --- key-value pairs to a comma-separated 'Encoding' of them. --- --- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |] --- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |] -catPairs :: ToJSONFun -> [ExpQ] -> ExpQ -catPairs Value = listE -catPairs Encoding = foldr1 (<%>) +objectE :: [(String, ExpQ)] -> ExpQ +objectE = fromPairsE . mconcatE . fmap (uncurry pairE) --- | --- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'. --- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs --- in an encoded 'Object'. +-- | 'mconcat' a list of fixed length. -- --- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |] --- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |] -objectExp :: ToJSONFun -> ExpQ -> ExpQ -objectExp target = wrapObject target . catPairsExp target +-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |] +mconcatE :: [ExpQ] -> ExpQ +mconcatE [] = [|Monoid.mempty|] +mconcatE [x] = x +mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs) --- | Counterpart of 'catPairsExp' when the list of pairs is already quoted. --- --- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |] --- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |] -catPairsExp :: ToJSONFun -> ExpQ -> ExpQ -catPairsExp Value e = e -catPairsExp Encoding e = [|commaSep|] `appE` e +fromPairsE :: ExpQ -> ExpQ +fromPairsE = ([|fromPairs|] `appE`) -- | Create (an encoding of) a key-value pair. -- --- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text. --- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|] -toPair :: ToJSONFun -> String -> ExpQ -> ExpQ -toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v -toPair Encoding k v = [|E.string k|] <:> v - --- | Map an associative list in an 'Object'. --- --- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |] --- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |] -wrapObject :: ToJSONFun -> ExpQ -> ExpQ -wrapObject Value e = [|A.object|] `appE` e -wrapObject Encoding e = [|E.wrapObject|] `appE` e - --- | Separate 'Encoding's by commas. --- --- > commaSep ["a","b","c"] = "a,b,c" -commaSep :: [E.Encoding] -> E.Encoding -commaSep [] = E.empty -commaSep [x] = x -commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs +-- > pairE "k" [|v|] = [|pair "k" v|] +pairE :: String -> ExpQ -> ExpQ +pairE k v = [|pair k|] `appE` v -------------------------------------------------------------------------------- -- FromJSON diff --git a/Data/Aeson/Text.hs b/Data/Aeson/Text.hs --- a/Data/Aeson/Text.hs +++ b/Data/Aeson/Text.hs @@ -46,8 +46,8 @@ -- embedded efficiently in a text-based protocol. -- -- If you are going to immediately encode straight to a --- 'L.ByteString', it is more efficient to use 'encodeToBuilder' --- instead. +-- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString) +-- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead. -- -- /Note:/ Uses 'toJSON' encodeToTextBuilder :: ToJSON a => a -> Builder diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -669,7 +669,7 @@ {-# INLINE withBool #-} -- | Decode a nested JSON-encoded string. -withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a +withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a withEmbeddedJSON _ innerParser (String txt) = either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt) where @@ -1042,8 +1042,8 @@ instance INCOHERENT_ (Selector s, FromJSON a) => FromRecord arity (S1 s (K1 i (Maybe a))) where - parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab - parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label + parseRecord _ _ (Just lab) obj = M1 . K1 <$> obj .:? lab + parseRecord opts _ Nothing obj = M1 . K1 <$> obj .:? pack label where label = fieldLabelModifier opts $ selName (undefined :: t s (K1 i (Maybe a)) p) diff --git a/Data/Aeson/Types/ToJSON.hs b/Data/Aeson/Types/ToJSON.hs --- a/Data/Aeson/Types/ToJSON.hs +++ b/Data/Aeson/Types/ToJSON.hs @@ -50,6 +50,8 @@ , contramapToJSONKeyFunction -- * Object key-value pairs , KeyValue(..) + , KeyValuePair(..) + , FromPairs(..) -- * Functions needed for documentation -- * Encoding functions , listEncoding @@ -853,14 +855,14 @@ , TaggedObject' enc pairs arity a isRecord , FromPairs enc pairs , FromString enc - , GKeyValue enc pairs + , KeyValuePair enc pairs , Constructor c ) => TaggedObject enc arity (C1 c a) where taggedObject opts targs tagFieldName contentsFieldName = fromPairs . (tag <>) . contents where - tag = tagFieldName `gPair` + tag = tagFieldName `pair` (fromString (constructorTagModifier opts (conName (undefined :: t c a p))) :: enc) contents = @@ -872,11 +874,11 @@ -> String -> f a -> Tagged isRecord pairs instance ( GToJSON enc arity f - , GKeyValue enc pairs + , KeyValuePair enc pairs ) => TaggedObject' enc pairs arity f False where taggedObject' opts targs contentsFieldName = - Tagged . (contentsFieldName `gPair`) . gToJSON opts targs + Tagged . (contentsFieldName `pair`) . gToJSON opts targs instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where taggedObject' _ _ _ _ = Tagged mempty @@ -1005,7 +1007,7 @@ instance ( Selector s , GToJSON enc arity a - , GKeyValue enc pairs + , KeyValuePair enc pairs ) => RecordToPairs enc pairs arity (S1 s a) where recordToPairs = fieldToPair @@ -1014,7 +1016,7 @@ instance INCOHERENT_ ( Selector s , GToJSON enc arity (K1 i (Maybe a)) - , GKeyValue enc pairs + , KeyValuePair enc pairs , Monoid pairs ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a))) where @@ -1026,7 +1028,7 @@ instance INCOHERENT_ ( Selector s , GToJSON enc arity (K1 i (Maybe a)) - , GKeyValue enc pairs + , KeyValuePair enc pairs , Monoid pairs ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a))) where @@ -1038,13 +1040,13 @@ fieldToPair :: (Selector s , GToJSON enc arity a - , GKeyValue enc pairs) + , KeyValuePair enc pairs) => Options -> ToArgs enc arity p -> S1 s a p -> pairs fieldToPair opts targs m1 = let key = fieldLabelModifier opts (selName m1) value = gToJSON opts targs (unM1 m1) - in key `gPair` value + in key `pair` value {-# INLINE fieldToPair #-} -------------------------------------------------------------------------------- @@ -1098,12 +1100,12 @@ instance ( GToJSON enc arity a , ConsToJSON enc arity a , FromPairs enc pairs - , GKeyValue enc pairs + , KeyValuePair enc pairs , Constructor c ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a) where sumToJSON' opts targs = - Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs + Tagged . fromPairs . (typ `pair`) . gToJSON opts targs where typ = constructorTagModifier opts $ conName (undefined :: t c a p) @@ -2716,20 +2718,24 @@ -------------------------------------------------------------------------------- +-- | Wrap a list of pairs as an object. class Monoid pairs => FromPairs enc pairs | enc -> pairs where fromPairs :: pairs -> enc -instance FromPairs Encoding Series where +instance (a ~ Value) => FromPairs (Encoding' a) Series where fromPairs = E.pairs instance FromPairs Value (DList Pair) where fromPairs = object . toList -class Monoid kv => GKeyValue v kv where - gPair :: String -> v -> kv +-- | Like 'KeyValue' but the value is already converted to JSON +-- ('Value' or 'Encoding'), and the result actually represents lists of pairs +-- so it can be readily concatenated. +class Monoid kv => KeyValuePair v kv where + pair :: String -> v -> kv -instance ToJSON v => GKeyValue v (DList Pair) where - gPair k v = DList.singleton (pack k .= v) +instance (v ~ Value) => KeyValuePair v (DList Pair) where + pair k v = DList.singleton (pack k .= v) -instance GKeyValue Encoding Series where - gPair = E.pairStr +instance (e ~ Encoding) => KeyValuePair e Series where + pair = E.pairStr diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 1.2.4.0 +version: 1.3.0.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -125,7 +125,7 @@ scientific >= 0.3.4.7 && < 0.4, tagged >=0.8.3 && <0.9, template-haskell >= 2.7, - text >= 1.1.1.0, + text >= 1.2.3, th-abstraction >= 0.2.2 && < 0.3, time >= 1.1.1.4, time-locale-compat >= 0.1.1 && < 0.2, @@ -212,7 +212,7 @@ directory, dlist, filepath, - generic-deriving >= 1.10 && < 1.12, + generic-deriving >= 1.10 && < 1.13, ghc-prim >= 0.2, hashable >= 1.2.4.0, scientific, diff --git a/attoparsec-iso8601/Data/Attoparsec/Time.hs b/attoparsec-iso8601/Data/Attoparsec/Time.hs --- a/attoparsec-iso8601/Data/Attoparsec/Time.hs +++ b/attoparsec-iso8601/Data/Attoparsec/Time.hs @@ -42,9 +42,9 @@ day :: Parser Day day = do absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id - y <- decimal <* char '-' - m <- twoDigits <* char '-' - d <- twoDigits + y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD" + m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD" + d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD" maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d) -- | Parse a two-digit integer (e.g. day of month, hour). diff --git a/benchmarks/AesonCompareAutoInstances.hs b/benchmarks/AesonCompareAutoInstances.hs deleted file mode 100644 --- a/benchmarks/AesonCompareAutoInstances.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main (main) where - -import Prelude () -import Prelude.Compat - -import Control.Monad -import Control.DeepSeq (NFData, rnf, deepseq) -import Criterion.Main hiding (defaultOptions) -import Data.Aeson -import Data.Aeson.Encoding -import Data.Aeson.TH -import Data.Aeson.Types -import Data.ByteString.Lazy (ByteString) -import Data.Data (Data) -import Data.Typeable (Typeable) -import GHC.Generics (Generic, Rep) -import Options - -toBS :: Encoding -> ByteString -toBS = encodingToLazyByteString - -gEncode :: (Generic a, GToEncoding Zero (Rep a)) => a -> ByteString -gEncode = toBS . genericToEncoding opts - --------------------------------------------------------------------------------- - -data D a = Nullary - | Unary Int - | Product String Char a - | Record { testOne :: Double - , testTwo :: Bool - , testThree :: D a - } - deriving (Show, Eq) - -deriveJSON opts ''D - -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 D' a = Nullary' - | Unary' Int - | Product' String Char a - | Record' { testOne' :: Double - , testTwo' :: Bool - , testThree' :: D' a - } - deriving (Show, Eq, Generic) - -instance ToJSON a => ToJSON (D' a) where - toJSON = genericToJSON opts - -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 - { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int - , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int - , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int - , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int - , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int - } deriving (Show, Eq, Generic) - -instance NFData BigRecord - -bigRecord = BigRecord 1 2 3 4 5 - 6 7 8 9 10 - 11 12 13 14 15 - 16 17 18 19 20 - 21 22 23 24 25 - -return [] - -gBigRecordToJSON :: BigRecord -> Value -gBigRecordToJSON = genericToJSON opts - -gBigRecordEncode :: BigRecord -> ByteString -gBigRecordEncode = gEncode - -gBigRecordFromJSON :: Value -> Result BigRecord -gBigRecordFromJSON = parse $ genericParseJSON opts - -thBigRecordToJSON :: BigRecord -> Value -thBigRecordToJSON = $(mkToJSON opts ''BigRecord) - -thBigRecordEncode :: BigRecord -> ByteString -thBigRecordEncode = toBS . $(mkToEncoding opts ''BigRecord) - -thBigRecordFromJSON :: Value -> Result BigRecord -thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord) - --------------------------------------------------------------------------------- - -data BigProduct = BigProduct - !Int !Int !Int !Int !Int - !Int !Int !Int !Int !Int - !Int !Int !Int !Int !Int - !Int !Int !Int !Int !Int - !Int !Int !Int !Int !Int - deriving (Show, Eq, Generic) - -instance NFData BigProduct - -bigProduct = BigProduct 1 2 3 4 5 - 6 7 8 9 10 - 11 12 13 14 15 - 16 17 18 19 20 - 21 22 23 24 25 - -return [] - -gBigProductToJSON :: BigProduct -> Value -gBigProductToJSON = genericToJSON opts - -gBigProductEncode :: BigProduct -> ByteString -gBigProductEncode = gEncode - -gBigProductFromJSON :: Value -> Result BigProduct -gBigProductFromJSON = parse $ genericParseJSON opts - -thBigProductToJSON :: BigProduct -> Value -thBigProductToJSON = $(mkToJSON opts ''BigProduct) - -thBigProductEncode :: BigProduct -> ByteString -thBigProductEncode = toBS . $(mkToEncoding opts ''BigProduct) - -thBigProductFromJSON :: Value -> Result BigProduct -thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct) - --------------------------------------------------------------------------------- - -data BigSum = F01 | F02 | F03 | F04 | F05 - | F06 | F07 | F08 | F09 | F10 - | F11 | F12 | F13 | F14 | F15 - | F16 | F17 | F18 | F19 | F20 - | F21 | F22 | F23 | F24 | F25 - deriving (Show, Eq, Generic) - -instance NFData BigSum - -bigSum = F25 - -return [] - -gBigSumToJSON :: BigSum -> Value -gBigSumToJSON = genericToJSON opts - -gBigSumEncode :: BigSum -> ByteString -gBigSumEncode = gEncode - -gBigSumFromJSON :: Value -> Result BigSum -gBigSumFromJSON = parse $ genericParseJSON opts - -thBigSumToJSON :: BigSum -> Value -thBigSumToJSON = $(mkToJSON opts ''BigSum) - -thBigSumEncode :: BigSum -> ByteString -thBigSumEncode = toBS . $(mkToEncoding opts ''BigSum) - -thBigSumFromJSON :: Value -> Result BigSum -thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum) - --------------------------------------------------------------------------------- - -type FJ a = Value -> Result a - -runBench :: IO () -runBench = defaultMain - [ let v = toJSON d - in (d, d', v) `deepseq` - bgroup "D" - [ group "toJSON" (nf toJSON d) - (nf toJSON d') - , group "encode" (nf encode d) - (nf encode d') - , group "fromJSON" (nf ( 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 gBigRecordToJSON bigRecord) - , group "encode" (nf thBigRecordEncode bigRecord) - (nf gBigRecordEncode bigRecord) - , group "fromJSON" (nf (thBigRecordFromJSON :: 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 gBigProductToJSON bigProduct) - , group "encode" (nf thBigProductEncode bigProduct) - (nf gBigProductEncode bigProduct) - , group "fromJSON" (nf (thBigProductFromJSON :: 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 gBigSumToJSON bigSum) - , group "encode" (nf thBigSumEncode bigSum) - (nf gBigSumEncode bigSum) - , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v) - (nf (gBigSumFromJSON :: FJ BigSum) v) - ] - ] - -group n th gen = bgroup n [ bench "th" th - , bench "generic" gen - ] - -sanityCheck = do - check d toJSON fromJSON encode - check d' toJSON fromJSON encode - check bigRecord thBigRecordToJSON thBigRecordFromJSON thBigRecordEncode - check bigRecord gBigRecordToJSON gBigRecordFromJSON gBigRecordEncode - check bigProduct thBigProductToJSON thBigProductFromJSON thBigProductEncode - check bigProduct gBigProductToJSON gBigProductFromJSON gBigProductEncode - check bigSum thBigSumToJSON thBigSumFromJSON thBigSumEncode - check bigSum gBigSumToJSON gBigSumFromJSON gBigSumEncode - -check :: (Show a, Eq a) - => a -> (a -> Value) -> (Value -> Result a) -> (a -> ByteString) -> IO () -check x toJSON fromJSON encode = do - unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x - unless (Success x == (decode' . encode) x) $ fail $ "encode: " ++ show x - where - decode' s = case decode s of - Just v -> fromJSON v - Nothing -> fail "" - -main = do - sanityCheck - runBench diff --git a/benchmarks/AesonFoldable.hs b/benchmarks/AesonFoldable.hs --- a/benchmarks/AesonFoldable.hs +++ b/benchmarks/AesonFoldable.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module Main (main) where @@ -9,8 +8,7 @@ import Prelude.Compat import Data.Foldable (toList) -import qualified "aeson" Data.Aeson as A -import qualified "aeson-benchmarks" Data.Aeson as B +import qualified Data.Aeson as A import qualified Data.Sequence as S import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U @@ -21,10 +19,6 @@ newtype L f = L { getL :: f Int } -instance Foldable f => B.ToJSON (L f) where - toJSON = error "do not use this" - toEncoding = B.toEncoding . toList . getL - instance Foldable f => A.ToJSON (L f) where toJSON = error "do not use this" toEncoding = A.toEncoding . toList . getL @@ -35,10 +29,6 @@ newtype F f = F { getF :: f Int } -instance Foldable f => B.ToJSON (F f) where - toJSON = error "do not use this" - toEncoding = B.foldable . getF - instance Foldable f => A.ToJSON (F f) where toJSON = error "do not use this" toEncoding = A.foldable . getF @@ -63,52 +53,34 @@ -- Main ------------------------------------------------------------------------------- -benchEncodeA +benchEncode :: A.ToJSON a => String -> a -> Benchmark -benchEncodeA name val +benchEncode name val = bench ("A " ++ name) $ nf A.encode val -benchEncodeB - :: B.ToJSON a - => String - -> a - -> Benchmark -benchEncodeB name val - = bench ("B " ++ name) $ nf B.encode val - main :: IO () main = defaultMain [ bgroup "encode" [ bgroup "List" - [ benchEncodeB "-" valueList - , benchEncodeB "L" $ L valueList - , benchEncodeB "F" $ F valueList - , benchEncodeA "-" valueList - , benchEncodeA "L" $ L valueList - , benchEncodeA "F" $ F valueList + [ benchEncode "-" valueList + , benchEncode "L" $ L valueList + , benchEncode "F" $ F valueList ] , bgroup "Seq" - [ benchEncodeB "-" valueSeq - , benchEncodeB "L" $ L valueSeq - , benchEncodeB "F" $ F valueSeq - , benchEncodeA "-" valueSeq - , benchEncodeA "L" $ L valueSeq - , benchEncodeA "F" $ F valueSeq + [ benchEncode "-" valueSeq + , benchEncode "L" $ L valueSeq + , benchEncode "F" $ F valueSeq ] , bgroup "Vector" - [ benchEncodeB "-" valueVector - , benchEncodeB "L" $ L valueVector - , benchEncodeB "F" $ F valueVector - , benchEncodeA "-" valueVector - , benchEncodeA "L" $ L valueVector - , benchEncodeA "F" $ F valueVector + [ benchEncode "-" valueVector + , benchEncode "L" $ L valueVector + , benchEncode "F" $ F valueVector ] , bgroup "Vector.Unboxed" - [ benchEncodeB "-" valueUVector - , benchEncodeA "-" valueUVector + [ benchEncode "-" valueUVector ] ] ] diff --git a/benchmarks/AesonMap.hs b/benchmarks/AesonMap.hs --- a/benchmarks/AesonMap.hs +++ b/benchmarks/AesonMap.hs @@ -1,6 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -15,9 +13,8 @@ import Data.Hashable import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged (..)) -import qualified "aeson" Data.Aeson as A -import qualified "aeson-benchmarks" Data.Aeson as B -import qualified "aeson-benchmarks" Data.Aeson.Types as B (fromJSONKeyCoerce) +import Data.Aeson +import Data.Aeson.Types (fromJSONKeyCoerce) import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM import qualified Data.Map as M @@ -47,10 +44,10 @@ instance Hashable T1 where hashWithSalt salt (T1 t) = hashWithSalt salt t -instance B.FromJSON T1 where - parseJSON = B.withText "T1" $ pure . T1 -instance B.FromJSONKey T1 where - fromJSONKey = B.FromJSONKeyText T1 +instance FromJSON T1 where + parseJSON = withText "T1" $ pure . T1 +instance FromJSONKey T1 where + fromJSONKey = FromJSONKeyText T1 ------------------------------------------------------------------------------- -- Coerce @@ -64,10 +61,10 @@ instance Hashable T2 where hashWithSalt salt (T2 t) = hashWithSalt salt t -instance B.FromJSON T2 where - parseJSON = B.withText "T2" $ pure . T2 -instance B.FromJSONKey T2 where - fromJSONKey = B.fromJSONKeyCoerce +instance FromJSON T2 where + parseJSON = withText "T2" $ pure . T2 +instance FromJSONKey T2 where + fromJSONKey = fromJSONKeyCoerce ------------------------------------------------------------------------------- -- TextParser @@ -81,10 +78,10 @@ instance Hashable T3 where hashWithSalt salt (T3 t) = hashWithSalt salt t -instance B.FromJSON T3 where - parseJSON = B.withText "T3" $ pure . T3 -instance B.FromJSONKey T3 where - fromJSONKey = B.FromJSONKeyTextParser (pure . T3) +instance FromJSON T3 where + parseJSON = withText "T3" $ pure . T3 +instance FromJSONKey T3 where + fromJSONKey = FromJSONKeyTextParser (pure . T3) ------------------------------------------------------------------------------- -- Values @@ -97,40 +94,30 @@ value10000 = value 10000 encodedValue10 :: LBS.ByteString -encodedValue10 = B.encode value10 +encodedValue10 = encode value10 encodedValue100 :: LBS.ByteString -encodedValue100 = B.encode value100 +encodedValue100 = encode value100 encodedValue1000 :: LBS.ByteString -encodedValue1000 = B.encode value1000 +encodedValue1000 = encode value1000 encodedValue10000 :: LBS.ByteString -encodedValue10000 = B.encode value10000 +encodedValue10000 = encode value10000 ------------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------------------- -decodeHMB - :: (B.FromJSONKey k, Eq k, Hashable k) - => Proxy k -> LBS.ByteString -> Maybe (HM.HashMap k T.Text) -decodeHMB _ = B.decode - -decodeHMA - :: (A.FromJSON (HM.HashMap k T.Text), Eq k, Hashable k) +decodeHM + :: (FromJSON (HM.HashMap k T.Text), Eq k, Hashable k) => Proxy k -> LBS.ByteString -> Maybe (HM.HashMap k T.Text) -decodeHMA _ = A.decode - -decodeMapB - :: (B.FromJSONKey k, Ord k) - => Proxy k -> LBS.ByteString -> Maybe (M.Map k T.Text) -decodeMapB _ = B.decode +decodeHM _ = decode -decodeMapA - :: (A.FromJSON (M.Map k T.Text), Ord k) +decodeMap + :: (FromJSON (M.Map k T.Text), Ord k) => Proxy k -> LBS.ByteString -> Maybe (M.Map k T.Text) -decodeMapA _ = A.decode +decodeMap _ = decode proxyText :: Proxy T.Text proxyText = Proxy @@ -156,15 +143,14 @@ -> LBS.ByteString -> Benchmark benchDecodeHM name val = bgroup name - [ bench "Text" $ nf (decodeHMB proxyText) val - , bench "Identity" $ nf (decodeHMB proxyT1) val - , bench "Coerce" $ nf (decodeHMB proxyT2) val - , bench "Parser" $ nf (decodeHMB proxyT3) val - , bench "aeson-hackage" $ nf (decodeHMA proxyText) val - , bench "Tagged Text" $ nf (decodeHMB $ proxyTagged proxyText) val - , bench "Tagged Identity" $ nf (decodeHMB $ proxyTagged proxyT1) val - , bench "Tagged Coerce" $ nf (decodeHMB $ proxyTagged proxyT2) val - , bench "Tagged Parser" $ nf (decodeHMB $ proxyTagged proxyT3) val + [ bench "Text" $ nf (decodeHM proxyText) val + , bench "Identity" $ nf (decodeHM proxyT1) val + , bench "Coerce" $ nf (decodeHM proxyT2) val + , bench "Parser" $ nf (decodeHM proxyT3) val + , bench "Tagged Text" $ nf (decodeHM $ proxyTagged proxyText) val + , bench "Tagged Identity" $ nf (decodeHM $ proxyTagged proxyT1) val + , bench "Tagged Coerce" $ nf (decodeHM $ proxyTagged proxyT2) val + , bench "Tagged Parser" $ nf (decodeHM $ proxyTagged proxyT3) val ] benchDecodeMap @@ -172,11 +158,10 @@ -> LBS.ByteString -> Benchmark benchDecodeMap name val = bgroup name - [ bench "Text" $ nf (decodeMapB proxyText) val - , bench "Identity" $ nf (decodeMapB proxyT1) val - , bench "Coerce" $ nf (decodeMapB proxyT2) val - , bench "Parser" $ nf (decodeMapB proxyT3) val - , bench "aeson-hackage" $ nf (decodeMapA proxyText) val + [ bench "Text" $ nf (decodeMap proxyText) val + , bench "Identity" $ nf (decodeMap proxyT1) val + , bench "Coerce" $ nf (decodeMap proxyT2) val + , bench "Parser" $ nf (decodeMap proxyT3) val ] benchEncodeHM @@ -184,8 +169,7 @@ -> HM.HashMap T.Text T.Text -> Benchmark benchEncodeHM name val = bgroup name - [ bench "Text" $ nf B.encode val - , bench "aeson-0.11" $ nf A.encode val + [ bench "Text" $ nf encode val ] benchEncodeMap @@ -193,8 +177,7 @@ -> HM.HashMap T.Text T.Text -> Benchmark benchEncodeMap name val = bgroup name - [ bench "Text" $ nf B.encode val' - , bench "aeson-0.11" $ nf A.encode val' + [ bench "Text" $ nf encode val' ] where val' :: M.Map T.Text T.Text diff --git a/benchmarks/AesonParse.hs b/benchmarks/AesonParse.hs --- a/benchmarks/AesonParse.hs +++ b/benchmarks/AesonParse.hs @@ -1,13 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module Main (main) where import Prelude () import Prelude.Compat -import "aeson-benchmarks" Data.Aeson +import Data.Aeson import Control.Monad import Data.Attoparsec.ByteString (IResult(..), parseWith) import Data.Time.Clock diff --git a/benchmarks/AutoCompare.hs b/benchmarks/AutoCompare.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AutoCompare.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Control.DeepSeq +import Control.Monad +import Criterion.Main +import Data.Aeson + +import qualified Auto.T.D as T +import qualified Auto.T.BigRecord as T +import qualified Auto.T.BigProduct as T +import qualified Auto.T.BigSum as T +import qualified Auto.G.D as G +import qualified Auto.G.BigRecord as G +import qualified Auto.G.BigProduct as G +import qualified Auto.G.BigSum as G + +-------------------------------------------------------------------------------- + +runBench :: IO () +runBench = defaultMain + [ compareBench "D" T.d G.d + , compareBench "BigRecord" T.bigRecord G.bigRecord + , compareBench "BigProduct" T.bigProduct G.bigProduct + , compareBench "BigSum" T.bigSum G.bigSum + ] + +group :: String -> Benchmarkable -> Benchmarkable -> Benchmark +group n th gen = bgroup n [ bench "th" th + , bench "generic" gen + ] + +compareBench + :: forall a b + . (ToJSON a, FromJSON a, NFData a, ToJSON b, FromJSON b, NFData b) + => String -> a -> b -> Benchmark +compareBench name a b = v `deepseq` bgroup name + [ group "toJSON" (nf toJSON a) + (nf toJSON b) + , group "encode" (nf encode a) + (nf encode b) + , group "fromJSON" (nf (fromJSON :: Value -> Result a) v) + (nf (fromJSON :: Value -> Result b) v) + ] where + v = toJSON a -- == toJSON b + +sanityCheck :: IO () +sanityCheck = do + check T.d + check G.d + check T.bigRecord + check G.bigRecord + check T.bigProduct + check G.bigProduct + check T.bigSum + check G.bigSum + +check :: (Show a, Eq a, FromJSON a, ToJSON a) + => a -> IO () +check x = do + unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x + unless (Success x == (decode_ . encode) x) $ fail $ "encode: " ++ show x + where + decode_ s = case decode s of + Just v -> fromJSON v + Nothing -> fail "" + +main :: IO () +main = do + sanityCheck + runBench diff --git a/benchmarks/Compare.hs b/benchmarks/Compare.hs --- a/benchmarks/Compare.hs +++ b/benchmarks/Compare.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where @@ -14,7 +13,7 @@ import Twitter import Twitter.Manual () import Typed.Common -import qualified "aeson-benchmarks" Data.Aeson as Aeson +import qualified Data.Aeson as Aeson import qualified Compare.JsonBench as JsonBench main :: IO () diff --git a/benchmarks/Compare/BufferBuilder.hs b/benchmarks/Compare/BufferBuilder.hs --- a/benchmarks/Compare/BufferBuilder.hs +++ b/benchmarks/Compare/BufferBuilder.hs @@ -12,7 +12,6 @@ import Data.BufferBuilder.Json import Data.Int (Int64) import Data.Monoid ((<>)) -import Prelude hiding (id) import Twitter import qualified Data.BufferBuilder.Utf8 as UB diff --git a/benchmarks/Compare/JsonBuilder.hs b/benchmarks/Compare/JsonBuilder.hs --- a/benchmarks/Compare/JsonBuilder.hs +++ b/benchmarks/Compare/JsonBuilder.hs @@ -10,7 +10,6 @@ import Data.Json.Builder import Data.Monoid ((<>)) -import Prelude hiding (id) import Twitter instance JsObject Metadata where diff --git a/benchmarks/CompareWithJSON.hs b/benchmarks/CompareWithJSON.hs --- a/benchmarks/CompareWithJSON.hs +++ b/benchmarks/CompareWithJSON.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -11,10 +10,9 @@ import Control.DeepSeq (NFData(rnf)) import Criterion.Main import Data.Maybe (fromMaybe) -import qualified "aeson-benchmarks" Data.Aeson as A -import qualified "aeson-benchmarks" Data.Aeson.Text as A -import qualified "aeson-benchmarks" Data.Aeson.Parser.Internal as I -import qualified "aeson" Data.Aeson as B +import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Parser.Internal as I import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL @@ -39,20 +37,14 @@ J.Ok v -> v J.Error _ -> error "fail to parse via JSON" -decodeA :: BL.ByteString -> A.Value -decodeA s = fromMaybe (error "fail to parse via Aeson") $ A.decode s - -decodeA' :: BL.ByteString -> A.Value -decodeA' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s - -decodeAS :: BS.ByteString -> A.Value -decodeAS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s +decode :: BL.ByteString -> A.Value +decode s = fromMaybe (error "fail to parse via Aeson") $ A.decode s -decodeB :: BL.ByteString -> B.Value -decodeB s = fromMaybe (error "fail to parse via Aeson") $ B.decode s +decode' :: BL.ByteString -> A.Value +decode' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s -decodeBS :: BS.ByteString -> B.Value -decodeBS s = fromMaybe (error "fail to parse via Aeson") $ B.decodeStrict' s +decodeS :: BS.ByteString -> A.Value +decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s decodeIP :: BL.ByteString -> A.Value decodeIP s = fromMaybe (error "fail to parse via Parser.decodeWith") $ @@ -80,32 +72,29 @@ defaultMain [ bgroup "decode" [ bgroup "en" [ - bench "aeson/lazy" $ nf decodeA enA - , bench "aeson/strict" $ nf decodeA' enA - , bench "aeson/stricter" $ nf decodeAS enS - , bench "aeson/hackage" $ nf decodeB enA - , bench "aeson/hackage'" $ nf decodeBS enS + bench "aeson/lazy" $ nf decode enA + , bench "aeson/strict" $ nf decode' enA + , bench "aeson/stricter" $ nf decodeS enS , bench "aeson/parser" $ nf decodeIP enA , bench "json" $ nf decodeJ enJ ] , bgroup "jp" [ - bench "aeson" $ nf decodeA jpA - , bench "aeson/stricter" $ nf decodeAS jpS - , bench "aeson/hackage" $ nf decodeB jpA + bench "aeson" $ nf decode jpA + , bench "aeson/stricter" $ nf decodeS jpS , bench "json" $ nf decodeJ jpJ ] ] , bgroup "encode" [ bgroup "en" [ - bench "aeson-to-bytestring" $ nf A.encode (decodeA enA) - , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decodeA enA) - , bench "aeson-to-text" $ nf encodeToText (decodeA enA) + bench "aeson-to-bytestring" $ nf A.encode (decode enA) + , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode enA) + , bench "aeson-to-text" $ nf encodeToText (decode enA) , bench "json" $ nf encodeJ (decodeJ enJ) ] , bgroup "jp" [ - bench "aeson-to-bytestring" $ nf A.encode (decodeA jpA) - , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decodeA jpA) - , bench "aeson-to-text" $ nf encodeToText (decodeA jpA) + bench "aeson-to-bytestring" $ nf A.encode (decode jpA) + , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode jpA) + , bench "aeson-to-text" $ nf encodeToText (decode jpA) , bench "json" $ nf encodeJ (decodeJ jpJ) ] ] diff --git a/benchmarks/Dates.hs b/benchmarks/Dates.hs --- a/benchmarks/Dates.hs +++ b/benchmarks/Dates.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fsimpl-tick-factor=0 #-} module Main (main) where import Prelude () diff --git a/benchmarks/Escape.hs b/benchmarks/Escape.hs --- a/benchmarks/Escape.hs +++ b/benchmarks/Escape.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Main (main) where @@ -7,19 +7,25 @@ import Prelude.Compat import Criterion.Main -import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapeFFI as FFI -import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapePure as Pure +import qualified Data.Aeson.Parser.UnescapeFFI as FFI +import qualified Data.Aeson.Parser.UnescapePure as Pure import qualified Data.ByteString.Char8 as BS - -n :: Int -n = 10000 - -input :: BS.ByteString -input = BS.concat $ replicate n $ BS.pack "\\\"" +import System.Environment (getArgs, withArgs) main :: IO () -main = defaultMain +main = do + args_ <- getArgs + let (args, p, n) = + case args_ of + "--pattern" : p : args_ -> k p args_ + _ -> k "\\\"" args_ + k p args_ = + case args_ of + "--repeat" : n : args_ -> (args_, p, read n) + args_ -> (args_, p, 10000) + input = BS.concat $ replicate n $ BS.pack p + withArgs args $ defaultMain [ bench "ffi" $ whnf FFI.unescapeText input , bench "pure" $ whnf Pure.unescapeText input ] diff --git a/benchmarks/Micro.hs b/benchmarks/Micro.hs --- a/benchmarks/Micro.hs +++ b/benchmarks/Micro.hs @@ -4,8 +4,9 @@ import Prelude.Compat import Criterion.Main -import qualified Data.Aeson.Encoding.Builder as AB -import qualified Data.ByteString.Builder as B + +-- Encoding is a newtype wrapper around Builder +import Data.Aeson.Encoding (text, string, encodingToLazyByteString) import qualified Data.Text as T main :: IO () @@ -13,8 +14,8 @@ let txt = "append (append b (primBounded w1 x1)) (primBounded w2 x2)" defaultMain [ bgroup "string" [ - bench "text" $ nf (B.toLazyByteString . AB.text) (T.pack txt) - , bench "string direct" $ nf (B.toLazyByteString . AB.string) txt - , bench "string via text" $ nf (B.toLazyByteString . AB.text . T.pack) txt + bench "text" $ nf (encodingToLazyByteString . text) (T.pack txt) + , bench "string direct" $ nf (encodingToLazyByteString . string) txt + , bench "string via text" $ nf (encodingToLazyByteString . text . T.pack) txt ] ] diff --git a/benchmarks/Options.hs b/benchmarks/Options.hs --- a/benchmarks/Options.hs +++ b/benchmarks/Options.hs @@ -1,8 +1,5 @@ module Options (opts) where -import Prelude () -import Prelude.Compat - import Data.Aeson.Types opts :: Options diff --git a/benchmarks/Typed/Common.hs b/benchmarks/Typed/Common.hs --- a/benchmarks/Typed/Common.hs +++ b/benchmarks/Typed/Common.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE CPP #-} -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -{-# LANGUAGE PackageImports #-} -#endif - {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Typed.Common (load) where @@ -14,12 +9,7 @@ import System.Exit import System.IO -#ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson hiding (Result) -#else -import "aeson" Data.Aeson hiding (Result) -import qualified "aeson-benchmarks" Data.Aeson as B -#endif load :: FromJSON a => FilePath -> IO a load fileName = do diff --git a/benchmarks/Typed/Generic.hs b/benchmarks/Typed/Generic.hs --- a/benchmarks/Typed/Generic.hs +++ b/benchmarks/Typed/Generic.hs @@ -1,60 +1,43 @@ -{-# LANGUAGE PackageImports #-} module Typed.Generic (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat -import "aeson" Data.Aeson hiding (Result) +import Data.Aeson hiding (Result) import Criterion import Data.ByteString.Lazy as L import Twitter.Generic import Typed.Common -import qualified "aeson-benchmarks" Data.Aeson as B -encodeDirectA :: Result -> L.ByteString -encodeDirectA = encode - -encodeViaValueA :: Result -> L.ByteString -encodeViaValueA = encode . toJSON - -encodeDirectB :: Result -> L.ByteString -encodeDirectB = B.encode +encodeDirect :: Result -> L.ByteString +encodeDirect = encode -encodeViaValueB :: Result -> L.ByteString -encodeViaValueB = B.encode . B.toJSON +encodeViaValue :: Result -> L.ByteString +encodeViaValue = encode . toJSON benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "encodeGeneric" [ bgroup "direct" [ - bench "twitter100" $ nf encodeDirectB twitter100 - , bench "jp100" $ nf encodeDirectB jp100 - , bench "twitter100 baseline" $ nf encodeDirectA twitter100 - , bench "jp100 baseline" $ nf encodeDirectA jp100 + bench "twitter100" $ nf encodeDirect twitter100 + , bench "jp100" $ nf encodeDirect jp100 ] , bgroup "viaValue" [ - bench "twitter100" $ nf encodeViaValueB twitter100 - , bench "jp100" $ nf encodeViaValueB jp100 - , bench "twitter100 baseline" $ nf encodeViaValueA twitter100 - , bench "jp100 baseline" $ nf encodeViaValueA jp100 + bench "twitter100" $ nf encodeViaValue twitter100 + , bench "jp100" $ nf encodeViaValue jp100 ] ] -decodeDirectA :: L.ByteString -> Maybe Result -decodeDirectA = decode - -decodeDirectB :: L.ByteString -> Maybe Result -decodeDirectB = B.decode +decodeDirect :: L.ByteString -> Maybe Result +decodeDirect = decode decodeBenchmarks :: Benchmark decodeBenchmarks = env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "decodeGeneric" [ bgroup "direct" - [ bench "twitter100" $ nf decodeDirectB twitter100 - , bench "jp100" $ nf decodeDirectB jp100 - , bench "twitter100 baseline" $ nf decodeDirectA twitter100 - , bench "jp100 baseline" $ nf decodeDirectA jp100 + [ bench "twitter100" $ nf decodeDirect twitter100 + , bench "jp100" $ nf decodeDirect jp100 ] ] diff --git a/benchmarks/Typed/Manual.hs b/benchmarks/Typed/Manual.hs --- a/benchmarks/Typed/Manual.hs +++ b/benchmarks/Typed/Manual.hs @@ -1,60 +1,43 @@ -{-# LANGUAGE PackageImports #-} module Typed.Manual (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat -import "aeson" Data.Aeson hiding (Result) +import Data.Aeson hiding (Result) import Criterion import Data.ByteString.Lazy as L import Twitter.Manual import Typed.Common -import qualified "aeson-benchmarks" Data.Aeson as B -encodeDirectA :: Result -> L.ByteString -encodeDirectA = encode - -encodeViaValueA :: Result -> L.ByteString -encodeViaValueA = encode . toJSON - -encodeDirectB :: Result -> L.ByteString -encodeDirectB = B.encode +encodeDirect :: Result -> L.ByteString +encodeDirect = encode -encodeViaValueB :: Result -> L.ByteString -encodeViaValueB = B.encode . B.toJSON +encodeViaValue :: Result -> L.ByteString +encodeViaValue = encode . toJSON benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "encodeManual" [ bgroup "direct" [ - bench "twitter100" $ nf encodeDirectB twitter100 - , bench "jp100" $ nf encodeDirectB jp100 - , bench "twitter100 baseline" $ nf encodeDirectA twitter100 - , bench "jp100 baseline" $ nf encodeDirectA jp100 + bench "twitter100" $ nf encodeDirect twitter100 + , bench "jp100" $ nf encodeDirect jp100 ] , bgroup "viaValue" [ - bench "twitter100" $ nf encodeViaValueB twitter100 - , bench "jp100" $ nf encodeViaValueB jp100 - , bench "twitter100 baseline" $ nf encodeViaValueA twitter100 - , bench "jp100 baseline" $ nf encodeViaValueA jp100 + bench "twitter100" $ nf encodeViaValue twitter100 + , bench "jp100" $ nf encodeViaValue jp100 ] ] -decodeDirectA :: L.ByteString -> Maybe Result -decodeDirectA = decode - -decodeDirectB :: L.ByteString -> Maybe Result -decodeDirectB = B.decode +decodeDirect :: L.ByteString -> Maybe Result +decodeDirect = decode decodeBenchmarks :: Benchmark decodeBenchmarks = env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "decodeManual" [ bgroup "direct" - [ bench "twitter100" $ nf decodeDirectB twitter100 - , bench "jp100" $ nf decodeDirectB jp100 - , bench "twitter100 baseline" $ nf decodeDirectA twitter100 - , bench "jp100 baseline" $ nf decodeDirectA jp100 + [ bench "twitter100" $ nf decodeDirect twitter100 + , bench "jp100" $ nf decodeDirect jp100 ] ] diff --git a/benchmarks/Typed/TH.hs b/benchmarks/Typed/TH.hs --- a/benchmarks/Typed/TH.hs +++ b/benchmarks/Typed/TH.hs @@ -1,60 +1,43 @@ -{-# LANGUAGE PackageImports #-} module Typed.TH (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat -import "aeson" Data.Aeson hiding (Result) +import Data.Aeson hiding (Result) import Criterion import Data.ByteString.Lazy as L import Twitter.TH import Typed.Common -import qualified "aeson-benchmarks" Data.Aeson as B -encodeDirectA :: Result -> L.ByteString -encodeDirectA = encode - -encodeViaValueA :: Result -> L.ByteString -encodeViaValueA = encode . toJSON - -encodeDirectB :: Result -> L.ByteString -encodeDirectB = B.encode +encodeDirect :: Result -> L.ByteString +encodeDirect = encode -encodeViaValueB :: Result -> L.ByteString -encodeViaValueB = B.encode . B.toJSON +encodeViaValue :: Result -> L.ByteString +encodeViaValue = encode . toJSON benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "encodeTH" [ bgroup "direct" [ - bench "twitter100" $ nf encodeDirectB twitter100 - , bench "jp100" $ nf encodeDirectB jp100 - , bench "twitter100 baseline" $ nf encodeDirectA twitter100 - , bench "jp100 baseline" $ nf encodeDirectA jp100 + bench "twitter100" $ nf encodeDirect twitter100 + , bench "jp100" $ nf encodeDirect jp100 ] , bgroup "viaValue" [ - bench "twitter100" $ nf encodeViaValueA twitter100 - , bench "jp100" $ nf encodeViaValueA jp100 - , bench "twitter100 baseline" $ nf encodeViaValueB twitter100 - , bench "jp100 baseline" $ nf encodeViaValueB jp100 + bench "twitter100" $ nf encodeViaValue twitter100 + , bench "jp100" $ nf encodeViaValue jp100 ] ] -decodeDirectA :: L.ByteString -> Maybe Result -decodeDirectA = decode - -decodeDirectB :: L.ByteString -> Maybe Result -decodeDirectB = B.decode +decodeDirect :: L.ByteString -> Maybe Result +decodeDirect = decode decodeBenchmarks :: Benchmark decodeBenchmarks = env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) -> bgroup "decodeTH" [ bgroup "direct" - [ bench "twitter100" $ nf decodeDirectB twitter100 - , bench "jp100" $ nf decodeDirectB jp100 - , bench "twitter100 baseline" $ nf decodeDirectA twitter100 - , bench "jp100 baseline" $ nf decodeDirectA jp100 + [ bench "twitter100" $ nf decodeDirect twitter100 + , bench "jp100" $ nf decodeDirect jp100 ] ] diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -1,100 +1,153 @@ name: aeson-benchmarks version: 0 build-type: Simple - -cabal-version: >=1.8 +cabal-version: >=1.10 flag bytestring-builder description: Depend on the bytestring-builder package for backwards compatibility. default: False manual: False +flag local-aeson + description: Build the local version of aeson, to avoid rebuilding aeson's + reverse dependencies for benchmarking (statistics, criterion). + default: True + manual: True + library default-language: Haskell2010 - hs-source-dirs: .. . ../ffi ../pure ../attoparsec-iso8601 - c-sources: ../cbits/unescape_string.c - exposed-modules: - Data.Aeson - Data.Aeson.Encoding - Data.Aeson.Encoding.Builder - Data.Aeson.Encoding.Internal - Data.Aeson.Internal - Data.Aeson.Internal.Functions - Data.Aeson.Internal.Time - Data.Aeson.Parser - Data.Aeson.Parser.Internal - Data.Aeson.Parser.Time - Data.Aeson.Parser.Unescape - Data.Aeson.Parser.UnescapeFFI - Data.Aeson.Parser.UnescapePure - Data.Aeson.TH - Data.Aeson.Text - Data.Aeson.Types - Data.Aeson.Types.Class - Data.Aeson.Types.FromJSON - Data.Aeson.Types.Generic - Data.Aeson.Types.Internal - Data.Aeson.Types.ToJSON - Data.Attoparsec.Time - Data.Attoparsec.Time.Internal - build-depends: - attoparsec >= 0.13.0.1, - base == 4.*, - base-compat >= 0.9.1 && <0.10, - time-locale-compat >=0.1.1 && <0.2, - containers, - deepseq, - dlist >= 0.2, - fail == 4.9.*, - ghc-prim >= 0.2, - hashable >= 1.1.2.0, - mtl, - scientific >= 0.3.4.7 && < 0.4, - syb, - tagged >=0.8.3 && <0.9, - template-haskell >= 2.4, - text >= 1.1.1.0, - th-abstraction >= 0.2.2 && < 0.3, - time, - transformers, - unordered-containers >= 0.2.3.0, - uuid-types >= 1.0.3 && <1.1, - vector >= 0.7.1 - if flag(bytestring-builder) build-depends: bytestring >= 0.9 && < 0.10.4, bytestring-builder >= 0.10.4 && < 1 else build-depends: bytestring >= 0.10.4 - if impl(ghc >=7.8) - cpp-options: -DHAS_COERCIBLE + if flag(local-aeson) - if !impl(ghc >= 8.0) - -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9 - build-depends: semigroups >= 0.18.2 && < 0.19 + hs-source-dirs: .. ../ffi ../pure ../attoparsec-iso8601 + c-sources: ../cbits/unescape_string.c + build-depends: + attoparsec >= 0.13.0.1, + base == 4.*, + base-compat >= 0.9.1 && <0.10, + time-locale-compat >=0.1.1 && <0.2, + containers, + deepseq, + dlist >= 0.2, + fail == 4.9.*, + ghc-prim >= 0.2, + hashable >= 1.1.2.0, + mtl, + scientific >= 0.3.4.7 && < 0.4, + syb, + tagged >=0.8.3 && <0.9, + template-haskell >= 2.4, + text >= 1.2.3, + th-abstraction >= 0.2.2 && < 0.3, + time, + transformers, + unordered-containers >= 0.2.3.0, + uuid-types >= 1.0.3 && <1.1, + vector >= 0.7.1 - include-dirs: ../include + if !impl(ghc >= 7.10) + -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8 + build-depends: nats >= 1 && < 1.2 - ghc-options: -O2 -Wall - cpp-options: -DGENERICS + if impl(ghc >=7.8) + cpp-options: -DHAS_COERCIBLE -executable aeson-benchmark-escape - main-is: Escape.hs - hs-source-dirs: ../examples . + if !impl(ghc >= 8.0) + -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9 + build-depends: semigroups >= 0.18.2 && < 0.19 + + include-dirs: ../include + + ghc-options: -O2 -Wall + cpp-options: -DGENERICS + + exposed-modules: + Data.Aeson + Data.Aeson.Compat + Data.Aeson.Encoding + Data.Aeson.Encoding.Builder + Data.Aeson.Encoding.Internal + Data.Aeson.Internal + Data.Aeson.Internal.Functions + Data.Aeson.Internal.Time + Data.Aeson.Parser + Data.Aeson.Parser.Internal + Data.Aeson.Parser.Time + Data.Aeson.Parser.Unescape + Data.Aeson.Parser.UnescapeFFI + Data.Aeson.Parser.UnescapePure + Data.Aeson.TH + Data.Aeson.Text + Data.Aeson.Types + Data.Aeson.Types.Class + Data.Aeson.Types.FromJSON + Data.Aeson.Types.Generic + Data.Aeson.Types.Internal + Data.Aeson.Types.ToJSON + Data.Attoparsec.Time + Data.Attoparsec.Time.Internal + + else + + build-depends: aeson + + reexported-modules: + Data.Aeson, + Data.Aeson.Encoding, + Data.Aeson.Parser.Internal, + Data.Aeson.Text, + Data.Aeson.TH, + Data.Aeson.Types + +executable aeson-benchmark-auto-compare + default-language: Haskell2010 + main-is: AutoCompare.hs + hs-source-dirs: . ghc-options: -Wall -O2 -rtsopts + other-modules: + Auto.T.D + Auto.T.BigRecord + Auto.T.BigProduct + Auto.T.BigSum + Auto.G.D + Auto.G.BigRecord + Auto.G.BigProduct + Auto.G.BigSum + Options build-depends: aeson-benchmarks, base, - base-compat, - bytestring, - criterion >= 1.0, + criterion, deepseq, - ghc-prim, - text + template-haskell +executable aeson-benchmark-escape + default-language: Haskell2010 + main-is: Escape.hs + hs-source-dirs: ../examples . + ghc-options: -Wall -O2 -rtsopts + if flag(local-aeson) + build-depends: + aeson-benchmarks, + base, + base-compat, + bytestring, + criterion >= 1.0, + deepseq, + ghc-prim, + text + else + -- Disabled because of inaccessible internals + buildable: False + executable aeson-benchmark-compare + default-language: Haskell2010 main-is: Compare.hs hs-source-dirs: ../examples . ghc-options: -Wall -O2 -rtsopts @@ -118,6 +171,7 @@ text executable aeson-benchmark-micro + default-language: Haskell2010 main-is: Micro.hs hs-source-dirs: ../examples . ghc-options: -Wall -O2 -rtsopts @@ -132,12 +186,10 @@ text executable aeson-benchmark-typed + default-language: Haskell2010 main-is: Typed.hs hs-source-dirs: ../examples . ghc-options: -Wall -O2 -rtsopts - -- We must help ourself in situations when there is both - -- aeson and aeson-benchmakrs - cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS other-modules: Twitter Twitter.Generic @@ -149,7 +201,6 @@ Typed.Manual Typed.TH build-depends: - aeson, aeson-benchmarks, base, base-compat, @@ -166,11 +217,10 @@ build-depends: bytestring >= 0.10.4 executable aeson-benchmark-compare-with-json + default-language: Haskell2010 main-is: CompareWithJSON.hs ghc-options: -Wall -O2 -rtsopts - cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS build-depends: - aeson, aeson-benchmarks, base, base-compat, @@ -182,6 +232,7 @@ text executable aeson-benchmark-aeson-encode + default-language: Haskell2010 main-is: AesonEncode.hs ghc-options: -Wall -O2 -rtsopts build-depends: @@ -194,6 +245,7 @@ time executable aeson-benchmark-aeson-parse + default-language: Haskell2010 main-is: AesonParse.hs ghc-options: -Wall -O2 -rtsopts build-depends: @@ -205,6 +257,7 @@ time executable aeson-benchmark-json-parse + default-language: Haskell2010 main-is: JsonParse.hs ghc-options: -Wall -O2 -rtsopts build-depends: @@ -215,6 +268,7 @@ time executable aeson-benchmark-dates + default-language: Haskell2010 main-is: Dates.hs ghc-options: -Wall -O2 -rtsopts build-depends: @@ -226,12 +280,14 @@ aeson-benchmarks, text, time + if impl(ghc >= 8.2) + ghc-options: -Wno-simplifiable-class-constraints executable aeson-benchmark-map + default-language: Haskell2010 main-is: AesonMap.hs ghc-options: -Wall -O2 -rtsopts build-depends: - aeson, aeson-benchmarks, base, base-compat, @@ -245,10 +301,10 @@ unordered-containers executable aeson-benchmark-foldable + default-language: Haskell2010 main-is: AesonFoldable.hs ghc-options: -Wall -O2 -rtsopts build-depends: - aeson, aeson-benchmarks, base, base-compat, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,23 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.3.0.0 + +Breaking changes: +* `GKeyValue` has been renamed to `KeyValuePair`, thanks to Xia Li-yao +* Removed unused `FromJSON` constraint in `withEmbeddedJson`, thanks to Tristan Seligmann + +Other improvements: +* Optimizations of TH toEncoding, thanks to Xia Li-yao +* Optimizations of hex decoding when using the default/pure unescape implementation, thanks to Xia Li-yao +* Improved error message on `Day` parse failures, thanks to Gershom Bazerman +* Add `encodeFile` as well as `decodeFile*` variants, thanks to Markus Hauck +* Documentation fixes, thanks to Lennart Spitzner +* CPP cleanup, thanks to Ryan Scott + ### 1.2.4.0 * Add `Ord` instance for `JSONPathElement`, thanks to Simon Hengel. + ### 1.2.3.0 diff --git a/examples/Twitter.hs b/examples/Twitter.hs --- a/examples/Twitter.hs +++ b/examples/Twitter.hs @@ -27,7 +27,6 @@ import Data.Int (Int64) import Data.Text (Text) import GHC.Generics (Generic) -import Prelude hiding (id) {-# ANN module "Hlint: ignore Use camelCase" #-} {-# ANN module "Hlint: ignore Use newtype instead of data" #-} diff --git a/examples/Twitter/Generic.hs b/examples/Twitter/Generic.hs --- a/examples/Twitter/Generic.hs +++ b/examples/Twitter/Generic.hs @@ -1,12 +1,7 @@ -- Use GHC generics to automatically generate good instances. -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -{-# LANGUAGE PackageImports #-} -#endif - module Twitter.Generic ( Metadata(..) @@ -21,12 +16,7 @@ import Twitter import Twitter.Options -#ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson (ToJSON (..), FromJSON (..), genericToJSON, genericToEncoding, genericParseJSON) -#else -import "aeson" Data.Aeson (ToJSON (..), FromJSON (..), genericToJSON, genericToEncoding, genericParseJSON) -import qualified "aeson-benchmarks" Data.Aeson as B -#endif instance ToJSON Metadata where toJSON = genericToJSON twitterOptions @@ -51,29 +41,3 @@ toEncoding = genericToEncoding twitterOptions instance FromJSON Result where parseJSON = genericParseJSON twitterOptions - -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -instance B.ToJSON Metadata where - toJSON = B.genericToJSON btwitterOptions - toEncoding = B.genericToEncoding btwitterOptions -instance B.FromJSON Metadata where - parseJSON = B.genericParseJSON btwitterOptions - -instance B.ToJSON Geo where - toJSON = B.genericToJSON btwitterOptions - toEncoding = B.genericToEncoding btwitterOptions -instance B.FromJSON Geo where - parseJSON = B.genericParseJSON btwitterOptions - -instance B.ToJSON Story where - toJSON = B.genericToJSON btwitterOptions - toEncoding = B.genericToEncoding btwitterOptions -instance B.FromJSON Story where - parseJSON = B.genericParseJSON btwitterOptions - -instance B.ToJSON Result where - toJSON = B.genericToJSON btwitterOptions - toEncoding = B.genericToEncoding btwitterOptions -instance B.FromJSON Result where - parseJSON = B.genericParseJSON btwitterOptions -#endif diff --git a/examples/Twitter/Manual.hs b/examples/Twitter/Manual.hs --- a/examples/Twitter/Manual.hs +++ b/examples/Twitter/Manual.hs @@ -1,14 +1,9 @@ -- Manually write instances. -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -{-# LANGUAGE PackageImports #-} -#endif - module Twitter.Manual ( Metadata(..) @@ -22,15 +17,9 @@ import Control.Applicative import Data.Monoid ((<>)) -import Prelude hiding (id) import Twitter -#ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson hiding (Result) -#else -import "aeson" Data.Aeson hiding (Result) -import qualified "aeson-benchmarks" Data.Aeson as B -#endif instance ToJSON Metadata where @@ -155,128 +144,3 @@ <*> v .: "max_id_str" <*> v .: "query" parseJSON _ = empty - -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -instance B.ToJSON Metadata where - toJSON Metadata{..} = B.object [ - "result_type" B..= result_type - ] - - toEncoding Metadata{..} = B.pairs $ - "result_type" B..= result_type - -instance B.FromJSON Metadata where - parseJSON (B.Object v) = Metadata <$> v B..: "result_type" - parseJSON _ = empty - -instance B.ToJSON Geo where - toJSON Geo{..} = B.object [ - "type_" B..= type_ - , "coordinates" B..= coordinates - ] - - toEncoding Geo{..} = B.pairs $ - "type_" B..= type_ - <> "coordinates" B..= coordinates - -instance B.FromJSON Geo where - parseJSON (B.Object v) = Geo <$> - v B..: "type_" - <*> v B..: "coordinates" - parseJSON _ = empty - -instance B.ToJSON Story where - toJSON Story{..} = B.object [ - "from_user_id_str" B..= from_user_id_str - , "profile_image_url" B..= profile_image_url - , "created_at" B..= created_at - , "from_user" B..= from_user - , "id_str" B..= id_str - , "metadata" B..= metadata - , "to_user_id" B..= to_user_id - , "text" B..= text - , "id" B..= id_ - , "from_user_id" B..= from_user_id - , "geo" B..= geo - , "iso_language_code" B..= iso_language_code - , "to_user_id_str" B..= to_user_id_str - , "source" B..= source - ] - - toEncoding Story{..} = B.pairs $ - "from_user_id_str" B..= from_user_id_str - <> "profile_image_url" B..= profile_image_url - <> "created_at" B..= created_at - <> "from_user" B..= from_user - <> "id_str" B..= id_str - <> "metadata" B..= metadata - <> "to_user_id" B..= to_user_id - <> "text" B..= text - <> "id" B..= id_ - <> "from_user_id" B..= from_user_id - <> "geo" B..= geo - <> "iso_language_code" B..= iso_language_code - <> "to_user_id_str" B..= to_user_id_str - <> "source" B..= source - -instance B.FromJSON Story where - parseJSON (B.Object v) = Story <$> - v B..: "from_user_id_str" - <*> v B..: "profile_image_url" - <*> v B..: "created_at" - <*> v B..: "from_user" - <*> v B..: "id_str" - <*> v B..: "metadata" - <*> v B..: "to_user_id" - <*> v B..: "text" - <*> v B..: "id" - <*> v B..: "from_user_id" - <*> v B..: "geo" - <*> v B..: "iso_language_code" - <*> v B..: "to_user_id_str" - <*> v B..: "source" - parseJSON _ = empty - -instance B.ToJSON Result where - toJSON Result{..} = B.object [ - "results" B..= results - , "max_id" B..= max_id - , "since_id" B..= since_id - , "refresh_url" B..= refresh_url - , "next_page" B..= next_page - , "results_per_page" B..= results_per_page - , "page" B..= page - , "completed_in" B..= completed_in - , "since_id_str" B..= since_id_str - , "max_id_str" B..= max_id_str - , "query" B..= query - ] - - toEncoding Result{..} = B.pairs $ - "results" B..= results - <> "max_id" B..= max_id - <> "since_id" B..= since_id - <> "refresh_url" B..= refresh_url - <> "next_page" B..= next_page - <> "results_per_page" B..= results_per_page - <> "page" B..= page - <> "completed_in" B..= completed_in - <> "since_id_str" B..= since_id_str - <> "max_id_str" B..= max_id_str - <> "query" B..= query - -instance B.FromJSON Result where - parseJSON (B.Object v) = Result <$> - v B..: "results" - <*> v B..: "max_id" - <*> v B..: "since_id" - <*> v B..: "refresh_url" - <*> v B..: "next_page" - <*> v B..: "results_per_page" - <*> v B..: "page" - <*> v B..: "completed_in" - <*> v B..: "since_id_str" - <*> v B..: "max_id_str" - <*> v B..: "query" - parseJSON _ = empty -#endif diff --git a/examples/Twitter/Options.hs b/examples/Twitter/Options.hs --- a/examples/Twitter/Options.hs +++ b/examples/Twitter/Options.hs @@ -1,20 +1,6 @@ -{-# LANGUAGE CPP #-} - -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -{-# LANGUAGE PackageImports #-} -#endif - module Twitter.Options (module Twitter.Options) where -#ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson -import Data.Aeson.Types -#else -import "aeson" Data.Aeson -import "aeson" Data.Aeson.Types -import qualified "aeson-benchmarks" Data.Aeson as B -import qualified "aeson-benchmarks" Data.Aeson.Types as B -#endif twitterOptions :: Options twitterOptions = defaultOptions @@ -22,12 +8,3 @@ "id_" -> "id" _ -> x } - -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -btwitterOptions :: B.Options -btwitterOptions = B.defaultOptions - { B.fieldLabelModifier = \x -> case x of - "id_" -> "id" - _ -> x - } -#endif diff --git a/examples/Twitter/TH.hs b/examples/Twitter/TH.hs --- a/examples/Twitter/TH.hs +++ b/examples/Twitter/TH.hs @@ -1,13 +1,8 @@ -- Use Template Haskell to generate good instances. -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -{-# LANGUAGE PackageImports #-} -#endif - module Twitter.TH ( Metadata(..) @@ -21,21 +16,9 @@ import Twitter import Twitter.Options -#ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson.TH -#else -import "aeson" Data.Aeson.TH -import qualified "aeson-benchmarks" Data.Aeson.TH as B -#endif $(deriveJSON twitterOptions ''Metadata) $(deriveJSON twitterOptions ''Geo) $(deriveJSON twitterOptions ''Story) $(deriveJSON twitterOptions ''Result) - -#ifdef HAS_BOTH_AESON_AND_BENCHMARKS -$(B.deriveJSON btwitterOptions ''Metadata) -$(B.deriveJSON btwitterOptions ''Geo) -$(B.deriveJSON btwitterOptions ''Story) -$(B.deriveJSON btwitterOptions ''Result) -#endif diff --git a/ffi/Data/Aeson/Parser/UnescapeFFI.hs b/ffi/Data/Aeson/Parser/UnescapeFFI.hs --- a/ffi/Data/Aeson/Parser/UnescapeFFI.hs +++ b/ffi/Data/Aeson/Parser/UnescapeFFI.hs @@ -10,7 +10,7 @@ import Control.Exception (evaluate, throw, try) import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Data.ByteString as B -import Data.ByteString.Internal as B hiding (c2w) +import Data.ByteString.Internal as B import Data.Text.Encoding.Error (UnicodeException (..)) import Data.Text.Internal (Text (..)) import Data.Text.Internal.Private (runText) diff --git a/pure/Data/Aeson/Parser/UnescapePure.hs b/pure/Data/Aeson/Parser/UnescapePure.hs --- a/pure/Data/Aeson/Parser/UnescapePure.hs +++ b/pure/Data/Aeson/Parser/UnescapePure.hs @@ -120,29 +120,11 @@ _ -> throwDecodeError decodeHex :: Word8 -> Word16 -decodeHex 48 = 0 -- '0' -decodeHex 49 = 1 -- '1' -decodeHex 50 = 2 -- '2' -decodeHex 51 = 3 -- '3' -decodeHex 52 = 4 -- '4' -decodeHex 53 = 5 -- '5' -decodeHex 54 = 6 -- '6' -decodeHex 55 = 7 -- '7' -decodeHex 56 = 8 -- '8' -decodeHex 57 = 9 -- '9' -decodeHex 65 = 10 -- 'A' -decodeHex 97 = 10 -- 'a' -decodeHex 66 = 11 -- 'B' -decodeHex 98 = 11 -- 'b' -decodeHex 67 = 12 -- 'C' -decodeHex 99 = 12 -- 'c' -decodeHex 68 = 13 -- 'D' -decodeHex 100 = 13 -- 'd' -decodeHex 69 = 14 -- 'E' -decodeHex 101 = 14 -- 'e' -decodeHex 70 = 15 -- 'F' -decodeHex 102 = 15 -- 'f' -decodeHex _ = throwDecodeError +decodeHex x + | 48 <= x && x <= 57 = fromIntegral x - 48 -- 0-9 + | 65 <= x && x <= 70 = fromIntegral x - 55 -- A-F + | 97 <= x && x <= 102 = fromIntegral x - 87 -- a-f + | otherwise = throwDecodeError unescapeText' :: ByteString -> Text unescapeText' bs = runText $ \done -> do diff --git a/stack-bench.yaml b/stack-bench.yaml --- a/stack-bench.yaml +++ b/stack-bench.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.5 +resolver: nightly-2017-12-23 # We use aeson in the snapshot to # - avoid recompilation of criterion # - compare against it @@ -10,6 +10,5 @@ packages: - benchmarks extra-deps: -- aeson-1.2.1.0 -- quickcheck-instances-0.3.14 -- th-abstraction-0.2.2.0 +- aeson-1.2.3.0 +- text-1.2.3.0 diff --git a/stack-ffi-unescape.yaml b/stack-ffi-unescape.yaml --- a/stack-ffi-unescape.yaml +++ b/stack-ffi-unescape.yaml @@ -1,7 +1,9 @@ -resolver: nightly-2017-09-04 +resolver: lts-10.0 packages: - '.' flags: aeson: fast: true cffi: true +extra-deps: +- text-1.2.3.0 diff --git a/stack-lts10.yaml b/stack-lts10.yaml new file mode 100644 --- /dev/null +++ b/stack-lts10.yaml @@ -0,0 +1,9 @@ +resolver: lts-10.0 +packages: +- '.' +flags: + aeson: + fast: true + cffi: false + attoparsec-iso8601: + fast: true diff --git a/stack-lts6.yaml b/stack-lts6.yaml --- a/stack-lts6.yaml +++ b/stack-lts6.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.30 +resolver: lts-6.35 packages: - '.' - attoparsec-iso8601 diff --git a/stack-lts7.yaml b/stack-lts7.yaml --- a/stack-lts7.yaml +++ b/stack-lts7.yaml @@ -1,4 +1,4 @@ -resolver: lts-7.19 +resolver: lts-7.24 packages: - '.' - attoparsec-iso8601 diff --git a/stack-lts8.yaml b/stack-lts8.yaml --- a/stack-lts8.yaml +++ b/stack-lts8.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.5 +resolver: lts-8.24 packages: - '.' - attoparsec-iso8601 diff --git a/stack-lts9.yaml b/stack-lts9.yaml --- a/stack-lts9.yaml +++ b/stack-lts9.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.3 +resolver: lts-9.9 packages: - '.' - attoparsec-iso8601 diff --git a/stack-nightly.yaml b/stack-nightly.yaml --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-09-04 +resolver: nightly-2018-03-07 packages: - '.' - attoparsec-iso8601