{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Convertion to and from @aeson@ 'A.Value'.
module Data.Aeson.Decoding (
    decode,
    eitherDecode,
    throwDecode,
    decodeStrict,
    eitherDecodeStrict,
    throwDecodeStrict,
    toEitherValue,
) where

import           Control.Monad.Catch                 (MonadThrow (..))
import           Data.Aeson.Key                      (Key)
import           Data.Aeson.Types.Internal           (formatError)
import           Data.Scientific                     (Scientific)

import qualified Data.Aeson.KeyMap                   as KM
import qualified Data.Aeson.Types                    as A
import qualified Data.ByteString                     as B
import qualified Data.ByteString.Lazy                as L
import qualified Data.Vector                         as V

import           Data.Aeson                          (AesonException (..))
import           Data.Aeson.Decoding.ByteString
import           Data.Aeson.Decoding.ByteString.Lazy
import           Data.Aeson.Decoding.Tokens

-------------------------------------------------------------------------------
-- Decoding: strict bytestring
-------------------------------------------------------------------------------

-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.
-- If this fails due to incomplete or invalid input, 'Nothing' is
-- returned.
decodeStrict :: (A.FromJSON a) => B.ByteString -> Maybe a
decodeStrict :: forall a. FromJSON a => ByteString -> Maybe a
decodeStrict ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
bsToTokens ByteString
bs)) (\String
_ -> Maybe a
forall a. Maybe a
Nothing) ((Value -> ByteString -> Maybe a) -> Maybe a)
-> (Value -> ByteString -> Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
bsSpace ByteString
bs' -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise   -> Maybe a
forall a. Maybe a
Nothing
    A.IError JSONPath
_ String
_      -> Maybe a
forall a. Maybe a
Nothing

-- | Like 'decodeStrict' but returns an error message when decoding fails.
eitherDecodeStrict :: (A.FromJSON a) => B.ByteString -> Either String a
eitherDecodeStrict :: forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
bsToTokens ByteString
bs)) String -> Either String a
forall a b. a -> Either a b
Left ((Value -> ByteString -> Either String a) -> Either String a)
-> (Value -> ByteString -> Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
bsSpace ByteString
bs' -> a -> Either String a
forall a b. b -> Either a b
Right a
x
        | Bool
otherwise   -> String -> Either String a
forall a b. a -> Either a b
Left String
"Trailing garbage"
    A.IError JSONPath
path String
msg -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ JSONPath -> String -> String
formatError JSONPath
path String
msg

-- | Like 'decodeStrict' but throws an 'AesonException' when decoding fails.
throwDecodeStrict :: forall a m. (A.FromJSON a, MonadThrow m) => B.ByteString -> m a
throwDecodeStrict :: forall a (m :: * -> *).
(FromJSON a, MonadThrow m) =>
ByteString -> m a
throwDecodeStrict ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
bsToTokens ByteString
bs)) (AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a)
-> (String -> AesonException) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AesonException
AesonException) ((Value -> ByteString -> m a) -> m a)
-> (Value -> ByteString -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
bsSpace ByteString
bs' -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        | Bool
otherwise   -> AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a) -> AesonException -> m a
forall a b. (a -> b) -> a -> b
$ String -> AesonException
AesonException String
"Trailing garbage"
    A.IError JSONPath
path String
msg -> AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a) -> AesonException -> m a
forall a b. (a -> b) -> a -> b
$ String -> AesonException
AesonException (String -> AesonException) -> String -> AesonException
forall a b. (a -> b) -> a -> b
$ JSONPath -> String -> String
formatError JSONPath
path String
msg

-------------------------------------------------------------------------------
-- Decoding: lazy bytestring
-------------------------------------------------------------------------------

-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.
-- If this fails due to incomplete or invalid input, 'Nothing' is
-- returned.
decode :: (A.FromJSON a) => L.ByteString -> Maybe a
decode :: forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
lbsToTokens ByteString
bs)) (\String
_ -> Maybe a
forall a. Maybe a
Nothing) ((Value -> ByteString -> Maybe a) -> Maybe a)
-> (Value -> ByteString -> Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
lbsSpace ByteString
bs' -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise    -> Maybe a
forall a. Maybe a
Nothing
    A.IError JSONPath
_ String
_       -> Maybe a
forall a. Maybe a
Nothing

-- | Like 'decodeStrict' but returns an error message when decoding fails.
eitherDecode :: (A.FromJSON a) => L.ByteString -> Either String a
eitherDecode :: forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
lbsToTokens ByteString
bs)) String -> Either String a
forall a b. a -> Either a b
Left ((Value -> ByteString -> Either String a) -> Either String a)
-> (Value -> ByteString -> Either String a) -> Either String a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
lbsSpace ByteString
bs' -> a -> Either String a
forall a b. b -> Either a b
Right a
x
        | Bool
otherwise    -> String -> Either String a
forall a b. a -> Either a b
Left String
"Trailing garbage"
    A.IError JSONPath
path String
msg  -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ JSONPath -> String -> String
formatError JSONPath
path String
msg

-- | Like 'decode' but throws an 'AesonException' when decoding fails.
throwDecode :: forall a m. (A.FromJSON a, MonadThrow m) => L.ByteString -> m a
throwDecode :: forall a (m :: * -> *).
(FromJSON a, MonadThrow m) =>
ByteString -> m a
throwDecode ByteString
bs = Result String ByteString Value
-> forall r. (String -> r) -> (Value -> ByteString -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens ByteString String -> Result String ByteString Value
forall k e. Tokens k e -> Result e k Value
toResultValue (ByteString -> Tokens ByteString String
lbsToTokens ByteString
bs)) (AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a)
-> (String -> AesonException) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AesonException
AesonException) ((Value -> ByteString -> m a) -> m a)
-> (Value -> ByteString -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Value
v ByteString
bs' -> case Value -> IResult a
forall a. FromJSON a => Value -> IResult a
A.ifromJSON Value
v of
    A.ISuccess a
x
        | ByteString -> Bool
lbsSpace ByteString
bs'  -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        | Bool
otherwise    -> AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a) -> AesonException -> m a
forall a b. (a -> b) -> a -> b
$ String -> AesonException
AesonException String
"Trailing garbage"
    A.IError JSONPath
path String
msg  -> AesonException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (AesonException -> m a) -> AesonException -> m a
forall a b. (a -> b) -> a -> b
$ String -> AesonException
AesonException (String -> AesonException) -> String -> AesonException
forall a b. (a -> b) -> a -> b
$ JSONPath -> String -> String
formatError JSONPath
path String
msg

-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------

bsSpace :: B.ByteString -> Bool
bsSpace :: ByteString -> Bool
bsSpace = (Word8 -> Bool) -> ByteString -> Bool
B.all (\Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x09)

lbsSpace :: L.ByteString -> Bool
lbsSpace :: ByteString -> Bool
lbsSpace = (Word8 -> Bool) -> ByteString -> Bool
L.all (\Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x09)

-- | Convert 'Tokens' to 'A.Value'.
toEitherValue
    :: Tokens k e             -- ^ tokens
    -> Either e (A.Value, k)  -- ^ either token error or value and leftover.
toEitherValue :: forall k e. Tokens k e -> Either e (Value, k)
toEitherValue Tokens k e
t = Result e k Value -> forall r. (e -> r) -> (Value -> k -> r) -> r
forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult (Tokens k e -> Result e k Value
forall k e. Tokens k e -> Result e k Value
toResultValue Tokens k e
t) e -> Either e (Value, k)
forall a b. a -> Either a b
Left ((Value -> k -> Either e (Value, k)) -> Either e (Value, k))
-> (Value -> k -> Either e (Value, k)) -> Either e (Value, k)
forall a b. (a -> b) -> a -> b
$ \Value
v k
k -> (Value, k) -> Either e (Value, k)
forall a b. b -> Either a b
Right (Value
v, k
k)

toResultValue
    :: Tokens k e           -- ^ tokens
    -> Result e k A.Value  -- ^ either token error or value and leftover.
toResultValue :: forall k e. Tokens k e -> Result e k Value
toResultValue Tokens k e
t0 = (forall r. (e -> r) -> (Value -> k -> r) -> r) -> Result e k Value
forall e k a.
(forall r. (e -> r) -> (a -> k -> r) -> r) -> Result e k a
Result (Tokens k e -> (e -> r) -> (Value -> k -> r) -> r
forall k e r. Tokens k e -> (e -> r) -> (Value -> k -> r) -> r
go Tokens k e
t0) where
    go :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r
    go :: forall k e r. Tokens k e -> (e -> r) -> (Value -> k -> r) -> r
go (TkLit Lit
l k
k)        e -> r
_ Value -> k -> r
f = Value -> k -> r
f (Lit -> Value
lit Lit
l) k
k
    go (TkText Text
t k
k)       e -> r
_ Value -> k -> r
f = Value -> k -> r
f (Text -> Value
A.String Text
t) k
k
    go (TkNumber Number
n k
k)     e -> r
_ Value -> k -> r
f = Value -> k -> r
f (Scientific -> Value
A.Number (Number -> Scientific
num Number
n)) k
k
    go (TkArrayOpen TkArray k e
arr)  e -> r
g Value -> k -> r
f = Int
-> ([Value] -> [Value])
-> TkArray k e
-> (e -> r)
-> (Int -> [Value] -> k -> r)
-> r
forall k e r.
Int
-> ([Value] -> [Value])
-> TkArray k e
-> (e -> r)
-> (Int -> [Value] -> k -> r)
-> r
goA Int
0 [Value] -> [Value]
forall a. a -> a
id TkArray k e
arr e -> r
g ((Int -> [Value] -> k -> r) -> r)
-> (Int -> [Value] -> k -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Int
n [Value]
xs k
k -> Value -> k -> r
f (Array -> Value
A.Array (Int -> [Value] -> Array
forall a. Int -> [a] -> Vector a
V.fromListN Int
n [Value]
xs)) k
k
    go (TkRecordOpen TkRecord k e
rec) e -> r
g Value -> k -> r
f = [(Key, Value)]
-> TkRecord k e -> (e -> r) -> ([(Key, Value)] -> k -> r) -> r
forall k e r.
[(Key, Value)]
-> TkRecord k e -> (e -> r) -> ([(Key, Value)] -> k -> r) -> r
goR [] TkRecord k e
rec e -> r
g (([(Key, Value)] -> k -> r) -> r)
-> ([(Key, Value)] -> k -> r) -> r
forall a b. (a -> b) -> a -> b
$ \[(Key, Value)]
xs k
k -> Value -> k -> r
f (Object -> Value
A.Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList [(Key, Value)]
xs)) k
k
    go (TkErr e
e)          e -> r
g Value -> k -> r
_ = e -> r
g e
e

    lit :: Lit -> A.Value
    lit :: Lit -> Value
lit Lit
LitNull  = Value
A.Null
    lit Lit
LitTrue  = Bool -> Value
A.Bool Bool
True
    lit Lit
LitFalse = Bool -> Value
A.Bool Bool
False

    num :: Number -> Scientific
    num :: Number -> Scientific
num (NumInteger Integer
n)    = Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n
    num (NumDecimal Scientific
s)    = Scientific
s
    num (NumScientific Scientific
s) = Scientific
s

    goA :: Int                           -- size accumulator
        -> ([A.Value] -> [A.Value])      -- dlist accumulator
        -> TkArray k e                   -- array tokens
        -> (e -> r)                      -- error continuation
        -> (Int -> [A.Value] -> k -> r)  -- success continuation
        -> r
    goA :: forall k e r.
Int
-> ([Value] -> [Value])
-> TkArray k e
-> (e -> r)
-> (Int -> [Value] -> k -> r)
-> r
goA !Int
n ![Value] -> [Value]
acc (TkItem Tokens (TkArray k e) e
toks)  e -> r
g Int -> [Value] -> k -> r
f = Tokens (TkArray k e) e
-> (e -> r) -> (Value -> TkArray k e -> r) -> r
forall k e r. Tokens k e -> (e -> r) -> (Value -> k -> r) -> r
go Tokens (TkArray k e) e
toks e -> r
g ((Value -> TkArray k e -> r) -> r)
-> (Value -> TkArray k e -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Value
v TkArray k e
k -> Int
-> ([Value] -> [Value])
-> TkArray k e
-> (e -> r)
-> (Int -> [Value] -> k -> r)
-> r
forall k e r.
Int
-> ([Value] -> [Value])
-> TkArray k e
-> (e -> r)
-> (Int -> [Value] -> k -> r)
-> r
goA (Int -> Int
forall a. Enum a => a -> a
succ Int
n) ([Value] -> [Value]
acc ([Value] -> [Value]) -> ([Value] -> [Value]) -> [Value] -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value
v Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)) TkArray k e
k e -> r
g Int -> [Value] -> k -> r
f
    goA !Int
n ![Value] -> [Value]
acc (TkArrayEnd k
k) e -> r
_ Int -> [Value] -> k -> r
f = Int -> [Value] -> k -> r
f Int
n ([Value] -> [Value]
acc []) k
k
    goA !Int
_ ![Value] -> [Value]
_   (TkArrayErr e
e) e -> r
g Int -> [Value] -> k -> r
_ = e -> r
g e
e

    -- we accumulate keys in reverse order
    -- then the first duplicate key in objects wins (as KM.fromList picks last).
    goR :: [(Key, A.Value)]
        -> TkRecord k e
        -> (e -> r)
        -> ([(Key, A.Value)] -> k -> r)
        -> r
    goR :: forall k e r.
[(Key, Value)]
-> TkRecord k e -> (e -> r) -> ([(Key, Value)] -> k -> r) -> r
goR ![(Key, Value)]
acc (TkPair Key
t Tokens (TkRecord k e) e
toks) e -> r
g [(Key, Value)] -> k -> r
f = Tokens (TkRecord k e) e
-> (e -> r) -> (Value -> TkRecord k e -> r) -> r
forall k e r. Tokens k e -> (e -> r) -> (Value -> k -> r) -> r
go Tokens (TkRecord k e) e
toks e -> r
g ((Value -> TkRecord k e -> r) -> r)
-> (Value -> TkRecord k e -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Value
v TkRecord k e
k -> [(Key, Value)]
-> TkRecord k e -> (e -> r) -> ([(Key, Value)] -> k -> r) -> r
forall k e r.
[(Key, Value)]
-> TkRecord k e -> (e -> r) -> ([(Key, Value)] -> k -> r) -> r
goR ((Key
t , Value
v) (Key, Value) -> [(Key, Value)] -> [(Key, Value)]
forall a. a -> [a] -> [a]
: [(Key, Value)]
acc) TkRecord k e
k e -> r
g [(Key, Value)] -> k -> r
f
    goR ![(Key, Value)]
acc (TkRecordEnd k
k) e -> r
_ [(Key, Value)] -> k -> r
f = [(Key, Value)] -> k -> r
f [(Key, Value)]
acc k
k
    goR ![(Key, Value)]
_   (TkRecordErr e
e) e -> r
g [(Key, Value)] -> k -> r
_ = e -> r
g e
e

newtype Result e k a = Result
    { forall e k a.
Result e k a -> forall r. (e -> r) -> (a -> k -> r) -> r
unResult :: forall r. (e -> r) -> (a -> k -> r) -> r }