module Rest.Gen.Base.JSON.Pretty where
import Control.Arrow (first)
import Data.Aeson.Types
import Data.Aeson.Utils (parseNumber)
import Data.Char
import Data.HashMap.Strict (HashMap)
import Data.Text (Text, unpack)
import Numeric
import Text.PrettyPrint.HughesPJ hiding (first)
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
pp_value :: Value -> Doc
pp_value v = case v of
Null -> pp_null
Bool x -> pp_boolean x
Number x -> pp_number (parseNumber x)
String x -> pp_js_string (unpack x)
Array vs -> pp_array $ V.toList vs
Object xs -> pp_js_object xs
pp_null :: Doc
pp_null = text "null"
pp_boolean :: Bool -> Doc
pp_boolean True = text "true"
pp_boolean False = text "false"
pp_number :: Either Integer Double -> Doc
pp_number = either integer double
pp_array :: [Value] -> Doc
pp_array xs = vlist "[" "]" $ map pp_value xs
vlist :: String -> String -> [Doc] -> Doc
vlist o c [] = text o <+> text c
vlist o c ls = vcat $ text o <+> head ls : map (comma <+>) (tail ls) ++ [text c]
pp_string :: String -> Doc
pp_string x = doubleQuotes $ hcat $ map pp_char x
where pp_char '\\' = text "\\\\"
pp_char '"' = text "\\\""
pp_char c | isControl c || fromEnum c >= 0x7f = uni_esc c
pp_char c = char c
uni_esc c = text "\\u" <> text (pad 4 (showHex (fromEnum c) ""))
pad n cs | len < n = replicate (nlen) '0' ++ cs
| otherwise = cs
where len = length cs
pp_object :: [(String,Value)] -> Doc
pp_object xs = vlist "{" "}" $ map pp_field xs
where pp_field (k,v) = pp_string k <> colon <+> pp_value v
pp_js_string :: String -> Doc
pp_js_string x = pp_string x
pp_js_object :: HashMap Text Value -> Doc
pp_js_object = pp_object . map (first unpack) . H.toList