{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

-- | Attempts to parse to either a result type or a direct report, by using a custom parser.
-- This parser uses Haskell primops to try to avoid allocations.
-- At the end of the day, it's not as fast as Attoparsec, but it's pretty dang fast.
--
-- We could not use Attoparsec directly due to the need for differnet error handling.
-- Other libraries with correct error handling behavior do exist, but in order to keep the dependency footprint low,
-- we rolled our own.
module Jordan.FromJSON.UnboxedReporting (parseOrReportWith, parseOrReport) where

import Control.Applicative (Alternative (empty, (<|>)))
import Control.Applicative.Combinators (sepBy)
import Control.Monad (when)
import Data.Bifunctor
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe as BS
import Data.Char (chr, isControl, ord)
import Data.Functor (void, ($>))
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Monoid (Alt (..))
import Data.Scientific (Scientific)
import qualified Data.Scientific as Scientific
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Word (Word8)
import Jordan.FromJSON.Class
import Jordan.FromJSON.Internal.Attoparsec (bsToInteger)
import Jordan.FromJSON.Internal.Permutation
import Jordan.FromJSON.Internal.UnboxedParser as UP hiding (AccumE (..), AccumEL, AccumER)
import Jordan.FromJSON.Internal.UnboxedReporting
import Jordan.Types.Internal.AccumE (AccumE (AccumE))
import Jordan.Types.JSONError
  ( JSONArrayError (..),
    JSONError
      ( ErrorBadArray,
        ErrorBadObject,
        ErrorBadTextConstant,
        ErrorBadType,
        ErrorInvalidJSON,
        ErrorMesage,
        ErrorNoValue
      ),
    JSONObjectError (..),
  )
import Jordan.Types.JSONType (JSONType (..))
import Numeric (showHex)

newtype ReportingParser a = ReportingParser {ReportingParser a -> Parser JSONError a
runReportingParser :: UP.Parser JSONError a}
  deriving (a -> ReportingParser b -> ReportingParser a
(a -> b) -> ReportingParser a -> ReportingParser b
(forall a b. (a -> b) -> ReportingParser a -> ReportingParser b)
-> (forall a b. a -> ReportingParser b -> ReportingParser a)
-> Functor ReportingParser
forall a b. a -> ReportingParser b -> ReportingParser a
forall a b. (a -> b) -> ReportingParser a -> ReportingParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ReportingParser b -> ReportingParser a
$c<$ :: forall a b. a -> ReportingParser b -> ReportingParser a
fmap :: (a -> b) -> ReportingParser a -> ReportingParser b
$cfmap :: forall a b. (a -> b) -> ReportingParser a -> ReportingParser b
Functor) via (UP.Parser JSONError)
  deriving (b -> ReportingParser a -> ReportingParser a
NonEmpty (ReportingParser a) -> ReportingParser a
ReportingParser a -> ReportingParser a -> ReportingParser a
(ReportingParser a -> ReportingParser a -> ReportingParser a)
-> (NonEmpty (ReportingParser a) -> ReportingParser a)
-> (forall b.
    Integral b =>
    b -> ReportingParser a -> ReportingParser a)
-> Semigroup (ReportingParser a)
forall b. Integral b => b -> ReportingParser a -> ReportingParser a
forall a. NonEmpty (ReportingParser a) -> ReportingParser a
forall a.
ReportingParser a -> ReportingParser a -> ReportingParser a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b.
Integral b =>
b -> ReportingParser a -> ReportingParser a
stimes :: b -> ReportingParser a -> ReportingParser a
$cstimes :: forall a b.
Integral b =>
b -> ReportingParser a -> ReportingParser a
sconcat :: NonEmpty (ReportingParser a) -> ReportingParser a
$csconcat :: forall a. NonEmpty (ReportingParser a) -> ReportingParser a
<> :: ReportingParser a -> ReportingParser a -> ReportingParser a
$c<> :: forall a.
ReportingParser a -> ReportingParser a -> ReportingParser a
Semigroup) via (Alt (UP.Parser JSONError) a)

newtype ReportingObjectParser a = ReportingObjectParser
  {ReportingObjectParser a -> Permutation (Parser JSONObjectError) a
runReportingObjectParser :: Permutation (UP.Parser JSONObjectError) a}
  deriving (a -> ReportingObjectParser b -> ReportingObjectParser a
(a -> b) -> ReportingObjectParser a -> ReportingObjectParser b
(forall a b.
 (a -> b) -> ReportingObjectParser a -> ReportingObjectParser b)
-> (forall a b.
    a -> ReportingObjectParser b -> ReportingObjectParser a)
-> Functor ReportingObjectParser
forall a b. a -> ReportingObjectParser b -> ReportingObjectParser a
forall a b.
(a -> b) -> ReportingObjectParser a -> ReportingObjectParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ReportingObjectParser b -> ReportingObjectParser a
$c<$ :: forall a b. a -> ReportingObjectParser b -> ReportingObjectParser a
fmap :: (a -> b) -> ReportingObjectParser a -> ReportingObjectParser b
$cfmap :: forall a b.
(a -> b) -> ReportingObjectParser a -> ReportingObjectParser b
Functor, Functor ReportingObjectParser
a -> ReportingObjectParser a
Functor ReportingObjectParser
-> (forall a. a -> ReportingObjectParser a)
-> (forall a b.
    ReportingObjectParser (a -> b)
    -> ReportingObjectParser a -> ReportingObjectParser b)
-> (forall a b c.
    (a -> b -> c)
    -> ReportingObjectParser a
    -> ReportingObjectParser b
    -> ReportingObjectParser c)
-> (forall a b.
    ReportingObjectParser a
    -> ReportingObjectParser b -> ReportingObjectParser b)
-> (forall a b.
    ReportingObjectParser a
    -> ReportingObjectParser b -> ReportingObjectParser a)
-> Applicative ReportingObjectParser
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser b
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser a
ReportingObjectParser (a -> b)
-> ReportingObjectParser a -> ReportingObjectParser b
(a -> b -> c)
-> ReportingObjectParser a
-> ReportingObjectParser b
-> ReportingObjectParser c
forall a. a -> ReportingObjectParser a
forall a b.
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser a
forall a b.
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser b
forall a b.
ReportingObjectParser (a -> b)
-> ReportingObjectParser a -> ReportingObjectParser b
forall a b c.
(a -> b -> c)
-> ReportingObjectParser a
-> ReportingObjectParser b
-> ReportingObjectParser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser a
$c<* :: forall a b.
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser a
*> :: ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser b
$c*> :: forall a b.
ReportingObjectParser a
-> ReportingObjectParser b -> ReportingObjectParser b
liftA2 :: (a -> b -> c)
-> ReportingObjectParser a
-> ReportingObjectParser b
-> ReportingObjectParser c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ReportingObjectParser a
-> ReportingObjectParser b
-> ReportingObjectParser c
<*> :: ReportingObjectParser (a -> b)
-> ReportingObjectParser a -> ReportingObjectParser b
$c<*> :: forall a b.
ReportingObjectParser (a -> b)
-> ReportingObjectParser a -> ReportingObjectParser b
pure :: a -> ReportingObjectParser a
$cpure :: forall a. a -> ReportingObjectParser a
$cp1Applicative :: Functor ReportingObjectParser
Applicative) via (Permutation (UP.Parser JSONObjectError))

newtype ReportingTupleParser a = ReportingTupleParser
  {ReportingTupleParser a
-> Integer -> (Integer, Parser JSONArrayError a)
runReportingTupleParser :: Integer -> (Integer, UP.Parser JSONArrayError a)}

instance Functor ReportingTupleParser where
  fmap :: (a -> b) -> ReportingTupleParser a -> ReportingTupleParser b
fmap a -> b
f (ReportingTupleParser Integer -> (Integer, Parser JSONArrayError a)
cb) =
    (Integer -> (Integer, Parser JSONArrayError b))
-> ReportingTupleParser b
forall a.
(Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
ReportingTupleParser ((Integer -> (Integer, Parser JSONArrayError b))
 -> ReportingTupleParser b)
-> (Integer -> (Integer, Parser JSONArrayError b))
-> ReportingTupleParser b
forall a b. (a -> b) -> a -> b
$ \Integer
index -> (Parser JSONArrayError a -> Parser JSONArrayError b)
-> (Integer, Parser JSONArrayError a)
-> (Integer, Parser JSONArrayError b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a -> b
f (a -> b) -> Parser JSONArrayError a -> Parser JSONArrayError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ((Integer, Parser JSONArrayError a)
 -> (Integer, Parser JSONArrayError b))
-> (Integer, Parser JSONArrayError a)
-> (Integer, Parser JSONArrayError b)
forall a b. (a -> b) -> a -> b
$ Integer -> (Integer, Parser JSONArrayError a)
cb Integer
index

instance Applicative ReportingTupleParser where
  pure :: a -> ReportingTupleParser a
pure a
a = (Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
forall a.
(Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
ReportingTupleParser (,a -> Parser JSONArrayError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
  (ReportingTupleParser Integer -> (Integer, Parser JSONArrayError (a -> b))
f) <*> :: ReportingTupleParser (a -> b)
-> ReportingTupleParser a -> ReportingTupleParser b
<*> (ReportingTupleParser Integer -> (Integer, Parser JSONArrayError a)
a) =
    (Integer -> (Integer, Parser JSONArrayError b))
-> ReportingTupleParser b
forall a.
(Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
ReportingTupleParser ((Integer -> (Integer, Parser JSONArrayError b))
 -> ReportingTupleParser b)
-> (Integer -> (Integer, Parser JSONArrayError b))
-> ReportingTupleParser b
forall a b. (a -> b) -> a -> b
$ \Integer
index ->
      let (Integer
index', Parser JSONArrayError (a -> b)
fp) = Integer -> (Integer, Parser JSONArrayError (a -> b))
f Integer
index
          (Integer
index'', Parser JSONArrayError a
ap) = Integer -> (Integer, Parser JSONArrayError a)
a Integer
index
       in ( Integer
index'',
            do
              a -> b
f' <- Parser JSONArrayError (a -> b)
fp
              Bool -> Parser JSONArrayError () -> Parser JSONArrayError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
index Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
index' Bool -> Bool -> Bool
&& Integer
index Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
index'') Parser JSONArrayError ()
forall err. Semigroup err => Parser err ()
comma
              a -> b
f' (a -> b) -> Parser JSONArrayError a -> Parser JSONArrayError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser JSONArrayError a
ap
          )

toObjectParser :: T.Text -> Parser JSONError a -> ReportingObjectParser a
toObjectParser :: Text -> Parser JSONError a -> ReportingObjectParser a
toObjectParser Text
field Parser JSONError a
itemParser =
  Permutation (Parser JSONObjectError) a -> ReportingObjectParser a
forall a.
Permutation (Parser JSONObjectError) a -> ReportingObjectParser a
ReportingObjectParser (Permutation (Parser JSONObjectError) a -> ReportingObjectParser a)
-> Permutation (Parser JSONObjectError) a
-> ReportingObjectParser a
forall a b. (a -> b) -> a -> b
$
    Parser JSONObjectError a
-> (forall b. Parser JSONObjectError b)
-> Permutation (Parser JSONObjectError) a
forall (f :: * -> *) a.
Alternative f =>
f a -> (forall b. f b) -> Permutation f a
asPermutationWithFailing Parser JSONObjectError a
parseKV forall b. Parser JSONObjectError b
failNoValue
  where
    failNoValue :: Parser JSONObjectError b
failNoValue = do
      ByteString
r <- Parser JSONObjectError ByteString
forall err. Semigroup err => Parser err ByteString
UP.peekRest
      JSONObjectError -> Parser JSONObjectError b
forall err a. err -> Parser err a
UP.failWith (JSONObjectError -> Parser JSONObjectError b)
-> JSONObjectError -> Parser JSONObjectError b
forall a b. (a -> b) -> a -> b
$
        Map Text JSONError -> JSONObjectError
MkJSONObjectError (Map Text JSONError -> JSONObjectError)
-> Map Text JSONError -> JSONObjectError
forall a b. (a -> b) -> a -> b
$ Text -> JSONError -> Map Text JSONError
forall k a. k -> a -> Map k a
Map.singleton Text
field JSONError
ErrorNoValue
    parseKV :: Parser JSONObjectError a
parseKV = (JSONError -> JSONObjectError)
-> Parser JSONError a -> Parser JSONObjectError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map Text JSONError -> JSONObjectError
MkJSONObjectError (Map Text JSONError -> JSONObjectError)
-> (JSONError -> Map Text JSONError)
-> JSONError
-> JSONObjectError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JSONError -> Map Text JSONError
forall k a. k -> a -> Map k a
Map.singleton Text
field) (Parser JSONError a -> Parser JSONObjectError a)
-> Parser JSONError a -> Parser JSONObjectError a
forall a b. (a -> b) -> a -> b
$ Text -> Parser JSONError a -> Parser JSONError a
forall err b. Monoid err => Text -> Parser err b -> Parser err b
parseObjectKV Text
field Parser JSONError a
itemParser
{-# INLINE toObjectParser #-}

toObjectParserDef :: Text -> Parser JSONError a -> a -> ReportingObjectParser a
toObjectParserDef Text
field Parser JSONError a
itemParser a
def =
  Permutation (Parser JSONObjectError) a -> ReportingObjectParser a
forall a.
Permutation (Parser JSONObjectError) a -> ReportingObjectParser a
ReportingObjectParser (Permutation (Parser JSONObjectError) a -> ReportingObjectParser a)
-> Permutation (Parser JSONObjectError) a
-> ReportingObjectParser a
forall a b. (a -> b) -> a -> b
$
    Parser JSONObjectError a
-> a -> Permutation (Parser JSONObjectError) a
forall (f :: * -> *) a.
Alternative f =>
f a -> a -> Permutation f a
asPermutationWithDefault Parser JSONObjectError a
parseKV a
def
  where
    parseKV :: Parser JSONObjectError a
parseKV = (JSONError -> JSONObjectError)
-> Parser JSONError a -> Parser JSONObjectError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map Text JSONError -> JSONObjectError
MkJSONObjectError (Map Text JSONError -> JSONObjectError)
-> (JSONError -> Map Text JSONError)
-> JSONError
-> JSONObjectError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JSONError -> Map Text JSONError
forall k a. k -> a -> Map k a
Map.singleton Text
field) (Parser JSONError a -> Parser JSONObjectError a)
-> Parser JSONError a -> Parser JSONObjectError a
forall a b. (a -> b) -> a -> b
$ do
      Text -> Parser JSONError a -> Parser JSONError a
forall err b. Monoid err => Text -> Parser err b -> Parser err b
parseObjectKV Text
field Parser JSONError a
itemParser

parseArrayInner :: UP.Parser JSONError a -> Integer -> UP.Parser JSONArrayError [a]
parseArrayInner :: Parser JSONError a -> Integer -> Parser JSONArrayError [a]
parseArrayInner Parser JSONError a
parse Integer
index =
  ((:) (a -> [a] -> [a])
-> Parser JSONArrayError a -> Parser JSONArrayError ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser JSONArrayError a
parseElem Parser JSONArrayError ([a] -> [a])
-> Parser JSONArrayError [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Parser JSONArrayError ()
forall err. Semigroup err => Parser err ()
comma Parser JSONArrayError ()
-> Parser JSONArrayError [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser JSONError a -> Integer -> Parser JSONArrayError [a]
forall a.
Parser JSONError a -> Integer -> Parser JSONArrayError [a]
parseArrayInner Parser JSONError a
parse (Integer
index Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) Parser JSONArrayError [a]
-> Parser JSONArrayError [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []))
    Parser JSONArrayError [a]
-> Parser JSONArrayError [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser JSONArrayError [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    parseElem :: Parser JSONArrayError a
parseElem = (JSONError -> JSONArrayError)
-> Parser JSONError a -> Parser JSONArrayError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map Integer JSONError -> JSONArrayError
MkJSONArrayError (Map Integer JSONError -> JSONArrayError)
-> (JSONError -> Map Integer JSONError)
-> JSONError
-> JSONArrayError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> JSONError -> Map Integer JSONError
forall k a. k -> a -> Map k a
Map.singleton Integer
index) Parser JSONError a
parse
{-# INLINE parseArrayInner #-}

parseDictKey :: UP.Parser JSONError a -> UP.Parser JSONObjectError (T.Text, a)
parseDictKey :: Parser JSONError a -> Parser JSONObjectError (Text, a)
parseDictKey Parser JSONError a
parseVal = do
  Text
key <- Parser JSONObjectError Text
forall err. Monoid err => Parser err Text
textParser
  Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
kvSep
  a
val <- (JSONError -> JSONObjectError)
-> Parser JSONError a -> Parser JSONObjectError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map Text JSONError -> JSONObjectError
MkJSONObjectError (Map Text JSONError -> JSONObjectError)
-> (JSONError -> Map Text JSONError)
-> JSONError
-> JSONObjectError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JSONError -> Map Text JSONError
forall k a. k -> a -> Map k a
Map.singleton Text
key) Parser JSONError a
parseVal
  (Text, a) -> Parser JSONObjectError (Text, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
key, a
val)

instance JSONTupleParser ReportingTupleParser where
  consumeItemWith :: (forall (valueParser :: * -> *).
 JSONParser valueParser =>
 valueParser a)
-> ReportingTupleParser a
consumeItemWith = \(ReportingParser itemParser) ->
    (Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
forall a.
(Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
ReportingTupleParser ((Integer -> (Integer, Parser JSONArrayError a))
 -> ReportingTupleParser a)
-> (Integer -> (Integer, Parser JSONArrayError a))
-> ReportingTupleParser a
forall a b. (a -> b) -> a -> b
$
      \Integer
index ->
        (Integer
index Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, (JSONError -> JSONArrayError)
-> Parser JSONError a -> Parser JSONArrayError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map Integer JSONError -> JSONArrayError
MkJSONArrayError (Map Integer JSONError -> JSONArrayError)
-> (JSONError -> Map Integer JSONError)
-> JSONError
-> JSONArrayError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> JSONError -> Map Integer JSONError
forall k a. k -> a -> Map k a
Map.singleton Integer
index) Parser JSONError a
itemParser)

instance JSONObjectParser ReportingObjectParser where
  parseFieldWith :: Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> ReportingObjectParser a
parseFieldWith Text
field = \(ReportingParser itemParser) ->
    Text -> Parser JSONError a -> ReportingObjectParser a
forall a. Text -> Parser JSONError a -> ReportingObjectParser a
toObjectParser Text
field Parser JSONError a
itemParser
  parseFieldWithDefault :: Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> a
-> ReportingObjectParser a
parseFieldWithDefault Text
field = \(ReportingParser itemParser) a
def ->
    Text -> Parser JSONError a -> a -> ReportingObjectParser a
forall a.
Text -> Parser JSONError a -> a -> ReportingObjectParser a
toObjectParserDef Text
field Parser JSONError a
itemParser a
def

instance JSONParser ReportingParser where
  parseTuple :: (forall (arrayParser :: * -> *).
 JSONTupleParser arrayParser =>
 arrayParser o)
-> ReportingParser o
parseTuple (ReportingTupleParser tp) =
    Parser JSONError o -> ReportingParser o
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError o -> ReportingParser o)
-> Parser JSONError o -> ReportingParser o
forall a b. (a -> b) -> a -> b
$ do
      JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
      case JSONType
jt of
        JSONType
JSONTypeArray -> Parser JSONError o
tuple
        JSONType
other -> JSONError -> Parser JSONError o
forall a. JSONError -> Parser JSONError a
skipWithFailure (JSONError -> Parser JSONError o)
-> JSONError -> Parser JSONError o
forall a b. (a -> b) -> a -> b
$ JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeArray JSONType
other
    where
      tuple :: Parser JSONError o
tuple = do
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
startArray
        let (Integer
_, Parser JSONArrayError o
arrayParse) = Integer -> (Integer, Parser JSONArrayError o)
tp Integer
0
        o
arr <- (JSONArrayError -> JSONError)
-> Parser JSONArrayError o -> Parser JSONError o
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JSONArrayError -> JSONError
ErrorBadArray Parser JSONArrayError o
arrayParse
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
endArray
        o -> Parser JSONError o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
arr
  {-# INLINE parseTuple #-}
  parseTextConstant :: Text -> ReportingParser ()
parseTextConstant Text
tc =
    Parser JSONError () -> ReportingParser ()
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError () -> ReportingParser ())
-> Parser JSONError () -> ReportingParser ()
forall a b. (a -> b) -> a -> b
$ do
      JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
      case JSONType
jt of
        JSONType
JSONTypeText -> Parser JSONError ()
textConstant
        JSONType
other -> JSONError -> Parser JSONError ()
forall a. JSONError -> Parser JSONError a
skipWithFailure (JSONError -> Parser JSONError ())
-> JSONError -> Parser JSONError ()
forall a b. (a -> b) -> a -> b
$ JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeText JSONType
other
    where
      textConstant :: Parser JSONError ()
textConstant = do
        ()
r <- Word8 -> Parser JSONError ()
forall err. Word8 -> Parser err ()
UP.specificWord Word8
34
        Parser JSONError () -> Parser JSONError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> Parser JSONError ()
forall err. Monoid err => Text -> Parser err ()
parseSpecificKeyAfterQuote Text
tc) Parser JSONError () -> Parser JSONError () -> Parser JSONError ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          Text
r <- Parser JSONError Text
forall err. Monoid err => Parser err Text
parseAfterQuote
          JSONError -> Parser JSONError ()
forall err a. err -> Parser err a
UP.failWith (Text -> Text -> JSONError
ErrorBadTextConstant Text
tc Text
r)
  {-# INLINE parseTextConstant #-}
  parseArrayWith :: (forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> ReportingParser [a]
parseArrayWith (ReportingParser rp) =
    Parser JSONError [a] -> ReportingParser [a]
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError [a] -> ReportingParser [a])
-> Parser JSONError [a] -> ReportingParser [a]
forall a b. (a -> b) -> a -> b
$
      Parser JSONError [a]
array
        Parser JSONError [a]
-> Parser JSONError [a] -> Parser JSONError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> JSONType -> Parser JSONError [a]
forall a. JSONType -> Parser JSONError a
skipNullExpecting JSONType
JSONTypeArray
        Parser JSONError [a]
-> Parser JSONError [a] -> Parser JSONError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> JSONType -> Parser JSONError [a]
forall a. JSONType -> Parser JSONError a
skipBoolExpecting JSONType
JSONTypeArray
        Parser JSONError [a]
-> Parser JSONError [a] -> Parser JSONError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> JSONType -> Parser JSONError [a]
forall a. JSONType -> Parser JSONError a
skipTextExpecting JSONType
JSONTypeArray
        Parser JSONError [a]
-> Parser JSONError [a] -> Parser JSONError [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> JSONType -> Parser JSONError [a]
forall a. JSONType -> Parser JSONError a
skipNumberExpecting JSONType
JSONTypeArray
    where
      array :: Parser JSONError [a]
array = do
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
startArray
        [a]
arr <- (JSONArrayError -> JSONError)
-> Parser JSONArrayError [a] -> Parser JSONError [a]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JSONArrayError -> JSONError
ErrorBadArray (Parser JSONArrayError [a] -> Parser JSONError [a])
-> Parser JSONArrayError [a] -> Parser JSONError [a]
forall a b. (a -> b) -> a -> b
$ Parser JSONError a -> Integer -> Parser JSONArrayError [a]
forall a.
Parser JSONError a -> Integer -> Parser JSONArrayError [a]
parseArrayInner Parser JSONError a
rp Integer
0
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
endArray
        [a] -> Parser JSONError [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
arr
  {-# INLINE parseDictionary #-}
  parseDictionary :: (forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> ReportingParser [(Text, a)]
parseDictionary (ReportingParser dict) =
    Parser JSONError [(Text, a)] -> ReportingParser [(Text, a)]
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError [(Text, a)] -> ReportingParser [(Text, a)])
-> Parser JSONError [(Text, a)] -> ReportingParser [(Text, a)]
forall a b. (a -> b) -> a -> b
$ do
      JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
      case JSONType
jt of
        JSONType
JSONTypeObject -> Parser JSONError [(Text, a)]
parseDict
        JSONType
other -> Parser JSONError JSONError -> Parser JSONError [(Text, a)]
forall err a. Parser err err -> Parser err a
UP.asFailure (Parser JSONError JSONError -> Parser JSONError [(Text, a)])
-> Parser JSONError JSONError -> Parser JSONError [(Text, a)]
forall a b. (a -> b) -> a -> b
$ Parser JSONError ()
forall err. Monoid err => Parser err ()
skipAnything Parser JSONError () -> JSONError -> Parser JSONError JSONError
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeObject JSONType
other
    where
      parseDict :: Parser JSONError [(Text, a)]
parseDict = do
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
startBracket
        [(Text, a)]
r <- (JSONObjectError -> JSONError)
-> Parser JSONObjectError [(Text, a)]
-> Parser JSONError [(Text, a)]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JSONObjectError -> JSONError
ErrorBadObject (Parser JSONObjectError [(Text, a)]
 -> Parser JSONError [(Text, a)])
-> Parser JSONObjectError [(Text, a)]
-> Parser JSONError [(Text, a)]
forall a b. (a -> b) -> a -> b
$ Parser JSONError a -> Parser JSONObjectError (Text, a)
forall a. Parser JSONError a -> Parser JSONObjectError (Text, a)
parseDictKey Parser JSONError a
dict Parser JSONObjectError (Text, a)
-> Parser JSONObjectError () -> Parser JSONObjectError [(Text, a)]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
`sepBy` Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
comma
        Parser JSONError ()
forall err. Semigroup err => Parser err ()
endBracket
        [(Text, a)] -> Parser JSONError [(Text, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, a)]
r
  parseObject :: (forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> ReportingParser a
parseObject (ReportingObjectParser permute) = Parser JSONError a -> ReportingParser a
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError a -> ReportingParser a)
-> Parser JSONError a -> ReportingParser a
forall a b. (a -> b) -> a -> b
$ do
    JSONType
r <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
    case JSONType
r of
      JSONType
JSONTypeObject -> Parser JSONError a
po
      JSONType
other -> Parser JSONError JSONError -> Parser JSONError a
forall err a. Parser err err -> Parser err a
UP.asFailure (Parser JSONError JSONError -> Parser JSONError a)
-> Parser JSONError JSONError -> Parser JSONError a
forall a b. (a -> b) -> a -> b
$ Parser JSONError ()
forall err. Monoid err => Parser err ()
skipAnything Parser JSONError () -> JSONError -> Parser JSONError JSONError
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeObject JSONType
other
    where
      po :: Parser JSONError a
po = (JSONObjectError -> JSONError)
-> Parser JSONObjectError a -> Parser JSONError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JSONObjectError -> JSONError
ErrorBadObject (Parser JSONObjectError a -> Parser JSONError a)
-> Parser JSONObjectError a -> Parser JSONError a
forall a b. (a -> b) -> a -> b
$ do
        Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
startBracket
        a
a <-
          Parser JSONObjectError ()
-> Parser JSONObjectError ()
-> Permutation (Parser JSONObjectError) a
-> Parser JSONObjectError a
forall (m :: * -> *) a b.
Alternative m =>
m b -> m b -> Permutation m a -> m a
wrapEffect
            Parser JSONObjectError ()
forall err. Monoid err => Parser err ()
skipAnyKV
            Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
comma
            Permutation (Parser JSONObjectError) a
permute
        ByteString
rest <- Parser JSONObjectError ByteString
forall err. Semigroup err => Parser err ByteString
peekRest
        Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
endBracket Parser JSONObjectError ()
-> Parser JSONObjectError () -> Parser JSONObjectError ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
comma
          Parser JSONObjectError ()
forall err. Monoid err => Parser err ()
skipAnyKV Parser JSONObjectError ()
-> Parser JSONObjectError () -> Parser JSONObjectError ()
forall (f :: * -> *) a1 a2. Alternative f => f a1 -> f a2 -> f ()
`sepByVoid` Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
comma
          Parser JSONObjectError ()
forall err. Semigroup err => Parser err ()
endBracket
        a -> Parser JSONObjectError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  {-# INLINE parseObject #-}
  parseNull :: ReportingParser ()
parseNull =
    Parser JSONError () -> ReportingParser ()
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError () -> ReportingParser ())
-> Parser JSONError () -> ReportingParser ()
forall a b. (a -> b) -> a -> b
$ do
      JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
      case JSONType
jt of
        JSONType
JSONTypeNull -> Parser JSONError ()
forall err. Semigroup err => Parser err ()
nullParser
        JSONType
other -> JSONError -> Parser JSONError ()
forall a. JSONError -> Parser JSONError a
skipWithFailure (JSONError -> Parser JSONError ())
-> JSONError -> Parser JSONError ()
forall a b. (a -> b) -> a -> b
$ JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeNull JSONType
other
  {-# INLINE parseNull #-}
  parseBool :: ReportingParser Bool
parseBool = Parser JSONError Bool -> ReportingParser Bool
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError Bool -> ReportingParser Bool)
-> Parser JSONError Bool -> ReportingParser Bool
forall a b. (a -> b) -> a -> b
$ do
    JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
    case JSONType
jt of
      JSONType
JSONTypeBool -> Parser JSONError Bool
forall err. Monoid err => Parser err Bool
boolParser
      JSONType
other -> JSONError -> Parser JSONError Bool
forall a. JSONError -> Parser JSONError a
skipWithFailure (JSONError -> Parser JSONError Bool)
-> JSONError -> Parser JSONError Bool
forall a b. (a -> b) -> a -> b
$ JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeBool JSONType
other
  {-# INLINE parseBool #-}
  parseText :: ReportingParser Text
parseText = Parser JSONError Text -> ReportingParser Text
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError Text -> ReportingParser Text)
-> Parser JSONError Text -> ReportingParser Text
forall a b. (a -> b) -> a -> b
$ do
    JSONType
jt <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
    case JSONType
jt of
      JSONType
JSONTypeText -> Parser JSONError Text
forall err. Monoid err => Parser err Text
textParser
      JSONType
other -> JSONError -> Parser JSONError Text
forall a. JSONError -> Parser JSONError a
skipWithFailure (JSONError -> Parser JSONError Text)
-> JSONError -> Parser JSONError Text
forall a b. (a -> b) -> a -> b
$ JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeText JSONType
other
  {-# INLINE parseText #-}
  parseNumber :: ReportingParser Scientific
parseNumber =
    Parser JSONError Scientific -> ReportingParser Scientific
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError Scientific -> ReportingParser Scientific)
-> Parser JSONError Scientific -> ReportingParser Scientific
forall a b. (a -> b) -> a -> b
$ do
      JSONType
r <- Parser JSONError JSONType
forall err. Monoid err => Parser err JSONType
peekJSONType
      case JSONType
r of
        JSONType
JSONTypeNumber -> Parser JSONError Scientific
forall err. Monoid err => Parser err Scientific
scientific
        JSONType
other -> Parser JSONError JSONError -> Parser JSONError Scientific
forall err a. Parser err err -> Parser err a
UP.asFailure (Parser JSONError JSONError -> Parser JSONError Scientific)
-> Parser JSONError JSONError -> Parser JSONError Scientific
forall a b. (a -> b) -> a -> b
$ Parser JSONError ()
forall err. Monoid err => Parser err ()
skipAnything Parser JSONError () -> JSONError -> Parser JSONError JSONError
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> JSONType -> JSONType -> JSONError
ErrorBadType JSONType
JSONTypeNumber JSONType
other
  {-# INLINE parseNumber #-}
  validateJSON :: ReportingParser (Either Text a) -> ReportingParser a
validateJSON (ReportingParser Parser JSONError (Either Text a)
rp) =
    Parser JSONError a -> ReportingParser a
forall a. Parser JSONError a -> ReportingParser a
ReportingParser (Parser JSONError a -> ReportingParser a)
-> Parser JSONError a -> ReportingParser a
forall a b. (a -> b) -> a -> b
$
      Parser JSONError (Either JSONError a) -> Parser JSONError a
forall err a. Parser err (Either err a) -> Parser err a
lowerErr ((Either Text a -> Either JSONError a)
-> Parser JSONError (Either Text a)
-> Parser JSONError (Either JSONError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> JSONError) -> Either Text a -> Either JSONError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> JSONError
ErrorMesage) Parser JSONError (Either Text a)
rp)
  {-# INLINE validateJSON #-}

parseOrReportWith ::
  (forall parser. JSONParser parser => parser a) ->
  BS.ByteString ->
  Either JSONError a
parseOrReportWith :: (forall (parser :: * -> *). JSONParser parser => parser a)
-> ByteString -> Either JSONError a
parseOrReportWith (ReportingParser rp) ByteString
bs =
  case Parser JSONError a -> ByteString -> Maybe (AccumE JSONError a)
forall err res.
Parser err res -> ByteString -> Maybe (AccumE err res)
UP.parseBS (Parser JSONError ()
forall err. Parser err ()
UP.skipWhitespace Parser JSONError () -> Parser JSONError a -> Parser JSONError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser JSONError a
rp) ByteString
bs of
    Maybe (AccumE JSONError a)
Nothing -> JSONError -> Either JSONError a
forall a b. a -> Either a b
Left JSONError
ErrorInvalidJSON
    Just (AccumE Either JSONError a
r) -> Either JSONError a
r
{-# INLINE parseOrReportWith #-}

parseOrReport :: (FromJSON a) => BS.ByteString -> Either JSONError a
parseOrReport :: ByteString -> Either JSONError a
parseOrReport = (forall (parser :: * -> *). JSONParser parser => parser a)
-> ByteString -> Either JSONError a
forall a.
(forall (parser :: * -> *). JSONParser parser => parser a)
-> ByteString -> Either JSONError a
parseOrReportWith forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (parser :: * -> *). JSONParser parser => parser a
fromJSON
{-# INLINE parseOrReport #-}