{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
#if __GLASGOW_HASKELL__ <= 800 && __GLASGOW_HASKELL__ >= 706
-- Work around a compiler bug
{-# OPTIONS_GHC -fsimpl-tick-factor=300 #-}
#endif
-- |
-- Module:      Data.Aeson.Parser.Internal
-- Copyright:   (c) 2011-2016 Bryan O'Sullivan
--              (c) 2011 MailRank, Inc.
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   experimental
-- Portability: portable
--
-- Efficiently and correctly parse a JSON string.  The string must be
-- encoded as UTF-8.

module Data.Aeson.Parser.Internal
    (
    -- * Lazy parsers
      json, jsonEOF
    , jsonWith
    , jsonLast
    , jsonAccum
    , jsonNoDup
    , value
    , jstring
    , jstring_
    , scientific
    -- * Strict parsers
    , json', jsonEOF'
    , jsonWith'
    , jsonLast'
    , jsonAccum'
    , jsonNoDup'
    , value'
    -- * Helpers
    , decodeWith
    , decodeStrictWith
    , eitherDecodeWith
    , eitherDecodeStrictWith
    -- ** Handling objects with duplicate keys
    , fromListAccum
    , parseListNoDup
    ) where

import Prelude.Compat

import Control.Applicative ((<|>))
import Control.Monad (void, when)
import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..), Key)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as Key
import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
import Data.Function (fix)
import Data.Functor.Compat (($>))
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Vector (Vector)
import Data.Word (Word8)
import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Lazy as L
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.ByteString.Builder as B
import qualified Data.Scientific as Sci
import Data.Aeson.Parser.Unescape (unescapeText)
import Data.Aeson.Internal.Text

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Aeson.Types

-------------------------------------------------------------------------------
-- Word8 ASCII codes as patterns
-------------------------------------------------------------------------------

-- GHC-8.0 doesn't support giving multiple pattern synonyms type signature at once

-- spaces
pattern W8_SPACE :: Word8
pattern W8_NL    :: Word8
pattern W8_CR    :: Word8
pattern W8_TAB   :: Word8

pattern $bW8_SPACE :: Word8
$mW8_SPACE :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_SPACE = 0x20
pattern $bW8_NL :: Word8
$mW8_NL :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_NL    = 0x0a
pattern $bW8_CR :: Word8
$mW8_CR :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_CR    = 0x0d
pattern $bW8_TAB :: Word8
$mW8_TAB :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_TAB   = 0x09

-- punctuation
pattern W8_BACKSLASH    :: Word8
pattern W8_DOUBLE_QUOTE :: Word8
pattern W8_DOT          :: Word8
pattern W8_COMMA        :: Word8

pattern $bW8_BACKSLASH :: Word8
$mW8_BACKSLASH :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_BACKSLASH    = 92
pattern $bW8_COMMA :: Word8
$mW8_COMMA :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_COMMA        = 44
pattern $bW8_DOT :: Word8
$mW8_DOT :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_DOT          = 46
pattern $bW8_DOUBLE_QUOTE :: Word8
$mW8_DOUBLE_QUOTE :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_DOUBLE_QUOTE = 34

-- parentheses
pattern W8_CLOSE_CURLY  :: Word8
pattern W8_CLOSE_SQUARE :: Word8
pattern W8_OPEN_SQUARE  :: Word8
pattern W8_OPEN_CURLY   :: Word8

pattern $bW8_OPEN_CURLY :: Word8
$mW8_OPEN_CURLY :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_OPEN_CURLY   = 123
pattern $bW8_OPEN_SQUARE :: Word8
$mW8_OPEN_SQUARE :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_OPEN_SQUARE  = 91
pattern $bW8_CLOSE_CURLY :: Word8
$mW8_CLOSE_CURLY :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_CLOSE_CURLY  = 125
pattern $bW8_CLOSE_SQUARE :: Word8
$mW8_CLOSE_SQUARE :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_CLOSE_SQUARE = 93

-- operators
pattern W8_MINUS :: Word8
pattern W8_PLUS  :: Word8

pattern $bW8_PLUS :: Word8
$mW8_PLUS :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_PLUS  = 43
pattern $bW8_MINUS :: Word8
$mW8_MINUS :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_MINUS = 45

-- digits
pattern W8_0 :: Word8
pattern W8_9 :: Word8

pattern $bW8_0 :: Word8
$mW8_0 :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_0 = 48
pattern $bW8_9 :: Word8
$mW8_9 :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_9 = 57

-- lower case
pattern W8_e :: Word8
pattern W8_f :: Word8
pattern W8_n :: Word8
pattern W8_t :: Word8

pattern $bW8_e :: Word8
$mW8_e :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_e = 101
pattern $bW8_f :: Word8
$mW8_f :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_f = 102
pattern $bW8_n :: Word8
$mW8_n :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_n = 110
pattern $bW8_t :: Word8
$mW8_t :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_t = 116

-- upper case
pattern W8_E :: Word8
pattern $bW8_E :: Word8
$mW8_E :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
W8_E = 69


-------------------------------------------------------------------------------
-- Parsers
-------------------------------------------------------------------------------

-- | Parse any JSON value.
--
-- The conversion of a parsed value to a Haskell value is deferred
-- until the Haskell value is needed.  This may improve performance if
-- only a subset of the results of conversions are needed, but at a
-- cost in thunk allocation.
--
-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
-- parsed only object or array types, in conformance with the
-- now-obsolete RFC 4627.
--
-- ==== Warning
--
-- If an object contains duplicate keys, only the first one will be kept.
-- For a more flexible alternative, see 'jsonWith'.
json :: Parser Value
json :: Parser Value
json = Parser Value
value

-- | Parse any JSON value.
--
-- This is a strict version of 'json' which avoids building up thunks
-- during parsing; it performs all conversions immediately.  Prefer
-- this version if most of the JSON data needs to be accessed.
--
-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
-- parsed only object or array types, in conformance with the
-- now-obsolete RFC 4627.
--
-- ==== Warning
--
-- If an object contains duplicate keys, only the first one will be kept.
-- For a more flexible alternative, see 'jsonWith''.
json' :: Parser Value
json' :: Parser Value
json' = Parser Value
value'

-- Open recursion: object_, object_', array_, array_' are parameterized by the
-- toplevel Value parser to be called recursively, to keep the parameter
-- mkObject outside of the recursive loop for proper inlining.

object_ :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value
object_ :: ([(Key, Value)] -> Either String Object)
-> Parser Value -> Parser Value
object_ [(Key, Value)] -> Either String Object
mkObject Parser Value
val = Object -> Value
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Key, Value)] -> Either String Object)
-> Parser Key -> Parser Value -> Parser Object
objectValues [(Key, Value)] -> Either String Object
mkObject Parser Key
key Parser Value
val
{-# INLINE object_ #-}

object_' :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value
object_' :: ([(Key, Value)] -> Either String Object)
-> Parser Value -> Parser Value
object_' [(Key, Value)] -> Either String Object
mkObject Parser Value
val' = do
  !Object
vals <- ([(Key, Value)] -> Either String Object)
-> Parser Key -> Parser Value -> Parser Object
objectValues [(Key, Value)] -> Either String Object
mkObject Parser Key
key' Parser Value
val'
  forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Object Object
vals)
 where
  key' :: Parser Key
key' = do
    !Key
s <- Parser Key
key
    forall (m :: * -> *) a. Monad m => a -> m a
return Key
s
{-# INLINE object_' #-}

objectValues :: ([(Key, Value)] -> Either String Object)
             -> Parser Key -> Parser Value -> Parser (KM.KeyMap Value)
objectValues :: ([(Key, Value)] -> Either String Object)
-> Parser Key -> Parser Value -> Parser Object
objectValues [(Key, Value)] -> Either String Object
mkObject Parser Key
str Parser Value
val = do
  Parser ()
skipSpace
  Word8
w <- Parser Word8
A.peekWord8'
  if Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_CLOSE_CURLY
    then Parser Word8
A.anyWord8 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall v. KeyMap v
KM.empty
    else [(Key, Value)] -> Parser Object
loop []
 where
  -- Why use acc pattern here, you may ask? because then the underlying 'KM.fromList'
  -- implementation can make use of mutation when constructing a map. For example,
  -- 'HashMap` uses 'unsafeInsert' and it's much faster because it's doing in place
  -- update to the 'HashMap'!
  loop :: [(Key, Value)] -> Parser Object
loop [(Key, Value)]
acc = do
    Key
k <- (Parser Key
str forall i a. Parser i a -> String -> Parser i a
A.<?> String
"object key") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Parser ByteString Char
char Char
':' forall i a. Parser i a -> String -> Parser i a
A.<?> String
"':'")
    Value
v <- (Parser Value
val forall i a. Parser i a -> String -> Parser i a
A.<?> String
"object value") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Word8
ch <- (Word8 -> Bool) -> Parser Word8
A.satisfy (\Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_COMMA Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_CLOSE_CURLY) forall i a. Parser i a -> String -> Parser i a
A.<?> String
"',' or '}'"
    let acc' :: [(Key, Value)]
acc' = (Key
k, Value
v) forall a. a -> [a] -> [a]
: [(Key, Value)]
acc
    if Word8
ch forall a. Eq a => a -> a -> Bool
== Word8
W8_COMMA
      then Parser ()
skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Key, Value)] -> Parser Object
loop [(Key, Value)]
acc'
      else case [(Key, Value)] -> Either String Object
mkObject [(Key, Value)]
acc' of
        Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right Object
obj -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
obj
{-# INLINE objectValues #-}

array_ :: Parser Value -> Parser Value
array_ :: Parser Value -> Parser Value
array_ Parser Value
val = Array -> Value
Array forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value -> Parser Array
arrayValues Parser Value
val
{-# INLINE array_ #-}

array_' :: Parser Value -> Parser Value
array_' :: Parser Value -> Parser Value
array_' Parser Value
val = do
  !Array
vals <- Parser Value -> Parser Array
arrayValues Parser Value
val
  forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Array Array
vals)
{-# INLINE array_' #-}

arrayValues :: Parser Value -> Parser (Vector Value)
arrayValues :: Parser Value -> Parser Array
arrayValues Parser Value
val = do
  Parser ()
skipSpace
  Word8
w <- Parser Word8
A.peekWord8'
  if Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_CLOSE_SQUARE
    then Parser Word8
A.anyWord8 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Vector a
Vector.empty
    else [Value] -> Int -> Parser Array
loop [] Int
1
  where
    loop :: [Value] -> Int -> Parser Array
loop [Value]
acc !Int
len = do
      Value
v <- (Parser Value
val forall i a. Parser i a -> String -> Parser i a
A.<?> String
"json list value") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
      Word8
ch <- (Word8 -> Bool) -> Parser Word8
A.satisfy (\Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_COMMA Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_CLOSE_SQUARE) forall i a. Parser i a -> String -> Parser i a
A.<?> String
"',' or ']'"
      if Word8
ch forall a. Eq a => a -> a -> Bool
== Word8
W8_COMMA
        then Parser ()
skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Value] -> Int -> Parser Array
loop (Value
vforall a. a -> [a] -> [a]
:[Value]
acc) (Int
lenforall a. Num a => a -> a -> a
+Int
1)
        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Vector a -> Vector a
Vector.reverse (forall a. Int -> [a] -> Vector a
Vector.fromListN Int
len (Value
vforall a. a -> [a] -> [a]
:[Value]
acc)))
{-# INLINE arrayValues #-}

-- | Parse any JSON value. Synonym of 'json'.
value :: Parser Value
value :: Parser Value
value = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
KM.fromList)

-- | Parse any JSON value.
--
-- This parser is parameterized by a function to construct an 'Object'
-- from a raw list of key-value pairs, where duplicates are preserved.
-- The pairs appear in __reverse order__ from the source.
--
-- ==== __Examples__
--
-- 'json' keeps only the first occurence of each key, using 'Data.Aeson.KeyMap.fromList'.
--
-- @
-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')
-- @
--
-- 'jsonLast' keeps the last occurence of each key, using
-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
--
-- @
-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
-- @
--
-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
-- 'fromListAccum'.
--
-- @
-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')
-- @
--
-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
--
-- @
-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
-- @
jsonWith :: ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith :: ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith [(Key, Value)] -> Either String Object
mkObject = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Parser Value
value_ -> do
  Parser ()
skipSpace
  Word8
w <- Parser Word8
A.peekWord8'
  case Word8
w of
    Word8
W8_DOUBLE_QUOTE  -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
jstring_)
    Word8
W8_OPEN_CURLY    -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([(Key, Value)] -> Either String Object)
-> Parser Value -> Parser Value
object_ [(Key, Value)] -> Either String Object
mkObject Parser Value
value_
    Word8
W8_OPEN_SQUARE   -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Value -> Parser Value
array_ Parser Value
value_
    Word8
W8_f             -> ByteString -> Parser ByteString
string ByteString
"false" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> Value
Bool Bool
False
    Word8
W8_t             -> ByteString -> Parser ByteString
string ByteString
"true" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> Value
Bool Bool
True
    Word8
W8_n             -> ByteString -> Parser ByteString
string ByteString
"null" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Value
Null
    Word8
_                 | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
W8_0 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
W8_9 Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_MINUS
                     -> Scientific -> Value
Number forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Scientific
scientific
      | Bool
otherwise    -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a valid json value"
{-# INLINE jsonWith #-}

-- | Variant of 'json' which keeps only the last occurence of every key.
jsonLast :: Parser Value
jsonLast :: Parser Value
jsonLast = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. (v -> v -> v) -> [(Key, v)] -> KeyMap v
KM.fromListWith (forall a b. a -> b -> a
const forall a. a -> a
id))

-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
-- key-value pairs with the same keys.
jsonAccum :: Parser Value
jsonAccum :: Parser Value
jsonAccum = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
fromListAccum)

-- | Variant of 'json' which fails if any object contains duplicate keys.
jsonNoDup :: Parser Value
jsonNoDup :: Parser Value
jsonNoDup = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith [(Key, Value)] -> Either String Object
parseListNoDup

-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
-- associated values from the original list @kvs@.
--
-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]
-- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])]
fromListAccum :: [(Key, Value)] -> Object
fromListAccum :: [(Key, Value)] -> Object
fromListAccum =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ [])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. (v -> v -> v) -> [(Key, v)] -> KeyMap v
KM.fromListWith forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (:)

-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
parseListNoDup :: [(Key, Value)] -> Either String Object
parseListNoDup :: [(Key, Value)] -> Either String Object
parseListNoDup =
  forall (f :: * -> *) v1 v2.
Applicative f =>
(Key -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)
KM.traverseWithKey forall {a} {b}. Show a => a -> Maybe b -> Either String b
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. (v -> v -> v) -> [(Key, v)] -> KeyMap v
KM.fromListWith (\Maybe Value
_ Maybe Value
_ -> forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a. a -> Maybe a
Just
  where

    unwrap :: a -> Maybe b -> Either String b
unwrap a
k Maybe b
Nothing = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"found duplicate key: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
k
    unwrap a
_ (Just b
v) = forall a b. b -> Either a b
Right b
v

-- | Strict version of 'value'. Synonym of 'json''.
value' :: Parser Value
value' :: Parser Value
value' = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
KM.fromList)

-- | Strict version of 'jsonWith'.
jsonWith' :: ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' :: ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' [(Key, Value)] -> Either String Object
mkObject = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Parser Value
value_ -> do
  Parser ()
skipSpace
  Word8
w <- Parser Word8
A.peekWord8'
  case Word8
w of
    Word8
W8_DOUBLE_QUOTE  -> do
                       !Text
s <- Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
jstring_
                       forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Value
String Text
s)
    Word8
W8_OPEN_CURLY    -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([(Key, Value)] -> Either String Object)
-> Parser Value -> Parser Value
object_' [(Key, Value)] -> Either String Object
mkObject Parser Value
value_
    Word8
W8_OPEN_SQUARE   -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Value -> Parser Value
array_' Parser Value
value_
    Word8
W8_f             -> ByteString -> Parser ByteString
string ByteString
"false" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> Value
Bool Bool
False
    Word8
W8_t             -> ByteString -> Parser ByteString
string ByteString
"true" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> Value
Bool Bool
True
    Word8
W8_n             -> ByteString -> Parser ByteString
string ByteString
"null" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Value
Null
    Word8
_                 | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
W8_0 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
W8_9 Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_MINUS
                     -> do
                       !Scientific
n <- Parser Scientific
scientific
                       forall (m :: * -> *) a. Monad m => a -> m a
return (Scientific -> Value
Number Scientific
n)
                      | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a valid json value"
{-# INLINE jsonWith' #-}

-- | Variant of 'json'' which keeps only the last occurence of every key.
jsonLast' :: Parser Value
jsonLast' :: Parser Value
jsonLast' = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. (v -> v -> v) -> [(Key, v)] -> KeyMap v
KM.fromListWith (forall a b. a -> b -> a
const forall a. a -> a
id))

-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve
-- key-value pairs with the same keys.
jsonAccum' :: Parser Value
jsonAccum' :: Parser Value
jsonAccum' = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
fromListAccum)

-- | Variant of 'json'' which fails if any object contains duplicate keys.
jsonNoDup' :: Parser Value
jsonNoDup' :: Parser Value
jsonNoDup' = ([(Key, Value)] -> Either String Object) -> Parser Value
jsonWith' [(Key, Value)] -> Either String Object
parseListNoDup

-- | Parse a quoted JSON string.
jstring :: Parser Text
jstring :: Parser Text
jstring = Word8 -> Parser Word8
A.word8 Word8
W8_DOUBLE_QUOTE forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
jstring_

-- | Parse a JSON Key
key :: Parser Key
key :: Parser Key
key = Text -> Key
Key.fromText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
jstring

-- | Parse a string without a leading quote.
jstring_ :: Parser Text
{-# INLINE jstring_ #-}
jstring_ :: Parser Text
jstring_ = do
  ByteString
s <- (Word8 -> Bool) -> Parser ByteString
A.takeWhile (\Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
/= Word8
W8_DOUBLE_QUOTE Bool -> Bool -> Bool
&& Word8
w forall a. Eq a => a -> a -> Bool
/= Word8
W8_BACKSLASH Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
0x20 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
< Word8
0x80)
  Maybe Word8
mw <- Parser (Maybe Word8)
A.peekWord8
  case Maybe Word8
mw of
    Maybe Word8
Nothing              -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"string without end"
    Just Word8
W8_DOUBLE_QUOTE -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ByteString -> Text
unsafeDecodeASCII ByteString
s
    Just Word8
w | Word8
w forall a. Ord a => a -> a -> Bool
< Word8
0x20    -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unescaped control character"
    Maybe Word8
_                    -> ByteString -> Parser Text
jstringSlow ByteString
s

jstringSlow :: B.ByteString -> Parser Text
{-# INLINE jstringSlow #-}
jstringSlow :: ByteString -> Parser Text
jstringSlow ByteString
s' = do
  ByteString
s <- forall s. s -> (s -> Word8 -> Maybe s) -> Parser ByteString
A.scan Bool
startState Bool -> Word8 -> Maybe Bool
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
A.anyWord8
  case ByteString -> Either UnicodeException Text
unescapeText (ByteString -> ByteString -> ByteString
B.append ByteString
s' ByteString
s) of
    Right Text
r  -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
r
    Left UnicodeException
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
err
 where
    startState :: Bool
startState                = Bool
False
    go :: Bool -> Word8 -> Maybe Bool
go Bool
a Word8
c
      | Bool
a                     = forall a. a -> Maybe a
Just Bool
False
      | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
W8_DOUBLE_QUOTE  = forall a. Maybe a
Nothing
      | Bool
otherwise = let a' :: Bool
a' = Word8
c forall a. Eq a => a -> a -> Bool
== Word8
W8_BACKSLASH
                    in forall a. a -> Maybe a
Just Bool
a'

decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a
decodeWith :: forall a.
Parser Value -> (Value -> Result a) -> ByteString -> Maybe a
decodeWith Parser Value
p Value -> Result a
to ByteString
s =
    case forall a. Parser a -> ByteString -> Result a
L.parse Parser Value
p ByteString
s of
      L.Done ByteString
_ Value
v -> case Value -> Result a
to Value
v of
                      Success a
a -> forall a. a -> Maybe a
Just a
a
                      Result a
_         -> forall a. Maybe a
Nothing
      Result Value
_          -> forall a. Maybe a
Nothing
{-# INLINE decodeWith #-}

decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString
                 -> Maybe a
decodeStrictWith :: forall a.
Parser Value -> (Value -> Result a) -> ByteString -> Maybe a
decodeStrictWith Parser Value
p Value -> Result a
to ByteString
s =
    case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> Result a
Error Value -> Result a
to (forall a. Parser a -> ByteString -> Either String a
A.parseOnly Parser Value
p ByteString
s) of
      Success a
a -> forall a. a -> Maybe a
Just a
a
      Result a
_         -> forall a. Maybe a
Nothing
{-# INLINE decodeStrictWith #-}

eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString
                 -> Either (JSONPath, String) a
eitherDecodeWith :: forall a.
Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
eitherDecodeWith Parser Value
p Value -> IResult a
to ByteString
s =
    case forall a. Parser a -> ByteString -> Result a
L.parse Parser Value
p ByteString
s of
      L.Done ByteString
_ Value
v     -> case Value -> IResult a
to Value
v of
                          ISuccess a
a      -> forall a b. b -> Either a b
Right a
a
                          IError JSONPath
path String
msg -> forall a b. a -> Either a b
Left (JSONPath
path, String
msg)
      L.Fail ByteString
notparsed [String]
ctx String
msg -> forall a b. a -> Either a b
Left ([], ByteString -> [String] -> String -> String
buildMsg ByteString
notparsed [String]
ctx String
msg)
  where
    buildMsg :: L.ByteString -> [String] -> String -> String
    buildMsg :: ByteString -> [String] -> String -> String
buildMsg ByteString
notYetParsed [] String
msg = String
msg forall a. [a] -> [a] -> [a]
++ ByteString -> String
formatErrorLine ByteString
notYetParsed
    buildMsg ByteString
notYetParsed (String
expectation:[String]
_) String
msg =
      String
msg forall a. [a] -> [a] -> [a]
++ String
". Expecting " forall a. [a] -> [a] -> [a]
++ String
expectation forall a. [a] -> [a] -> [a]
++ ByteString -> String
formatErrorLine ByteString
notYetParsed
{-# INLINE eitherDecodeWith #-}

-- | Grab the first 100 bytes from the non parsed portion and
-- format to get nicer error messages
formatErrorLine :: L.ByteString -> String
formatErrorLine :: ByteString -> String
formatErrorLine ByteString
bs =
  ByteString -> String
C.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  -- if formatting results in empty ByteString just return that
  -- otherwise construct the error message with the bytestring builder
  (\ByteString
bs' ->
     if ByteString -> Bool
BSL.null ByteString
bs'
       then ByteString
BSL.empty
       else
         Builder -> ByteString
B.toLazyByteString forall a b. (a -> b) -> a -> b
$
         String -> Builder
B.stringUtf8 String
" at '" forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.lazyByteString ByteString
bs' forall a. Semigroup a => a -> a -> a
<> String -> Builder
B.stringUtf8 String
"'"
  ) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  -- if newline is present cut at that position
  (Word8 -> Bool) -> ByteString -> ByteString
BSL.takeWhile (Word8
10 forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  -- remove spaces, CR's, tabs, backslashes and quotes characters
  (Word8 -> Bool) -> ByteString -> ByteString
BSL.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Word8
9, Word8
13, Word8
32, Word8
34, Word8
47, Word8
92]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  -- take 100 bytes
  Int64 -> ByteString -> ByteString
BSL.take Int64
100 forall a b. (a -> b) -> a -> b
$ ByteString
bs

eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
                       -> Either (JSONPath, String) a
eitherDecodeStrictWith :: forall a.
Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
eitherDecodeStrictWith Parser Value
p Value -> IResult a
to ByteString
s =
    case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. JSONPath -> String -> IResult a
IError []) Value -> IResult a
to (forall a. Parser a -> ByteString -> Either String a
A.parseOnly Parser Value
p ByteString
s) of
      ISuccess a
a      -> forall a b. b -> Either a b
Right a
a
      IError JSONPath
path String
msg -> forall a b. a -> Either a b
Left (JSONPath
path, String
msg)
{-# INLINE eitherDecodeStrictWith #-}

-- $lazy
--
-- The 'json' and 'value' parsers decouple identification from
-- conversion.  Identification occurs immediately (so that an invalid
-- JSON document can be rejected as early as possible), but conversion
-- to a Haskell value is deferred until that value is needed.
--
-- This decoupling can be time-efficient if only a smallish subset of
-- elements in a JSON value need to be inspected, since the cost of
-- conversion is zero for uninspected elements.  The trade off is an
-- increase in memory usage, due to allocation of thunks for values
-- that have not yet been converted.

-- $strict
--
-- The 'json'' and 'value'' parsers combine identification with
-- conversion.  They consume more CPU cycles up front, but have a
-- smaller memory footprint.

-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input.  See also: 'json'.
jsonEOF :: Parser Value
jsonEOF :: Parser Value
jsonEOF = Parser Value
json forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput

-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input.  See also: 'json''.
jsonEOF' :: Parser Value
jsonEOF' :: Parser Value
jsonEOF' = Parser Value
json' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput

-- | The only valid whitespace in a JSON document is space, newline,
-- carriage return, and tab.
skipSpace :: Parser ()
skipSpace :: Parser ()
skipSpace = (Word8 -> Bool) -> Parser ()
A.skipWhile forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_SPACE Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_NL Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_CR Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
W8_TAB
{-# INLINE skipSpace #-}

------------------ Copy-pasted and adapted from attoparsec ------------------

-- A strict pair
data SP = SP !Integer {-# UNPACK #-}!Int

decimal0 :: Parser Integer
decimal0 :: Parser Integer
decimal0 = do
  ByteString
digits <- (Word8 -> Bool) -> Parser ByteString
A.takeWhile1 Word8 -> Bool
isDigit_w8
  if ByteString -> Int
B.length ByteString
digits forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& ByteString -> Word8
B.unsafeHead ByteString
digits forall a. Eq a => a -> a -> Bool
== Word8
W8_0
    then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"leading zero"
    else forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Integer
bsToInteger ByteString
digits)

-- | Parse a JSON number.
scientific :: Parser Scientific
scientific :: Parser Scientific
scientific = do
  Word8
sign <- Parser Word8
A.peekWord8'
  let !positive :: Bool
positive = Bool -> Bool
not (Word8
sign forall a. Eq a => a -> a -> Bool
== Word8
W8_MINUS)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
sign forall a. Eq a => a -> a -> Bool
== Word8
W8_PLUS Bool -> Bool -> Bool
|| Word8
sign forall a. Eq a => a -> a -> Bool
== Word8
W8_MINUS) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Word8
A.anyWord8

  Integer
n <- Parser Integer
decimal0

  let f :: ByteString -> SP
f ByteString
fracDigits = Integer -> Int -> SP
SP (forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' forall {a}. Num a => a -> Word8 -> a
step Integer
n ByteString
fracDigits)
                        (forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
fracDigits)
      step :: a -> Word8 -> a
step a
a Word8
w = a
a forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w forall a. Num a => a -> a -> a
- Word8
W8_0)

  Maybe Word8
dotty <- Parser (Maybe Word8)
A.peekWord8
  SP Integer
c Int
e <- case Maybe Word8
dotty of
              Just Word8
W8_DOT -> Parser Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ByteString -> SP
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
A.takeWhile1 Word8 -> Bool
isDigit_w8)
              Maybe Word8
_           -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Int -> SP
SP Integer
n Int
0)

  let !signedCoeff :: Integer
signedCoeff | Bool
positive  =  Integer
c
                   | Bool
otherwise = -Integer
c

  ((Word8 -> Bool) -> Parser Word8
A.satisfy (\Word8
ex -> case Word8
ex of Word8
W8_e -> Bool
True; Word8
W8_E -> Bool
True; Word8
_ -> Bool
False) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Int -> Scientific
Sci.scientific Integer
signedCoeff forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
e forall a. Num a => a -> a -> a
+)) (forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Scientific
Sci.scientific Integer
signedCoeff    Int
e)
{-# INLINE scientific #-}

------------------ Copy-pasted and adapted from base ------------------------

bsToInteger :: B.ByteString -> Integer
bsToInteger :: ByteString -> Integer
bsToInteger ByteString
bs
    | Int
l forall a. Ord a => a -> a -> Bool
> Int
40    = Integer -> Int -> [Integer] -> Integer
valInteger Integer
10 Int
l [ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w forall a. Num a => a -> a -> a
- Word8
W8_0) | Word8
w <- ByteString -> [Word8]
B.unpack ByteString
bs ]
    | Bool
otherwise = ByteString -> Integer
bsToIntegerSimple ByteString
bs
  where
    l :: Int
l = ByteString -> Int
B.length ByteString
bs

bsToIntegerSimple :: B.ByteString -> Integer
bsToIntegerSimple :: ByteString -> Integer
bsToIntegerSimple = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' forall {a}. Num a => a -> Word8 -> a
step Integer
0 where
  step :: a -> Word8 -> a
step a
a Word8
b = a
a forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
b forall a. Num a => a -> a -> a
- Word8
W8_0)

-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
-- digits are combined into a single radix b^2 digit. This process is
-- repeated until we are left with a single digit. This algorithm
-- performs well only on large inputs, so we use the simple algorithm
-- for smaller inputs.
valInteger :: Integer -> Int -> [Integer] -> Integer
valInteger :: Integer -> Int -> [Integer] -> Integer
valInteger = Integer -> Int -> [Integer] -> Integer
go
  where
    go :: Integer -> Int -> [Integer] -> Integer
    go :: Integer -> Int -> [Integer] -> Integer
go Integer
_ Int
_ []  = Integer
0
    go Integer
_ Int
_ [Integer
d] = Integer
d
    go Integer
b Int
l [Integer]
ds
        | Int
l forall a. Ord a => a -> a -> Bool
> Int
40 = Integer
b' seq :: forall a b. a -> b -> b
`seq` Integer -> Int -> [Integer] -> Integer
go Integer
b' Int
l' (forall {t}. Num t => t -> [t] -> [t]
combine Integer
b [Integer]
ds')
        | Bool
otherwise = Integer -> [Integer] -> Integer
valSimple Integer
b [Integer]
ds
      where
        -- ensure that we have an even number of digits
        -- before we call combine:
        ds' :: [Integer]
ds' = if forall a. Integral a => a -> Bool
even Int
l then [Integer]
ds else Integer
0 forall a. a -> [a] -> [a]
: [Integer]
ds
        b' :: Integer
b' = Integer
b forall a. Num a => a -> a -> a
* Integer
b
        l' :: Int
l' = (Int
l forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`quot` Int
2

    combine :: t -> [t] -> [t]
combine t
b (t
d1 : t
d2 : [t]
ds) = t
d seq :: forall a b. a -> b -> b
`seq` (t
d forall a. a -> [a] -> [a]
: t -> [t] -> [t]
combine t
b [t]
ds)
      where
        d :: t
d = t
d1 forall a. Num a => a -> a -> a
* t
b forall a. Num a => a -> a -> a
+ t
d2
    combine t
_ []  = []
    combine t
_ [t
_] = forall a. String -> a
errorWithoutStackTrace String
"this should not happen"

-- The following algorithm is only linear for types whose Num operations
-- are in constant time.
valSimple :: Integer -> [Integer] -> Integer
valSimple :: Integer -> [Integer] -> Integer
valSimple Integer
base = forall {a}. Integral a => Integer -> [a] -> Integer
go Integer
0
  where
    go :: Integer -> [a] -> Integer
go Integer
r [] = Integer
r
    go Integer
r (a
d : [a]
ds) = Integer
r' seq :: forall a b. a -> b -> b
`seq` Integer -> [a] -> Integer
go Integer
r' [a]
ds
      where
        r' :: Integer
r' = Integer
r forall a. Num a => a -> a -> a
* Integer
base forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d