{json.r JSON to Rebol converter for REBOL(TM)
Copyright (c) 2005-2013 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: 5-Sep-2013
    Version: 0.0.9
    History: [
        0.0.1 13-Nov-2003 "First release" Romano
        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.
        }
        0.0.7 21-Apr-2008 {
        	Doug Crockford is confident that comments will not be re-added
        	to the JSON spec, so all comment support has been removed.
        	The comment rules also handled whitespace, so there have been a
        	number of rule changes due to that.
        } Gregg
        0.0.8 1-Feb-2010 {
            Fixed naive escaping.
        } Gregg
        0.0.9 5-Sep-2013 {
            Changed property-list and array-list rules to use ANY instead of
            recursion, to handle larger datasets without hitting PARSE limits.
        } Gregg
    ]
    Purpose: "Convert a JSON string to Rebol data, and vice versa."
    Notes: {
        From Romano:
        
        - 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.
        				; BSD/MIT is closer to JSON, but Romano used GPL.
        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]

    make-translate-func: func [
        table [series!] "Escape table, as pairs of from/to string! or char! values."
        /local make-rule rules
    ][
        ; There are some NEW-LINE calls in this function, which may seem
        ; superfluous. It's true that it may be a rare case where you want to
        ; inspect the generated function if used dynamically, but this may also
        ; be used to generate static functions to be included. That is, you may
        ; use it as a code generator. In that case, the extra formatting helps.
        
        make-rule: func [
            "Returns a parse rule to translate one value to another in the input."
            orig
            new
        ] [
            orig: form orig
            new: form new
            new-line/all compose [
                (orig)
                (to-paren compose [pos: change/part pos (new) (length? orig)])
                :pos
            ] off
        ]

        ; Create a block of parse rules from the table of value translations.        
        rules: copy []
        foreach [from to] table [
            repend rules [make-rule from to '|]
        ]
        append rules 'skip ; The final rule

        ; Make the formatting of the generated code a little nicer, putting 
        ; each parse rule on a separate line.
        new-line rules on
        new-line/skip next rules on 2
        
        ; Return a function that uses the parse rules we just generated from 
        ; the map.
        func [
            "Return a copy of the input string, after translating values."
            string [any-string!]
            /local pos
        ] compose/deep [
            parse/all string [any [pos: (rules)]]
            string
        ]
        
    ]

    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)
        space opt property-list
        #"}" (
            res: back pop res: either make-objects? [
                change res make object! first res
            ][
                change/only res make emit-type first res
            ]
        )
    ]
    property-list: [
        ; 05-Sep-2013 changed from using property-list rule recursively to using ANY.
        ; i.e., was: property opt [sep property-list]
        property any [sep property]
    ]
    property: [
        string-literal space #":" (emit either make-objects? [to-set-word s] [s])
        JSON-value
    ]
    array-list: [
        ; 05-Sep-2013 changed from using array-list rule recursively to using ANY.
        ; i.e., was: JSON-value opt [sep array-list]
        JSON-value any [sep JSON-value]
    ]
    JSON-array: [
        #"[" (push emit copy [] res: res/-1)
        space opt array-list
        #"]" (res: pop)
    ]

    JSON-value: [
    	space
    	[
	        "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
	    ]
	    space
    ]
    ex-chars: charset {\"^-^/}
    chars: complement ex-chars
    escaped: charset {"\/>bfnrt}
    escape-table: [
    ;   JSON REBOL
        {\"} "^""   ; " reset syntax highlighting
        {\\} "\"
        {\/} "/"
        {\>} ">"
        {\b} "^H"
        {\f} "^L"
        {\r} "^M"
        {\n} "^/"
        {\t} "^-"
    ]
    
    esc-json-to-reb: make-translate-func escape-table
    esc-reb-to-json: make-translate-func reverse copy escape-table
    
    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
                esc-json-to-reb s
            ]
        )
    ]

	; 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 [""] [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-cleanup: make-translate-func ["{ " "{"  "[ " "["  " }" "}"  " ]" "]"]

    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 [
            single-line-cleanup s
        ] [val]
    ]

    json-escaped-str: func [val] [
        esc-reb-to-json val
        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
    ]
]