{-# LANGUAGE BangPatterns #-}

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.HashMap.Lazy                   as HM
import           Data.Scientific                     as Scientific
import qualified Data.Text                           as T
import qualified Data.Vector                         as V

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

encodeObject :: Aeson.Object -> Encoding
encodeObject :: Object -> Encoding
encodeObject vs :: Object
vs =
    Word -> Encoding
encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Object -> Int
forall k v. HashMap k v -> Int
HM.size Object
vs))
 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Text -> Value -> Encoding -> Encoding)
-> Encoding -> Object -> Encoding
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey (\k :: Text
k v :: Value
v r :: Encoding
r -> Text -> Encoding
encodeString Text
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

encodeArray :: Aeson.Array -> Encoding
encodeArray :: Array -> Encoding
encodeArray vs :: 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 (\v :: Value
v r :: 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 lenient :: Bool
lenient = do
    TokenType
tkty <- Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType
    case TokenType
tkty of
      TypeUInt    -> Decoder s Value
forall s. Decoder s Value
decodeNumberIntegral
      TypeUInt64  -> Decoder s Value
forall s. Decoder s Value
decodeNumberIntegral
      TypeNInt    -> Decoder s Value
forall s. Decoder s Value
decodeNumberIntegral
      TypeNInt64  -> Decoder s Value
forall s. Decoder s Value
decodeNumberIntegral
      TypeInteger -> Decoder s Value
forall s. Decoder s Value
decodeNumberIntegral
      TypeFloat16 -> Decoder s Value
forall s. Decoder s Value
decodeNumberFloat16
      TypeFloat32 -> Decoder s Value
forall s. Decoder s Value
decodeNumberFloating
      TypeFloat64 -> Decoder s Value
forall s. Decoder s Value
decodeNumberFloating
      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
      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
      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

      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
      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 []
      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 k v. HashMap k v
HM.empty

      _           -> 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
$ "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 acc :: [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 acc :: Object
acc =
    case Int
n of
      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
      _ -> 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
>>= \v :: Value
v -> case Value
v of
                 String s :: 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 d :: 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   b :: 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)
                 _        -> String -> Decoder s Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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
-1) (Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
tk Value
tv Object
acc)