jimson

aspect 2015-02-25: A bug report against jimhttp

in which EF and dbohdan discusses handling json stringification with a type schema. It echoed ideas I had some time ago but never fully developed, but more fully formed. I got excited and hacked this up. While jimhttp's json.tcl is compatible with Tcl 8.5+, this isn't compatible with Jim. And I only have an hour to spend, so it's not compatible with the required signature. But hopefully it's mostly correct, and not too hard to hammer into shape.

Tests at the bottom serve as an example of use. Please report obvious errors!

proc assert {x {msg ""}} {
    if {![uplevel 1 expr [list $x]]} {
        catch {
            set y [uplevel 1 subst [list $x]]
            if {$y ne $x} {
                set x "{$y} from {$x}"
            }
        }
        throw ASSERT "[concat "Assertion failed!" $msg] $x"
    }
}

proc is_dict {d} {
    try {
        dict size $d
    } on error {} {
        return false
    }
}

proc range {a {b ""}} {
    if {$b eq ""} {
        set b $a
        set a 0
    }
    for {set r {}} {$a<$b} {incr a} {
        lappend r $a
    }
    return $r
}

proc prefix_matches {prefix keys} {
    lmap key $keys {
        if {[string match $prefix* $key]} {
            set key
        } else {
            continue
        }
    }
}

proc unique_prefix {prefix keys} {
    set m [prefix_matches $prefix $keys]
    if {[llength $m] == 1} {
        lindex $m 0
    } else {
        return ""
    }
}

proc dict_glob {dict key} {
    set idx {}
    foreach elem $key {
        if {[dict exists $dict {*}$idx $elem]} {
            lappend idx $elem
        } elseif {[dict exists $dict {*}$idx *]} {
            lappend idx *
        } else {
            return ""
        }
    }
    return $idx
}

proc stringify_string {s} {
    # FIXME: more quoting?
    return "\"[string map {{"} {\"}} $s]\""
    # "\" vim gets confused!
}


proc stringify {dict {schema {}} {key {}}} {
    if {$key ne ""} {
        if {![dict exists $dict {*}$key]} {
            error "this can't happen"
        }
        set value [dict get $dict {*}$key]
        if {[dict exists $schema {*}$key]} {
            set type [dict get $schema {*}$key]
        } else {
            set realkey [dict_glob $schema $key]
            if {$realkey ne ""} {
                set type [dict get $schema {*}$realkey]
            } else {
                set type ""
            }
        }
    } else {
        set value $dict
        set type $schema
    }
    if {$type ne ""} {
        set type [unique_prefix $type {number string boolean null object array}]
    }
    if {$type eq ""} {
        if {![is_dict $value]} {
            if {[string is double -strict $value]} {
                set type "number"
            } else {
                set type "string"
            }
        } else {
            if {[dict keys $value] eq [range [dict size $value]]} {
                set type "array"
            } else {
                set type "dict"
            }
        }
    }

    switch -exact $type {
        "number" {
            return "$value"
        }
        "null" {
            return "null"
        }
        "boolean" {
            return [expr {$value ? "true" : "false"}]
        }
        "string" {
            # FIXME: quote quotes.  And maybe other things?
            return [stringify_string $value]
        }
        "dict" {
            set i 0
            set body [lmap {k v} $value {
                set res [stringify_string $k]
                append res ":"
                append res [stringify $dict $schema [list {*}$key $k]]
            }]
            return "{[join $body ,]}"
        }
        "array" {
            set body {}
            for {set i 0} {$i < [dict size $value]} {incr i} {
                lappend body [dict get $value $i]
            }
            return "\[[join $body ,]\]"
        }
    }
}

proc tests {} {
    assert {[prefix_matches foo {food bard foop}] eq {food foop}}
    assert {[prefix_matches foo {{food bard} baz}] eq {{food bard}}}

    assert {[unique_prefix foo {food bard foop}] eq ""}
    assert {[unique_prefix foo {foo\ d bard fop}] eq "foo d"}

    assert {[dict_glob {a {* s}} {a b}] eq {a *}}
    assert {[dict_glob {a {b s}} {a *}] eq {}}
    assert {[dict_glob {a {* s}} {b b}] eq {}}

    assert {[stringify {a 1 b 2}] eq {{"a":1,"b":2}}}
    assert {[stringify {a 1 b foo}] eq {{"a":1,"b":"foo"}}}
    assert {[stringify {0 1 1 3}] eq {[1,3]}}
    assert {[stringify {0 1 1 3} string] eq {"0 1 1 3"}}
    assert {[stringify {113} num] eq {113}}
    assert {[stringify \" str] eq {"\""}}
    assert {[stringify {a 1 b 2} {b s}] eq {{"a":1,"b":"2"}}}
    assert {[stringify {a 1 b {1 2 3 4}}] eq {{"a":1,"b":{"1":2,"3":4}}}}
    assert {[stringify {a 1 b {1 2 3 4}} {b s}] eq {{"a":1,"b":"1 2 3 4"}}}
    assert {[stringify {a 1 b 2} {* s}] eq {{"a":"1","b":"2"}}}
    assert {[stringify {a 1 b {1 2 3 4}} {b {* s}}] eq {{"a":1,"b":{"1":"2","3":"4"}}}}
    puts "ok"
}

catch {if {[info script] eq $::argv0} tests}