Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

Conflicts:
	Data/Aeson/Types/Internal.hs
  • Loading branch information...
commit 3d8b167ee51ee28f5c6511d84608193b956d05fc 2 parents c7972e1 + ce36f22
@gabrielmc gabrielmc authored
View
2  .gitignore
@@ -8,3 +8,5 @@ cabal.sandbox.config
benchmarks/AesonEncode
tests/qc
+
+cabal.sandbox.config
View
3  .hgignore
@@ -4,7 +4,8 @@
^tests/(?:qc)
syntax: glob
-cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
*~
.*.swp
.\#*
View
1  .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
View
16 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
View
155 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,7 +222,7 @@ 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
@@ -210,7 +230,7 @@ unescape = toByteString <$> go mempty where
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
View
6 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
View
3  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
View
741 Data/Aeson/Types/Class.hs
@@ -1,7 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
- GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
- OverloadedStrings, UndecidableInstances, ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP, FlexibleContexts #-}
#ifdef GENERICS
{-# LANGUAGE DefaultSignatures #-}
@@ -9,7 +6,7 @@
-- |
-- 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>
@@ -31,58 +28,9 @@ module Data.Aeson.Types.Class
, 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
@@ -242,688 +190,3 @@ class FromJSON a where
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"
View
2  Data/Aeson/Types/Generic.hs
@@ -22,7 +22,7 @@ module Data.Aeson.Types.Generic ( ) where
import Control.Applicative ((<*>), (<$>), (<|>), pure)
import Control.Monad ((<=<))
import Control.Monad.ST (ST)
-import Data.Aeson.Types.Class
+import Data.Aeson.Types.Instances
import Data.Aeson.Types.Internal
import Data.Bits
import Data.DList (DList, toList, empty)
View
798 Data/Aeson/Types/Instances.hs
@@ -0,0 +1,798 @@
+{-# 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 #-}
View
53 Data/Aeson/Types/Internal.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types #-}
-- |
-- Module: Data.Aeson.Types.Internal
@@ -36,22 +36,28 @@ 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
@@ -170,16 +176,27 @@ type Array = Vector Value
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 = ()
@@ -193,11 +210,9 @@ instance Hashable Value where
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
View
22 aeson.cabal
@@ -21,9 +21,6 @@ description:
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:
.
@@ -84,8 +81,8 @@ extra-source-files:
benchmarks/*.py
benchmarks/Makefile
benchmarks/json-data/*.json
+ changelog
examples/*.hs
- release-notes.markdown
flag developer
description: operate in developer mode
@@ -108,6 +105,7 @@ library
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)
@@ -130,7 +128,8 @@ library
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
@@ -148,12 +147,13 @@ test-suite tests
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
View
2  benchmarks/AesonEncode.hs
@@ -3,7 +3,7 @@
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
View
7 benchmarks/AesonParse.hs
@@ -3,12 +3,13 @@
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