diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,36 @@ # Revision history for hermes-json +## 0.9.0.0 -- 2026-10-14 + +### Breaking +* Remove `parseScientific` from `Data.Hermes.Decoder.Value`. The `scientific` + decoder now parses numbers in C++ and no longer uses a Haskell scanner. +* `scientific` rejects numbers with a leading `+` or leading zeros, matching + aeson and the other number decoders. +* `withInputBuffer` frees the padded copy of the input when its callback + returns. Pointers into the input must not be used after decoding. + +### Changed +* Update simdjson to 5.0.4 +* Primitive decoders reuse a scratch buffer for FFI results instead of + allocating pinned memory on every call, which makes decoding faster and + reduces allocation. +* `scientific` is faster and reports `INCORRECT_TYPE` for non-number values and + `NUMBER_ERROR` for malformed numbers. Exponents with more than 18 significant + digits are now an error instead of silently overflowing. +* `withRawByteString` and `withRawJsonByteString` return copies of the input + bytes, so the result stays valid after decoding. +* `HermesEnv` holds a lock, so sharing one across threads is safe. A decode + that finds the env busy uses a temporary env instead of waiting. Use one env + per thread or a pool to keep reusing envs. + +### Fixed +* `scientific` no longer fails on numbers followed by whitespace, such as + `{"a": 1.5 }`. +* Input buffers are freed as soon as decoding finishes. They were previously + freed by a GC finalizer, so decoders that allocate little on the Haskell heap + could grow native memory without bound. + ## 0.8.2.0 -- 2026-08-30 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -85,27 +85,44 @@ ### Specs -* GHC 9.10.2 w/ -O1 -* aeson-2.2 -* Apple M1 Pro +* GHC 9.14.1 w/ -O1 +* aeson-2.3 +* Apple M5 Pro -![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench/hermes-bench/bench.svg) +#### Arrays +![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench-0.9/hermes-bench/svg/arrays.svg) + +#### Persons + +![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench-0.9/hermes-bench/svg/persons.svg) + +#### Partial Twitter + +![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench-0.9/hermes-bench/svg/partial-twitter.svg) + +#### Persons (Aeson Value) + +![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench-0.9/hermes-bench/svg/persons-aeson-value.svg) + +#### Twitter (Aeson Value) + +![](https://raw.githubusercontent.com/velveteer/hermes/refs/heads/bench-0.9/hermes-bench/svg/twitter-aeson-value.svg) + -| Name | Mean (ps) | 2*Stdev (ps) | Allocated | Copied | Peak Memory | -| -------------------------------- | ------------ | ------------ | --------- | --------- | ----------- | -| All.Hermes Arrays | 1238823437 | 69966216 | 4159827 | 43225 | 94371840 | -| All.Aeson Arrays | 19088587500 | 1727306610 | 71612641 | 1923087 | 94371840 | -| All.Hermes Persons | 45510337500 | 1799699310 | 128324650 | 23251095 | 133169152 | -| All.Aeson Persons | 135171600000 | 13410594088 | 344109912 | 119331077 | 227540992 | -| All.Hermes Partial Twitter | 285580859 | 26755950 | 286206 | 248 | 227540992 | -| All.Aeson Partial Twitter | 2867570312 | 206853756 | 12088346 | 185157 | 227540992 | -| All.JsonStream Partial Twitter | 2885024218 | 182665790 | 16295467 | 14388 | 227540992 | -| All.Hermes Persons (Aeson Value) | 120848125000 | 4797483844 | 279944292 | 105987198 | 227540992 | -| All.Aeson Persons (Aeson Value) | 112195950000 | 7547400244 | 272053846 | 99592364 | 247463936 | -| All.Hermes Twitter (Aeson Value) | 2925018750 | 226059484 | 11260357 | 144688 | 247463936 | -| All.Aeson Twitter (Aeson Value) | 3010517968 | 124325378 | 11882027 | 196351 | 247463936 | -| | +| Name | Mean (ps) | 2*Stdev (ps) | Allocated | Copied | Peak Memory | +| -------------------------------- | ----------- | ------------ | --------- | --------- | ----------- | +| All.Arrays.Hermes | 736661914 | 56835868 | 4320997 | 49336 | 78643200 | +| All.Arrays.Aeson | 11665968750 | 935375184 | 71682940 | 1967960 | 78643200 | +| All.Persons.Hermes | 14243446875 | 1005063640 | 52984155 | 9592134 | 126877696 | +| All.Persons.Aeson | 82948100000 | 8126094636 | 358899523 | 125070437 | 261095424 | +| All.Partial Twitter.Hermes | 125155444 | 3923382 | 195772 | 149 | 75497472 | +| All.Partial Twitter.Aeson | 1779148046 | 152850968 | 12796011 | 220186 | 74448896 | +| All.Partial Twitter.JsonStream | 1732640625 | 156437412 | 16170009 | 14820 | 90177536 | +| All.Persons (Aeson Value).Hermes | 42076150000 | 4106762446 | 152298884 | 70268110 | 168820736 | +| All.Persons (Aeson Value).Aeson | 67366093750 | 2380713624 | 285929614 | 92447746 | 239075328 | +| All.Twitter (Aeson Value).Hermes | 1127491406 | 93825760 | 7282920 | 122405 | 75497472 | +| All.Twitter (Aeson Value).Aeson | 1857667968 | 114563544 | 12589248 | 205953 | 74448896 | ## Performance Tips @@ -113,8 +130,23 @@ * Decode to `Text` instead of `String` wherever possible! * 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. +* In tight loops or servers, reuse a `HermesEnv` with `parseByteString` instead of `decodeEither`. +* Give each thread its own `HermesEnv`, or use a pool. Sharing one is safe but slower under contention. -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. See the [simdjson performance docs](https://github.com/simdjson/simdjson/blob/master/doc/performance.md#performance-notes) for more info. 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). +Pooling envs with `resource-pool`: + +```haskell +import Data.ByteString (ByteString) +import Data.Hermes +import Data.Pool (Pool, defaultPoolConfig, newPool, withResource) + +-- Up to 8 envs, each dropped after 60 idle seconds. +mkEnvPool :: IO (Pool HermesEnv) +mkEnvPool = newPool $ defaultPoolConfig mkHermesEnv_ (const $ pure ()) 60 8 + +decodeWithPool :: Pool HermesEnv -> Decoder a -> ByteString -> IO a +decodeWithPool pool d bs = withResource pool $ \env -> parseByteStringIO env d bs +``` ## Limitations diff --git a/cbits/lib.cpp b/cbits/lib.cpp --- a/cbits/lib.cpp +++ b/cbits/lib.cpp @@ -216,6 +216,64 @@ return SUCCESS; } + // Parses a number token as coefficient * 10^exponent. Writes to out: + // [0] coefficient, or its sign when the digits do not fit in int64 + // [1] exponent + // [2..5] integer digits and fraction digits as (pointer, length) pairs + // Returns 0, -1 when the coefficient must be built from the digits, + // or an error code. + int get_scientific(ondemand::value &val, int64_t *out) { + std::string_view tok = val.raw_json_token(); + const char *p = tok.data(); + const char *end = p + tok.size(); + auto digit = [&] { return p < end && unsigned(*p - '0') < 10; }; + if (p == end || !(*p == '-' || unsigned(*p - '0') < 10)) { return INCORRECT_TYPE; } + bool neg = *p == '-'; + if (neg) { ++p; } + uint64_t m = 0; + const char *intStart = p; + while (digit()) { m = m * 10 + unsigned(*p - '0'); ++p; } + const char *intEnd = p; + if (intStart == intEnd || (*intStart == '0' && intEnd - intStart > 1)) { return NUMBER_ERROR; } + const char *fracStart = p; + const char *fracEnd = p; + if (p < end && *p == '.') { + fracStart = ++p; + while (digit()) { m = m * 10 + unsigned(*p - '0'); ++p; } + fracEnd = p; + if (fracStart == fracEnd) { return NUMBER_ERROR; } + } + int64_t e = 0; + if (p < end && (*p == 'e' || *p == 'E')) { + ++p; + bool eneg = p < end && *p == '-'; + if (p < end && (*p == '+' || *p == '-')) { ++p; } + const char *expStart = p; + while (p < end && *p == '0') { ++p; } + const char *expDigits = p; + while (digit()) { + if (p - expDigits == 18) { return NUMBER_ERROR; } + e = e * 10 + (*p - '0'); + ++p; + } + if (p == expStart) { return NUMBER_ERROR; } + if (eneg) { e = -e; } + } + while (p < end && (*p == ' ' || *p == '\t' || *p == '\n' || *p == '\r')) { ++p; } + if (p != end) { return NUMBER_ERROR; } + out[1] = e - (fracEnd - fracStart); + if ((intEnd - intStart) + (fracEnd - fracStart) <= 18) { + out[0] = neg ? -int64_t(m) : int64_t(m); + return 0; + } + out[0] = neg ? -1 : 1; + out[2] = int64_t(reinterpret_cast(intStart)); + out[3] = intEnd - intStart; + out[4] = int64_t(reinterpret_cast(fracStart)); + out[5] = fracEnd - fracStart; + return -1; + } + error_code is_null(ondemand::value &val, bool &out) { return val.is_null().get(out); } 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.8.2.0 +version: 0.9.0.0 category: Text, Web, JSON, FFI synopsis: Fast JSON decoding via simdjson C++ bindings description: @@ -56,7 +56,6 @@ Data.Hermes.SIMDJSON.Wrapper other-modules: Data.Hermes.Decoder.Internal - Data.Hermes.Decoder.Internal.Scientific build-depends: base >= 4.13 && < 4.23, bytestring >= 0.10.12 && < 0.13, diff --git a/simdjson/singleheader/simdjson.cpp b/simdjson/singleheader/simdjson.cpp # file too large to diff: simdjson/singleheader/simdjson.cpp diff --git a/simdjson/singleheader/simdjson.h b/simdjson/singleheader/simdjson.h # file too large to diff: simdjson/singleheader/simdjson.h diff --git a/src/Data/Hermes.hs b/src/Data/Hermes.hs --- a/src/Data/Hermes.hs +++ b/src/Data/Hermes.hs @@ -12,29 +12,33 @@ -- instance. Decoding a document into a scalar from a `Value` is not supported -- by simdjson. While simdjson can cast a document directly to a scalar, this -- library currently exposes no interface for this. - module Data.Hermes ( -- * Decoding from ByteString input decodeEither , decodeEitherIO , parseByteString , parseByteStringIO - , Decoder(runDecoder) - , FieldsDecoder(runFieldsDecoder) + , Decoder (runDecoder) + , FieldsDecoder (runFieldsDecoder) + -- * Decoder monad - , DecoderM(runDecoderM) - , HermesEnv(hPath, hDocument, hParser) + , DecoderM (runDecoderM) + , HermesEnv (hPath, hDocument, hParser) , mkHermesEnv , mkHermesEnv_ , withHermesEnv , withHermesEnv_ + -- * Object field decoders , atKey , atKeyOptional , atKeyStrict + -- * Decoders + -- ** JSON pointer , atPointer + -- ** Values , bool , char @@ -55,7 +59,9 @@ , objectAsMap , objectAsMapExcluding , liftObjectDecoder + -- ** Date and time + -- | Parses date and time types from Data.Time using the -- same Text parsers as Data.Aeson via -- . @@ -67,10 +73,12 @@ , localTime , utcTime , zonedTime + -- * Error Types - , HermesException(..) - , DocumentError(..) + , HermesException (..) + , DocumentError (..) , formatException + -- * Value helpers , getType , isNull @@ -83,9 +91,11 @@ , withText , withType , withVector - -- * Raw ByteString access + + -- * Raw ByteString access , withRawByteString , withRawJsonByteString + -- * simdjson Opaque Types , Array , ArrayIter @@ -94,17 +104,17 @@ , Object , Parser , Value - , ValueType(..) + , ValueType (..) ) where -import Data.Hermes.Decoder -import Data.Hermes.Decoder.Internal - ( DecoderM(runDecoderM) - , Decoder(runDecoder) - , FieldsDecoder(runFieldsDecoder) - , DocumentError(..) - , HermesEnv(hDocument, hParser, hPath) - , HermesException(..) +import Data.Hermes.Decoder +import Data.Hermes.Decoder.Internal + ( Decoder (runDecoder) + , DecoderM (runDecoderM) + , DocumentError (..) + , FieldsDecoder (runFieldsDecoder) + , HermesEnv (hDocument, hParser, hPath) + , HermesException (..) , decodeEither , decodeEitherIO , formatException @@ -116,4 +126,4 @@ , withHermesEnv , withHermesEnv_ ) -import Data.Hermes.SIMDJSON.Types +import Data.Hermes.SIMDJSON.Types diff --git a/src/Data/Hermes/Decoder.hs b/src/Data/Hermes/Decoder.hs --- a/src/Data/Hermes/Decoder.hs +++ b/src/Data/Hermes/Decoder.hs @@ -2,6 +2,6 @@ ( module Export ) where -import Data.Hermes.Decoder.Path as Export -import Data.Hermes.Decoder.Time as Export -import Data.Hermes.Decoder.Value as Export +import Data.Hermes.Decoder.Path as Export +import Data.Hermes.Decoder.Time as Export +import Data.Hermes.Decoder.Value as Export 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 @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,18 +7,21 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} module Data.Hermes.Decoder.Internal - ( DecoderM(..) - , DecoderPrimM(..) - , HermesEnv(..) - , HermesException(..) - , DocumentError(..) - , Path(..) - , Decoder(..) - , FieldsDecoder(..) + ( DecoderM (..) + , DecoderPrimM (..) + , HermesEnv (..) + , HermesException (..) + , DocumentError (..) + , Path (..) + , Decoder (..) + , FieldsDecoder (..) , asks , local + , scratch + , scratchPair , decodeEither , decodeEitherIO , formatException @@ -29,6 +31,7 @@ , withHermesEnv_ , typePrefix , handleErrorCode + , throwErrorCode , parseByteString , parseByteStringIO , liftIO @@ -36,50 +39,52 @@ , liftObjectDecoder ) where -import Control.Applicative (Alternative(..)) -import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception, catch, throwIO, try) -import Control.Monad (when) -import Control.Monad.Primitive (PrimMonad(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Applicative (Alternative (..)) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, tryTakeMVar) +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception, catch, finally, mask, throwIO, try) +import Control.Monad (when) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT (..)) import qualified Data.ByteString as BS -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T +import Data.Word (Word8) import qualified Foreign.C as F import qualified Foreign.ForeignPtr as F -import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.ForeignPtr.Unsafe as F import qualified Foreign.Ptr as F import qualified Foreign.Storable as F -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified System.IO.Unsafe as Unsafe -import Data.Hermes.SIMDJSON.Bindings +import Data.Hermes.SIMDJSON.Bindings ( getDocumentValueImpl , getErrorMessageImpl , getTypeImpl , resetArrayImpl , resetObjectImpl ) -import Data.Hermes.SIMDJSON.Types - ( Array(..) - , Document(..) - , Object(..) - , Parser(..) +import Data.Hermes.SIMDJSON.Types + ( Array (..) + , Document (..) + , Object (..) + , Parser (..) , SIMDDocument - , SIMDErrorCode(..) + , SIMDErrorCode (..) , SIMDParser - , Value(..) - , ValueType(..) + , Value (..) + , ValueType (..) ) -import Data.Hermes.SIMDJSON.Wrapper +import Data.Hermes.SIMDJSON.Wrapper -- | DecoderM is some context around the IO needed by the C FFI to allocate local memory. -- Users have no access to the underlying IO, since this could allow decoders to launch nukes. -- Using `decodeEither` discharges the IO and returns us to purity, -- since we know decoding a document is referentially transparent. -newtype DecoderM a = DecoderM { runDecoderM :: ReaderT HermesEnv IO a } - deriving newtype (Functor, Applicative, Monad) +newtype DecoderM a = DecoderM {runDecoderM :: ReaderT HermesEnv IO a} + deriving newtype (Applicative, Functor, Monad) instance Alternative DecoderM where empty = fail "Unspecified error" @@ -90,8 +95,8 @@ {-# INLINE fail #-} fail = throwHermes . T.pack -newtype DecoderPrimM a = DecoderPrimM { runDecoderPrimM :: DecoderM a } - deriving newtype (Functor, Applicative, Monad) +newtype DecoderPrimM a = DecoderPrimM {runDecoderPrimM :: DecoderM a} + deriving newtype (Applicative, Functor, Monad) instance PrimMonad DecoderPrimM where type PrimState DecoderPrimM = PrimState (ReaderT HermesEnv IO) @@ -101,25 +106,28 @@ -- | Contains foreign references to the allocated simdjson::parser and -- simdjson::document. Also maintains state for error reporting that is updated -- when an object field or array value is entered. -data HermesEnv = - HermesEnv - { hParser :: {-# UNPACK #-} !(F.ForeignPtr SIMDParser) - , hDocument :: {-# UNPACK #-} !(F.ForeignPtr SIMDDocument) - , hPath :: [Path] - } deriving (Eq, Generic) +data HermesEnv + = HermesEnv + { hParser :: {-# UNPACK #-} !(F.ForeignPtr SIMDParser) + , hDocument :: {-# UNPACK #-} !(F.ForeignPtr SIMDDocument) + , hScratch :: {-# UNPACK #-} !(F.ForeignPtr Word8) + , hLock :: {-# UNPACK #-} !(MVar ()) + , hPath :: [Path] + } + deriving (Eq, Generic) instance NFData HermesEnv where - rnf HermesEnv{..} = rnf hPath `seq` () + rnf HermesEnv {..} = rnf hPath `seq` () -data Path = - Key Text +data Path + = Key Text | Idx {-# UNPACK #-} !Int | Pointer Text - deriving (Eq, Show, Generic) + deriving (Eq, Generic, Show) instance NFData Path -newtype Decoder a = Decoder { runDecoder :: Value -> DecoderM a } +newtype Decoder a = Decoder {runDecoder :: Value -> DecoderM a} instance Functor Decoder where {-# INLINE fmap #-} @@ -142,23 +150,26 @@ instance Alternative Decoder where {-# INLINE (<|>) #-} (Decoder a) <|> (Decoder b) = Decoder $ \val -> withRunInIO $ \run -> - run (a val) `catch` (\(_err :: HermesException) -> do - valType <- F.alloca $ \ptr -> do - errCode <- toEnum . fromIntegral <$> getTypeImpl val ptr - if errCode == SUCCESS - then fmap (Just . toEnum . fromIntegral) $ F.peek ptr - else pure Nothing - -- Attempt to reset arrays and objects on decoding errors. - -- This is necessary since when iterating over arrays and objects - -- we do not want to re-enter the object/array. simdjson lets us - -- "reset" the iterator so we can parse it anew. - when (valType == Just VArray) $ do - let (Value vptr) = val - resetArrayImpl (Array $ F.castPtr vptr) - when (valType == Just VObject) $ do - let (Value vptr) = val - resetObjectImpl (Object $ F.castPtr vptr) - run (b val)) + run (a val) + `catch` ( \(_err :: HermesException) -> do + ptr <- run scratch + errCode <- toEnum . fromIntegral <$> getTypeImpl val ptr + valType <- + if errCode == SUCCESS + then fmap (Just . toEnum . fromIntegral) $ F.peek ptr + else pure Nothing + -- Attempt to reset arrays and objects on decoding errors. + -- This is necessary since when iterating over arrays and objects + -- we do not want to re-enter the object/array. simdjson lets us + -- "reset" the iterator so we can parse it anew. + when (valType == Just VArray) $ do + let (Value vptr) = val + resetArrayImpl (Array $ F.castPtr vptr) + when (valType == Just VObject) $ do + let (Value vptr) = val + resetObjectImpl (Object $ F.castPtr vptr) + run (b val) + ) {-# INLINE empty #-} empty = Decoder $ const empty @@ -173,8 +184,8 @@ -- However, simdjson provides a way to reset the iterator. See -- `liftObjectDecoder` if you need to run an object decoder after already -- starting iteration on that object. -newtype FieldsDecoder a = - FieldsDecoder { runFieldsDecoder :: Object -> Decoder a } +newtype FieldsDecoder a + = FieldsDecoder {runFieldsDecoder :: Object -> Decoder a} instance Functor FieldsDecoder where {-# INLINE fmap #-} @@ -216,22 +227,35 @@ decodeEitherIO :: Decoder a -> BS.ByteString -> IO a decodeEitherIO d bs = withHermesEnv_ $ \hEnv -> parseByteStringIO hEnv d bs --- Given a HermesEnv, decode a strict ByteString. +-- | Given a HermesEnv, decode a strict ByteString. parseByteString :: HermesEnv -> Decoder a -> BS.ByteString -> Either HermesException a -parseByteString hEnv d bs = Unsafe.unsafeDupablePerformIO . try $ parseByteStringIO hEnv d bs +-- Not dupable, since an abandoned duplicate could hold the env lock forever +-- and send every later decode to a temporary env. +parseByteString hEnv d bs = Unsafe.unsafePerformIO . try $ parseByteStringIO hEnv d bs {-# NOINLINE parseByteString #-} --- Given a HermesEnv, decode a strict ByteString in IO. +-- | Given a HermesEnv, decode a strict ByteString in IO. +-- If the env is busy, decodes on a temporary env instead. parseByteStringIO :: HermesEnv -> Decoder a -> BS.ByteString -> IO a -parseByteStringIO hEnv d bs = +parseByteStringIO hEnv d bs = mask $ \restore -> do + -- Never wait for the lock. A decoder can force a thunk that decodes on + -- this env, so waiting could deadlock. + acquired <- tryTakeMVar (hLock hEnv) + case acquired of + Nothing -> restore (decodeEitherIO d bs) + Just () -> restore (parseLocked hEnv d bs) `finally` putMVar (hLock hEnv) () + +parseLocked :: HermesEnv -> Decoder a -> BS.ByteString -> IO a +parseLocked hEnv d bs = allocaValue $ \valPtr -> withInputBuffer bs $ \inputPtr -> do F.withForeignPtr (hParser hEnv) $ \parserPtr -> - F.withForeignPtr (hDocument hEnv) $ \docPtr -> do - err <- getDocumentValueImpl (Parser parserPtr) inputPtr (Document docPtr) valPtr - flip runReaderT hEnv{hPath=[]} . runDecoderM $ do - handleErrorCode "" err - runDecoder d valPtr + F.withForeignPtr (hDocument hEnv) $ \docPtr -> + F.withForeignPtr (hScratch hEnv) $ \_ -> do + err <- getDocumentValueImpl (Parser parserPtr) inputPtr (Document docPtr) valPtr + flip runReaderT hEnv {hPath = []} . runDecoderM $ do + handleErrorCode "" err + runDecoder d valPtr -- | Allocates foreign references to a simdjson::ondemand::parser and a -- simdjson::ondemand::document. The optional capacity argument sets the max @@ -240,16 +264,22 @@ -- 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. +-- A `HermesEnv` is safe to share across threads. A decode that finds it busy +-- uses a temporary env, so use one per thread or a pool to keep reuse. mkHermesEnv :: Maybe Int -> IO HermesEnv mkHermesEnv mCapacity = do - parser <- mkSIMDParser mCapacity + parser <- mkSIMDParser mCapacity document <- mkSIMDDocument - pure HermesEnv - { hParser = parser - , hDocument = document - , hPath = [] - } + scratchBuf <- F.mallocForeignPtrBytes 48 + lock <- newMVar () + pure + HermesEnv + { hParser = parser + , hDocument = document + , hScratch = scratchBuf + , hLock = lock + , hPath = [] + } mkHermesEnv_ :: IO HermesEnv mkHermesEnv_ = mkHermesEnv Nothing @@ -261,19 +291,19 @@ withHermesEnv_ = withHermesEnv Nothing -- | The library can throw exceptions from simdjson in addition to its own exceptions. -data HermesException = +data HermesException + = -- | An exception thrown from the simdjson library. SIMDException !DocumentError - -- ^ An exception thrown from the simdjson library. - | InternalException !DocumentError - -- ^ An exception thrown from an internal library function. - deriving stock (Eq, Show, Generic) + | -- | An exception thrown from an internal library function. + InternalException !DocumentError + deriving stock (Eq, Generic, Show) instance Exception HermesException instance NFData HermesException formatException :: HermesException -> Text formatException ex = case ex of - SIMDException doc -> formatDoc doc + SIMDException doc -> formatDoc doc InternalException doc -> formatDoc doc where formatDoc err @@ -281,15 +311,15 @@ | otherwise = "Error in " <> path err <> ": " <> errorMsg err -- | Record containing all pertinent information for troubleshooting an exception. -data DocumentError = - DocumentError - { path :: Text - -- ^ The path to the current element determined by the decoder. - -- Formatted in the JSON Pointer standard per RFC 6901. - , errorMsg :: Text - -- ^ An error message. - } - deriving stock (Eq, Show, Generic) +data DocumentError + = DocumentError + { path :: Text + -- ^ The path to the current element determined by the decoder. + -- Formatted in the JSON Pointer standard per RFC 6901. + , errorMsg :: Text + -- ^ An error message. + } + deriving stock (Eq, Generic, Show) instance NFData DocumentError @@ -316,24 +346,29 @@ [] -> "" xs -> T.concat $ fmap escapeKey xs where - els = reverse dl - escapeKey (Key txt) = "/" <> T.concatMap escChar txt - escapeKey (Idx int) = "/" <> (T.pack . show $ int) + els = reverse dl + escapeKey (Key txt) = "/" <> T.concatMap escChar txt + escapeKey (Idx int) = "/" <> (T.pack . show $ int) escapeKey (Pointer p) = p - escChar '/' = "~1" - escChar '~' = "~0" - escChar x = T.singleton x + escChar '/' = "~1" + escChar '~' = "~0" + escChar x = T.singleton x handleErrorCode :: Text -> F.CInt -> DecoderM () handleErrorCode pre errInt = do let errCode = toEnum $ fromIntegral errInt if errCode == SUCCESS - then pure () - else do - errStr <- liftIO $ F.peekCString =<< getErrorMessageImpl errInt - throwSIMD . T.strip $ T.unwords [pre, T.pack errStr] + then pure () + else throwErrorCode pre errInt {-# INLINE handleErrorCode #-} +-- | Throw the simdjson error for a non-zero error code. +throwErrorCode :: Text -> F.CInt -> DecoderM a +throwErrorCode pre errInt = do + errStr <- liftIO $ F.peekCString =<< getErrorMessageImpl errInt + throwSIMD . T.strip $ T.unwords [pre, T.pack errStr] +{-# NOINLINE throwErrorCode #-} + withRunInIO :: ((forall a. DecoderM a -> IO a) -> IO b) -> DecoderM b withRunInIO inner = DecoderM . ReaderT $ \r -> @@ -347,6 +382,20 @@ asks :: (HermesEnv -> a) -> DecoderM a asks f = DecoderM . ReaderT $ pure . f {-# INLINE asks #-} + +-- | Six words for FFI out-parameters, shared by all primitive decoders. +-- Read results before making another FFI call. +scratch :: DecoderM (F.Ptr a) +scratch = asks (F.castPtr . F.unsafeForeignPtrToPtr . hScratch) +{-# INLINE scratch #-} + +-- | The first two scratch words, for calls returning a pointer and a length. +-- Nested decoders overwrite them, so read both before running one. +scratchPair :: DecoderM (F.Ptr a, F.Ptr b) +scratchPair = do + p <- scratch + pure (p, F.castPtr p `F.plusPtr` 8) +{-# INLINE scratchPair #-} local :: (HermesEnv -> HermesEnv) -> DecoderM a -> DecoderM a local f (DecoderM m) = DecoderM . ReaderT $ runReaderT m . f diff --git a/src/Data/Hermes/Decoder/Internal/Scientific.hs b/src/Data/Hermes/Decoder/Internal/Scientific.hs deleted file mode 100644 --- a/src/Data/Hermes/Decoder/Internal/Scientific.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Scientific parsing from Text -- shamelessly copied from Aeson internals. - -module Data.Hermes.Decoder.Internal.Scientific - ( scanScientific - ) where - -import Data.Integer.Conversion (textToInteger) -import Data.Scientific (Scientific) -import Data.Text (Text) - -import qualified Data.Scientific as Sci -import qualified Data.Text as T - --- | Parse 'Scientific' number from 'Text'. --- --- This is different from how JSON numbers are parsed: arbitrary leading zeroes --- are accepted. --- -scanScientific - :: forall r. (Scientific -> Text -> r) - -> (String -> r) - -> Text - -> r -scanScientific kont err input0 = case T.uncons input0 of - Nothing -> errEnd - Just (c, text') - | c == '+' -> scanScientific' kont err text' - | c == '-' -> scanScientific' (\sci -> kont (negate sci)) err text' - | otherwise -> scanScientific' kont err input0 - where - errEnd = err "Unexpected end-of-input while parsing number literal" - -scanScientific' - :: forall r. (Scientific -> Text -> r) - -> (String -> r) - -> Text - -> r -scanScientific' kont err input0 = state_start input0 where - state_start :: Text -> r - state_start !text = case T.uncons text of - Nothing -> errEnd - Just (c, text') - | '0' <= c, c <= '9' -> state_i 1 text' - | otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal" - - state_i :: Int -> Text -> r - state_i !n !text = case T.uncons text of - Nothing -> kont (fromInteger int) text - Just (c, text') - | '0' <= c, c <= '9' -> state_i (n + 1) text' - | '.' == c -> go_dec int text' - | 'e' == c || 'E' == c -> go_sci int 0 text' - | otherwise -> kont (fromInteger int) text - where - int = textToInteger (T.take n input0) - - go_dec :: Integer -> Text -> r - go_dec !int !text1 = case T.uncons text1 of - Nothing -> errEnd - Just (c, text') - | '0' <= c, c <= '9' -> state_dec 1 text' - | otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal" - where - state_dec :: Int -> Text -> r - state_dec !n !text = case T.uncons text of - Nothing -> kont dec text - Just (c, text') - | '0' <= c, c <= '9' -> state_dec (n + 1) text' - | 'e' == c || 'E' == c -> go_sci coef (negate n) text' - | otherwise -> kont dec text - where - frac = textToInteger (T.take n text1) - coef = int * 10 ^ n + frac - dec = Sci.scientific coef (negate n) - - go_sci :: Integer -> Int -> Text -> r - go_sci !coef !exp10 !text2 = case T.uncons text2 of - Nothing -> errEnd - Just (c, text') - | '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 1 text' - | '+' == c -> case T.uncons text' of - Nothing -> errEnd - Just (c', text'') - | '0' <= c', c' <= '9' -> go_sci_pos coef exp10 text' 1 text'' - | otherwise -> errUnx c' - | '-' == c -> case T.uncons text' of - Nothing -> errEnd - Just (c', text'') - | '0' <= c', c' <= '9' -> go_sci_neg coef exp10 text' 1 text'' - | otherwise -> errUnx c' - | otherwise -> errUnx c - - go_sci_pos :: Integer -> Int -> Text -> Int -> Text -> r - go_sci_pos !coef !exp10 !text2 !n !text = case T.uncons text of - Nothing -> kont sci text - Just (c, text') - | '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 (n + 1) text' - | otherwise -> kont sci text - where - exp10' = fromInteger (textToInteger (T.take n text2)) - sci = Sci.scientific coef (exp10 + exp10') - - go_sci_neg :: Integer -> Int -> Text -> Int -> Text -> r - go_sci_neg !coef !exp10 !text2 !n !text = case T.uncons text of - Nothing -> kont sci text - Just (c, text') - | '0' <= c, c <= '9' -> go_sci_neg coef exp10 text2 (n + 1) text' - | otherwise -> kont sci text - where - exp10' = fromInteger (textToInteger (T.take n text2)) - sci = Sci.scientific coef (exp10 - exp10') - - errEnd = err "Unexpected end-of-input while parsing number literal" - errUnx c = err $ "Unexpected " ++ show c ++ " while parsing number literal" diff --git a/src/Data/Hermes/Decoder/Path.hs b/src/Data/Hermes/Decoder/Path.hs --- a/src/Data/Hermes/Decoder/Path.hs +++ b/src/Data/Hermes/Decoder/Path.hs @@ -4,18 +4,18 @@ , withPointer ) where -import Data.Text (Text) +import Data.Text (Text) -import Data.Hermes.Decoder.Internal (DecoderM, HermesEnv(hPath), Path(..), local) +import Data.Hermes.Decoder.Internal (DecoderM, HermesEnv (hPath), Path (..), local) withKey :: Text -> DecoderM a -> DecoderM a -withKey key = local $ \st -> st { hPath = Key key : hPath st } +withKey key = local $ \st -> st {hPath = Key key : hPath st} {-# INLINE withKey #-} withPointer :: Text -> DecoderM a -> DecoderM a -withPointer path = local $ \st -> st { hPath = [Pointer path] } +withPointer path = local $ \st -> st {hPath = [Pointer path]} {-# INLINE withPointer #-} withIndex :: Int -> DecoderM a -> DecoderM a -withIndex idx = local $ \st -> st { hPath = Idx idx : hPath st } +withIndex idx = local $ \st -> st {hPath = Idx idx : hPath st} {-# INLINE withIndex #-} 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 @@ -1,5 +1,4 @@ -- | ISO 8601 Compatibility - module Data.Hermes.Decoder.Time ( day , localTime @@ -11,22 +10,22 @@ , zonedTime ) where -import qualified Data.Time.FromText as Time -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Time as Time import qualified Data.Time.Calendar.Month.Compat as Time import qualified Data.Time.Calendar.Quarter.Compat as Time +import qualified Data.Time.FromText as Time import qualified Data.Time.LocalTime as Local -import Data.Hermes.Decoder.Internal (Decoder(..)) -import Data.Hermes.Decoder.Value (withText) +import Data.Hermes.Decoder.Internal (Decoder (..)) +import Data.Hermes.Decoder.Value (withText) -- | Run a Text parser as a Decoder. runParser :: (Text -> Either String a) -> Text -> Decoder a runParser p t = case p t of Left err -> fail $ "Could not parse date: " <> err - Right r -> pure r + Right r -> pure r {-# INLINE runParser #-} -- | Parse a date of the form [+-]YYYY-MM-DD. 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 @@ -1,7 +1,7 @@ -{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_HADDOCK show-extensions #-} module Data.Hermes.Decoder.Value ( atKey @@ -21,7 +21,6 @@ , objectFold , objectAsMap , objectAsMapExcluding - , parseScientific , scientific , string , text @@ -43,31 +42,31 @@ , withVector ) where -import Control.Monad ((>=>)) +import Control.Monad ((>=>)) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as Unsafe import qualified Data.DList as DList -import Data.Map (Map) +import Data.Integer.Conversion (byteStringToInteger) +import Data.Map (Map) import qualified Data.Map.Strict as M import qualified Data.Scientific as Sci -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Foreign as T import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as GM import qualified Foreign.C.String as F +import qualified Foreign.C.Types as F import qualified Foreign.ForeignPtr as F -import qualified Foreign.Marshal.Alloc as F import qualified Foreign.Marshal.Array as F import qualified Foreign.Marshal.Utils as F import qualified Foreign.Ptr as F import qualified Foreign.Storable as F -import Data.Hermes.Decoder.Internal -import Data.Hermes.Decoder.Internal.Scientific -import Data.Hermes.Decoder.Path -import Data.Hermes.SIMDJSON +import Data.Hermes.Decoder.Internal +import Data.Hermes.Decoder.Path +import Data.Hermes.SIMDJSON -- | Decode a value at the particular JSON pointer following RFC 6901. -- Be careful where you use this because it rewinds the document on each @@ -144,13 +143,11 @@ -- | Returns True if the Value is null. isNull :: Decoder Bool -isNull = Decoder $ \valPtr -> - withRunInIO $ \run -> - F.alloca $ \ptr -> do - err <- isNullImpl valPtr ptr - run $ do - handleErrorCode "" err - fmap F.toBool . liftIO $ F.peek ptr +isNull = Decoder $ \valPtr -> do + ptr <- scratch + err <- liftIO $ isNullImpl valPtr ptr + handleErrorCode "" err + fmap F.toBool . liftIO $ F.peek ptr {-# INLINE isNull #-} -- | Is more efficient by looping in C++ instead of Haskell. @@ -162,6 +159,7 @@ err <- intArrayImpl arrPtr out run $ handleErrorCode "Error decoding array of ints." err F.peekArray len out + {-# RULES "list int/listOfInt" list int = listOfInt #-} -- | Is more efficient by looping in C++ instead of Haskell. @@ -173,6 +171,7 @@ err <- doubleArrayImpl arrPtr out run $ handleErrorCode "Error decoding array of doubles." err F.peekArray len out + {-# RULES "list double/listOfDouble" list double = listOfDouble #-} -- | Find an object field by key, where an exception is thrown @@ -199,14 +198,14 @@ -- | Parse a homogenous JSON array into a Haskell list. list :: Decoder a -> Decoder [a] list f = withArrayIter $ iterateOverArray f -{-# INLINE[2] list #-} +{-# INLINE [2] list #-} -- | Parse a homogenous JSON array into a generic `Vector`. -vector :: G.Vector v a => Decoder a -> Decoder (v a) +vector :: (G.Vector v a) => Decoder a -> Decoder (v a) vector f = withArrayLenIter $ iterateOverArrayLen f {-# INLINE vector #-} -withVector :: G.Vector v a => Decoder a -> (v a -> Decoder a) -> Decoder a +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 #-} @@ -233,7 +232,7 @@ -- | Parse an object into a strict `Map`. objectAsMap - :: Ord k + :: (Ord k) => (Text -> Decoder k) -- ^ Parses a Text key in the Decoder monad. JSON keys are always text. -> Decoder v @@ -245,7 +244,7 @@ -- | Parse an object into a strict `Map`. -- Skips any fields in the given list, which adds a slight performance penalty. objectAsMapExcluding - :: Ord k + :: (Ord k) => [Text] -- ^ List of field names to exclude. -> (Text -> Decoder k) @@ -258,7 +257,7 @@ {-# INLINE objectAsMapExcluding #-} withObjectAsMap - :: Ord k + :: (Ord k) => (Text -> Decoder k) -- ^ Parses a Text key in the Decoder monad. JSON keys are always text. -> Decoder v @@ -308,7 +307,7 @@ -- | Parse a JSON number into a signed Haskell Int. int :: Decoder Int int = Decoder getInt -{-# INLINE[2] int #-} +{-# INLINE [2] int #-} -- | Parse a JSON number into an unsigned Haskell Int (Word). uint :: Decoder Word @@ -318,34 +317,51 @@ -- | Parse a JSON number into a Haskell Double. double :: Decoder Double double = Decoder getDouble -{-# INLINE[2] double #-} +{-# INLINE [2] double #-} -- | Parse a Scientific from a Value. scientific :: Decoder Sci.Scientific -scientific = withRawText parseScientific +scientific = Decoder $ \val -> do + out <- scratch + st <- liftIO $ getScientificImpl val out + let word i = liftIO $ F.peekElemOff out i + if + | st == 0 -> do + coef <- word 0 + expo <- peekExponent out + pure $! Sci.scientific (toInteger coef) expo + | st == -1 -> do + sign <- word 0 + expo <- peekExponent out + digits <- liftIO $ (<>) <$> peekSpan out 2 <*> peekSpan out 4 + let coef = byteStringToInteger digits + pure $! Sci.scientific (if sign < 0 then negate coef else coef) expo + | otherwise -> throwErrorCode (typePrefix "scientific") st + where + -- The exponent is an Int64 and may not fit in Int on 32-bit targets. + peekExponent out = do + expo <- liftIO $ F.peekElemOff out 1 + if toInteger expo < toInteger (minBound :: Int) || toInteger expo > toInteger (maxBound :: Int) + then throwErrorCode (typePrefix "scientific") (fromIntegral $ fromEnum NUMBER_ERROR) + else pure (fromIntegral expo :: Int) + peekSpan out i = do + ptr <- F.peekElemOff out i + len <- F.peekElemOff out (i + 1) + Unsafe.unsafePackCStringLen (F.intPtrToPtr (fromIntegral ptr), fromIntegral len) {-# INLINE scientific #-} withScientific :: (Sci.Scientific -> Decoder a) -> Decoder a withScientific f = Decoder $ \val -> runDecoder scientific val >>= \sci -> runDecoder (f sci) val {-# INLINE withScientific #-} --- | Parse a Scientific from UTF-8 text. -parseScientific :: Text -> Decoder Sci.Scientific -parseScientific = scanScientific - (\sci rest -> if T.null rest then return sci else fail $ "Expecting end-of-input, got " ++ show (T.take 10 rest)) - fail -{-# INLINE parseScientific #-} - -- | Get the simdjson type of the Value. getType :: Decoder ValueType getType = - Decoder $ \valPtr -> - withRunInIO $ \run -> - F.alloca $ \ptr -> do - err <- getTypeImpl valPtr ptr - run $ do - handleErrorCode "" err - fmap (toEnum . fromIntegral) . liftIO $ F.peek ptr + Decoder $ \valPtr -> do + ptr <- scratch + err <- liftIO $ getTypeImpl valPtr ptr + handleErrorCode "" err + fmap (toEnum . fromIntegral) . liftIO $ F.peek ptr {-# INLINE getType #-} withType :: (ValueType -> Decoder a) -> Decoder a @@ -388,19 +404,17 @@ -- | Helper to work with an ArrayIter and its length. withArrayLenIter :: (ArrayIter -> Int -> DecoderM a) -> Decoder a -withArrayLenIter f = Decoder $ \(Value valPtr) -> - withRunInIO $ \run -> do - F.alloca $ \outLen -> do - err <- getArrayIterLenFromValueImpl (Value valPtr) outLen - len <- fmap fromIntegral $ F.peek outLen - run $ do - handleErrorCode "" err - f (ArrayIter $ F.castPtr valPtr) len +withArrayLenIter f = Decoder $ \(Value valPtr) -> do + outLen <- scratch + err <- liftIO $ getArrayIterLenFromValueImpl (Value valPtr) outLen + len <- fmap fromIntegral . liftIO $ F.peek outLen + handleErrorCode "" err + f (ArrayIter $ F.castPtr valPtr) len {-# INLINE withArrayLenIter #-} -- | Execute a function on each Value in an ArrayIter and -- accumulate the results into a generic `Vector`. -iterateOverArrayLen :: G.Vector v a => Decoder a -> ArrayIter -> Int -> DecoderM (v a) +iterateOverArrayLen :: (G.Vector v a) => Decoder a -> ArrayIter -> Int -> DecoderM (v a) iterateOverArrayLen f iterPtr len = withRunInIO $ \run -> allocaValue $ \valPtr -> do @@ -435,16 +449,16 @@ -- | Execute a function on each Field in an ObjectIter and accumulate into a `Map`. iterateOverFieldsMap - :: Ord a + :: (Ord a) => (Text -> Decoder a) -> Decoder b -> ObjectIter -> DecoderM (Map a b) iterateOverFieldsMap fk fv iterPtr = withRunInIO $ \run -> - F.alloca $ \lenPtr -> - F.alloca $ \keyPtr -> - allocaValue $ \valPtr -> run $ go M.empty keyPtr lenPtr valPtr + allocaValue $ \valPtr -> run $ do + (keyPtr, lenPtr) <- scratchPair + go M.empty keyPtr lenPtr valPtr where go !acc keyPtr lenPtr valPtr = do isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr @@ -455,12 +469,11 @@ kLen <- fmap fromIntegral . liftIO $ F.peek lenPtr kStr <- liftIO $ F.peek keyPtr keyTxt <- parseTextFromCStrLen (kStr, kLen) - (k, v) - <- - withKey keyTxt $ do - k <- runDecoder (fk keyTxt) valPtr - v <- runDecoder fv valPtr - pure (k, v) + (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 @@ -468,7 +481,7 @@ {-# INLINE iterateOverFieldsMap #-} iterateOverFieldsMapExcluding - :: Ord a + :: (Ord a) => [Text] -> (Text -> Decoder a) -> Decoder b @@ -476,9 +489,9 @@ -> 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 + allocaValue $ \valPtr -> run $ do + (keyPtr, lenPtr) <- scratchPair + go M.empty keyPtr lenPtr valPtr where go !acc keyPtr lenPtr valPtr = do isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr @@ -494,12 +507,11 @@ 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) + (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 @@ -515,9 +527,9 @@ -> DecoderM [(a, b)] iterateOverFields fk fv iterPtr = withRunInIO $ \run -> - F.alloca $ \lenPtr -> - F.alloca $ \keyPtr -> - allocaValue $ \valPtr -> run $ go DList.empty keyPtr lenPtr valPtr + allocaValue $ \valPtr -> run $ do + (keyPtr, lenPtr) <- scratchPair + go DList.empty keyPtr lenPtr valPtr where go acc keyPtr lenPtr valPtr = do isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr @@ -546,9 +558,9 @@ -> DecoderM state iterateOverFieldsFold initial step iterPtr = withRunInIO $ \run -> - F.alloca $ \lenPtr -> - F.alloca $ \keyPtr -> - allocaValue $ \valPtr -> run $ go initial keyPtr lenPtr valPtr + allocaValue $ \valPtr -> run $ do + (keyPtr, lenPtr) <- scratchPair + go initial keyPtr lenPtr valPtr where go !acc keyPtr lenPtr valPtr = do isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr @@ -582,9 +594,10 @@ 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 + if + | errCode == SUCCESS -> Just <$> runDecoder f vPtr + | errCode == NO_SUCH_FIELD -> pure Nothing + | otherwise -> Nothing <$ handleErrorCode "" err {-# INLINE withUnorderedOptionalField #-} withField :: Value -> Decoder a -> Object -> Text -> DecoderM a @@ -598,51 +611,45 @@ {-# INLINE withField #-} getInt :: Value -> DecoderM Int -getInt valPtr = - withRunInIO $ \run -> - F.alloca $ \ptr -> run $ do - err <- liftIO $ getIntImpl valPtr ptr - handleErrorCode (typePrefix "int") err - liftIO $ F.peek ptr +getInt valPtr = do + ptr <- scratch + err <- liftIO $ getIntImpl valPtr ptr + handleErrorCode (typePrefix "int") err + liftIO $ F.peek ptr {-# INLINE getInt #-} getUInt :: Value -> DecoderM Word -getUInt valPtr = - withRunInIO $ \run -> - F.alloca $ \ptr -> run $ do - err <- liftIO $ getUIntImpl valPtr ptr - handleErrorCode (typePrefix "unsigned int") err - liftIO $ F.peek ptr +getUInt valPtr = do + ptr <- scratch + err <- liftIO $ getUIntImpl valPtr ptr + handleErrorCode (typePrefix "unsigned int") err + liftIO $ F.peek ptr {-# INLINE getUInt #-} getDouble :: Value -> DecoderM Double -getDouble valPtr = - withRunInIO $ \run -> - F.alloca $ \ptr -> run $ do - err <- liftIO $ getDoubleImpl valPtr ptr - handleErrorCode (typePrefix "double") err - liftIO $ F.peek ptr +getDouble valPtr = do + ptr <- scratch + err <- liftIO $ getDoubleImpl valPtr ptr + handleErrorCode (typePrefix "double") err + liftIO $ F.peek ptr {-# INLINE getDouble #-} getBool :: Value -> DecoderM Bool -getBool valPtr = - withRunInIO $ \run -> - F.alloca $ \ptr -> run $ do - err <- liftIO $ getBoolImpl valPtr ptr - handleErrorCode (typePrefix "bool") err - fmap F.toBool . liftIO $ F.peek ptr +getBool valPtr = do + ptr <- scratch + err <- liftIO $ getBoolImpl valPtr ptr + handleErrorCode (typePrefix "bool") err + fmap F.toBool . liftIO $ F.peek ptr {-# INLINE getBool #-} withCStringLen :: Text -> (F.CStringLen -> DecoderM a) -> Value -> DecoderM a -withCStringLen lbl f valPtr = - withRunInIO $ \run -> - F.alloca $ \strPtr -> - F.alloca $ \lenPtr -> run $ do - err <- liftIO $ getStringImpl valPtr strPtr lenPtr - handleErrorCode (typePrefix lbl) err - len <- fmap fromIntegral . liftIO $ F.peek lenPtr - str <- liftIO $ F.peek strPtr - f (str, len) +withCStringLen lbl f valPtr = do + (strPtr, lenPtr) <- scratchPair + err <- liftIO $ getStringImpl valPtr strPtr lenPtr + handleErrorCode (typePrefix lbl) err + len <- fmap fromIntegral . liftIO $ F.peek (lenPtr :: F.Ptr F.CSize) + str <- liftIO $ F.peek strPtr + f (str, len) {-# INLINE withCStringLen #-} getString :: Value -> DecoderM String @@ -658,49 +665,42 @@ {-# INLINE parseTextFromCStrLen #-} getRawByteString :: Value -> DecoderM BS.ByteString -getRawByteString valPtr = - liftIO $ - F.alloca $ \strPtr -> - F.alloca $ \lenPtr -> do - getRawJSONTokenImpl valPtr strPtr lenPtr - len <- fmap fromIntegral $ F.peek lenPtr - str <- F.peek strPtr - Unsafe.unsafePackCStringLen (str, len) +getRawByteString valPtr = do + (strPtr, lenPtr) <- scratchPair + liftIO $ do + getRawJSONTokenImpl valPtr strPtr lenPtr + len <- fmap fromIntegral $ F.peek (lenPtr :: F.Ptr F.CSize) + str <- F.peek strPtr + BS.packCStringLen (str, len) {-# INLINE getRawByteString #-} getRawJsonByteString :: Value -> DecoderM BS.ByteString getRawJsonByteString valPtr = do - (errorCode, cString, byteLength) <- - liftIO $ - F.alloca $ \stringPtr -> - F.alloca $ \lengthPtr -> do - errorCode <- getRawJSONImpl valPtr stringPtr lengthPtr - byteLength <- fmap fromIntegral $ F.peek lengthPtr - cString <- F.peek stringPtr - pure (errorCode, cString, byteLength) + (strPtr, lenPtr) <- scratchPair + errorCode <- liftIO $ getRawJSONImpl valPtr strPtr lenPtr handleErrorCode "raw JSON" errorCode - liftIO $ Unsafe.unsafePackCStringLen (cString, byteLength) + liftIO $ do + byteLength <- fmap fromIntegral $ F.peek (lenPtr :: F.Ptr F.CSize) + cString <- F.peek strPtr + BS.packCStringLen (cString, byteLength) {-# INLINE getRawJsonByteString #-} getRawText :: Value -> DecoderM Text -getRawText valPtr = - liftIO $ - F.alloca $ \strPtr -> - F.alloca $ \lenPtr -> do - getRawJSONTokenImpl valPtr strPtr lenPtr - len <- fmap fromIntegral $ F.peek lenPtr - str <- F.peek strPtr - T.fromPtr (F.castPtr str) len +getRawText valPtr = do + (strPtr, lenPtr) <- scratchPair + liftIO $ do + getRawJSONTokenImpl valPtr strPtr lenPtr + len <- fmap fromIntegral $ F.peek (lenPtr :: F.Ptr F.CSize) + str <- F.peek strPtr + T.fromPtr (F.castPtr str) len {-# INLINE getRawText #-} -- | Helper to work with an Array and its length parsed from a Value. withArrayLen :: ((Array, Int) -> DecoderM a) -> Decoder a -withArrayLen f = Decoder $ \(Value val) -> - withRunInIO $ \run -> - F.alloca $ \outLen -> do - err <- getArrayLenFromValueImpl (Value val) outLen - len <- fmap fromIntegral $ F.peek outLen - run $ do - handleErrorCode (typePrefix "array") err - f (Array $ F.castPtr val, len) +withArrayLen f = Decoder $ \(Value val) -> do + outLen <- scratch + err <- liftIO $ getArrayLenFromValueImpl (Value val) outLen + len <- fmap fromIntegral . liftIO $ F.peek outLen + handleErrorCode (typePrefix "array") err + f (Array $ F.castPtr val, len) {-# INLINE withArrayLen #-} diff --git a/src/Data/Hermes/SIMDJSON/Bindings.hs b/src/Data/Hermes/SIMDJSON/Bindings.hs --- a/src/Data/Hermes/SIMDJSON/Bindings.hs +++ b/src/Data/Hermes/SIMDJSON/Bindings.hs @@ -1,5 +1,4 @@ -- | Contains Haskell bindings to C++ wrappers around simdjson methods. - module Data.Hermes.SIMDJSON.Bindings ( arrayIterGetCurrentImpl , arrayIterIsDoneImpl @@ -24,6 +23,7 @@ , getObjectIterFromValueImpl , getRawJSONTokenImpl , getRawJSONImpl + , getScientificImpl , getStringImpl , getTypeImpl , intArrayImpl @@ -39,119 +39,160 @@ , resetObjectImpl ) where -import Foreign.C (CBool(..), CInt(..), CSize(..), CString) -import Foreign.Ptr (FunPtr, Ptr) +import Data.Int (Int64) +import Foreign.C (CBool (..), CInt (..), CSize (..), CString) +import Foreign.Ptr (FunPtr, Ptr) -import Data.Hermes.SIMDJSON.Types +import Data.Hermes.SIMDJSON.Types -- Constructor/destructors -foreign import ccall safe "parser_init" parserInit - :: CSize -> IO (Ptr SIMDParser) +foreign import ccall safe "parser_init" + parserInit + :: CSize -> IO (Ptr SIMDParser) -foreign import ccall unsafe "&parser_destroy" parserDestroy - :: FunPtr (Ptr SIMDParser -> IO ()) +foreign import ccall unsafe "&parser_destroy" + parserDestroy + :: FunPtr (Ptr SIMDParser -> IO ()) -foreign import ccall safe "make_document" makeDocumentImpl - :: IO (Ptr SIMDDocument) +foreign import ccall safe "make_document" + makeDocumentImpl + :: IO (Ptr SIMDDocument) -foreign import ccall unsafe "&delete_document" deleteDocumentImpl - :: FunPtr (Ptr SIMDDocument -> IO ()) +foreign import ccall unsafe "&delete_document" + deleteDocumentImpl + :: FunPtr (Ptr SIMDDocument -> IO ()) -foreign import ccall safe "make_input" makeInputImpl - :: CString -> CSize -> IO (Ptr PaddedString) +foreign import ccall safe "make_input" + makeInputImpl + :: CString -> CSize -> IO (Ptr PaddedString) -foreign import ccall unsafe "&delete_input" deleteInputImpl - :: FunPtr (Ptr PaddedString -> IO ()) +foreign import ccall unsafe "&delete_input" + deleteInputImpl + :: FunPtr (Ptr PaddedString -> IO ()) -- Document parsers -foreign import ccall safe "get_document_value" getDocumentValueImpl - :: Parser -> InputBuffer -> Document -> Value -> IO CInt +foreign import ccall safe "get_document_value" + getDocumentValueImpl + :: Parser -> InputBuffer -> Document -> Value -> IO CInt -foreign import ccall unsafe "at_pointer" atPointerImpl - :: CString -> Int -> Document -> Value -> IO CInt +foreign import ccall unsafe "at_pointer" + atPointerImpl + :: CString -> Int -> Document -> Value -> IO CInt -foreign import ccall unsafe "get_object_from_value" getObjectFromValueImpl - :: Value -> IO CInt +foreign import ccall unsafe "get_object_from_value" + getObjectFromValueImpl + :: Value -> IO CInt -foreign import ccall unsafe "get_object_iter_from_value" getObjectIterFromValueImpl - :: Value -> IO CInt +foreign import ccall unsafe "get_object_iter_from_value" + getObjectIterFromValueImpl + :: Value -> IO CInt -foreign import ccall unsafe "obj_iter_is_done" objectIterIsDoneImpl - :: ObjectIter -> IO CBool +foreign import ccall unsafe "obj_iter_is_done" + objectIterIsDoneImpl + :: ObjectIter -> IO CBool -foreign import ccall unsafe "obj_iter_get_current" objectIterGetCurrentImpl - :: ObjectIter -> Ptr CString -> Ptr CSize -> Value -> IO CInt +foreign import ccall unsafe "obj_iter_get_current" + objectIterGetCurrentImpl + :: ObjectIter -> Ptr CString -> Ptr CSize -> Value -> IO CInt -foreign import ccall unsafe "obj_iter_move_next" objectIterMoveNextImpl - :: ObjectIter -> IO () +foreign import ccall unsafe "obj_iter_move_next" + objectIterMoveNextImpl + :: ObjectIter -> IO () -foreign import ccall unsafe "get_array_from_value" getArrayFromValueImpl - :: Value -> Array -> IO CInt +foreign import ccall unsafe "get_array_from_value" + getArrayFromValueImpl + :: Value -> Array -> IO CInt -foreign import ccall unsafe "get_array_len_from_value" getArrayLenFromValueImpl - :: Value -> Ptr CSize -> IO CInt +foreign import ccall unsafe "get_array_len_from_value" + getArrayLenFromValueImpl + :: Value -> Ptr CSize -> IO CInt -foreign import ccall unsafe "int_array" intArrayImpl - :: Array -> Ptr Int -> IO CInt +foreign import ccall unsafe "int_array" + intArrayImpl + :: Array -> Ptr Int -> IO CInt -foreign import ccall unsafe "double_array" doubleArrayImpl - :: Array -> Ptr Double -> IO CInt +foreign import ccall unsafe "double_array" + doubleArrayImpl + :: Array -> Ptr Double -> IO CInt -foreign import ccall unsafe "get_array_iter_from_value" getArrayIterFromValueImpl - :: Value -> IO CInt +foreign import ccall unsafe "get_array_iter_from_value" + getArrayIterFromValueImpl + :: Value -> IO CInt -foreign import ccall unsafe "get_array_iter_len_from_value" getArrayIterLenFromValueImpl - :: Value -> Ptr CSize -> IO CInt +foreign import ccall unsafe "get_array_iter_len_from_value" + getArrayIterLenFromValueImpl + :: Value -> Ptr CSize -> IO CInt -foreign import ccall unsafe "arr_iter_is_done" arrayIterIsDoneImpl - :: ArrayIter -> IO CBool +foreign import ccall unsafe "arr_iter_is_done" + arrayIterIsDoneImpl + :: ArrayIter -> IO CBool -foreign import ccall unsafe "arr_iter_get_current" arrayIterGetCurrentImpl - :: ArrayIter -> Value -> IO CInt +foreign import ccall unsafe "arr_iter_get_current" + arrayIterGetCurrentImpl + :: ArrayIter -> Value -> IO CInt -foreign import ccall unsafe "arr_iter_move_next" arrayIterMoveNextImpl - :: ArrayIter -> IO () +foreign import ccall unsafe "arr_iter_move_next" + arrayIterMoveNextImpl + :: ArrayIter -> IO () -foreign import ccall unsafe "reset_array" resetArrayImpl - :: Array -> IO () +foreign import ccall unsafe "reset_array" + resetArrayImpl + :: Array -> IO () -foreign import ccall unsafe "reset_object" resetObjectImpl - :: Object -> IO () +foreign import ccall unsafe "reset_object" + resetObjectImpl + :: Object -> IO () -foreign import ccall unsafe "find_field_unordered" findFieldUnorderedImpl - :: Object -> CString -> Int -> Value -> IO CInt +foreign import ccall unsafe "find_field_unordered" + findFieldUnorderedImpl + :: Object -> CString -> Int -> Value -> IO CInt -foreign import ccall unsafe "find_field" findFieldImpl - :: Object -> CString -> Int -> Value -> IO CInt +foreign import ccall unsafe "find_field" + findFieldImpl + :: Object -> CString -> Int -> Value -> IO CInt -- Helpers -foreign import ccall unsafe "get_error_message" getErrorMessageImpl - :: CInt -> IO CString +foreign import ccall unsafe "get_error_message" + getErrorMessageImpl + :: CInt -> IO CString -- Primitives -foreign import ccall unsafe "get_int" getIntImpl - :: Value -> Ptr Int -> IO CInt +foreign import ccall unsafe "get_int" + getIntImpl + :: Value -> Ptr Int -> IO CInt -foreign import ccall unsafe "get_uint" getUIntImpl - :: Value -> Ptr Word -> IO CInt +foreign import ccall unsafe "get_uint" + getUIntImpl + :: Value -> Ptr Word -> IO CInt -foreign import ccall unsafe "get_double" getDoubleImpl - :: Value -> Ptr Double -> IO CInt +foreign import ccall unsafe "get_double" + getDoubleImpl + :: Value -> Ptr Double -> IO CInt -foreign import ccall unsafe "get_string" getStringImpl - :: Value -> Ptr CString -> Ptr CSize -> IO CInt +foreign import ccall unsafe "get_string" + getStringImpl + :: Value -> Ptr CString -> Ptr CSize -> IO CInt -foreign import ccall unsafe "get_bool" getBoolImpl - :: Value -> Ptr CBool -> IO CInt +foreign import ccall unsafe "get_bool" + getBoolImpl + :: Value -> Ptr CBool -> IO CInt -foreign import ccall unsafe "get_raw_json_token" getRawJSONTokenImpl - :: Value -> Ptr CString -> Ptr CSize -> IO () +foreign import ccall unsafe "get_raw_json_token" + getRawJSONTokenImpl + :: Value -> Ptr CString -> Ptr CSize -> IO () -foreign import ccall unsafe "get_raw_json" getRawJSONImpl - :: Value -> Ptr CString -> Ptr CSize -> IO CInt +foreign import ccall unsafe "get_raw_json" + getRawJSONImpl + :: Value -> Ptr CString -> Ptr CSize -> IO CInt -foreign import ccall unsafe "get_type" getTypeImpl - :: Value -> Ptr CInt -> IO CInt +foreign import ccall unsafe "get_type" + getTypeImpl + :: Value -> Ptr CInt -> IO CInt -foreign import ccall unsafe "is_null" isNullImpl - :: Value -> Ptr CBool -> IO CInt +foreign import ccall unsafe "get_scientific" + getScientificImpl + :: Value -> Ptr Int64 -> IO CInt + +foreign import ccall unsafe "is_null" + isNullImpl + :: Value -> Ptr CBool -> IO CInt diff --git a/src/Data/Hermes/SIMDJSON/Types.hs b/src/Data/Hermes/SIMDJSON/Types.hs --- a/src/Data/Hermes/SIMDJSON/Types.hs +++ b/src/Data/Hermes/SIMDJSON/Types.hs @@ -2,28 +2,28 @@ module Data.Hermes.SIMDJSON.Types ( -- * simdjson Opaque Types - Array(..) - , ArrayIter(..) - , Document(..) - , InputBuffer(..) + Array (..) + , ArrayIter (..) + , Document (..) + , InputBuffer (..) , JSONArray , JSONArrayIter , JSONObject , JSONObjectIter , JSONValue - , Object(..) - , ObjectIter(..) + , Object (..) + , ObjectIter (..) , PaddedString - , Parser(..) + , Parser (..) , SIMDDocument - , SIMDErrorCode(..) + , SIMDErrorCode (..) , SIMDParser - , Value(..) - , ValueType(..) + , Value (..) + , ValueType (..) ) - where +where -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr) -- | A reference to an opaque simdjson::ondemand::parser. newtype Parser = Parser (Ptr SIMDParser) @@ -74,8 +74,8 @@ data JSONObjectIter -- | Enum for simdjson errors. -data SIMDErrorCode = - SUCCESS +data SIMDErrorCode + = SUCCESS | CAPACITY | MEMALLOC | TAPE_ERROR @@ -107,32 +107,32 @@ | SCALAR_DOCUMENT_AS_VALUE | OUT_OF_BOUNDS | TRAILING_CONTENT - deriving (Eq, Show, Bounded, Enum) + deriving (Bounded, Enum, Eq, Show) -data ValueType = - VArray +data ValueType + = VArray | VObject | VNumber | VString | VBoolean | VNull - deriving (Eq, Bounded, Show) + deriving (Bounded, Eq, Show) instance Enum ValueType where - fromEnum - = \case - VArray -> 1 - VObject -> 2 - VNumber -> 3 - VString -> 4 - VBoolean -> 5 - VNull -> 6 - toEnum - = \case - 1 -> VArray - 2 -> VObject - 3 -> VNumber - 4 -> VString - 5 -> VBoolean - 6 -> VNull - _ -> error "unknown int for Value type" + fromEnum = + \case + VArray -> 1 + VObject -> 2 + VNumber -> 3 + VString -> 4 + VBoolean -> 5 + VNull -> 6 + toEnum = + \case + 1 -> VArray + 2 -> VObject + 3 -> VNumber + 4 -> VString + 5 -> VBoolean + 6 -> VNull + _ -> error "unknown int for Value type" diff --git a/src/Data/Hermes/SIMDJSON/Wrapper.hs b/src/Data/Hermes/SIMDJSON/Wrapper.hs --- a/src/Data/Hermes/SIMDJSON/Wrapper.hs +++ b/src/Data/Hermes/SIMDJSON/Wrapper.hs @@ -1,5 +1,4 @@ -- | Contains functions for constructing and working with foreign simdjson instances. - module Data.Hermes.SIMDJSON.Wrapper ( allocaValue , mkSIMDParser @@ -7,16 +6,16 @@ , mkSIMDPaddedStr , withInputBuffer ) - where +where -import Data.ByteString (ByteString) +import Control.Exception (finally, mask_) +import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as Unsafe -import Data.Maybe (fromMaybe) -import Control.Exception (mask_) +import Data.Maybe (fromMaybe) import qualified Foreign.ForeignPtr as F import qualified Foreign.Marshal.Alloc as F -import Data.Hermes.SIMDJSON.Bindings +import Data.Hermes.SIMDJSON.Bindings ( deleteDocumentImpl , deleteInputImpl , makeDocumentImpl @@ -24,11 +23,11 @@ , parserDestroy , parserInit ) -import Data.Hermes.SIMDJSON.Types +import Data.Hermes.SIMDJSON.Types mkSIMDParser :: Maybe Int -> IO (F.ForeignPtr SIMDParser) mkSIMDParser mCap = mask_ $ do - let maxCap = 4000000000; -- 4GB + let maxCap = 4000000000 -- 4GB ptr <- parserInit . toEnum $ fromMaybe maxCap mCap F.newForeignPtr parserDestroy ptr {-# INLINE mkSIMDParser #-} @@ -49,7 +48,8 @@ withInputBuffer :: ByteString -> (InputBuffer -> IO a) -> IO a withInputBuffer bs f = do pStr <- mkSIMDPaddedStr bs - F.withForeignPtr pStr $ f . InputBuffer + -- Free the copy now rather than waiting for a GC to run the finalizer. + F.withForeignPtr pStr (f . InputBuffer) `finally` F.finalizeForeignPtr pStr {-# INLINE withInputBuffer #-} allocaValue :: (Value -> IO a) -> IO a diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -6,26 +6,31 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) +import Control.Monad (replicateM_) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BSL -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Scientific (Scientific) import qualified Data.Scientific as Sci -import Data.Scientific (Scientific) -import Data.Text (Text) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Time as Time import qualified Data.Vector as V -import Data.Word (Word16) -import GHC.Generics (Generic) -import Hedgehog +import Data.Word (Word16) +import GHC.Generics (Generic) +import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Hedgehog +import System.Mem (performGC) +import System.Timeout (timeout) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog -import Data.Hermes +import Data.Hermes main :: IO () main = defaultMain tests @@ -34,30 +39,99 @@ tests = testGroup "Tests" [properties, units] properties :: TestTree -properties = testGroup "Properties" [rtProp, rtPropOptional, rtErrors, rtRecursiveDataType] +properties = testGroup "Properties" [rtProp, rtPropOptional, rtErrors, rtRecursiveDataType, scientificMatchesAeson] units :: TestTree -units = testGroup "Units" [altCases, objectFields, dependentObjectFold, rawJsonAccess] +units = + testGroup + "Units" + [altCases, objectFields, dependentObjectFold, rawJsonAccess, rawOutlivesInput, scientificCases, nestedSameEnv] dependentObjectFold :: TestTree -dependentObjectFold = testCase "dependent object fold" $ - decodeEither - (objectFold (0 :: Int) $ \key total -> - case key of - "add" -> (+ total) <$> int - "enabled" -> (\value -> if value then total + 100 else total) <$> bool - _ -> total <$ withRawJsonByteString (const (pure ()))) - "{\"add\":2,\"ignored\":{\"nested\":[1,2]},\"enabled\":true,\"add\":3}" - @?= Right 105 +dependentObjectFold = + testCase "dependent object fold" $ + decodeEither + ( objectFold (0 :: Int) $ \key total -> + case key of + "add" -> (+ total) <$> int + "enabled" -> (\value -> if value then total + 100 else total) <$> bool + _ -> total <$ withRawJsonByteString (const (pure ())) + ) + "{\"add\":2,\"ignored\":{\"nested\":[1,2]},\"enabled\":true,\"add\":3}" + @?= Right 105 rawJsonAccess :: TestTree -rawJsonAccess = testCase "complete raw JSON access" $ - decodeEither - (object $ atKey "payload" $ - withRawJsonByteString (\bytes -> pure bytes)) - "{\"payload\":{\"nested\":[1,true,null]}}" - @?= Right "{\"nested\":[1,true,null]}" +rawJsonAccess = + testCase "complete raw JSON access" $ + decodeEither + ( object + $ atKey "payload" + $ withRawJsonByteString (\bytes -> pure bytes) + ) + "{\"payload\":{\"nested\":[1,true,null]}}" + @?= Right "{\"nested\":[1,true,null]}" +scientificMatchesAeson :: TestTree +scientificMatchesAeson = testProperty "Scientific Matches Aeson" $ + property $ do + num <- forAll genNumberToken + pad <- forAll $ Gen.element ["", " ", "\n "] + let input = T.encodeUtf8 $ "[" <> pad <> num <> pad <> "]" + either (const Nothing) Just (decodeEither (list scientific) input) + === (A.decodeStrict input :: Maybe [Scientific]) + where + digits lo hi = Gen.text (Range.linear lo hi) Gen.digit + genNumberToken = do + sign <- Gen.element ["", "-"] + whole <- Gen.choice [pure "0", (<>) <$> (T.singleton <$> Gen.element ['1' .. '9']) <*> digits 0 30] + frac <- Gen.maybe (digits 1 30) + ex <- + Gen.maybe $ + (\e es ds -> e <> es <> ds) + <$> Gen.element ["e", "E"] + <*> Gen.element ["", "+", "-"] + <*> digits 1 3 + pure $ sign <> whole <> maybe "" ("." <>) frac <> maybe "" Prelude.id ex + +fmtErr :: Either HermesException a -> Either Text a +fmtErr = either (Left . formatException) Right + +scientificCases :: TestTree +scientificCases = testCase "Scientific" $ do + decodeEither (list scientific) "[1.5,-0.25e3,0,-0.5,1E+2,-123456789012345678901.5e-3]" + @?= Right [1.5, -250, 0, -0.5, 100, -123456789012345678.9015] + fmtErr (decodeEither (list scientific) "[007]") + @?= Left "Error in /0: Error while getting value of type scientific. NUMBER_ERROR: Problem while parsing a number" + fmtErr (decodeEither (list scientific) "[+5]") + @?= Left + "Error in /0: Error while getting value of type scientific. INCORRECT_TYPE: The JSON element does not have the requested type." + decodeEither (object $ atKey "a" scientific) "{ \"a\": 1.5 }" @?= Right 1.5 + fmtErr (decodeEither (list scientific) "[\"1\"]") + @?= Left + "Error in /0: Error while getting value of type scientific. INCORRECT_TYPE: The JSON element does not have the requested type." + fmtErr (decodeEither (list scientific) "[1.e5]") + @?= Left "Error in /0: Error while getting value of type scientific. NUMBER_ERROR: Problem while parsing a number" + decodeEither (list scientific) "[1e0000000000000000001,1e-100000000000000000]" + @?= Right [10, Sci.scientific 1 (-100000000000000000)] + fmtErr (decodeEither (list scientific) "[1e1000000000000000000]") + @?= Left "Error in /0: Error while getting value of type scientific. NUMBER_ERROR: Problem while parsing a number" + +rawOutlivesInput :: TestTree +rawOutlivesInput = testCase "raw ByteStrings outlive the input buffer" $ do + let decodeRaw = either (ioError . userError . show) pure . decodeEither (list $ withRawJsonByteString pure) + raw <- decodeRaw "[{\"a\":[1,2,3]},\"x\"]" + performGC + replicateM_ 100 $ decodeRaw "[{\"b\":[4,5,6]},\"y\"]" + raw @?= ["{\"a\":[1,2,3]}", "\"x\""] + +nestedSameEnv :: TestTree +nestedSameEnv = testCase "decoder forcing a decode on its own env" $ do + env <- mkHermesEnv_ + let inner = parseByteString env (object $ atKey "b" int) "{\"b\": 2}" + outer = object $ atKey "a" int >>= \a -> either (fail . show) (pure . (+ a)) inner + result <- timeout 5000000 $ pure $! parseByteString env outer "{\"a\": 1}" + result @?= Just (Right 3) + rtRecursiveDataType :: TestTree rtRecursiveDataType = testProperty "Round Trip With Recursive Data Type" $ property $ do @@ -82,265 +156,290 @@ rtErrors :: TestTree rtErrors = testProperty "Errors Should Not Break Referential Transparency" $ property $ do - p <- forAll - $ Gen.element - [ "{" - , "}" - , "{\"}" - , "true" - , "{\"key\": }" - , "[" - , "]" - , "\x00" - , "{\"_id\": false }" - ] + p <- + forAll $ + Gen.element + [ "{" + , "}" + , "{\"}" + , "true" + , "{\"key\": }" + , "[" + , "]" + , "\x00" + , "{\"_id\": false }" + ] let d1 = decodeEither decodePerson p d2 = decodeEither decodePerson p d1 === d2 -roundtrip :: A.ToJSON a => Decoder a -> a -> PropertyT IO a +roundtrip :: (A.ToJSON a) => Decoder a -> a -> PropertyT IO a roundtrip decoder = either (fail . show) pure . decodeEither decoder . BSL.toStrict . A.encode altCases :: TestTree -altCases = testGroup "Alternative" - [ testCase "Object Iterator" $ - decodeEither - (objectAsMap pure (1 <$ bool) <|> objectAsMap pure int) - "{ \"key1\": 1, \"key2\": 2 }" - @?= Right (Map.fromList [("key1", 1), ("key2", 2)]) - - , testCase "Array Iterator" $ - decodeEither - (([1] <$ list bool) <|> list int) - "[1, 2, 3]" - @?= Right [1,2,3] - - , testCase "Number Arrays (Not Iterator)" $ - decodeEither - (listOfDouble <|> ([1.0] <$ listOfInt)) - "[1, true, 3]" - @?= Left (SIMDException (DocumentError - { path = "" - , errorMsg = "Error decoding array of ints. \ - \INCORRECT_TYPE: The JSON element \ - \does not have the requested type." - })) - - , testCase "Inner Array Decoder" $ - decodeEither - (list ((1 <$ bool) <|> int)) - "[1, 2, 3]" - @?= Right [1,2,3] - - , testCase "Inner Object Decoder" $ - decodeEither - (objectAsMap (\txt -> fail "nope" <|> pure txt) ((1 <$ bool) <|> int)) - "{ \"key1\": 1, \"key2\": 2 }" - @?= Right (Map.fromList [("key1", 1), ("key2", 2)]) - - , 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)) - "{ \"key1\": 1, \"key2\": 2 }" - @?= Right 1 - ] +altCases = + testGroup + "Alternative" + [ testCase "Object Iterator" $ + decodeEither + (objectAsMap pure (1 <$ bool) <|> objectAsMap pure int) + "{ \"key1\": 1, \"key2\": 2 }" + @?= Right (Map.fromList [("key1", 1), ("key2", 2)]) + , testCase "Array Iterator" $ + decodeEither + (([1] <$ list bool) <|> list int) + "[1, 2, 3]" + @?= Right [1, 2, 3] + , testCase "Number Arrays (Not Iterator)" $ + decodeEither + (listOfDouble <|> ([1.0] <$ listOfInt)) + "[1, true, 3]" + @?= Left + ( SIMDException + ( DocumentError + { path = "" + , errorMsg = + "Error decoding array of ints. \ + \INCORRECT_TYPE: The JSON element \ + \does not have the requested type." + } + ) + ) + , testCase "Inner Array Decoder" $ + decodeEither + (list ((1 <$ bool) <|> int)) + "[1, 2, 3]" + @?= Right [1, 2, 3] + , testCase "Inner Object Decoder" $ + decodeEither + (objectAsMap (\txt -> fail "nope" <|> pure txt) ((1 <$ bool) <|> int)) + "{ \"key1\": 1, \"key2\": 2 }" + @?= Right (Map.fromList [("key1", 1), ("key2", 2)]) + , 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)) + "{ \"key1\": 1, \"key2\": 2 }" + @?= 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")])) - ] +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 - , index :: Int - , guid :: Text - , isActive :: Bool - , balance :: Text - , picture :: Maybe Text - , age :: Word - , latitude :: Double - , longitude :: Double - , tags :: V.Vector Text - , friends :: [Friend] - , doubles :: [[Double]] - , greeting :: Maybe Text - , favoriteFruit :: Text - , employer :: Employer - , mapOfInts :: Map KeyType Int - , utcTimeField :: Time.UTCTime - } - deriving stock (Eq, Show, Generic) - deriving anyclass (A.ToJSON) +data Person + = Person + { _id :: Text + , index :: Int + , guid :: Text + , isActive :: Bool + , balance :: Text + , picture :: Maybe Text + , age :: Word + , latitude :: Double + , longitude :: Double + , tags :: V.Vector Text + , friends :: [Friend] + , doubles :: [[Double]] + , greeting :: Maybe Text + , favoriteFruit :: Text + , employer :: Employer + , mapOfInts :: Map KeyType Int + , utcTimeField :: Time.UTCTime + } + deriving stock (Eq, Generic, Show) + deriving anyclass (A.ToJSON) -data PersonOptional = - PersonOptional - { _id :: Maybe Text - , index :: Maybe Int - , guid :: Maybe Text - , isActive :: Maybe Bool - , balance :: Maybe Text - , picture :: Maybe (Maybe Text) - , age :: Maybe Word - , latitude :: Maybe Double - , longitude :: Maybe Double - , tags :: Maybe (V.Vector Text) - , friends :: Maybe [Friend] - , doubles :: Maybe [[Double]] - , greeting :: Maybe (Maybe Text) - , favoriteFruit :: Maybe Text - , employer :: Maybe Employer - , mapOfInts :: Maybe (Map KeyType Int) - , utcTimeField :: Maybe Time.UTCTime - } - deriving stock (Eq, Show, Generic) +data PersonOptional + = PersonOptional + { _id :: Maybe Text + , index :: Maybe Int + , guid :: Maybe Text + , isActive :: Maybe Bool + , balance :: Maybe Text + , picture :: Maybe (Maybe Text) + , age :: Maybe Word + , latitude :: Maybe Double + , longitude :: Maybe Double + , tags :: Maybe (V.Vector Text) + , friends :: Maybe [Friend] + , doubles :: Maybe [[Double]] + , greeting :: Maybe (Maybe Text) + , favoriteFruit :: Maybe Text + , employer :: Maybe Employer + , mapOfInts :: Maybe (Map KeyType Int) + , utcTimeField :: Maybe Time.UTCTime + } + deriving stock (Eq, Generic, Show) instance A.ToJSON PersonOptional where - toJSON = A.genericToJSON A.defaultOptions { A.omitNothingFields = True } + toJSON = A.genericToJSON A.defaultOptions {A.omitNothingFields = True} newtype KeyType = KeyType Text - deriving newtype (Eq, Ord, Show, A.ToJSON, A.ToJSONKey) + deriving newtype (A.ToJSON, A.ToJSONKey, Eq, Ord, Show) -data Friend = - Friend - { id :: Int - , name :: Text - } - deriving stock (Eq, Show, Generic) - deriving anyclass A.ToJSON +data Friend + = Friend + { id :: Int + , name :: Text + } + deriving stock (Eq, Generic, Show) + deriving anyclass (A.ToJSON) -data Employer = - Employer - { inefficient :: String - , exp :: Scientific - } - deriving stock (Eq, Show, Generic) - deriving anyclass A.ToJSON +data Employer + = Employer + { inefficient :: String + , exp :: Scientific + } + deriving stock (Eq, Generic, Show) + deriving anyclass (A.ToJSON) decodePerson :: Decoder Person -decodePerson = object $ - Person - <$> atKey "_id" text - <*> atKey "index" int - <*> atKey "guid" text - <*> atKey "isActive" bool - <*> atKey "balance" text - <*> atKey "picture" (nullable text) - <*> atKey "age" uint - <*> atKey "latitude" double - <*> atKey "longitude" double - <*> atKey "tags" (vector text) - <*> atKey "friends" (list decodeFriend) - <*> atKey "doubles" (list (list double)) - <*> atKey "greeting" (nullable text) - <*> atKey "favoriteFruit" text - <*> atKey "employer" decodeEmployer - <*> (Map.fromList <$> atKey "mapOfInts" - (objectAsKeyValues (pure . KeyType) int)) - <*> atKey "utcTimeField" utcTime +decodePerson = + object $ + Person + <$> atKey "_id" text + <*> atKey "index" int + <*> atKey "guid" text + <*> atKey "isActive" bool + <*> atKey "balance" text + <*> atKey "picture" (nullable text) + <*> atKey "age" uint + <*> atKey "latitude" double + <*> atKey "longitude" double + <*> atKey "tags" (vector text) + <*> atKey "friends" (list decodeFriend) + <*> atKey "doubles" (list (list double)) + <*> atKey "greeting" (nullable text) + <*> atKey "favoriteFruit" text + <*> atKey "employer" decodeEmployer + <*> ( Map.fromList + <$> atKey + "mapOfInts" + (objectAsKeyValues (pure . KeyType) int) + ) + <*> atKey "utcTimeField" utcTime decodePersonOptional :: Decoder PersonOptional -decodePersonOptional = object $ - PersonOptional - <$> atKeyOptional "_id" text - <*> atKeyOptional "index" int - <*> atKeyOptional "guid" text - <*> atKeyOptional "isActive" bool - <*> atKeyOptional "balance" text - <*> atKeyOptional "picture" (nullable text) - <*> atKeyOptional "age" uint - <*> atKeyOptional "latitude" double - <*> atKeyOptional "longitude" double - <*> atKeyOptional "tags" (vector text) - <*> atKeyOptional "friends" (list decodeFriend) - <*> atKeyOptional "doubles" (list (list double)) - <*> atKeyOptional "greeting" (nullable text) - <*> atKeyOptional "favoriteFruit" text - <*> atKeyOptional "employer" decodeEmployer - <*> (fmap Map.fromList <$> atKeyOptional "mapOfInts" - (objectAsKeyValues (pure . KeyType) int)) - <*> atKeyOptional "utcTimeField" utcTime +decodePersonOptional = + object $ + PersonOptional + <$> atKeyOptional "_id" text + <*> atKeyOptional "index" int + <*> atKeyOptional "guid" text + <*> atKeyOptional "isActive" bool + <*> atKeyOptional "balance" text + <*> atKeyOptional "picture" (nullable text) + <*> atKeyOptional "age" uint + <*> atKeyOptional "latitude" double + <*> atKeyOptional "longitude" double + <*> atKeyOptional "tags" (vector text) + <*> atKeyOptional "friends" (list decodeFriend) + <*> atKeyOptional "doubles" (list (list double)) + <*> atKeyOptional "greeting" (nullable text) + <*> atKeyOptional "favoriteFruit" text + <*> atKeyOptional "employer" decodeEmployer + <*> ( fmap Map.fromList + <$> atKeyOptional + "mapOfInts" + (objectAsKeyValues (pure . KeyType) int) + ) + <*> atKeyOptional "utcTimeField" utcTime decodeFriend :: Decoder Friend -decodeFriend = object $ - Friend - <$> atKey "id" int - <*> atKey "name" text +decodeFriend = + object $ + Friend + <$> atKey "id" int + <*> atKey "name" text genPerson :: Gen Person -genPerson = Person - <$> Gen.text (Range.linear 0 100) Gen.unicode - <*> Gen.int (Range.linear minBound maxBound) - <*> Gen.text (Range.linear 0 100) Gen.unicode - <*> Gen.bool - <*> Gen.text (Range.linear 0 100) Gen.unicode - <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.word (Range.linear minBound maxBound) - <*> genDouble - <*> genDouble - <*> (V.fromList <$> Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 100) Gen.unicode)) - <*> Gen.list (Range.linear 0 100) genFriend - <*> Gen.list (Range.linear 0 100) (Gen.list (Range.linear 0 100) genDouble) - <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.text (Range.linear 0 100) Gen.unicode - <*> genEmployer - <*> Gen.map (Range.linear 0 100) - ((,) <$> fmap KeyType (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.int (Range.linear 0 10000)) - <*> utcTimeGenerator +genPerson = + Person + <$> Gen.text (Range.linear 0 100) Gen.unicode + <*> Gen.int (Range.linear minBound maxBound) + <*> Gen.text (Range.linear 0 100) Gen.unicode + <*> Gen.bool + <*> Gen.text (Range.linear 0 100) Gen.unicode + <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.word (Range.linear minBound maxBound) + <*> genDouble + <*> genDouble + <*> (V.fromList <$> Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 100) Gen.unicode)) + <*> Gen.list (Range.linear 0 100) genFriend + <*> Gen.list (Range.linear 0 100) (Gen.list (Range.linear 0 100) genDouble) + <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.text (Range.linear 0 100) Gen.unicode + <*> genEmployer + <*> Gen.map + (Range.linear 0 100) + ( (,) + <$> fmap KeyType (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.int (Range.linear 0 10000) + ) + <*> utcTimeGenerator genPersonOptional :: Gen PersonOptional -genPersonOptional = PersonOptional - <$> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.maybe (Gen.int (Range.linear minBound maxBound)) - <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.maybe Gen.bool - <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.maybe (Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode)) - <*> Gen.maybe (Gen.word (Range.linear 0 100)) - <*> Gen.maybe genDouble - <*> Gen.maybe genDouble - <*> Gen.maybe (V.fromList <$> Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 100) Gen.unicode)) - <*> Gen.maybe (Gen.list (Range.linear 0 100) genFriend) - <*> Gen.maybe (Gen.list (Range.linear 0 100) (Gen.list (Range.linear 0 100) genDouble)) - <*> Gen.maybe (Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode)) - <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.maybe genEmployer - <*> Gen.maybe (Gen.map (Range.linear 0 100) - ((,) <$> fmap KeyType (Gen.text (Range.linear 0 100) Gen.unicode) - <*> Gen.int (Range.linear 0 10000))) - <*> Gen.maybe utcTimeGenerator +genPersonOptional = + PersonOptional + <$> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.maybe (Gen.int (Range.linear minBound maxBound)) + <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.maybe Gen.bool + <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.maybe (Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode)) + <*> Gen.maybe (Gen.word (Range.linear 0 100)) + <*> Gen.maybe genDouble + <*> Gen.maybe genDouble + <*> Gen.maybe (V.fromList <$> Gen.list (Range.linear 0 100) (Gen.text (Range.linear 0 100) Gen.unicode)) + <*> Gen.maybe (Gen.list (Range.linear 0 100) genFriend) + <*> Gen.maybe (Gen.list (Range.linear 0 100) (Gen.list (Range.linear 0 100) genDouble)) + <*> Gen.maybe (Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode)) + <*> Gen.maybe (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.maybe genEmployer + <*> Gen.maybe + ( Gen.map + (Range.linear 0 100) + ( (,) + <$> fmap KeyType (Gen.text (Range.linear 0 100) Gen.unicode) + <*> Gen.int (Range.linear 0 10000) + ) + ) + <*> Gen.maybe utcTimeGenerator genFriend :: Gen Friend -genFriend = Friend - <$> Gen.int (Range.linear 0 100) - <*> Gen.text (Range.linear 0 100) Gen.unicode +genFriend = + Friend + <$> Gen.int (Range.linear 0 100) + <*> Gen.text (Range.linear 0 100) Gen.unicode genEmployer :: Gen Employer -genEmployer = Employer - <$> Gen.string (Range.linear 0 1000) Gen.unicode - <*> genScientific +genEmployer = + Employer + <$> Gen.string (Range.linear 0 1000) Gen.unicode + <*> genScientific decodeEmployer :: Decoder Employer -decodeEmployer = object $ - Employer - <$> atKey "inefficient" string - <*> atKey "exp" scientific +decodeEmployer = + object $ + Employer + <$> atKey "inefficient" string + <*> atKey "exp" scientific utcTimeGenerator :: Gen Time.UTCTime utcTimeGenerator = @@ -357,15 +456,16 @@ timeOfDayGenerator :: Gen Time.DiffTime timeOfDayGenerator = - fmap (\x -> fromIntegral (floor $ (x :: Time.DiffTime) * 1000000 :: Int) / 1000000) - $ Gen.realFrac_ (Range.constant 0 86400) + fmap (\x -> fromIntegral (floor $ (x :: Time.DiffTime) * 1000000 :: Int) / 1000000) $ + Gen.realFrac_ (Range.constant 0 86400) genDouble :: Gen Double genDouble = - Gen.double $ Range.linearFracFrom - 0 - (-1000000000000000000000000) - 1000000000000000000000000 + Gen.double $ + Range.linearFracFrom + 0 + (-1000000000000000000000000) + 1000000000000000000000000 genScientific :: Gen Scientific genScientific = fmap Sci.fromFloatDigits genDouble @@ -377,7 +477,7 @@ toJSON (Peano 0) = A.object [] toJSON (Peano suc) = A.object [("suc", A.toJSON (Peano $ suc - 1))] -genPeano :: MonadGen m => m Peano +genPeano :: (MonadGen m) => m Peano genPeano = Peano <$> Gen.word16 Range.linearBounded decodePeano :: Decoder Peano @@ -388,14 +488,16 @@ Just (Peano subTree) -> Peano $ 1 + subTree Nothing -> Peano 0 -data FriendWithMap = - FriendWithMap - { id :: Int - , rest :: Map Text Text - } deriving (Eq, Show) +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) +decodeFriendSlurp = + object $ + FriendWithMap + <$> atKey "id" int + <*> liftObjectDecoder (objectAsMapExcluding ["id"] pure text)