{-# 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 d :: JsonDoc
d =
  case JsonDoc
d of
    JSNull -> String -> SDoc
text "null"
    JSBool b :: Bool
b -> String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
b then "true" else "false"
    JSInt    n :: Int
n -> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n
    JSString s :: 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 as :: [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 fs :: [(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 (s :: String
s, j :: 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 pp :: a -> SDoc
pp xs :: [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 '\b' = "\\b"
    escapeChar '\f' = "\\f"
    escapeChar '\n' = "\\n"
    escapeChar '\r' = "\\r"
    escapeChar '\t' = "\\t"
    escapeChar '"'  = "\\\""
    escapeChar '\\'  = "\\\\"
    escapeChar c :: 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
>= 0x7f  = Char -> String
forall a. Enum a => a -> String
uni_esc Char
c
    escapeChar c :: Char
c = [Char
c]

    uni_esc :: a -> String
uni_esc c :: a
c = "\\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
pad 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) ""))

    pad :: Int -> String -> String
pad n :: Int
n cs :: 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) '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