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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
{-- snippet module --}
module PrettyJSON
(
renderJValue
) where
import Numeric (showHex)
import Data.Char (ord)
import Data.Bits (shiftR, (.&.))
import SimpleJSON (JValue(..))
import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text,
compact, pretty)
{-- /snippet module --}
{-- snippet renderJValue --}
renderJValue :: JValue -> Doc
renderJValue (JBool True) = text "true"
renderJValue (JBool False) = text "false"
renderJValue JNull = text "null"
renderJValue (JNumber num) = double num
renderJValue (JString str) = string str
{-- /snippet renderJValue --}
{-- snippet renderJValue.array --}
renderJValue (JArray ary) = series '[' ']' renderJValue ary
{-- /snippet renderJValue.array --}
{-- snippet renderJValue.object --}
renderJValue (JObject obj) = series '{' '}' field obj
where field (name,val) = string name
<> text ": "
<> renderJValue val
{-- /snippet renderJValue.object --}
{-- snippet enclose --}
enclose :: Char -> Char -> Doc -> Doc
enclose left right x = char left <> x <> char right
{-- /snippet enclose --}
{-- snippet hexEscape --}
hexEscape :: Char -> Doc
hexEscape c | d < 0x10000 = smallHex d
| otherwise = astral (d - 0x10000)
where d = ord c
{-- /snippet hexEscape --}
{-- snippet smallHex --}
smallHex :: Int -> Doc
smallHex x = text "\\u"
<> text (replicate (4 - length h) '0')
<> text h
where h = showHex x ""
{-- /snippet smallHex --}
{-- snippet astral --}
astral :: Int -> Doc
astral n = smallHex (a + 0xd800) <> smallHex (b + 0xdc00)
where a = (n `shiftR` 10) .&. 0x3ff
b = n .&. 0x3ff
{-- /snippet astral --}
{-- snippet string --}
string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar
{-- /snippet string --}
{-- snippet pointyString --}
pointyString :: String -> Doc
pointyString s = enclose '"' '"' (hcat (map oneChar s))
{-- /snippet pointyString --}
{-- snippet oneChar --}
oneChar :: Char -> Doc
oneChar c = case lookup c simpleEscapes of
Just r -> text r
Nothing | mustEscape c -> hexEscape c
| otherwise -> char c
where mustEscape c = c < ' ' || c == '\x7f' || c > '\xff'
simpleEscapes :: [(Char, String)]
simpleEscapes = zipWith ch "\b\n\f\r\t\\\"/" "bnfrt\\\"/"
where ch a b = (a, ['\\',b])
{-- /snippet oneChar --}
{-- snippet series --}
series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close item = enclose open close
. fsep . punctuate (char ',') . map item
{-- /snippet series --}
|
