hermes-json 0.8.2.0 → 0.9.0.0
raw patch · 17 files changed
+1011/−807 lines, 17 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.Hermes.Decoder.Value: parseScientific :: Text -> Decoder Scientific
+ Data.Hermes.SIMDJSON.Bindings: getScientificImpl :: Value -> Ptr Int64 -> IO CInt
Files
- CHANGELOG.md +31/−0
- README.md +51/−19
- cbits/lib.cpp +58/−0
- hermes-json.cabal +1/−2
- simdjson/singleheader/simdjson.cpp too large to diff
- simdjson/singleheader/simdjson.h too large to diff
- src/Data/Hermes.hs +28/−18
- src/Data/Hermes/Decoder.hs +3/−3
- src/Data/Hermes/Decoder/Internal.hs +153/−104
- src/Data/Hermes/Decoder/Internal/Scientific.hs +0/−117
- src/Data/Hermes/Decoder/Path.hs +5/−5
- src/Data/Hermes/Decoder/Time.hs +5/−6
- src/Data/Hermes/Decoder/Value.hs +144/−144
- src/Data/Hermes/SIMDJSON/Bindings.hs +117/−76
- src/Data/Hermes/SIMDJSON/Types.hs +35/−35
- src/Data/Hermes/SIMDJSON/Wrapper.hs +9/−9
- tests/test.hs +371/−269
CHANGELOG.md view
@@ -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
README.md view
@@ -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 -+#### Arrays +++#### Persons++++#### Partial Twitter++++#### Persons (Aeson Value)++++#### Twitter (Aeson Value)+++ <!-- AUTO-GENERATED-CONTENT:START (BENCHES) -->-| 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 | <!-- AUTO-GENERATED-CONTENT:END (BENCHES) --> ## 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
cbits/lib.cpp view
@@ -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<intptr_t>(intStart));+ out[3] = intEnd - intStart;+ out[4] = int64_t(reinterpret_cast<intptr_t>(fracStart));+ out[5] = fracEnd - fracStart;+ return -1;+ }+ error_code is_null(ondemand::value &val, bool &out) { return val.is_null().get(out); }
hermes-json.cabal view
@@ -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,
simdjson/singleheader/simdjson.cpp view
file too large to diff
simdjson/singleheader/simdjson.h view
file too large to diff
src/Data/Hermes.hs view
@@ -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 -- <https://hackage.haskell.org/package/text-iso8601>.@@ -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
src/Data/Hermes/Decoder.hs view
@@ -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
src/Data/Hermes/Decoder/Internal.hs view
@@ -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
− src/Data/Hermes/Decoder/Internal/Scientific.hs
@@ -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"
src/Data/Hermes/Decoder/Path.hs view
@@ -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 #-}
src/Data/Hermes/Decoder/Time.hs view
@@ -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.
src/Data/Hermes/Decoder/Value.hs view
@@ -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 #-}
src/Data/Hermes/SIMDJSON/Bindings.hs view
@@ -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
src/Data/Hermes/SIMDJSON/Types.hs view
@@ -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"
src/Data/Hermes/SIMDJSON/Wrapper.hs view
@@ -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
tests/test.hs view
@@ -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)