json.hs

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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
module Main(main) where

import Control.Monad
import Data.Char
import Data.Maybe
import Data.List
import Text.Parsec
import Text.Parsec.String

data JValue = JObject [(String, JValue)]
            | JArray [JValue]
            | JString String
            | JNumber Double
            | JTrue | JFalse
            | JNull
    deriving Show

whitespaceChar = oneOf " \n\r\f" >> return ()
              <?> "whitespace character"

ws = skipMany whitespaceChar <?> "whitespace"

tok = between ws ws . char

beginArray     = tok '['
beginObject    = tok '{'
endArray       = tok ']'
endObject      = tok '}'
nameSeparator  = tok ':'
valueSeparator = tok ',' <?> "comma"

true = string "true" >> return JTrue
false = string "false" >> return JFalse
jnull = string "null" >> return JNull

object :: Parser JValue
object = (liftM JObject . between beginObject endObject $ member `sepBy` valueSeparator)
      <?> "object"
    where
        member = do (JString name) <- jstring
                    _ <- nameSeparator
                    v <- jvalue
                    return (name, v)
                 <?> "member"

array :: Parser JValue
array = (liftM JArray . between beginArray endArray $ jvalue `sepBy` valueSeparator)
     <?> "array"

jstring :: Parser JValue
jstring = (liftM JString . between quote quote $ many character)
       <?> "string"
    where
        quote = char '"'
        character = unescaped <|> escaped
        escaped = do _ <- char '\\'
                     c <- oneOf $ 'u' : map fst escapables
                     if c == 'u' then readHex else readNormal c

        readHex = do ds <- count 4 hexDigit -- contains 4 hex digits, as characters.
                     let ds' = zip (reverse [0..3]) $ map digitToInt ds
                      in return . toEnum $ foldl' (\n (e, d) -> n+d*0x10^e) 0 ds'

        readNormal c = return . fromJust $ lookup c escapables

        unescaped :: Parser Char
        unescaped = satisfy (valid . ord)
            where
                valid c = 0x20 <= c && c <= 0x21
                       || 0x23 <= c && c <= 0x5B
                       || 0x5D <= c && c <= 0x10FFFF
                     
        escapables = [ ('"', '"')
                     , ('\\', '\\')
                     , ('b', '\b')
                     , ('f', '\f')
                     , ('n', '\n')
                     , ('r', '\r')
                     , ('t', '\t')
                     ]

number :: Parser JValue
number = do s1 <- readSign
            n <- rawNum
            f <- option "0" $ char '.' >> rawNum
            (expon, s2) <- option ("0", '+') expo
            let s = [s1] ++ n ++ "." ++ f ++ "e" ++ [s2] ++ expon
            return . JNumber $ read s
          <?> "number"
    where
        readSign = liftM (\c -> if c == '+' then ' ' else c) $ option '+' sign
        expo = do _ <- oneOf "eE"
                  s <- readSign
                  ex <- rawNum
                  return (ex, s)
        rawNum = many1 digit
        sign = oneOf "+-" <?> "sign"

jvalue :: Parser JValue
jvalue = object
      <|> true <|> false
      <|> jnull
      <|> array
      <|> number
      <|> jstring

parseJSON :: Parser JValue
parseJSON = object <|> array

--simpleTest = readFile "simple.json"
--arrayTest = readFile "array.json"
--objectTest = readFile "object.json"

main :: IO ()
main = parseTest parseJSON "{\"x\":1 }"
-- OUTPUT:
-- parse error at (line 1, column 8):
-- unexpected "}"
-- expecting whitespace character or ","