Archive version of: json.r ... version: 3 ... greggirwin 20-Apr-2008

Amendment note: Cleanup and adjustment for changes in the JSON spec. || Publicly available? Yes

{json.r JSON to Rebol converter for REBOL(TM)
Copyright (c) 2005-2008 JSON.org

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The Software shall be used for Good, not Evil.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
}

rebol [
    File: %json.r
    Title: "JSON to Rebol converter"
    Author: ["Romano Paolo Tenca" "Gregg Irwin" "Douglas Crockford"]
    Date: 20-Apr-2008
    Version: 0.0.6
    History: [
        0.0.1 13/11/03 "First release"
        0.0.2 26-Jan-2005 {
            Fixed array parsing
            Fixed empty string parsing
            Added comment parsing
            Added REBOL-to-JSON conversion
            Added option to output hash! instead of object! values (to test)
        } Gregg
        0.0.3 27-Jan-2005 {
            Aligned code with Romano's latest changes.
        } Gregg
        0.0.4 31-May-2005 {
            Added unicode decoding. (I think they were Romano's funcs I added)
        } Gregg
        0.0.5 14-Apr-2008 {
            Added "/" to the escaped char list (found by Will Arp).
        } Gregg
        0.0.6 20-Apr-2008 {
        	Cleanup and adjustment for changes in the spec. I've left the 
			comment support in place for now, though Doug Crockford says 
			there are no comments in JSON.

			Checked against the test suite from JSON.org. Test #18 should 
			fail, but doesn't. It's a depth limit not enforced here.
        }
    ]
    Purpose: "Convert a JSON string to Rebol data, and vice versa"
    Notes: {
        - parse rules can be more robust if loops are used instead of
          recursion I used recursion to remain near the bnf grammar

        - todo: better error handling

        - because json has relaxed limits about property names
          in the rebol object can appear words that load cannot understand
          for example:
                ;json
                {"/word": 3}
            become
                ;rebol
                make object! [
                    /word: 3
                ]
            can be a problem if you do:

                load mold json-to-rebol str

            (Gregg added option to convert to objects or hashes as a test)

    }
    library: [
        level: 'intermediate
        platform: 'all
        type: [tool]
        domain: [xml parse]
        tested-under: none
        support: none
        license: 'GPL ; should be "JSON", but REBOL.org doesn't support that.
        see-also: none
    ]
]

json-ctx: context [
    emit-type: object!
    make-objects?: does [object! = emit-type]
    cache: copy []
    push: func [val] [cache: insert/only cache val]
    pop: has [tmp] [tmp: first cache: back cache remove cache tmp]
    out: res: s: none
    emit: func [value][res: insert/only res value]

    decode-unicode-char: func [val /local c] [
        c: to-integer debase/base val 16
        rejoin either c < 128 [[to-char c]] [
            either c < 2048 [[
                to-char (192 or to-integer (c / 64))
                to-char (128 or (c and 63))
            ]] [[
                to-char (224 or to-integer (c / 4096))
                to-char (128 or ((to-integer (c / 64)) and 63))
                to-char (128 or (c and 63))
            ]]
        ]
    ]
    replace-unicode-escapes: func [s [string!] /local c uc] [
        parse s [
            any [
                some chars
                | [mark: #"\"
                   #"u" copy c 4 hex-c (
                    change/part mark uc: decode-unicode-char c 6  ; 6 = length "\uxxxx"
                    ) -1 skip :mark
                | escaped]
            ]
        ]
    ]

    encode-control-char: func [char [char! integer!]] [
         join "\u" at to-hex to integer! char 5
    ]

    escape-control-chars: func [
        "Convert all control chars in string to \uxxxx format"
        s [any-string!] /local ctrl-ch c
    ][
        ctrl-ch: charset [#"^@" - #"^_"]
        parse/all s [
            any [
                mark: copy c ctrl-ch (
                    change/part mark encode-control-char to char! c 1
                ) 5 skip
                | skip
            ]
        ]
        s
    ]

    ;rules
    space-char: charset " ^-^/"
    space: [any space-char]
    sep: [space #"," space]
    JSON-object: [
        #"{" (push res: insert/only res copy [] res: res/-1)
        comments opt property-list comments
        #"}" (
            res: back pop res: either make-objects? [
                change res make object! first res
            ][
                change/only res make emit-type first res
            ]
        )
    ]
    property-list: [
        property opt [sep comments property-list]
    ]
    property: [
        string-literal space #":" (emit either make-objects? [to-set-word s] [s])
        comments JSON-value comments
    ]
    array-list: [
        JSON-value opt [sep comments array-list]
    ]
    JSON-array: [
        #"[" (push emit copy [] res: res/-1)
        comments opt array-list comments
        #"]" (res: pop)
    ]

    single-line-comment: ["//" thru newline]
    ; JSON doesn't support nested comments, but this does.
    multi-line-comment:  [
        "/*" any [
            "*/" break | single-line-comment | multi-line-comment | skip
        ]
    ]
    comment:  [single-line-comment | multi-line-comment]
    comments: [any [space-char | comment]]

    JSON-value: [
        comment |
        "true"  (emit true)  |
        "false" (emit false) |
        "null"  (emit none)  |
        JSON-object |
        JSON-array  |
        string-literal (emit s) |
        copy s numeric-literal (emit load s)
        mark:   ; set mark for failure location
    ]
    ex-chars: charset {\"^-^/}
    chars: complement ex-chars
    escaped: charset {"\/>bfnrt}
    escape-table: [
        {\"} "^""
        {\\} "\"
        {\/} "/"
        {\>} ">"
        {\b} "^H"
        {\f} "^L"
        {\r} "^M"
        {\n} "^/"
        {\t} "^-"
    ]
    digits: charset "0123456789"
    non-zero-digits: charset "123456789"
    hex-c: union digits charset "ABCDEFabcdef"

    string-literal: [
        #"^"" copy s [
            any [some chars | #"\" [#"u" 4 hex-c | escaped]]
        ] #"^"" (
            if not empty? s: any [s copy ""] [
                replace-unicode-escapes s
                foreach [from to] escape-table [replace/all s from to]
            ]
        )
    ]

	; Added = naming convention to these rules to avoid naming confusion
	; with sign, int, exp, and number. Those names are used here to match
	; the names in the JSON spec on JSON.org.
	sign=: [#"-"]
    ; Integers can't have leading zeros, but zero by itself is valid.
	int=: [[1 1 non-zero-digits any digits] | [1 1 digits]]
	frac=: [#"." some digits]
	exp=: [#"e" opt [#"+" | #"-"] some digits]
	number=: [
		opt sign= int= opt [frac= exp= | frac= | exp=]
	]
    numeric-literal: :number=

    ;public functions
    system/words/JSON-to-REBOL: JSON-to-REBOL: func [
        [catch]
        "Convert a JSON string to rebol data"
        str [string!] "The JSON string"
        /objects-to "Convert JSON objects to blocks instead of REBOL objects"
            type [datatype!] "Specific block type to make (e.g. hash!)"
    ][
        if all [type  not any-block? make type none] [
            throw make error! "Only block types can be used for object output"
        ]
        emit-type: any [type object!]
        out: res: copy []
        mark: str
        ;either parse/all str [any [comments JSON-value] comments] [
        either parse/all str [space [JSON-object | JSON-array] space] [
            pick out 1
        ][
            throw make error! reform [
                "Invalid JSON string. Near:"
                either tail? mark ["<end of input>"] [mold copy/part mark 40]
            ]
        ]
    ]

    ;-----------------------------------------------------------
    ;-- REBOL to JSON conversion
    ;-----------------------------------------------------------
    dent:    copy ""
    dent-size: 4
    indent:  does [insert/dup dent #" " dent-size]
    outdent: does [remove/part dent dent-size]
    pad-names: off
    padded-name-len: 0

    ; Is this ugly or what?!
    longest-field-name: func [obj [object!] /local flds] [
        flds: copy next first obj
        if empty? flds [return none]
        forall flds [flds/1: form flds/1]
        flds: head flds
        sort/compare flds func [a b] [(length? a) < (length? b)]
        last flds
    ]

    pad: func [string len] [
        head insert/dup tail string #" " len - length? string
    ]

    set-padded-name-len: func [obj] [
        ; add 3 to account for quotes and colon
        padded-name-len: 3 + length? any [longest-field-name obj ""]
    ]

    single-line-reformat: func [
        "Reformats a block/object to a single line if it's short enough."
        val /local s map
    ] [
        either 80 >= length? join dent s: trim/lines copy val [
            map: ["{ " "{"  "[ " "["  " }" "}"  " ]" "]"]
            foreach [from to] map [replace s from to]
        ] [val]
    ]

    json-escaped-str: func [val] [
        foreach [from to] escape-table [replace/all val to from]
        escape-control-chars val
    ]

    reb-to-json-name: func [val] [
        pad join mold form val ":" padded-name-len
    ]

    add-quotes: func [str] [append insert str {"} {"}]

    reb-to-JSON-value: func [val /local tmp] [
        switch/default type?/word val [
            none!    ["null"]
            logic!   [pick ["true" "false"] val]
            integer! [form val]
            decimal! [form val]
            ;string!  [add-quotes json-escaped-str copy val]
            object!  [reb-to-json-object val]
            word!    [reb-to-JSON-value get val]
        ] [
            either any-block? val [reb-to-json-block val] [
                add-quotes either any-string? val [
                    json-escaped-str copy val
                ] [form val]
            ]
        ]
    ]

    reb-to-json-block: func [block [any-block!] /local result sep] [
        indent
        result: copy "[^/"
        foreach value block [
            append result rejoin [dent reb-to-JSON-value value ",^/"]
        ]
        outdent
        append clear any [find/last result ","  tail result] rejoin ["^/" dent "]"]
        single-line-reformat result
    ]

    reb-to-json-object: func [object [object!] /local result sep] [
        if pad-names [set-padded-name-len object]
        indent
        result: copy "{^/"
        foreach word next first object [
            append result rejoin [
                dent reb-to-json-name :word " "
                reb-to-JSON-value object/:word ",^/"
            ]
        ]
        outdent
        append clear any [find/last result ","  tail result] rejoin ["^/" dent "}"]
        single-line-reformat result
    ]

    ;public functions
    system/words/rebol-to-json: rebol-to-json: func [
        [catch]
        "Convert REBOL data to a JSON string"
        data
        /pad-names "pad property names with spaces so values line up"
        /block-indent "Number of spaces to indent nested structures"
            size [integer!]
        /local result
    ][
        dent-size: any [size 4]
        self/pad-names: pad-names
        result: make string! 4000
        foreach value compose/only [(data)] [
            append result reb-to-JSON-value value
        ]
        result
    ]
]