{-# 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
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
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
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)