{-# 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           Data.Scientific                     as Scientific
import qualified Data.Text                           as T
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 :: Bool -> Decoder s Value
decodeValue Bool
lenient = do
    TokenType
tkty <- Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType
    case TokenType
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 (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 (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 (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 (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
_           -> String -> Decoder s Value
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

decodeNumberIntegral :: Decoder s Value
decodeNumberIntegral :: 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 :: 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 :: Decoder s Value
decodeNumberFloat16 = do
    Float
f <- Decoder s Float
forall s. Decoder s Float
decodeFloat
    if Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
f
        then Value -> Decoder s Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        else Value -> Decoder s Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Decoder s Value) -> Value -> Decoder s Value
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number (Float -> Scientific
forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits Float
f)

decodeListN :: Bool -> Int -> Decoder s Value
decodeListN :: Bool -> Int -> Decoder s Value
decodeListN !Bool
lenient !Int
n = do
  Array
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) 
  Value -> Decoder s Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Decoder s Value) -> Value -> Decoder s Value
forall a b. (a -> b) -> a -> b
$! Array -> Value
Array Array
vec

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

decodeMapN :: Bool -> Int -> Aeson.Object -> Decoder s Value
decodeMapN :: Bool -> Int -> Object -> Decoder s Value
decodeMapN !Bool
lenient !Int
n Object
acc =
    case Int
n of
      Int
0 -> Value -> Decoder s Value
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
        !Text
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 (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 (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 (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 (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not decode map key type"
        !Value
tv  <- Bool -> Decoder s Value
forall s. Bool -> Decoder s Value
decodeValue Bool
lenient
        Bool -> Int -> Object -> Decoder s Value
forall s. Bool -> Int -> Object -> Decoder s Value
decodeMapN Bool
lenient (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Text -> Value -> Object -> Object
forall v. Text -> v -> KeyMap v -> KeyMap v
insert Text
tk Value
tv Object
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