{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
module GHC.Utils.Json where
import GHC.Prelude
import GHC.Utils.Outputable
import Data.Char
import Numeric
data JsonDoc where
JSNull :: JsonDoc
JSBool :: Bool -> JsonDoc
JSInt :: Int -> JsonDoc
JSString :: String -> JsonDoc
JSArray :: [JsonDoc] -> JsonDoc
JSObject :: [(String, JsonDoc)] -> JsonDoc
renderJSON :: JsonDoc -> SDoc
renderJSON :: JsonDoc -> SDoc
renderJSON JsonDoc
d =
case JsonDoc
d of
JsonDoc
JSNull -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"null"
JSBool Bool
b -> if Bool
b then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"true" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"false"
JSInt Int
n -> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n
JSString String
s -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> String
escapeJsonString String
s
JSArray [JsonDoc]
as -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (JsonDoc -> SDoc) -> [JsonDoc] -> SDoc
forall {doc} {a}. IsLine doc => (a -> doc) -> [a] -> doc
pprList JsonDoc -> SDoc
renderJSON [JsonDoc]
as
JSObject [(String, JsonDoc)]
fs -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ((String, JsonDoc) -> SDoc) -> [(String, JsonDoc)] -> SDoc
forall {doc} {a}. IsLine doc => (a -> doc) -> [a] -> doc
pprList (String, JsonDoc) -> SDoc
renderField [(String, JsonDoc)]
fs
where
renderField :: (String, JsonDoc) -> SDoc
renderField :: (String, JsonDoc) -> SDoc
renderField (String
s, JsonDoc
j) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
s) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> JsonDoc -> SDoc
renderJSON JsonDoc
j
pprList :: (a -> doc) -> [a] -> doc
pprList a -> doc
pp [a]
xs = [doc] -> doc
forall doc. IsLine doc => [doc] -> doc
hcat (doc -> [doc] -> [doc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate doc
forall doc. IsLine doc => doc
comma ((a -> doc) -> [a] -> [doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> doc
pp [a]
xs))
escapeJsonString :: String -> String
escapeJsonString :: String -> String
escapeJsonString = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
where
escapeChar :: Char -> String
escapeChar Char
'\b' = String
"\\b"
escapeChar Char
'\f' = String
"\\f"
escapeChar Char
'\n' = String
"\\n"
escapeChar Char
'\r' = String
"\\r"
escapeChar Char
'\t' = String
"\\t"
escapeChar Char
'"' = String
"\\\""
escapeChar Char
'\\' = String
"\\\\"
escapeChar Char
c | Char -> Bool
isControl Char
c Bool -> Bool -> Bool
|| Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x7f = Char -> String
forall {a}. Enum a => a -> String
uni_esc Char
c
escapeChar Char
c = [Char
c]
uni_esc :: a -> String
uni_esc a
c = String
"\\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
pad Int
4 (Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (a -> Int
forall a. Enum a => a -> Int
fromEnum a
c) String
""))
pad :: Int -> String -> String
pad Int
n String
cs | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs
| Bool
otherwise = String
cs
where len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs
class ToJson a where
json :: a -> JsonDoc
instance ToJson String where
json :: String -> JsonDoc
json = String -> JsonDoc
JSString
instance ToJson Int where
json :: Int -> JsonDoc
json = Int -> JsonDoc
JSInt