utils/Json.hs

    {-# LANGUAGE GADTs #-}
    module Json where

    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 d =
      case d of
        JSNull -> text "null"
        JSBool b -> text $ if b then "true" else "false"
        JSInt    n -> ppr n
        JSString s -> doubleQuotes $ text $ escapeJsonString s
        JSArray as -> brackets $ pprList renderJSON as
        JSObject fs -> braces $ pprList renderField fs
      where
        renderField :: (String, JsonDoc) -> SDoc
        renderField (s, j) = doubleQuotes (text s) <>  colon <+> renderJSON j

        pprList pp xs = hcat (punctuate comma (map pp xs))

    escapeJsonString :: String -> String
    escapeJsonString = concatMap escapeChar
      where
        escapeChar '\b' = "\\b"
        escapeChar '\f' = "\\f"
        escapeChar '\n' = "\\n"
        escapeChar '\r' = "\\r"
        escapeChar '\t' = "\\t"
        escapeChar '"'  = "\\\""
        escapeChar '\\'  = "\\\\"
        escapeChar c | isControl c || fromEnum c >= 0x7f  = uni_esc c
        escapeChar c = [c]

        uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) ""))

        pad n cs  | len < n   = replicate (n-len) '0' ++ cs
                              | otherwise = cs
                                       where len = length cs

    class ToJson a where
      json :: a -> JsonDoc