altjson.r

Rebol [
	Title: "JSON Parser/Encoder for Rebol 2"
	Author: "Christopher Ross-Gill"
	Date: 22-Sep-2015
	Home: http://www.ross-gill.com/page/JSON_and_Rebol
	File: %altjson.r
	Version: 0.3.6
	Purpose: "Convert a Rebol block to a JSON string"
	Rights: http://opensource.org/licenses/Apache-2.0
	Type: 'module
	Name: 'rgchris.altjson
	Exports: [load-json to-json]
	History: [
		22-Sep-2015 0.3.6 "Sync with v0.3.6 for Rebol 3"
		07-Jul-2014 0.3.0 "Initial support for JSONP"
		15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
		02-Dec-2010 0.2.5 "Support for time! added"
		28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
		06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
		22-May-2005 0.1.0 "Original Version"
	]
	Notes: {
		- Simple Escaping
		- Converts date! to RFC 3339 Date String
	}
]

load-json: use [
	tree branch here val is-flat emit new-child to-parent neaten
	space word comma number string block object _content value ident
][
	branch: make block! 10

	emit: func [val][here: insert/only here val]
	new-child: [(insert/only branch insert/only here here: copy [])]
	to-parent: [(here: take branch)]
	neaten: [
		(new-line/all head here true)
		(new-line/all/skip head here true 2)
	]

	word: use [word1 word+ special escapes escape wordify][
		word1: charset ["!&*=?_|~" #"A" - #"Z" #"a" - #"z"]
		word+: charset ["!&'*+-.0123456789=?_|~" #"A" - #"Z" #"a" - #"z"]
		special: charset "^-^/ &'+-.0123456789^^"

		escapes: [#"^-" "^^t" #"^/" "^^n" #" " "^^_"]

		escape: use [mk][
			[
				mk: special (
					mk: change/part mk any [
						select escapes mk/1
						join "^^" mk/1
					] 1
				) :mk
			]
		]

		wordify: func [value /local mk][
			if parse/all value: copy value [
				[some word1 | escape]
				any [some word+ | escape]
			][
				if value = "self" [value: "^^self"]
				to set-word! value
			]
		]

		[#"^"" copy val some [word1 | special] #"^"" (val: wordify val)]
	]

	space: use [space][
		space: charset " ^-^/^M"
		[any space]
	]

	comma: [space #"," space]

	number: use [dg ex nm as-num][
		dg: charset "0123456789"
		ex: [[#"e" | #"E"] opt [#"+" | #"-"] some dg]
		nm: [opt #"-" some dg opt [#"." some dg] opt ex]

		as-num: func [val /num][
			num: load val

			all [
				parse val [opt "-" some dg]
				decimal? num
				num: to issue! val
			]

			num
		]

		[copy val nm (val: as-num val)]
	]

	string: use [ch dq es hx mp decode][
		ch: complement charset {\"}
		es: charset {"\/bfnrt}
		hx: charset "0123456789ABCDEFabcdef"
		mp: [#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-"]

		decode: use [ch mk escape to-utf-char][
			to-utf-char: use [os fc en][
				os: [0 192 224 240 248 252]
				fc: [1 64 4096 262144 16777216 1073741824]
				en: [127 2047 65535 2097151 67108863 2147483647]

				func [int [integer!] /local char][
					repeat ln 6 [
						if int <= en/:ln [
							char: reduce [os/:ln + to integer! (int / fc/:ln)]
							repeat ps ln - 1 [
								insert next char (to integer! int / fc/:ps) // 64 + 128
							]
							break
						]
					]

					to string! to binary! char
				]
			]

			escape: [
				mk: #"\" [
					  es (mk: change/part mk select mp mk/2 2)
					| #"u" copy ch 4 hx (
						mk: change/part mk to-utf-char to integer! to issue! ch 6
					)
				] :mk
			]

			func [text [string! none!] /mk][
				either none? text [copy ""][
					all [parse/all text [any [to "\" escape] to end] text]
				]
			]
		]

		[#"^"" copy val [any [some ch | #"\" [#"u" 4 hx | es]]] #"^"" (val: decode val)]
	]

	block: use [list][
		list: [space opt [value any [comma value]] space]

		[#"[" new-child list #"]" neaten/1 to-parent]
	]

	_content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr

	object: use [name list as-object token][
		name: [
			token space #":" space
			(emit either is-flat [to tag! val][val])
		]
		list: [
			(token: either is-flat [string][word])
			space opt [name value any [comma name value]] space
		]
		as-object: [(unless is-flat [here: change back here make object! here/-1])]

		[#"{" new-child list #"}" neaten/2 to-parent as-object]
	]

	ident: use [initial ident][
		initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
		ident: union initial charset [#"0" - #"9"]

		[initial any ident]
	]

	value: [
		  "null" (emit none)
		| "true" (emit true)
		| "false" (emit false)
		| number (emit val)
		| string (emit val)
		| _content
		| object | block
	]

	func [
		[catch] "Convert a JSON string to Rebol data"
		json [string! binary! file! url!] "JSON string"
		/flat "Objects are imported as tag-value pairs"
		/padded "Loads JSON data wrapped in a JSONP envelope"
	][
		is-flat: :flat
		tree: here: copy []
		if any [file? json url? json][
			if error? json: try [read (json)][
				throw :json
			]
		]
		unless parse/all json either padded [
			[space ident space "(" space opt value space ")" opt ";" space]
		][
			[space opt value space]
		][
			throw make error! either is-flat [
				"Not a valid JSON string"
			][
				"Cannot load JSON string, try in /FLAT mode"
			]
		]
		pick tree 1
	]
]

to-json: use [
	json emit emits escape to-token emit-issue emit-date
	here lookup comma block block-of-pairs object value
][
	emit: func [data][repend json data]
	emits: func [data][emit {"} emit data emit {"}]

	escape: use [mp ch es encode][
		mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
		ch: complement es: charset extract mp 2
		encode: func [here][change/part here select mp here/1 1]

		func [txt][
			parse/all txt [any [txt: some ch | es (txt: encode txt) :txt]]
			head txt
		]
	]

	to-token: use [special escapes mark][
		special: charset "&'+-.0123456789nst^^_"
		escapes: [#"t" "^-" #"n" "^/" #"_" " "]

		func [name [set-word!]][
			if parse/all name: to string! name [
				some [
					mark: "^^" special (
						mark: change/part mark any [
							select escapes mark/2
							mark/2
						] 2
					) :mark
					| skip
				]
			][
				name
			]
		]
	]

	emit-issue: use [dg nm][
		dg: charset "0123456789"
		nm: [opt "-" some dg]

		[(either parse/all here/1 nm [emit here/1][emits here/1])]
	]

	emit-date: use [pad second][
		pad: func [part length][
			part: to string! part head insert/dup part "0" length - length? part
		]

		[(
			emits rejoin collect [
				keep reduce [pad here/1/year 4 "-" pad here/1/month 2 "-" pad here/1/day 2]
				if here/1/time [
					keep reduce ["T" pad here/1/time/hour 2 ":" pad here/1/time/minute 2 ":"]
					second: parse/all to string! here/1/time/second "."
					keep pad second/1 2
					unless second/2 = "0" [keep join "." second/2]

					keep either any [
						none? here/1/zone
						zero? here/1/zone
					]["Z"][
						reduce [
							either here/1/zone/hour < 0 ["-"]["+"]
							pad abs here/1/zone/hour 2 ":" pad here/1/zone/minute 2
						]
					]
				]
			]
		)]
	]

	lookup: [
		here: [get-word! | get-path!]
		(change here reduce reduce [here/1])
		end skip
	]

	comma: [(if not tail? here [emit ","])]

	block: [(emit "[") any [here: value here: comma] (emit "]")]

	block-of-pairs: [
		  some [set-word! skip]
		| some [tag! skip]
	]

	object: [
		(emit "{")
		any [
			here: [set-word! (change here to-token here/1) | tag!]
			(emit [{"} escape to string! here/1 {":}])
			here: value here: comma
		]
		(emit "}")
	]

	value: [
		  lookup
		| number! (emit here/1)
		| [logic! | 'true | 'false] (emit to string! here/1)
		| [none! | 'none] (emit 'null)
		| date! emit-date
		| issue! emit-issue
		| [
			any-string! | word! | lit-word! | tuple! | pair! | money! | time!
		] (emits escape form here/1)
		| any-word! (emits escape form to word! here/1)

		| object! :here (change/only here body-of first here) into object
		| into block-of-pairs :here (change/only here copy first here) into object
		| any-block! :here (change/only here copy first here) into block

		| any-type! (emits to tag! type?/word first here)
	]

	func [
		"Convert a Rebol value to JSON string"
		item [any-type!] "Rebol value to convert"
	][
		json: make string! ""
		if parse compose/only [(item)][here: value][json]
	]
]