GenJSON.icl 31 KB
Newer Older
Camil Staps's avatar
Camil Staps committed
1
implementation module Text.GenJSON
2

Camil Staps's avatar
Camil Staps committed
3
import StdGeneric, Data.Maybe, StdList, StdOrdList, StdString, _SystemArray, StdTuple, StdBool, StdFunc, StdOverloadedList, StdFile
4
import Data.List, Text, Text.PPrint, Text.GenJSON, Data.GenEq
5

6 7
//Basic JSON serialization
instance toString JSONNode
8
where
9
	//make target string -> copy characters
10 11 12
	//The reason why first a big string is made into which the characters are copied is to
	//avoid many string concatenations with big strings
	toString node
13
		#! len = sizeOf node
14
		= snd (copyNode 0 node (createArray len '\0'))
15

16 17
//Determine serialized size of a JSON datastructure
sizeOf :: !JSONNode -> Int
18 19 20 21
sizeOf (JSONNull)       = 4
sizeOf (JSONBool True)  = 4
sizeOf (JSONBool False) = 5
sizeOf (JSONInt x)      = size (toString x)
22
sizeOf (JSONReal x)     = size (jsonRealtoString x)
23 24
//For strings we need to allocate extra size for the enclosing double quotes and the escaping of special characters
sizeOf (JSONString x)   = size x + 2 + sizeOfEscapeChars x
25
//For arrays we need to allocate extra size for the enclosing brackets and comma's
26 27 28
sizeOf (JSONArray x)
  #! len = length x
  = (if (len > 0) (foldl (\s x -> s + sizeOf x) (len - 1) x) 0) + 2
29
//For objects we need to allocate extra size for the enclosing braces, comma's and labels
30 31
sizeOf (JSONObject x)
  #! len = length x
32
  = (if (len > 0) (foldl (\s (l,o) -> s + sizeOf (JSONString l) + 1 + sizeOf o) (len - 1) x) 0) + 2
33 34
sizeOf (JSONRaw x)      = size x
sizeOf (JSONError)      = 0
35

36 37
sizeOfEscapeChars :: !String -> Int
sizeOfEscapeChars s = count 0 s 0
38
where
39 40
	count :: !Int !String !Int -> Int
	count i s n
41
		| i < size s
42
			#! c = s.[i]
43
			| c == '"' || c == '\b' || c == '\f' || c == '\n' || c == '\r' || c == '\t' || c == '\\'
44
				= count (i + 1) s (n + 1) //We'll add a '\' to escape
45
			| c < ' '
46 47
				= count (i + 1) s (n + 5) //We'll replace the character by '\uXXXX'
			= count(i + 1) s n
Mart Lubbers's avatar
Mart Lubbers committed
48
		= n
49

50 51
//Copy structure to a string
copyNode :: !Int !JSONNode !*{#Char} -> *(!Int, !*{#Char})
52 53 54
copyNode start (JSONNull) buffer		= (start + 4, copyChars start 4 "null" buffer)
copyNode start (JSONBool True) buffer	= (start + 4, copyChars start 4 "true" buffer)
copyNode start (JSONBool False) buffer	= (start + 5, copyChars start 5 "false" buffer)
55 56 57 58
copyNode start (JSONInt x) buffer
  #! s = toString x
  = (start + size s, copyChars start (size s) s buffer)
copyNode start (JSONReal x) buffer
59
  #! s = jsonRealtoString x
60
  = (start + size s, copyChars start (size s) s buffer)
61
copyNode start (JSONString s) buffer
62
  #! (start,buffer)	= (start + 1, {buffer & [start] = '"'})
63
  #! (start,buffer) = (start + size s + sizeOfEscapeChars s, copyAndEscapeChars 0 start (size s) s buffer)
64
  = (start + 1, {buffer & [start] = '"'})
65
copyNode start (JSONArray items) buffer
66 67
	#! (start,buffer)	= (start + 1, {buffer & [start] = '['})
	#! (start,buffer)	= copyArrayItems start items buffer
68 69
	= (start + 1, {buffer & [start] = ']'})
where
70
    copyArrayItems :: !Int ![JSONNode] !*String -> *(!Int, !*String)
71 72 73
	copyArrayItems start [] buffer = (start,buffer)
	copyArrayItems start [x] buffer = copyNode start x buffer
	copyArrayItems start [x:xs] buffer
74
		#! (start,buffer) = copyNode start x buffer
75 76
		= copyArrayItems (start + 1) xs {buffer & [start] = ','}
copyNode start (JSONObject items) buffer
77 78
	#! (start, buffer) = (start + 1, {buffer & [start] = '{'})
	#! (start, buffer) = copyObjectItems start items buffer
79 80
	= (start + 1, {buffer &	[start] = '}'})
where
81
    copyObjectItems :: !Int ![(String, JSONNode)] !*String -> *(!Int, !*String)
82 83
	copyObjectItems start [] buffer = (start,buffer)
	copyObjectItems start [(l,x)] buffer
84 85
		# (start,buffer) = copyNode start (JSONString l) buffer
		# (start,buffer) = (start + 1, {buffer & [start] = ':'})
86 87
		= copyNode start x buffer
	copyObjectItems start [(l,x):xs] buffer
88 89
		# (start,buffer) = copyNode start (JSONString l) buffer
		# (start,buffer) = (start + 1, {buffer & [start] = ':'})
90 91
		# (start,buffer) = copyNode start x buffer
		= copyObjectItems (start + 1) xs {buffer & [start] = ','}
92
copyNode start (JSONRaw x) buffer	= (start + size x, copyChars start (size x) x buffer) 	
93
copyNode start _ buffer				= (start,buffer)
94

95
//Straightforward copying of strings, with some optimization
96
copyChars :: !Int !Int !String !*String -> *String
97 98 99 100 101 102 103 104 105
copyChars offset num src dst
	| num > 3
		#! di = offset + num
		#! dst & [di-4] = src.[num-4]
		#! dst & [di-3] = src.[num-3]
		#! dst & [di-2] = src.[num-2]
		#! dst & [di-1] = src.[num-1]
		= copyChars offset (num - 4) src dst
	| num > 1
106 107
		#! dst & [offset] = src.[0]
		#! dst & [offset+1] = src.[1]
108
		| num == 3
109
			= {dst & [offset+2] = src.[2]}
110 111 112 113 114 115
		= dst
	| num == 1
		= {dst & [offset] = src.[0]}
	= dst

//Copying strings with escaping of special characters (not optimized)
116 117 118 119 120
copyAndEscapeChars :: !Int !Int !Int !String !*String -> *String
copyAndEscapeChars soffset doffset num src dst
	| num > 0
		#! c = src.[soffset]
		//Check for special characters
121
		| c == '"' || c == '\b' || c == '\f' || c == '\n' || c == '\r' || c == '\t' || c == '\\'
122
			#! dst & [doffset] = '\\'
123
			#! dst & [doffset + 1] = charOf c
124
			= copyAndEscapeChars (soffset + 1) (doffset + 2) (num - 1) src dst	
125
		| c < ' '
126 127 128 129 130 131
            #! cint = toInt c
			#! dst & [doffset] = '\\'
			#! dst & [doffset + 1] = 'u'
			//Put the hexadecimal representation of the character in the following 4 characters
			#! dst & [doffset + 2] = '0'
			#! dst & [doffset + 3] = '0'
132 133
			#! dst & [doffset + 4] = toHexDigit ((cint >> 4) bitand 15)
			#! dst & [doffset + 5] = toHexDigit (cint bitand 15)
134 135 136 137 138 139
			= copyAndEscapeChars (soffset + 1) (doffset + 6) (num - 1) src dst	
		| otherwise	
			#! dst & [doffset] = c
			= copyAndEscapeChars (soffset + 1) (doffset + 1) (num - 1) src dst	
	= dst
where
140 141 142 143 144 145 146
	charOf '"' = '"'
	charOf '\b' = 'b'
	charOf '\f' = 'f'
	charOf '\n' = 'n'
	charOf '\r' = 'r'
	charOf '\t' = 't'
	charOf '\\' = '\\'
Camil Staps's avatar
Camil Staps committed
147
	charOf _   = abort "error in copyAndEscapeChars\n"
148 149
	
	toHexDigit c
150 151
		| c < 10 = toChar (c + 48)
	 			 = toChar (c + 87)
152

153 154 155 156 157 158 159 160 161 162
//Escape a string
jsonEscape :: !String -> String
jsonEscape src
	= copyAndEscapeChars 0 0 (size src) src (createArray (size src + sizeOfEscapeChars src) '\0')

instance <<< JSONNode
where
	(<<<) f JSONNull            = f <<< "null"
	(<<<) f (JSONBool True)     = f <<< "true"
	(<<<) f (JSONBool False)    = f <<< "false"
163
	(<<<) f (JSONInt i)         = f <<< toString i
164
	(<<<) f (JSONReal r)        = f <<< jsonRealtoString r
165 166 167 168 169 170 171 172 173 174 175 176 177 178
	(<<<) f (JSONString s)      = f <<< '"' <<< jsonEscape s <<< '"'
	(<<<) f (JSONArray nodes)   = printNodes nodes (f <<< "[") <<< "]"
	where
		printNodes :: [JSONNode] *File -> *File
		printNodes []         f = f
		printNodes [n]        f = f <<< n
		printNodes [n:ns]     f = printNodes ns (f <<< n <<< ",")
	(<<<) f (JSONObject nodes)  = printNodes nodes (f <<< "{") <<< "}"
	where
		printNodes :: [(String,JSONNode)] *File -> *File
		printNodes []         f = f
		printNodes [(k,v)]    f = f <<< '"' <<< jsonEscape k <<< "\":" <<< v
		printNodes [(k,v):ns] f = printNodes ns (f <<< '"' <<< jsonEscape k <<< "\":" <<< v <<< ",")
	(<<<) f (JSONRaw s)         = f <<< s
Camil Staps's avatar
Camil Staps committed
179
	(<<<) f JSONError           = abort "<<< called on JSONError\n"
180

181 182 183
//Basic JSON deserialization (just structure)
instance fromString JSONNode
where
184
	fromString s = fst (parse 0 s)
185 186 187

IsDigit c :== c >= '0' && c <= '9'

188 189
parse :: !Int !String -> (!JSONNode,!Int)
parse offset input
190
	| offset<size input
191
		#! c = input.[offset]
192
		| c=='"'
193
			#! offset=offset+1
194
			= parse_string offset offset input
195
		| c=='n' && offset+3<size input && input.[offset+1]=='u' && input.[offset+2]=='l' && input.[offset+3]=='l'
196
			= (JSONNull,offset+4)
197
		| c=='t' && offset+3<size input && input.[offset+1]=='r' && input.[offset+2]=='u' && input.[offset+3]=='e'
198
			= (JSONBool True, offset+4)
199
		| c=='f' && offset+4<size input && input.[offset+1]=='a' && input.[offset+2]=='l' && input.[offset+3]=='s' && input.[offset+4]=='e'
200
			= (JSONBool False, offset+5)
201
		| IsDigit c
202
			= parse_number (offset+1) offset input
203
		| c=='-' && offset+1<size input && IsDigit input.[offset+1]
204 205 206 207 208 209 210 211 212
			= parse_number (offset+2) offset input
		| c=='['
			= parse_array (offset+1) input
		| c=='{'
		 	= parse_object (offset+1) input
		| c==' ' || c=='\t' || c=='\n' || c=='\r' || c=='\f' || c=='\v' // inlined isSpace c
			= parse (skip_spaces (offset+1) input) input
			= (JSONError, offset)
		= (JSONError, offset)
213
where
214 215 216
	parse_string :: !Int !Int !{#Char} -> (!JSONNode,!Int)
	parse_string offset stringCharsOffset input
		| offset<size input
217
			#! c=input.[offset]
218 219 220 221 222 223 224 225 226 227 228
			| c <> '"'
				| c <> '\\'
					= parse_string (offset + 1) stringCharsOffset input
					= parse_string_with_escape (offset + 2) stringCharsOffset input // skip the escaped character
				#! string = input % (stringCharsOffset,offset-1)
				= (JSONString string, offset+1)
			= (JSONError,offset) // missing '"'
	where
		parse_string_with_escape :: !Int !Int !{#Char} -> (!JSONNode,!Int)
		parse_string_with_escape offset stringCharsOffset input
			| offset<size input
229
				#! c = input.[offset]
230 231 232 233 234 235 236 237 238 239 240
				| c <> '"'
					| c <> '\\'
						= parse_string_with_escape (offset + 1) stringCharsOffset input
						= parse_string_with_escape (offset + 2) stringCharsOffset input // skip the escaped character
					#! string = input % (stringCharsOffset,offset-1)
					= (JSONString (jsonUnescape string), offset+1)
				= (JSONError,offset) // missing '"'

	skip_spaces :: !Int !String -> Int
	skip_spaces offset input
		| offset<size input
241
			#! c = input.[offset]
242 243 244 245 246 247 248
			| c==' ' || c=='\t' || c=='\n' || c=='\r' || c=='\f' || c=='\v' // inlined isSpace c
				= skip_spaces (offset+1) input
				= offset
			= offset

	parse_number :: !Int !Int !{#Char} -> (!JSONNode,!Int)
	parse_number offset numberOffset input
249 250
		| offset>=size input
			#! i = toInt (input % (numberOffset,offset-1))
251
			= (JSONInt i,offset)
252
		#! c = input.[offset]
253
		| IsDigit c
254
			= parse_number (offset+1) numberOffset input
255 256
		| c<>'.'
			#! i = toInt (input % (numberOffset,offset-1))
257 258 259 260 261 262 263 264
			= (JSONInt i, offset)
			= parse_real (offset+1) numberOffset input
	where
		parse_real :: !Int !Int !{#Char} -> (!JSONNode,!Int)
		parse_real offset numberOffset input
			| offset>=size input
				#! r = toReal (input % (numberOffset,offset-1))
				= (JSONReal r,offset)
265
			#! c = input.[offset]
266 267 268 269 270 271 272
			| IsDigit c
				= parse_real (offset+1) numberOffset input
			| c<>'e' && c<>'E'
				#! r = toReal (input % (numberOffset,offset-1))
				= (JSONReal r, offset)
			| offset+1<size input && IsDigit input.[offset+1]
				= parse_real_with_exponent (offset+2) numberOffset input
273
			| offset+2<size input && (input.[offset+1]=='-' || input.[offset+1] == '+') && IsDigit input.[offset+2]
274
				= parse_real_with_exponent (offset+3) numberOffset input
275 276 277
			#! r = toReal (input % (numberOffset,offset-1))
			= (JSONReal r, offset)
		
278 279 280 281 282 283 284 285 286 287 288 289 290 291
		parse_real_with_exponent :: !Int !Int !{#Char} -> (!JSONNode,!Int)
		parse_real_with_exponent offset numberOffset input
			| offset>=size input
				#! r = toReal (input % (numberOffset,offset-1))
				= (JSONReal r,offset)
			| IsDigit input.[offset]
				= parse_real_with_exponent (offset+1) numberOffset input
				#! r = toReal (input % (numberOffset,offset-1))
				= (JSONReal r, offset)

	parse_array :: !Int !{#Char} -> (!JSONNode,!Int)
	parse_array offset input
		| offset<size input && input.[offset]==']'
			= (JSONArray [], offset+1)
292
		#! offset = skip_spaces offset input
293 294 295 296 297 298
		| offset<size input && input.[offset]==']'
			= (JSONArray [], offset+1)
			= parse_array_items offset [] offset input
	where
		parse_array_items :: !Int !*[JSONNode] !Int !{#Char} -> (!JSONNode,!Int)
		parse_array_items offset items offset_after_bracket_open input
299
			#! (item,offset) = parse offset input
300 301 302 303
			| offset<size input && input.[offset]==','
				= parse_array_items (offset+1) [item:items] offset_after_bracket_open input
			| offset<size input && input.[offset]==']'
				= (JSONArray (reverse_append items [item]), offset+1)
304
			#! offset = skip_spaces offset input
305 306 307 308 309 310 311 312 313 314
			| offset<size input && input.[offset]==','
				= parse_array_items (offset+1) [item:items] offset_after_bracket_open input
			| offset<size input && input.[offset]==']'
				= (JSONArray (reverse_append items [item]), offset+1)
				= (JSONError, offset_after_bracket_open)

	parse_object :: !Int !{#Char} -> (!JSONNode,!Int)
	parse_object offset input
		| offset<size input && input.[offset]=='}'
			= (JSONObject [], offset+1)
315
		#! offset = skip_spaces offset input
316 317 318 319
		| offset<size input && input.[offset]=='}'
			= (JSONObject [], offset+1)
			= parse_object_items offset [] offset input
	where
320
		parse_object_items :: !Int !*[({#Char}, JSONNode)] !Int !{#Char} -> (!JSONNode,!Int)
321 322 323
		parse_object_items offset items offset_after_bracket_open input
			| offset<size input
				| input.[offset]=='"'
324 325
					#! offset=offset+1
					#! (label,offset) = lex_label offset offset input
326 327 328
					| offset>=0
						| offset<size input && input.[offset]==':'
							= parse_object_items_after_label_and_colon label (offset+1) items offset_after_bracket_open input
329
							#! offset = skip_spaces offset input
330 331 332 333
							| offset<size input && input.[offset]==':'
								= parse_object_items_after_label_and_colon label (offset+1) items offset_after_bracket_open input
								= (JSONError, offset_after_bracket_open)
						= (JSONError, offset_after_bracket_open)
334
					#! c = input.[offset]
335 336 337 338 339 340 341 342
					| c==' ' || c=='\t' || c=='\n' || c=='\r' || c=='\f' || c=='\v' // inlined isSpace c
						= parse_object_items (skip_spaces (offset+1) input) items offset_after_bracket_open input
						= (JSONError, offset_after_bracket_open)
				= (JSONError, offset_after_bracket_open)
		where
			lex_label :: !Int !Int !{#Char} -> (!{#Char},!Int)
			lex_label offset stringCharsOffset input
				| offset<size input
343
					#! c=input.[offset]
344 345 346 347 348 349 350 351 352 353 354
					| c <> '"'
						| c <> '\\'
							= lex_label (offset + 1) stringCharsOffset input
							= lex_label_with_escape (offset + 2) stringCharsOffset input // skip the escaped character
						#! string = input % (stringCharsOffset,offset-1)
						= (string, offset+1)
					= ("",-1) // missing '"'

			lex_label_with_escape :: !Int !Int !{#Char} -> (!{#Char},!Int)
			lex_label_with_escape offset stringCharsOffset input
				| offset<size input
355
					#! c=input.[offset]
356 357 358 359 360 361 362 363
					| c <> '"'
						| c <> '\\'
							= lex_label_with_escape (offset + 1) stringCharsOffset input
							= lex_label_with_escape (offset + 2) stringCharsOffset input // skip the escaped character
						#! string = input % (stringCharsOffset,offset-1)
						= (jsonUnescape string, offset+1)
					= ("",-1) // missing '"'

364
		parse_object_items_after_label_and_colon :: !{#Char} !Int !*[({#Char}, JSONNode)] !Int !{#Char} -> (!JSONNode,!Int)
365
		parse_object_items_after_label_and_colon label offset items offset_after_brace_open input
366
			#! (item,offset) = parse offset input
367 368 369 370
			| offset<size input && input.[offset]==','
				= parse_object_items (offset+1) [(label,item):items] offset_after_brace_open input
			| offset<size input && input.[offset]=='}'
				= (JSONObject (reverse_append items [(label,item)]), offset+1)
371
			#! offset = skip_spaces offset input
372 373 374 375 376 377
			| offset<size input && input.[offset]==','
				= parse_object_items (offset+1) [(label,item):items] offset_after_brace_open input
			| offset<size input && input.[offset]=='}'
				= (JSONObject (reverse_append items [(label,item)]), offset+1)
				= (JSONError, offset_after_brace_open)

378
	reverse_append :: !*[.a] !*[.a] -> *[.a]
379 380
	reverse_append [hd:tl] list	= reverse_append tl [hd:list]
	reverse_append [] list		= list
381

382 383 384 385
//For strings that contain escaped characters, the destination string will be smaller
//This function determines 
sizeOfExtraCharsOfEscapes :: !String -> Int
sizeOfExtraCharsOfEscapes s = count 0 s 0
Camil Staps's avatar
Camil Staps committed
386
where
387 388 389 390 391 392 393 394 395 396
	count :: !Int !String !Int -> Int
	count i s n
		| i < (size s - 1)
			#! cc = s.[i]
			#! cn = s.[i + 1]
			| cc == '\\'
				| cn == 'u' = count (i + 6) s (n + 5)
							= count (i + 2) s (n + 1)
			= count (i + 1) s n
		= n
Camil Staps's avatar
Camil Staps committed
397

398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
//Copying strings with escaping of special characters (not optimized)
copyAndUnescapeChars :: !Int !Int !Int !String !*String -> *String
copyAndUnescapeChars soffset doffset num src dst
	| num > 0
		#! cc = src.[soffset]
		//Check for escapes
		| cc == '\\' && num > 1
			#! cn = src.[soffset + 1]
			| cn == '"' || cn == '/' || cn == 'b' || cn == 'f' || cn == 'n' || cn == 'r' || cn == 't' || cn == '\\'
				#! dst & [doffset] = charOf cn
				= copyAndUnescapeChars (soffset + 2) (doffset + 1) (num - 2) src dst	
			| cn == 'u' && num > 5
				// The escape is in the form \uXXXX
				// Use the last two hex numbers to reconstruct the character value
				#! dst & [doffset] = toChar (((fromHexDigit src.[soffset + 4]) << 4) + (fromHexDigit src.[soffset + 5]))
				= copyAndUnescapeChars (soffset + 6) (doffset + 1) (num - 6) src dst	
			| otherwise
				#! dst & [doffset] = cc
				= copyAndUnescapeChars (soffset + 1) (doffset + 1) (num - 1) src dst	
		| otherwise
			#! dst & [doffset] = cc
			= copyAndUnescapeChars (soffset + 1) (doffset + 1) (num - 1) src dst
	= dst
where
	charOf '"' = '"'
	charOf '/' = '/'
	charOf 'b' = '\b'
	charOf 'f' = '\f'
	charOf 'n' = '\n'
	charOf 'r' = '\r'
	charOf 't' = '\t'
	charOf '\\' = '\\'
Camil Staps's avatar
Camil Staps committed
430
	charOf _   = abort "error in copyAndUnescapeChars\n"
431 432 433 434 435 436 437
	
	fromHexDigit :: Char -> Int
	fromHexDigit c
		| isDigit c = digitToInt c
		| c <= 'f' && c >= 'a' = toInt c - 87
		| c <= 'F' && c >= 'A' = toInt c - 55
		= 0
438

439 440
//Unescape a string
jsonUnescape :: !String -> String
441
jsonUnescape src
442
	= copyAndUnescapeChars 0 0 (size src) src (createArray (size src - sizeOfExtraCharsOfEscapes src) '\0')
443

444 445
//-------------------------------------------------------------------------------------------

446
toJSON :: !a -> JSONNode | JSONEncode{|*|} a
447 448 449 450 451 452 453
toJSON x = toJSON` False x

toJSONInField :: !a -> JSONNode | JSONEncode{|*|} a
toJSONInField x = toJSON` True x

toJSON` :: !Bool !a -> JSONNode | JSONEncode{|*|} a
toJSON` flag x = case (JSONEncode{|*|} flag x) of
454 455 456 457 458 459
	[node]	= node
	_		= JSONError 

/*
* Generic JSON encoder
*/
460 461 462 463 464 465 466 467 468
generic JSONEncode t :: !Bool !t -> [JSONNode]

JSONEncode{|Int|} _ x = [JSONInt x]
JSONEncode{|Real|} _ x = [JSONReal x]
JSONEncode{|Char|} _ x = [JSONString {x}]
JSONEncode{|Bool|} _ x = [JSONBool x]
JSONEncode{|String|} _ x = [JSONString x]
JSONEncode{|UNIT|} _ (UNIT) = []
JSONEncode{|PAIR|} fx fy _ (PAIR x y) = fx False x ++ fy False y
469 470 471 472
where
	(++) infixr 5::![.a] !u:[.a] -> u:[.a]
	(++) [hd:tl]	list	= [hd:tl ++ list]
	(++) nil 		list	= list
473 474 475 476
JSONEncode{|EITHER|} fx fy _ (LEFT x) = fx False x
JSONEncode{|EITHER|} fx fy _ (RIGHT y) = fy False y
JSONEncode{|OBJECT|} fx _ (OBJECT x) = fx False x
JSONEncode{|CONS of {gcd_name}|} fx _ (CONS x)
477
  = [JSONArray [JSONString gcd_name : fx False x]]
478
JSONEncode{|RECORD of {grd_fields}|} fx _ (RECORD x)
479 480 481 482 483
	= [JSONObject [(name, o) \\ o <- fx False x & name <- grd_fields | isNotNull o]]
where
	isNotNull :: !JSONNode -> Bool
	isNotNull JSONNull = False
	isNotNull _ = True
484
JSONEncode{|FIELD|} fx _ (FIELD x) = fx True x
485
JSONEncode{|[]|} fx _ x = [JSONArray (flatten (map (fx False) x))]
486
JSONEncode{|()|} _ () = [JSONNull]
487 488 489 490
JSONEncode{|(,)|} fx fy _ (x,y) = [JSONArray (fx False x ++ fy False y)]
JSONEncode{|(,,)|} fx fy fz _ (x,y,z) = [JSONArray (fx False x ++ fy False y ++ fz False z)]
JSONEncode{|(,,,)|} fx fy fz fi _ (x,y,z,i) = [JSONArray (fx False x ++ fy False y ++ fz False z ++ fi False i)]
JSONEncode{|(,,,,)|} fx fy fz fi fj _ (x,y,z,i,j) = [JSONArray (fx False x ++ fy False y ++ fz False z ++ fi False i ++ fj False j)]
491
JSONEncode{|(,,,,,)|} fx fy fz fi fj fk _ (x,y,z,i,j,k) = [JSONArray (fx False x ++ fy False y ++ fz False z ++ fi False i ++ fj False j ++ fk False k)]
492 493
JSONEncode{|(,,,,,,)|} fx fy fz fi fj fk fl _ (x,y,z,i,j,k,l) = [JSONArray (fx False x ++ fy False y ++ fz False z ++ fi False i ++ fj False j ++ fk False k ++ fl False l)]
JSONEncode{|(,,,,,,,)|} fx fy fz fi fj fk fl fm _ (x,y,z,i,j,k,l,m) = [JSONArray (fx False x ++ fy False y ++ fz False z ++ fi False i ++ fj False j ++ fk False k ++ fl False l ++ fm False m)]
494 495 496 497 498
JSONEncode{|{}|} fx _ x = [JSONArray (flatten [fx False e \\ e <-: x])]
JSONEncode{|{!}|} fx _ x = [JSONArray (flatten [fx False e \\ e <-: x])]
JSONEncode{|Maybe|} fx inField (Just x) = if inField (fx False x) [JSONArray [JSONString "Just" : fx False x]]
JSONEncode{|Maybe|} fx inField Nothing = if inField [JSONNull] [JSONArray [JSONString "Nothing"]]
JSONEncode{|JSONNode|} _ node = [node]
499 500

//-------------------------------------------------------------------------------------------
501
fromJSON :: !JSONNode -> Maybe a | JSONDecode{|*|} a
502
fromJSON node = fst (JSONDecode{|*|} False [node])
503

504 505 506
/*
* Generic JSON parser, using a list of tokens
*/
507
generic JSONDecode t :: !Bool ![JSONNode] -> (!Maybe t, ![JSONNode])
508

509 510
JSONDecode{|Int|} _ [JSONInt i:xs]		= (Just i, xs)
JSONDecode{|Int|} _ l					= (Nothing, l)
511

512
JSONDecode{|Real|} _ [JSONNull:xs]		= (Just NaN, xs)
513 514 515
JSONDecode{|Real|} _ [JSONReal r:xs]	= (Just r, xs)
JSONDecode{|Real|} _ [JSONInt i:xs]		= (Just (toReal i), xs)
JSONDecode{|Real|} _ l					= (Nothing, l)
516

517
JSONDecode{|Char|} _ l=:[JSONString s:xs]
518 519
	| size s == 1						= (Just s.[0],xs)
										= (Nothing, l)
520
JSONDecode{|Char|} _ l					= (Nothing, l)
521

522 523
JSONDecode{|Bool|} _ [JSONBool b:xs]	= (Just b,xs)
JSONDecode{|Bool|} _ l					= (Nothing, l)
524

525 526
JSONDecode{|String|} _ [JSONString s:xs]= (Just s, xs)
JSONDecode{|String|} _ l				= (Nothing, l)
527

528
JSONDecode{|UNIT|} _ l					= (Just UNIT, l)
529

530 531
JSONDecode{|PAIR|} fx fy _ l = d1 fy (fx False l) l
  where
532
  d1 :: !(Bool [JSONNode] -> (Maybe b, [JSONNode])) !(!Maybe a, ![JSONNode]) ![JSONNode]
533 534 535
     -> (!Maybe (PAIR a b), ![JSONNode])
  d1 fy (Just x,xs)  l = d2 x (fy False xs) l
  d1 _  (Nothing, _) l = (Nothing, l)
536

537 538 539
  d2 :: !a !(!Maybe b, ![JSONNode]) ![JSONNode] -> (!Maybe (PAIR a b), ![JSONNode])
  d2 x (Just y, ys) l = (Just (PAIR x y), ys)
  d2 x (Nothing, _) l = (Nothing, l)
540 541

JSONDecode{|EITHER|} fx fy _ l = case fx False l of
542
	(Just x, xs)				= (Just (LEFT x),xs)
543
	(Nothing, xs)				= case fy False l of
544 545 546
		(Just y, ys)			= (Just (RIGHT y),ys)
		(Nothing, ys)			= (Nothing, l)

547
JSONDecode{|OBJECT|} fx _ l = case fx False l of
548 549 550
	(Just x, xs)	= (Just (OBJECT x),xs)
	_				= (Nothing, l)

551 552
JSONDecode{|CONS of {gcd_name}|} fx _ l=:[JSONArray [JSONString name:fields] :xs]
	| name == gcd_name				= case fx False fields of
553 554 555
		(Just x, _)					= (Just (CONS x), xs)
		_							= (Nothing, l)
	| otherwise						= (Nothing, l)		
556
JSONDecode{|CONS|} fx _ l = (Nothing, l)
557

558
JSONDecode{|RECORD|} fx _ l=:[obj=:JSONObject fields : xs] = d (fx False [obj]) xs l
559 560 561 562 563 564 565 566 567
  where
  d :: !(!Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
  d (Just x, _)  xs l = (Just (RECORD x),xs)
  d (Nothing, _) xs l = (Nothing, l)
JSONDecode{|RECORD|} fx _ l=:[obj=:JSONArray fields : xs] = d (fx False [obj]) xs l
  where
  d :: !(!Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
  d (Just x, _)  xs l = (Just (RECORD x),xs)
  d (Nothing, _) xs l = (Nothing, l)
568 569 570
JSONDecode{|RECORD|} fx _ l = (Nothing,l)

JSONDecode{|FIELD of {gfd_name}|} fx _ l =:[JSONObject fields]
571 572 573 574 575
  #! field = findField gfd_name fields
  = case fx True field of
      (Just x, _) = (Just (FIELD x), l)
      (_, _)      = (Nothing, l)
  where
576
  findField :: !String ![(String, JSONNode)] -> [JSONNode]
577 578 579 580 581
  findField match [(l,x):xs]
    | l == match = [x]
    | otherwise  = findField match xs
  findField match [] = []
JSONDecode{|FIELD of {gfd_index}|} fx _ l =:[JSONArray fields]
Camil Staps's avatar
Camil Staps committed
582 583 584 585 586
	= case fields !? gfd_index of
		Nothing    = (Nothing, l)
		Just field = case fx True [field] of
			(Just x, _) = (Just (FIELD x), l)
			(_, _)      = (Nothing, l)
587
JSONDecode{|FIELD|} fx _ l = (Nothing, l)
588

589
JSONDecode{|[]|} fx _ l =:[JSONArray items:xs]
590 591 592
	= case decodeItems fx items of
		(Just x)		= (Just x, xs)
		_				= (Nothing, l)
593
JSONDecode{|[]|} fx _ l = (Nothing, l)
594

595 596 597 598
JSONDecode{|()|} _ [JSONNull:c]     = (Just (), c)
JSONDecode{|()|} _ [JSONObject []:c]= (Just (), c)
JSONDecode{|()|} _ c                = (Nothing, c)

599 600 601
JSONDecode{|(,)|} fx fy _ l =:[JSONArray [xo,yo]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
602 603
			(Just y,_)		= (Just (x,y), xs)
			_				= (Nothing, l)
604
		_					= (Nothing, l)
605
JSONDecode{|(,)|} fx fy _ l	= (Nothing, l)
606

607 608 609 610
JSONDecode{|(,,)|} fx fy fz _ l =:[JSONArray [xo,yo,zo]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
			(Just y,_)			= case fz False [zo] of
611 612 613 614
				(Just z,_)		= (Just (x,y,z), xs)
				_				= (Nothing, l)
			_					= (Nothing, l)
		_						= (Nothing, l)
615
JSONDecode{|(,,)|} fx fy fz _ l	= (Nothing, l)
616

617 618 619 620 621
JSONDecode{|(,,,)|} fx fy fz fi _ l =:[JSONArray [xo,yo,zo,io]:xs]
	= case fx False [xo] of
		(Just x,_) = case fy False [yo] of
			(Just y,_)	= case fz False [zo] of
				(Just z,_) = case fi False [io] of
622 623 624 625
					(Just i,_)		= (Just (x,y,z,i), xs)
					_				= (Nothing, l)
				_					= (Nothing, l)
			_						= (Nothing, l)
626
		_							= (Nothing, l)
627 628 629 630 631 632 633 634
JSONDecode{|(,,,)|} fx fy fz fi _ l	= (Nothing, l)

JSONDecode{|(,,,,)|} fx fy fz fi fj _ l =:[JSONArray [xo,yo,zo,io,jo]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
			(Just y,_)	= case fz False [zo] of
				(Just z,_) = case fi False [io] of
					(Just i,_)	= case fj False [jo] of
635 636 637 638 639 640
						(Just j,_)		= (Just (x,y,z,i,j), xs)
						_				= (Nothing, l)
					_					= (Nothing, l)
				_						= (Nothing, l)
			_							= (Nothing, l)
		_								= (Nothing, l)
641
JSONDecode{|(,,,,)|} fx fy fz fi fj _ l	= (Nothing, l)
642

643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658
JSONDecode{|(,,,,,)|} fx fy fz fi fj fk _ l =:[JSONArray [xo,yo,zo,io,jo,ko]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
			(Just y,_)	= case fz False [zo] of
				(Just z,_) = case fi False [io] of
					(Just i,_)	= case fj False [jo] of
						(Just j,_)		= case fk False [ko] of
                            (Just k, _) = (Just (x,y,z,i,j,k), xs)
                            _           = (Nothing, l)
						_				= (Nothing, l)
					_					= (Nothing, l)
				_						= (Nothing, l)
			_							= (Nothing, l)
		_								= (Nothing, l)
JSONDecode{|(,,,,,)|} fx fy fz fi fj fk _ l	= (Nothing, l)

659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696
JSONDecode{|(,,,,,,)|} fx fy fz fi fj fk fm _ l =:[JSONArray [xo,yo,zo,io,jo,ko,mo]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
			(Just y,_)	= case fz False [zo] of
				(Just z,_) = case fi False [io] of
					(Just i,_) = case fj False [jo] of
						(Just j,_) = case fk False [ko] of
                            (Just k, _) = case fm False [mo] of
                              (Just m, _) = (Just (x,y,z,i,j,k,m), xs)
                              _           = (Nothing, l)
                            _           = (Nothing, l)
						_				= (Nothing, l)
					_					= (Nothing, l)
				_						= (Nothing, l)
			_							= (Nothing, l)
		_								= (Nothing, l)
JSONDecode{|(,,,,,,)|} fx fy fz fi fj fk fm _ l	= (Nothing, l)

JSONDecode{|(,,,,,,,)|} fx fy fz fi fj fk fm fn _ l =:[JSONArray [xo,yo,zo,io,jo,ko,mo,no]:xs]
	= case fx False [xo] of
		(Just x,_)	= case fy False [yo] of
			(Just y,_)	= case fz False [zo] of
				(Just z,_) = case fi False [io] of
					(Just i,_) = case fj False [jo] of
						(Just j,_) = case fk False [ko] of
                            (Just k, _) = case fm False [mo] of
                              (Just m, _) = case fn False [no] of
                                (Just n, _) = (Just (x,y,z,i,j,k,m,n), xs)
                                _           = (Nothing, l)
                              _           = (Nothing, l)
                            _           = (Nothing, l)
						_				= (Nothing, l)
					_					= (Nothing, l)
				_						= (Nothing, l)
			_							= (Nothing, l)
		_								= (Nothing, l)
JSONDecode{|(,,,,,,,)|} fx fy fz fi fj fk fm fn _ l	= (Nothing, l)

697
JSONDecode{|{}|} fx _ l =:[JSONArray items:xs]
698 699 700
	= case decodeItems fx items of
		(Just x)		= (Just {e \\ e <- x}, xs)
		_				= (Nothing, l)
701
JSONDecode{|{}|} fx _ l = (Nothing, l)
702

703
JSONDecode{|{!}|} fx _ l =:[JSONArray items:xs]
704 705 706
	= case decodeItems fx items of
		(Just x)		= (Just {e \\ e <- x}, xs)
		_				= (Nothing, l)
707
JSONDecode{|{!}|} fx _ l = (Nothing, l)
708

709
decodeItems :: !(Bool [JSONNode] -> (Maybe a, [JSONNode])) ![JSONNode] -> Maybe [a]
710
decodeItems fx [] 		= Just []
711
decodeItems fx [ox:oxs]	= case fx False [ox] of
712 713 714 715
	(Just x, _)	= case decodeItems fx oxs of
		(Just xs)	= Just [x:xs]
		_ 			= Nothing
	_			= Nothing
716

717 718 719 720 721 722 723 724 725 726 727 728 729 730
// When not in a record, treat Maybe normally
JSONDecode{|Maybe|} fx False [JSONArray [JSONString "Nothing"]:xs] = (Just Nothing, xs)
JSONDecode{|Maybe|} fx False [JSONArray [JSONString "Just":l]:xs]
  = case fx False l of
      (Just x, _) = (Just (Just x), xs)
      _           = (Nothing, l)
// Maybe is treated a bit special in record fields for efficiency
JSONDecode{|Maybe|} fx True [JSONNull:xs] = (Just Nothing, xs) // Interpret null as Nothing
JSONDecode{|Maybe|} fx True []            = (Just Nothing, []) // Interpret absentness as Nothing
JSONDecode{|Maybe|} fx True l
  = case fx False l of                  // Interpret existense as Just
      (Just x,xs)                         = (Just (Just x), xs)
      _                                   = (Nothing, l)
JSONDecode{|Maybe|} _ _ l               = (Nothing, l) // If all else fails... Nothing
731

732
JSONDecode{|JSONNode|} _ [node:xs]      = (Just node, xs)
733
JSONDecode{|JSONNode|} True []			= (Just JSONNull, []) //In record fields, fields with value JSONNull are removed
734
JSONDecode{|JSONNode|} _ l				= (Nothing, l)
735

736 737 738 739 740 741
jsonQuery :: !String !JSONNode -> Maybe a | JSONDecode{|*|} a
jsonQuery path node
	= case (findNode (split "/" path) node ) of
		Just child	= fromJSON child
		Nothing		= Nothing
where
742
	findNode :: ![String] !JSONNode -> Maybe JSONNode
743 744 745 746 747 748
	findNode [] node	= Just node
	findNode [s:ss] (JSONObject fields)
		= case findField s fields of
			Just f	= findNode ss f
			Nothing	= Nothing
	findNode [s:ss] (JSONArray items)
749
		#! index = toInt s
750 751 752 753
		| index >= 0 && index < length items	= findNode ss (items !! index)
		| otherwise								= Nothing
	findNode _ _		= Nothing
	
754
    findField :: !String ![(String, JSONNode)] -> Maybe JSONNode
755 756
	findField s []			= Nothing
	findField s [(l,x):xs]	= if (l == s) (Just x) (findField s xs)
Jeroen Henrix's avatar
Jeroen Henrix committed
757

758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
instance == JSONNode where
  (==) JSONNull        JSONNull        = True
  (==) (JSONBool x)    (JSONBool y)    = x == y
  (==) (JSONInt x)     (JSONInt y)     = x == y
  (==) (JSONReal x)    (JSONReal y)    = toString x == toString y
  (==) (JSONInt x)     (JSONReal y)    = toString (toReal x) == toString y
  (==) (JSONReal x)    (JSONInt y)     = toString x == toString (toReal y)
  (==) (JSONString x)  (JSONString y)  = x == y
  (==) (JSONArray xs)  (JSONArray ys)  = xs == ys
  (==) (JSONObject xs) (JSONObject ys) = sortBy cmpFst (filter (notNull o snd) xs) == sortBy cmpFst (filter (notNull o snd) ys)
    where
    cmpFst :: !(!a, b) !(!a, c) -> Bool | < a
    cmpFst a b = fst a < fst b
    notNull :: !JSONNode -> Bool
    notNull JSONNull = False
    notNull _        = True
  (==) (JSONRaw x)     (JSONRaw y)     = x == y
  (==) JSONError       JSONError       = True
  (==) _               _               = False
777

778 779
gEq{|JSONNode|} x y = x == y

780
jsonPrettyPrint :: !JSONNode -> String
781 782 783 784 785 786 787
jsonPrettyPrint json = display (renderPretty 0.0 400 (pretty json))

instance Pretty JSONNode
where
	pretty JSONNull 			= string "null"
	pretty (JSONBool x)			= string (if x "true" "false")
	pretty (JSONInt x)			= string (toString x)
788
	pretty (JSONReal x)			= string (jsonRealtoString x)
789 790 791 792 793
	pretty (JSONString x)		= dquotes (string (jsonEscape x))
	pretty (JSONArray nodes)	= list (map pretty nodes)
	pretty (JSONObject attr)	= encloseSep lbrace rbrace comma [dquotes (string label) <-> colon <-> pretty val \\ (label,val) <- attr]
	pretty (JSONRaw x)			= string x
	pretty JSONError			= string "null"
794 795 796 797 798 799 800 801

jsonRealtoString :: !Real -> String
jsonRealtoString x
	| isInfinity x
		| x < 0.0 = "-1.e+9999"
		= "1.e+9999"
	| isNaN x = toString JSONNull
	= toString x