Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
456 lines (394 sloc) 10.4 KB
Red [
Title: "JSON Decoder/Encoder for Red"
Author: "Christopher Ross-Gill"
Date: 24-Feb-2018
Home: http://www.ross-gill.com/page/JSON_and_Rebol
File: %altjson.red
Version: 0.4.1
Purpose: "Convert a Red block to a JSON string"
Rights: http://opensource.org/licenses/Apache-2.0
Type: 'module
Name: 'rgchris.altjson
Exports: [load-json to-json]
History: [
24-Feb-2018 0.4.1 "Red Compiler Friendly"
24-Feb-2018 0.4.0 "New TO-JSON engine, /PRETTY option"
12-Sep-2017 0.3.6.1 "Red Compatibilities"
18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
21-Apr-2015 0.3.3 {
- Merge from Reb4.me version
- Recognise set-word pairs as objects
- Use map! as the default object type
- Serialize dates in RFC 3339 form
}
14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
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: {
- Converts date! to RFC 3339 Date String
- Flattens Flickr '_content' objects
- Handles Surrogate Pairs
- Supports JSONP
}
]
json-loader: make object! [
tree: here: mark: current-value: is-flat: none
branch: make block! 10
emit: func [value][here: insert/only here value]
new-child: quote (insert/only branch insert/only here here: make block! 10)
to-parent: quote (here: take branch)
neaten-one: quote (new-line/all head here true)
neaten-two: quote (new-line/all/skip head here true 2)
; upper ranges borrowed from AltXML
word-initial: charset [
"!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
word-chars: charset [
"!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
to-word: function [text [string!]][
all [
parse text [word-initial any word-chars]
to word! text
]
]
space-chars: charset " ^-^/^M"
space: [any space-chars]
comma: [space #"," space]
number-digit: charset "0123456789"
number-exponent: [[#"e" | #"E"] opt [#"+" | #"-"] some number-digit]
number-rule: [opt #"-" some number-digit opt [#"." some number-digit] opt number-exponent]
as-number: func [value [string!]][
case [
not parse value [opt "-" some number-digit][to float! value]
not integer? try [value: to integer! value][to issue! value]
value [value]
]
]
number: [copy current-value number-rule (current-value: as-number current-value)]
string-chars: complement charset {\"}
string-hex: charset "0123456789ABCDEFabcdef"
string-lookup: #(#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-")
string-escapes: charset words-of string-lookup
hex-to-integer: func [part [string!]][
to integer! debase/base part 16
]
string-decode-surrogate: func [high [string!] low [string!]][
#"^(10000)"
+ (shift/left 03FFh and hex-to-integer high 10)
+ (03FFh and hex-to-integer low)
]
string-part: string-pair-high: string-pair-low: none
string-rule: [
string-mark:
some string-chars string-to: (append/part current-value string-mark string-to)
|
#"\" [
string-escapes (
append current-value select string-lookup string-mark/2
)
|
#"u" copy string-pair-high [#"d" [#"8" | #"9" | #"a" | #"b"] 2 string-hex]
"\u" copy string-pair-low [#"d" [#"c" | #"d" | #"e" | #"f"] 2 string-hex]
(append current-value string-decode-surrogate string-pair-high string-pair-low)
|
#"u" copy string-part 4 string-hex (
append current-value to char! hex-to-integer string-part
)
]
]
string: [
#"^"" (current-value: make string! 1024)
any [string-from: string-rule]
#"^""
]
array-elements: [space opt [value any [comma value]] space]
array: [#"[" new-child array-elements #"]" neaten-one to-parent]
_content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr
object-name: [
string space #":" space (
emit either is-flat [
to tag! current-value
][
any [
to-word current-value
current-value
]
]
)
]
object-members: [
space opt [
object-name value
any [comma object-name value]
] space
]
object-as-map: [
(unless is-flat [here: change back here make map! pick back here 1])
]
object-rule: [#"{" new-child object-members #"}" neaten-two to-parent object-as-map]
ident-initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
ident-chars: union ident-initial charset [#"0" - #"9"]
ident: [ident-initial any ident-chars]
value: [
"null" (emit none)
| "true" (emit true)
| "false" (emit false)
| number (emit current-value)
| string (emit current-value)
| _content
| array
| object-rule
]
json-rule: [space opt value space]
padded-json-rule: [space ident space #"(" value #")" space opt #";" space]
load-json: func [json [string!] flat [logic!] padded [logic!]][
is-flat: :flat
tree: here: make block! 16
either parse json either padded [padded-json-rule][json-rule][
take tree
][
do make error! "Not a valid JSON string"
]
]
]
json-emitter: make object! [
json: is-pretty: value: none
emit: func [data][repend json data]
emit-part: func [from [string!] to [string!]][
append/part json from to
]
stack: make block! 16 ; check for recursion
indent: ""
colon: ":"
circular: {["..."]}
unknown: {"\uFFFD"}
increase: func [indent [string!]][
either is-pretty [
append indent " "
][
indent
]
]
decrease: func [indent [string!]][
either is-pretty [
head clear skip tail indent -4
][
indent
]
]
emit-array: func [
elements [block!]
][
emit #"["
unless tail? elements [
increase indent
while [not tail? elements][
emit indent
emit-value pick elements 1
unless tail? elements: next elements [
emit #","
]
]
emit decrease indent
]
emit #"]"
]
emit-object: func [
members [block!]
][
emit #"{"
unless tail? members [
increase indent
while [not tail? members][
emit indent
emit-string pick members 1
emit colon
emit-value pick members 2
unless tail? members: skip members 2 [
emit #","
]
]
emit decrease indent
]
emit #"}"
]
string-escapes: #(#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\")
string-chars: intersect string-chars: charset [#" " - #"~"] difference string-chars charset words-of string-escapes
emit-char: func [char [char!]][
emit ["\u" skip tail form to-hex to integer! char -4]
]
emit-string: function [
value [any-type!]
/local mark extent
][
value: switch/default type?/word value [
string! [value]
get-word! set-word! [to string! to word! value]
binary! [enbase value]
][
to string! value
]
emit #"^""
parse value [
any [
mark: some string-chars extent: (emit-part mark extent)
| skip (
case [
find string-escapes first mark [
emit select string-escapes first mark
]
mark/1 < 65536 [
emit-char first mark
]
mark/1 [ ; surrogate pairs
emit-char mark/1 - 65536 / 1024 + 55296
emit-char mark/1 - 65536 // 1024 + 56320
]
/else [emit "\uFFFD"]
]
)
]
]
emit #"^""
]
emit-date: func [value [date!] /local second][
emit #"^""
emit [
pad/left/with value/year 4 #"0"
#"-" pad/left/with value/month 2 #"0"
#"-" pad/left/with value/day 2 #"0"
]
if value/time [
emit [
#"T" pad/left/with value/hour 2 #"0"
#":" pad/left/with value/minute 2 #"0"
#":"
]
emit pad/left/with to integer! value/second 2 #"0"
any [
".0" = second: find form round/to value/second 0.000001 #"."
emit second
]
emit either any [
none? value/zone
zero? value/zone
][#"Z"][
[
either value/zone/hour < 0 [#"-"][#"+"]
pad/left/with absolute value/zone/hour 2 #"0"
#":" pad/left/with value/zone/minute 2 #"0"
]
]
]
emit #"^""
]
issue-digit: charset "0123456789"
issue-number: [opt #"-" some issue-digit]
emit-issue: function [value [issue!]][
value: next mold value
either parse value issue-number [
emit value
][
emit-string value
]
]
emit-value: func [value [any-type!]][
if any [
get-word? :value
get-path? :value
][
set/any 'value take reduce reduce [value]
]
switch value [
none blank null _ [value: none]
true yes [value: true]
false no [value: false]
]
switch/default type?/word value [
block! [
either find/only/same stack value [
emit circular
][
insert/only stack value
either parse value [some [set-word! skip] | some [tag! skip]][
emit-object value
][
emit-array value
]
remove stack
]
]
object! map! [
either find/same stack value [
emit circular
][
emit-object body-of value
]
]
string! binary! file! email! url! tag! pair! time! tuple! money!
word! lit-word! get-word! set-word! refinement! [
emit-string value
]
issue! [
emit-issue value
]
date! [
emit-date value
]
integer! float! decimal! [
emit to string! value
]
logic! [
emit to string! value
]
none! unset! [
emit "null"
]
paren! path! get-path! set-path! lit-path! [
emit-array value
]
][
emit unknown
]
json
]
to-json: func [value [any-type!] pretty [logic!]][
is-pretty: :pretty
indent: pick ["^/" ""] is-pretty
colon: pick [": " ":"] is-pretty
clear stack
json: make string! 1024
emit-value value
]
]
load-json: func [
"Convert a JSON string to Red data"
json [string!] "JSON string"
/flat "Objects are imported as tag-value pairs"
/padded "Loads JSON data wrapped in a JSONP envelope"
][
json-loader/load-json json flat padded
]
to-json: func [
"Convert a Red value to JSON string"
value [any-type!] "Red value to convert"
/pretty "Format Output"
][
json-emitter/to-json :value pretty
]