Merge branch 'master' of https://github.com/bos/aeson

Conflicts:
	Data/Aeson/Types/Internal.hs

.gitignore

@@ -8,3 +8,5 @@ cabal.sandbox.config
 benchmarks/AesonEncode
 
 tests/qc
+
+cabal.sandbox.config

.hgignore

@@ -4,7 +4,8 @@
 ^tests/(?:qc)
 
 syntax: glob
-cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
 *~
 .*.swp
 .\#*

.hgtags

@@ -25,3 +25,4 @@ c292fe0c0808c7ecc576a98cd64931bc5e74b546 0.5.0.0
 3041d9f301a908355dfdb28d8cb0c2cba39e2491 0.6.0.2
 b1770e9401a9ddb5a92543547d4faa3fd8576bd6 0.6.1.0
 717ddce43a7f0a99b57a4ff832ba7c876243d520 0.6.2.0
+52038e5c0ea396945bfb0926c5806b9484bb5d34 0.6.2.1

Data/Aeson/Encode.hs

@@ -24,11 +24,10 @@ module Data.Aeson.Encode
     ) where
 
 import Data.Aeson.Types (ToJSON(..), Value(..))
-import Data.Attoparsec.Number (Number(..))
 import Data.Monoid (mappend)
+import Data.Scientific (Scientific, coefficient, base10Exponent, scientificBuilder)
 import Data.Text.Lazy.Builder
 import Data.Text.Lazy.Builder.Int (decimal)
-import Data.Text.Lazy.Builder.RealFloat (realFloat)
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Numeric (showHex)
 import qualified Data.ByteString.Lazy as L
@@ -43,7 +42,7 @@ fromValue :: Value -> Builder
 fromValue Null = {-# SCC "fromValue/Null" #-} "null"
 fromValue (Bool b) = {-# SCC "fromValue/Bool" #-}
                      if b then "true" else "false"
-fromValue (Number n) = {-# SCC "fromValue/Number" #-} fromNumber n
+fromValue (Number s) = {-# SCC "fromValue/Number" #-} fromScientific s
 fromValue (String s) = {-# SCC "fromValue/String" #-} string s
 fromValue (Array v)
     | V.null v = {-# SCC "fromValue/Array" #-} "[]"
@@ -87,11 +86,12 @@ string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'
         | otherwise  = singleton c
         where h = showHex (fromEnum c) ""
 
-fromNumber :: Number -> Builder
-fromNumber (I i) = decimal i
-fromNumber (D d)
-    | isNaN d || isInfinite d = "null"
-    | otherwise               = realFloat d
+fromScientific :: Scientific -> Builder
+fromScientific s
+    | e < 0     = scientificBuilder s
+    | otherwise = decimal (coefficient s * 10 ^ e)
+  where
+    e = base10Exponent s
 
 -- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
 encode :: ToJSON a => a -> L.ByteString

Data/Aeson/Parser/Internal.hs

@@ -41,25 +41,42 @@ import Data.ByteString.Lazy.Builder
   (Builder, byteString, toLazyByteString, charUtf8, word8)
 #endif
 
-import Control.Applicative as A
+import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)
 import Data.Aeson.Types (Result(..), Value(..))
-import Data.Attoparsec.Char8 hiding (Result)
+import Data.Attoparsec.Char8 (Parser, char, endOfInput, rational,
+                              skipSpace, string)
 import Data.Bits ((.|.), shiftL)
-import Data.ByteString as B
+import Data.ByteString (ByteString)
 import Data.Char (chr)
 import Data.Monoid (mappend, mempty)
-import Data.Text as T
+import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8')
-import Data.Vector as Vector hiding ((++))
+import Data.Vector as Vector (Vector, fromList)
 import Data.Word (Word8)
 import qualified Data.Attoparsec as A
 import qualified Data.Attoparsec.Lazy as L
 import qualified Data.Attoparsec.Zepto as Z
-import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Unsafe as B
 import qualified Data.HashMap.Strict as H
 
+#define BACKSLASH 92
+#define CLOSE_CURLY 125
+#define CLOSE_SQUARE 93
+#define COMMA 44
+#define DOUBLE_QUOTE 34
+#define OPEN_CURLY 123
+#define OPEN_SQUARE 91
+#define C_0 48
+#define C_9 57
+#define C_A 65
+#define C_F 70
+#define C_a 97
+#define C_f 102
+#define C_n 110
+#define C_t 116
+
 -- | Parse a top-level JSON value.  This must be either an object or
 -- an array, per RFC 4627.
 --
@@ -81,8 +98,8 @@ json' = json_ object_' array_'
 
 json_ :: Parser Value -> Parser Value -> Parser Value
 json_ obj ary = do
-  w <- skipSpace *> A.satisfy (\w -> w == 123 || w == 91)
-  if w == 123
+  w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)
+  if w == OPEN_CURLY
     then obj
     else ary
 {-# INLINE json_ #-}
@@ -102,12 +119,8 @@ object_' = {-# SCC "object_'" #-} do
 objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
 objectValues str val = do
   skipSpace
-  let pair = do
-        a <- str <* skipSpace
-        b <- char ':' *> skipSpace *> val
-        return (a,b)
-  vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
-  return (H.fromList vals)
+  let pair = liftA2 (,) (str <* skipSpace) (char ':' *> skipSpace *> val)
+  H.fromList <$> commaSeparated pair CLOSE_CURLY
 {-# INLINE objectValues #-}
 
 array_ :: Parser Value
@@ -118,11 +131,25 @@ array_' = {-# SCC "array_'" #-} do
   !vals <- arrayValues value'
   return (Array vals)
 
+commaSeparated :: Parser a -> Word8 -> Parser [a]
+commaSeparated item endByte = do
+  w <- A.peekWord8'
+  if w == endByte
+    then A.anyWord8 >> return []
+    else loop
+  where
+    loop = do
+      v <- item <* skipSpace
+      ch <- A.satisfy $ \w -> w == COMMA || w == endByte
+      if ch == COMMA
+        then skipSpace >> (v:) <$> loop
+        else return [v]
+{-# INLINE commaSeparated #-}
+
 arrayValues :: Parser Value -> Parser (Vector Value)
 arrayValues val = do
   skipSpace
-  vals <- ((val <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
-  return (Vector.fromList vals)
+  Vector.fromList <$> commaSeparated val CLOSE_SQUARE
 {-# INLINE arrayValues #-}
 
 -- | Parse any JSON value.  You should usually 'json' in preference to
@@ -136,64 +163,57 @@ arrayValues val = do
 -- implementations in other languages conform to that same restriction
 -- to preserve interoperability and security.
 value :: Parser Value
-value = most <|> (Number <$> number)
- where
-  most = do
-    c <- satisfy (`B8.elem` "{[\"ftn")
-    case c of
-      '{' -> object_
-      '[' -> array_
-      '"' -> String <$> jstring_
-      'f' -> string "alse" *> pure (Bool False)
-      't' -> string "rue" *> pure (Bool True)
-      'n' -> string "ull" *> pure Null
-      _   -> error "attoparsec panic! the impossible happened!"
+value = do
+  w <- A.peekWord8'
+  case w of
+    DOUBLE_QUOTE  -> A.anyWord8 *> (String <$> jstring_)
+    OPEN_CURLY    -> A.anyWord8 *> object_
+    OPEN_SQUARE   -> A.anyWord8 *> array_
+    C_f           -> string "false" *> pure (Bool False)
+    C_t           -> string "true" *> pure (Bool True)
+    C_n           -> string "null" *> pure Null
+    _              | w >= 48 && w <= 57 || w == 45
+                  -> Number <$> rational
+      | otherwise -> fail "not a valid json value"
 
 -- | Strict version of 'value'. See also 'json''.
 value' :: Parser Value
-value' = most <|> num
- where
-  most = do
-    c <- satisfy (`B8.elem` "{[\"ftn")
-    case c of
-      '{' -> object_'
-      '[' -> array_'
-      '"' -> do
-          !s <- jstring_
-          return (String s)
-      'f' -> string "alse" *> pure (Bool False)
-      't' -> string "rue" *> pure (Bool True)
-      'n' -> string "ull" *> pure Null
-      _   -> error "attoparsec panic! the impossible happened!"
-  num = do
-    !n <- number
-    return (Number n)
-
-doubleQuote, backslash :: Word8
-doubleQuote = 34
-backslash = 92
-{-# INLINE backslash #-}
-{-# INLINE doubleQuote #-}
+value' = do
+  w <- A.peekWord8'
+  case w of
+    DOUBLE_QUOTE  -> do
+                     !s <- A.anyWord8 *> jstring_
+                     return (String s)
+    OPEN_CURLY    -> A.anyWord8 *> object_'
+    OPEN_SQUARE   -> A.anyWord8 *> array_'
+    C_f           -> string "false" *> pure (Bool False)
+    C_t           -> string "true" *> pure (Bool True)
+    C_n           -> string "null" *> pure Null
+    _              | w >= 48 && w <= 57 || w == 45
+                  -> do
+                     !n <- rational
+                     return (Number n)
+      | otherwise -> fail "not a valid json value"
 
 -- | Parse a quoted JSON string.
 jstring :: Parser Text
-jstring = A.word8 doubleQuote *> jstring_
+jstring = A.word8 DOUBLE_QUOTE *> jstring_
 
 -- | Parse a string without a leading quote.
 jstring_ :: Parser Text
 jstring_ = {-# SCC "jstring_" #-} do
   s <- A.scan False $ \s c -> if s then Just False
-                                   else if c == doubleQuote
+                                   else if c == DOUBLE_QUOTE
                                         then Nothing
-                                        else Just (c == backslash)
-  _ <- A.word8 doubleQuote
-  s' <- if backslash `B.elem` s
+                                        else Just (c == BACKSLASH)
+  _ <- A.word8 DOUBLE_QUOTE
+  s1 <- if BACKSLASH `B.elem` s
         then case Z.parse unescape s of
             Right r  -> return r
             Left err -> fail err
          else return s
 
-  case decodeUtf8' s' of
+  case decodeUtf8' s1 of
       Right r  -> return r
       Left err -> fail $ show err
 
@@ -202,15 +222,15 @@ jstring_ = {-# SCC "jstring_" #-} do
 unescape :: Z.Parser ByteString
 unescape = toByteString <$> go mempty where
   go acc = do
-    h <- Z.takeWhile (/=backslash)
+    h <- Z.takeWhile (/=BACKSLASH)
     let rest = do
           start <- Z.take 2
           let !slash = B.unsafeHead start
               !t = B.unsafeIndex start 1
               escape = case B.findIndex (==t) "\"\\/ntbrfu" of
                          Just i -> i
                          _      -> 255
-          if slash /= backslash || escape == 255
+          if slash /= BACKSLASH || escape == 255
             then fail "invalid JSON escape sequence"
             else do
             let cont m = go (acc `mappend` byteString h `mappend` m)
@@ -237,10 +257,10 @@ unescape = toByteString <$> go mempty where
 hexQuad :: Z.Parser Int
 hexQuad = do
   s <- Z.take 4
-  let hex n | w >= 48 && w <= 57  = w - 48
-            | w >= 97 && w <= 122 = w - 87
-            | w >= 65 && w <= 90  = w - 55
-            | otherwise           = 255
+  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
@@ -279,12 +299,9 @@ eitherDecodeWith p to s =
 eitherDecodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString
                        -> Either String a
 eitherDecodeStrictWith p to s =
-    case A.parse p s of
-      A.Done _ v -> case to v of
-                      Success a -> Right a
-                      Error msg -> Left msg
-      A.Fail _ _ msg -> Left msg
-      A.Partial _    -> Left "incomplete input"
+    case either Error to (A.parseOnly p s) of
+      Success a -> Right a
+      Error msg -> Left msg
 {-# INLINE eitherDecodeStrictWith #-}
 
 -- $lazy

Data/Aeson/TH.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP, FlexibleInstances, NamedFieldPuns, NoImplicitPrelude,
-    OverlappingInstances, TemplateHaskell, UndecidableInstances, IncoherentInstances
-  #-}
+{-# LANGUAGE CPP, FlexibleInstances, IncoherentInstances, NamedFieldPuns,
+    NoImplicitPrelude, OverlappingInstances, TemplateHaskell,
+    UndecidableInstances #-}
 
 {-|
 Module:      Data.Aeson.TH

Data/Aeson/Types.hs

@@ -47,6 +47,7 @@ module Data.Aeson.Types
     , withText
     , withArray
     , withNumber
+    , withScientific
     , withBool
 
     -- * Constructors and accessors
@@ -63,7 +64,7 @@ module Data.Aeson.Types
     , defaultTaggedObject
     ) where
 
-import Data.Aeson.Types.Class
+import Data.Aeson.Types.Instances
 import Data.Aeson.Types.Internal
 
 #ifdef GENERICS