aeson 0.3.2.14 → 0.4.0.0

raw patch · 26 files changed

+3008/−1577 lines, 26 filesdep +QuickCheckdep +aesondep +dlistdep ~attoparsecdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, dlist, ghc-prim, test-framework, test-framework-quickcheck2

Dependency ranges changed: attoparsec, base, template-haskell, text, vector

API changes (from Hackage documentation)

Files

• Data/Aeson.hs +34/−7
• Data/Aeson/Encode.hs +3/−3
• Data/Aeson/Functions.hs +33/−20
• Data/Aeson/Generic.hs +347/−9
• Data/Aeson/Parser.hs +41/−131
• Data/Aeson/Parser/Internal.hs +258/−0
• Data/Aeson/TH.hs +287/−130
• Data/Aeson/Types.hs +48/−1133
• Data/Aeson/Types/Class.hs +782/−0
• Data/Aeson/Types/Generic.hs +284/−0
• Data/Aeson/Types/Internal.hs +223/−0
• README.markdown +6/−16
• aeson.cabal +53/−33
• benchmarks/AesonCompareAutoInstances.hs +198/−0
• benchmarks/AesonTuples.hs +45/−0
• benchmarks/Makefile +1/−1
• benchmarks/bench-parse.py +55/−0
• benchmarks/encode.py +14/−0
• examples/Demo.hs +0/−70
• examples/Generic.hs +38/−0
• examples/GenericSYB.hs +30/−0
• examples/Simplest.hs +30/−0
• examples/TemplateHaskell.hs +29/−0
• release-notes.markdown +68/−0
• tests/Makefile +0/−9
• tests/Properties.hs +101/−15

@@ -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 <bos@mailrank.com>+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- 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' #-}

@@ -4,7 +4,7 @@ -- Module:      Data.Aeson.Encode -- Copyright:   (c) 2011 MailRank, Inc. -- License:     Apache--- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- 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

@@ -1,15 +1,23 @@+-- |+-- Module:      Data.Aeson.Functions+-- Copyright:   (c) 2011 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     Apache+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- 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

@@ -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 <bos@mailrank.com>+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- 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 }

@@ -4,149 +4,59 @@ -- Module:      Data.Aeson.Parser -- Copyright:   (c) 2011 MailRank, Inc. -- License:     Apache--- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com> -- 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.

@@ -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 <bos@serpentine.com>+-- 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&#xef;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.

@@ -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 \"\<error message\>\"+                          _ -> fail \"\<error message\>\"+                    | 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 \"\<error message\>\"+                          _ -> fail \"\<error message\>\"+                    | 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 \"\<error message\>\"+                          _ -> fail \"\<error message\>\"+                    | otherwise -> fail \"\<error message\>\"+              _ -> fail \"\<error message\>\"+          _ -> fail \"\<error message\>\" @ +Note that every \"\<error message\>\" 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 \"\<error message\>\"+--                     other -> fail \"\<error message\>\" -- @ 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 .: "<FIELD>""-         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.! <IX>)"+         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"          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"

@@ -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 <bos@mailrank.com>--- 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 <bos@serpentine.com>+-- 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

@@ -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 <bos@serpentine.com>+-- 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"

@@ -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 <bos@serpentine.com>+-- 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++--------------------------------------------------------------------------------

@@ -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 <bos@serpentine.com>+-- 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 #-}

@@ -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,-<bos@mailrank.com>.+<bos@serpentine.com>.

@@ -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 <bos@mailrank.com>-maintainer:      Bryan O'Sullivan <bos@mailrank.com>+copyright:       (c) 2011 Bryan O'Sullivan+                 (c) 2011 MailRank, Inc.+author:          Bryan O'Sullivan <bos@serpentine.com>+maintainer:      Bryan O'Sullivan <bos@serpentine.com> 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+    <https://github.com/bos/aeson/blob/master/release-notes.markdown>+    .     /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:-    <https://github.com/mailrank/aeson#readme>+    <https://github.com/bos/aeson#readme>     .     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

@@ -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+                              ]

@@ -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)+                ]+              ]

@@ -1,7 +1,7 @@ ghc := ghc ghcflags := -O -binaries := AesonParse AesonEncode JsonParse+binaries := AesonParse AesonEncode JsonParse AesonCompareAutoInstances  all: $(binaries) $(binaries:%=%_p) 

@@ -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))

@@ -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

@@ -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\"}"

@@ -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)

@@ -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)

@@ -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)

@@ -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)

@@ -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.

@@ -1,9 +0,0 @@-ghc := ghc--all: qc--qc: Properties.hs-	$(ghc) -Wall -o -threaded --make $@ $<--clean:-	-rm -f qc *.o *.hi

@@ -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)     ]   ]