{-# LANGUAGE OverloadedStrings #-}
module Distribution.Client.Utils.Json
( Value(..)
, Object, object, Pair, (.=)
, encodeToString
, encodeToBuilder
, ToJSON(toJSON)
)
where
import Distribution.Client.Compat.Prelude
import Data.Char (intToDigit)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
data Value = Object !Object
| Array [Value]
| String String
| Number !Double
| Bool !Bool
| Null
deriving (Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, ReadPrec [Value]
ReadPrec Value
Int -> ReadS Value
ReadS [Value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Value]
$creadListPrec :: ReadPrec [Value]
readPrec :: ReadPrec Value
$creadPrec :: ReadPrec Value
readList :: ReadS [Value]
$creadList :: ReadS [Value]
readsPrec :: Int -> ReadS Value
$creadsPrec :: Int -> ReadS Value
Read, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)
type Pair = (String, Value)
type Object = [Pair]
infixr 8 .=
(.=) :: ToJSON v => String -> v -> Pair
String
k .= :: forall v. ToJSON v => String -> v -> (String, Value)
.= v
v = (String
k, forall a. ToJSON a => a -> Value
toJSON v
v)
object :: [Pair] -> Value
object :: Object -> Value
object = Object -> Value
Object
instance IsString Value where
fromString :: String -> Value
fromString = String -> Value
String
class ToJSON a where
toJSON :: a -> Value
instance ToJSON () where
toJSON :: () -> Value
toJSON () = [Value] -> Value
Array []
instance ToJSON Value where
toJSON :: Value -> Value
toJSON = forall a. a -> a
id
instance ToJSON Bool where
toJSON :: Bool -> Value
toJSON = Bool -> Value
Bool
instance ToJSON a => ToJSON [a] where
toJSON :: [a] -> Value
toJSON = [Value] -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
toJSON
instance ToJSON a => ToJSON (Maybe a) where
toJSON :: Maybe a -> Value
toJSON Maybe a
Nothing = Value
Null
toJSON (Just a
a) = forall a. ToJSON a => a -> Value
toJSON a
a
instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
toJSON :: (a, b) -> Value
toJSON (a
a,b
b) = [Value] -> Value
Array [forall a. ToJSON a => a -> Value
toJSON a
a, forall a. ToJSON a => a -> Value
toJSON b
b]
instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
toJSON :: (a, b, c) -> Value
toJSON (a
a,b
b,c
c) = [Value] -> Value
Array [forall a. ToJSON a => a -> Value
toJSON a
a, forall a. ToJSON a => a -> Value
toJSON b
b, forall a. ToJSON a => a -> Value
toJSON c
c]
instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
toJSON :: (a, b, c, d) -> Value
toJSON (a
a,b
b,c
c,d
d) = [Value] -> Value
Array [forall a. ToJSON a => a -> Value
toJSON a
a, forall a. ToJSON a => a -> Value
toJSON b
b, forall a. ToJSON a => a -> Value
toJSON c
c, forall a. ToJSON a => a -> Value
toJSON d
d]
instance ToJSON Float where
toJSON :: Float -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Double where
toJSON :: Double -> Value
toJSON = Double -> Value
Number
instance ToJSON Int where toJSON :: Int -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int8 where toJSON :: Int8 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int16 where toJSON :: Int16 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int32 where toJSON :: Int32 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word where toJSON :: Word -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word8 where toJSON :: Word8 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word16 where toJSON :: Word16 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word32 where toJSON :: Word32 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int64 where toJSON :: Int64 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word64 where toJSON :: Word64 -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Integer where toJSON :: Integer -> Value
toJSON = Double -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
encodeToBuilder :: ToJSON a => a -> Builder
encodeToBuilder :: forall a. ToJSON a => a -> Builder
encodeToBuilder = Value -> Builder
encodeValueBB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON
encodeValueBB :: Value -> Builder
encodeValueBB :: Value -> Builder
encodeValueBB Value
jv = case Value
jv of
Bool Bool
True -> Builder
"true"
Bool Bool
False -> Builder
"false"
Value
Null -> Builder
"null"
Number Double
n
| forall a. RealFloat a => a -> Bool
isNaN Double
n Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isInfinite Double
n -> Value -> Builder
encodeValueBB Value
Null
| Just Int64
i <- Double -> Maybe Int64
doubleToInt64 Double
n -> Int64 -> Builder
BB.int64Dec Int64
i
| Bool
otherwise -> Double -> Builder
BB.doubleDec Double
n
Array [Value]
a -> [Value] -> Builder
encodeArrayBB [Value]
a
String String
s -> String -> Builder
encodeStringBB String
s
Object Object
o -> Object -> Builder
encodeObjectBB Object
o
encodeArrayBB :: [Value] -> Builder
encodeArrayBB :: [Value] -> Builder
encodeArrayBB [] = Builder
"[]"
encodeArrayBB [Value]
jvs = Char -> Builder
BB.char8 Char
'[' forall a. Semigroup a => a -> a -> a
<> [Value] -> Builder
go [Value]
jvs forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
']'
where
go :: [Value] -> Builder
go = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BB.char8 Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Value -> Builder
encodeValueBB
encodeObjectBB :: Object -> Builder
encodeObjectBB :: Object -> Builder
encodeObjectBB [] = Builder
"{}"
encodeObjectBB Object
jvs = Char -> Builder
BB.char8 Char
'{' forall a. Semigroup a => a -> a -> a
<> Object -> Builder
go Object
jvs forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
'}'
where
go :: Object -> Builder
go = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BB.char8 Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String, Value) -> Builder
encPair
encPair :: (String, Value) -> Builder
encPair (String
l,Value
x) = String -> Builder
encodeStringBB String
l forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
':' forall a. Semigroup a => a -> a -> a
<> Value -> Builder
encodeValueBB Value
x
encodeStringBB :: String -> Builder
encodeStringBB :: String -> Builder
encodeStringBB String
str = Char -> Builder
BB.char8 Char
'"' forall a. Semigroup a => a -> a -> a
<> String -> Builder
go String
str forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
'"'
where
go :: String -> Builder
go = String -> Builder
BB.stringUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeString
encodeToString :: ToJSON a => a -> String
encodeToString :: forall a. ToJSON a => a -> String
encodeToString a
jv = Value -> ShowS
encodeValue (forall a. ToJSON a => a -> Value
toJSON a
jv) []
encodeValue :: Value -> ShowS
encodeValue :: Value -> ShowS
encodeValue Value
jv = case Value
jv of
Bool Bool
b -> String -> ShowS
showString (if Bool
b then String
"true" else String
"false")
Value
Null -> String -> ShowS
showString String
"null"
Number Double
n
| forall a. RealFloat a => a -> Bool
isNaN Double
n Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isInfinite Double
n -> Value -> ShowS
encodeValue Value
Null
| Just Int64
i <- Double -> Maybe Int64
doubleToInt64 Double
n -> forall a. Show a => a -> ShowS
shows Int64
i
| Bool
otherwise -> forall a. Show a => a -> ShowS
shows Double
n
Array [Value]
a -> [Value] -> ShowS
encodeArray [Value]
a
String String
s -> String -> ShowS
encodeString String
s
Object Object
o -> Object -> ShowS
encodeObject Object
o
encodeArray :: [Value] -> ShowS
encodeArray :: [Value] -> ShowS
encodeArray [] = String -> ShowS
showString String
"[]"
encodeArray [Value]
jvs = (Char
'['forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> ShowS
go [Value]
jvs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'forall a. a -> [a] -> [a]
:)
where
go :: [Value] -> ShowS
go [] = forall a. a -> a
id
go [Value
x] = Value -> ShowS
encodeValue Value
x
go (Value
x:[Value]
xs) = Value -> ShowS
encodeValue Value
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
','forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> ShowS
go [Value]
xs
encodeObject :: Object -> ShowS
encodeObject :: Object -> ShowS
encodeObject [] = String -> ShowS
showString String
"{}"
encodeObject Object
jvs = (Char
'{'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> ShowS
go Object
jvs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'}'forall a. a -> [a] -> [a]
:)
where
go :: Object -> ShowS
go [] = forall a. a -> a
id
go [(String
l,Value
x)] = String -> ShowS
encodeString String
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ShowS
encodeValue Value
x
go ((String
l,Value
x):Object
lxs) = String -> ShowS
encodeString String
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ShowS
encodeValue Value
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
','forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> ShowS
go Object
lxs
encodeString :: String -> ShowS
encodeString :: String -> ShowS
encodeString String
str = (Char
'"'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (ShowS
escapeString String
str) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'"'forall a. a -> [a] -> [a]
:)
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 Double
x
| forall a. Num a => Integer -> a
fromInteger Integer
x' forall a. Eq a => a -> a -> Bool
== Double
x
, Integer
x' forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int64)
, Integer
x' forall a. Ord a => a -> a -> Bool
>= forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound :: Int64)
= forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x')
| Bool
otherwise = forall a. Maybe a
Nothing
where
x' :: Integer
x' = forall a b. (RealFrac a, Integral b) => a -> b
round Double
x
escapeString :: String -> String
escapeString :: ShowS
escapeString String
s
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
needsEscape String
s) = String
s
| Bool
otherwise = ShowS
escape String
s
where
escape :: ShowS
escape [] = []
escape (Char
x:String
xs) = case Char
x of
Char
'\\' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'\\'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'"' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'"'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\b' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'b'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\f' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'f'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\n' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'n'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\r' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'r'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\t' -> Char
'\\'forall a. a -> [a] -> [a]
:Char
't'forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
c | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x10 -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'u'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Int -> Char
intToDigit (Char -> Int
ord Char
c)forall a. a -> [a] -> [a]
:ShowS
escape String
xs
| Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x20 -> Char
'\\'forall a. a -> [a] -> [a]
:Char
'u'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'1'forall a. a -> [a] -> [a]
:Int -> Char
intToDigit (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
0x10)forall a. a -> [a] -> [a]
:ShowS
escape String
xs
| Bool
otherwise -> Char
c forall a. a -> [a] -> [a]
: ShowS
escape String
xs
needsEscape :: Char -> Bool
needsEscape Char
c = Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x20 Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'"']