{-# LANGUAGE OverloadedStrings #-}

-- | Minimal JSON / RFC 7159 support
--
-- The API is heavily inspired by @aeson@'s API but puts emphasis on
-- simplicity rather than performance. The 'ToJSON' instances are
-- intended to have an encoding compatible with @aeson@'s encoding.
--
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

-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'

-- | A JSON value represented as a Haskell value.
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)

-- | A key\/value pair for an 'Object'
type Pair = (String, Value)

-- | A JSON \"object\" (key/value map).
type Object = [Pair]

infixr 8 .=

-- | A key-value pair for encoding a JSON object.
(.=) :: 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)

-- | Create a 'Value' from a list of name\/value 'Pair's.
object :: [Pair] -> Value
object :: Object -> Value
object = Object -> Value
Object

instance IsString Value where
  fromString :: String -> Value
fromString = String -> Value
String


-- | A type that can be converted to JSON.
class ToJSON a where
  -- | Convert a Haskell value to a JSON-friendly intermediate type.
  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

-- | Possibly lossy due to conversion to 'Double'
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

-- | Possibly lossy due to conversion to 'Double'
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

-- | Possibly lossy due to conversion to 'Double'
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

------------------------------------------------------------------------------
-- 'BB.Builder'-based encoding

-- | Serialise value as JSON/UTF8-encoded 'Builder'
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

------------------------------------------------------------------------------
-- 'String'-based encoding

-- | Serialise value as JSON-encoded Unicode 'String'
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]
:)

------------------------------------------------------------------------------
-- helpers

-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
-- representable loss-free as integral 'Int64' value.
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

-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
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

    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
    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
'"']