diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for hermes-json +## 0.5.0.0 -- 2023-03-08 + +* Convert `DecoderM` callbacks to `Decoder`. This is a breaking change. +* Add useful instances for the `Decoder` monad +* Remove some redundant functions +* Adjust `vector` bounds + ## 0.4.0.0 -- 2023-03-07 * Update simdjson to 3.1.3 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -90,17 +90,17 @@ | Name | Mean (ps) | 2*Stdev (ps) | Allocated | Copied | Peak Memory | | --------------------------------------- | ------------- | ------------ | ---------- | ---------- | ----------- | -| All.Decode.Arrays.Hermes | 267104550000 | 18274712758 | 503599934 | 439150544 | 541065216 | -| All.Decode.Arrays.Aeson | 2205838200000 | 108871466542 | 7094759154 | 2392723275 | 1166016512 | -| All.Decode.Persons.Hermes | 47153700000 | 3880584170 | 144901928 | 57032737 | 1166016512 | -| All.Decode.Persons.Aeson | 134265700000 | 7195219536 | 357269946 | 188529734 | 1166016512 | -| All.Decode.Partial Twitter.Hermes | 246448046 | 20934312 | 348540 | 3088 | 1166016512 | -| All.Decode.Partial Twitter.JsonStream | 2105484765 | 73210262 | 15261108 | 273820 | 1166016512 | -| All.Decode.Partial Twitter.Aeson | 4297434375 | 139205712 | 12547656 | 4625157 | 1166016512 | -| All.Decode.Persons (Aeson Value).Hermes | 108099550000 | 9966602188 | 303649194 | 138051155 | 1166016512 | -| All.Decode.Persons (Aeson Value).Aeson | 119240200000 | 9148201308 | 286148916 | 177027844 | 1166016512 | -| All.Decode.Twitter (Aeson Value).Hermes | 4261312500 | 149205128 | 12555922 | 4151184 | 1166016512 | -| All.Decode.Twitter (Aeson Value).Aeson | 4832229687 | 242990712 | 12539421 | 5527422 | 1166016512 | +| All.Decode.Arrays.Hermes | 267914650000 | 10610366160 | 503599934 | 439150544 | 541065216 | +| All.Decode.Arrays.Aeson | 2214928800000 | 160279563772 | 7094759111 | 2392723388 | 1166016512 | +| All.Decode.Persons.Hermes | 47338175000 | 4290343628 | 144901928 | 57032737 | 1166016512 | +| All.Decode.Persons.Aeson | 132864400000 | 9509102680 | 357269946 | 188529742 | 1166016512 | +| All.Decode.Partial Twitter.Hermes | 241083593 | 13856196 | 348540 | 3088 | 1166016512 | +| All.Decode.Partial Twitter.JsonStream | 2116192187 | 158907568 | 15259526 | 273821 | 1166016512 | +| All.Decode.Partial Twitter.Aeson | 4254060937 | 262619196 | 12538003 | 4634594 | 1166016512 | +| All.Decode.Persons (Aeson Value).Hermes | 106420425000 | 3747538126 | 303886293 | 135388183 | 1166016512 | +| All.Decode.Persons (Aeson Value).Aeson | 119489550000 | 9713032080 | 286148916 | 177027852 | 1166016512 | +| All.Decode.Twitter (Aeson Value).Hermes | 4164246875 | 240020934 | 12368752 | 4149211 | 1166016512 | +| All.Decode.Twitter (Aeson Value).Aeson | 4810817187 | 345165042 | 12539421 | 5527424 | 1166016512 | | | @@ -111,7 +111,7 @@ * Decode to `Int` or `Double` instead of `Scientific` if you can. * Decode your object fields in order. If encoding with `aeson`, you can leverage `toEncoding` to enforce ordering. -If you need to decode in tight loops or long-running processes (like a server), consider using the `withHermesEnv/mkHermesEnv` and `parseByteString` functions instead of `decodeEither`. This ensures the simdjson instances are not re-created on each decode. Please see the [simdjson performance docs](https://github.com/simdjson/simdjson/blob/master/doc/performance.md#performance-notes) for more info. +If you need to decode in tight loops or long-running processes (like a server), consider using the `withHermesEnv/mkHermesEnv` and `parseByteString` functions instead of `decodeEither`. This ensures the simdjson instances are not re-created on each decode. Please see the [simdjson performance docs](https://github.com/simdjson/simdjson/blob/master/doc/performance.md#performance-notes) for more info. But please ensure that you use one `HermesEnv` per thread, as simdjson is [single-threaded by default](https://github.com/simdjson/simdjson/blob/master/doc/basics.md#thread-safety). ## Limitations 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.4.0.0 +version: 0.5.0.0 category: Text, Web, JSON, FFI synopsis: Fast JSON decoding via simdjson C++ bindings description: @@ -72,7 +72,7 @@ transformers >= 0.5.6 && < 0.6, time >= 1.9.3 && < 1.13, time-compat >= 1.9.5 && < 1.10, - vector >= 0.13.0 && < 0.14 + vector >= 0.12.3.1 && < 0.14 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Data/Hermes.hs b/src/Data/Hermes.hs --- a/src/Data/Hermes.hs +++ b/src/Data/Hermes.hs @@ -69,14 +69,12 @@ , withBool , withDouble , withInt - , withNull , withObject , withObjectAsMap , withScientific , withString , withText , withType - , withTypeM , withVector -- * Raw ByteString access , withRawByteString 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 @@ -105,6 +105,34 @@ newtype Decoder a = Decoder { runDecoder :: Value -> DecoderM a } +instance Functor Decoder where + {-# INLINE fmap #-} + fmap f d = Decoder $ \val -> f <$> runDecoder d val + +instance Applicative Decoder where + {-# INLINE pure #-} + pure a = Decoder $ \_ -> pure a + {-# INLINE (<*>) #-} + (Decoder f) <*> (Decoder e) = Decoder $ \val -> f val <*> e val + +instance Monad Decoder where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + (Decoder d) >>= f = Decoder $ \val -> do + x <- d val + runDecoder (f x) val + +instance Alternative Decoder where + {-# INLINE (<|>) #-} + (Decoder a) <|> (Decoder b) = Decoder $ \val -> a val <|> b val + {-# INLINE empty #-} + empty = Decoder $ const empty + +instance MonadFail Decoder where + {-# INLINE fail #-} + fail e = Decoder $ \_ -> fail e + -- | Decode a strict `ByteString` using the simdjson::ondemand bindings. -- Creates simdjson instances on each decode. decodeEither :: Decoder a -> BS.ByteString -> Either HermesException a @@ -139,6 +167,8 @@ -- It is preferable to use `withHermesEnv` to keep foreign references in scope. -- Be careful using this, the foreign references can be finalized if the -- `HermesEnv` goes out of scope. +-- +-- Do _not_ share a `HermesEnv` across multiple threads. Each thread should get its own. mkHermesEnv :: Maybe Int -> IO HermesEnv mkHermesEnv mCapacity = do parser <- mkSIMDParser mCapacity diff --git a/src/Data/Hermes/Decoder/Time.hs b/src/Data/Hermes/Decoder/Time.hs --- a/src/Data/Hermes/Decoder/Time.hs +++ b/src/Data/Hermes/Decoder/Time.hs @@ -19,11 +19,11 @@ import qualified Data.Time.Calendar.Quarter.Compat as Time import qualified Data.Time.LocalTime as Local -import Data.Hermes.Decoder.Internal (DecoderM, Decoder(..)) +import Data.Hermes.Decoder.Internal (Decoder(..)) import Data.Hermes.Decoder.Value (withText) -- | Run an attoparsec text parser as a hermes decoder. -runAttoDate :: AT.Parser a -> Text -> DecoderM a +runAttoDate :: AT.Parser a -> Text -> Decoder a runAttoDate p t = case AT.parseOnly (p <* AT.endOfInput) t of Left err -> fail $ "Could not parse date: " <> err 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 @@ -18,6 +18,7 @@ , nullable , objectAsKeyValues , objectAsMap + , parseScientific , scientific , string , text @@ -29,7 +30,6 @@ , withBool , withDouble , withInt - , withNull , withObject , withObjectAsMap , withRawByteString @@ -37,7 +37,6 @@ , withString , withText , withType - , withTypeM , withVector ) where @@ -89,44 +88,44 @@ {-# INLINE atPointer #-} -- | Helper to work with an Object parsed from a Value. -withObject :: (Object -> DecoderM a) -> Decoder a +withObject :: (Object -> Decoder a) -> Decoder a withObject f = Decoder $ \valPtr -> withRunInIO $ \ run -> allocaObject $ \oPtr -> do err <- getObjectFromValueImpl valPtr oPtr run $ do handleErrorCode (typePrefix "object") err - f oPtr + runDecoder (f oPtr) valPtr {-# INLINE withObject #-} -- | Helper to work with an Int parsed from a Value. -withInt :: (Int -> DecoderM a) -> Decoder a -withInt f = Decoder $ getInt >=> f +withInt :: (Int -> Decoder a) -> Decoder a +withInt f = Decoder $ \val -> getInt val >>= \i -> runDecoder (f i) val {-# INLINE withInt #-} -- | Helper to work with a Double parsed from a Value. -withDouble :: (Double -> DecoderM a) -> Decoder a -withDouble f = Decoder $ getDouble >=> f +withDouble :: (Double -> Decoder a) -> Decoder a +withDouble f = Decoder $ \val -> getDouble val >>= \d -> runDecoder (f d) val {-# INLINE withDouble #-} -- | Helper to work with a Bool parsed from a Value. -withBool :: (Bool -> DecoderM a) -> Decoder a -withBool f = Decoder $ getBool >=> f +withBool :: (Bool -> Decoder a) -> Decoder a +withBool f = Decoder $ \val -> getBool val >>= \b -> runDecoder (f b) val {-# INLINE withBool #-} -- | Helper to work with the raw ByteString of the JSON token parsed from the given Value. -withRawByteString :: (BS.ByteString -> DecoderM a) -> Decoder a -withRawByteString f = Decoder $ getRawByteString >=> f +withRawByteString :: (BS.ByteString -> Decoder a) -> Decoder a +withRawByteString f = Decoder $ \val -> getRawByteString val >>= \b -> runDecoder (f b) val {-# INLINE withRawByteString #-} -- | Helper to work with a String parsed from a Value. -withString :: (String -> DecoderM a) -> Decoder a -withString f = Decoder $ getString >=> f +withString :: (String -> Decoder a) -> Decoder a +withString f = Decoder $ \val -> getString val >>= \s -> runDecoder (f s) val {-# INLINE withString #-} -- | Helper to work with a Text parsed from a Value. -withText :: (Text -> DecoderM a) -> Decoder a -withText f = Decoder $ getText >=> f +withText :: (Text -> Decoder a) -> Decoder a +withText f = Decoder $ \val -> getText val >>= \t -> runDecoder (f t) val {-# INLINE withText #-} -- | Returns True if the Value is null. @@ -163,32 +162,32 @@ {-# RULES "list double/listOfDouble" list double = listOfDouble #-} -- | Helper to work with an Array parsed from a Value. -withArray :: (Array -> DecoderM a) -> Decoder a +withArray :: (Array -> Decoder a) -> Decoder a withArray f = Decoder $ \val -> withRunInIO $ \run -> allocaArray $ \arrPtr -> do err <- getArrayFromValueImpl val arrPtr run $ do handleErrorCode (typePrefix "array") err - f arrPtr + runDecoder (f arrPtr) val {-# INLINE withArray #-} -- | Find an object field by key, where an exception is thrown -- if the key is missing. -atKey :: Text -> Decoder a -> Object -> DecoderM a -atKey key parser obj = withUnorderedField parser obj key +atKey :: Text -> Decoder a -> Object -> Decoder a +atKey key parser obj = Decoder . const $ withUnorderedField parser obj key {-# INLINE atKey #-} -- | Find an object field by key, where Nothing is returned -- if the key is missing. -atKeyOptional :: Text -> Decoder a -> Object -> DecoderM (Maybe a) -atKeyOptional key parser obj = withUnorderedOptionalField parser obj key +atKeyOptional :: Text -> Decoder a -> Object -> Decoder (Maybe a) +atKeyOptional key parser obj = Decoder . const $ withUnorderedOptionalField parser obj key {-# INLINE atKeyOptional #-} -- | Uses find_field, which means if you access a field out-of-order -- this will throw an exception. It also cannot support optional fields. -atKeyStrict :: Text -> Decoder a -> Object -> DecoderM a -atKeyStrict key parser obj = withField parser obj key +atKeyStrict :: Text -> Decoder a -> Object -> Decoder a +atKeyStrict key parser obj = Decoder . const $ withField parser obj key {-# INLINE atKeyStrict #-} -- | Parse a homogenous JSON array into a Haskell list. @@ -201,14 +200,14 @@ vector f = withArrayLenIter $ iterateOverArrayLen f {-# INLINE vector #-} -withVector :: G.Vector v a => Decoder a -> (v a -> DecoderM a) -> Decoder a -withVector inner f = Decoder $ runDecoder (vector inner) >=> f +withVector :: G.Vector v a => Decoder a -> (v a -> Decoder a) -> Decoder a +withVector inner f = Decoder $ \val -> runDecoder (vector inner) val >>= \v -> runDecoder (f v) val {-# INLINE withVector #-} -- | Parse an object into a homogenous list of key-value tuples. objectAsKeyValues - :: (Text -> DecoderM k) - -- ^ Parses a Text key in the DecoderM monad. JSON keys are always text. + :: (Text -> Decoder k) + -- ^ Parses a Text key in the Decoder monad. JSON keys are always text. -> Decoder v -- ^ Decoder for the field value. -> Decoder [(k, v)] @@ -218,8 +217,8 @@ -- | Parse an object into a strict `Map`. objectAsMap :: Ord k - => (Text -> DecoderM k) - -- ^ Parses a Text key in the DecoderM monad. JSON keys are always text. + => (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) @@ -228,13 +227,13 @@ withObjectAsMap :: Ord k - => (Text -> DecoderM k) - -- ^ Parses a Text key in the DecoderM monad. JSON keys are always text. + => (Text -> Decoder k) + -- ^ Parses a Text key in the Decoder monad. JSON keys are always text. -> Decoder v -- ^ Decoder for the field value. - -> (Map k v -> DecoderM a) + -> (Map k v -> Decoder a) -> Decoder a -withObjectAsMap kf vf f = Decoder $ runDecoder (objectAsMap kf vf) >=> f +withObjectAsMap kf vf f = Decoder $ \val -> runDecoder (objectAsMap kf vf) val >>= \m -> runDecoder (f m) val {-# INLINE withObjectAsMap #-} -- | Transforms a parser to return Nothing when the value is null. @@ -246,14 +245,6 @@ else Just <$> runDecoder parser val {-# INLINE nullable #-} -withNull :: (Bool -> DecoderM a) -> Decoder a -withNull f = Decoder $ \val -> do - nil <- runDecoder isNull val - if nil - then f True - else f False -{-# INLINE withNull #-} - -- | Parse only a single character. char :: Decoder Char char = Decoder $ getText >=> justOne @@ -297,8 +288,8 @@ scientific = withRawByteString parseScientific {-# INLINE scientific #-} -withScientific :: (Sci.Scientific -> DecoderM a) -> Decoder a -withScientific f = Decoder $ runDecoder scientific >=> f +withScientific :: (Sci.Scientific -> Decoder a) -> Decoder a +withScientific f = Decoder $ \val -> runDecoder scientific val >>= \sci -> runDecoder (f sci) val {-# INLINE withScientific #-} -- | Get the simdjson type of the Value. @@ -317,9 +308,13 @@ withType f = Decoder $ \val -> runDecoder getType val >>= \ty -> runDecoder (f ty) val {-# INLINE withType #-} -withTypeM :: (ValueType -> DecoderM a) -> Decoder a -withTypeM f = Decoder $ runDecoder getType >=> f -{-# INLINE withTypeM #-} +-- | Parse a Scientific using attoparsec's ByteString.Char8 parser. +parseScientific :: BS.ByteString -> Decoder Sci.Scientific +parseScientific + = either (\err -> fail $ "Failed to parse Scientific: " <> err) pure + . A.parseOnly (AC.scientific <* A.endOfInput) + . BSC.strip +{-# INLINE parseScientific #-} -- Internal Functions @@ -398,17 +393,17 @@ withObjectIter :: (ObjectIter -> DecoderM a) -> Decoder a withObjectIter f = Decoder $ \valPtr -> withRunInIO $ \run -> - allocaObjectIter $ \iterPtr -> do - err <- getObjectIterFromValueImpl valPtr iterPtr - run $ do - handleErrorCode (typePrefix "object") err - f iterPtr + allocaObjectIter $ \iterPtr -> do + err <- getObjectIterFromValueImpl valPtr iterPtr + run $ do + handleErrorCode (typePrefix "object") err + f iterPtr {-# INLINE withObjectIter #-} -- | Execute a function on each Field in an ObjectIter and accumulate into a `Map`. iterateOverFieldsMap :: Ord a - => (Text -> DecoderM a) + => (Text -> Decoder a) -> Decoder b -> ObjectIter -> DecoderM (Map a b) @@ -430,7 +425,7 @@ (k, v) <- withKey keyTxt $ do - k <- fk keyTxt + k <- runDecoder (fk keyTxt) valPtr v <- runDecoder fv valPtr pure (k, v) liftIO $ objectIterMoveNextImpl iterPtr @@ -442,7 +437,7 @@ -- | Execute a function on each Field in an ObjectIter and -- accumulate key-value tuples into a list. iterateOverFields - :: (Text -> DecoderM a) + :: (Text -> Decoder a) -> Decoder b -> ObjectIter -> DecoderM [(a, b)] @@ -464,7 +459,7 @@ kv <- withKey keyTxt $ do - k <- fk keyTxt + k <- runDecoder (fk keyTxt) valPtr v <- runDecoder fv valPtr pure (k, v) liftIO $ objectIterMoveNextImpl iterPtr @@ -486,23 +481,23 @@ withUnorderedOptionalField :: Decoder a -> Object -> Text -> DecoderM (Maybe a) withUnorderedOptionalField f objPtr key = withRunInIO $ \run -> - Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) -> - allocaValue $ \vPtr -> run $ withKey key $ do - err <- liftIO $ findFieldUnorderedImpl objPtr cstr len vPtr - let errCode = toEnum $ fromIntegral err - if | errCode == SUCCESS -> Just <$> runDecoder f vPtr - | errCode == NO_SUCH_FIELD -> pure Nothing - | otherwise -> Nothing <$ handleErrorCode "" err + Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) -> + allocaValue $ \vPtr -> run $ withKey key $ do + err <- liftIO $ findFieldUnorderedImpl objPtr cstr len vPtr + let errCode = toEnum $ fromIntegral err + if | errCode == SUCCESS -> Just <$> runDecoder f vPtr + | errCode == NO_SUCH_FIELD -> pure Nothing + | otherwise -> Nothing <$ handleErrorCode "" err {-# INLINE withUnorderedOptionalField #-} withField :: Decoder a -> Object -> Text -> DecoderM a withField f objPtr key = withRunInIO $ \run -> Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) -> - allocaValue $ \vPtr -> run $ withKey key $ do - err <- liftIO $ findFieldImpl objPtr cstr len vPtr + allocaValue $ \val -> run $ withKey key $ do + err <- liftIO $ findFieldImpl objPtr cstr len val handleErrorCode "" err - runDecoder f vPtr + runDecoder f val {-# INLINE withField #-} getInt :: Value -> DecoderM Int @@ -522,14 +517,6 @@ handleErrorCode (typePrefix "double") err liftIO $ F.peek ptr {-# INLINE getDouble #-} - --- | Parse a Scientific using attoparsec's ByteString.Char8 parser. -parseScientific :: BS.ByteString -> DecoderM Sci.Scientific -parseScientific - = either (\err -> fail $ "Failed to parse Scientific: " <> err) pure - . A.parseOnly (AC.scientific <* A.endOfInput) - . BSC.strip -{-# INLINE parseScientific #-} getBool :: Value -> DecoderM Bool getBool valPtr =