diff --git a/Data/Aeson.hs b/Data/Aeson.hs --- a/Data/Aeson.hs +++ b/Data/Aeson.hs @@ -1,8 +1,9 @@ -- | -- Module: Data.Aeson --- Copyright: (c) 2011 MailRank, Inc. +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. -- License: Apache --- Maintainer: Bryan O'Sullivan +-- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- @@ -12,8 +13,12 @@ module Data.Aeson ( + -- * Encoding and decoding + decode + , decode' + , encode -- * Core JSON types - Value(..) + , Value(..) , Array , Object -- * Convenience types @@ -27,12 +32,34 @@ , (.=) , (.:) , (.:?) + , (.!=) , object - -- * Encoding and parsing - , encode + -- * Parsing , json + , json' ) where -import Data.Aeson.Encode -import Data.Aeson.Parser +import Data.Aeson.Encode (encode) +import Data.Aeson.Parser.Internal (decodeWith, json, json') import Data.Aeson.Types +import qualified Data.ByteString.Lazy as L + +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- This function parses immediately, but defers conversion. See +-- 'json' for details. +decode :: (FromJSON a) => L.ByteString -> Maybe a +decode = decodeWith json fromJSON +{-# INLINE decode #-} + +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- This function parses and performs conversion immediately. See +-- 'json'' for details. +decode' :: (FromJSON a) => L.ByteString -> Maybe a +decode' = decodeWith json' fromJSON +{-# INLINE decode' #-} diff --git a/Data/Aeson/Encode.hs b/Data/Aeson/Encode.hs --- a/Data/Aeson/Encode.hs +++ b/Data/Aeson/Encode.hs @@ -4,7 +4,7 @@ -- Module: Data.Aeson.Encode -- Copyright: (c) 2011 MailRank, Inc. -- License: Apache --- Maintainer: Bryan O'Sullivan +-- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- @@ -25,7 +25,7 @@ import Numeric (showHex) import Blaze.Text (double, integral) import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as M +import qualified Data.HashMap.Strict as H import qualified Data.Text as T import qualified Data.Vector as V @@ -42,7 +42,7 @@ V.foldr f (fromChar ']') (V.unsafeTail v) where f a z = fromChar ',' `mappend` fromValue a `mappend` z fromValue (Object m) = - case M.toList m of + case H.toList m of (x:xs) -> fromChar '{' `mappend` one x `mappend` foldr f (fromChar '}') xs diff --git a/Data/Aeson/Functions.hs b/Data/Aeson/Functions.hs --- a/Data/Aeson/Functions.hs +++ b/Data/Aeson/Functions.hs @@ -1,15 +1,23 @@ +-- | +-- Module: Data.Aeson.Functions +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable + module Data.Aeson.Functions - ( - hashMap - , mapHash - , transformMap + ( mapHashKeyVal + , hashMapKey + , mapKeyVal + , mapKey -- * String conversions , decode , strict , lazy ) where -import Control.Arrow ((***), first) import Data.Hashable (Hashable) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -18,23 +26,28 @@ import qualified Data.HashMap.Strict as H import qualified Data.Map as M --- | Transform one map into another. The ordering of keys must be --- preserved by the key transformation function. -transformMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2) - -> M.Map k1 v1 -> M.Map k2 v2 -transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList -{-# INLINE transformMap #-} +-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys. +mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2) + -> M.Map k1 v1 -> H.HashMap k2 v2 +mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty +{-# INLINE mapHashKeyVal #-} --- | Transform a 'H.HashMap' into a 'M.Map'. -hashMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2) - -> H.HashMap k1 v1 -> M.Map k2 v2 -hashMap fk kv = M.fromList . map (fk *** kv) . H.toList -{-# INLINE hashMap #-} +-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys. +hashMapKey :: (Ord k2) => (k1 -> k2) + -> H.HashMap k1 v -> M.Map k2 v +hashMapKey kv = H.foldrWithKey (M.insert . kv) M.empty +{-# INLINE hashMapKey #-} --- | Transform a 'M.Map' into a 'H.HashMap'. -mapHash :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.Map k1 v -> H.HashMap k2 v -mapHash fk = H.fromList . map (first fk) . M.toList -{-# INLINE mapHash #-} +-- | Transform the keys and values of a 'H.HashMap'. +mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2) + -> H.HashMap k1 v1 -> H.HashMap k2 v2 +mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty +{-# INLINE mapKeyVal #-} + +-- | Transform the keys of a 'H.HashMap'. +mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> H.HashMap k1 v -> H.HashMap k2 v +mapKey fk = mapKeyVal fk id +{-# INLINE mapKey #-} strict :: L.ByteString -> Text strict = decode . B.concat . L.toChunks diff --git a/Data/Aeson/Generic.hs b/Data/Aeson/Generic.hs --- a/Data/Aeson/Generic.hs +++ b/Data/Aeson/Generic.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards, Rank2Types, ScopedTypeVariables #-} -- | -- Module: Data.Aeson.Generic --- Copyright: (c) 2011 MailRank, Inc. +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. -- (c) 2008, 2009 Lennart Augustsson -- License: BSD3 --- Maintainer: Bryan O'Sullivan +-- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- @@ -16,15 +17,352 @@ module Data.Aeson.Generic ( - fromJSON + -- * Decoding and encoding + decode + , decode' + , encode + -- * Lower-level conversion functions + , fromJSON , toJSON ) where -import Data.Aeson.Types (Value, Result, genericFromJSON, genericToJSON) -import Data.Data (Data) +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Monad.State.Strict +import Data.Aeson.Functions hiding (decode) +import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON) +import Data.Attoparsec.Number (Number) +import Data.Generics +import Data.Hashable (Hashable) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.IntSet (IntSet) +import Data.Maybe (fromJust) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Aeson.Parser.Internal (decodeWith, json, json') +import qualified Data.Aeson.Encode as E +import qualified Data.Aeson.Functions as F +import qualified Data.Aeson.Types as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as H +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as DT +import qualified Data.Text.Lazy as LT +import qualified Data.Traversable as T +import qualified Data.Vector as V -fromJSON :: (Data a) => Value -> Result a -fromJSON = genericFromJSON +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'. +encode :: (Data a) => a -> L.ByteString +encode = E.encode . toJSON +{-# INLINE encode #-} +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- This function parses immediately, but defers conversion. See +-- 'json' for details. +decode :: (Data a) => L.ByteString -> Maybe a +decode = decodeWith json fromJSON +{-# INLINE decode #-} + +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- This function parses and performs conversion immediately. See +-- 'json'' for details. +decode' :: (Data a) => L.ByteString -> Maybe a +decode' = decodeWith json' fromJSON +{-# INLINE decode' #-} + +type T a = a -> Value + toJSON :: (Data a) => a -> Value -toJSON = genericToJSON +toJSON = toJSON_generic + `ext1Q` list + `ext1Q` vector + `ext1Q` set + `ext2Q'` mapAny + `ext2Q'` hashMapAny + -- Use the standard encoding for all base types. + `extQ` (T.toJSON :: T Integer) + `extQ` (T.toJSON :: T Int) + `extQ` (T.toJSON :: T Int8) + `extQ` (T.toJSON :: T Int16) + `extQ` (T.toJSON :: T Int32) + `extQ` (T.toJSON :: T Int64) + `extQ` (T.toJSON :: T Word) + `extQ` (T.toJSON :: T Word8) + `extQ` (T.toJSON :: T Word16) + `extQ` (T.toJSON :: T Word32) + `extQ` (T.toJSON :: T Word64) + `extQ` (T.toJSON :: T Double) + `extQ` (T.toJSON :: T Number) + `extQ` (T.toJSON :: T Float) + `extQ` (T.toJSON :: T Rational) + `extQ` (T.toJSON :: T Char) + `extQ` (T.toJSON :: T Text) + `extQ` (T.toJSON :: T LT.Text) + `extQ` (T.toJSON :: T String) + `extQ` (T.toJSON :: T B.ByteString) + `extQ` (T.toJSON :: T L.ByteString) + `extQ` (T.toJSON :: T T.Value) + `extQ` (T.toJSON :: T DotNetTime) + `extQ` (T.toJSON :: T UTCTime) + `extQ` (T.toJSON :: T IntSet) + `extQ` (T.toJSON :: T Bool) + `extQ` (T.toJSON :: T ()) + --`extQ` (T.toJSON :: T Ordering) + where + list xs = Array . V.fromList . map toJSON $ xs + vector v = Array . V.map toJSON $ v + set s = Array . V.fromList . map toJSON . Set.toList $ s + + mapAny m + | tyrep == typeOf DT.empty = remap id + | tyrep == typeOf LT.empty = remap LT.toStrict + | tyrep == typeOf "" = remap pack + | tyrep == typeOf B.empty = remap F.decode + | tyrep == typeOf L.empty = remap strict + | otherwise = modError "toJSON" $ + "cannot convert map keyed by type " ++ show tyrep + where tyrep = typeOf . head . Map.keys $ m + remap f = Object . mapHashKeyVal (f . fromJust . cast) toJSON $ m + + hashMapAny m + | tyrep == typeOf DT.empty = remap id + | tyrep == typeOf LT.empty = remap LT.toStrict + | tyrep == typeOf "" = remap pack + | tyrep == typeOf B.empty = remap F.decode + | tyrep == typeOf L.empty = remap strict + | otherwise = modError "toJSON" $ + "cannot convert map keyed by type " ++ show tyrep + where tyrep = typeOf . head . H.keys $ m + remap f = Object . mapKeyVal (f . fromJust . cast) toJSON $ m + +-- Skip leading '_' in field name so we can use keywords +-- etc. as field names. +mungeField :: String -> Text +mungeField ('_':cs) = pack cs +mungeField cs = pack cs + +toJSON_generic :: (Data a) => a -> Value +toJSON_generic = generic + where + -- Generic encoding of an algebraic data type. + generic a = + case dataTypeRep (dataTypeOf a) of + -- No constructor, so it must be an error value. Code + -- it anyway as Null. + AlgRep [] -> Null + -- Elide a single constructor and just code the arguments. + AlgRep [c] -> encodeArgs c (gmapQ toJSON a) + -- For multiple constructors, make an object with a + -- field name that is the constructor (except lower + -- case) and the data is the arguments encoded. + AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a) + rep -> err (dataTypeOf a) rep + where + err dt r = modError "toJSON" $ "not AlgRep " ++ + show r ++ "(" ++ show dt ++ ")" + -- Encode nullary constructor as a string. + -- Encode non-nullary constructors as an object with the constructor + -- name as the single field and the arguments as the value. + -- Use an array if the are no field names, but elide singleton arrays, + -- and use an object if there are field names. + encodeConstr c [] = String . constrString $ c + encodeConstr c as = object [(constrString c, encodeArgs c as)] + + constrString = pack . showConstr + + encodeArgs c = encodeArgs' (constrFields c) + encodeArgs' [] [j] = j + encodeArgs' [] js = Array . V.fromList $ js + encodeArgs' ns js = object $ zip (map mungeField ns) js + + +fromJSON :: (Data a) => Value -> Result a +fromJSON = parse parseJSON + +type F a = Parser a + +parseJSON :: (Data a) => Value -> Parser a +parseJSON j = parseJSON_generic j + `ext1R` list + `ext1R` vector + `ext2R'` mapAny + `ext2R'` hashMapAny + -- Use the standard encoding for all base types. + `extR` (value :: F Integer) + `extR` (value :: F Int) + `extR` (value :: F Int8) + `extR` (value :: F Int16) + `extR` (value :: F Int32) + `extR` (value :: F Int64) + `extR` (value :: F Word) + `extR` (value :: F Word8) + `extR` (value :: F Word16) + `extR` (value :: F Word32) + `extR` (value :: F Word64) + `extR` (value :: F Double) + `extR` (value :: F Number) + `extR` (value :: F Float) + `extR` (value :: F Rational) + `extR` (value :: F Char) + `extR` (value :: F Text) + `extR` (value :: F LT.Text) + `extR` (value :: F String) + `extR` (value :: F B.ByteString) + `extR` (value :: F L.ByteString) + `extR` (value :: F T.Value) + `extR` (value :: F DotNetTime) + `extR` (value :: F UTCTime) + `extR` (value :: F IntSet) + `extR` (value :: F Bool) + `extR` (value :: F ()) + where + value :: (T.FromJSON a) => Parser a + value = T.parseJSON j + list :: (Data a) => Parser [a] + list = V.toList <$> parseJSON j + vector :: (Data a) => Parser (V.Vector a) + vector = case j of + Array js -> V.mapM parseJSON js + _ -> myFail + + mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e) + mapAny + | tyrep == typeOf DT.empty = process id + | tyrep == typeOf LT.empty = process LT.fromStrict + | tyrep == typeOf "" = process DT.unpack + | tyrep == typeOf B.empty = process encodeUtf8 + | tyrep == typeOf L.empty = process lazy + | otherwise = myFail + where + process f = maybe myFail return . cast =<< parseWith f + parseWith :: (Ord c) => (Text -> c) -> Parser (Map.Map c e) + parseWith f = case j of + Object js -> Map.fromList . map (first f) . H.toList <$> + T.mapM parseJSON js + _ -> myFail + tyrep = typeOf (undefined :: f) + + hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e) + hashMapAny + | tyrep == typeOf DT.empty = process id + | tyrep == typeOf LT.empty = process LT.fromStrict + | tyrep == typeOf "" = process DT.unpack + | tyrep == typeOf B.empty = process encodeUtf8 + | tyrep == typeOf L.empty = process lazy + | otherwise = myFail + where + process f = maybe myFail return . cast =<< parseWith f + parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e) + parseWith f = case j of + Object js -> mapKey f <$> T.mapM parseJSON js + _ -> myFail + tyrep = typeOf (undefined :: f) + + myFail = modFail "parseJSON" $ "bad data: " ++ show j + +parseJSON_generic :: (Data a) => Value -> Parser a +parseJSON_generic j = generic + where + typ = dataTypeOf $ resType generic + generic = case dataTypeRep typ of + AlgRep [] -> case j of + Null -> return (modError "parseJSON" "empty type") + _ -> modFail "parseJSON" "no-constr bad data" + AlgRep [_] -> decodeArgs (indexConstr typ 1) j + AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j' + rep -> modFail "parseJSON" $ + show rep ++ "(" ++ show typ ++ ")" + getConstr t (Object o) | [(s, j')] <- fromJSObject o = do + c <- readConstr' t s + return (c, j') + getConstr t (String js) = do c <- readConstr' t (unpack js) + return (c, Null) -- handle nullary ctor + getConstr _ _ = modFail "parseJSON" "bad constructor encoding" + readConstr' t s = + maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++ + show t) + return $ readConstr t s + + decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0 + (constrFields c0) + where + go 0 c _ Null = construct c [] -- nullary constructor + go 1 c [] jd = construct c [jd] -- unary constructor + go n c [] (Array js) + | n > 1 = construct c (V.toList js) -- no field names + -- FIXME? We could allow reading an array into a constructor + -- with field names. + go _ c fs@(_:_) (Object o) = selectFields o fs >>= + construct c -- field names + go _ c _ jd = modFail "parseJSON" $ + "bad decodeArgs data " ++ show (c, jd) + + fromJSObject = map (first unpack) . H.toList + + -- Build the value by stepping through the list of subparts. + construct c = evalStateT $ fromConstrM f c + where f :: (Data a) => StateT [Value] Parser a + f = do js <- get + case js of + [] -> lift $ modFail "construct" "empty list" + (j':js') -> do put js'; lift $ parseJSON j' + + -- Select the named fields from a JSON object. + selectFields fjs = mapM sel + where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++ + f) return $ H.lookup (mungeField f) fjs + + -- Count how many arguments a constructor has. The value x is + -- used to determine what type the constructor returns. + numConstrArgs :: (Data a) => a -> Constr -> Int + numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0 + where f = do modify (+1); return undefined + + resType :: MonadPlus m => m a -> a + resType _ = modError "parseJSON" "resType" + +modFail :: (Monad m) => String -> String -> m a +modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err + +modError :: String -> String -> a +modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err + + +-- Type extension for binary type constructors. + +-- | Flexible type extension +ext2' :: (Data a, Typeable2 t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2' def ext = maybe def id (dataCast2 ext) + +-- | Type extension of queries for type constructors +ext2Q' :: (Data d, Typeable2 t) + => (d -> q) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) + -> d -> q +ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext)) + +-- | Type extension of readers for type constructors +ext2R' :: (Monad m, Data d, Typeable2 t) + => m d + -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) + -> m d +ext2R' def ext = unR ((R def) `ext2'` (R ext)) + +-- | The type constructor for queries +newtype Q q x = Q { unQ :: x -> q } + +-- | The type constructor for readers +newtype R m x = R { unR :: m x } diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs --- a/Data/Aeson/Parser.hs +++ b/Data/Aeson/Parser.hs @@ -4,149 +4,59 @@ -- Module: Data.Aeson.Parser -- Copyright: (c) 2011 MailRank, Inc. -- License: Apache --- Maintainer: Bryan O'Sullivan +-- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- -- Efficiently and correctly parse a JSON string. The string must be -- encoded as UTF-8. +-- +-- It can be useful to think of parsing as occurring in two phases: +-- +-- * Identification of the textual boundaries of a JSON value. This +-- is always strict, so that an invalid JSON document can be +-- rejected as soon as possible. +-- +-- * Conversion of a JSON value to a Haskell value. This may be +-- either immediate (strict) or deferred (lazy); see below for +-- details. +-- +-- The question of whether to choose a lazy or strict parser is +-- subtle, but it can have significant performance implications, +-- resulting in changes in CPU use and memory footprint of 30% to 50%, +-- or occasionally more. Measure the performance of your application +-- with each! module Data.Aeson.Parser ( + -- * Lazy parsers + -- $lazy json , value , jstring + -- * Strict parsers + -- $strict + , json' + , value' ) where -import Blaze.ByteString.Builder (fromByteString, toByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromChar) -import Blaze.ByteString.Builder.Word (fromWord8) -import Control.Applicative as A -import Data.Aeson.Types (Value(..)) -import Data.Attoparsec.Char8 -import Data.Bits ((.|.), shiftL) -import Data.ByteString as B -import Data.Char (chr) -import Data.Map as Map -import Data.Monoid (mappend, mempty) -import Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import Data.Vector as Vector hiding ((++)) -import Data.Word (Word8) -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Zepto as Z -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Unsafe as B - --- | Parse a top-level JSON value. This must be either an object or --- an array. -json :: Parser Value -json = do - c <- skipSpace *> satisfy (`B8.elem` "{[") - if c == '{' - then object_ - else array_ - -object_ :: Parser Value -object_ = {-# SCC "object_" #-} do - skipSpace - let pair = do - a <- jstring <* skipSpace - b <- char ':' *> skipSpace *> value - return (a,b) - vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}' - return . Object $ Map.fromList vals - -array_ :: Parser Value -array_ = {-# SCC "array_" #-} do - skipSpace - vals <- ((value <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']' - return . Array $ Vector.fromList vals - --- | Parse any JSON value. Use 'json' in preference to this function --- if you are parsing data from an untrusted source. -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!" - -doubleQuote, backslash :: Word8 -doubleQuote = 34 -backslash = 92 -{-# INLINE backslash #-} -{-# INLINE doubleQuote #-} - -jstring :: Parser Text -jstring = A.word8 doubleQuote *> 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 - then Nothing - else Just (c == backslash) - _ <- A.word8 doubleQuote - if backslash `B.elem` s - then case Z.parse unescape s of - Right r -> return (decodeUtf8 r) - Left err -> fail err - else return (decodeUtf8 s) -{-# INLINE jstring_ #-} +import Data.Aeson.Parser.Internal (json, json', jstring, value, value') -unescape :: Z.Parser ByteString -unescape = toByteString <$> go mempty where - go acc = do - h <- Z.takeWhile (/=backslash) - let rest = do - start <- Z.take 2 - let !slash = B.unsafeHead start - !t = B.unsafeIndex start 1 - escape = case B.findIndex (==t) "\"\\/ntbrfu" of - Just i -> i - _ -> 255 - if slash /= backslash || escape == 255 - then fail "invalid JSON escape sequence" - else do - let cont m = go (acc `mappend` fromByteString h `mappend` m) - {-# INLINE cont #-} - if t /= 117 -- 'u' - then cont (fromWord8 (B.unsafeIndex mapping escape)) - else do - a <- hexQuad - if a < 0xd800 || a > 0xdfff - then cont (fromChar (chr a)) - else do - b <- Z.string "\\u" *> hexQuad - if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff - then let !c = ((a - 0xd800) `shiftL` 10) + - (b - 0xdc00) + 0x10000 - in cont (fromChar (chr c)) - else fail "invalid UTF-16 surrogates" - done <- Z.atEnd - if done - then return (acc `mappend` fromByteString h) - else rest - mapping = "\"\\/\n\t\b\r\f" +-- $lazy +-- +-- The 'json' and 'value' parsers decouple identification from +-- conversion. Identification occurs immediately (so that an invalid +-- JSON document can be rejected as early as possible), but conversion +-- to a Haskell value is deferred until that value is needed. +-- +-- This decoupling can be time-efficient if only a smallish subset of +-- elements in a JSON value need to be inspected, since the cost of +-- conversion is zero for uninspected elements. The trade off is an +-- increase in memory usage, due to allocation of thunks for values +-- that have not yet been converted. -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 - where w = fromIntegral $ B.unsafeIndex s n - a = hex 0; b = hex 1; c = hex 2; d = hex 3 - if (a .|. b .|. c .|. d) /= 255 - then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12) - else fail "invalid hex escape" +-- $strict +-- +-- The 'json'' and 'value'' parsers combine identification with +-- conversion. They consume more CPU cycles up front, but have a +-- smaller memory footprint. diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Parser/Internal.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +-- | +-- Module: Data.Aeson.Parser.Internal +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently and correctly parse a JSON string. The string must be +-- encoded as UTF-8. + +module Data.Aeson.Parser.Internal + ( + -- * Lazy parsers + json + , value + , jstring + -- * Strict parsers + , json' + , value' + -- * Helpers + , decodeWith + ) where + +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromChar) +import Blaze.ByteString.Builder.Word (fromWord8) +import Control.Applicative as A +import Data.Aeson.Types (Result(..), Value(..)) +import Data.Attoparsec.Char8 hiding (Result) +import Data.Bits ((.|.), shiftL) +import Data.ByteString as B +import Data.Char (chr) +import Data.Monoid (mappend, mempty) +import Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Vector as Vector hiding ((++)) +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.Lazy as L +import qualified Data.ByteString.Unsafe as B +import qualified Data.HashMap.Strict as H + +-- | Parse a top-level JSON value. This must be either an object or +-- an array, per RFC 4627. +-- +-- The conversion of a parsed value to a Haskell value is deferred +-- until the Haskell value is needed. This may improve performance if +-- only a subset of the results of conversions are needed, but at a +-- cost in thunk allocation. +json :: Parser Value +json = json_ object_ array_ + +-- | Parse a top-level JSON value. This must be either an object or +-- an array, per RFC 4627. +-- +-- This is a strict version of 'json' which avoids building up thunks +-- during parsing; it performs all conversions immediately. Prefer +-- this version if most of the JSON data needs to be accessed. +json' :: Parser Value +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 + then obj + else ary +{-# INLINE json_ #-} + +object_ :: Parser Value +object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value + +object_' :: Parser Value +object_' = {-# SCC "object_'" #-} do + !vals <- objectValues jstring' value' + return (Object vals) + where + jstring' = do + !s <- jstring + return s + +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) +{-# INLINE objectValues #-} + +array_ :: Parser Value +array_ = {-# SCC "array_" #-} Array <$> arrayValues value + +array_' :: Parser Value +array_' = {-# SCC "array_'" #-} do + !vals <- arrayValues value' + return (Array vals) + +arrayValues :: Parser Value -> Parser (Vector Value) +arrayValues val = do + skipSpace + vals <- ((val <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']' + return (Vector.fromList vals) +{-# INLINE arrayValues #-} + +-- | Parse any JSON value. You should usually 'json' in preference to +-- this function, as this function relaxes the object-or-array +-- requirement of RFC 4627. +-- +-- In particular, be careful in using this function if you think your +-- code might interoperate with Javascript. A naïve Javascript +-- library that parses JSON data using @eval@ is vulnerable to attack +-- unless the encoded data represents an object or an array. JSON +-- 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!" + +-- | 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 #-} + +-- | Parse a quoted JSON string. +jstring :: Parser Text +jstring = A.word8 doubleQuote *> 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 + then Nothing + else Just (c == backslash) + _ <- A.word8 doubleQuote + if backslash `B.elem` s + then case Z.parse unescape s of + Right r -> return (decodeUtf8 r) + Left err -> fail err + else return (decodeUtf8 s) +{-# INLINE jstring_ #-} + +unescape :: Z.Parser ByteString +unescape = toByteString <$> go mempty where + go acc = do + h <- Z.takeWhile (/=backslash) + let rest = do + start <- Z.take 2 + let !slash = B.unsafeHead start + !t = B.unsafeIndex start 1 + escape = case B.findIndex (==t) "\"\\/ntbrfu" of + Just i -> i + _ -> 255 + if slash /= backslash || escape == 255 + then fail "invalid JSON escape sequence" + else do + let cont m = go (acc `mappend` fromByteString h `mappend` m) + {-# INLINE cont #-} + if t /= 117 -- 'u' + then cont (fromWord8 (B.unsafeIndex mapping escape)) + else do + a <- hexQuad + if a < 0xd800 || a > 0xdfff + then cont (fromChar (chr a)) + else do + b <- Z.string "\\u" *> hexQuad + if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff + then let !c = ((a - 0xd800) `shiftL` 10) + + (b - 0xdc00) + 0x10000 + in cont (fromChar (chr c)) + else fail "invalid UTF-16 surrogates" + done <- Z.atEnd + if done + then return (acc `mappend` fromByteString h) + else rest + mapping = "\"\\/\n\t\b\r\f" + +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 + where w = fromIntegral $ B.unsafeIndex s n + a = hex 0; b = hex 1; c = hex 2; d = hex 3 + if (a .|. b .|. c .|. d) /= 255 + then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12) + else fail "invalid hex escape" + +decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a +decodeWith p to s = + case L.parse p s of + L.Done _ v -> case to v of + Success a -> Just a + _ -> Nothing + _ -> Nothing +{-# INLINE decodeWith #-} + +-- $lazy +-- +-- The 'json' and 'value' parsers decouple identification from +-- conversion. Identification occurs immediately (so that an invalid +-- JSON document can be rejected as early as possible), but conversion +-- to a Haskell value is deferred until that value is needed. +-- +-- This decoupling can be time-efficient if only a smallish subset of +-- elements in a JSON value need to be inspected, since the cost of +-- conversion is zero for uninspected elements. The trade off is an +-- increase in memory usage, due to allocation of thunks for values +-- that have not yet been converted. + +-- $strict +-- +-- The 'json'' and 'value'' parsers combine identification with +-- conversion. They consume more CPU cycles up front, but have a +-- smaller memory footprint. diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -2,6 +2,8 @@ {-| Module: Data.Aeson.TH +Copyright: (c) 2011 Bryan O'Sullivan + (c) 2011 MailRank, Inc. License: Apache Stability: experimental Portability: portable @@ -38,8 +40,8 @@ import Control.Monad import Data.Aeson import Data.Aeson.TH -import qualified Data.Map as M -import qualified Data.Text as T +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T import qualified Data.Vector as V instance 'ToJSON' a => 'ToJSON' (D a) where @@ -47,21 +49,23 @@ \value -> case value of Nullary -> - 'object' ['T.pack' \"Nullary\" .= 'toJSON' ([] :: [()])] + 'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])] Unary arg1 -> - 'object' ['T.pack' \"Unary\" .= 'toJSON' arg1] + 'object' [T.pack \"Unary\" .= 'toJSON' arg1] Product arg1 arg2 arg3 -> - 'object' [ 'T.pack' \"Product\" - .= 'toJSON' [ 'toJSON' arg1 - , 'toJSON' arg2 - , 'toJSON' arg3 - ] + 'object' [ T.pack \"Product\" + .= ('Array' $ 'V.create' $ do + mv <- 'VM.unsafeNew' 3 + 'VM.unsafeWrite' mv 0 ('toJSON' arg1) + 'VM.unsafeWrite' mv 1 ('toJSON' arg2) + 'VM.unsafeWrite' mv 2 ('toJSON' arg3) + return mv) ] Record arg1 arg2 arg3 -> - 'object' [ 'T.pack' \"Record\" - .= 'object' [ 'T.pack' \"One\" '.=' arg1 - , 'T.pack' \"Two\" '.=' arg2 - , 'T.pack' \"Three\" '.=' arg3 + 'object' [ T.pack \"Record\" + .= 'object' [ T.pack \"One\" '.=' arg1 + , T.pack \"Two\" '.=' arg2 + , T.pack \"Three\" '.=' arg3 ] ] @ @@ -72,35 +76,45 @@ \value -> case value of 'Object' obj -> - case 'M.toList' obj of + case H.toList obj of [(conKey, conVal)] -> - case conKey of - _ | (conKey '==' 'T.pack' \"Nullary\") -> - case conVal of - 'Array' arr | 'V.null' arr -> 'pure' Nullary - _ -> 'mzero' - | (conKey '==' 'T.pack' \"Unary\") -> - case conVal of - arg -> Unary '<$>' 'parseJSON' arg - | (conKey '==' 'T.pack' \"Product\") -> - case conVal of - 'Array' arr | 'V.length' arr '==' 3 -> - 'Product' '<$>' 'parseJSON' (arr 'V.!' 0) - '<*>' 'parseJSON' (arr 'V.!' 1) - '<*>' 'parseJSON' (arr 'V.!' 2) - _ -> 'mzero' - | (conKey '==' 'T.pack' \"Record\") -> - case conVal of - 'Object' obj -> - Record '<$>' (obj '.:' 'T.pack' \"One\") - '<*>' (obj '.:' 'T.pack' \"Two\") - '<*>' (obj '.:' 'T.pack' \"Three\") - _ -> 'mzero' - | 'otherwise' -> 'mzero' - _ -> 'mzero' - _ -> 'mzero' + case conKey of + _ | conKey == T.pack \"Nullary\" -> + case conVal of + 'Array' arr -> + if V.null arr + then pure Nullary + else fail \"\\" + _ -> fail \"\\" + | conKey == T.pack \"Unary\" -> + case conVal of + arg -> Unary \<$\> parseJSON arg + | conKey == T.pack \"Product\" -> + case conVal of + 'Array' arr -> + if V.length arr == 3 + then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0) + \<*\> 'parseJSON' (arr `V.unsafeIndex` 1) + \<*\> 'parseJSON' (arr `V.unsafeIndex` 2) + else fail \"\\" + _ -> fail \"\\" + | conKey == T.pack \"Record\" -> + case conVal of + 'Object' recObj -> + if H.size recObj == 3 + then Record \<$\> recObj '.:' T.pack \"One\" + \<*\> recObj '.:' T.pack \"Two\" + \<*\> recObj '.:' T.pack \"Three\" + else fail \"\\" + _ -> fail \"\\" + | otherwise -> fail \"\\" + _ -> fail \"\\" + _ -> fail \"\\" @ +Note that every \"\\" is in fact a descriptive message which +provides as much information as is reasonable about the failed parse. + Now we can use the newly created instances. @ @@ -114,6 +128,13 @@ >>> fromJSON (toJSON d) == Success d > True +Please note that you can derive instances for tuples using the following syntax: + +@ +-- FromJSON and ToJSON instances for 4-tuples. +$('deriveJSON' id ''(,,,)) +@ + -} module Data.Aeson.TH @@ -131,34 +152,38 @@ -------------------------------------------------------------------------------- -- from aeson: -import Data.Aeson ( toJSON, object, (.=), (.:) +import Data.Aeson ( toJSON, Object, object, (.=) , ToJSON, toJSON , FromJSON, parseJSON ) -import Data.Aeson.Types ( Value(..) ) +import Data.Aeson.Types ( Value(..), Parser ) -- from base: import Control.Applicative ( pure, (<$>), (<*>) ) -import Control.Monad ( return, mapM, mzero, liftM2 ) +import Control.Monad ( return, mapM, liftM2, fail ) import Data.Bool ( otherwise ) import Data.Eq ( (==) ) import Data.Function ( ($), (.), id ) import Data.Functor ( fmap ) -import Data.List ( (++), foldl', map, zip, genericLength ) -import Prelude ( String, (-), Integer, error ) +import Data.List ( (++), foldl, foldl', intercalate + , length, map, zip, genericLength + ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import Prelude ( String, (-), Integer, fromIntegral, error ) +import Text.Printf ( printf ) import Text.Show ( show ) #if __GLASGOW_HASKELL__ < 700 -import Control.Monad ( (>>=), fail ) +import Control.Monad ( (>>=) ) import Prelude ( fromInteger ) #endif --- from containers: -import qualified Data.Map as M ( toList ) +-- from unordered-containers: +import qualified Data.HashMap.Strict as H ( lookup, toList, size ) -- from template-haskell: import Language.Haskell.TH -- from text: -import qualified Data.Text as T ( pack ) +import qualified Data.Text as T ( Text, pack, unpack ) -- from vector: -import qualified Data.Vector as V ( (!), null, length ) - +import qualified Data.Vector as V ( unsafeIndex, null, length, create ) +import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite ) -------------------------------------------------------------------------------- @@ -210,7 +235,11 @@ -- instance 'ToJSON' Foo where -- 'toJSON' = -- \value -> case value of --- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2] +-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do +-- mv <- 'VM.unsafeNew' 2 +-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1) +-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2) +-- return mv -- @ deriveToJSON :: (String -> String) -- ^ Function to change field names. @@ -241,12 +270,12 @@ -- Example: -- -- @ --- data Foo = Foo 'Int' +-- data Foo = Foo Int -- @ -- -- @ -- encodeFoo :: Foo -> 'Value' --- encodeFoo = $('mkToJSON' 'id' ''Foo) +-- encodeFoo = $('mkToJSON' id ''Foo) -- @ -- -- This will splice in the following code: @@ -306,12 +335,28 @@ [] -- Polyadic constructors with special case for unary constructors. encodeArgs withExp _ (NormalC conName ts) = do - args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]] - let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of - -- Single argument is directly converted. - [e] -> e - -- Multiple arguments are converted to a JSON array. - es -> [e|toJSON|] `appE` listE es + let len = length ts + args <- mapM newName ["arg" ++ show n | n <- [1..len]] + js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of + -- Single argument is directly converted. + [e] -> return e + -- Multiple arguments are converted to a JSON array. + es -> do + mv <- newName "mv" + let newMV = bindS (varP mv) + ([e|VM.unsafeNew|] `appE` + litE (integerL $ fromIntegral len)) + stmts = [ noBindS $ + [e|VM.unsafeWrite|] `appE` + (varE mv) `appE` + litE (integerL ix) `appE` + e + | (ix, e) <- zip [(0::Integer)..] es + ] + ret = noBindS $ [e|return|] `appE` varE mv + return $ [e|Array|] `appE` + (varE 'V.create `appE` + doE (newMV:stmts++[ret])) match (conP conName $ map varP args) (normalB $ withExp js) [] @@ -352,8 +397,8 @@ -- Example: -- -- @ --- data Foo = Foo 'Char' 'Int' --- $('deriveFromJSON' 'id' ''Foo) +-- data Foo = Foo Char Int +-- $('deriveFromJSON' id ''Foo) -- @ -- -- This will splice in the following code: @@ -362,10 +407,12 @@ -- instance 'FromJSON' Foo where -- 'parseJSON' = -- \value -> case value of --- 'Array' arr | ('V.length' arr '==' 2) -> --- Foo '<$>' 'parseJSON' (arr 'V.!' 0) --- '<*>' 'parseJSON' (arr 'V.!' 1) --- _ -> 'mzero' +-- 'Array' arr -> +-- if (V.length arr == 2) +-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0) +-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1) +-- else fail \"\\" +-- other -> fail \"\\" -- @ deriveFromJSON :: (String -> String) -- ^ Function to change field names. @@ -382,7 +429,7 @@ (classType `appT` instanceType) [ funD 'parseJSON [ clause [] - (normalB $ consFromJSON withField cons) + (normalB $ consFromJSON name withField cons) [] ] ] @@ -402,36 +449,38 @@ -- -- @ -- parseFoo :: 'Value' -> 'Parser' Foo --- parseFoo = $('mkParseJSON' 'id' ''Foo) +-- parseFoo = $('mkParseJSON' id ''Foo) -- @ -- -- This will splice in the following code: -- -- @ --- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg +-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg -- @ mkParseJSON :: (String -> String) -- ^ Function to change field names. -> Name -- ^ Name of the encoded type. -> Q Exp mkParseJSON withField name = - withType name (\_ cons -> consFromJSON withField cons) + withType name (\_ cons -> consFromJSON name withField cons) -- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates -- code to parse the JSON encoding of a number of constructors. All constructors -- must be from the same type. -consFromJSON :: (String -> String) +consFromJSON :: Name + -- ^ Name of the type to which the constructors belong. + -> (String -> String) -- ^ Function to change field names. -> [Con] -- ^ Constructors for which to generate JSON parsing code. -> Q Exp -consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: " - ++ "Not a single constructor given!" -consFromJSON withField [con] = do +consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: " + ++ "Not a single constructor given!" +consFromJSON tName withField [con] = do value <- newName "value" lam1E (varP value) $ caseE (varE value) - (parseArgs withField con) -consFromJSON withField cons = do + (parseArgs tName withField con) +consFromJSON tName withField cons = do value <- newName "value" obj <- newName "obj" conKey <- newName "conKey" @@ -440,12 +489,19 @@ let -- Convert the Data.Map inside the Object to a list and pattern match -- against it. It must contain a single element otherwise the parse will -- fail. - caseLst = caseE ([e|M.toList|] `appE` varE obj) + caseLst = caseE ([e|H.toList|] `appE` varE obj) [ match (listP [tupP [varP conKey, varP conVal]]) (normalB caseKey) [] - , errorMatch + , do other <- newName "other" + match (varP other) + (normalB $ [|wrongPairCountFail|] + `appE` (litE $ stringL $ show tName) + `appE` ([|show . length|] `appE` varE other) + ) + [] ] + caseKey = caseE (varE conKey) [match wildP (guardedB guards) []] guards = [ do g <- normalG $ infixApp (varE conKey) @@ -454,44 +510,59 @@ `appE` conNameExp con ) e <- caseE (varE conVal) - (parseArgs withField con) + (parseArgs tName withField con) return (g, e) | con <- cons ] ++ - [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]] + [ liftM2 (,) + (normalG [e|otherwise|]) + ( [|conNotFoundFail|] + `appE` (litE $ stringL $ show tName) + `appE` listE (map (litE . stringL . nameBase . getConName) cons) + `appE` ([|T.unpack|] `appE` varE conKey) + ) + ] lam1E (varP value) $ caseE (varE value) [ match (conP 'Object [varP obj]) (normalB caseLst) [] - , errorMatch + , do other <- newName "other" + match (varP other) + ( normalB + $ [|noObjectFail|] + `appE` (litE $ stringL $ show tName) + `appE` ([|valueConName|] `appE` varE other) + ) + [] ] - where - -- Makes a string literal expression from a constructor's name. - conNameExp :: Con -> Q Exp - conNameExp = litE . stringL . nameBase . getConName --- | Generates code to parse the JSON encoding of a single --- constructor. -parseArgs :: (String -> String) -- ^ Function to change field names. +-- | Generates code to parse the JSON encoding of a single constructor. +parseArgs :: Name -- ^ Name of the type to which the constructor belongs. + -> (String -> String) -- ^ Function to change field names. -> Con -- ^ Constructor for which to generate JSON parsing code. -> [Q Match] -- Nullary constructors. -parseArgs _ (NormalC conName []) = +parseArgs tName _ (NormalC conName []) = [ do arr <- newName "arr" - g <- normalG $ [|V.null|] `appE` varE arr - e <- [e|pure|] `appE` conE conName - -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e'] - -- But first need to have "instance Applicative Q". match (conP 'Array [varP arr]) - (guardedB [return (g, e)]) + ( normalB $ condE ([|V.null|] `appE` varE arr) + ([e|pure|] `appE` conE conName) + ( parseTypeMismatch tName conName + (litE $ stringL "an empty Array") + ( infixApp (litE $ stringL $ "Array of length ") + [|(++)|] + ([|show . V.length|] `appE` varE arr) + ) + ) + ) [] - , errorMatch + , matchFailed tName conName "Array" ] -- Unary constructors. -parseArgs _ (NormalC conName [_]) = +parseArgs _ _ (NormalC conName [_]) = [ do arg <- newName "arg" match (varP arg) ( normalB $ infixApp (conE conName) @@ -500,71 +571,144 @@ ) [] ] - -- Polyadic constructors. -parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts +parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts -- Records. -parseArgs withField (RecC conName ts) = - [ do obj <- newName "obj" - -- List of: "obj .: """ - let x:xs = [ infixApp (varE obj) - [|(.:)|] - ( [e|T.pack|] - `appE` - fieldNameExp withField field - ) +parseArgs tName withField (RecC conName ts) = + [ do obj <- newName "recObj" + let x:xs = [ [|lookupField|] + `appE` (litE $ stringL $ show tName) + `appE` (litE $ stringL $ nameBase conName) + `appE` (varE obj) + `appE` ( [e|T.pack|] + `appE` + fieldNameExp withField field + ) | (field, _, _) <- ts ] match (conP 'Object [varP obj]) - ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b) - (infixApp (conE conName) [|(<$>)|] x) - xs + ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj) + [|(==)|] + (litE $ integerL $ genericLength ts) + ) + ( foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) + xs + ) + ( parseTypeMismatch tName conName + ( litE $ stringL $ "Object with " + ++ show (length ts) + ++ " name/value pairs" + ) + ( infixApp ([|show . H.size|] `appE` varE obj) + [|(++)|] + (litE $ stringL $ " name/value pairs") + ) + ) ) [] - , errorMatch + , matchFailed tName conName "Object" ] -- Infix constructors. Apart from syntax these are the same as -- polyadic constructors. -parseArgs _ (InfixC _ conName _) = parseProduct conName 2 +parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2 -- Existentially quantified constructors. We ignore the quantifiers -- and proceed with the contained constructor. -parseArgs withField (ForallC _ _ con) = parseArgs withField con +parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con -- | Generates code to parse the JSON encoding of an n-ary -- constructor. -parseProduct :: Name -- ^ 'Con'structor name. +parseProduct :: Name -- ^ Name of the type to which the constructor belongs. + -> Name -- ^ 'Con'structor name. -> Integer -- ^ 'Con'structor arity. -> [Q Match] -parseProduct conName numArgs = +parseProduct tName conName numArgs = [ do arr <- newName "arr" - g <- normalG $ infixApp ([|V.length|] `appE` varE arr) - [|(==)|] - (litE $ integerL numArgs) - -- List of: "parseJSON (arr V.! )" + -- List of: "parseJSON (arr `V.unsafeIndex` )" let x:xs = [ [|parseJSON|] `appE` infixApp (varE arr) - [|(V.!)|] + [|V.unsafeIndex|] (litE $ integerL ix) | ix <- [0 .. numArgs - 1] ] - e <- foldl' (\a b -> infixApp a [|(<*>)|] b) - (infixApp (conE conName) [|(<$>)|] x) - xs match (conP 'Array [varP arr]) - (guardedB [return (g, e)]) + (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr) + [|(==)|] + (litE $ integerL numArgs) + ) + ( foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) + xs + ) + ( parseTypeMismatch tName conName + (litE $ stringL $ "Array of length " ++ show numArgs) + ( infixApp (litE $ stringL $ "Array of length ") + [|(++)|] + ([|show . V.length|] `appE` varE arr) + ) + ) + ) [] - , errorMatch + , matchFailed tName conName "Array" ] --- | --- @ --- _ -> 'mzero' --- @ -errorMatch :: Q Match -errorMatch = match wildP (normalB [|mzero|]) [] +-------------------------------------------------------------------------------- +-- Parsing errors +-------------------------------------------------------------------------------- +matchFailed :: Name -> Name -> String -> MatchQ +matchFailed tName conName expected = do + other <- newName "other" + match (varP other) + ( normalB $ parseTypeMismatch tName conName + (litE $ stringL expected) + ([|valueConName|] `appE` varE other) + ) + [] + +parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ +parseTypeMismatch tName conName expected actual = + foldl appE + [|parseTypeMismatch'|] + [ litE $ stringL $ nameBase conName + , litE $ stringL $ show tName + , expected + , actual + ] + +lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a +lookupField tName rec obj key = + case H.lookup key obj of + Nothing -> unknownFieldFail tName rec (T.unpack key) + Just v -> parseJSON v + +unknownFieldFail :: String -> String -> String -> Parser fail +unknownFieldFail tName rec key = + fail $ printf "When parsing the record %s of type %s the key %s was not present." + rec tName key + +noObjectFail :: String -> String -> Parser fail +noObjectFail t o = + fail $ printf "When parsing %s expected Object but got %s." t o + +wrongPairCountFail :: String -> String -> Parser fail +wrongPairCountFail t n = + fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs." + t n + +conNotFoundFail :: String -> [String] -> String -> Parser fail +conNotFoundFail t cs o = + fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s." + t (intercalate ", " cs) o + +parseTypeMismatch' :: String -> String -> String -> String -> Parser fail +parseTypeMismatch' tName conName expected actual = + fail $ printf "When parsing the constructor %s of type %s expected %s but got %s." + conName tName expected actual + + -------------------------------------------------------------------------------- -- Utility functions -------------------------------------------------------------------------------- @@ -604,8 +748,21 @@ tvbName (PlainTV name ) = name tvbName (KindedTV name _) = name +-- | Makes a string literal expression from a constructor's name. +conNameExp :: Con -> Q Exp +conNameExp = litE . stringL . nameBase . getConName + -- | Creates a string literal expression from a record field name. fieldNameExp :: (String -> String) -- ^ Function to change the field name. -> Name -> Q Exp fieldNameExp f = litE . stringL . f . nameBase + +-- | The name of the outermost 'Value' constructor. +valueConName :: Value -> String +valueConName (Object _) = "Object" +valueConName (Array _) = "Array" +valueConName (String _) = "String" +valueConName (Number _) = "Number" +valueConName (Bool _) = "Boolean" +valueConName Null = "Null" diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs --- a/Data/Aeson/Types.hs +++ b/Data/Aeson/Types.hs @@ -1,1133 +1,48 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, - IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types, - ViewPatterns, FlexibleContexts, UndecidableInstances, - ScopedTypeVariables, PatternGuards #-} - -{-# LANGUAGE CPP #-} -#ifdef DEFAULT_SIGNATURES -{-# LANGUAGE DefaultSignatures #-} -#endif - --- | --- Module: Data.Aeson.Types --- Copyright: (c) 2011 MailRank, Inc. --- License: Apache --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- Types for working with JSON data. - -module Data.Aeson.Types - ( - -- * Core JSON types - Value(..) - , Array - , emptyArray - , Pair - , Object - , emptyObject - -- * Convenience types and functions - , DotNetTime(..) - , typeMismatch - -- * Type conversion - , Parser - , Result(..) - , FromJSON(..) - , fromJSON - , parse - , parseEither - , parseMaybe - , ToJSON(..) - -- * Constructors and accessors - , (.=) - , (.:) - , (.:?) - , object - -- * Generic toJSON and fromJSON - , genericToJSON - , genericFromJSON - ) where - -import Control.Applicative -import Control.Arrow (first) -import Control.Monad.State.Strict -import Control.DeepSeq (NFData(..)) -import Data.Aeson.Functions -import Data.Attoparsec.Char8 (Number(..)) -import Data.Generics -import Data.Hashable (Hashable(..)) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.IntSet (IntSet) -import Data.List (foldl') -import Data.Map (Map) -import Data.Maybe (fromJust) -import Data.Monoid (Dual(..), First(..), Last(..)) -import Data.Monoid (Monoid(..)) -import Data.Ratio (Ratio) -import Data.String (IsString(..)) -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock (UTCTime) -import Data.Time.Format (FormatTime, formatTime, parseTime) -import Data.Vector (Vector) -import Data.Word (Word, Word8, Word16, Word32, Word64) -import Foreign.Storable (Storable) -import System.Locale (defaultTimeLocale) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.HashMap.Strict as H -import qualified Data.HashSet as HashSet -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.Traversable as T -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Generic as VG - - --- | The result of running a 'Parser'. -data Result a = Error String - | Success a - deriving (Eq, Show, Typeable) - -instance (NFData a) => NFData (Result a) where - rnf (Success a) = rnf a - rnf (Error err) = rnf err - -instance Functor Result where - fmap f (Success a) = Success (f a) - fmap _ (Error err) = Error err - {-# INLINE fmap #-} - -instance Monad Result where - return = Success - {-# INLINE return #-} - Success a >>= k = k a - Error err >>= _ = Error err - {-# INLINE (>>=) #-} - -instance Applicative Result where - pure = return - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance MonadPlus Result where - mzero = fail "mzero" - {-# INLINE mzero #-} - mplus a@(Success _) _ = a - mplus _ b = b - {-# INLINE mplus #-} - -instance Alternative Result where - empty = mzero - {-# INLINE empty #-} - (<|>) = mplus - {-# INLINE (<|>) #-} - -instance Monoid (Result a) where - mempty = fail "mempty" - {-# INLINE mempty #-} - mappend = mplus - {-# INLINE mappend #-} - --- | Failure continuation. -type Failure f r = String -> f r --- | Success continuation. -type Success a f r = a -> f r - --- | A continuation-based parser type. -newtype Parser a = Parser { - runParser :: forall f r. - Failure f r - -> Success a f r - -> f r - } - -instance Monad Parser where - m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks - in runParser m kf ks' - {-# INLINE (>>=) #-} - return a = Parser $ \_kf ks -> ks a - {-# INLINE return #-} - fail msg = Parser $ \kf _ks -> kf msg - {-# INLINE fail #-} - -instance Functor Parser where - fmap f m = Parser $ \kf ks -> let ks' a = ks (f a) - in runParser m kf ks' - {-# INLINE fmap #-} - -instance Applicative Parser where - pure = return - {-# INLINE pure #-} - (<*>) = apP - {-# INLINE (<*>) #-} - -instance Alternative Parser where - empty = fail "empty" - {-# INLINE empty #-} - (<|>) = mplus - {-# INLINE (<|>) #-} - -instance MonadPlus Parser where - mzero = fail "mzero" - {-# INLINE mzero #-} - mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks - in runParser a kf' ks - {-# INLINE mplus #-} - -instance Monoid (Parser a) where - mempty = fail "mempty" - {-# INLINE mempty #-} - mappend = mplus - {-# INLINE mappend #-} - -apP :: Parser (a -> b) -> Parser a -> Parser b -apP d e = do - b <- d - a <- e - return (b a) -{-# INLINE apP #-} - --- | A JSON \"object\" (key\/value map). -type Object = Map Text Value - --- | A JSON \"array\" (sequence). -type Array = Vector Value - --- | A JSON value represented as a Haskell value. -data Value = Object Object - | Array Array - | String Text - | Number Number - | Bool !Bool - | Null - deriving (Eq, Show, Typeable, Data) - -instance NFData Value where - rnf (Object o) = obj_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 (Bool b) = rnf b - rnf Null = () - -obj_rnf :: (NFData k, NFData v) => Map k v -> () -#if MIN_VERSION_containers(0,4,2) -obj_rnf = rnf -#else -obj_rnf = rnf . M.toList -#endif - -instance IsString Value where - fromString = String . pack - {-# INLINE fromString #-} - -instance Hashable Value where - hash (Object o) = foldl' hashWithSalt 0 . M.toList $ o - hash (Array a) = V.foldl' hashWithSalt 1 a - hash (String s) = 2 `hashWithSalt` s - hash (Number n) = 3 `hashWithSalt` case n of I i -> hash i; D d -> hash d - hash (Bool b) = 4 `hashWithSalt` b - hash Null = 5 - --- | The empty array. -emptyArray :: Value -emptyArray = Array V.empty - --- | The empty object. -emptyObject :: Value -emptyObject = Object M.empty - --- | A key\/value pair for an 'Object'. -type Pair = (Text, Value) - --- | 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 #-} - --- | Run a 'Parser'. -parse :: (a -> Parser b) -> a -> Result b -parse m v = runParser (m v) Error Success -{-# INLINE parse #-} - --- | Run a 'Parser' with a 'Maybe' result type. -parseMaybe :: (a -> Parser b) -> a -> Maybe b -parseMaybe m v = runParser (m v) (const Nothing) Just -{-# INLINE parseMaybe #-} - --- | Run a 'Parser' with an 'Either' result type. -parseEither :: (a -> Parser b) -> a -> Either String b -parseEither m v = runParser (m v) Left Right -{-# INLINE parseEither #-} - --- | 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 M.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 M.lookup key obj of - Nothing -> pure Nothing - Just v -> parseJSON v -{-# INLINE (.:?) #-} - --- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate --- keys arise, earlier keys and their associated values win. -object :: [Pair] -> Value -object = Object . M.fromList -{-# INLINE object #-} - --- | A type that can be converted to JSON. --- --- An example type and instance: --- --- @data Coord { x :: Double, y :: Double } --- --- instance ToJSON Coord where --- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] --- @ --- --- This example assumes the OverloadedStrings language option is enabled. -class ToJSON a where - toJSON :: a -> Value - -#ifdef DEFAULT_SIGNATURES - default toJSON :: Data a => a -> Value - toJSON = genericToJSON -#endif - --- | A type that can be converted from JSON, with the possibility of --- failure. --- --- When writing an instance, use 'mzero' or 'fail' to make a --- conversion fail, e.g. if an 'Object' is missing a required key, or --- the value is of the wrong type. --- --- An example type and instance: --- --- @data Coord { x :: Double, y :: Double } --- --- instance FromJSON Coord where --- parseJSON ('Object' v) = Coord '<$>' --- v '.:' \"x\" '<*>' --- v '.:' \"y\" --- --- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail. --- parseJSON _ = 'mzero' --- @ --- --- This example assumes the OverloadedStrings language option is enabled. -class FromJSON a where - parseJSON :: Value -> Parser a - -#ifdef DEFAULT_SIGNATURES - default parseJSON :: Data a => Value -> Parser a - parseJSON = genericParseJSON -#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 (M.toList -> [(key, value)])) - | key == left = Left <$> parseJSON value - | key == right = Right <$> parseJSON value - parseJSON _ = mzero - {-# INLINE parseJSON #-} - -left, right :: Text -left = "Left" -right = "Right" - -instance ToJSON Bool where - toJSON = Bool - {-# INLINE toJSON #-} - -instance FromJSON Bool where - parseJSON (Bool b) = pure b - parseJSON v = typeMismatch "Bool" v - {-# INLINE parseJSON #-} - -instance ToJSON () where - toJSON _ = emptyArray - {-# INLINE toJSON #-} - -instance FromJSON () where - parseJSON (Array v) | V.null v = pure () - parseJSON v = typeMismatch "()" v - {-# INLINE parseJSON #-} - -instance ToJSON [Char] where - toJSON = String . T.pack - {-# INLINE toJSON #-} - -instance FromJSON [Char] where - parseJSON (String t) = pure (T.unpack t) - parseJSON v = typeMismatch "String" v - {-# INLINE parseJSON #-} - -instance ToJSON Char where - toJSON = String . T.singleton - {-# INLINE toJSON #-} - -instance FromJSON Char where - parseJSON (String t) - | T.compareLength t 1 == EQ = pure (T.head t) - parseJSON v = typeMismatch "Char" v - {-# 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 (Number n) = pure $ case n of - D d -> toRational d - I i -> fromIntegral i - parseJSON v = typeMismatch "Ratio Integer" 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 (Number n) = pure (floor n) -parseIntegral v = typeMismatch "Integral" v -{-# 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 (String t) = pure t - parseJSON v = typeMismatch "Text" v - {-# INLINE parseJSON #-} - -instance ToJSON LT.Text where - toJSON = String . LT.toStrict - {-# INLINE toJSON #-} - -instance FromJSON LT.Text where - parseJSON (String t) = pure (LT.fromStrict t) - parseJSON v = typeMismatch "Lazy Text" v - {-# INLINE parseJSON #-} - -instance ToJSON B.ByteString where - toJSON = String . decode - {-# INLINE toJSON #-} - -instance FromJSON B.ByteString where - parseJSON (String t) = pure . encodeUtf8 $ t - parseJSON v = typeMismatch "ByteString" v - {-# INLINE parseJSON #-} - -instance ToJSON LB.ByteString where - toJSON = toJSON . strict - {-# INLINE toJSON #-} - -instance FromJSON LB.ByteString where - parseJSON (String t) = pure . lazy $ t - parseJSON v = typeMismatch "Lazy ByteString" v - {-# INLINE parseJSON #-} - -instance (ToJSON a) => ToJSON [a] where - toJSON = Array . V.fromList . map toJSON - {-# INLINE toJSON #-} - -instance (FromJSON a) => FromJSON [a] where - parseJSON (Array a) = mapM parseJSON (V.toList a) - parseJSON v = typeMismatch "[a]" v - {-# INLINE parseJSON #-} - -instance (ToJSON a) => ToJSON (Vector a) where - toJSON = Array . V.map toJSON - {-# INLINE toJSON #-} - -instance (FromJSON a) => FromJSON (Vector a) where - parseJSON (Array a) = V.mapM parseJSON a - parseJSON v = typeMismatch "Vector a" v - {-# 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 _ (Array a) = V.convert <$> V.mapM parseJSON a -vectorParseJSON s v = typeMismatch s v -{-# 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 v) => ToJSON (M.Map Text v) where - toJSON = Object . M.map toJSON - {-# INLINE toJSON #-} - -instance (FromJSON v) => FromJSON (M.Map Text v) where - parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o) - where go (k,v) = ((,) k) <$> parseJSON v - parseJSON v = typeMismatch "Map Text a" v - -instance (ToJSON v) => ToJSON (M.Map LT.Text v) where - toJSON = Object . transformMap LT.toStrict toJSON - -instance (FromJSON v) => FromJSON (M.Map LT.Text v) where - parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON - -instance (ToJSON v) => ToJSON (M.Map String v) where - toJSON = Object . transformMap pack toJSON - -instance (FromJSON v) => FromJSON (M.Map String v) where - parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON - -instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where - toJSON = Object . transformMap decode toJSON - -instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where - parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON - -instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where - toJSON = Object . transformMap strict toJSON - -instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where - parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON - -instance (ToJSON v) => ToJSON (H.HashMap Text v) where - toJSON = Object . hashMap id toJSON - {-# INLINE toJSON #-} - -instance (FromJSON v) => FromJSON (H.HashMap Text v) where - parseJSON (Object o) = H.fromList <$> mapM go (M.toList o) - where go (k,v) = ((,) k) <$> parseJSON v - parseJSON v = typeMismatch "HashMap Text a" v - -instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where - toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) [] - -instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where - parseJSON = fmap (mapHash LT.fromStrict) . parseJSON - -instance (ToJSON v) => ToJSON (H.HashMap String v) where - toJSON = Object . hashMap pack toJSON - -instance (FromJSON v) => FromJSON (H.HashMap String v) where - parseJSON = fmap (mapHash unpack) . parseJSON - -instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where - toJSON = Object . hashMap decode toJSON - -instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where - parseJSON = fmap (mapHash encodeUtf8) . parseJSON - -instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where - toJSON = Object . hashMap strict toJSON - -instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where - parseJSON = fmap (mapHash lazy) . 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 (String t) = - case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of - Just d -> pure (DotNetTime d) - _ -> fail "could not parse .NET time" - where (s,m) = T.splitAt (T.length t - 5) t - t' = T.concat [s,".",m] - parseJSON v = typeMismatch "DotNetTime" v - {-# INLINE parseJSON #-} - -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 (String t) = - case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of - Just d -> pure d - _ -> fail "could not parse ISO-8601 date" - parseJSON v = typeMismatch "UTCTime" v - {-# INLINE parseJSON #-} - -instance (ToJSON a, ToJSON b) => ToJSON (a,b) where - toJSON (a,b) = toJSON [toJSON a, toJSON b] - {-# INLINE toJSON #-} - -instance (FromJSON a, FromJSON b) => FromJSON (a,b) where - parseJSON (Array ab) = - case V.toList ab of - [a,b] -> (,) <$> parseJSON a <*> parseJSON b - _ -> fail $ "cannot unpack array of length " ++ - show (V.length ab) ++ " into a pair" - parseJSON v = typeMismatch "(a,b)" v - {-# INLINE parseJSON #-} - -instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where - toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c] - {-# INLINE toJSON #-} - -instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where - parseJSON (Array abc) = - case V.toList abc of - [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c - _ -> fail $ "cannot unpack array of length " ++ - show (V.length abc) ++ " into a 3-tuple" - parseJSON v = typeMismatch "(a,b,c)" v - {-# 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 #-} - --- | 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" - - --------------------------------------------------------------------------------- --- Generic toJSON and fromJSON - -type T a = a -> Value - -genericToJSON :: (Data a) => a -> Value -genericToJSON = toJSON_generic - `ext1Q` list - `ext1Q` vector - `ext1Q` set - `ext2Q'` mapAny - `ext2Q'` hashMapAny - -- Use the standard encoding for all base types. - `extQ` (toJSON :: T Integer) - `extQ` (toJSON :: T Int) - `extQ` (toJSON :: T Int8) - `extQ` (toJSON :: T Int16) - `extQ` (toJSON :: T Int32) - `extQ` (toJSON :: T Int64) - `extQ` (toJSON :: T Word) - `extQ` (toJSON :: T Word8) - `extQ` (toJSON :: T Word16) - `extQ` (toJSON :: T Word32) - `extQ` (toJSON :: T Word64) - `extQ` (toJSON :: T Double) - `extQ` (toJSON :: T Number) - `extQ` (toJSON :: T Float) - `extQ` (toJSON :: T Rational) - `extQ` (toJSON :: T Char) - `extQ` (toJSON :: T Text) - `extQ` (toJSON :: T LT.Text) - `extQ` (toJSON :: T String) - `extQ` (toJSON :: T B.ByteString) - `extQ` (toJSON :: T LB.ByteString) - `extQ` (toJSON :: T Value) - `extQ` (toJSON :: T DotNetTime) - `extQ` (toJSON :: T UTCTime) - `extQ` (toJSON :: T IntSet) - `extQ` (toJSON :: T Bool) - `extQ` (toJSON :: T ()) - --`extQ` (T.toJSON :: T Ordering) - where - list xs = Array . V.fromList . map genericToJSON $ xs - vector v = Array . V.map genericToJSON $ v - set s = Array . V.fromList . map genericToJSON . Set.toList $ s - - mapAny m - | tyrep == typeOf T.empty = remap id - | tyrep == typeOf LT.empty = remap LT.toStrict - | tyrep == typeOf string = remap pack - | tyrep == typeOf B.empty = remap decode - | tyrep == typeOf LB.empty = remap strict - | otherwise = modError "genericToJSON" $ - "cannot convert map keyed by type " ++ show tyrep - where tyrep = typeOf . head . M.keys $ m - remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m - - hashMapAny m - | tyrep == typeOf T.empty = remap id - | tyrep == typeOf LT.empty = remap LT.toStrict - | tyrep == typeOf string = remap pack - | tyrep == typeOf B.empty = remap decode - | tyrep == typeOf LB.empty = remap strict - | otherwise = modError "genericToJSON" $ - "cannot convert map keyed by type " ++ show tyrep - where tyrep = typeOf . head . H.keys $ m - remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m - - -toJSON_generic :: (Data a) => a -> Value -toJSON_generic = generic - where - -- Generic encoding of an algebraic data type. - generic a = - case dataTypeRep (dataTypeOf a) of - -- No constructor, so it must be an error value. Code - -- it anyway as Null. - AlgRep [] -> Null - -- Elide a single constructor and just code the arguments. - AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a) - -- For multiple constructors, make an object with a - -- field name that is the constructor (except lower - -- case) and the data is the arguments encoded. - AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a) - rep -> err (dataTypeOf a) rep - where - err dt r = modError "genericToJSON" $ "not AlgRep " ++ - show r ++ "(" ++ show dt ++ ")" - -- Encode nullary constructor as a string. - -- Encode non-nullary constructors as an object with the constructor - -- name as the single field and the arguments as the value. - -- Use an array if the are no field names, but elide singleton arrays, - -- and use an object if there are field names. - encodeConstr c [] = String . constrString $ c - encodeConstr c as = object [(constrString c, encodeArgs c as)] - - constrString = pack . showConstr - - encodeArgs c = encodeArgs' (constrFields c) - encodeArgs' [] [j] = j - encodeArgs' [] js = Array . V.fromList $ js - encodeArgs' ns js = object $ zip (map mungeField ns) js - - -- Skip leading '_' in field name so we can use keywords - -- etc. as field names. - mungeField ('_':cs) = pack cs - mungeField cs = pack cs - -genericFromJSON :: (Data a) => Value -> Result a -genericFromJSON = parse genericParseJSON - -type F a = Parser a - -genericParseJSON :: (Data a) => Value -> Parser a -genericParseJSON j = parseJSON_generic j - `ext1R` list - `ext1R` vector - `ext2R'` mapAny - `ext2R'` hashMapAny - -- Use the standard encoding for all base types. - `extR` (value :: F Integer) - `extR` (value :: F Int) - `extR` (value :: F Int8) - `extR` (value :: F Int16) - `extR` (value :: F Int32) - `extR` (value :: F Int64) - `extR` (value :: F Word) - `extR` (value :: F Word8) - `extR` (value :: F Word16) - `extR` (value :: F Word32) - `extR` (value :: F Word64) - `extR` (value :: F Double) - `extR` (value :: F Number) - `extR` (value :: F Float) - `extR` (value :: F Rational) - `extR` (value :: F Char) - `extR` (value :: F Text) - `extR` (value :: F LT.Text) - `extR` (value :: F String) - `extR` (value :: F B.ByteString) - `extR` (value :: F LB.ByteString) - `extR` (value :: F Value) - `extR` (value :: F DotNetTime) - `extR` (value :: F UTCTime) - `extR` (value :: F IntSet) - `extR` (value :: F Bool) - `extR` (value :: F ()) - where - value :: (FromJSON a) => Parser a - value = parseJSON j - list :: (Data a) => Parser [a] - list = V.toList <$> genericParseJSON j - vector :: (Data a) => Parser (V.Vector a) - vector = case j of - Array js -> V.mapM genericParseJSON js - _ -> myFail - mapAny :: forall e f. (Data e, Data f) => Parser (Map f e) - mapAny - | tyrep `elem` stringyTypes = res - | otherwise = myFail - where res = case j of - Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js - _ -> myFail - trans - | tyrep == typeOf T.empty = remap id - | tyrep == typeOf LT.empty = remap LT.fromStrict - | tyrep == typeOf string = remap T.unpack - | tyrep == typeOf B.empty = remap encodeUtf8 - | tyrep == typeOf LB.empty = remap lazy - | otherwise = modError "genericParseJSON" - "mapAny -- should never happen" - tyrep = typeOf (undefined :: f) - remap f = fromJust . cast . f - hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e) - hashMapAny - | tyrep == typeOf string = process T.unpack - | tyrep == typeOf LT.empty = process LT.fromStrict - | tyrep == typeOf T.empty = process id - | otherwise = myFail - where - process f = maybe myFail return . cast =<< parseWith f - parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e) - parseWith f = case j of - Object js -> H.fromList . map (first f) . M.toList <$> - T.mapM genericParseJSON js - _ -> myFail - tyrep = typeOf (undefined :: f) - myFail = modFail "genericParseJSON" $ "bad data: " ++ show j - stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty, - typeOf LB.empty, typeOf string] - -parseJSON_generic :: (Data a) => Value -> Parser a -parseJSON_generic j = generic - where - typ = dataTypeOf $ resType generic - generic = case dataTypeRep typ of - AlgRep [] -> case j of - Null -> return (modError "genericParseJSON" "empty type") - _ -> modFail "genericParseJSON" "no-constr bad data" - AlgRep [_] -> decodeArgs (indexConstr typ 1) j - AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j' - rep -> modFail "genericParseJSON" $ - show rep ++ "(" ++ show typ ++ ")" - getConstr t (Object o) | [(s, j')] <- fromJSObject o = do - c <- readConstr' t s - return (c, j') - getConstr t (String js) = do c <- readConstr' t (unpack js) - return (c, Null) -- handle nullary ctor - getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding" - readConstr' t s = - maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++ - show t) - return $ readConstr t s - - decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0 - (constrFields c0) - where - go 0 c _ Null = construct c [] -- nullary constructor - go 1 c [] jd = construct c [jd] -- unary constructor - go n c [] (Array js) - | n > 1 = construct c (V.toList js) -- no field names - -- FIXME? We could allow reading an array into a constructor - -- with field names. - go _ c fs@(_:_) (Object o) = selectFields o fs >>= - construct c -- field names - go _ c _ jd = modFail "genericParseJSON" $ - "bad decodeArgs data " ++ show (c, jd) - - fromJSObject = map (first unpack) . M.toList - - -- Build the value by stepping through the list of subparts. - construct c = evalStateT $ fromConstrM f c - where f :: (Data a) => StateT [Value] Parser a - f = do js <- get - case js of - [] -> lift $ modFail "construct" "empty list" - (j':js') -> do put js'; lift $ genericParseJSON j' - - -- Select the named fields from a JSON object. - selectFields fjs = mapM sel - where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++ - f) return $ M.lookup (pack f) fjs - - -- Count how many arguments a constructor has. The value x is - -- used to determine what type the constructor returns. - numConstrArgs :: (Data a) => a -> Constr -> Int - numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0 - where f = do modify (+1); return undefined - - resType :: MonadPlus m => m a -> a - resType _ = modError "genericParseJSON" "resType" - -modFail :: (Monad m) => String -> String -> m a -modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err - -modError :: String -> String -> a -modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err - -string :: String -string = "" - --- Type extension for binary type constructors. - --- | Flexible type extension -ext2' :: (Data a, Typeable2 t) - => c a - -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) - -> c a -ext2' def ext = maybe def id (dataCast2 ext) - --- | Type extension of queries for type constructors -ext2Q' :: (Data d, Typeable2 t) - => (d -> q) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) - -> d -> q -ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext)) - --- | Type extension of readers for type constructors -ext2R' :: (Monad m, Data d, Typeable2 t) - => m d - -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) - -> m d -ext2R' def ext = unR ((R def) `ext2'` (R ext)) - --- | The type constructor for queries -newtype Q q x = Q { unQ :: x -> q } - --- | The type constructor for readers -newtype R m x = R { unR :: m x } +{-# LANGUAGE CPP #-} + +-- | +-- Module: Data.Aeson.Types +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types for working with JSON data. + +module Data.Aeson.Types + ( + -- * Core JSON types + Value(..) + , Array + , emptyArray + , Pair + , Object + , emptyObject + -- * Convenience types and functions + , DotNetTime(..) + , typeMismatch + -- * Type conversion + , Parser + , Result(..) + , FromJSON(..) + , fromJSON + , parse + , parseEither + , parseMaybe + , ToJSON(..) + -- * Constructors and accessors + , (.=) + , (.:) + , (.:?) + , (.!=) + , object + ) where + +import Data.Aeson.Types.Class +import Data.Aeson.Types.Internal + +#ifdef GENERICS +import Data.Aeson.Types.Generic () +#endif diff --git a/Data/Aeson/Types/Class.hs b/Data/Aeson/Types/Class.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Types/Class.hs @@ -0,0 +1,782 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances, + OverloadedStrings, UndecidableInstances, ViewPatterns #-} + +#ifdef GENERICS +{-# LANGUAGE DefaultSignatures #-} +#endif + +-- | +-- Module: Data.Aeson.Types.Class +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types for working with JSON data. + +module Data.Aeson.Types.Class + ( + -- * Type classes + -- ** Core JSON classes + FromJSON(..) + , ToJSON(..) +#ifdef GENERICS + -- ** Generic JSON classes + , GFromJSON(..) + , GToJSON(..) +#endif + -- * Types + , DotNetTime(..) + -- * Functions + , fromJSON + , (.:) + , (.:?) + , (.!=) + , (.=) + , typeMismatch + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Data.Aeson.Functions +import Data.Aeson.Types.Internal +import Data.Attoparsec.Char8 (Number(..)) +import Data.Hashable (Hashable(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Maybe (fromMaybe) +import Data.Monoid (Dual(..), First(..), Last(..)) +import Data.Ratio (Ratio) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +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) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +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 + +class GToJSON f where + gToJSON :: f a -> Value + +class GFromJSON f where + gParseJSON :: Value -> Parser (f a) +#endif + +-- | A type that can be converted to JSON. +-- +-- An example type and instance: +-- +-- @{-\# LANGUAGE OverloadedStrings #-} +-- +-- data Coord { x :: Double, y :: Double } +-- +-- instance ToJSON Coord where +-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] +-- @ +-- +-- Note the use of the @OverloadedStrings@ language extension which enables +-- 'Text' values to be written as string literals. +-- +-- Instead of manually writing your 'ToJSON' instance, there are three options +-- to do it automatically: +-- +-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an +-- instance at compile-time. The generated instance is optimized for your type +-- so will probably be more efficient than the following two options: +-- +-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any +-- type which is an instance of 'Data'. +-- +-- * If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic +-- implementation. +-- +-- To use the latter option, simply add a @deriving 'Generic'@ clause to your +-- datatype and declare a @ToJSON@ instance for your datatype without giving a +-- definition for @toJSON@. +-- +-- For example the previous example can be simplified to just: +-- +-- @{-\# LANGUAGE DeriveGeneric \#-} +-- +-- import GHC.Generics +-- +-- data Coord { x :: Double, y :: Double } deriving Generic +-- +-- instance ToJSON Coord +-- @ +class ToJSON a where + toJSON :: a -> Value + +#ifdef GENERICS + default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value + toJSON = gToJSON . from +#endif + +-- | A type that can be converted from JSON, with the possibility of +-- failure. +-- +-- When writing an instance, use 'empty', 'mzero', or 'fail' to make a +-- conversion fail, e.g. if an 'Object' is missing a required key, or +-- the value is of the wrong type. +-- +-- An example type and instance: +-- +-- @{-\# LANGUAGE OverloadedStrings #-} +-- +-- data Coord { x :: Double, y :: Double } +-- +-- instance FromJSON Coord where +-- parseJSON ('Object' v) = Coord '<$>' +-- v '.:' \"x\" '<*>' +-- v '.:' \"y\" +-- +-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail. +-- parseJSON _ = 'mzero' +-- @ +-- +-- Note the use of the @OverloadedStrings@ language extension which enables +-- 'Text' values to be written as string literals. +-- +-- Instead of manually writing your 'FromJSON' instance, there are three options +-- to do it automatically: +-- +-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an +-- instance at compile-time. The generated instance is optimized for your type +-- so will probably be more efficient than the following two options: +-- +-- * 'Data.Aeson.Generic' provides a generic @fromJSON@ function that parses to +-- any type which is an instance of 'Data'. +-- +-- * If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions, @parseJSON@ will have a default +-- generic implementation. +-- +-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and +-- declare a @FromJSON@ instance for your datatype without giving a definition +-- for @parseJSON@. +-- +-- For example the previous example can be simplified to just: +-- +-- @{-\# LANGUAGE DeriveGeneric \#-} +-- +-- import GHC.Generics +-- +-- data Coord { x :: Double, y :: Double } deriving Generic +-- +-- instance FromJSON Coord +-- @ +class FromJSON a where + parseJSON :: Value -> Parser a + +#ifdef GENERICS + default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a + parseJSON = fmap to . gParseJSON +#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 (Bool b) = pure b + parseJSON v = typeMismatch "Bool" v + {-# INLINE parseJSON #-} + +instance ToJSON () where + toJSON _ = emptyArray + {-# INLINE toJSON #-} + +instance FromJSON () where + parseJSON (Array v) | V.null v = pure () + parseJSON v = typeMismatch "()" v + {-# INLINE parseJSON #-} + +instance ToJSON [Char] where + toJSON = String . T.pack + {-# INLINE toJSON #-} + +instance FromJSON [Char] where + parseJSON (String t) = pure (T.unpack t) + parseJSON v = typeMismatch "String" v + {-# INLINE parseJSON #-} + +instance ToJSON Char where + toJSON = String . T.singleton + {-# INLINE toJSON #-} + +instance FromJSON Char where + parseJSON (String t) + | T.compareLength t 1 == EQ = pure (T.head t) + parseJSON v = typeMismatch "Char" v + {-# 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 (Number n) = pure $ case n of + D d -> toRational d + I i -> fromIntegral i + parseJSON v = typeMismatch "Ratio Integer" 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 (Number n) = pure (floor n) +parseIntegral v = typeMismatch "Integral" v +{-# 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 (String t) = pure t + parseJSON v = typeMismatch "Text" v + {-# INLINE parseJSON #-} + +instance ToJSON LT.Text where + toJSON = String . LT.toStrict + {-# INLINE toJSON #-} + +instance FromJSON LT.Text where + parseJSON (String t) = pure (LT.fromStrict t) + parseJSON v = typeMismatch "Lazy Text" v + {-# INLINE parseJSON #-} + +instance ToJSON B.ByteString where + toJSON = String . decode + {-# INLINE toJSON #-} + +instance FromJSON B.ByteString where + parseJSON (String t) = pure . encodeUtf8 $ t + parseJSON v = typeMismatch "ByteString" v + {-# INLINE parseJSON #-} + +instance ToJSON LB.ByteString where + toJSON = toJSON . strict + {-# INLINE toJSON #-} + +instance FromJSON LB.ByteString where + parseJSON (String t) = pure . lazy $ t + parseJSON v = typeMismatch "Lazy ByteString" v + {-# INLINE parseJSON #-} + +instance (ToJSON a) => ToJSON [a] where + toJSON = Array . V.fromList . map toJSON + {-# INLINE toJSON #-} + +instance (FromJSON a) => FromJSON [a] where + parseJSON (Array a) = mapM parseJSON (V.toList a) + parseJSON v = typeMismatch "[a]" v + {-# INLINE parseJSON #-} + +instance (ToJSON a) => ToJSON (Vector a) where + toJSON = Array . V.map toJSON + {-# INLINE toJSON #-} + +instance (FromJSON a) => FromJSON (Vector a) where + parseJSON (Array a) = V.mapM parseJSON a + parseJSON v = typeMismatch "Vector a" v + {-# 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 _ (Array a) = V.convert <$> V.mapM parseJSON a +vectorParseJSON s v = typeMismatch s v +{-# 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 (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o + parseJSON v = typeMismatch "Map Text a" v + +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 (M.Map B.ByteString v) where + toJSON = Object . mapHashKeyVal decode toJSON + +instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where + parseJSON = fmap (hashMapKey encodeUtf8) . parseJSON + +instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where + toJSON = Object . mapHashKeyVal strict toJSON + +instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where + parseJSON = fmap (hashMapKey lazy) . 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 (Object o) = traverse parseJSON o + parseJSON v = typeMismatch "HashMap Text a" v + +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 (H.HashMap B.ByteString v) where + toJSON = Object . mapKeyVal decode toJSON + +instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where + parseJSON = fmap (mapKey encodeUtf8) . parseJSON + +instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where + toJSON = Object . mapKeyVal strict toJSON + +instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where + parseJSON = fmap (mapKey lazy) . 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 (String t) = + case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of + Just d -> pure (DotNetTime d) + _ -> fail "could not parse .NET time" + where (s,m) = T.splitAt (T.length t - 5) t + t' = T.concat [s,".",m] + parseJSON v = typeMismatch "DotNetTime" v + {-# INLINE parseJSON #-} + +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 (String t) = + case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of + Just d -> pure d + _ -> fail "could not parse ISO-8601 date" + parseJSON v = typeMismatch "UTCTime" v + {-# 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 (Array ab) + | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0) + <*> parseJSON (V.unsafeIndex ab 1) + | otherwise = fail $ "cannot unpack array of length " ++ + show n ++ " into a pair" + where + n = V.length ab + parseJSON v = typeMismatch "(a,b)" v + {-# 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 (Array abc) + | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0) + <*> parseJSON (V.unsafeIndex abc 1) + <*> parseJSON (V.unsafeIndex abc 2) + | otherwise = fail $ "cannot unpack array of length " ++ + show n ++ " into a 3-tuple" + where + n = V.length abc + parseJSON v = typeMismatch "(a,b,c)" v + {-# 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 (Array abcd) + | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0) + <*> parseJSON (V.unsafeIndex abcd 1) + <*> parseJSON (V.unsafeIndex abcd 2) + <*> parseJSON (V.unsafeIndex abcd 3) + | otherwise = fail $ "cannot unpack array of length " ++ + show n ++ " into a 4-tuple" + where + n = V.length abcd + parseJSON v = typeMismatch "(a,b,c,d)" v + {-# 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 #-} + +-- | 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" diff --git a/Data/Aeson/Types/Generic.hs b/Data/Aeson/Types/Generic.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Types/Generic.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE DefaultSignatures + , EmptyDataDecls + , FlexibleInstances + , FunctionalDependencies + , KindSignatures + , OverlappingInstances + , ScopedTypeVariables + , TypeOperators + , UndecidableInstances + , ViewPatterns + #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Data.Aeson.Types.Generic +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types for working with JSON data. + +module Data.Aeson.Types.Generic ( ) where + +import Control.Applicative +import Control.Monad.State.Strict +import Data.Bits (shiftR) +import Data.Aeson.Types.Class +import Data.Aeson.Types.Internal +import Data.Text (pack, unpack) +import Data.DList (DList, toList) +import Data.Monoid (mappend) +import GHC.Generics +import Control.Monad.ST (ST) +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM + +-------------------------------------------------------------------------------- +-- Generic toJSON + +instance (GToJSON a) => GToJSON (M1 i c a) where + gToJSON = gToJSON . unM1 + {-# INLINE gToJSON #-} + +instance (ToJSON a) => GToJSON (K1 i a) where + gToJSON = toJSON . unK1 + {-# INLINE gToJSON #-} + +instance GToJSON U1 where + gToJSON _ = emptyArray + {-# INLINE gToJSON #-} + +instance (ConsToJSON a) => GToJSON (C1 c a) where + gToJSON = consToJSON . unM1 + {-# INLINE gToJSON #-} + +instance ( GProductToValues a, GProductToValues b + , ProductSize a, ProductSize b) => GToJSON (a :*: b) where + gToJSON p = Array $ V.create $ do + mv <- VM.unsafeNew lenProduct + gProductToValues mv 0 lenProduct p + return mv + where + lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int) + {-# INLINE gToJSON #-} + +instance (GObject a, GObject b) => GToJSON (a :+: b) where + gToJSON (L1 x) = Object $ gObject x + gToJSON (R1 x) = Object $ gObject x + {-# INLINE gToJSON #-} + +-------------------------------------------------------------------------------- + +class ConsToJSON f where consToJSON :: f a -> Value +class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value) + +newtype Tagged s b = Tagged {unTagged :: b} + +instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where + consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value)) + {-# INLINE consToJSON #-} + +instance (GRecordToPairs f) => ConsToJSON' True f where + consToJSON' = Tagged (object . toList . gRecordToPairs) + {-# INLINE consToJSON' #-} + +instance GToJSON f => ConsToJSON' False f where + consToJSON' = Tagged gToJSON + {-# INLINE consToJSON' #-} + +-------------------------------------------------------------------------------- + +class GRecordToPairs f where + gRecordToPairs :: f a -> DList Pair + +instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where + gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b + {-# INLINE gRecordToPairs #-} + +instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where + gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1)) + {-# INLINE gRecordToPairs #-} + +-------------------------------------------------------------------------------- + +class GProductToValues f where + gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s () + +instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where + gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix lenL a + gProductToValues mv ixR lenR b + where + lenL = len `shiftR` 1 + ixR = ix + lenL + lenR = len - lenL + {-# INLINE gProductToValues #-} + +instance (GToJSON a) => GProductToValues a where + gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON + {-# INLINE gProductToValues #-} + +-------------------------------------------------------------------------------- + +class GObject f where + gObject :: f a -> Object + +instance (GObject a, GObject b) => GObject (a :+: b) where + gObject (L1 x) = gObject x + gObject (R1 x) = gObject x + {-# INLINE gObject #-} + +instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where + gObject = H.singleton (pack $ conName (undefined :: t c a p)) . gToJSON + {-# INLINE gObject #-} + +-------------------------------------------------------------------------------- +-- Generic parseJSON + +instance (GFromJSON a) => GFromJSON (M1 i c a) where + gParseJSON = fmap M1 . gParseJSON + {-# INLINE gParseJSON #-} + +instance (FromJSON a) => GFromJSON (K1 i a) where + gParseJSON = fmap K1 . parseJSON + {-# INLINE gParseJSON #-} + +instance GFromJSON U1 where + gParseJSON v + | isEmptyArray v = pure U1 + | otherwise = typeMismatch "unit constructor (U1)" v + {-# INLINE gParseJSON #-} + +instance (ConsFromJSON a) => GFromJSON (C1 c a) where + gParseJSON = fmap M1 . consParseJSON + {-# INLINE gParseJSON #-} + +instance ( GFromProduct a, GFromProduct b + , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where + gParseJSON (Array arr) + | lenArray == lenProduct = gParseProduct arr 0 lenProduct + | otherwise = + fail $ "When expecting a product of " ++ show lenProduct ++ + " values, encountered an Array of " ++ show lenArray ++ + " elements instead" + where + lenArray = V.length arr + lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int) + + gParseJSON v = typeMismatch "product (:*:)" v + {-# INLINE gParseJSON #-} + +instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where + gParseJSON (Object (H.toList -> [keyVal@(key, _)])) = + case gParseSum keyVal of + Nothing -> notFound $ unpack key + Just p -> p + gParseJSON v = typeMismatch "sum (:+:)" v + {-# INLINE gParseJSON #-} + +notFound :: String -> Parser a +notFound key = fail $ "The key \"" ++ key ++ "\" was not found" +{-# INLINE notFound #-} + +-------------------------------------------------------------------------------- + +class ConsFromJSON f where consParseJSON :: Value -> Parser (f a) +class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a)) + +instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where + consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a))) + {-# INLINE consParseJSON #-} + +instance (GFromRecord f) => ConsFromJSON' True f where + consParseJSON' = Tagged parseRecord + where + parseRecord (Object obj) = gParseRecord obj + parseRecord v = typeMismatch "record (:*:)" v + {-# INLINE consParseJSON' #-} + +instance (GFromJSON f) => ConsFromJSON' False f where + consParseJSON' = Tagged gParseJSON + {-# INLINE consParseJSON' #-} + +-------------------------------------------------------------------------------- + +class GFromRecord f where + gParseRecord :: Object -> Parser (f a) + +instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where + gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj + {-# INLINE gParseRecord #-} + +instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where + gParseRecord = maybe (notFound key) gParseJSON . H.lookup (T.pack key) + where + key = selName (undefined :: t s a p) + {-# INLINE gParseRecord #-} + +-------------------------------------------------------------------------------- + +class ProductSize f where + productSize :: Tagged2 f Int + +newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b} + +instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where + productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) + + unTagged2 (productSize :: Tagged2 b Int) + +instance ProductSize (S1 s a) where + productSize = Tagged2 1 + +-------------------------------------------------------------------------------- + +class GFromProduct f where + gParseProduct :: Array -> Int -> Int -> Parser (f a) + +instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where + gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL + <*> gParseProduct arr ixR lenR + where + lenL = len `shiftR` 1 + ixR = ix + lenL + lenR = len - lenL + {-# INLINE gParseProduct #-} + +instance (GFromJSON a) => GFromProduct (S1 s a) where + gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix + {-# INLINE gParseProduct #-} + +-------------------------------------------------------------------------------- + +class GFromSum f where + gParseSum :: Pair -> Maybe (Parser (f a)) + +instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where + gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|> + (fmap R1 <$> gParseSum keyVal) + {-# INLINE gParseSum #-} + +instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where + gParseSum (key, value) + | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value + | otherwise = Nothing + {-# INLINE gParseSum #-} + +-------------------------------------------------------------------------------- + +class IsRecord (f :: * -> *) b | f -> b + +data True +data False + +instance (IsRecord f b) => IsRecord (f :*: g) b +instance IsRecord (M1 S NoSelector f) False +instance (IsRecord f b) => IsRecord (M1 S c f) b +instance IsRecord (K1 i c) True +instance IsRecord U1 False + +-------------------------------------------------------------------------------- diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Types/Internal.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-} + +-- | +-- Module: Data.Aeson.Types.Internal +-- Copyright: (c) 2011 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types for working with JSON data. + +module Data.Aeson.Types.Internal + ( + -- * Core JSON types + Value(..) + , Array + , emptyArray, isEmptyArray + , Pair + , Object + , emptyObject + -- * Type conversion + , Parser + , Result(..) + , parse + , parseEither + , parseMaybe + -- * Constructors and accessors + , object + ) where + +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Control.Monad.State.Strict +import Data.Attoparsec.Char8 (Number(..)) +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 qualified Data.HashMap.Strict as H +import qualified Data.Vector as V + +-- | The result of running a 'Parser'. +data Result a = Error String + | Success a + deriving (Eq, Show, Typeable) + +instance (NFData a) => NFData (Result a) where + rnf (Success a) = rnf a + rnf (Error err) = rnf err + +instance Functor Result where + fmap f (Success a) = Success (f a) + fmap _ (Error err) = Error err + {-# INLINE fmap #-} + +instance Monad Result where + return = Success + {-# INLINE return #-} + Success a >>= k = k a + Error err >>= _ = Error err + {-# INLINE (>>=) #-} + +instance Applicative Result where + pure = return + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance MonadPlus Result where + mzero = fail "mzero" + {-# INLINE mzero #-} + mplus a@(Success _) _ = a + mplus _ b = b + {-# INLINE mplus #-} + +instance Alternative Result where + empty = mzero + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +instance Monoid (Result a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = mplus + {-# INLINE mappend #-} + +-- | Failure continuation. +type Failure f r = String -> f r +-- | Success continuation. +type Success a f r = a -> f r + +-- | A continuation-based parser type. +newtype Parser a = Parser { + runParser :: forall f r. + Failure f r + -> Success a f r + -> f r + } + +instance Monad Parser where + m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks + in runParser m kf ks' + {-# INLINE (>>=) #-} + return a = Parser $ \_kf ks -> ks a + {-# INLINE return #-} + fail msg = Parser $ \kf _ks -> kf msg + {-# INLINE fail #-} + +instance Functor Parser where + fmap f m = Parser $ \kf ks -> let ks' a = ks (f a) + in runParser m kf ks' + {-# INLINE fmap #-} + +instance Applicative Parser where + pure = return + {-# INLINE pure #-} + (<*>) = apP + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = fail "empty" + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +instance MonadPlus Parser where + mzero = fail "mzero" + {-# INLINE mzero #-} + mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks + in runParser a kf' ks + {-# INLINE mplus #-} + +instance Monoid (Parser a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = mplus + {-# INLINE mappend #-} + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + a <- e + return (b a) +{-# INLINE apP #-} + +-- | A JSON \"object\" (key\/value map). +type Object = HashMap Text Value + +-- | A JSON \"array\" (sequence). +type Array = Vector Value + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array !Array + | String !Text + | Number !Number + | Bool !Bool + | Null + deriving (Eq, Show, Typeable) + +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 (Bool b) = rnf b + rnf Null = () + +instance IsString Value where + fromString = String . pack + {-# INLINE fromString #-} + +instance Hashable Value where + hash (Object o) = H.foldl' hashWithSalt 0 o + hash (Array a) = V.foldl' hashWithSalt 1 a + hash (String s) = 2 `hashWithSalt` s + hash (Number n) = 3 `hashWithSalt` case n of I i -> hash i; D d -> hash d + hash (Bool b) = 4 `hashWithSalt` b + hash Null = 5 + +-- | The empty array. +emptyArray :: Value +emptyArray = Array V.empty + +-- | Determines if the 'Value' is an empty 'Array'. +-- Note that: @isEmptyArray 'emptyArray'@. +isEmptyArray :: Value -> Bool +isEmptyArray (Array arr) = V.null arr +isEmptyArray _ = False + +-- | The empty object. +emptyObject :: Value +emptyObject = Object H.empty + +-- | Run a 'Parser'. +parse :: (a -> Parser b) -> a -> Result b +parse m v = runParser (m v) Error Success +{-# INLINE parse #-} + +-- | Run a 'Parser' with a 'Maybe' result type. +parseMaybe :: (a -> Parser b) -> a -> Maybe b +parseMaybe m v = runParser (m v) (const Nothing) Just +{-# INLINE parseMaybe #-} + +-- | Run a 'Parser' with an 'Either' result type. +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither m v = runParser (m v) Left Right + +-- | A key\/value pair for an 'Object'. +type Pair = (Text, Value) + +{-# INLINE parseEither #-} +-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate +-- keys arise, earlier keys and their associated values win. +object :: [Pair] -> Value +object = Object . H.fromList +{-# INLINE object #-} diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -2,28 +2,18 @@ aeson is a fast Haskell library for working with JSON data. -# Important note for users of GHCi and Template Haskell -This package depends on the [blaze-textual -package](http://hackage.haskell.org/package/blaze-textual) , and is -unfortunately subject to crashes if you use GHCi or Template Haskell -in your work. - -For complete details, including a workaround, see the writeup in [the -blaze-textual -README](https://github.com/mailrank/blaze-textual#readme). - # Join in! We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. Please report bugs via the -[github issue tracker](http://github.com/mailrank/aeson/issues). +[github issue tracker](http://github.com/bos/aeson/issues). -Master [git repository](http://github.com/mailrank/aeson): +Master [git repository](http://github.com/bos/aeson): -* `git clone git://github.com/mailrank/aeson.git` +* `git clone git://github.com/bos/aeson.git` There's also a [Mercurial mirror](http://bitbucket.org/bos/aeson): @@ -31,8 +21,8 @@ (You can create and contribute changes using either git or Mercurial.) -Authors -------- +# Authors + This library is written and maintained by Bryan O'Sullivan, -. +. diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,26 +1,33 @@ name: aeson -version: 0.3.2.14 +version: 0.4.0.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON -copyright: Copyright 2011 MailRank, Inc. -author: Bryan O'Sullivan -maintainer: Bryan O'Sullivan +copyright: (c) 2011 Bryan O'Sullivan + (c) 2011 MailRank, Inc. +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan stability: experimental -tested-with: GHC == 6.12.3 +tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2 synopsis: Fast JSON parsing and encoding cabal-version: >= 1.8 -homepage: http://github.com/mailrank/aeson -bug-reports: http://github.com/mailrank/aeson/issues +homepage: https://github.com/bos/aeson +bug-reports: https://github.com/bos/aeson/issues build-type: Simple description: A JSON parsing and encoding library optimized for ease of use and high performance. . + To get started, see the documentation for the @Data.Aeson@ module + below. + . + For release notes, see + + . /Note/: if you use GHCi or Template Haskell, please see the @README@ file for important details about building this package, and other packages that depend on it: - + . Parsing performance on a late 2010 MacBook Pro (2.66GHz Core i7), for mostly-English tweets from Twitter's JSON search API: @@ -77,26 +84,13 @@ extra-source-files: README.markdown - benchmarks/AesonEncode.hs - benchmarks/AesonParse.hs - benchmarks/JsonParse.hs + benchmarks/*.hs + benchmarks/*.py benchmarks/Makefile - benchmarks/ReadFile.hs - benchmarks/parse.py - benchmarks/json-data/example.json - benchmarks/json-data/integers.json - benchmarks/json-data/jp10.json - benchmarks/json-data/jp50.json - benchmarks/json-data/jp100.json - benchmarks/json-data/numbers.json - benchmarks/json-data/twitter1.json - benchmarks/json-data/twitter10.json - benchmarks/json-data/twitter20.json - benchmarks/json-data/twitter50.json - benchmarks/json-data/twitter100.json - tests/Makefile + benchmarks/json-data/*.json + examples/*.hs + release-notes.markdown tests/Properties.hs - examples/Demo.hs flag developer description: operate in developer mode @@ -113,7 +107,16 @@ other-modules: Data.Aeson.Functions + Data.Aeson.Parser.Internal + Data.Aeson.Types.Class + Data.Aeson.Types.Internal + if impl(ghc >= 7.2.1) + cpp-options: -DGENERICS + build-depends: ghc-prim >= 0.2, dlist >= 0.2 + other-modules: + Data.Aeson.Types.Generic + build-depends: attoparsec >= 0.8.6.1, base == 4.*, @@ -126,25 +129,42 @@ mtl, old-locale, syb, - text >= 0.11.0.2, template-haskell >= 2.4, + text >= 0.11.0.2, time, unordered-containers >= 0.1.3.0, - vector >= 0.7 + vector >= 0.7.1 if flag(developer) ghc-options: -Werror ghc-prof-options: -auto-all - if(impl(ghc >= 7.2.1)) - cpp-options: -DDEFAULT_SIGNATURES - ghc-options: -Wall +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Properties.hs + + ghc-options: + -Wall -threaded -rtsopts + + build-depends: + QuickCheck, + aeson, + attoparsec, + base, + containers, + bytestring, + template-haskell, + test-framework, + test-framework-quickcheck2, + text + source-repository head type: git - location: http://github.com/mailrank/aeson + location: git://github.com/bos/aeson.git source-repository head type: mercurial - location: http://bitbucket.org/bos/aeson + location: https://bitbucket.org/bos/aeson diff --git a/benchmarks/AesonCompareAutoInstances.hs b/benchmarks/AesonCompareAutoInstances.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AesonCompareAutoInstances.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-} + +module Main where + +-------------------------------------------------------------------------------- + +import Criterion.Main + +import Control.DeepSeq (NFData, rnf, deepseq) + +import Data.Typeable (Typeable) +import Data.Data (Data) +import GHC.Generics (Generic) + +import Data.Aeson.Types +import Data.Aeson.TH (mkToJSON, mkParseJSON) +import qualified Data.Aeson.Generic as G (fromJSON, toJSON) + +-------------------------------------------------------------------------------- + +-- Taken from the documentation of Data.Aeson.TH: +data D a = Nullary + | Unary Int + | Product String Char a + | Record { testOne :: Double + , testTwo :: Bool + , testThree :: D a + } deriving (Show, Eq, Generic, Data, Typeable) + +instance NFData a => NFData (D a) where + rnf Nullary = () + rnf (Unary n) = rnf n + rnf (Product s c x) = s `deepseq` c `deepseq` rnf x + rnf (Record d b y) = d `deepseq` b `deepseq` rnf y + +type T = D (D (D ())) + +d :: T +d = Record + { testOne = 1234.56789 + , testTwo = True + , testThree = Product "Hello World!" 'a' $ + Record + { testOne = 9876.54321 + , testTwo = False + , testThree = Product "Yeehaa!!!" '\n' Nullary + } + } + +instance ToJSON a => ToJSON (D a) +instance FromJSON a => FromJSON (D a) + +thDToJSON :: ToJSON a => D a -> Value +thDToJSON = $(mkToJSON id ''D) + +thDParseJSON :: FromJSON a => Value -> Parser (D a) +thDParseJSON = $(mkParseJSON id ''D) + +thDFromJSON :: FromJSON a => Value -> Result (D a) +thDFromJSON = parse thDParseJSON + +-------------------------------------------------------------------------------- + +data BigRecord = BigRecord + { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int + , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int + , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int + , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int + , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int + } deriving (Show, Eq, Generic, Data, Typeable) + +instance NFData BigRecord + +bigRecord = BigRecord 1 2 3 4 5 + 6 7 8 9 10 + 11 12 13 14 15 + 16 17 18 19 20 + 21 22 23 24 25 + +instance ToJSON BigRecord +instance FromJSON BigRecord + +thBigRecordToJSON :: BigRecord -> Value +thBigRecordToJSON = $(mkToJSON id ''BigRecord) + +thBigRecordParseJSON :: Value -> Parser BigRecord +thBigRecordParseJSON = $(mkParseJSON id ''BigRecord) + +thBigRecordFromJSON :: Value -> Result BigRecord +thBigRecordFromJSON = parse thBigRecordParseJSON + +-------------------------------------------------------------------------------- + +data BigProduct = BigProduct + !Int !Int !Int !Int !Int + !Int !Int !Int !Int !Int + !Int !Int !Int !Int !Int + !Int !Int !Int !Int !Int + !Int !Int !Int !Int !Int + deriving (Show, Eq, Generic, Data, Typeable) + +instance NFData BigProduct + +bigProduct = BigProduct 1 2 3 4 5 + 6 7 8 9 10 + 11 12 13 14 15 + 16 17 18 19 20 + 21 22 23 24 25 + +instance ToJSON BigProduct +instance FromJSON BigProduct + +thBigProductToJSON :: BigProduct -> Value +thBigProductToJSON = $(mkToJSON id ''BigProduct) + +thBigProductParseJSON :: Value -> Parser BigProduct +thBigProductParseJSON = $(mkParseJSON id ''BigProduct) + +thBigProductFromJSON :: Value -> Result BigProduct +thBigProductFromJSON = parse thBigProductParseJSON + +-------------------------------------------------------------------------------- + +data BigSum = F01 | F02 | F03 | F04 | F05 + | F06 | F07 | F08 | F09 | F10 + | F11 | F12 | F13 | F14 | F15 + | F16 | F17 | F18 | F19 | F20 + | F21 | F22 | F23 | F24 | F25 + deriving (Show, Eq, Generic, Data, Typeable) + +instance NFData BigSum + +bigSum = F25 + +instance ToJSON BigSum +instance FromJSON BigSum + +thBigSumToJSON :: BigSum -> Value +thBigSumToJSON = $(mkToJSON id ''BigSum) + +thBigSumParseJSON :: Value -> Parser BigSum +thBigSumParseJSON = $(mkParseJSON id ''BigSum) + +thBigSumFromJSON :: Value -> Result BigSum +thBigSumFromJSON = parse thBigSumParseJSON + +-------------------------------------------------------------------------------- + +type FJ a = Value -> Result a + +main :: IO () +main = defaultMain + [ let v = thDToJSON d + in d `deepseq` v `deepseq` + bgroup "D" + [ group "toJSON" (nf thDToJSON d) + (nf G.toJSON d) + (nf toJSON d) + , group "fromJSON" (nf (thDFromJSON :: FJ T) v) + (nf (G.fromJSON :: FJ T) v) + (nf (fromJSON :: FJ T) v) + ] + , let v = thBigRecordToJSON bigRecord + in bigRecord `deepseq` v `deepseq` + bgroup "BigRecord" + [ group "toJSON" (nf thBigRecordToJSON bigRecord) + (nf G.toJSON bigRecord) + (nf toJSON bigRecord) + , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v) + (nf (G.fromJSON :: FJ BigRecord) v) + (nf (fromJSON :: FJ BigRecord) v) + ] + , let v = thBigProductToJSON bigProduct + in bigProduct `deepseq` v `deepseq` + bgroup "BigProduct" + [ group "toJSON" (nf thBigProductToJSON bigProduct) + (nf G.toJSON bigProduct) + (nf toJSON bigProduct) + , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v) + (nf (G.fromJSON :: FJ BigProduct) v) + (nf (fromJSON :: FJ BigProduct) v) + ] + , let v = thBigSumToJSON bigSum + in bigSum `deepseq` v `deepseq` + bgroup "BigSum" + [ group "toJSON" (nf thBigSumToJSON bigSum) + (nf G.toJSON bigSum) + (nf toJSON bigSum) + , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v) + (nf (G.fromJSON :: FJ BigSum) v) + (nf (fromJSON :: FJ BigSum) v) + ] + ] + +group n th syb gen = bgroup n [ bench "th" th + , bench "syb" syb + , bench "generic" gen + ] diff --git a/benchmarks/AesonTuples.hs b/benchmarks/AesonTuples.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AesonTuples.hs @@ -0,0 +1,45 @@ +module Main where + +-------------------------------------------------------------------------------- + +import Criterion.Main +import Control.DeepSeq (deepseq) +import Data.Aeson + +-------------------------------------------------------------------------------- + +type FJ a = Value -> Result a + +type T2 = (Int, Int) +type T3 = (Int, Int, Int) +type T4 = (Int, Int, Int, Int) + +t2 :: T2 +t2 = (1, 2) + +t3 :: T3 +t3 = (1, 2, 3) + +t4 :: T4 +t4 = (1, 2, 3, 4) + +main :: IO () +main = let v2 = toJSON t2 + v3 = toJSON t3 + v4 = toJSON t4 + in t2 `deepseq` t3 `deepseq` t4 `deepseq` + v2 `deepseq` v3 `deepseq` v4 `deepseq` + defaultMain + [ bgroup "t2" + [ bench "toJSON" (nf toJSON t2) + , bench "fromJSON" (nf (fromJSON :: FJ T2) v2) + ] + , bgroup "t3" + [ bench "toJSON" (nf toJSON t3) + , bench "fromJSON" (nf (fromJSON :: FJ T3) v3) + ] + , bgroup "t4" + [ bench "toJSON" (nf toJSON t4) + , bench "fromJSON" (nf (fromJSON :: FJ T4) v4) + ] + ] diff --git a/benchmarks/Makefile b/benchmarks/Makefile --- a/benchmarks/Makefile +++ b/benchmarks/Makefile @@ -1,7 +1,7 @@ ghc := ghc ghcflags := -O -binaries := AesonParse AesonEncode JsonParse +binaries := AesonParse AesonEncode JsonParse AesonCompareAutoInstances all: $(binaries) $(binaries:%=%_p) diff --git a/benchmarks/bench-parse.py b/benchmarks/bench-parse.py new file mode 100644 --- /dev/null +++ b/benchmarks/bench-parse.py @@ -0,0 +1,55 @@ +#!/usr/bin/env python + +import os, re, subprocess, sys + +result_re = re.compile(r'^\s*(\d+) good, (\d+\.\d+)s$', re.M) + +if len(sys.argv) > 1: + parser_exe = sys.argv[1] +else: + parser_exe = './AesonParse' + +def run(count, filename): + print ' %s :: %s times' % (filename, count) + p = subprocess.Popen([parser_exe, str(count), filename], + stdout=subprocess.PIPE) + output = p.stdout.read() + p.wait() + m = result_re.search(output) + if not m: + print >> sys.stderr, 'run gave confusing output!?' + sys.stderr.write(output) + return + else: + #sys.stdout.write(output) + pass + good, elapsed = m.groups() + good, elapsed = int(good), float(elapsed) + st = os.stat(filename) + parses_per_second = good / elapsed + mb_per_second = st.st_size * parses_per_second / 1048576 + print (' %.3f seconds, %d parses/sec, %.3f MB/sec' % + (elapsed, parses_per_second, mb_per_second)) + return parses_per_second, mb_per_second, st.st_size, elapsed + +def runtimes(count, filename, times=1): + for i in xrange(times): + yield run(count, filename) + +info = ''' +json-data/twitter1.json 60000 +json-data/twitter10.json 13000 +json-data/twitter20.json 7500 +json-data/twitter50.json 2500 +json-data/twitter100.json 1000 +json-data/jp10.json 4000 +json-data/jp50.json 1200 +json-data/jp100.json 700 +''' + +for i in info.strip().splitlines(): + name, count = i.split() + best = sorted(runtimes(int(count), name, times=3), reverse=True)[0] + parses_per_second, mb_per_second, size, elapsed = best + print ('%.1f KB: %d msg\\/sec (%.1f MB\\/sec)' % + (size / 1024.0, int(round(parses_per_second)), mb_per_second)) diff --git a/benchmarks/encode.py b/benchmarks/encode.py new file mode 100644 --- /dev/null +++ b/benchmarks/encode.py @@ -0,0 +1,14 @@ +#!/usr/bin/env python + +import json, sys, time + +count = int(sys.argv[1]) + +for n in sys.argv[2:]: + print '%s:' % n + obj = json.load(open(n)) + start = time.time() + for i in xrange(count): + json.dumps(obj) + end = time.time() + print ' ', end - start diff --git a/examples/Demo.hs b/examples/Demo.hs deleted file mode 100644 --- a/examples/Demo.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Simplest example of parsing and encoding JSON with Aeson. - --- Above, we enable OverloadedStrings to allow a literal string (e.g. "name") --- to be automatically converted to Data.Text. --- This is useful when using Aeson's functions such as (.:) which expect Text. --- Without it we'd need to use pack. - -import Data.Aeson -import qualified Data.Aeson.Types as T - -import Data.Attoparsec (parse, Result(..)) -import Data.Text (Text) -import Control.Applicative ((<$>)) -import Control.Monad (mzero) -import qualified Data.ByteString.Char8 as BS --- Aeson's "encode" to JSON generates lazy bytestrings -import qualified Data.ByteString.Lazy.Char8 as BSL - --- In main we'll parse a JSON message into a Msg and display that, --- then we'll encode a different Msg as JSON, and display it. -main ::IO () -main = do - print $ parseMsgFromString exampleJSONMessage - let reply = Msg "hello Aeson!" - putStrLn $ "Encoded reply: " ++ BSL.unpack (encode reply) - --- this is the type we'll be converting to and from JSON -data Msg = Msg Text deriving (Show) - --- here's how we should parse JSON and construct a Msg -instance FromJSON Msg where - parseJSON (Object v) = Msg <$> v .: "message" - parseJSON _ = mzero - --- here's how we should encode a Msg as JSON -instance ToJSON Msg where - toJSON (Msg s) = object [ "message" .= s] - --- Here's one way to actually run the parsers. --- --- Note that we do two parses: --- once into JSON then one more into our final type. --- There are a number of choices when dealing with parse failures. --- Here we've chosen to parse to Maybe Msg, and a Nothing will be returned --- if parseJSON fails. (More informative options are available.) --- --- This should take us (depending on success or failure) --- from {"message": "hello world"} to Just (Msg "hello world") --- or to Nothing --- --- Note also that we have not checked here that the input has been completely --- consumed, so: --- {"message": "hello world"} foo BIG mistake --- would yield the same successfully translated message! --- We could look in "rest" for the remainder. -parseMsgFromString :: String -> Maybe Msg -parseMsgFromString s = - let bs = BS.pack s - in case parse json bs of - (Done rest r) -> T.parseMaybe parseJSON r :: Maybe Msg - _ -> Nothing - --- Here's the example JSON message we're going to try to parse: --- {"message": "hello world"} --- It's a JSON object with a single pair, having key 'message', and a string value. --- It could have more fields and structure, but that's all we're going to parse out of it. -exampleJSONMessage :: String -exampleJSONMessage = "{\"message\":\"hello world\"}" diff --git a/examples/Generic.hs b/examples/Generic.hs new file mode 100644 --- /dev/null +++ b/examples/Generic.hs @@ -0,0 +1,38 @@ +-- This example is basically the same as in Simplest.hs, only it uses +-- GHC's builtin generics instead of explicit instances of ToJSON and +-- FromJSON. + +-- This example only works with GHC 7.2 or newer, as it uses the +-- datatype-generic programming machinery introduced in 7.2. + +-- We enable the DeriveGeneric language extension so that GHC can +-- automatically derive the Generic class for us. + +{-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import qualified Data.ByteString.Lazy.Char8 as BL + +-- To decode or encode a value using the generic machinery, we must +-- make the type an instance of the Generic class. + +import GHC.Generics (Generic) + +data Coord = Coord { x :: Double, y :: Double } + deriving (Show, Generic) + +-- While we still have to declare our type as instances of FromJSON +-- and ToJSON, we do *not* need to provide bodies for the instances. +-- Default versions will be supplied for us. + +instance FromJSON Coord +instance ToJSON Coord + +main :: IO () +main = do + let req = decode "{\"x\":3.0,\"y\":-1.0}" :: Maybe Coord + print req + let reply = Coord 123.4 20 + BL.putStrLn (encode reply) diff --git a/examples/GenericSYB.hs b/examples/GenericSYB.hs new file mode 100644 --- /dev/null +++ b/examples/GenericSYB.hs @@ -0,0 +1,30 @@ +-- This example is basically the same as in Simplest.hs, only it uses +-- SYB generics instead of explicit instances of ToJSON and FromJSON. + +-- This mechanism is much slower than the newer generics mechanism +-- demonstrated in Generic.hs, but it works on versions of GHC older +-- than 7.2. + +-- We enable the DeriveDataTypeable language extension so that GHC can +-- automatically derive the Typeable and Data classes for us. + +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE OverloadedStrings #-} + +import Data.Data (Typeable, Data) +import Data.Aeson.Generic (decode, encode) +import qualified Data.ByteString.Lazy.Char8 as BL + +-- To decode or encode a value using the generic machinery, we must +-- make the type an instance of the Typeable and Data classes. + +data Coord = Coord { x :: Double, y :: Double } + deriving (Show, Typeable, Data) + +main :: IO () +main = do + let req = decode "{\"x\":3.0,\"y\":-1.0}" :: Maybe Coord + print req + let reply = Coord 123.4 20 + BL.putStrLn (encode reply) diff --git a/examples/Simplest.hs b/examples/Simplest.hs new file mode 100644 --- /dev/null +++ b/examples/Simplest.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative ((<$>), (<*>), empty) +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BL + +data Coord = Coord { x :: Double, y :: Double } + deriving (Show) + +-- A ToJSON instance allows us to encode a value as JSON. + +instance ToJSON Coord where + toJSON (Coord xV yV) = object [ "x" .= xV, + "y" .= yV ] + +-- A FromJSON instance allows us to decode a value from JSON. This +-- should match the format used by the ToJSON instance. + +instance FromJSON Coord where + parseJSON (Object v) = Coord <$> + v .: "x" <*> + v .: "y" + parseJSON _ = empty + +main :: IO () +main = do + let req = decode "{\"x\":3.0,\"y\":-1.0}" :: Maybe Coord + print req + let reply = Coord 123.4 20 + BL.putStrLn (encode reply) diff --git a/examples/TemplateHaskell.hs b/examples/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/examples/TemplateHaskell.hs @@ -0,0 +1,29 @@ +-- We can use Template Haskell (TH) to generate instances of the +-- FromJSON and ToJSON classes automatically. This is the fastest way +-- to add JSON support for a type. + +{-# LANGUAGE TemplateHaskell #-} + +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson (decode, encode) +import Data.Aeson.TH (deriveJSON) +import qualified Data.ByteString.Lazy.Char8 as BL + +data Coord = Coord { x :: Double, y :: Double } + deriving (Show) + +-- This splice will derive instances of ToJSON and FromJSON for us. +-- +-- The use of "id" below is a placeholder function to transform the +-- names of the type's fields. We don't want to transform them, so we +-- use the identity function. + +$(deriveJSON id ''Coord) + +main :: IO () +main = do + let req = decode "{\"x\":3.0,\"y\":-1.0}" :: Maybe Coord + print req + let reply = Coord 123.4 20 + BL.putStrLn (encode reply) diff --git a/release-notes.markdown b/release-notes.markdown new file mode 100644 --- /dev/null +++ b/release-notes.markdown @@ -0,0 +1,68 @@ +# 0.3 to 0.4 + +## Ease of use + +The new [`decode` +function](http://hackage.haskell.org/packages/archive/aeson/latest/doc/html/Data-Aeson.html#v:decode) +complements the longstanding `encode` function, and makes the API +simpler. + +[New examples](https://github.com/bos/aeson/tree/master/examples) make +it easier to learn to use the package. + + +## Generics support + +aeson's support for data-type generic programming makes it possible to +use JSON encodings of most data types without writing any boilerplate +instances. + +Thanks to Bas Van Dijk, aeson now supports the two major schemes for +doing datatype-generic programming: + +* the modern mechanism, [built into GHC + itself](http://www.haskell.org/ghc/docs/latest/html/users_guide/generic-programming.html) + +* the older mechanism, based on SYB (aka "scrap your boilerplate") + +The modern GHC-based generic mechanism is fast and terse: in fact, its +performance is generally comparable in performance to hand-written and +TH-derived `ToJSON` and `FromJSON` instances. To see how to use GHC +generics, refer to +[`examples/Generic.hs`](https://github.com/bos/aeson/blob/master/examples/Generic.hs). + +The SYB-based generics support lives in +[Data.Aeson.Generic](http://hackage.haskell.org/packages/archive/aeson/latest/doc/html/Data-Aeson-Generic.html), +and is provided mainly for users of GHC older than 7.2. SYB is far +slower (by about 10x) than the more modern generic mechanism. To see +how to use SYB generics, refer to +[`examples/GenericSYB.hs`](https://github.com/bos/aeson/blob/master/examples/GenericSYB.hs). + + +## Improved performance + +* We switched the intermediate representation of JSON objects from + `Data.Map` to + [`Data.HashMap`](http://hackage.haskell.org/package/unordered-containers), + which has improved type conversion performance. + +* Instances of `ToJSON` and `FromJSON` for tuples are between 45% and + 70% faster than in 0.3. + + +## Evaluation control + +This version of aeson makes explicit the decoupling between +*identifying* an element of a JSON document and *converting* it to +Haskell. See the +[`Data.Aeson.Parser`](http://hackage.haskell.org/packages/archive/aeson/latest/doc/html/Data-Aeson-Parser.html) +documentation for details. + +The normal aeson `decode` function performs identification strictly, +but defers conversion until needed. This can result in improved +performance (e.g. if the results of some conversions are never +needed), but at a cost in increased memory consumption. + +The new `decode'` function performs identification and conversion +immediately. This incurs an up-front cost in CPU cycles, but reduces +reduce memory consumption. diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -ghc := ghc - -all: qc - -qc: Properties.hs - $(ghc) -Wall -o -threaded --make $@ $< - -clean: - -rm -f qc *.o *.hi diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,37 +1,48 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards, + ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Control.Monad +import Control.Applicative import Data.Aeson.Encode import Data.Aeson.Parser (value) import Data.Aeson.Types import Data.Attoparsec.Number +import Data.Data (Typeable, Data) +import Data.Text (Text) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary) -import qualified Data.ByteString.Lazy.Char8 as L +import Test.QuickCheck (Arbitrary(..)) +import qualified Data.Aeson.Generic as G import qualified Data.Attoparsec.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Text as T +import qualified Data.Map as Map encodeDouble :: Double -> Double -> Bool encodeDouble num denom | isInfinite d || isNaN d = encode (Number (D d)) == "null" - | otherwise = encode (Number (D d)) == L.pack (show d) + | otherwise = (read . L.unpack . encode . Number . D) d == d where d = num / denom encodeInteger :: Integer -> Bool encodeInteger i = encode (Number (I i)) == L.pack (show i) -roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> Bool -roundTrip eq i = +roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool +roundTrip eq _ i = case fmap fromJSON . L.parse value . encode . toJSON $ i of L.Done _ (Success v) -> v `eq` i _ -> False -roundTripBool :: Bool -> Bool -roundTripBool = roundTrip (==) -roundTripDouble :: Double -> Bool -roundTripDouble = roundTrip approxEq -roundTripInteger :: Integer -> Bool -roundTripInteger = roundTrip (==) +roundTripEq :: (Eq a, FromJSON a, ToJSON a) => a -> a -> Bool +roundTripEq x y = roundTrip (==) x y +genericTo :: (Data a, ToJSON a) => a -> a -> Bool +genericTo _ v = G.toJSON v == toJSON v + +genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool +genericFrom _ v = G.fromJSON (toJSON v) == Success v + approxEq :: Double -> Double -> Bool approxEq a b = a == b || d < maxAbsoluteError || @@ -45,6 +56,62 @@ Error _ -> False Success x' -> x == x' +genericToFromJSON :: (Arbitrary a, Eq a, Data a) => a -> Bool +genericToFromJSON x = case G.fromJSON . G.toJSON $ x of + Error _ -> False + Success x' -> x == x' + + +data Foo = Foo { + fooInt :: Int + , fooDouble :: Double + , fooTuple :: (String, Text, Int) + -- This definition causes an infinite loop in genericTo and genericFrom! + -- , fooMap :: Map.Map String Foo + , fooMap :: Map.Map String (Text,Int) + } deriving (Show, Typeable, Data) + +instance Eq Foo where + a == b = fooInt a == fooInt b && + fooDouble a `approxEq` fooDouble b && + fooTuple a == fooTuple b + +instance ToJSON Foo where + toJSON Foo{..} = object [ "fooInt" .= fooInt + , "fooDouble" .= fooDouble + , "fooTuple" .= fooTuple + , "fooMap" .= fooMap + ] + +instance FromJSON Foo where + parseJSON (Object v) = Foo <$> + v .: "fooInt" <*> + v .: "fooDouble" <*> + v .: "fooTuple" <*> + v .: "fooMap" + parseJSON _ = empty + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where + arbitrary = Map.fromList <$> arbitrary + +instance Arbitrary Foo where + arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary + +{- + Test for Data.Aeson.Generic handling '_' names +-} +data UFoo = UFoo { + _UFooInt :: Int + , uFooInt :: Int + } deriving (Show, Eq, Data, Typeable) + +instance Arbitrary UFoo where + arbitrary = UFoo <$> arbitrary <*> arbitrary + where _ = uFooInt + main :: IO () main = defaultMain tests @@ -54,10 +121,26 @@ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger ], + testGroup "genericFrom" [ + testProperty "Bool" $ genericFrom True + , testProperty "Double" $ genericFrom (1::Double) + , testProperty "Int" $ genericFrom (1::Int) + , testProperty "Foo" $ genericFrom (undefined::Foo) + ], + testGroup "genericTo" [ + testProperty "Bool" $ genericTo True + , testProperty "Double" $ genericTo (1::Double) + , testProperty "Int" $ genericTo (1::Int) + , testProperty "Foo" $ genericTo (undefined::Foo) + ], testGroup "roundTrip" [ - testProperty "roundTripBool" roundTripBool - , testProperty "roundTripDouble" roundTripDouble - , testProperty "roundTripInteger" roundTripInteger + testProperty "Bool" $ roundTripEq True + , testProperty "Double" $ roundTrip approxEq (1::Double) + , testProperty "Int" $ roundTripEq (1::Int) + , testProperty "Integer" $ roundTripEq (1::Integer) + , testProperty "String" $ roundTripEq (""::String) + , testProperty "Text" $ roundTripEq T.empty + , testProperty "Foo" $ roundTripEq (undefined::Foo) ], testGroup "toFromJSON" [ testProperty "Integer" (toFromJSON :: Integer -> Bool) @@ -65,5 +148,8 @@ , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Bool) , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Bool) , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Bool) + ], + testGroup "genericToFromJSON" [ + testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool) ] ]