{-# LANGUAGE GADTs #-}
module Json where

import GhcPrelude

import Outputable
import Data.Char
import Numeric

-- | Simple data type to represent JSON documents.
data JsonDoc where
  JSNull :: JsonDoc
  JSBool :: Bool -> JsonDoc
  JSInt  :: Int  -> JsonDoc
  JSString :: String -> JsonDoc
  JSArray :: [JsonDoc] -> JsonDoc
  JSObject :: [(String, JsonDoc)] -> JsonDoc


-- This is simple and slow as it is only used for error reporting
renderJSON :: JsonDoc -> SDoc
renderJSON :: JsonDoc -> SDoc
renderJSON JsonDoc
d =
  case JsonDoc
d of
    JsonDoc
JSNull -> String -> SDoc
text String
"null"
    JSBool Bool
b -> String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"true" else String
"false"
    JSInt    Int
n -> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n
    JSString String
s -> SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> String
escapeJsonString String
s
    JSArray [JsonDoc]
as -> SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (JsonDoc -> SDoc) -> [JsonDoc] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprList JsonDoc -> SDoc
renderJSON [JsonDoc]
as
    JSObject [(String, JsonDoc)]
fs -> SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ((String, JsonDoc) -> SDoc) -> [(String, JsonDoc)] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprList (String, JsonDoc) -> SDoc
renderField [(String, JsonDoc)]
fs
  where
    renderField :: (String, JsonDoc) -> SDoc
    renderField :: (String, JsonDoc) -> SDoc
renderField (String
s, JsonDoc
j) = SDoc -> SDoc
doubleQuotes (String -> SDoc
text String
s) SDoc -> SDoc -> SDoc
<>  SDoc
colon SDoc -> SDoc -> SDoc
<+> JsonDoc -> SDoc
renderJSON JsonDoc
j

    pprList :: (a -> SDoc) -> [a] -> SDoc
pprList a -> SDoc
pp [a]
xs = [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
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, Show 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 (t :: * -> *) a. Foldable t => t a -> Int
length String
cs

class ToJson a where
  json :: a -> JsonDoc