Commits

Anonymous committed d06882a Merge with conflicts

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

Conflicts:
Data/Aeson/Types/Internal.hs

Comments (0)

Files changed (21)

 benchmarks/AesonEncode
 
 tests/qc
+
+cabal.sandbox.config
 ^tests/(?:qc)
 
 syntax: glob
-cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
 *~
 .*.swp
 .\#*
 3041d9f301a908355dfdb28d8cb0c2cba39e2491 0.6.0.2
 b1770e9401a9ddb5a92543547d4faa3fd8576bd6 0.6.1.0
 717ddce43a7f0a99b57a4ff832ba7c876243d520 0.6.2.0
+52038e5c0ea396945bfb0926c5806b9484bb5d34 0.6.2.1

Data/Aeson/Encode.hs

     ) 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
 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" #-} "[]"
         | 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

   (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.
 --
 
 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_ #-}
 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
   !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
 -- 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
 
 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
               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)
 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
 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
-{-# 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

     , withText
     , withArray
     , withNumber
+    , withScientific
     , withBool
 
     -- * Constructors and accessors
     , defaultTaggedObject
     ) where
 
-import Data.Aeson.Types.Class
+import Data.Aeson.Types.Instances
 import Data.Aeson.Types.Internal
 
 #ifdef GENERICS

Data/Aeson/Types/Class.hs

-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
-    GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
-    OverloadedStrings, UndecidableInstances, ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP, FlexibleContexts #-}
 
 #ifdef GENERICS
 {-# LANGUAGE DefaultSignatures #-}
 
 -- |
 -- Module:      Data.Aeson.Types.Class
--- Copyright:   (c) 2011, 2012 Bryan O'Sullivan
+-- Copyright:   (c) 2011-2013 Bryan O'Sullivan
 --              (c) 2011 MailRank, Inc.
 -- License:     Apache
 -- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
     , genericToJSON
     , genericParseJSON
 #endif
-    -- * Types
-    , DotNetTime(..)
-
-      -- * Inspecting @'Value's@
-    , withObject
-    , withText
-    , withArray
-    , withNumber
-    , withBool
-
-    -- * Functions
-    , fromJSON
-    , (.:)
-    , (.:?)
-    , (.!=)
-    , (.=)
-    , typeMismatch
     ) where
 
-import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
-import Data.Aeson.Functions
 import Data.Aeson.Types.Internal
-import Data.Attoparsec.Char8 (Number(..))
-import Data.Fixed
-import Data.Hashable (Hashable(..))
-import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Maybe (fromMaybe)
-import Data.Monoid (Dual(..), First(..), Last(..), mappend)
-import Data.Ratio (Ratio)
-import Data.Text (Text, pack, unpack)
-import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
-import Data.Time.Format (FormatTime, formatTime, parseTime)
-import Data.Traversable (traverse)
-import Data.Typeable (Typeable)
-import Data.Vector (Vector)
-import Data.Word (Word, Word8, Word16, Word32, Word64)
-import Foreign.Storable (Storable)
-import System.Locale (defaultTimeLocale, dateTimeFmt)
-import qualified Data.HashMap.Strict as H
-import qualified Data.HashSet as HashSet
-import qualified Data.IntMap as IntMap
-import qualified Data.IntSet as IntSet
-import qualified Data.Map as M
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import qualified Data.Vector as V
-import qualified Data.Vector.Generic as VG
-import qualified Data.Vector.Primitive as VP
-import qualified Data.Vector.Storable as VS
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
 
 #ifdef GENERICS
 import GHC.Generics
     default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
     parseJSON = genericParseJSON defaultOptions
 #endif
-
-instance (ToJSON a) => ToJSON (Maybe a) where
-    toJSON (Just a) = toJSON a
-    toJSON Nothing  = Null
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a) => FromJSON (Maybe a) where
-    parseJSON Null   = pure Nothing
-    parseJSON a      = Just <$> parseJSON a
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
-    toJSON (Left a)  = object [left  .= a]
-    toJSON (Right b) = object [right .= b]
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
-    parseJSON (Object (H.toList -> [(key, value)]))
-        | key == left  = Left  <$> parseJSON value
-        | key == right = Right <$> parseJSON value
-    parseJSON _        = fail ""
-    {-# INLINE parseJSON #-}
-
-left, right :: Text
-left  = "Left"
-right = "Right"
-
-instance ToJSON Bool where
-    toJSON = Bool
-    {-# INLINE toJSON #-}
-
-instance FromJSON Bool where
-    parseJSON = withBool "Bool" pure
-    {-# INLINE parseJSON #-}
-
-instance ToJSON () where
-    toJSON _ = emptyArray
-    {-# INLINE toJSON #-}
-
-instance FromJSON () where
-    parseJSON = withArray "()" $ \v ->
-                  if V.null v
-                    then pure ()
-                    else fail "Expected an empty array"
-    {-# INLINE parseJSON #-}
-
-instance ToJSON [Char] where
-    toJSON = String . T.pack
-    {-# INLINE toJSON #-}
-
-instance FromJSON [Char] where
-    parseJSON = withText "String" $ pure . T.unpack
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Char where
-    toJSON = String . T.singleton
-    {-# INLINE toJSON #-}
-
-instance FromJSON Char where
-    parseJSON = withText "Char" $ \t ->
-                  if T.compareLength t 1 == EQ
-                    then pure $ T.head t
-                    else fail "Expected a string of length 1"
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Double where
-    toJSON = Number . D
-    {-# INLINE toJSON #-}
-
-instance FromJSON Double where
-    parseJSON (Number n) = case n of
-                             D d -> pure d
-                             I i -> pure (fromIntegral i)
-    parseJSON Null       = pure (0/0)
-    parseJSON v          = typeMismatch "Double" v
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Number where
-    toJSON = Number
-    {-# INLINE toJSON #-}
-
-instance FromJSON Number where
-    parseJSON (Number n) = pure n
-    parseJSON Null       = pure (D (0/0))
-    parseJSON v          = typeMismatch "Number" v
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Float where
-    toJSON = Number . realToFrac
-    {-# INLINE toJSON #-}
-
-instance FromJSON Float where
-    parseJSON (Number n) = pure $ case n of
-                                    D d -> realToFrac d
-                                    I i -> fromIntegral i
-    parseJSON Null       = pure (0/0)
-    parseJSON v          = typeMismatch "Float" v
-    {-# INLINE parseJSON #-}
-
-instance ToJSON (Ratio Integer) where
-    toJSON = Number . fromRational
-    {-# INLINE toJSON #-}
-
-instance FromJSON (Ratio Integer) where
-    parseJSON = withNumber "Ration Integer" $ \n ->
-                  pure $ case n of
-                           D d -> toRational d
-                           I i -> fromIntegral i
-    {-# INLINE parseJSON #-}
-
-instance HasResolution a => ToJSON (Fixed a) where
-    toJSON = Number . realToFrac
-    {-# INLINE toJSON #-}
-
-instance HasResolution a => FromJSON (Fixed a) where
-    parseJSON (Number n) = pure $ case n of
-                                    D d -> realToFrac d
-                                    I i -> fromIntegral i
-    parseJSON v          = typeMismatch "Fixed" v
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Int where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Int where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-parseIntegral :: Integral a => Value -> Parser a
-parseIntegral = withNumber "Integral" $ pure . floor
-{-# INLINE parseIntegral #-}
-
-instance ToJSON Integer where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Integer where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Int8 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Int8 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Int16 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Int16 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Int32 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Int32 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Int64 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Int64 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Word where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Word where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Word8 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Word8 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Word16 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Word16 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Word32 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Word32 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Word64 where
-    toJSON = Number . fromIntegral
-    {-# INLINE toJSON #-}
-
-instance FromJSON Word64 where
-    parseJSON = parseIntegral
-    {-# INLINE parseJSON #-}
-
-instance ToJSON Text where
-    toJSON = String
-    {-# INLINE toJSON #-}
-
-instance FromJSON Text where
-    parseJSON = withText "Text" pure
-    {-# INLINE parseJSON #-}
-
-instance ToJSON LT.Text where
-    toJSON = String . LT.toStrict
-    {-# INLINE toJSON #-}
-
-instance FromJSON LT.Text where
-    parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a) => ToJSON [a] where
-    toJSON = Array . V.fromList . map toJSON
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a) => FromJSON [a] where
-    parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a) => ToJSON (Vector a) where
-    toJSON = Array . V.map toJSON
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a) => FromJSON (Vector a) where
-    parseJSON = withArray "Vector a" $ V.mapM parseJSON
-    {-# INLINE parseJSON #-}
-
-vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
-vectorToJSON = Array . V.map toJSON . V.convert
-{-# INLINE vectorToJSON #-}
-
-vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
-vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
-{-# INLINE vectorParseJSON #-}
-
-instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
-    toJSON = vectorToJSON
-
-instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
-    parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
-
-instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
-    toJSON = vectorToJSON
-
-instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
-    parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
-
-instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
-    toJSON = vectorToJSON
-
-instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
-    parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
-
-instance (ToJSON a) => ToJSON (Set.Set a) where
-    toJSON = toJSON . Set.toList
-    {-# INLINE toJSON #-}
-
-instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
-    parseJSON = fmap Set.fromList . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
-    toJSON = toJSON . HashSet.toList
-    {-# INLINE toJSON #-}
-
-instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
-    parseJSON = fmap HashSet.fromList . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance ToJSON IntSet.IntSet where
-    toJSON = toJSON . IntSet.toList
-    {-# INLINE toJSON #-}
-
-instance FromJSON IntSet.IntSet where
-    parseJSON = fmap IntSet.fromList . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance ToJSON a => ToJSON (IntMap.IntMap a) where
-    toJSON = toJSON . IntMap.toList
-    {-# INLINE toJSON #-}
-
-instance FromJSON a => FromJSON (IntMap.IntMap a) where
-    parseJSON = fmap IntMap.fromList . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON v) => ToJSON (M.Map Text v) where
-    toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty
-    {-# INLINE toJSON #-}
-
-instance (FromJSON v) => FromJSON (M.Map Text v) where
-    parseJSON = withObject "Map Text a" $
-                  fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
-
-instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
-    toJSON = Object . mapHashKeyVal LT.toStrict toJSON
-
-instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
-    parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON
-
-instance (ToJSON v) => ToJSON (M.Map String v) where
-    toJSON = Object . mapHashKeyVal pack toJSON
-
-instance (FromJSON v) => FromJSON (M.Map String v) where
-    parseJSON = fmap (hashMapKey unpack) . parseJSON
-
-instance (ToJSON v) => ToJSON (H.HashMap Text v) where
-    toJSON = Object . H.map toJSON
-    {-# INLINE toJSON #-}
-
-instance (FromJSON v) => FromJSON (H.HashMap Text v) where
-    parseJSON = withObject "HashMap Text a" $ traverse parseJSON
-
-instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
-    toJSON = Object . mapKeyVal LT.toStrict toJSON
-
-instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
-    parseJSON = fmap (mapKey LT.fromStrict) . parseJSON
-
-instance (ToJSON v) => ToJSON (H.HashMap String v) where
-    toJSON = Object . mapKeyVal pack toJSON
-
-instance (FromJSON v) => FromJSON (H.HashMap String v) where
-    parseJSON = fmap (mapKey unpack) . parseJSON
-
-instance ToJSON Value where
-    toJSON a = a
-    {-# INLINE toJSON #-}
-
-instance FromJSON Value where
-    parseJSON a = pure a
-    {-# INLINE parseJSON #-}
-
--- | A newtype wrapper for 'UTCTime' that uses the same non-standard
--- serialization format as Microsoft .NET, whose @System.DateTime@
--- type is by default serialized to JSON as in the following example:
---
--- > /Date(1302547608878)/
---
--- The number represents milliseconds since the Unix epoch.
-newtype DotNetTime = DotNetTime {
-      fromDotNetTime :: UTCTime
-    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
-
-instance ToJSON DotNetTime where
-    toJSON (DotNetTime t) =
-        String (pack (secs ++ msecs ++ ")/"))
-      where secs  = formatTime defaultTimeLocale "/Date(%s" t
-            msecs = take 3 $ formatTime defaultTimeLocale "%q" t
-    {-# INLINE toJSON #-}
-
-instance FromJSON DotNetTime where
-    parseJSON = withText "DotNetTime" $ \t ->
-        let (s,m) = T.splitAt (T.length t - 5) t
-            t'    = T.concat [s,".",m]
-        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
-             Just d -> pure (DotNetTime d)
-             _      -> fail "could not parse .NET time"
-    {-# INLINE parseJSON #-}
-
-instance ToJSON ZonedTime where
-    toJSON t = String $ pack $ formatTime defaultTimeLocale format t
-      where
-        format = "%FT%T" ++ milliseconds ++ tzFormat
-        milliseconds = take 4 $ formatTime defaultTimeLocale "%Q" t
-        tzFormat
-          | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"
-          | otherwise = "%z"
-
-instance FromJSON ZonedTime where
-    parseJSON (String t) =
-      tryFormats alternateFormats
-      <|> fail "could not parse ECMA-262 ISO-8601 date"
-      where
-        tryFormat f =
-          case parseTime defaultTimeLocale f (unpack t) of
-            Just d -> pure d
-            Nothing -> empty
-        tryFormats = foldr1 (<|>) . map tryFormat
-        alternateFormats =
-          dateTimeFmt defaultTimeLocale :
-          distributeList ["%Y", "%Y-%m", "%F"]
-                         ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
-
-        distributeList xs ys =
-          foldr (\x acc -> acc ++ distribute x ys) [] xs
-        distribute x = map (mappend x)
-
-    parseJSON v = typeMismatch "ZonedTime" v
-
-instance ToJSON UTCTime where
-    toJSON t = String (pack (take 23 str ++ "Z"))
-      where str = formatTime defaultTimeLocale "%FT%T%Q" t
-    {-# INLINE toJSON #-}
-
-instance FromJSON UTCTime where
-    parseJSON = withText "UTCTime" $ \t ->
-        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
-          Just d -> pure d
-          _      -> fail "could not parse ISO-8601 date"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
-    toJSON (a,b) = Array $ V.create $ do
-                     mv <- VM.unsafeNew 2
-                     VM.unsafeWrite mv 0 (toJSON a)
-                     VM.unsafeWrite mv 1 (toJSON b)
-                     return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
-    parseJSON = withArray "(a,b)" $ \ab ->
-        let n = V.length ab
-        in if n == 2
-             then (,) <$> parseJSON (V.unsafeIndex ab 0)
-                      <*> parseJSON (V.unsafeIndex ab 1)
-             else fail $ "cannot unpack array of length " ++
-                         show n ++ " into a pair"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
-    toJSON (a,b,c) = Array $ V.create $ do
-                       mv <- VM.unsafeNew 3
-                       VM.unsafeWrite mv 0 (toJSON a)
-                       VM.unsafeWrite mv 1 (toJSON b)
-                       VM.unsafeWrite mv 2 (toJSON c)
-                       return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
-    parseJSON = withArray "(a,b,c)" $ \abc ->
-        let n = V.length abc
-        in if n == 3
-             then (,,) <$> parseJSON (V.unsafeIndex abc 0)
-                       <*> parseJSON (V.unsafeIndex abc 1)
-                       <*> parseJSON (V.unsafeIndex abc 2)
-             else fail $ "cannot unpack array of length " ++
-                          show n ++ " into a 3-tuple"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
-    toJSON (a,b,c,d) = Array $ V.create $ do
-                         mv <- VM.unsafeNew 4
-                         VM.unsafeWrite mv 0 (toJSON a)
-                         VM.unsafeWrite mv 1 (toJSON b)
-                         VM.unsafeWrite mv 2 (toJSON c)
-                         VM.unsafeWrite mv 3 (toJSON d)
-                         return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
-    parseJSON = withArray "(a,b,c,d)" $ \abcd ->
-        let n = V.length abcd
-        in if n == 4
-             then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
-                        <*> parseJSON (V.unsafeIndex abcd 1)
-                        <*> parseJSON (V.unsafeIndex abcd 2)
-                        <*> parseJSON (V.unsafeIndex abcd 3)
-             else fail $ "cannot unpack array of length " ++
-                         show n ++ " into a 4-tuple"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a,b,c,d,e) where
-    toJSON (a,b,c,d,e) = Array $ V.create $ do
-                           mv <- VM.unsafeNew 5
-                           VM.unsafeWrite mv 0 (toJSON a)
-                           VM.unsafeWrite mv 1 (toJSON b)
-                           VM.unsafeWrite mv 2 (toJSON c)
-                           VM.unsafeWrite mv 3 (toJSON d)
-                           VM.unsafeWrite mv 4 (toJSON e)
-                           return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a,b,c,d,e) where
-    parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->
-        let n = V.length abcde
-        in if n == 5
-             then (,,,,) <$> parseJSON (V.unsafeIndex abcde 0)
-                         <*> parseJSON (V.unsafeIndex abcde 1)
-                         <*> parseJSON (V.unsafeIndex abcde 2)
-                         <*> parseJSON (V.unsafeIndex abcde 3)
-                         <*> parseJSON (V.unsafeIndex abcde 4)
-             else fail $ "cannot unpack array of length " ++
-                         show n ++ " into a 5-tuple"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a,b,c,d,e,f) where
-    toJSON (a,b,c,d,e,f) = Array $ V.create $ do
-                             mv <- VM.unsafeNew 6
-                             VM.unsafeWrite mv 0 (toJSON a)
-                             VM.unsafeWrite mv 1 (toJSON b)
-                             VM.unsafeWrite mv 2 (toJSON c)
-                             VM.unsafeWrite mv 3 (toJSON d)
-                             VM.unsafeWrite mv 4 (toJSON e)
-                             VM.unsafeWrite mv 5 (toJSON f)
-                             return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a,b,c,d,e,f) where
-    parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->
-        let n = V.length abcdef
-        in if n == 6
-             then (,,,,,) <$> parseJSON (V.unsafeIndex abcdef 0)
-                          <*> parseJSON (V.unsafeIndex abcdef 1)
-                          <*> parseJSON (V.unsafeIndex abcdef 2)
-                          <*> parseJSON (V.unsafeIndex abcdef 3)
-                          <*> parseJSON (V.unsafeIndex abcdef 4)
-                          <*> parseJSON (V.unsafeIndex abcdef 5)
-             else fail $ "cannot unpack array of length " ++
-                         show n ++ " into a 6-tuple"
-    {-# INLINE parseJSON #-}
-
-instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a,b,c,d,e,f,g) where
-    toJSON (a,b,c,d,e,f,g) = Array $ V.create $ do
-                               mv <- VM.unsafeNew 7
-                               VM.unsafeWrite mv 0 (toJSON a)
-                               VM.unsafeWrite mv 1 (toJSON b)
-                               VM.unsafeWrite mv 2 (toJSON c)
-                               VM.unsafeWrite mv 3 (toJSON d)
-                               VM.unsafeWrite mv 4 (toJSON e)
-                               VM.unsafeWrite mv 5 (toJSON f)
-                               VM.unsafeWrite mv 6 (toJSON g)
-                               return mv
-    {-# INLINE toJSON #-}
-
-instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where
-    parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->
-        let n = V.length abcdefg
-        in if n == 7
-             then (,,,,,,) <$> parseJSON (V.unsafeIndex abcdefg 0)
-                           <*> parseJSON (V.unsafeIndex abcdefg 1)
-                           <*> parseJSON (V.unsafeIndex abcdefg 2)
-                           <*> parseJSON (V.unsafeIndex abcdefg 3)
-                           <*> parseJSON (V.unsafeIndex abcdefg 4)
-                           <*> parseJSON (V.unsafeIndex abcdefg 5)
-                           <*> parseJSON (V.unsafeIndex abcdefg 6)
-             else fail $ "cannot unpack array of length " ++
-                         show n ++ " into a 7-tuple"
-    {-# INLINE parseJSON #-}
-
-instance ToJSON a => ToJSON (Dual a) where
-    toJSON = toJSON . getDual
-    {-# INLINE toJSON #-}
-
-instance FromJSON a => FromJSON (Dual a) where
-    parseJSON = fmap Dual . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance ToJSON a => ToJSON (First a) where
-    toJSON = toJSON . getFirst
-    {-# INLINE toJSON #-}
-
-instance FromJSON a => FromJSON (First a) where
-    parseJSON = fmap First . parseJSON
-    {-# INLINE parseJSON #-}
-
-instance ToJSON a => ToJSON (Last a) where
-    toJSON = toJSON . getLast
-    {-# INLINE toJSON #-}
-
-instance FromJSON a => FromJSON (Last a) where
-    parseJSON = fmap Last . parseJSON
-    {-# INLINE parseJSON #-}
-
--- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
---   and fails using @'typeMismatch' expected@ otherwise.
-withObject :: String -> (Object -> Parser a) -> Value -> Parser a
-withObject _        f (Object obj) = f obj
-withObject expected _ v            = typeMismatch expected v
-{-# INLINE withObject #-}
-
--- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
---   and fails using @'typeMismatch' expected@ otherwise.
-withText :: String -> (Text -> Parser a) -> Value -> Parser a
-withText _        f (String txt) = f txt
-withText expected _ v            = typeMismatch expected v
-{-# INLINE withText #-}
-
--- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
---   and fails using @'typeMismatch' expected@ otherwise.
-withArray :: String -> (Array -> Parser a) -> Value -> Parser a
-withArray _        f (Array arr) = f arr
-withArray expected _ v           = typeMismatch expected v
-{-# INLINE withArray #-}
-
--- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
---   and fails using @'typeMismatch' expected@ otherwise.
-withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
-withNumber _        f (Number num) = f num
-withNumber expected _ v            = typeMismatch expected v
-{-# INLINE withNumber #-}
-
--- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
---   and fails using @'typeMismatch' expected@ otherwise.
-withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
-withBool _        f (Bool arr) = f arr
-withBool expected _ v          = typeMismatch expected v
-{-# INLINE withBool #-}
-
--- | Construct a 'Pair' from a key and a value.
-(.=) :: ToJSON a => Text -> a -> Pair
-name .= value = (name, toJSON value)
-{-# INLINE (.=) #-}
-
--- | Convert a value from JSON, failing if the types do not match.
-fromJSON :: (FromJSON a) => Value -> Result a
-fromJSON = parse parseJSON
-{-# INLINE fromJSON #-}
-
--- | Retrieve the value associated with the given key of an 'Object'.
--- The result is 'empty' if the key is not present or the value cannot
--- be converted to the desired type.
---
--- This accessor is appropriate if the key and value /must/ be present
--- in an object for it to be valid.  If the key and value are
--- optional, use '(.:?)' instead.
-(.:) :: (FromJSON a) => Object -> Text -> Parser a
-obj .: key = case H.lookup key obj of
-               Nothing -> fail $ "key " ++ show key ++ " not present"
-               Just v  -> parseJSON v
-{-# INLINE (.:) #-}
-
--- | 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 accessor is most useful if the key and value can be absent
--- from an object without affecting its validity.  If the key and
--- value are mandatory, use '(.:)' instead.
-(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
-obj .:? key = case H.lookup key obj of
-               Nothing -> pure Nothing
-               Just v  -> parseJSON v
-{-# INLINE (.:?) #-}
-
--- | Helper for use in combination with '.:?' to provide default
--- values for optional JSON object fields.
---
--- This combinator is most useful if the key and value can be absent
--- from an object without affecting its validity and we know a default
--- value to assign in that case.  If the key and value are mandatory,
--- use '(.:)' instead.
---
--- Example usage:
---
--- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"
--- v2 <- o '.:'  \"mandatory_field\"
--- v3 <- o '.:?' \"opt_field2\"
--- @
-(.!=) :: Parser (Maybe a) -> a -> Parser a
-pmval .!= val = fromMaybe val <$> pmval
-{-# INLINE (.!=) #-}
-
--- | Fail parsing due to a type mismatch, with a descriptive message.
-typeMismatch :: String -- ^ The name of the type you are trying to parse.
-             -> Value  -- ^ The actual value encountered.
-             -> Parser a
-typeMismatch expected actual =
-    fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
-           " instead"
-  where
-    name = case actual of
-             Object _ -> "Object"
-             Array _  -> "Array"
-             String _ -> "String"
-             Number _ -> "Number"
-             Bool _   -> "Boolean"
-             Null     -> "Null"

Data/Aeson/Types/Generic.hs

 import Control.Applicative ((<*>), (<$>), (<|>), pure)
 import Control.Monad ((<=<))
 import Control.Monad.ST (ST)
-import Data.Aeson.Types.Class
+import Data.Aeson.Types.Instances
 import Data.Aeson.Types.Internal
 import Data.Bits
 import Data.DList (DList, toList, empty)

Data/Aeson/Types/Instances.hs

+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
+    GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
+    OverloadedStrings, UndecidableInstances, ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+#ifdef GENERICS
+{-# LANGUAGE DefaultSignatures #-}
+#endif
+
+-- |
+-- Module:      Data.Aeson.Types.Instances
+-- Copyright:   (c) 2011-2013 Bryan O'Sullivan
+--              (c) 2011 MailRank, Inc.
+-- License:     Apache
+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Types for working with JSON data.
+
+module Data.Aeson.Types.Instances
+    (
+    -- * Type classes
+    -- ** Core JSON classes
+      FromJSON(..)
+    , ToJSON(..)
+#ifdef GENERICS
+    -- ** Generic JSON classes
+    , GFromJSON(..)
+    , GToJSON(..)
+    , genericToJSON
+    , genericParseJSON
+#endif
+    -- * Types
+    , DotNetTime(..)
+
+      -- * Inspecting @'Value's@
+    , withObject
+    , withText
+    , withArray
+    , withNumber
+    , withScientific
+    , withBool
+
+    -- * Functions
+    , fromJSON
+    , (.:)
+    , (.:?)
+    , (.!=)
+    , (.=)
+    , typeMismatch
+    ) where
+
+import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
+import Data.Aeson.Functions
+import Data.Aeson.Types.Class
+import Data.Aeson.Types.Internal
+import Data.Scientific (Scientific)
+import qualified Data.Scientific as Scientific (coefficient, base10Exponent, fromFloatDigits)
+import Data.Attoparsec.Number (Number(..))
+import Data.Fixed
+import Data.Hashable (Hashable(..))
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Dual(..), First(..), Last(..), mappend)
+import Data.Ratio (Ratio, (%), numerator, denominator)
+import Data.Text (Text, pack, unpack)
+import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
+import Data.Time.Format (FormatTime, formatTime, parseTime)
+import Data.Traversable (traverse)
+import Data.Vector (Vector)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
+import Foreign.Storable (Storable)
+import System.Locale (defaultTimeLocale, dateTimeFmt)
+import qualified Data.HashMap.Strict as H
+import qualified Data.HashSet as HashSet
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import qualified Data.Map as M
+import qualified Data.Set as Set
+import qualified Data.Tree as Tree
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
+
+instance (ToJSON a) => ToJSON (Maybe a) where
+    toJSON (Just a) = toJSON a
+    toJSON Nothing  = Null
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a) => FromJSON (Maybe a) where
+    parseJSON Null   = pure Nothing
+    parseJSON a      = Just <$> parseJSON a
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
+    toJSON (Left a)  = object [left  .= a]
+    toJSON (Right b) = object [right .= b]
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
+    parseJSON (Object (H.toList -> [(key, value)]))
+        | key == left  = Left  <$> parseJSON value
+        | key == right = Right <$> parseJSON value
+    parseJSON _        = fail ""
+    {-# INLINE parseJSON #-}
+
+left, right :: Text
+left  = "Left"
+right = "Right"
+
+instance ToJSON Bool where
+    toJSON = Bool
+    {-# INLINE toJSON #-}
+
+instance FromJSON Bool where
+    parseJSON = withBool "Bool" pure
+    {-# INLINE parseJSON #-}
+
+instance ToJSON () where
+    toJSON _ = emptyArray
+    {-# INLINE toJSON #-}
+
+instance FromJSON () where
+    parseJSON = withArray "()" $ \v ->
+                  if V.null v
+                    then pure ()
+                    else fail "Expected an empty array"
+    {-# INLINE parseJSON #-}
+
+instance ToJSON [Char] where
+    toJSON = String . T.pack
+    {-# INLINE toJSON #-}
+
+instance FromJSON [Char] where
+    parseJSON = withText "String" $ pure . T.unpack
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Char where
+    toJSON = String . T.singleton
+    {-# INLINE toJSON #-}
+
+instance FromJSON Char where
+    parseJSON = withText "Char" $ \t ->
+                  if T.compareLength t 1 == EQ
+                    then pure $ T.head t
+                    else fail "Expected a string of length 1"
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Scientific where
+    toJSON = Number
+    {-# INLINE toJSON #-}
+
+instance FromJSON Scientific where
+    parseJSON = withScientific "Scientific" pure
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Double where
+    toJSON = realFloatToJSON
+    {-# INLINE toJSON #-}
+
+realFloatToJSON :: RealFloat a => a -> Value
+realFloatToJSON d
+    | isNaN d || isInfinite d = Null
+    | otherwise = Number $ Scientific.fromFloatDigits d
+{-# INLINE realFloatToJSON #-}
+
+instance FromJSON Double where
+    parseJSON (Number s) = pure $ realToFrac s
+    parseJSON Null       = pure (0/0)
+    parseJSON v          = typeMismatch "Double" v
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Number where
+    toJSON (D d) = toJSON d
+    toJSON (I i) = toJSON i
+    {-# INLINE toJSON #-}
+
+instance FromJSON Number where
+    parseJSON (Number s) = pure $ scientificToNumber s
+    parseJSON Null       = pure (D (0/0))
+    parseJSON v          = typeMismatch "Number" v
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Float where
+    toJSON = realFloatToJSON
+    {-# INLINE toJSON #-}
+
+instance FromJSON Float where
+    parseJSON (Number s) = pure $ realToFrac s
+    parseJSON Null       = pure (0/0)
+    parseJSON v          = typeMismatch "Float" v
+    {-# INLINE parseJSON #-}
+
+instance ToJSON (Ratio Integer) where
+    toJSON r = object [ "numerator"   .= numerator   r
+                      , "denominator" .= denominator r
+                      ]
+    {-# INLINE toJSON #-}
+
+instance FromJSON (Ratio Integer) where
+    parseJSON = withObject "Rational" $ \obj ->
+                  (%) <$> obj .: "numerator"
+                      <*> obj .: "denominator"
+    {-# INLINE parseJSON #-}
+
+instance HasResolution a => ToJSON (Fixed a) where
+    toJSON = Number . realToFrac
+    {-# INLINE toJSON #-}
+
+instance HasResolution a => FromJSON (Fixed a) where
+    parseJSON = withScientific "Fixed" $ pure . realToFrac
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Int where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+parseIntegral :: Integral a => Value -> Parser a
+parseIntegral = withScientific "Integral" $ pure . floor
+{-# INLINE parseIntegral #-}
+
+instance ToJSON Integer where
+    toJSON = Number . fromInteger
+    {-# INLINE toJSON #-}
+
+instance FromJSON Integer where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Int8 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int8 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Int16 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int16 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Int32 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int32 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Int64 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Int64 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Word where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Word8 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word8 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Word16 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word16 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Word32 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word32 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Word64 where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+instance FromJSON Word64 where
+    parseJSON = parseIntegral
+    {-# INLINE parseJSON #-}
+
+instance ToJSON Text where
+    toJSON = String
+    {-# INLINE toJSON #-}
+
+instance FromJSON Text where
+    parseJSON = withText "Text" pure
+    {-# INLINE parseJSON #-}
+
+instance ToJSON LT.Text where
+    toJSON = String . LT.toStrict
+    {-# INLINE toJSON #-}
+
+instance FromJSON LT.Text where
+    parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a) => ToJSON [a] where
+    toJSON = Array . V.fromList . map toJSON
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a) => FromJSON [a] where
+    parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a) => ToJSON (Vector a) where
+    toJSON = Array . V.map toJSON
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a) => FromJSON (Vector a) where
+    parseJSON = withArray "Vector a" $ V.mapM parseJSON
+    {-# INLINE parseJSON #-}
+
+vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
+vectorToJSON = Array . V.map toJSON . V.convert
+{-# INLINE vectorToJSON #-}
+
+vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
+{-# INLINE vectorParseJSON #-}
+
+instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
+    toJSON = vectorToJSON
+
+instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
+    parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
+
+instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
+    toJSON = vectorToJSON
+
+instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
+    parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
+
+instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
+    toJSON = vectorToJSON
+
+instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
+    parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
+
+instance (ToJSON a) => ToJSON (Set.Set a) where
+    toJSON = toJSON . Set.toList
+    {-# INLINE toJSON #-}
+
+instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
+    parseJSON = fmap Set.fromList . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
+    toJSON = toJSON . HashSet.toList
+    {-# INLINE toJSON #-}
+
+instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
+    parseJSON = fmap HashSet.fromList . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance ToJSON IntSet.IntSet where
+    toJSON = toJSON . IntSet.toList
+    {-# INLINE toJSON #-}
+
+instance FromJSON IntSet.IntSet where
+    parseJSON = fmap IntSet.fromList . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance ToJSON a => ToJSON (IntMap.IntMap a) where
+    toJSON = toJSON . IntMap.toList
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (IntMap.IntMap a) where
+    parseJSON = fmap IntMap.fromList . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON v) => ToJSON (M.Map Text v) where
+    toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty
+    {-# INLINE toJSON #-}
+
+instance (FromJSON v) => FromJSON (M.Map Text v) where
+    parseJSON = withObject "Map Text a" $
+                  fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
+
+instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
+    toJSON = Object . mapHashKeyVal LT.toStrict toJSON
+
+instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
+    parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON
+
+instance (ToJSON v) => ToJSON (M.Map String v) where
+    toJSON = Object . mapHashKeyVal pack toJSON
+
+instance (FromJSON v) => FromJSON (M.Map String v) where
+    parseJSON = fmap (hashMapKey unpack) . parseJSON
+
+instance (ToJSON v) => ToJSON (H.HashMap Text v) where
+    toJSON = Object . H.map toJSON
+    {-# INLINE toJSON #-}
+
+instance (FromJSON v) => FromJSON (H.HashMap Text v) where
+    parseJSON = withObject "HashMap Text a" $ traverse parseJSON
+
+instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
+    toJSON = Object . mapKeyVal LT.toStrict toJSON
+
+instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
+    parseJSON = fmap (mapKey LT.fromStrict) . parseJSON
+
+instance (ToJSON v) => ToJSON (H.HashMap String v) where
+    toJSON = Object . mapKeyVal pack toJSON
+
+instance (FromJSON v) => FromJSON (H.HashMap String v) where
+    parseJSON = fmap (mapKey unpack) . parseJSON
+
+instance (ToJSON v) => ToJSON (Tree.Tree v) where
+    toJSON (Tree.Node root branches) = toJSON (root,branches)
+
+instance (FromJSON v) => FromJSON (Tree.Tree v) where
+    parseJSON j = uncurry Tree.Node <$> parseJSON j
+
+instance ToJSON Value where
+    toJSON a = a
+    {-# INLINE toJSON #-}
+
+instance FromJSON Value where
+    parseJSON a = pure a
+    {-# INLINE parseJSON #-}
+
+instance ToJSON DotNetTime where
+    toJSON (DotNetTime t) =
+        String (pack (secs ++ formatMillis t ++ ")/"))
+      where secs  = formatTime defaultTimeLocale "/Date(%s" t
+    {-# INLINE toJSON #-}
+
+instance FromJSON DotNetTime where
+    parseJSON = withText "DotNetTime" $ \t ->
+        let (s,m) = T.splitAt (T.length t - 5) t
+            t'    = T.concat [s,".",m]
+        in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
+             Just d -> pure (DotNetTime d)
+             _      -> fail "could not parse .NET time"
+    {-# INLINE parseJSON #-}
+
+instance ToJSON ZonedTime where
+    toJSON t = String $ pack $ formatTime defaultTimeLocale format t
+      where
+        format = "%FT%T." ++ formatMillis t ++ tzFormat
+        tzFormat
+          | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"
+          | otherwise = "%z"
+
+formatMillis :: (FormatTime t) => t -> String
+formatMillis t = take 3 . formatTime defaultTimeLocale "%q" $ t
+
+instance FromJSON ZonedTime where
+    parseJSON (String t) =
+      tryFormats alternateFormats
+      <|> fail "could not parse ECMA-262 ISO-8601 date"
+      where
+        tryFormat f =
+          case parseTime defaultTimeLocale f (unpack t) of
+            Just d -> pure d
+            Nothing -> empty
+        tryFormats = foldr1 (<|>) . map tryFormat
+        alternateFormats =
+          dateTimeFmt defaultTimeLocale :
+          distributeList ["%Y", "%Y-%m", "%F"]
+                         ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
+
+        distributeList xs ys =
+          foldr (\x acc -> acc ++ distribute x ys) [] xs
+        distribute x = map (mappend x)
+
+    parseJSON v = typeMismatch "ZonedTime" v
+
+instance ToJSON UTCTime where
+    toJSON t = String (pack (str ++ z : "Z"))
+      where (str,(x:y:_)) = splitAt 22 $
+                            formatTime defaultTimeLocale "%FT%T.%q" t
+            z | y < '5'   = x
+              | otherwise = succ x
+    {-# INLINE toJSON #-}
+
+instance FromJSON UTCTime where
+    parseJSON = withText "UTCTime" $ \t ->
+        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
+          Just d -> pure d
+          _      -> fail "could not parse ISO-8601 date"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
+    toJSON (a,b) = Array $ V.create $ do
+                     mv <- VM.unsafeNew 2
+                     VM.unsafeWrite mv 0 (toJSON a)
+                     VM.unsafeWrite mv 1 (toJSON b)
+                     return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
+    parseJSON = withArray "(a,b)" $ \ab ->
+        let n = V.length ab
+        in if n == 2
+             then (,) <$> parseJSON (V.unsafeIndex ab 0)
+                      <*> parseJSON (V.unsafeIndex ab 1)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a pair"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
+    toJSON (a,b,c) = Array $ V.create $ do
+                       mv <- VM.unsafeNew 3
+                       VM.unsafeWrite mv 0 (toJSON a)
+                       VM.unsafeWrite mv 1 (toJSON b)
+                       VM.unsafeWrite mv 2 (toJSON c)
+                       return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
+    parseJSON = withArray "(a,b,c)" $ \abc ->
+        let n = V.length abc
+        in if n == 3
+             then (,,) <$> parseJSON (V.unsafeIndex abc 0)
+                       <*> parseJSON (V.unsafeIndex abc 1)
+                       <*> parseJSON (V.unsafeIndex abc 2)
+             else fail $ "cannot unpack array of length " ++
+                          show n ++ " into a 3-tuple"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+    toJSON (a,b,c,d) = Array $ V.create $ do
+                         mv <- VM.unsafeNew 4
+                         VM.unsafeWrite mv 0 (toJSON a)
+                         VM.unsafeWrite mv 1 (toJSON b)
+                         VM.unsafeWrite mv 2 (toJSON c)
+                         VM.unsafeWrite mv 3 (toJSON d)
+                         return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
+    parseJSON = withArray "(a,b,c,d)" $ \abcd ->
+        let n = V.length abcd
+        in if n == 4
+             then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
+                        <*> parseJSON (V.unsafeIndex abcd 1)
+                        <*> parseJSON (V.unsafeIndex abcd 2)
+                        <*> parseJSON (V.unsafeIndex abcd 3)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a 4-tuple"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a,b,c,d,e) where
+    toJSON (a,b,c,d,e) = Array $ V.create $ do
+                           mv <- VM.unsafeNew 5
+                           VM.unsafeWrite mv 0 (toJSON a)
+                           VM.unsafeWrite mv 1 (toJSON b)
+                           VM.unsafeWrite mv 2 (toJSON c)
+                           VM.unsafeWrite mv 3 (toJSON d)
+                           VM.unsafeWrite mv 4 (toJSON e)
+                           return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a,b,c,d,e) where
+    parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->
+        let n = V.length abcde
+        in if n == 5
+             then (,,,,) <$> parseJSON (V.unsafeIndex abcde 0)
+                         <*> parseJSON (V.unsafeIndex abcde 1)
+                         <*> parseJSON (V.unsafeIndex abcde 2)
+                         <*> parseJSON (V.unsafeIndex abcde 3)
+                         <*> parseJSON (V.unsafeIndex abcde 4)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a 5-tuple"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a,b,c,d,e,f) where
+    toJSON (a,b,c,d,e,f) = Array $ V.create $ do
+                             mv <- VM.unsafeNew 6
+                             VM.unsafeWrite mv 0 (toJSON a)
+                             VM.unsafeWrite mv 1 (toJSON b)
+                             VM.unsafeWrite mv 2 (toJSON c)
+                             VM.unsafeWrite mv 3 (toJSON d)
+                             VM.unsafeWrite mv 4 (toJSON e)
+                             VM.unsafeWrite mv 5 (toJSON f)
+                             return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a,b,c,d,e,f) where
+    parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->
+        let n = V.length abcdef
+        in if n == 6
+             then (,,,,,) <$> parseJSON (V.unsafeIndex abcdef 0)
+                          <*> parseJSON (V.unsafeIndex abcdef 1)
+                          <*> parseJSON (V.unsafeIndex abcdef 2)
+                          <*> parseJSON (V.unsafeIndex abcdef 3)
+                          <*> parseJSON (V.unsafeIndex abcdef 4)
+                          <*> parseJSON (V.unsafeIndex abcdef 5)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a 6-tuple"
+    {-# INLINE parseJSON #-}
+
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a,b,c,d,e,f,g) where
+    toJSON (a,b,c,d,e,f,g) = Array $ V.create $ do
+                               mv <- VM.unsafeNew 7
+                               VM.unsafeWrite mv 0 (toJSON a)
+                               VM.unsafeWrite mv 1 (toJSON b)
+                               VM.unsafeWrite mv 2 (toJSON c)
+                               VM.unsafeWrite mv 3 (toJSON d)
+                               VM.unsafeWrite mv 4 (toJSON e)
+                               VM.unsafeWrite mv 5 (toJSON f)
+                               VM.unsafeWrite mv 6 (toJSON g)
+                               return mv
+    {-# INLINE toJSON #-}
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where
+    parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->
+        let n = V.length abcdefg
+        in if n == 7
+             then (,,,,,,) <$> parseJSON (V.unsafeIndex abcdefg 0)
+                           <*> parseJSON (V.unsafeIndex abcdefg 1)
+                           <*> parseJSON (V.unsafeIndex abcdefg 2)
+                           <*> parseJSON (V.unsafeIndex abcdefg 3)
+                           <*> parseJSON (V.unsafeIndex abcdefg 4)
+                           <*> parseJSON (V.unsafeIndex abcdefg 5)
+                           <*> parseJSON (V.unsafeIndex abcdefg 6)
+             else fail $ "cannot unpack array of length " ++
+                         show n ++ " into a 7-tuple"
+    {-# INLINE parseJSON #-}
+
+instance ToJSON a => ToJSON (Dual a) where
+    toJSON = toJSON . getDual
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (Dual a) where
+    parseJSON = fmap Dual . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance ToJSON a => ToJSON (First a) where
+    toJSON = toJSON . getFirst
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (First a) where
+    parseJSON = fmap First . parseJSON
+    {-# INLINE parseJSON #-}
+
+instance ToJSON a => ToJSON (Last a) where
+    toJSON = toJSON . getLast
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (Last a) where
+    parseJSON = fmap Last . parseJSON
+    {-# INLINE parseJSON #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withObject :: String -> (Object -> Parser a) -> Value -> Parser a
+withObject _        f (Object obj) = f obj
+withObject expected _ v            = typeMismatch expected v
+{-# INLINE withObject #-}
+
+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withText :: String -> (Text -> Parser a) -> Value -> Parser a
+withText _        f (String txt) = f txt
+withText expected _ v            = typeMismatch expected v
+{-# INLINE withText #-}
+
+-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withArray :: String -> (Array -> Parser a) -> Value -> Parser a
+withArray _        f (Array arr) = f arr
+withArray expected _ v           = typeMismatch expected v
+{-# INLINE withArray #-}
+
+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.
+--   and fails using @'typeMismatch' expected@ otherwise.
+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
+withNumber expected f = withScientific expected (f . scientificToNumber)
+{-# INLINE withNumber #-}
+{-# DEPRECATED withNumber "Use withScientific instead" #-}
+
+-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.
+--   and fails using @'typeMismatch' expected@ otherwise.
+withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
+withScientific _        f (Number scientific) = f scientific
+withScientific expected _ v                   = typeMismatch expected v
+{-# INLINE withScientific #-}
+
+-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
+--   and fails using @'typeMismatch' expected@ otherwise.
+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
+withBool _        f (Bool arr) = f arr
+withBool expected _ v          = typeMismatch expected v
+{-# INLINE withBool #-}
+
+-- | Construct a 'Pair' from a key and a value.
+(.=) :: ToJSON a => Text -> a -> Pair
+name .= value = (name, toJSON value)
+{-# INLINE (.=) #-}
+
+-- | Convert a value from JSON, failing if the types do not match.
+fromJSON :: (FromJSON a) => Value -> Result a
+fromJSON = parse parseJSON
+{-# INLINE fromJSON #-}
+
+-- | Retrieve the value associated with the given key of an 'Object'.
+-- The result is 'empty' if the key is not present or the value cannot
+-- be converted to the desired type.
+--
+-- This accessor is appropriate if the key and value /must/ be present
+-- in an object for it to be valid.  If the key and value are
+-- optional, use '(.:?)' instead.
+(.:) :: (FromJSON a) => Object -> Text -> Parser a
+obj .: key = case H.lookup key obj of
+               Nothing -> fail $ "key " ++ show key ++ " not present"
+               Just v  -> parseJSON v
+{-# INLINE (.:) #-}
+
+-- | 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 accessor is most useful if the key and value can be absent
+-- from an object without affecting its validity.  If the key and
+-- value are mandatory, use '(.:)' instead.
+(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
+obj .:? key = case H.lookup key obj of
+               Nothing -> pure Nothing
+               Just v  -> parseJSON v
+{-# INLINE (.:?) #-}
+
+-- | Helper for use in combination with '.:?' to provide default
+-- values for optional JSON object fields.
+--
+-- This combinator is most useful if the key and value can be absent
+-- from an object without affecting its validity and we know a default
+-- value to assign in that case.  If the key and value are mandatory,
+-- use '(.:)' instead.
+--
+-- Example usage:
+--
+-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"
+-- v2 <- o '.:'  \"mandatory_field\"
+-- v3 <- o '.:?' \"opt_field2\"
+-- @
+(.!=) :: Parser (Maybe a) -> a -> Parser a
+pmval .!= val = fromMaybe val <$> pmval
+{-# INLINE (.!=) #-}
+
+-- | Fail parsing due to a type mismatch, with a descriptive message.
+typeMismatch :: String -- ^ The name of the type you are trying to parse.
+             -> Value  -- ^ The actual value encountered.
+             -> Parser a
+typeMismatch expected actual =
+    fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
+           " instead"
+  where
+    name = case actual of
+             Object _ -> "Object"
+             Array _  -> "Array"
+             String _ -> "String"
+             Number _ -> "Number"
+             Bool _   -> "Boolean"
+             Null     -> "Null"
+
+scientificToNumber :: Scientific -> Number
+scientificToNumber s
+    | e < 0     = D $ realToFrac s
+    | otherwise = I $ c * 10 ^ e
+  where
+    e = Scientific.base10Exponent s
+    c = Scientific.coefficient s
+{-# INLINE scientificToNumber #-}

Data/Aeson/Types/Internal.hs

-{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types #-}
 
 -- |
 -- Module:      Data.Aeson.Types.Internal
     , defaultOptions
     , defaultTaggedObject
 
-    -- Used for changing CamelCase names into something else.
+    -- * Used for changing CamelCase names into something else.
     , camelTo
+
+    -- * Other types
+    , DotNetTime(..)
     ) where
 
+
 import Control.Applicative
 import Control.Monad
-import Control.DeepSeq        ( NFData(..) )
-import Data.Attoparsec.Char8  ( Number(..) )
-import Data.Char              ( isUpper, toLower )
-import Data.Hashable          ( Hashable(..) )
-import Data.HashMap.Strict    ( HashMap )
-import Data.Monoid            ( Monoid(..) )
-import Data.String            ( IsString(..) )
-import Data.Text              ( Text, pack )
-import Data.Typeable          ( Typeable )
-import Data.Vector            ( Vector )
+import Control.DeepSeq (NFData(..))
+import Data.Char (toLower, isUpper)
+import Data.Scientific (Scientific)
+import Data.Hashable (Hashable(..))
+import Data.HashMap.Strict (HashMap)
+import Data.Monoid (Monoid(..))
+import Data.String (IsString(..))
+import Data.Text (Text, pack)
+import Data.Time (UTCTime)
+import Data.Time.Format (FormatTime)
+import Data.Typeable (Typeable)
+import Data.Vector (Vector)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Vector as V
 
 data Value = Object !Object
            | Array !Array
            | String !Text
-           | Number !Number
+           | Number !Scientific
            | Bool !Bool
            | Null
              deriving (Eq, Show, Typeable)
 
+-- | A newtype wrapper for 'UTCTime' that uses the same non-standard
+-- serialization format as Microsoft .NET, whose @System.DateTime@
+-- type is by default serialized to JSON as in the following example:
+--
+-- > /Date(1302547608878)/
+--
+-- The number represents milliseconds since the Unix epoch.
+newtype DotNetTime = DotNetTime {
+      fromDotNetTime :: UTCTime
+    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
+
 instance NFData Value where
     rnf (Object o) = rnf o
     rnf (Array a)  = V.foldl' (\x y -> rnf y `seq` x) () a
     rnf (String s) = rnf s
-    rnf (Number n) = case n of I i -> rnf i; D d -> rnf d
+    rnf (Number n) = rnf n
     rnf (Bool b)   = rnf b
     rnf Null       = ()
 
     hashWithSalt s (Array a)    = V.foldl' hashWithSalt
                                   (s `hashWithSalt` (1::Int)) a
     hashWithSalt s (String str) = s `hashWithSalt` (2::Int) `hashWithSalt` str
-    hashWithSalt s (Number n)   = 3 `hashWithSalt`
-                                  case n of I i -> hashWithSalt s i
-                                            D d -> hashWithSalt s d
-    hashWithSalt s (Bool b)   = s `hashWithSalt` (4::Int) `hashWithSalt` b
-    hashWithSalt s Null       = s `hashWithSalt` (5::Int)
+    hashWithSalt s (Number n)   = s `hashWithSalt` (3::Int) `hashWithSalt` n
+    hashWithSalt s (Bool b)     = s `hashWithSalt` (4::Int) `hashWithSalt` b
+    hashWithSalt s Null         = s `hashWithSalt` (5::Int)
 
 -- | The empty array.
 emptyArray :: Value
     To get started, see the documentation for the @Data.Aeson@ module
     below.
     .
-    For release notes, see
-    <https://github.com/bos/aeson/blob/master/release-notes.markdown>
-    .
     Parsing performance on a late 2010 MacBook Pro (2.66GHz Core i7),
     for mostly-English tweets from Twitter's JSON search API:
     .
     benchmarks/*.py
     benchmarks/Makefile
     benchmarks/json-data/*.json
+    changelog
     examples/*.hs
-    release-notes.markdown
 
 flag developer
   description: operate in developer mode
     Data.Aeson.Functions
     Data.Aeson.Parser.Internal
     Data.Aeson.Types.Class
+    Data.Aeson.Types.Instances
     Data.Aeson.Types.Internal
 
   if impl(ghc >= 7.2.1)
     text >= 0.11.1.0,
     time,
     unordered-containers >= 0.1.3.0,
-    vector >= 0.7.1
+    vector >= 0.7.1,
+    scientific >= 0.1
 
   if flag(blaze-builder)
     build-depends: blaze-builder >= 0.2.1.4
   type:           exitcode-stdio-1.0
   hs-source-dirs: tests
   main-is:        Properties.hs
-  other-modules:  Functions
-                  Instances
-                  Types
-                  Options
-                  Encoders
-                  Properties.Deprecated
+  other-modules:
+    Encoders
+    Functions
+    Instances
+    Options
+    Properties.Deprecated
+    Types
 
   ghc-options:
     -Wall -threaded -rtsopts

benchmarks/AesonEncode.hs

 import Control.Exception
 import Control.Monad
 import Data.Aeson
-import Data.Attoparsec
+import Data.Attoparsec (IResult(..), parseWith)
 import Data.Time.Clock
 import System.Environment (getArgs)
 import System.IO

benchmarks/AesonParse.hs

 import Control.Exception
 import Control.Monad
 import Data.Aeson
-import Data.Attoparsec
+import Data.Attoparsec (IResult(..), parseWith)
 import Data.Time.Clock
 import System.Environment (getArgs)
 import System.IO
 import qualified Data.ByteString as B
 
+main :: IO ()
 main = do
   (bs:cnt:args) <- getArgs
   let count = read cnt :: Int
           let refill = B.hGet h blkSize
           result <- parseWith refill json =<< refill
           case result of
-            Done _ r -> loop (good+1) bad
+            Done _ _ -> loop (good+1) bad
             _        -> loop good (bad+1)
     (good, _) <- loop 0 0
     delta <- flip diffUTCTime start `fmap` getCurrentTime
     putStrLn $ "  " ++ show good ++ " good, " ++ show delta
     let rate = fromIntegral count / realToFrac delta :: Double
-    putStrLn $ "  " ++ show (round rate) ++ " per second"
+    putStrLn $ "  " ++ show (round rate :: Int) ++ " per second"