Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 203 lines (177 sloc) 7.623 kb
1f42837b »
2011-10-20 JSON for Haskell.
1 module JSON where
2
3 {-
4 JSON.hs
5
6 Implements RFC 4627, the JSON interchange format.
7
8 TODO:
9 1. Implement the unicode characters as specified in the RFC.
10 2. Extension: enable single quote strings.
11 -}
12
13 import Control.Monad (liftM)
14 import Data.Char
15 import qualified Data.Map as DM
16 import Util
17
18 data JSONValue = JNum Int | JStr String | JBool Bool | JNull |
19 JArr [JSONValue] | JObj (DM.Map String JSONValue)
20
21 data Token = NUM String | LIT String | STR String | BARRAY | BOBJECT |
22 EARRAY | EOBJECT | COMMA | COLON deriving Show
23
24 type Tokens = [Token]
25
26 tokenise :: Monad m => String -> m Tokens
27 tokenise "" = return []
28 tokenise ('"':xs) = case drawString xs of
29 Yes (str, rst) -> liftM ((STR str):) $ tokenise rst
30 No x -> fail x
31 tokenise (',':xs) = liftM (COMMA:) $ tokenise xs
32 tokenise (':':xs) = liftM (COLON:) $ tokenise xs
33 tokenise ('[':xs) = liftM (BARRAY:) $ tokenise xs
34 tokenise (']':xs) = liftM (EARRAY:) $ tokenise xs
35 tokenise ('{':xs) = liftM (BOBJECT:) $ tokenise xs
36 tokenise ('}':xs) = liftM (EOBJECT:) $ tokenise xs
37 tokenise s@(x:xs) | isSpace x = tokenise xs
38 | isDigit x = case drawNumber s of
39 Yes (num, rst) -> liftM ((NUM num):) $ tokenise rst
40 No y -> fail y
41 | isAlpha x = case drawLiteral s of
42 Yes (lit, rst) -> liftM ((LIT lit):) $ tokenise rst
43 No y -> fail y
44 | (x == '-') && (not $ null xs) && (isDigit $ head xs) =
45 case drawNumber xs of
46 Yes (num, rst) -> liftM ((NUM ("-" ++ num)):) $ tokenise rst
47 No y -> fail y
48 | otherwise = fail $ "Illegal character " ++ show x
49
50 drawString, drawLiteral, drawNumber :: Monad m => String -> m (String, String)
51 drawString = drs False "" where
52 drs :: Monad m => Bool -> String -> String -> m (String, String)
53 drs True _ "" = fail "Dangling escape"
54 drs True s (x:xs) = drs False (s ++ [escapee x]) xs
55 drs False s "" = fail "Unclosed quote"
56 drs False s ('\\':xs) = drs True s xs
57 drs False s ('"':xs) = return (s, xs)
58 drs False s (x:xs) = drs False (s ++ [x]) xs
59
60 drawLiteral = drl "" where
61 drl :: Monad m => String -> String -> m (String, String)
62 drl s "" = return (s, "")
63 drl s r@(x:xs) | isAlpha x = drl (s ++ [x]) xs
64 | otherwise = return (s, r)
65
66 drawNumber = drn "" where
67 drn :: Monad m => String -> String -> m (String, String)
68 drn s "" = return (s, "")
69 drn s r@(x:xs) | isDigit x = drn (s ++ [x]) xs
70 | otherwise = return (s, r)
71
72 escapee :: Char -> Char
73 escapee 'n' = '\n'
74 escapee 't' = '\t'
75 escapee 'b' = '\b'
76 escapee 'f' = '\f'
77 escapee 'r' = '\r'
78 escapee x = x
79
80 parse :: Monad m => [Token] -> m JSONValue
81 parse it@(BARRAY:xs) = case parseToks it of
82 Yes (rez, _) -> return rez
83 No e -> fail e
84 parse it@(BOBJECT:xs) = case parseToks it of
85 Yes (rez, _) -> return rez
86 No e -> fail e
87 parse _ = fail "JSON documents must be [arrays] or {objects}"
88
89 parseToks :: Monad m => Tokens -> m (JSONValue, Tokens)
90 parseToks ((NUM x):xs) = case getInt x of
91 Nothing -> fail ("A malformed number, " ++ (show x) ++ ", was encountered")
92 Just i -> return (JNum i, xs)
93 parseToks ((STR s):xs) = return (JStr s, xs)
94 parseToks ((LIT l):xs) = case l of
95 "true" -> return (JBool True, xs)
96 "false" -> return (JBool False, xs)
97 "null" -> return (JNull, xs)
98 _ -> fail $ "Unrecognised literal: " ++ show l
99 parseToks (BARRAY:xs) = case arrayElems xs of
100 Yes (them, rst) -> return (JArr them, rst)
101 No e -> fail e
102 parseToks (BOBJECT:xs) = case objMembers xs of
103 Yes (them, rst) -> return (JObj $ DM.fromList them, rst)
104 No e -> fail e
105 parseToks _ = fail "Missing element"
106
107 arrayElems :: Monad m => Tokens -> m ([JSONValue], Tokens)
108 arrayElems = ae_ [] where
109 ae_ :: Monad m => [JSONValue] -> Tokens -> m ([JSONValue], Tokens)
110 ae_ _ [] = fail "Array doesn't close"
111 ae_ sf (EARRAY:xs) = return (sf, xs)
112 ae_ sf rst = case parseToks rst of
113 Yes (stuff, tks) -> case postMemElem tks of
114 Yes nxt -> ae_ (sf ++ [stuff]) nxt
115 No rsn -> fail rsn
116 No e -> fail e
117
118 objMembers :: Monad m => Tokens -> m ([(String, JSONValue)], Tokens)
119 objMembers = om_ [] where
120 om_ :: Monad m => [(String, JSONValue)] -> Tokens -> m ([(String, JSONValue)], Tokens)
121 om_ _ [] = fail "Object doesn't close"
122 om_ sf (EOBJECT:xs) = return (sf, xs)
123 om_ sf rst = case parseToks rst of
124 Yes (nom, tks) -> case pickMemRgt tks of
125 Yes (val, mo) -> case postMemElem mo of
126 Yes nxt -> case rawString nom of
127 Yes raw -> om_ ((raw, val):sf) nxt
128 No e3 -> fail e3
129 No e2 -> fail e2
130 No e1 -> fail e1
131 No e -> fail e
132
133 pickMemRgt :: Monad m => Tokens -> m (JSONValue, Tokens)
134 pickMemRgt (COLON:xs) = parseToks xs
135 pickMemRgt _ = fail "Separate object pairs with a colon (:)"
136
137 rawString :: Monad m => JSONValue -> m String
138 rawString (JStr s) = return s
139 rawString _ = fail "Object member names should be strings"
140
141 postMemElem :: Monad m => Tokens -> m Tokens
142 postMemElem (COMMA:xs) = return xs
143 postMemElem it@(EOBJECT:xs) = return it
144 postMemElem it@(EARRAY:xs) = return it
145 postMemElem _ = fail "Put a comma between all elements"
146
147 instance Show JSONValue where
148 show (JNum n) = show n
149 show (JStr s) = show s
150 show (JBool b) = if b then "true" else "false"
151 show JNull = "null"
152 show (JArr ar) = show ar
153 show (JObj ob) =
154 let s = case DM.toList ob of {
155 [] -> "";
156 [x] -> doPair x;
157 (x:xs) -> (foldr (\y z -> z ++ (doPair y) ++ ", ") "" xs) ++
158 doPair x} in "{" ++ s ++ "}" where
159 doPair :: (String, JSONValue) -> String
160 doPair (s, v) = (show s) ++ ":" ++ (show v)
161
162 toJSON :: Monad m => String -> m JSONValue
163 toJSON str = case tokenise str of
164 Yes x -> case parse x of
165 Yes y -> return y
166 No z -> fail z
167 No e -> fail e
168
169 (@@) :: Monad m => String -> JSONValue -> m JSONValue
170 p @@ j = fetch_ (pathify p) j where
171 pathify :: String -> [String]
172 pathify str =
173 let (f, s) = break (== '/') str in
174 (case f of
175 "" -> []
176 _ -> [f]) ++ if null s then [] else (pathify $ drop 1 s)
177
178 fetch_ :: Monad m => [String] -> JSONValue -> m JSONValue
179 fetch_ [] j = return j
180 fetch_ (x:xs) j = lissez x j >>= fetch_ xs
181
182 lissez :: Monad m => String -> JSONValue -> m JSONValue
183 lissez mem json = (case getInt mem of
184 Nothing -> (case json of
185 JObj m -> (case DM.lookup mem m of
186 Nothing -> fail $ (show mem) ++ " Not found"
187 Just it -> return it)
188 _ -> fail $ "Can't locate " ++ show mem ++ " in an array")
189 Just n -> (case json of
190 JArr r -> (case getAt r n of
191 Nothing -> fail $ show n ++ " is out of array bounds"
192 Just it -> return it)
193 _ -> fail $ "You're using ints as object keys? No."))
194
195 getInt :: Monad m => String -> m Int
196 getInt ('-':xs) = getInt xs >>= (\x -> return (-x))
197 getInt str =
198 if and [isDigit x | x <- str] then return $ read str else fail "NaN"
199
200 getAt :: Monad m => [a] -> Int -> m a
201 getAt [] _ = fail "Out of bounds"
202 getAt (x:_) 0 = return x
203 getAt (x:xs) n = getAt xs (n - 1)
Something went wrong with that request. Please try again.