-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE TypeFamilies #-}

{- | A resumable walk over the vendored json-stream lexer's tokens, and its body-bounded driver.
Each primitive keeps the acceptance of the json-stream combinator it stands in for: which strings
and keys are decoded, which malformed input is skipped, and where a read fails. The lexer's own
leniency passes through unchanged. It reads @:@ and @,@ as whitespace, reads a lone @-@, @.@ or
@-.@ within a piece as 0 but fails one at a piece's end, and wraps an exponent past 'Int', so
@1e18446744073709551617@ reads as 10. A walk returns a pure 'Step', or a step in 'ST' when it writes
as it reads.
-}
module Ecluse.Core.Registry.Json.Walk (
    -- * Driving a walk
    Steps (..),
    Step,
    Walk (..),
    readJsonWalk,
    readJsonWalkST,
    nestingLimit,
    Walked (..),
    FieldStep,
    pureStep,
    emit,

    -- * Tokens
    withElement,
    skipFrom,
    skipRest,
    tooDeep,
    isString,
    readString,
    eachMember,
    memberName,
    eachItem,
) where

import Control.Monad.ST (ST)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.JsonStream.CLexer (tokenParser, unescapeText)
import Data.JsonStream.TokenParser (Element (..), TokenResult (..))
import GHC.Exts (oneShot)

import Ecluse.Core.Registry.Json.Intern (InternTable, Name (Plain), decodedName)
import Ecluse.Core.Registry.JsonStream (Step, Steps (..), StreamResult, readSteps)
import Ecluse.Core.Security (BodyLimit, LimitError)

-- | The parse error that marks a retained value past its structural budget.
nestingLimit :: Text
nestingLimit :: Text
nestingLimit = Text
"retained JSON nesting limit"

-- | What a walk's continuations return: a read that needs input, has failed or been refused, or is done.
class Walk r where
    -- | What a finished walk returns.
    type Result r

    -- | Suspend until the next chunk of input.
    needData :: (ByteString -> r) -> r

    -- | Stop on a parse error.
    failWith :: Text -> r

    -- | Stop on a refused field.
    refuse :: LimitError -> r

    -- | Finish with the walk's result.
    finish :: Result r -> r

instance Walk (Steps Identity s) where
    type Result (Steps Identity s) = s
    needData :: (ByteString -> Steps Identity s) -> Steps Identity s
needData = (ByteString -> Identity (Steps Identity s)) -> Steps Identity s
forall (m :: * -> *) s. (ByteString -> m (Steps m s)) -> Steps m s
NeedData ((ByteString -> Identity (Steps Identity s)) -> Steps Identity s)
-> ((ByteString -> Steps Identity s)
    -> ByteString -> Identity (Steps Identity s))
-> (ByteString -> Steps Identity s)
-> Steps Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Steps Identity s)
-> ByteString -> Identity (Steps Identity s)
forall a b. Coercible a b => a -> b
coerce
    failWith :: Text -> Steps Identity s
failWith = Text -> Steps Identity s
forall (m :: * -> *) s. Text -> Steps m s
Failed
    refuse :: LimitError -> Steps Identity s
refuse = LimitError -> Steps Identity s
forall (m :: * -> *) s. LimitError -> Steps m s
Refused
    finish :: Result (Steps Identity s) -> Steps Identity s
finish = s -> Steps Identity s
Result (Steps Identity s) -> Steps Identity s
forall (m :: * -> *) s. s -> Steps m s
Finished

instance Walk (ST st (Steps (ST st) s)) where
    type Result (ST st (Steps (ST st) s)) = s
    needData :: (ByteString -> ST st (Steps (ST st) s)) -> ST st (Steps (ST st) s)
needData = Steps (ST st) s -> ST st (Steps (ST st) s)
forall a. a -> ST st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Steps (ST st) s -> ST st (Steps (ST st) s))
-> ((ByteString -> ST st (Steps (ST st) s)) -> Steps (ST st) s)
-> (ByteString -> ST st (Steps (ST st) s))
-> ST st (Steps (ST st) s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ST st (Steps (ST st) s)) -> Steps (ST st) s
forall (m :: * -> *) s. (ByteString -> m (Steps m s)) -> Steps m s
NeedData
    failWith :: Text -> ST st (Steps (ST st) s)
failWith = Steps (ST st) s -> ST st (Steps (ST st) s)
forall a. a -> ST st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Steps (ST st) s -> ST st (Steps (ST st) s))
-> (Text -> Steps (ST st) s) -> Text -> ST st (Steps (ST st) s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Steps (ST st) s
forall (m :: * -> *) s. Text -> Steps m s
Failed
    refuse :: LimitError -> ST st (Steps (ST st) s)
refuse = Steps (ST st) s -> ST st (Steps (ST st) s)
forall a. a -> ST st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Steps (ST st) s -> ST st (Steps (ST st) s))
-> (LimitError -> Steps (ST st) s)
-> LimitError
-> ST st (Steps (ST st) s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LimitError -> Steps (ST st) s
forall (m :: * -> *) s. LimitError -> Steps m s
Refused
    finish :: Result (ST st (Steps (ST st) s)) -> ST st (Steps (ST st) s)
finish = Steps (ST st) s -> ST st (Steps (ST st) s)
forall a. a -> ST st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Steps (ST st) s -> ST st (Steps (ST st) s))
-> (s -> Steps (ST st) s) -> s -> ST st (Steps (ST st) s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Steps (ST st) s
forall (m :: * -> *) s. s -> Steps m s
Finished

-- | Walk a body as 'Ecluse.Core.Registry.JsonStream.readJsonStream' reads one, from the lexer's first token.
readJsonWalk :: (Monad m) => BodyLimit -> (TokenResult -> Step s) -> m ByteString -> m (Either LimitError (StreamResult s))
readJsonWalk :: forall (m :: * -> *) s.
Monad m =>
BodyLimit
-> (TokenResult -> Step s)
-> m ByteString
-> m (Either LimitError (StreamResult s))
readJsonWalk BodyLimit
bound TokenResult -> Step s
walk = (forall a. Identity a -> m a)
-> BodyLimit
-> Step s
-> m ByteString
-> m (Either LimitError (StreamResult s))
forall (n :: * -> *) (m :: * -> *) s.
Monad n =>
(forall a. m a -> n a)
-> BodyLimit
-> Steps m s
-> n ByteString
-> n (Either LimitError (StreamResult s))
readSteps (a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (Identity a -> a) -> Identity a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity) BodyLimit
bound (TokenResult -> Step s
walk (ByteString -> TokenResult
tokenParser ByteString
BS.empty))

-- | 'readJsonWalk' for a walk that writes in 'ST' as it reads, run in the reader's effect.
readJsonWalkST :: (Monad m) => (forall a. ST st a -> m a) -> BodyLimit -> (TokenResult -> ST st (Steps (ST st) s)) -> m ByteString -> m (Either LimitError (StreamResult s))
readJsonWalkST :: forall (m :: * -> *) st s.
Monad m =>
(forall a. ST st a -> m a)
-> BodyLimit
-> (TokenResult -> ST st (Steps (ST st) s))
-> m ByteString
-> m (Either LimitError (StreamResult s))
readJsonWalkST forall a. ST st a -> m a
run BodyLimit
bound TokenResult -> ST st (Steps (ST st) s)
walk m ByteString
readChunk = ST st (Steps (ST st) s) -> m (Steps (ST st) s)
forall a. ST st a -> m a
run (TokenResult -> ST st (Steps (ST st) s)
walk (ByteString -> TokenResult
tokenParser ByteString
BS.empty)) m (Steps (ST st) s)
-> (Steps (ST st) s -> m (Either LimitError (StreamResult s)))
-> m (Either LimitError (StreamResult s))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Steps (ST st) s
start -> (forall a. ST st a -> m a)
-> BodyLimit
-> Steps (ST st) s
-> m ByteString
-> m (Either LimitError (StreamResult s))
forall (n :: * -> *) (m :: * -> *) s.
Monad n =>
(forall a. m a -> n a)
-> BodyLimit
-> Steps m s
-> n ByteString
-> n (Either LimitError (StreamResult s))
readSteps ST st a -> m a
forall a. ST st a -> m a
run BodyLimit
bound Steps (ST st) s
start m ByteString
readChunk

-- | A walk's state between tokens: the read's table and the consumer's accumulator.
data Walked s = Walked !InternTable s

-- | How a consumer takes each field: it continues with its next state, or refuses the field.
type FieldStep s field r = s -> field -> (Either LimitError s -> r) -> r

-- | A consumer that takes each field without an effect of its own.
pureStep :: (s -> field -> Either LimitError s) -> FieldStep s field r
pureStep :: forall s field r.
(s -> field -> Either LimitError s) -> FieldStep s field r
pureStep s -> field -> Either LimitError s
step s
acc field
field Either LimitError s -> r
next = Either LimitError s -> r
next (s -> field -> Either LimitError s
step s
acc field
field)
{-# INLINE pureStep #-}

-- | Pass a field to the consumer's step. A refused field ends the walk.
emit :: (Walk r) => FieldStep s field r -> s -> field -> (s -> r) -> r
emit :: forall r s field.
Walk r =>
FieldStep s field r -> s -> field -> (s -> r) -> r
emit FieldStep s field r
step s
acc field
field s -> r
next = FieldStep s field r
step s
acc field
field ((LimitError -> r) -> (s -> r) -> Either LimitError s -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LimitError -> r
forall r. Walk r => LimitError -> r
refuse s -> r
next)
{-# INLINE emit #-}

-- | The next element, suspending for input at a chunk boundary. The continuation runs once.
withElement :: (Walk r) => TokenResult -> (Element -> TokenResult -> r) -> r
withElement :: forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens Element -> TokenResult -> r
next = case TokenResult
tokens of
    PartialResult Element
element TokenResult
rest -> Element -> TokenResult -> r
once Element
element TokenResult
rest
    TokenResult
_ -> TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
awaitElement TokenResult
tokens Element -> TokenResult -> r
once
  where
    once :: Element -> TokenResult -> r
once = (Element -> TokenResult -> r) -> Element -> TokenResult -> r
forall a b. (a -> b) -> a -> b
oneShot ((TokenResult -> r) -> TokenResult -> r
forall a b. (a -> b) -> a -> b
oneShot ((TokenResult -> r) -> TokenResult -> r)
-> (Element -> TokenResult -> r) -> Element -> TokenResult -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> TokenResult -> r
next)
{-# INLINE withElement #-}

awaitElement :: (Walk r) => TokenResult -> (Element -> TokenResult -> r) -> r
awaitElement :: forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
awaitElement TokenResult
tokens Element -> TokenResult -> r
next = case TokenResult
tokens of
    PartialResult Element
element TokenResult
rest -> Element -> TokenResult -> r
next Element
element TokenResult
rest
    TokMoreData ByteString -> TokenResult
more -> (ByteString -> r) -> r
forall r. Walk r => (ByteString -> r) -> r
needData (\ByteString
chunk -> TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
awaitElement (ByteString -> TokenResult
more ByteString
chunk) Element -> TokenResult -> r
next)
    TokenResult
TokFailed -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"the JSON lexer failed"
{-# INLINEABLE awaitElement #-}

-- | Skip the value starting at the element without decoding it, as json-stream's @ignoreVal@ does.
skipFrom :: (Walk r) => Element -> TokenResult -> (TokenResult -> r) -> r
skipFrom :: forall r.
Walk r =>
Element -> TokenResult -> (TokenResult -> r) -> r
skipFrom Element
element TokenResult
rest TokenResult -> r
next = case Element
element of
    JValue Value
_ -> TokenResult -> r
next TokenResult
rest
    JInteger CLong
_ -> TokenResult -> r
next TokenResult
rest
    StringRaw{} -> TokenResult -> r
next TokenResult
rest
    StringContent ByteString
_ -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => TokenResult -> (TokenResult -> r) -> r
skipStringThen TokenResult
rest TokenResult -> r
next
    Element
ArrayBegin -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest Int
1 TokenResult
rest TokenResult -> r
next
    Element
ObjectBegin -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest Int
1 TokenResult
rest TokenResult -> r
next
    ArrayEnd ByteString
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected end of array"
    ObjectEnd ByteString
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected end of object"
    StringEnd ByteString
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected end of string"
{-# INLINEABLE skipFrom #-}

-- | Skip to the end of the container the given number of levels up. Any closing token closes a level.
skipRest :: (Walk r) => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest :: forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest !Int
level TokenResult
tokens TokenResult -> r
next = case TokenResult
tokens of
    PartialResult Element
element TokenResult
rest -> case Element
element of
        ArrayEnd ByteString
_ -> TokenResult -> r
closed TokenResult
rest
        ObjectEnd ByteString
_ -> TokenResult -> r
closed TokenResult
rest
        Element
ArrayBegin -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TokenResult
rest TokenResult -> r
next
        Element
ObjectBegin -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TokenResult
rest TokenResult -> r
next
        StringContent ByteString
_ -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => TokenResult -> (TokenResult -> r) -> r
skipStringThen TokenResult
rest (\TokenResult
after -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest Int
level TokenResult
after TokenResult -> r
next)
        StringEnd ByteString
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected end of string"
        Element
_ -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest Int
level TokenResult
rest TokenResult -> r
next
    TokMoreData ByteString -> TokenResult
more -> (ByteString -> r) -> r
forall r. Walk r => (ByteString -> r) -> r
needData (\ByteString
chunk -> Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest Int
level (ByteString -> TokenResult
more ByteString
chunk) TokenResult -> r
next)
    TokenResult
TokFailed -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"the JSON lexer failed"
  where
    closed :: TokenResult -> r
closed TokenResult
rest
        | Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = TokenResult -> r
next TokenResult
rest
        | Bool
otherwise = Int -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => Int -> TokenResult -> (TokenResult -> r) -> r
skipRest (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TokenResult
rest TokenResult -> r
next
{-# INLINEABLE skipRest #-}

skipStringThen :: (Walk r) => TokenResult -> (TokenResult -> r) -> r
skipStringThen :: forall r. Walk r => TokenResult -> (TokenResult -> r) -> r
skipStringThen TokenResult
tokens TokenResult -> r
next = TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens ((Element -> TokenResult -> r) -> r)
-> (Element -> TokenResult -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Element
element TokenResult
rest -> case Element
element of
    StringContent ByteString
_ -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => TokenResult -> (TokenResult -> r) -> r
skipStringThen TokenResult
rest TokenResult -> r
next
    StringEnd ByteString
_ -> TokenResult -> r
next TokenResult
rest
    Element
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected token in a string"
{-# INLINEABLE skipStringThen #-}

-- | Skip the value, then fail: a retained value with no structural budget left.
tooDeep :: (Walk r) => Element -> TokenResult -> r
tooDeep :: forall r. Walk r => Element -> TokenResult -> r
tooDeep Element
element TokenResult
rest = Element -> TokenResult -> (TokenResult -> r) -> r
forall r.
Walk r =>
Element -> TokenResult -> (TokenResult -> r) -> r
skipFrom Element
element TokenResult
rest (r -> TokenResult -> r
forall a b. a -> b -> a
const (Text -> r
forall r. Walk r => Text -> r
failWith Text
nestingLimit))
{-# INLINEABLE tooDeep #-}

-- | Whether the element starts a string.
isString :: Element -> Bool
isString :: Element -> Bool
isString = \case
    StringRaw{} -> Bool
True
    StringContent ByteString
_ -> Bool
True
    JValue (Aeson.String Text
_) -> Bool
True
    Element
_ -> Bool
False

-- | Decode the string starting at the element, failing where json-stream's @string@ fails.
readString :: (Walk r) => Element -> TokenResult -> (Name -> TokenResult -> r) -> r
readString :: forall r.
Walk r =>
Element -> TokenResult -> (Name -> TokenResult -> r) -> r
readString Element
element TokenResult
rest Name -> TokenResult -> r
next = case Element
element of
    StringRaw ByteString
bytes Bool
True ByteString
_ -> Name -> TokenResult -> r
next (ByteString -> Name
Plain ByteString
bytes) TokenResult
rest
    StringRaw ByteString
bytes Bool
False ByteString
_ -> case ByteString -> Either UnicodeException Text
unescapeText ByteString
bytes of
        Right Text
text -> Name -> TokenResult -> r
next (Text -> Name
decodedName Text
text) TokenResult
rest
        Left UnicodeException
err -> Text -> r
forall r. Walk r => Text -> r
failWith (UnicodeException -> Text
forall b a. (Show a, IsString b) => a -> b
show UnicodeException
err)
    StringContent ByteString
part -> [ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
forall r.
Walk r =>
[ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
longString [ByteString
part] TokenResult
rest Name -> TokenResult -> r
next
    JValue (Aeson.String Text
text) -> Name -> TokenResult -> r
next (Text -> Name
decodedName Text
text) TokenResult
rest
    Element
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"expected a string"
{-# INLINEABLE readString #-}

longString :: (Walk r) => [ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
longString :: forall r.
Walk r =>
[ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
longString [ByteString]
parts TokenResult
tokens Name -> TokenResult -> r
next = TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens ((Element -> TokenResult -> r) -> r)
-> (Element -> TokenResult -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Element
element TokenResult
rest -> case Element
element of
    StringContent ByteString
part -> [ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
forall r.
Walk r =>
[ByteString] -> TokenResult -> (Name -> TokenResult -> r) -> r
longString (ByteString
part ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
parts) TokenResult
rest Name -> TokenResult -> r
next
    StringEnd ByteString
_ -> case ByteString -> Either UnicodeException Text
unescapeText ([ByteString] -> ByteString
BS.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
parts)) of
        Right Text
text -> Name -> TokenResult -> r
next (Text -> Name
decodedName Text
text) TokenResult
rest
        Left UnicodeException
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"Error decoding UTF8"
    Element
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected token in a string"
{-# INLINEABLE longString #-}

{- | Visit each member of an object whose opening brace was read, as json-stream's @objectKeyValues@
does: every key is decoded, and a key longer than 64 KiB across pieces drops its member unread.
-}
eachMember :: (Walk r) => (st -> Name -> TokenResult -> (st -> TokenResult -> r) -> r) -> (st -> TokenResult -> r) -> st -> TokenResult -> r
eachMember :: forall r st.
Walk r =>
(st -> Name -> TokenResult -> (st -> TokenResult -> r) -> r)
-> (st -> TokenResult -> r) -> st -> TokenResult -> r
eachMember st -> Name -> TokenResult -> (st -> TokenResult -> r) -> r
visit st -> TokenResult -> r
done = st -> TokenResult -> r
loop
  where
    loop :: st -> TokenResult -> r
loop st
acc TokenResult
tokens = TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens ((Element -> TokenResult -> r) -> r)
-> (Element -> TokenResult -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Element
element TokenResult
rest -> case Element
element of
        ObjectEnd ByteString
_ -> st -> TokenResult -> r
done st
acc TokenResult
rest
        Element
_ -> Element
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
forall r.
Walk r =>
Element
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
memberName Element
element TokenResult
rest (\Name
key TokenResult
after -> st -> Name -> TokenResult -> (st -> TokenResult -> r) -> r
visit st
acc Name
key TokenResult
after st -> TokenResult -> r
loop) (st -> TokenResult -> r
loop st
acc)
{-# INLINE eachMember #-}

-- | Decode the object key at the element, or skip its member when json-stream drops it unread.
memberName :: (Walk r) => Element -> TokenResult -> (Name -> TokenResult -> r) -> (TokenResult -> r) -> r
memberName :: forall r.
Walk r =>
Element
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
memberName Element
element TokenResult
rest Name -> TokenResult -> r
named TokenResult -> r
dropped = case Element
element of
    JValue (Aeson.String Text
key) -> Name -> TokenResult -> r
named (Text -> Name
decodedName Text
key) TokenResult
rest
    StringRaw ByteString
bytes Bool
True ByteString
_ -> Name -> TokenResult -> r
named (ByteString -> Name
Plain ByteString
bytes) TokenResult
rest
    StringRaw ByteString
bytes Bool
False ByteString
_ -> case ByteString -> Either UnicodeException Text
unescapeText ByteString
bytes of
        Right Text
key -> Name -> TokenResult -> r
named (Text -> Name
decodedName Text
key) TokenResult
rest
        Left UnicodeException
err -> Text -> r
forall r. Walk r => Text -> r
failWith (UnicodeException -> Text
forall b a. (Show a, IsString b) => a -> b
show UnicodeException
err)
    StringContent ByteString
part -> [ByteString]
-> Int
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
forall r.
Walk r =>
[ByteString]
-> Int
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
longKey [ByteString
part] (ByteString -> Int
BS.length ByteString
part) TokenResult
rest Name -> TokenResult -> r
named TokenResult -> r
dropped
    Element
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected token where an object key belongs"
{-# INLINEABLE memberName #-}

-- json-stream's getLongKey: the limit applies from the third piece, and a dropped key skips its value.
longKey :: (Walk r) => [ByteString] -> Int -> TokenResult -> (Name -> TokenResult -> r) -> (TokenResult -> r) -> r
longKey :: forall r.
Walk r =>
[ByteString]
-> Int
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
longKey [ByteString]
parts !Int
size TokenResult
tokens Name -> TokenResult -> r
next TokenResult -> r
dropped = TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens ((Element -> TokenResult -> r) -> r)
-> (Element -> TokenResult -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Element
element TokenResult
rest -> case Element
element of
    StringEnd ByteString
_ -> case ByteString -> Either UnicodeException Text
unescapeText ([ByteString] -> ByteString
BS.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
parts)) of
        Right Text
key -> Name -> TokenResult -> r
next (Text -> Name
decodedName Text
key) TokenResult
rest
        Left UnicodeException
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"Error decoding UTF8"
    StringContent ByteString
part
        | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
65536 -> TokenResult -> (TokenResult -> r) -> r
forall r. Walk r => TokenResult -> (TokenResult -> r) -> r
skipStringThen TokenResult
rest (\TokenResult
after -> TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
after (\Element
value TokenResult
afterValue -> Element -> TokenResult -> (TokenResult -> r) -> r
forall r.
Walk r =>
Element -> TokenResult -> (TokenResult -> r) -> r
skipFrom Element
value TokenResult
afterValue TokenResult -> r
dropped))
        | Bool
otherwise -> [ByteString]
-> Int
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
forall r.
Walk r =>
[ByteString]
-> Int
-> TokenResult
-> (Name -> TokenResult -> r)
-> (TokenResult -> r)
-> r
longKey (ByteString
part ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
parts) (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
part) TokenResult
rest Name -> TokenResult -> r
next TokenResult -> r
dropped
    Element
_ -> Text -> r
forall r. Walk r => Text -> r
failWith Text
"unexpected token in an object key"
{-# INLINEABLE longKey #-}

-- | Visit each item of an array whose opening bracket was read, with its position.
eachItem :: (Walk r) => (st -> Int -> Element -> TokenResult -> (st -> TokenResult -> r) -> r) -> (st -> TokenResult -> r) -> st -> TokenResult -> r
eachItem :: forall r st.
Walk r =>
(st
 -> Int -> Element -> TokenResult -> (st -> TokenResult -> r) -> r)
-> (st -> TokenResult -> r) -> st -> TokenResult -> r
eachItem st
-> Int -> Element -> TokenResult -> (st -> TokenResult -> r) -> r
visit st -> TokenResult -> r
done = Int -> st -> TokenResult -> r
loop Int
0
  where
    loop :: Int -> st -> TokenResult -> r
loop !Int
position st
acc TokenResult
tokens = TokenResult -> (Element -> TokenResult -> r) -> r
forall r.
Walk r =>
TokenResult -> (Element -> TokenResult -> r) -> r
withElement TokenResult
tokens ((Element -> TokenResult -> r) -> r)
-> (Element -> TokenResult -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Element
element TokenResult
rest -> case Element
element of
        ArrayEnd ByteString
_ -> st -> TokenResult -> r
done st
acc TokenResult
rest
        Element
_ -> st
-> Int -> Element -> TokenResult -> (st -> TokenResult -> r) -> r
visit st
acc Int
position Element
element TokenResult
rest (Int -> st -> TokenResult -> r
loop (Int
position Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
{-# INLINE eachItem #-}