    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP          #-}

    module Codec.CBOR.JSON
     ( encodeValue
     , decodeValue
     ) where

    import           Data.Monoid
    import           Control.Applicative
    import           Prelude hiding (decodeFloat)

    import           Codec.CBOR.Encoding
    import           Codec.CBOR.Decoding
    import           Data.Aeson                          ( Value(..) )
    import qualified Data.Aeson                          as Aeson
    import qualified Data.ByteString.Base64.URL          as Base64url
    import           Data.Scientific                     as Scientific
    import qualified Data.Text                           as T
    import qualified Data.Text.Encoding                  as TE
    import qualified Data.Vector                         as V

    #if MIN_VERSION_aeson(2,0,0)
    import qualified Data.Aeson.Key                      as K
    import qualified Data.Aeson.KeyMap                   as KM
    #else
    import qualified Data.HashMap.Lazy                   as HM
    #endif

    -- | Encode a JSON value into CBOR.
    encodeValue :: Value -> Encoding
    encodeValue :: Value -> Encoding
    encodeValue (Object Object
    vs) = Object -> Encoding
    encodeObject Object
    vs
    encodeValue (Array  Array
    vs) = Array -> Encoding
    encodeArray  Array
    vs
    encodeValue (String Text
    s)  = Text -> Encoding
    encodeString Text
    s
    encodeValue (Number Scientific
    n)  = case Scientific -> Either Double Integer
    forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
    Scientific.floatingOrInteger Scientific
    n of
                                Left  Double
    d -> Double -> Encoding
    encodeDouble  Double
    d
                                Right Integer
    i -> Integer -> Encoding
    encodeInteger Integer
    i
    encodeValue (Bool   Bool
    b)  = Bool -> Encoding
    encodeBool Bool
    b
    encodeValue  Value
    Null       = Encoding
    encodeNull

    encodeObject :: Aeson.Object -> Encoding
    encodeObject :: Object -> Encoding
    encodeObject Object
    vs =
         Word -> Encoding
    encodeMapLen (Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    size)
      Encoding -> Encoding -> Encoding
    forall a. Semigroup a => a -> a -> a
    <> (Key -> Value -> Encoding -> Encoding)
    -> Encoding -> Object -> Encoding
    forall {v} {a}. (Key -> v -> a -> a) -> a -> KeyMap v -> a
    foldrWithKey (\Key
    k Value
    v Encoding
    r -> Key -> Encoding
    encodeString' Key
    k Encoding -> Encoding -> Encoding
    forall a. Semigroup a => a -> a -> a
    <> Value -> Encoding
    encodeValue Value
    v Encoding -> Encoding -> Encoding
    forall a. Semigroup a => a -> a -> a
    <> Encoding
    r) Encoding
    forall a. Monoid a => a
    mempty Object
    vs
      where
    #if MIN_VERSION_aeson(2,0,0)
        size :: Int
    size = Object -> Int
    forall v. KeyMap v -> Int
    KM.size Object
    vs
        foldrWithKey :: (Key -> v -> a -> a) -> a -> KeyMap v -> a
    foldrWithKey = (Key -> v -> a -> a) -> a -> KeyMap v -> a
    forall {v} {a}. (Key -> v -> a -> a) -> a -> KeyMap v -> a
    KM.foldrWithKey
        encodeString' :: Key -> Encoding
    encodeString' = Text -> Encoding
    encodeString (Text -> Encoding) -> (Key -> Text) -> Key -> Encoding
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key -> Text
    K.toText
    #else
        size = HM.size vs
        foldrWithKey = HM.foldrWithKey
        encodeString' = encodeString
    #endif

    encodeArray :: Aeson.Array -> Encoding
    encodeArray :: Array -> Encoding
    encodeArray Array
    vs =
        Word -> Encoding
    encodeListLen (Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Array -> Int
    forall a. Vector a -> Int
    V.length Array
    vs))
     Encoding -> Encoding -> Encoding
    forall a. Semigroup a => a -> a -> a
    <> (Value -> Encoding -> Encoding) -> Encoding -> Array -> Encoding
    forall a b. (a -> b -> b) -> b -> Vector a -> b
    V.foldr (\Value
    v Encoding
    r -> Value -> Encoding
    encodeValue Value
    v Encoding -> Encoding -> Encoding
    forall a. Semigroup a => a -> a -> a
    <> Encoding
    r) Encoding
    forall a. Monoid a => a
    mempty Array
    vs

    -- | Decode an arbitrary CBOR value into JSON.
    decodeValue :: Bool -> Decoder s Value
    decodeValue :: forall s. Bool -> Decoder s Value
    decodeValue Bool
    lenient = do
        tkty <- Decoder s TokenType
    forall s. Decoder s TokenType
    peekTokenType
        case tkty of
          TokenType
    TypeUInt    -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberIntegral
          TokenType
    TypeUInt64  -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberIntegral
          TokenType
    TypeNInt    -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberIntegral
          TokenType
    TypeNInt64  -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberIntegral
          TokenType
    TypeInteger -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberIntegral
          TokenType
    TypeFloat16 -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberFloat16
          TokenType
    TypeFloat32 -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberFloating
          TokenType
    TypeFloat64 -> Decoder s Value
    forall s. Decoder s Value
    decodeNumberFloating
          TokenType
    TypeBool    -> Bool -> Value
    Bool   (Bool -> Value) -> Decoder s Bool -> Decoder s Value
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Decoder s Bool
    forall s. Decoder s Bool
    decodeBool
          TokenType
    TypeNull    -> Value
    Null   Value -> Decoder s () -> Decoder s Value
    forall a b. a -> Decoder s b -> Decoder s a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$  Decoder s ()
    forall s. Decoder s ()
    decodeNull
          TokenType
    TypeString  -> Text -> Value
    String (Text -> Value) -> Decoder s Text -> Decoder s Value
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Decoder s Text
    forall s. Decoder s Text
    decodeString

          TokenType
    TypeListLen      -> Decoder s Int
    forall s. Decoder s Int
    decodeListLen Decoder s Int -> (Int -> Decoder s Value) -> Decoder s Value
    forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Bool -> Int -> Decoder s Value
    forall s. Bool -> Int -> Decoder s Value
    decodeListN Bool
    lenient
          TokenType
    TypeListLenIndef -> Decoder s ()
    forall s. Decoder s ()
    decodeListLenIndef Decoder s () -> Decoder s Value -> Decoder s Value
    forall a b. Decoder s a -> Decoder s b -> Decoder s b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> [Value] -> Decoder s Value
    forall s. Bool -> [Value] -> Decoder s Value
    decodeListIndef Bool
    lenient []
          TokenType
    TypeMapLen       -> Decoder s Int
    forall s. Decoder s Int
    decodeMapLen Decoder s Int -> (Int -> Decoder s Value) -> Decoder s Value
    forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Int -> Object -> Decoder s Value)
    -> Object -> Int -> Decoder s Value
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Bool -> Int -> Object -> Decoder s Value
    forall s. Bool -> Int -> Object -> Decoder s Value
    decodeMapN Bool
    lenient) Object
    forall a. Monoid a => a
    mempty

          TokenType
    TypeBytes   -> ByteString -> Value
    bytesToBase64Text (ByteString -> Value) -> Decoder s ByteString -> Decoder s Value
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Decoder s ByteString
    forall s. Decoder s ByteString
    decodeBytes

          TokenType
    _           -> String -> Decoder s Value
    forall a. String -> Decoder s a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Decoder s Value) -> String -> Decoder s Value
    forall a b. (a -> b) -> a -> b
    $ String
    "unexpected CBOR token type for a JSON value: "
                             String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ TokenType -> String
    forall a. Show a => a -> String
    show TokenType
    tkty
        where
          bytesToBase64Text :: ByteString -> Value
    bytesToBase64Text = Text -> Value
    String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Text
    TE.decodeLatin1 (ByteString -> Text)
    -> (ByteString -> ByteString) -> ByteString -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString
    Base64url.encode

    decodeNumberIntegral :: Decoder s Value
    decodeNumberIntegral :: forall s. Decoder s Value
    decodeNumberIntegral = Scientific -> Value
    Number (Scientific -> Value)
    -> (Integer -> Scientific) -> Integer -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> Scientific
    forall a. Num a => Integer -> a
    fromInteger (Integer -> Value) -> Decoder s Integer -> Decoder s Value
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Decoder s Integer
    forall s. Decoder s Integer
    decodeInteger

    decodeNumberFloating :: Decoder s Value
    decodeNumberFloating :: forall s. Decoder s Value
    decodeNumberFloating = Scientific -> Value
    Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Double -> Scientific
    forall a. RealFloat a => a -> Scientific
    Scientific.fromFloatDigits (Double -> Value) -> Decoder s Double -> Decoder s Value
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Decoder s Double
    forall s. Decoder s Double
    decodeDouble

    decodeNumberFloat16 :: Decoder s Value
    decodeNumberFloat16 :: forall s. Decoder s Value
    decodeNumberFloat16 = do
        f <- Decoder s Float
    forall s. Decoder s Float
    decodeFloat
        if isNaN f || isInfinite f
            then return Null
            else return $ Number (Scientific.fromFloatDigits f)

    decodeListN :: Bool -> Int -> Decoder s Value
    decodeListN :: forall s. Bool -> Int -> Decoder s Value
    decodeListN !Bool
    lenient !Int
    n = do
      vec <- Int -> Decoder s Value -> Decoder s Array
    forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
    V.replicateM Int
    n (Bool -> Decoder s Value
    forall s. Bool -> Decoder s Value
    decodeValue Bool
    lenient)
      return $! Array vec

    decodeListIndef :: Bool -> [Value] -> Decoder s Value
    decodeListIndef :: forall s. Bool -> [Value] -> Decoder s Value
    decodeListIndef !Bool
    lenient [Value]
    acc = do
        stop <- Decoder s Bool
    forall s. Decoder s Bool
    decodeBreakOr
        if stop then return $! Array (V.fromList (reverse acc))
                else do !tm <- decodeValue lenient
                        decodeListIndef lenient (tm : acc)

    decodeMapN :: Bool -> Int -> Aeson.Object -> Decoder s Value
    decodeMapN :: forall s. Bool -> Int -> Object -> Decoder s Value
    decodeMapN !Bool
    lenient !Int
    n Object
    acc =
        case Int
    n of
          Int
    0 -> Value -> Decoder s Value
    forall a. a -> Decoder s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Value -> Decoder s Value) -> Value -> Decoder s Value
    forall a b. (a -> b) -> a -> b
    $! Object -> Value
    Object Object
    acc
          Int
    _ -> do
            !tk <- Bool -> Decoder s Value
    forall s. Bool -> Decoder s Value
    decodeValue Bool
    lenient Decoder s Value -> (Value -> Decoder s Text) -> Decoder s Text
    forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Value
    v -> case Value
    v of
                     String Text
    s           -> Text -> Decoder s Text
    forall a. a -> Decoder s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    s
                     -- These cases are only allowed when --lenient is passed,
                     -- as printing them as strings may result in key collisions.
                     Number Scientific
    d | Bool
    lenient -> Text -> Decoder s Text
    forall a. a -> Decoder s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Text -> Decoder s Text) -> Text -> Decoder s Text
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (Scientific -> String
    forall a. Show a => a -> String
    show Scientific
    d)
                     Bool   Bool
    b | Bool
    lenient -> Text -> Decoder s Text
    forall a. a -> Decoder s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Text -> Decoder s Text) -> Text -> Decoder s Text
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (Bool -> String
    forall a. Show a => a -> String
    show Bool
    b)
                     Value
    _        -> String -> Decoder s Text
    forall a. String -> Decoder s a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Could not decode map key type"
            !tv  <- decodeValue lenient
            decodeMapN lenient (n-1) (insert tk tv acc)
      where
    #if MIN_VERSION_aeson(2,0,0)
        insert :: Text -> v -> KeyMap v -> KeyMap v
    insert Text
    k v
    v KeyMap v
    m = Key -> v -> KeyMap v -> KeyMap v
    forall v. Key -> v -> KeyMap v -> KeyMap v
    KM.insert (Text -> Key
    K.fromText Text
    k) v
    v KeyMap v
    m
    #else
        insert k v m = HM.insert k v m
    #endif