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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

--- Provides a datatype representing data in JavaScript Object Notation
--- as well as traversal, read and show functions for that datatype.
---
--- See http://www.crockford.com/JSON/ for further information.
---
--- @author Sebastian Fischer
module Json ( Json(..), trJson, readJson, showJson ) where

import Char
import Parse
import ReadShowTerm

data Json
  = Object [(String, Json)]
  | Array [Json]
  | String String
  | Int Int
  | Bool Bool
  | Null

--- Universal transformation for JSON values.
trJson :: ([(String, a)] -> a)
       -> ([a] -> a)
       -> (String -> a)
       -> (Int -> a)
       -> (Bool -> a)
       -> a
       -> Json
       -> a

trJson object array string int bool null (Object ms)
  = object (map member ms)
 where
  member (key, value)
    = (key, (trJson object array string int bool null) value)

trJson object array string int bool null (Array vs)
  = array (map (trJson object array string int bool null) vs)

trJson _ _ string _ _ _ (String s) = string s
trJson _ _ _ int _ _ (Int n) = int n
trJson _ _ _ _ bool _ (Bool b) = bool b
trJson _ _ _ _ _ null Null = null

--- Transforms a JSON value into its String representation.
showJson :: Json -> String
showJson json = trJson object array string int bool null json []
 where
  list = foldr1 (\x xs -> x . (","++) . xs)

  object [] = ("{}"++)
  object (m:ms) = ("{"++) . list (map member (m:ms)) . ("}"++)
  member (key, value) = (show key++) . (":"++) . value

  array [] = ("[]"++)
  array (v:vs) = ("["++) . list (v:vs) . ("]"++)

  string s = (show s++)
  int n = (show n++)
  bool b = (map toLower (show b)++)
  null = ("null"++)

--- Parses a JSON value from its string representation.
readJson :: String -> Json
readJson s | null sols = failed
           | otherwise = head sols
 where
  sols = map fst (filter (null . snd) (jsonP s))

spaceP :: Parser Char String
spaceP s = [span isSpace s]

listP :: Parser Char a -> Parser Char [a]
listP p s
  = case (p <.> spaceP) s of
      [] -> [([],s)]
      [(v,',':s1)] -> update (v:) (spaceP <:> listP p) s1
      [(v,s1)] -> [([v],s1)]
      xs -> error (show xs)

stringP :: Parser Char String
stringP = readsQTerm

jsonP :: Parser Char Json
jsonP = spaceP <:> (valueP <.> spaceP)

valueP :: Parser Char Json
valueP s = case s of
  '{':cs -> update Object (listP memberP <.> spaceP <.> terminal '}') cs
  '[':cs -> update Array (listP jsonP <.> spaceP <.> terminal ']') cs
  '"' :_ -> update String stringP s
  't':'r':'u':'e':cs -> [(Bool True,cs)]
  'f':'a':'l':'s':'e':cs -> [(Bool False,cs)]
  'n':'u':'l':'l':cs -> [(Null,cs)]
  c:cs -> if isDigit c || c=='-' && isDigit (head cs)
           then update Int readsQTerm s else []
  _ -> []

memberP :: Parser Char (String, Json)
memberP
  = spaceP <:> (stringP <*> \key ->
                update (\val -> (key,val)) (spaceP <:> terminal ':' <:> jsonP))