RFC: Object parser

Data/Aeson/Types/ObjectParser.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE GADTs, PatternGuards #-}
+module Data.Aeson.Types.ObjectParser (
+    ObjectParser,
+    withObjectParser,
+    withObjectParser',
+    runObjectParser,
+    runObjectParser',
+    liftObjectParser,
+    explicitObjectField,
+    objectField,
+    ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Text (Text)
+import qualified Data.HashSet as HS
+
+import Data.Aeson.Types.Internal
+import Data.Aeson.Types.FromJSON
+
+-- | Applicative Object parser
+data ObjectParser a = OP
+    { runObjectParser :: !(Object -> Parser a)
+    , _opKeys         :: !(HS.HashSet Text)
+    -- TODO: maybe fields
+    }
+
+instance Functor ObjectParser where
+    fmap f (OP x ks) = OP (fmap f . x) ks
+    {-# INLINE fmap #-}
+
+instance Applicative ObjectParser where
+    pure x = OP (\_ -> pure x) mempty
+    OP f ks <*> OP x ks' = OP (\obj -> f obj <*> x obj) (HS.union ks ks')
+    {-# INLINE (<*>) #-}
+
+withObjectParser :: String -> ObjectParser a -> Value -> Parser a
+withObjectParser name p = withObject name (runObjectParser p)
+
+withObjectParser'
+    :: String
+    -> ObjectParser a
+    -> HS.HashSet Text  -- ^ required
+    -> HS.HashSet Text  -- ^ optional
+    -> Value -> Parser a
+withObjectParser' name p req opt = withObject name (runObjectParser' p req opt)
+
+liftObjectParser :: Text -> (Value -> Parser a) -> ObjectParser a
+liftObjectParser k p = OP (\obj -> explicitParseField p obj k) (HS.singleton k)
+{-# INLINE liftObjectParser #-}
+
+explicitObjectField :: Text -> (Value -> Parser a) -> ObjectParser a
+explicitObjectField = liftObjectParser
+
+objectField :: FromJSON a => Text -> ObjectParser a
+objectField k = explicitObjectField k parseJSON
+
+-- | Strict 'runObjectParser'.
+--
+-- First checks that there aren't extra keys in the 'Object'.
+runObjectParser'
+    :: ObjectParser a
+    -> HS.HashSet Text  -- additional required keys, these keys MUST be present
+    -> HS.HashSet Text  -- additional optional keys, these keys MAY be present
+    -> Object
+    -> Parser a
+runObjectParser' (OP p ks) ks' os' obj
+    | Just missing <- required `isSubsetOf` keys =
+        -- take only few keys to have reasonable sized errors
+        fail $ "Not all required keys present: " ++ show (take 3 $ HS.toList missing)
+    | Just extra <-  keys `isSubsetOf` optional =
+        fail $ "Extra keys present: " ++ show (take 3 $ HS.toList extra)
+    | otherwise                        = p obj
+  where
+    keys = HS.fromMap (() <$ obj)
+    required = HS.union ks ks'
+    optional = HS.union required os'
+
+-- Special case: Nothing = True, Just extraKeys = False
+isSubsetOf :: HS.HashSet Text -> HS.HashSet Text -> Maybe (HS.HashSet Text)
+isSubsetOf as bs
+    | HS.null cs = Nothing
+    | otherwise  = Just cs
+  where
+    cs = HS.difference as bs

aeson.cabal

@@ -104,11 +104,12 @@ library
     Data.Aeson.Parser.Internal
     Data.Aeson.Parser.Unescape
     Data.Aeson.Parser.Time
+    Data.Aeson.Types.Class
     Data.Aeson.Types.FromJSON
     Data.Aeson.Types.Generic
-    Data.Aeson.Types.ToJSON
-    Data.Aeson.Types.Class
     Data.Aeson.Types.Internal
+    Data.Aeson.Types.ObjectParser
+    Data.Aeson.Types.ToJSON
     Data.Attoparsec.Time
     Data.Attoparsec.Time.Internal
 

benchmarks/Typed/Manual.hs

@@ -47,6 +47,12 @@ decodeDirectA = decode
 decodeDirectB :: L.ByteString -> Maybe Result
 decodeDirectB = B.decode
 
+decodeObjectB :: L.ByteString -> Maybe Result
+-- decodeObjectB = fmap R . B.decode
+decodeObjectB b = case  B.eitherDecode b of
+    Right (R r) -> Just r
+    Left err    -> error err
+
 decodeBenchmarks :: Benchmark
 decodeBenchmarks =
   env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->
@@ -57,4 +63,8 @@ decodeBenchmarks =
       , bench "twitter100 baseline"  $ nf decodeDirectA twitter100
       , bench "jp100 baseline"      $ nf decodeDirectA jp100
       ]
+    , bgroup "object-parser"
+      [ bench "twitter100"          $ nf decodeObjectB twitter100
+      , bench "jp100"               $ nf decodeObjectB jp100
+      ]
     ]

benchmarks/aeson-benchmarks.cabal

@@ -33,6 +33,7 @@ library
     Data.Aeson.Types.FromJSON
     Data.Aeson.Types.Generic
     Data.Aeson.Types.Internal
+    Data.Aeson.Types.ObjectParser
     Data.Aeson.Types.ToJSON
     Data.Attoparsec.Time
     Data.Attoparsec.Time.Internal
@@ -142,7 +143,8 @@ executable aeson-benchmark-typed
     deepseq,
     ghc-prim,
     text,
-    time
+    time,
+    unordered-containers
 
   if flag(bytestring-builder)
     build-depends: bytestring >= 0.9 && < 0.10.4,

examples/Twitter/Manual.hs

@@ -15,6 +15,10 @@ module Twitter.Manual
     , Geo(..)
     , Story(..)
     , Result(..)
+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS
+    -- * object parsers
+    , R (..)
+#endif
     ) where
 
 import Prelude ()
@@ -30,6 +34,11 @@ import Data.Aeson hiding (Result)
 #else
 import "aeson" Data.Aeson hiding (Result)
 import qualified "aeson-benchmarks" Data.Aeson as B
+import qualified "aeson-benchmarks" Data.Aeson.Types as B
+import qualified "aeson-benchmarks" Data.Aeson.Types.ObjectParser as B
+
+import qualified Data.HashSet as HS
+
 #endif
 
 instance ToJSON Metadata where
@@ -156,6 +165,8 @@ instance FromJSON Result where
     <*> v .: "query"
   parseJSON _ = empty
 
+
+
 #ifdef HAS_BOTH_AESON_AND_BENCHMARKS
 instance B.ToJSON Metadata where
   toJSON Metadata{..} = B.object [
@@ -220,8 +231,8 @@ instance B.ToJSON Story where
     <> "source"            B..= source
 
 instance B.FromJSON Story where
-  parseJSON (B.Object v) = Story <$>
-        v B..: "from_user_id_str"
+  parseJSON = B.withObject "Story" $ \v -> Story
+    <$> v B..: "from_user_id_str"
     <*> v B..: "profile_image_url"
     <*> v B..: "created_at"
     <*> v B..: "from_user"
@@ -235,7 +246,28 @@ instance B.FromJSON Story where
     <*> v B..: "iso_language_code"
     <*> v B..: "to_user_id_str"
     <*> v B..: "source"
-  parseJSON _ = empty
+
+storyObjectParser :: B.ObjectParser Story
+storyObjectParser = Story
+    <$> B.objectField "from_user_id_str"
+    <*> B.objectField "profile_image_url"
+    <*> B.objectField "created_at"
+    <*> B.objectField "from_user"
+    <*> B.objectField "id_str"
+    <*> B.objectField "metadata"
+    <*> B.objectField "to_user_id"
+    <*> B.objectField "text"
+    <*> B.objectField "id"
+    <*> B.objectField "from_user_id"
+    <*> B.objectField "geo"
+    <*> B.objectField "iso_language_code"
+    <*> B.objectField "to_user_id_str"
+    <*> B.objectField "source"
+
+parseStory :: B.Value -> B.Parser Story
+parseStory =  B.withObjectParser' "Story" storyObjectParser
+    mempty
+    (HS.fromList ["to_user", "place"])
 
 instance B.ToJSON Result where
   toJSON Result{..} = B.object [
@@ -279,4 +311,25 @@ instance B.FromJSON Result where
     <*> v B..: "max_id_str"
     <*> v B..: "query"
   parseJSON _ = empty
+
+newtype R = R { getR :: Result }
+
+instance B.FromJSON R where
+    parseJSON = B.withObjectParser' "Result" (fmap R resultObjectParser)
+        mempty
+        (HS.fromList ["warning"])
+
+resultObjectParser :: B.ObjectParser Result
+resultObjectParser = Result
+    <$> B.explicitObjectField "results" (B.listParser parseStory)
+    <*> B.objectField "max_id"
+    <*> B.objectField "since_id"
+    <*> B.objectField "refresh_url"
+    <*> B.objectField "next_page"
+    <*> B.objectField "results_per_page"
+    <*> B.objectField "page"
+    <*> B.objectField "completed_in"
+    <*> B.objectField "since_id_str"
+    <*> B.objectField "max_id_str"
+    <*> B.objectField "query"
 #endif