{-# LANGUAGE OverloadedStrings #-}
module Haddock.Utils.Json
( Value(..)
, Object, object, Pair, (.=)
, encodeToString
, encodeToBuilder
, ToJSON(toJSON)
)
where
import Data.Char
import Data.Int
import Data.String
import Data.Word
import Data.List (intersperse)
import Data.Monoid
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
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
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]
(Int -> ReadS Value)
-> ReadS [Value]
-> ReadPrec Value
-> ReadPrec [Value]
-> Read 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
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
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 .= :: String -> v -> Pair
.= v
v = (String
k, v -> Value
forall a. ToJSON a => a -> Value
toJSON v
v)
object :: [Pair] -> Value
object :: [Pair] -> Value
object = [Pair] -> 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 = Value -> Value
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 ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
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) = a -> Value
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 [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
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 [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b, c -> Value
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 [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b, c -> Value
forall a. ToJSON a => a -> Value
toJSON c
c, d -> Value
forall a. ToJSON a => a -> Value
toJSON d
d]
instance ToJSON Float where
toJSON :: Float -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Float -> Double) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
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 (Double -> Value) -> (Int -> Double) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int8 where toJSON :: Int8 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int8 -> Double) -> Int8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int16 where toJSON :: Int16 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int16 -> Double) -> Int16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int32 where toJSON :: Int32 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int32 -> Double) -> Int32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word where toJSON :: Word -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word -> Double) -> Word -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word8 where toJSON :: Word8 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word8 -> Double) -> Word8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word16 where toJSON :: Word16 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word16 -> Double) -> Word16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word32 where toJSON :: Word32 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word32 -> Double) -> Word32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int64 where toJSON :: Int64 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int64 -> Double) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word64 where toJSON :: Word64 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word64 -> Double) -> Word64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Integer where toJSON :: Integer -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Integer -> Double) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger
encodeToBuilder :: ToJSON a => a -> Builder
encodeToBuilder :: a -> Builder
encodeToBuilder = Value -> Builder
encodeValueBB (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
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
| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
n Bool -> Bool -> Bool
|| Double -> 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 [Pair]
o -> [Pair] -> Builder
encodeObjectBB [Pair]
o
encodeArrayBB :: [Value] -> Builder
encodeArrayBB :: [Value] -> Builder
encodeArrayBB [] = Builder
"[]"
encodeArrayBB [Value]
jvs = Char -> Builder
BB.char8 Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Value] -> Builder
go [Value]
jvs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
']'
where
go :: [Value] -> Builder
go = [Builder] -> Builder
forall a. Monoid a => [a] -> a
Data.Monoid.mconcat ([Builder] -> Builder)
-> ([Value] -> [Builder]) -> [Value] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BB.char8 Char
',') ([Builder] -> [Builder])
-> ([Value] -> [Builder]) -> [Value] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Builder) -> [Value] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Builder
encodeValueBB
encodeObjectBB :: Object -> Builder
encodeObjectBB :: [Pair] -> Builder
encodeObjectBB [] = Builder
"{}"
encodeObjectBB [Pair]
jvs = Char -> Builder
BB.char8 Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Pair] -> Builder
go [Pair]
jvs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
'}'
where
go :: [Pair] -> Builder
go = [Builder] -> Builder
forall a. Monoid a => [a] -> a
Data.Monoid.mconcat ([Builder] -> Builder)
-> ([Pair] -> [Builder]) -> [Pair] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BB.char8 Char
',') ([Builder] -> [Builder])
-> ([Pair] -> [Builder]) -> [Pair] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> Builder) -> [Pair] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> Builder
encPair
encPair :: Pair -> Builder
encPair (String
l,Value
x) = String -> Builder
encodeStringBB String
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
':' Builder -> Builder -> Builder
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
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
go String
str Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BB.char8 Char
'"'
where
go :: String -> Builder
go = String -> Builder
BB.stringUtf8 (String -> Builder) -> ShowS -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeString
encodeToString :: ToJSON a => a -> String
encodeToString :: a -> String
encodeToString a
jv = Value -> ShowS
encodeValue (a -> Value
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
| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
n Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n -> Value -> ShowS
encodeValue Value
Null
| Just Int64
i <- Double -> Maybe Int64
doubleToInt64 Double
n -> Int64 -> ShowS
forall a. Show a => a -> ShowS
shows Int64
i
| Bool
otherwise -> Double -> ShowS
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 [Pair]
o -> [Pair] -> ShowS
encodeObject [Pair]
o
encodeArray :: [Value] -> ShowS
encodeArray :: [Value] -> ShowS
encodeArray [] = String -> ShowS
showString String
"[]"
encodeArray [Value]
jvs = (Char
'['Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> ShowS
go [Value]
jvs ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:)
where
go :: [Value] -> ShowS
go [] = ShowS
forall a. a -> a
id
go [Value
x] = Value -> ShowS
encodeValue Value
x
go (Value
x:[Value]
xs) = Value -> ShowS
encodeValue Value
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
','Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> ShowS
go [Value]
xs
encodeObject :: Object -> ShowS
encodeObject :: [Pair] -> ShowS
encodeObject [] = String -> ShowS
showString String
"{}"
encodeObject [Pair]
jvs = (Char
'{'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> ShowS
go [Pair]
jvs ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'}'Char -> ShowS
forall a. a -> [a] -> [a]
:)
where
go :: [Pair] -> ShowS
go [] = ShowS
forall a. a -> a
id
go [(String
l,Value
x)] = String -> ShowS
encodeString String
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ShowS
encodeValue Value
x
go ((String
l,Value
x):[Pair]
lxs) = String -> ShowS
encodeString String
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ShowS
encodeValue Value
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
','Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> ShowS
go [Pair]
lxs
encodeString :: String -> ShowS
encodeString :: String -> ShowS
encodeString String
str = (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (ShowS
escapeString String
str) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:)
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 Double
x
| Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
x' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x
, Integer
x' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)
, Integer
x' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
minBound :: Int64)
= Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x')
| Bool
otherwise = Maybe Int64
forall a. Maybe a
Nothing
where
x' :: Integer
x' = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x
escapeString :: String -> String
escapeString :: ShowS
escapeString String
s
| Bool -> Bool
not ((Char -> Bool) -> String -> Bool
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
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'"' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\b' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'b'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\f' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'f'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\n' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'n'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\r' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'r'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
'\t' -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
Char
c | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10 -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'u'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> Char
intToDigit (Char -> Int
ord Char
c)Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x20 -> Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'u'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'1'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> Char
intToDigit (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x10)Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
escape String
xs
| Bool
otherwise -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
xs
needsEscape :: Char -> Bool
needsEscape Char
c = Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x20 Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'"']