{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Aeson.Compat
-- Copyright   :  (C) 2015 Oleg Grenrus
-- License     :  BSD3
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
-- Compatibility notices
--
--   * 'decode' etc. work as in @aeson >=0.9@
--   * but it is generalised to work in any 'MonadThrow' (that is extra)
--   * '.:?' works as in @aeson <0.10 || >=0.11@
--   * '.:!' works as in @aeson <0.10 || >=0.11@ and as '.:?' did in @aeson ==0.10.*@
--   * Orphan instances 'FromJSON' 'Day' and 'FromJSON' 'LocalTime' for @aeson <0.10@
--   * 'Encoding' related functionality is not added. It's present only with @aeson >=0.10@
--
module Data.Aeson.Compat (
    -- * Encoding and decoding
    -- ** Direct encoding
    decode,
    decode',
    AesonException(..),
    eitherDecode,
    eitherDecode',
    encode,
    -- ** Variants for strict bytestrings
    decodeStrict,
    decodeStrict',
    eitherDecodeStrict,
    eitherDecodeStrict',
    -- * Core JSON types
    Value(..),
#if MIN_VERSION_aeson(0,10,0)
    Encoding,
    fromEncoding,
#endif
    Array,
    Object,
    -- * Convenience types
    DotNetTime(..),
    -- * Type conversion
    FromJSON(..),
    Result(..),
    fromJSON,
    ToJSON(..),
#if MIN_VERSION_aeson(0,10,0)
    KeyValue(..),
#else
    (.=),
#endif
    -- ** Generic JSON classes and options
    GFromJSON,
    GToJSON,
#if MIN_VERSION_aeson(0,11,0)
    -- GToEncoding is introduced in 0.11.0.0
    GToEncoding,
#endif
    genericToJSON,
#if MIN_VERSION_aeson(0,10,0)
    genericToEncoding,
#endif
    genericParseJSON,
    defaultOptions,

    -- * Inspecting @'Value's@
    withObject,
    withText,
    withArray,
    withNumber,
    withScientific,
    withBool,
    withEmbeddedJSON,
    -- * Constructors and accessors
#if MIN_VERSION_aeson(0,10,0)
    Series,
    pairs,
    foldable,
#endif
    (.:),
    (.:?),
    (.:!),
    (.!=),
    object,
    -- * Parsing
    json,
    json',
    value,
    value',
    Parser,
  ) where

import Prelude ()
import Prelude.Compat

import           Data.Aeson hiding
  ((.:?), (.:), decode, decode', decodeStrict, decodeStrict'
#if MIN_VERSION_aeson (0,11,0)
  , (.:!)
#endif
#if !MIN_VERSION_aeson (0,9,0)
  , eitherDecode, eitherDecode', eitherDecodeStrict, eitherDecodeStrict'
#endif
#if !MIN_VERSION_aeson (1,4,0)
  , withNumber
#endif
  )

import qualified Data.Aeson as Aeson

import           Data.Aeson.Parser (value, value')

#if !MIN_VERSION_aeson (0,9,0)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A (skipSpace)
import qualified Data.Attoparsec.Lazy as L
#endif

import           Control.Monad.Catch (MonadThrow (..), Exception)
import           Data.Aeson.Types (Parser, modifyFailure, typeMismatch, defaultOptions)
import           Data.ByteString as BS
import qualified Data.Scientific as Scientific
import           Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HM
import           Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Typeable (Typeable)

#if !MIN_VERSION_aeson(0,10,0)
import           Data.Time (Day, LocalTime, formatTime, NominalDiffTime)
import           Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Data.Attoparsec.Text as Atto
import qualified Data.Attoparsec.Time as CompatTime
#endif

#if !(MIN_VERSION_aeson(0,11,0) && MIN_VERSION_base(4,8,0))
import Numeric.Natural (Natural)
#endif

#if !MIN_VERSION_aeson(0,11,0)
import Data.Version (Version, showVersion, parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)
#endif

#if !MIN_VERSION_aeson(0,11,1)
import Control.Applicative (Const (..))
import Data.List.NonEmpty  (NonEmpty (..))
import Data.Proxy          (Proxy (..))
import Data.Tagged         (Tagged (..))

import qualified Data.List.NonEmpty as NE
import qualified Data.Vector        as V
#endif

#if !MIN_VERSION_aeson(1,4,1)
import Data.Void (Void, absurd)
#endif

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
#endif

import Data.Attoparsec.Number (Number (..))

-- | Exception thrown by 'decode' - family of functions in this module.
newtype AesonException = AesonException String
  deriving (Int -> AesonException -> ShowS
[AesonException] -> ShowS
AesonException -> String
(Int -> AesonException -> ShowS)
-> (AesonException -> String)
-> ([AesonException] -> ShowS)
-> Show AesonException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AesonException] -> ShowS
$cshowList :: [AesonException] -> ShowS
show :: AesonException -> String
$cshow :: AesonException -> String
showsPrec :: Int -> AesonException -> ShowS
$cshowsPrec :: Int -> AesonException -> ShowS
Show, Typeable)

instance Exception AesonException

eitherAesonExc :: (MonadThrow m) => Either String a -> m a
eitherAesonExc :: Either String a -> m a
eitherAesonExc (Left String
err) = AesonException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> AesonException
AesonException String
err)
eitherAesonExc (Right a
x)  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Like original 'Data.Aeson.decode' but in arbitrary 'MonadThrow'.
--
-- Parse a top-level JSON value, i.e. also strings, numbers etc.
decode :: (FromJSON a, MonadThrow m) => LBS.ByteString -> m a
decode :: ByteString -> m a
decode = Either String a -> m a
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
eitherAesonExc (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode

-- | Like original 'Data.Aeson.decode'' but in arbitrary 'MonadThrow'.
decode' :: (FromJSON a, MonadThrow m) => LBS.ByteString -> m a
decode' :: ByteString -> m a
decode' = Either String a -> m a
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
eitherAesonExc (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode'

-- | Like original 'Data.Aeson.decodeStrict' but in arbitrary 'MonadThrow'.
decodeStrict :: (FromJSON a, MonadThrow m) => BS.ByteString -> m a
decodeStrict :: ByteString -> m a
decodeStrict = Either String a -> m a
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
eitherAesonExc (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict

-- | Like original 'Data.Aeson.decodeStrict'' but in arbitrary 'MonadThrow'.
decodeStrict' :: (FromJSON a, MonadThrow m) => BS.ByteString -> m a
decodeStrict' :: ByteString -> m a
decodeStrict' = Either String a -> m a
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
eitherAesonExc (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict'

(.:) :: (FromJSON a) => Object -> Text -> Parser a
#if MIN_VERSION_aeson(2,0,0)
Object
obj .: :: Object -> Text -> Parser a
.: Text
key = Object
obj Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Text -> Key
Key.fromText Text
key
#else
obj .: key = obj Aeson..: key
#endif

-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'Nothing' if the key is not present, or 'empty' if
-- the value cannot be converted to the desired type.
--
-- This accessor is most useful if the key and value can be absent
-- from an object without affecting its validity.  If the key and
-- value are mandatory, use '.:' instead.
--
-- This operator is consistent in @aeson >=0.7 && <0.11@
(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
Object
obj .:? :: Object -> Text -> Parser (Maybe a)
.:? Text
key =
#if MIN_VERSION_aeson(2,0,0)
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
key) Object
obj of
#else
  case HM.lookup key obj of
#endif
                Maybe Value
Nothing -> Maybe a -> Parser (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                Just Value
v  ->
#if MIN_VERSION_aeson(0,10,0)
                  ShowS -> Parser (Maybe a) -> Parser (Maybe a)
forall a. ShowS -> Parser a -> Parser a
modifyFailure ShowS
addKeyName (Parser (Maybe a) -> Parser (Maybe a))
-> Parser (Maybe a) -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ Value -> Parser (Maybe a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v -- <?> Key key
  where
    addKeyName :: ShowS
addKeyName = String -> ShowS
forall a. Monoid a => a -> a -> a
mappend (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"failed to parse field ", Text -> String
T.unpack Text
key, String
": "]
#else
                  parseJSON v
#endif
{-# INLINE (.:?) #-}

-- | Like '.:?', but the resulting parser will fail,
-- if the key is present but is 'Null'.
(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
#if MIN_VERSION_aeson(2,0,0)
Object
obj .:! :: Object -> Text -> Parser (Maybe a)
.:! Text
key = Object
obj Object -> Key -> Parser (Maybe a)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:! Text -> Key
Key.fromText Text
key
#else
#if MIN_VERSION_aeson(0,11,0)
(.:!) = (Aeson..:!)
#else
obj .:! key =
#if MIN_VERSION_aeson(2,0,0)
  case KM.lookup (Key.fromText key) obj of
#else
  case HM.lookup key obj of
#endif
                Nothing -> pure Nothing
                Just v  ->
#if MIN_VERSION_aeson(0,10,0)
                  modifyFailure addKeyName $ Just <$> parseJSON v -- <?> Key key
  where
    addKeyName = mappend $ mconcat ["failed to parse field ", T.unpack key, ": "]
#else
                  Just <$> parseJSON v
#endif
{-# INLINE (.:!) #-}
#endif
#endif

#if !MIN_VERSION_aeson(0,9,0)
-- From Parser.Internal

-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input.  See also: 'json'.
jsonEOF :: A.Parser Value
jsonEOF = value <* A.skipSpace <* A.endOfInput

-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input.  See also: 'json''.
jsonEOF' :: A.Parser Value
jsonEOF' = value' <* A.skipSpace <* A.endOfInput

-- | Like 'decode' but returns an error message when decoding fails.
eitherDecode :: (FromJSON a) => LBS.ByteString -> Either String a
eitherDecode = eitherDecodeWith jsonEOF fromJSON
{-# INLINE eitherDecode #-}

-- | Like 'decodeStrict' but returns an error message when decoding fails.
eitherDecodeStrict :: (FromJSON a) => BS.ByteString -> Either String a
eitherDecodeStrict = eitherDecodeStrictWith jsonEOF fromJSON
{-# INLINE eitherDecodeStrict #-}

-- | Like 'decode'' but returns an error message when decoding fails.
eitherDecode' :: (FromJSON a) => LBS.ByteString -> Either String a
eitherDecode' = eitherDecodeWith jsonEOF' fromJSON
{-# INLINE eitherDecode' #-}

-- | Like 'decodeStrict'' but returns an error message when decoding fails.
eitherDecodeStrict' :: (FromJSON a) => BS.ByteString -> Either String a
eitherDecodeStrict' = eitherDecodeStrictWith jsonEOF' fromJSON
{-# INLINE eitherDecodeStrict' #-}

eitherDecodeWith :: L.Parser Value -> (Value -> Result a) -> LBS.ByteString
                 -> Either String a
eitherDecodeWith p to s =
    case L.parse p s of
      L.Done _ v -> case to v of
                      Success a -> Right a
                      Error msg -> Left msg
      L.Fail _ _ msg -> Left msg
{-# INLINE eitherDecodeWith #-}

eitherDecodeStrictWith :: A.Parser Value -> (Value -> Result a) -> BS.ByteString
                       -> Either String a
eitherDecodeStrictWith p to s =
    case either Error to (A.parseOnly p s) of
      Success a -> Right a
      Error msg -> Left msg
{-# INLINE eitherDecodeStrictWith #-}

#endif

-----------------------------------------------------------------------
-- Instances in aeson-0.10
-----------------------------------------------------------------------

#if !MIN_VERSION_aeson(0,10,0)
attoRun :: Atto.Parser a -> Text -> Parser a
attoRun p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
    Left err -> fail $ "could not parse date: " ++ err
    Right r  -> return r

instance FromJSON Day where
  parseJSON = withText "Day" (attoRun CompatTime.day)

instance FromJSON LocalTime where
  parseJSON = withText "LocalTime" (attoRun CompatTime.localTime)

instance ToJSON Day where
  toJSON = toJSON . T.pack . formatTime defaultTimeLocale "%F"

instance ToJSON LocalTime where
  toJSON = toJSON . T.pack . formatTime defaultTimeLocale "%FT%T%Q"

instance ToJSON NominalDiffTime where
  toJSON = Number . realToFrac
  {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
  toEncoding = Encoding . E.number . realToFrac
  {-# INLINE toEncoding #-}
#endif

-- | /WARNING:/ Only parse lengths of time from trusted input
-- since an attacker could easily fill up the memory of the target
-- system by specifying a scientific number with a big exponent like
-- @1e1000000000@.
instance FromJSON NominalDiffTime where
  parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
  {-# INLINE parseJSON #-}
#endif

-----------------------------------------------------------------------
-- Instances in aeson-0.11
-----------------------------------------------------------------------

#if !(MIN_VERSION_aeson(0,11,1))
#if !(MIN_VERSION_aeson(0,11,0) && MIN_VERSION_base(4,8,0))
instance ToJSON Natural where
    toJSON = toJSON . toInteger
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding = toEncoding . toInteger
    {-# INLINE toEncoding #-}
#endif

instance FromJSON Natural where
    parseJSON = withScientific "Natural" $ \s ->
      if Scientific.coefficient s < 0
        then fail $ "Expected a Natural number but got the negative number: " ++ show s
        else pure $ truncate s
#endif
#endif

#if !MIN_VERSION_aeson(0,11,0)
instance ToJSON Version where
    toJSON = toJSON . showVersion
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding = toEncoding . showVersion
    {-# INLINE toEncoding #-}
#endif

instance FromJSON Version where
    {-# INLINE parseJSON #-}
    parseJSON = withText "Version" $ go . readP_to_S parseVersion . T.unpack
      where
        go [(v,[])] = return v
        go (_ : xs) = go xs
        go _        = fail "could not parse Version"

instance ToJSON Ordering where
  toJSON     = toJSON     . orderingToText
#if MIN_VERSION_aeson(0,10,0)
  toEncoding = toEncoding . orderingToText
#endif

orderingToText :: Ordering -> T.Text
orderingToText o = case o of
                     LT -> "LT"
                     EQ -> "EQ"
                     GT -> "GT"

instance FromJSON Ordering where
  parseJSON = withText "Ordering" $ \s ->
    case s of
      "LT" -> return LT
      "EQ" -> return EQ
      "GT" -> return GT
      _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""
#endif

#if !MIN_VERSION_aeson(0,11,1)
instance ToJSON (Proxy a) where
    toJSON _ = Null
    {-# INLINE toJSON #-}

    -- No 'toEncoding', default is good enough

instance FromJSON (Proxy a) where
    {-# INLINE parseJSON #-}
    parseJSON Null = pure Proxy
    parseJSON v    = typeMismatch "Proxy" v

instance ToJSON b => ToJSON (Tagged a b) where
    toJSON (Tagged x) = toJSON x
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding (Tagged x) = toEncoding x
    {-# INLINE toEncoding #-}
#endif

instance FromJSON b => FromJSON (Tagged a b) where
    {-# INLINE parseJSON #-}
    parseJSON = fmap Tagged . parseJSON

instance ToJSON a => ToJSON (Const a b) where
    toJSON (Const x) = toJSON x
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding (Const x) = toEncoding x
    {-# INLINE toEncoding #-}
#endif

instance FromJSON a => FromJSON (Const a b) where
    {-# INLINE parseJSON #-}
    parseJSON = fmap Const . parseJSON

instance (ToJSON a) => ToJSON (NonEmpty a) where
    toJSON = toJSON . NE.toList
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding = toEncoding . NE.toList
    {-# INLINE toEncoding #-}
#endif

instance (FromJSON a) => FromJSON (NonEmpty a) where
    parseJSON = withArray "NonEmpty a" $
        (>>= ne) . traverse parseJSON . V.toList
      where
        ne []     = fail "Expected a NonEmpty but got an empty list"
        ne (x:xs) = pure (x :| xs)
#endif

#if !MIN_VERSION_aeson(1,4,1)
instance ToJSON Void where
    toJSON = absurd
    {-# INLINE toJSON #-}

#if MIN_VERSION_aeson(0,10,0)
    toEncoding = absurd
    {-# INLINE toEncoding #-}
#endif

instance FromJSON Void where
    parseJSON _ = fail "Cannot parse Void"
    {-# INLINE parseJSON #-}
#endif
-------------------------------------------------------------------------------
-- with*
-------------------------------------------------------------------------------

-- | @'withNumber' expected f value@ applies @f@ to the 'Number' when @value@
-- is a 'Number' and fails using @'typeMismatch' expected@ otherwise.
withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
withNumber String
expected Number -> Parser a
f = String -> (Scientific -> Parser a) -> Value -> Parser a
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
expected (Number -> Parser a
f (Number -> Parser a)
-> (Scientific -> Number) -> Scientific -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Number
scientificToNumber)
{-# INLINE withNumber #-}
{-# DEPRECATED withNumber "Use withScientific instead" #-}

scientificToNumber :: Scientific.Scientific -> Number
scientificToNumber :: Scientific -> Number
scientificToNumber Scientific
s
    | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1024 = Double -> Number
D (Double -> Number) -> Double -> Number
forall a b. (a -> b) -> a -> b
$ Scientific -> Double
forall a. RealFloat a => Scientific -> a
Scientific.toRealFloat Scientific
s
    | Bool
otherwise         = Integer -> Number
I (Integer -> Number) -> Integer -> Number
forall a b. (a -> b) -> a -> b
$ Integer
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e
  where
    e :: Int
e = Scientific -> Int
Scientific.base10Exponent Scientific
s
    c :: Integer
c = Scientific -> Integer
Scientific.coefficient Scientific
s
{-# INLINE scientificToNumber #-}

#if !MIN_VERSION_aeson(1,2,3)
-- | Decode a nested JSON-encoded string.
withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
withEmbeddedJSON _ innerParser (String txt) =
    either fail innerParser $ eitherDecode (LBS.fromStrict $ TE.encodeUtf8 txt)
withEmbeddedJSON name _ v = typeMismatch name v
{-# INLINE withEmbeddedJSON #-}
#endif