From 09a7a889468653cd5b801b1ec247d349dfe03335 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 13 Jul 2017 15:15:07 +0300 Subject: [PATCH] WIP: ObjectParser --- Data/Aeson/Types/ObjectParser.hs | 86 +++++++++++++++++++++++++++++++ aeson.cabal | 5 +- benchmarks/Typed/Manual.hs | 10 ++++ benchmarks/aeson-benchmarks.cabal | 4 +- examples/Twitter/Manual.hs | 59 +++++++++++++++++++-- 5 files changed, 158 insertions(+), 6 deletions(-) create mode 100644 Data/Aeson/Types/ObjectParser.hs diff --git a/Data/Aeson/Types/ObjectParser.hs b/Data/Aeson/Types/ObjectParser.hs new file mode 100644 index 000000000..5c224a47a --- /dev/null +++ b/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 diff --git a/aeson.cabal b/aeson.cabal index a16c3dcd1..39e84aaa9 100644 --- a/aeson.cabal +++ b/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 diff --git a/benchmarks/Typed/Manual.hs b/benchmarks/Typed/Manual.hs index c633c6e1f..28404f786 100644 --- a/benchmarks/Typed/Manual.hs +++ b/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 + ] ] diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal index 69f56e15a..e148a6041 100644 --- a/benchmarks/aeson-benchmarks.cabal +++ b/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, diff --git a/examples/Twitter/Manual.hs b/examples/Twitter/Manual.hs index 5476ecead..62995c5a8 100644 --- a/examples/Twitter/Manual.hs +++ b/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