Commits

Bryan O'Sullivan committed 3bebcc6 Merge

Merge

Comments (0)

Files changed (18)

File contents unchanged.

 -- Module:      Data.Aeson
 -- 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
 --
 
 module Data.Aeson
     (
+    -- * Encoding and decoding
+      decode
+    , encode
     -- * Core JSON types
-      Value(..)
+    , Value(..)
     , Array
     , Object
     -- * Convenience types
     , (.=)
     , (.:)
     , (.:?)
+    , (.:/)
     , object
-    -- * Encoding and parsing
-    , encode
+    -- * Parsing
     , json
     ) where
 
-import Data.Aeson.Encode
-import Data.Aeson.Parser
+import Data.Aeson.Encode (encode)
+import Data.Aeson.Parser (json)
 import Data.Aeson.Types
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Attoparsec.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.
+decode :: (FromJSON a) => L.ByteString -> Maybe a
+decode s = case L.parse json s of
+             L.Done _ v -> case fromJSON v of
+                             Success a -> Just a
+                             _         -> Nothing
+             _          -> Nothing
+{-# INLINE decode #-}

Data/Aeson/Encode.hs

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

Data/Aeson/Functions.hs

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

Data/Aeson/Generic.hs

-{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables  #-}
+{-# LANGUAGE PatternGuards, Rank2Types, ScopedTypeVariables #-}
 
 -- |
 -- Module:      Data.Aeson.Generic
 -- Copyright:   (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
 --
     , 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
+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 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
+
+type T a = a -> Value
+
+toJSON :: (Data a) => a -> Value
+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 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 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 = genericFromJSON
+fromJSON = parse parseJSON
 
-toJSON :: (Data a) => a -> Value
-toJSON = genericToJSON
+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 }

Data/Aeson/Parser.hs

 -- 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
 --
 module Data.Aeson.Parser
     (
       json
+    , json'
     , value
+    , value'
     , jstring
     ) where
 
 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 qualified Data.Attoparsec.Zepto as Z
 import qualified Data.ByteString.Char8 as B8
 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.
 json :: Parser Value
-json = do
-  c <- skipSpace *> satisfy (`B8.elem` "{[")
-  if c == '{'
-    then object_
-    else array_
+json = json_ object_ array_
+
+-- | Parse a top-level JSON value.  This must be either an object or
+-- an array.
+--
+-- This is a strict parser version of 'json' which avoids
+-- building up thunks during parsing. 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_" #-} do
+object_ = {-# SCC "object_" #-} Object <$> objectValues value
+
+object_' :: Parser Value
+object_' = {-# SCC "object_'" #-} do
+  !vals <- objectValues value'
+  return (Object vals)
+
+objectValues :: Parser Value -> Parser (H.HashMap Text Value)
+objectValues val = do
   skipSpace
   let pair = do
         a <- jstring <* skipSpace
-        b <- char ':' *> skipSpace *> value
+        b <- char ':' *> skipSpace *> val
         return (a,b)
   vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
-  return . Object $ Map.fromList vals
+  return (H.fromList vals)
+{-# INLINE objectValues #-}
 
 array_ :: Parser Value
-array_ = {-# SCC "array_" #-} do
+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 <- ((value <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
-  return . Array $ Vector.fromList vals
+  vals <- ((val <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
+  return (Vector.fromList vals)
+{-# INLINE arrayValues #-}
 
 -- | Parse any JSON value.  Use 'json' in preference to this function
 -- if you are parsing data from an untrusted source.
       '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
 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
       \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
                                  ]
                      ]
 @
       \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.
 
 @
 >>> 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
 --------------------------------------------------------------------------------
 
 -- 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 )
 
 
 --------------------------------------------------------------------------------
 -- 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.
 -- 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:
           []
 -- 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)
           []
 -- Example:
 --
 -- @
--- data Foo = Foo 'Char' 'Int'
--- $('deriveFromJSON' 'id' ''Foo)
+-- data Foo = Foo Char Int
+-- $('deriveFromJSON' id ''Foo)
 -- @
 --
 -- This will splice in the following code:
 -- 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.
                   (classType `appT` instanceType)
                   [ funD 'parseJSON
                          [ clause []
-                                  (normalB $ consFromJSON withField cons)
+                                  (normalB $ consFromJSON name withField cons)
                                   []
                          ]
                   ]
 --
 -- @
 -- 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"
   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)
                                               `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)
                )
                []
     ]
-
 -- 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
 
 
 --------------------------------------------------------------------------------
 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"

Data/Aeson/Types.hs

-{-# 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>
+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
 -- Stability:   experimental
 -- Portability: portable
 --
     , (.=)
     , (.:)
     , (.:?)
+    , (.:/)
     , 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
+import Data.Aeson.Types.Class
+import Data.Aeson.Types.Internal
 
-
--- | 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) = 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) = 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
+#ifdef GENERICS
+import Data.Aeson.Types.Generic ()
 #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