1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
-- | Display JSON values using pretty printing combinators.
module Text.JSON.Pretty
( module Text.JSON.Pretty
, module Text.PrettyPrint.HughesPJ
) where
import Text.JSON.Types
import Text.PrettyPrint.HughesPJ
import qualified Text.PrettyPrint.HughesPJ as PP
import Data.Ratio
import Data.Char
import Numeric
pp_value :: JSValue -> Doc
pp_value v = case v of
JSNull -> pp_null
JSBool x -> pp_boolean x
JSRational asf x -> pp_number asf x
JSString x -> pp_js_string x
JSArray vs -> pp_array vs
JSObject 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 :: Bool -> Rational -> Doc
pp_number _ x | denominator x == 1 = integer (numerator x)
pp_number True x = float (fromRational x)
pp_number _ x = double (fromRational x)
pp_array :: [JSValue] -> Doc
pp_array xs = brackets $ fsep $ punctuate comma $ map pp_value xs
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 = uni_esc c
pp_char c = char c
uni_esc c = text "\\u" PP.<> text (pad 4 (showHex (fromEnum c) ""))
pad n cs | len < n = replicate (n-len) '0' ++ cs
| otherwise = cs
where len = length cs
pp_object :: [(String,JSValue)] -> Doc
pp_object xs = braces $ fsep $ punctuate comma $ map pp_field xs
where pp_field (k,v) = pp_string k PP.<> colon <+> pp_value v
pp_js_string :: JSString -> Doc
pp_js_string x = pp_string (fromJSString x)
pp_js_object :: JSObject JSValue -> Doc
pp_js_object x = pp_object (fromJSObject x)
|
