diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Revision history for hermes-json +## 0.6.1.0 -- 2023-08-27 + +### Changed +* Bump upper bounds on dependencies + +### Fixed +* Fix bug in `FieldsDecoder` `Alternative` instance that was causing seg faults + on missing keys + +### Added +* Add `liftObjectDecoder` +* Add `objectAsMapExcluding` +* Add `formatException` + ## 0.6.0.0 -- 2023-08-22 ### Breaking Changes: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -79,6 +79,10 @@ * Partial decoding of Twitter status objects to highlight the on-demand benefits * Decoding entire documents into `Data.Aeson.Value` +Please be aware that GHC does not report C-allocated memory. simdjson does actually +allocate more memory than appears here, but we still strive to keep our Haskell memory +footprint as small as possible. + ### Specs * GHC 9.4.6 w/ -O1 diff --git a/hermes-json.cabal b/hermes-json.cabal --- a/hermes-json.cabal +++ b/hermes-json.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hermes-json -version: 0.6.0.0 +version: 0.6.1.0 category: Text, Web, JSON, FFI synopsis: Fast JSON decoding via simdjson C++ bindings description: @@ -61,15 +61,15 @@ Data.Hermes.Decoder.Internal Data.Hermes.Decoder.Internal.Scientific build-depends: - base >= 4.13 && < 4.19, - bytestring >= 0.10.12 && < 0.12, + base >= 4.13 && < 4.20, + bytestring >= 0.10.12 && < 0.13, containers >= 0.6.5 && < 0.7, deepseq >= 1.4.4 && < 1.5, dlist >= 0.8 && < 1.1, integer-conversion >= 0.1 && < 0.2, - primitive >= 0.7.0 && < 0.9, + primitive >= 0.7.0 && < 0.10, scientific >= 0.3.6 && < 0.4, - text >= 2.0 && < 2.1, + text >= 2.0 && < 2.2, text-iso8601 >= 0.1 && < 0.2, transformers >= 0.5.6 && < 0.7, time >= 1.9.3 && < 1.13, diff --git a/src/Data/Hermes.hs b/src/Data/Hermes.hs --- a/src/Data/Hermes.hs +++ b/src/Data/Hermes.hs @@ -52,6 +52,8 @@ , nullable , objectAsKeyValues , objectAsMap + , objectAsMapExcluding + , liftObjectDecoder -- ** Date and time -- | Parses date and time types from Data.Time using the -- same Text parsers as Data.Aeson via @@ -67,6 +69,7 @@ -- * Error Types , HermesException(..) , DocumentError(..) + , formatException -- * Value helpers , getType , isNull @@ -102,6 +105,8 @@ , HermesException(..) , decodeEither , decodeEitherIO + , formatException + , liftObjectDecoder , mkHermesEnv , mkHermesEnv_ , parseByteString diff --git a/src/Data/Hermes/Decoder/Internal.hs b/src/Data/Hermes/Decoder/Internal.hs --- a/src/Data/Hermes/Decoder/Internal.hs +++ b/src/Data/Hermes/Decoder/Internal.hs @@ -22,6 +22,7 @@ , local , decodeEither , decodeEitherIO + , formatException , mkHermesEnv , mkHermesEnv_ , withHermesEnv @@ -32,6 +33,7 @@ , parseByteStringIO , liftIO , withRunInIO + , liftObjectDecoder ) where import Control.Applicative (Alternative(..)) @@ -190,7 +192,8 @@ instance Alternative FieldsDecoder where {-# INLINE (<|>) #-} - (FieldsDecoder a) <|> (FieldsDecoder b) = FieldsDecoder $ \obj -> a obj <|> b obj + (FieldsDecoder a) <|> (FieldsDecoder b) = FieldsDecoder $ \obj -> Decoder $ \val -> + runDecoder (a obj) val <|> runDecoder (b obj) val {-# INLINE empty #-} empty = FieldsDecoder $ const empty @@ -264,6 +267,15 @@ instance Exception HermesException instance NFData HermesException +formatException :: HermesException -> Text +formatException ex = case ex of + SIMDException doc -> formatDoc doc + InternalException doc -> formatDoc doc + where + formatDoc err + | T.null (path err) = "Document error: " <> errorMsg err + | otherwise = "Error in " <> path err <> ": " <> errorMsg err + -- | Record containing all pertinent information for troubleshooting an exception. data DocumentError = DocumentError @@ -315,7 +327,7 @@ then pure () else do errStr <- liftIO $ F.peekCString =<< getErrorMessageImpl errInt - throwSIMD $ pre <> " " <> T.pack errStr + throwSIMD . T.strip $ T.unwords [pre, T.pack errStr] {-# INLINE handleErrorCode #-} withRunInIO :: ((forall a. DecoderM a -> IO a) -> IO b) -> DecoderM b @@ -335,3 +347,17 @@ local :: (HermesEnv -> HermesEnv) -> DecoderM a -> DecoderM a local f (DecoderM m) = DecoderM . ReaderT $ runReaderT m . f {-# INLINE local #-} + +-- | Resets the object being iterated and runs the provided `Decoder` on the +-- object but as a `FieldsDecoder`. This is mostly a convenience for +-- re-entering an object after starting iteration, which isn't very +-- useful or performant. +-- +-- > object $ (,) +-- > <$> atKey "hello" text +-- > <*> liftObjectDecoder (objectAsMap pure text))) +liftObjectDecoder :: Decoder a -> FieldsDecoder a +liftObjectDecoder decoder = FieldsDecoder $ \(Object obj) -> Decoder $ \_ -> do + liftIO $ resetObjectImpl (Object obj) + runDecoder decoder (Value $ F.castPtr obj) +{-# INLINE liftObjectDecoder #-} diff --git a/src/Data/Hermes/Decoder/Value.hs b/src/Data/Hermes/Decoder/Value.hs --- a/src/Data/Hermes/Decoder/Value.hs +++ b/src/Data/Hermes/Decoder/Value.hs @@ -19,6 +19,7 @@ , object , objectAsKeyValues , objectAsMap + , objectAsMapExcluding , parseScientific , scientific , string @@ -218,6 +219,21 @@ objectAsMap kf vf = withObjectIter $ iterateOverFieldsMap kf vf {-# INLINE objectAsMap #-} +-- | Parse an object into a strict `Map`. +-- Skips any fields in the given list, which adds a slight performance penalty. +objectAsMapExcluding + :: Ord k + => [Text] + -- ^ List of field names to exclude. + -> (Text -> Decoder k) + -- ^ Parses a Text key in the Decoder monad. JSON keys are always text. + -> Decoder v + -- ^ Decoder for the field value. + -> Decoder (Map k v) +objectAsMapExcluding fields kf vf = + withObjectIter $ iterateOverFieldsMapExcluding fields kf vf +{-# INLINE objectAsMapExcluding #-} + withObjectAsMap :: Ord k => (Text -> Decoder k) @@ -427,6 +443,45 @@ else pure acc {-# INLINE iterateOverFieldsMap #-} + +iterateOverFieldsMapExcluding + :: Ord a + => [Text] + -> (Text -> Decoder a) + -> Decoder b + -> ObjectIter + -> DecoderM (Map a b) +iterateOverFieldsMapExcluding fields fk fv iterPtr = + withRunInIO $ \run -> + F.alloca $ \lenPtr -> + F.alloca $ \keyPtr -> + allocaValue $ \valPtr -> run $ go M.empty keyPtr lenPtr valPtr + where + go !acc keyPtr lenPtr valPtr = do + isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr + if not isOver + then do + err <- liftIO $ objectIterGetCurrentImpl iterPtr keyPtr lenPtr valPtr + handleErrorCode "" err + kLen <- fmap fromIntegral . liftIO $ F.peek lenPtr + kStr <- liftIO $ F.peek keyPtr + keyTxt <- parseTextFromCStrLen (kStr, kLen) + if keyTxt `elem` fields + then do + liftIO $ objectIterMoveNextImpl iterPtr + go acc keyPtr lenPtr valPtr + else do + (k, v) + <- + withKey keyTxt $ do + k <- runDecoder (fk keyTxt) valPtr + v <- runDecoder fv valPtr + pure (k, v) + liftIO $ objectIterMoveNextImpl iterPtr + go (M.insert k v acc) keyPtr lenPtr valPtr + else + pure acc +{-# INLINE iterateOverFieldsMapExcluding #-} -- | Execute a function on each Field in an ObjectIter and -- accumulate key-value tuples into a list. diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -37,7 +37,7 @@ properties = testGroup "Properties" [rtProp, rtPropOptional, rtErrors, rtRecursiveDataType] units :: TestTree -units = testGroup "Units" [altCases] +units = testGroup "Units" [altCases, objectFields] rtRecursiveDataType :: TestTree rtRecursiveDataType = testProperty "Round Trip With Recursive Data Type" $ @@ -48,21 +48,21 @@ rtProp :: TestTree rtProp = testProperty "Round Trip With Aeson.ToJSON" $ - withTests 1000 . property $ do + property $ do p <- forAll genPerson dp <- roundtrip decodePerson p p === dp rtPropOptional :: TestTree rtPropOptional = testProperty "Round Trip With Aeson.ToJSON (Optional Keys)" $ - withTests 1000 . property $ do + property $ do p <- forAll genPersonOptional dp <- roundtrip decodePersonOptional p p === dp rtErrors :: TestTree rtErrors = testProperty "Errors Should Not Break Referential Transparency" $ - withTests 1000 . property $ do + property $ do p <- forAll $ Gen.element [ "{" @@ -120,12 +120,18 @@ "{ \"key1\": 1, \"key2\": 2 }" @?= Right (Map.fromList [("key1", 1), ("key2", 2)]) - , testCase "Alternative Keys" $ + , testCase "Alternative Keys (value error)" $ decodeEither (object $ atKey "key1" (1 <$ bool) <|> atKey "key2" int) "{ \"key1\": 1, \"key2\": 2 }" @?= Right 2 + , testCase "Alternative Keys (key error)" $ + decodeEither + (object $ atKey "nope" int <|> atKey "key2" int) + "{ \"key1\": 1, \"key2\": 2 }" + @?= Right 2 + , testCase "Alternative Objects" $ decodeEither (object (atKey "key1" (2 <$ bool)) <|> object (atKey "key1" int)) @@ -133,6 +139,13 @@ @?= Right 1 ] +objectFields :: TestTree +objectFields = testGroup "Object Fields" + [ testCase "liftObjectDecoder" $ + decodeEither decodeFriendSlurp "{ \"id\": 1, \"first\": \"Bob\", \"last\": \"Kelso\" }" + @?= Right (FriendWithMap 1 (Map.fromList [("first", "Bob"), ("last", "Kelso")])) + ] + data Person = Person { _id :: Text @@ -336,7 +349,7 @@ 1000000000000000000000000 genScientific :: Gen Scientific -genScientific = fmap Sci.fromFloatDigits $ genDouble +genScientific = fmap Sci.fromFloatDigits genDouble newtype Peano = Peano Word16 deriving (Eq, Show) @@ -355,3 +368,15 @@ case mPeano of Just (Peano subTree) -> Peano $ 1 + subTree Nothing -> Peano 0 + +data FriendWithMap = + FriendWithMap + { id :: Int + , rest :: Map Text Text + } deriving (Eq, Show) + +decodeFriendSlurp :: Decoder FriendWithMap +decodeFriendSlurp = object $ + FriendWithMap + <$> atKey "id" int + <*> liftObjectDecoder (objectAsMapExcluding ["id"] pure text)