aeson 1.0.0.0 → 1.0.1.0
raw patch · 10 files changed
+506/−205 lines, 10 filesdep ~QuickCheckdep ~generic-derivingPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: QuickCheck, generic-deriving
API changes (from Hackage documentation)
Files
- Data/Aeson/Parser/Internal.hs +26/−141
- Data/Aeson/Parser/Unescape.hs +51/−0
- Data/Aeson/Types/FromJSON.hs +106/−16
- Data/Aeson/Types/ToJSON.hs +104/−13
- aeson.cabal +6/−3
- benchmarks/aeson-benchmarks.cabal +10/−11
- cbits/unescape_string.c +150/−0
- changelog.md +11/−0
- tests/Instances.hs +28/−21
- tests/UnitTests.hs +14/−0
Data/Aeson/Parser/Internal.hs view
@@ -36,34 +36,23 @@ import Prelude () import Prelude.Compat -import Control.Monad.IO.Class (liftIO) import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..)) import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string)+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string) import Data.Bits ((.|.), shiftL) import Data.ByteString.Internal (ByteString(..)) import Data.Char (chr) import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8')-import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)-import Data.Text.Internal.Unsafe.Char (ord)-import Data.Vector as Vector (Vector, empty, fromList, reverse)-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Utils (copyBytes)-import Foreign.Ptr (Ptr, minusPtr, plusPtr)-import Foreign.Storable (poke)-import System.IO.Unsafe (unsafePerformIO)+import Data.Vector as Vector (Vector, empty, fromListN, reverse) import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.Lazy as L-import qualified Data.Attoparsec.Zepto as Z import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Unsafe as B import qualified Data.HashMap.Strict as H+import Data.Aeson.Parser.Unescape #if MIN_VERSION_ghc_prim(0,3,1)-import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)+import GHC.Base (Int#, (==#), isTrue#, word2Int#) import GHC.Word (Word8(W8#)) #endif @@ -126,16 +115,18 @@ w <- A.peekWord8' if w == CLOSE_CURLY then A.anyWord8 >> return H.empty- else loop H.empty+ else loop [] where- loop m0 = do+ -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'+ -- and it's much faster because it's doing in place update to the 'HashMap'!+ loop acc = do k <- str <* skipSpace <* char ':' v <- val <* skipSpace- let !m = H.insert k v m0 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY+ let acc' = (k, v) : acc if ch == COMMA- then skipSpace >> loop m- else return m+ then skipSpace >> loop acc'+ else return (H.fromList acc') {-# INLINE objectValues #-} array_ :: Parser Value@@ -152,14 +143,14 @@ w <- A.peekWord8' if w == CLOSE_SQUARE then A.anyWord8 >> return Vector.empty- else loop []+ else loop [] 1 where- loop acc = do+ loop acc !len = do v <- val <* skipSpace ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE if ch == COMMA- then skipSpace >> loop (v:acc)- else return (Vector.reverse (Vector.fromList (v:acc)))+ then skipSpace >> loop (v:acc) (len+1)+ else return (Vector.reverse (Vector.fromListN len (v:acc))) {-# INLINE arrayValues #-} -- | Parse any JSON value. You should usually 'json' in preference to@@ -215,101 +206,30 @@ jstring_ :: Parser Text {-# INLINE jstring_ #-} jstring_ = {-# SCC "jstring_" #-} do- (s, fin) <- A.runScanner startState go- _ <- A.anyWord8- s1 <- if isEscaped fin- then case unescape s of- Right r -> return r- Left err -> fail err- else return s- case decodeUtf8' s1 of+ s <- A.scan startState go <* A.anyWord8+ case unescapeText s of Right r -> return r Left err -> fail $ show err where #if MIN_VERSION_ghc_prim(0,3,1)- isEscaped (S _ escaped) = isTrue# escaped- startState = S 0# 0#- go (S a b) (W8# c)- | isTrue# a = Just (S 0# b)+ startState = S 0#+ go (S a) (W8# c)+ | isTrue# a = Just (S 0#) | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote | otherwise = let a' = word2Int# c ==# 92# -- backslash- in Just (S a' (orI# a' b))+ in Just (S a') -data S = S Int# Int#+data S = S Int# #else- isEscaped (S _ escaped) = escaped- startState = S False False- go (S a b) c- | a = Just (S False b)+ startState = False+ go a c+ | a = Just False | c == DOUBLE_QUOTE = Nothing | otherwise = let a' = c == backslash- in Just (S a' (a' || b))+ in Just a' where backslash = BACKSLASH--data S = S !Bool !Bool #endif -unescape :: ByteString -> Either String ByteString-unescape s = unsafePerformIO $ do- let len = B.length s- fp <- B.mallocByteString len- -- We perform no bounds checking when writing to the destination- -- string, as unescaping always makes it shorter than the source.- withForeignPtr fp $ \ptr -> do- ret <- Z.parseT (go ptr) s- case ret of- Left err -> return (Left err)- Right p -> do- let newlen = p `minusPtr` ptr- slop = len - newlen- Right <$> if slop >= 128 && slop >= len `quot` 4- then B.create newlen $ \np -> copyBytes np ptr newlen- else return (PS fp 0 newlen)- where- go ptr = do- h <- Z.takeWhile (/=BACKSLASH)- let rest = do- start <- Z.take 2- let !slash = B.unsafeHead start- !t = B.unsafeIndex start 1- escape = case B.elemIndex t "\"\\/ntbrfu" of- Just i -> i- _ -> 255- if slash /= BACKSLASH || escape == 255- then fail "invalid JSON escape sequence"- else- if t /= 117 -- 'u'- then copy h ptr >>= word8 (B.unsafeIndex mapping escape) >>= go- else do- a <- hexQuad- if a < 0xd800 || a > 0xdfff- then copy h ptr >>= charUtf8 (chr a) >>= go- else do- b <- Z.string "\\u" *> hexQuad- if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff- then let !c = ((a - 0xd800) `shiftL` 10) +- (b - 0xdc00) + 0x10000- in copy h ptr >>= charUtf8 (chr c) >>= go- else fail "invalid UTF-16 surrogates"- done <- Z.atEnd- if done- then copy h ptr- else rest- mapping = "\"\\/\n\t\b\r\f"--hexQuad :: Z.ZeptoT IO Int-hexQuad = do- s <- Z.take 4- let hex n | w >= C_0 && w <= C_9 = w - C_0- | w >= C_a && w <= C_f = w - 87- | w >= C_A && w <= C_F = w - 55- | otherwise = 255- where w = fromIntegral $ B.unsafeIndex s n- a = hex 0; b = hex 1; c = hex 2; d = hex 3- if (a .|. b .|. c .|. d) /= 255- then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)- else fail "invalid hex escape"- decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a decodeWith p to s = case L.parse p s of@@ -373,38 +293,3 @@ -- end-of-input. See also: 'json''. jsonEOF' :: Parser Value jsonEOF' = json' <* skipSpace <* endOfInput--word8 :: Word8 -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)-word8 w ptr = do- liftIO $ poke ptr w- return $! ptr `plusPtr` 1--copy :: ByteString -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)-copy (PS fp off len) ptr =- liftIO . withForeignPtr fp $ \src -> do- copyBytes ptr (src `plusPtr` off) len- return $! ptr `plusPtr` len--charUtf8 :: Char -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)-charUtf8 ch ptr- | ch < '\x80' = liftIO $ do- poke ptr (fromIntegral (ord ch))- return $! ptr `plusPtr` 1- | ch < '\x800' = liftIO $ do- let (a,b) = ord2 ch- poke ptr a- poke (ptr `plusPtr` 1) b- return $! ptr `plusPtr` 2- | ch < '\xffff' = liftIO $ do- let (a,b,c) = ord3 ch- poke ptr a- poke (ptr `plusPtr` 1) b- poke (ptr `plusPtr` 2) c- return $! ptr `plusPtr` 3- | otherwise = liftIO $ do- let (a,b,c,d) = ord4 ch- poke ptr a- poke (ptr `plusPtr` 1) b- poke (ptr `plusPtr` 2) c- poke (ptr `plusPtr` 3) d- return $! ptr `plusPtr` 4
+ Data/Aeson/Parser/Unescape.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}++module Data.Aeson.Parser.Unescape (+ unescapeText+) where++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 qualified Data.Text.Array as A+import Data.Text.Encoding.Error (UnicodeException (..))+import Data.Text.Internal (Text (..))+import Data.Text.Internal.Private (runText)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Word (Word8)+import Foreign.C.Types (CInt (..), CSize (..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek)+import GHC.Base (MutableByteArray#)++foreign import ccall unsafe "_js_decode_string" c_js_decode+ :: MutableByteArray# s -> Ptr CSize+ -> Ptr Word8 -> Ptr Word8 -> IO CInt++unescapeText' :: ByteString -> Text+unescapeText' (PS fp off len) = runText $ \done -> do+ let go dest = withForeignPtr fp $ \ptr ->+ with (0::CSize) $ \destOffPtr -> do+ let end = ptr `plusPtr` (off + len)+ loop curPtr = do+ res <- c_js_decode (A.maBA dest) destOffPtr curPtr end+ case res of+ 0 -> do+ n <- peek destOffPtr+ unsafeSTToIO (done dest (fromIntegral n))+ _ ->+ throw (DecodeError desc Nothing)+ loop (ptr `plusPtr` off)+ (unsafeIOToST . go) =<< A.new len+ where+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"+{-# INLINE unescapeText' #-}++unescapeText :: ByteString -> Either UnicodeException Text+unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'+{-# INLINE unescapeText #-}
Data/Aeson/Types/FromJSON.hs view
@@ -87,7 +87,7 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), Dual(..), First (..), Last (..))+import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) import Data.Ratio ((%), Ratio) import Data.Scientific (Scientific)@@ -104,6 +104,7 @@ import GHC.Generics import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S)+import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson.Parser.Time as Time import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific) import qualified Data.DList as DList@@ -112,7 +113,9 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as M+import qualified Data.Monoid as Monoid import qualified Data.Scientific as Scientific+import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T@@ -124,7 +127,6 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU-import Unsafe.Coerce (unsafeCoerce) #ifndef HAS_COERCIBLE #define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)@@ -655,9 +657,9 @@ Just v -> parseJSON v <?> Key key {-# INLINE (.:) #-} --- | Retrieve the value associated with the given key of an 'Object'. The--- result is 'Nothing' if the key is not present or value is 'Null', or 'empty'--- if the value cannot be converted to the desired type.+-- | Retrieve the value associated with the given key of an 'Object'. The+-- result is 'Nothing' if the key is not present or if its value is 'Null',+-- or 'empty' if the value cannot be converted to the desired type. -- -- This accessor is most useful if the key and value can be absent -- from an object without affecting its validity. If the key and@@ -668,8 +670,12 @@ Just v -> parseJSON v <?> Key key {-# INLINE (.:?) #-} --- | Like '.:?', but the resulting parser will fail,--- if the key is present but is 'Null'.+-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'Nothing' if the key is not present or 'empty' if the+-- value cannot be converted to the desired type.+--+-- This differs from '.:?' by attempting to parse 'Null' the same as any+-- other JSON value, instead of interpreting it as 'Nothing'. (.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) obj .:! key = case H.lookup key obj of Nothing -> pure Nothing@@ -1605,29 +1611,113 @@ -- base Monoid/Semigroup ------------------------------------------------------------------------------- -instance FromJSON1 Dual where- liftParseJSON p _ = fmap Dual . p+instance FromJSON1 Monoid.Dual where+ liftParseJSON p _ = fmap Monoid.Dual . p {-# INLINE liftParseJSON #-} -instance FromJSON a => FromJSON (Dual a) where+instance FromJSON a => FromJSON (Monoid.Dual a) where parseJSON = parseJSON1 {-# INLINE parseJSON #-} -instance FromJSON1 First where- liftParseJSON p p' = fmap First . liftParseJSON p p'+instance FromJSON1 Monoid.First where+ liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p' {-# INLINE liftParseJSON #-} -instance FromJSON a => FromJSON (First a) where+instance FromJSON a => FromJSON (Monoid.First a) where parseJSON = parseJSON1 {-# INLINE parseJSON #-} -instance FromJSON1 Last where- liftParseJSON p p' = fmap Last . liftParseJSON p p'+instance FromJSON1 Monoid.Last where+ liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p' {-# INLINE liftParseJSON #-} -instance FromJSON a => FromJSON (Last a) where+instance FromJSON a => FromJSON (Monoid.Last a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}+++instance FromJSON1 Semigroup.Min where+ liftParseJSON p _ a = Semigroup.Min <$> p a+ {-# INLINE liftParseJSON #-}++ liftParseJSONList _ p a = fmap Semigroup.Min <$> p a+ {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Min a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}++ parseJSONList = liftParseJSONList parseJSON parseJSONList+ {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Max where+ liftParseJSON p _ a = Semigroup.Max <$> p a+ {-# INLINE liftParseJSON #-}++ liftParseJSONList _ p a = fmap Semigroup.Max <$> p a+ {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Max a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}++ parseJSONList = liftParseJSONList parseJSON parseJSONList+ {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.First where+ liftParseJSON p _ a = Semigroup.First <$> p a+ {-# INLINE liftParseJSON #-}++ liftParseJSONList _ p a = fmap Semigroup.First <$> p a+ {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.First a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}++ parseJSONList = liftParseJSONList parseJSON parseJSONList+ {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Last where+ liftParseJSON p _ a = Semigroup.Last <$> p a+ {-# INLINE liftParseJSON #-}++ liftParseJSONList _ p a = fmap Semigroup.Last <$> p a+ {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Last a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}++ parseJSONList = liftParseJSONList parseJSON parseJSONList+ {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.WrappedMonoid where+ liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a+ {-# INLINE liftParseJSON #-}++ liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a+ {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where+ parseJSON = parseJSON1+ {-# INLINE parseJSON #-}++ parseJSONList = liftParseJSONList parseJSON parseJSONList+ {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Option where+ liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'+ {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Semigroup.Option a) where parseJSON = parseJSON1 {-# INLINE parseJSON #-}
Data/Aeson/Types/ToJSON.hs view
@@ -78,7 +78,7 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..))-import Data.Monoid ((<>), Dual(..), First(..), Last(..))+import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) import Data.Ratio (Ratio, denominator, numerator) import Data.Scientific (Scientific)@@ -104,7 +104,9 @@ import qualified Data.IntSet as IntSet import qualified Data.List.NonEmpty as NE import qualified Data.Map as M+import qualified Data.Monoid as Monoid import qualified Data.Scientific as Scientific+import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T@@ -2026,14 +2028,14 @@ -- base Monoid/Semigroup ------------------------------------------------------------------------------- -instance ToJSON1 Dual where- liftToJSON t _ = t . getDual+instance ToJSON1 Monoid.Dual where+ liftToJSON t _ = t . Monoid.getDual {-# INLINE liftToJSON #-} - liftToEncoding t _ = t . getDual+ liftToEncoding t _ = t . Monoid.getDual {-# INLINE liftToEncoding #-} -instance ToJSON a => ToJSON (Dual a) where+instance ToJSON a => ToJSON (Monoid.Dual a) where toJSON = toJSON1 {-# INLINE toJSON #-} @@ -2041,14 +2043,14 @@ {-# INLINE toEncoding #-} -instance ToJSON1 First where- liftToJSON t to' = liftToJSON t to' . getFirst+instance ToJSON1 Monoid.First where+ liftToJSON t to' = liftToJSON t to' . Monoid.getFirst {-# INLINE liftToJSON #-} - liftToEncoding t to' = liftToEncoding t to' . getFirst+ liftToEncoding t to' = liftToEncoding t to' . Monoid.getFirst {-# INLINE liftToEncoding #-} -instance ToJSON a => ToJSON (First a) where+instance ToJSON a => ToJSON (Monoid.First a) where toJSON = toJSON1 {-# INLINE toJSON #-} @@ -2056,14 +2058,103 @@ {-# INLINE toEncoding #-} -instance ToJSON1 Last where- liftToJSON t to' = liftToJSON t to' . getLast+instance ToJSON1 Monoid.Last where+ liftToJSON t to' = liftToJSON t to' . Monoid.getLast {-# INLINE liftToJSON #-} - liftToEncoding t to' = liftToEncoding t to' . getLast+ liftToEncoding t to' = liftToEncoding t to' . Monoid.getLast {-# INLINE liftToEncoding #-} -instance ToJSON a => ToJSON (Last a) where+instance ToJSON a => ToJSON (Monoid.Last a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Min where+ liftToJSON t _ (Semigroup.Min x) = t x+ {-# INLINE liftToJSON #-}++ liftToEncoding t _ (Semigroup.Min x) = t x+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Min a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Max where+ liftToJSON t _ (Semigroup.Max x) = t x+ {-# INLINE liftToJSON #-}++ liftToEncoding t _ (Semigroup.Max x) = t x+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Max a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}++instance ToJSON1 Semigroup.First where+ liftToJSON t _ (Semigroup.First x) = t x+ {-# INLINE liftToJSON #-}++ liftToEncoding t _ (Semigroup.First x) = t x+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.First a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Last where+ liftToJSON t _ (Semigroup.Last x) = t x+ {-# INLINE liftToJSON #-}++ liftToEncoding t _ (Semigroup.Last x) = t x+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Last a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.WrappedMonoid where+ liftToJSON t _ (Semigroup.WrapMonoid x) = t x+ {-# INLINE liftToJSON #-}++ liftToEncoding t _ (Semigroup.WrapMonoid x) = t x+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where+ toJSON = toJSON1+ {-# INLINE toJSON #-}++ toEncoding = toEncoding1+ {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Option where+ liftToJSON t to' = liftToJSON t to' . Semigroup.getOption+ {-# INLINE liftToJSON #-}++ liftToEncoding t to' = liftToEncoding t to' . Semigroup.getOption+ {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Option a) where toJSON = toJSON1 {-# INLINE toJSON #-}
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.0.0.0+version: 1.0.1.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -52,6 +52,7 @@ examples/*.hs examples/Twitter/*.hs include/*.h+ cbits/*.c flag developer description: operate in developer mode@@ -91,6 +92,7 @@ Data.Aeson.Encoding.Builder Data.Aeson.Internal.Functions Data.Aeson.Parser.Internal+ Data.Aeson.Parser.Unescape Data.Aeson.Parser.Time Data.Aeson.Types.FromJSON Data.Aeson.Types.Generic@@ -146,6 +148,7 @@ ghc-options: -O2 include-dirs: include+ c-sources: cbits/unescape_string.c test-suite tests default-language: Haskell2010@@ -170,7 +173,7 @@ build-depends: HUnit,- QuickCheck >= 2.7 && <2.8.3,+ QuickCheck >= 2.7 && <2.9.2, aeson, attoparsec, base,@@ -178,7 +181,7 @@ base-orphans >= 0.5.3 && <0.6, containers, dlist,- generic-deriving >= 1.10 && < 1.11,+ generic-deriving >= 1.10 && < 1.12, ghc-prim >= 0.2, hashable >= 1.2.4.0, scientific,
benchmarks/aeson-benchmarks.cabal view
@@ -11,28 +11,27 @@ library hs-source-dirs: .. .-+ c-sources: ../cbits/unescape_string.c exposed-modules: Data.Aeson Data.Aeson.Encoding- Data.Aeson.Parser- Data.Aeson.Text- Data.Aeson.Types- Data.Aeson.TH-+ Data.Aeson.Encoding.Builder Data.Aeson.Encoding.Internal Data.Aeson.Internal- Data.Aeson.Internal.Time-- Data.Aeson.Encoding.Builder 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.TH+ Data.Aeson.Text+ Data.Aeson.Types+ Data.Aeson.Types.Class Data.Aeson.Types.FromJSON Data.Aeson.Types.Generic- Data.Aeson.Types.ToJSON- Data.Aeson.Types.Class Data.Aeson.Types.Internal+ Data.Aeson.Types.ToJSON build-depends: attoparsec >= 0.13.0.1,
+ cbits/unescape_string.c view
@@ -0,0 +1,150 @@+// Copyright (c) 2008-2009 Bjoern Hoehrmann+// Copyright (c) 2015, Ondrej Palkovsky+// Copyright (c) 2016, Winterland++#include <string.h>+#include <stdio.h>+#include <stdint.h>+++#define UTF8_ACCEPT 0+#define UTF8_REJECT 12++static const uint8_t utf8d[] = {+ // The first part of the table maps bytes to character classes that+ // to reduce the size of the transition table and create bitmasks.+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,+ 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,+ 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,++ // The second part is a transition table that maps a combination+ // of a state of the automaton and a character class to a state.+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,+ 12,36,12,12,12,12,12,12,12,12,12,12,+};++static inline uint32_t decode(uint32_t* state, uint32_t* codep, uint32_t byte) {+ uint32_t type = utf8d[byte];++ *codep = (*state != UTF8_ACCEPT) ?+ (byte & 0x3fu) | (*codep << 6) :+ (0xff >> type) & (byte);++ *state = utf8d[256 + *state + type];+ return *state;+}++static inline uint16_t decode_hex(uint32_t c)+{+ if (c >= '0' && c <= '9') return c - '0';+ else if (c >= 'a' && c <= 'f') return c - 'a' + 10;+ else if (c >= 'A' && c <= 'F') return c - 'A' + 10;+ return 0xFFFF; // Should not happen+}++// Decode, return non-zero value on error+int _js_decode_string(uint16_t *const dest, size_t *destoff,+ const uint8_t *s, const uint8_t *const srcend)+{+ uint16_t *d = dest + *destoff;+ uint32_t state = 0;+ uint32_t codepoint;++ uint8_t surrogate = 0;+ uint16_t temp_hex = 0;+ uint16_t unidata;++ // Optimized version of dispatch when just an ASCII char is expected+ #define DISPATCH_ASCII(label) {\+ if (s >= srcend) {\+ return -1;\+ }\+ codepoint = *s++;\+ goto label;\+ }++ standard:+ // Test end of stream+ while (s < srcend) {+ if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {+ if (state == UTF8_REJECT) { return -1; }+ continue;+ }++ if (codepoint == '\\')+ DISPATCH_ASCII(backslash)+ else if (codepoint <= 0xffff)+ *d++ = (uint16_t) codepoint;+ else {+ *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));+ *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));+ }+ }+ *destoff = d - dest;+ // Exit point+ return (state != UTF8_ACCEPT);+ backslash:+ switch (codepoint) {+ case '"':+ case '\\':+ case '/':+ *d++ = (uint16_t) codepoint;+ goto standard;+ break;+ case 'b': *d++ = '\b';goto standard;+ case 'f': *d++ = '\f';goto standard;+ case 'n': *d++ = '\n';goto standard;+ case 'r': *d++ = '\r';goto standard;+ case 't': *d++ = '\t';goto standard;+ case 'u': DISPATCH_ASCII(unicode1);;break;+ default:+ return -1;+ }+ unicode1:+ temp_hex = decode_hex(codepoint);+ if (temp_hex == 0xFFFF) { return -1; }+ else unidata = temp_hex << 12;+ DISPATCH_ASCII(unicode2);+ unicode2:+ temp_hex = decode_hex(codepoint);+ if (temp_hex == 0xFFFF) { return -1; }+ else unidata |= temp_hex << 8;+ DISPATCH_ASCII(unicode3);+ unicode3:+ temp_hex = decode_hex(codepoint);+ if (temp_hex == 0xFFFF) { return -1; }+ else unidata |= temp_hex << 4;+ DISPATCH_ASCII(unicode4);+ unicode4:+ temp_hex = decode_hex(codepoint);+ if (temp_hex == 0xFFFF) { return -1; }+ else unidata |= temp_hex;+ *d++ = (uint16_t) unidata;++ if (surrogate) {+ if (unidata <= 0xDC00 || unidata >= 0xDFFF) // is not low surrogate+ return -1;+ surrogate = 0;+ } else if (unidata >= 0xD800 && unidata <= 0xDBFF ) { // is high surrogate+ surrogate = 1;+ DISPATCH_ASCII(surrogate1);+ } else if (unidata >= 0xDC00 && unidata <= 0xDFFF) { // is low surrogate+ return -1;+ }+ goto standard;+ surrogate1:+ if (codepoint != '\\') { return -1; }+ DISPATCH_ASCII(surrogate2)+ surrogate2:+ if (codepoint != 'u') { return -1; }+ DISPATCH_ASCII(unicode1)+}+
changelog.md view
@@ -1,5 +1,16 @@ 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.0.1.0++* Decoding performance has been significantly improved (see+ https://github.com/bos/aeson/pull/452).++* Add `ToJSON`/`FromJSON` instances for newtypes from+ `Data.Semigroup`: `Min`, `Max`, `First`, `Last`, `WrappedMonoid`,+ `Option`.++* Make the documentation for `.:!` more accurate.+ # 1.0.0.0 Major enhancements:
tests/Instances.hs view
@@ -11,24 +11,29 @@ import Prelude () import Prelude.Compat -import Control.Applicative (Const(..), empty)+import Control.Applicative (empty) import Control.Monad import Data.Aeson.Types import Data.Function (on) import Data.Functor.Compose (Compose (..))-import Data.Functor.Identity (Identity (..))-import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Tagged (Tagged(..)) import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..))-import Data.Version import Functions-import Test.QuickCheck (Arbitrary(..), getNonNegative, elements, listOf1, oneof, resize)+import Test.QuickCheck (Arbitrary(..), elements, oneof) import Types import qualified Data.DList as DList import qualified Data.HashMap.Strict as HM +#if !MIN_VERSION_QuickCheck(2,9,0)+import Control.Applicative (Const(..))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Functor.Identity (Identity (..))+import Data.Version+import Test.QuickCheck (getNonNegative, listOf1, resize)+#endif+ import Data.Orphans () import Test.QuickCheck.Instances () #if MIN_VERSION_base(4,7,0)@@ -172,21 +177,11 @@ instance (ApproxEq a) => ApproxEq [a] where a =~ b = length a == length b && all (uncurry (=~)) (zip a b) -instance Arbitrary Version where- arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)--instance Arbitrary a => Arbitrary (NonEmpty a) where- arbitrary = (:|) <$> arbitrary <*> arbitrary- -- Version tags are deprecated, so we avoid using them in the Arbitrary -- instance. However, the recommended constructor 'makeVersion' is not -- exported by "Data.Version" until base-4.8.0.0. For previous versions, -- a definition is given below. -#if !MIN_VERSION_base(4,8,0)-makeVersion :: [Int] -> Version-makeVersion b = Version b []-#endif #if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3) instance Arbitrary Natural where@@ -199,15 +194,27 @@ instance Arbitrary b => Arbitrary (Tagged a b) where arbitrary = Tagged <$> arbitrary +instance Arbitrary a => Arbitrary (DList.DList a) where+ arbitrary = DList.fromList <$> arbitrary++instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where+ arbitrary = Compose <$> arbitrary++#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary a => Arbitrary (Const a b) where arbitrary = Const <$> arbitrary -instance Arbitrary a => Arbitrary (DList.DList a) where- arbitrary = DList.fromList <$> arbitrary+instance Arbitrary a => Arbitrary (NonEmpty a) where+ arbitrary = (:|) <$> arbitrary <*> arbitrary --- would like to have -- https://github.com/nick8325/quickcheck/issues/73+instance Arbitrary Version where+ arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)++#if !MIN_VERSION_base(4,8,0)+makeVersion :: [Int] -> Version+makeVersion b = Version b []+#endif+ instance Arbitrary a => Arbitrary (Identity a) where arbitrary = Identity <$> arbitrary--instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where- arbitrary = Compose <$> arbitrary+#endif
tests/UnitTests.hs view
@@ -59,6 +59,8 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as M+import qualified Data.Monoid as Monoid+import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text.Lazy as LT@@ -419,6 +421,18 @@ , Example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String) , Example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String)++ -- newtypes from Monoid/Semigroup+ , Example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)+ , Example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)+ , Example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)+ , Example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)+ , Example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)+ , Example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)+ , Example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)+ , Example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)+ , Example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)+ , Example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool)) ]