chris-rg-json.r3

Rebol [
    Title: "JSON Parser for Rebol 3"
    Author: "Christopher Ross-Gill"
    Date: 18-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: [
        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
    }
]

load-json: use [
    tree branch here val is-flat emit new-child to-parent neaten to-word
    space 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)
    ]

    to-word: use [word1 word+][
        ; upper ranges borrowed from AltXML
        word1: 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+: 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)"
        ]

        func [val [string!]][
            all [
                parse val [word1 any word+]
                to word! 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 [string!]][
            case [
                not parse val [opt "-" some dg][to decimal! val]
                not integer? try [val: to integer! val][to issue! val]
                val [val]
            ]
        ]

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

    string: use [ch 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][
            escape: [
                ; should be possible to use CHANGE keyword to replace escaped characters.
                mk: #"\" [
                    es (mk: change/part mk select mp mk/2 2)
                    |
                    #"u" copy ch 4 hx (
                        mk: change/part mk to char! to integer! debase/base ch 16 6
                    )
                ] :mk
            ]

            func [text [string! none!]][
                either none? text [make string! 0][
                    all [parse 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-map][
        name: [
            string space #":" space (
                emit either is-flat [
                    to tag! val
                ][
                    any [
                        to-word val
                        val
                    ]
                ]
            )
        ]
        list: [space opt [name value any [comma name value]] space]
        as-map: [(unless is-flat [here: change back here make map! pick back here 1])]

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

    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 [
        "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"
    ][
        case/all [
            any [file? json url? json][
                if error? json: try [read/string (json)][
                    do :json
                ]
            ]
            binary? json [json: to string! json]
        ]

        is-flat: :flat
        tree: here: copy []

        either parse json either padded [
            [space ident space "(" space opt value space ")" opt ";" space]
        ][
            [space opt value space]
        ][
            pick tree 1
        ][
            do make error! "Not a valid JSON string"
        ]
    ]
]

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

    escape: use [mp ch encode][
        mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
        ch: intersect ch: charset [#" " - #"~"] difference ch charset extract mp 2

        encode: func [here][
            change/part here any [
                select mp here/1
                join "\u" skip tail form to-hex to integer! here/1 -4
            ] 1
        ]

        func [txt][
            parse txt [any [txt: some ch | skip (txt: encode txt) :txt]]
            head txt
        ]
    ]

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

        [(either parse next form here/1 [copy mk nm][emit mk][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/hour 2 ":" pad here/1/minute 2 ":"]
                    keep either integer? here/1/second [
                        pad here/1/second 2
                    ][
                        second: split to string! here/1/second "."
                        reduce [pad second/1 2 "." 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])
        fail
    ]

    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 word! here/1) | any-string! | any-word!]
            (emit [{"} escape to string! here/1 {":}])
            here: value here: comma
        ]
        (emit "}")
    ]

    value: [
          lookup ; resolve a GET-WORD! reference
        | number! (
            if percent? here/1 [change here to decimal! here/1]
            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! | map!] :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? 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]
    ]
]