namespacify

[scpubgit/TenDotTcl.git] / json.tcl

namespace eval ten::json {

  namespace eval deparse {

    variable quotes [
      list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t
    ]

    variable indent
    variable indentBy 0
    variable indentIncr
    variable nl

    proc indent_one {} {
      variable indentIncr
      variable indentBy [ expr $indentBy + $indentIncr ]
      variable indent [ string repeat " " $indentBy ]
    }

    proc outdent_one {} {
      variable indentIncr
      variable indentBy [ expr $indentBy - $indentIncr ]
      variable indent [ string repeat " " $indentBy ]
    }

    proc str {str} {
      variable quotes
      return \"[ string map $quotes $str ]\"
    }

    proc num {num} {
      return $num
    }

    proc list {args} {
      variable indent
      variable nl
      set out \[
      indent_one
      foreach el [lrange $args 0 end] {
        append out $nl$indent
        append out [ deparse $el ],
      }
      outdent_one
      append out $nl$indent\]
      return $out
    }

    proc obj {args} {
      variable indent
      variable nl
      set out \{
      indent_one
      dict for {k v} $args {
        append out $nl$indent[ str $k ]:\ [ deparse $v ],
      }
      outdent_one
      append out $nl$indent\}
    }

    proc deparse {data} {
      switch -regexp [lindex $data 0] {
        ^(true|false|null)$  { lindex $data 0 }
        ^(num|str|obj|list)$ { eval $data }
        default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
      }
    }
  }

  proc deparse_json {data {indentIncr 2}} {
    set deparse::indentBy 0
    set deparse::indentIncr $indentIncr
    if [expr $indentIncr == 0] {
      set deparse::nl ""
    } else {
      set deparse::nl "\n"
    }
    deparse::deparse $data
  }

  namespace eval tclify {

    proc str {str} { return $str }

    proc num {num} { return $num }

    proc obj {args} {
      return $args
    }

    proc tclify {data} {
      switch -regexp [lindex $data 0] {
        ^(true|false|null)$ { uplevel 1 return [lindex $data 0] }
        ^(num|str|obj|list)$ {}
        default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
      }
      eval $data
    }
  }

  proc tclify_json {data} {
    tclify::tclify $data
  }

  namespace eval parse {

    variable json

    proc eat_spaces {} {
      variable json
      set json [string trimleft $json]
    }

    proc eat_char {char} {
      variable json
      eat_spaces
      if {[string index $json 0] eq "$char"} {
        eat_any
      }
    }

    proc eat_any {} {
      variable json
      set json [ string range $json 1 end ]
    }

    proc parse_list {} {
      variable json
      eat_any
      set tcl {list}
      while {"$json" ne ""} {
        eat_spaces
        if {[string index $json 0] eq "]"} {
          eat_any
          return $tcl
        }
        lappend tcl [ parse ]
        eat_char ,
      }
      error "Ran out of JSON. Confused now."
    }

    proc parse_obj {} {
      variable json
      eat_any
      set tcl {obj}
      while {"$json" ne ""} {
        eat_spaces
        if {[string index $json 0] eq "\}"} {
          eat_any
          return $tcl
        }
        eat_spaces
        lappend tcl [ parse_str ]
        eat_spaces
        eat_char :
        eat_spaces
        lappend tcl [ parse ]
        eat_char ,
      }
      error "Ran out of JSON. Confused now."
    }

    proc parse_str {} {
      variable json
      # like Text::Balanced except ugly (borrowed from tcvJSON's code)
      set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
      if {![regexp $reStr $json string]} {
        error "Invalid string: $json"
      }
      set json [string range $json [string length $string] end]
      # chop off outer ""s and substitute backslashes
      # This does more than the RFC-specified backslash sequences,
      # but it does cover them all
      list str [subst -nocommand -novariable [string range $string 1 end-1]]
    }

    proc parse_num {} {
      variable json
      string is double -failindex last $json
      if {$last == 0} {
        error "Saw number but wasn't - $json"
      }
      set num [string range $json 0 [expr {$last - 1}]]
      set json [string range $json $last end]
      list num $num
    }

    proc parse_bare {} {
      variable json
      if [regexp {^(true|false|null)} $json matched] {
        set json [ string range $json [ string length $matched ] end ]
        return $matched
      } else {
        error "Out of ideas parsing: $json"
      }
    }

    proc parse {} {
      variable json
      eat_spaces
      if {$json eq ""} {
        return
      }
      switch -regexp [string index $json 0] {
        {\{} { parse_obj }
        {\[} { parse_list }
        {\"} { parse_str }

        {[-0-9]} { parse_num }

        default { parse_bare }
      }
    }
  }

  proc parse_json {json} {
    set parse::json [ string trim $json ]
    set result [ parse::parse ]
    parse::eat_spaces
    if {$parse::json ne ""} {
      error "Had JSON left over: $parse::json"
    }
    return $result
  }

  namespace export parse_json deparse_json tclify_json
}

set ex_json { list {str foo} {num 0} {obj __remote_object__ {str 512}} {null} }

set jtext {
  [
    "foo",
    0,
    {
      "__remote_object__": "512",
    },
    null,
  ]
}

namespace import ten::json::*

puts [ deparse_json $ex_json 2 ]

dict for {k v} [ tclify_json [
  lindex [ tclify_json $ex_json ] 2
] ] { puts "$k: $v" }

puts [ parse_json $jtext ]

puts [ parse_json {["foo",2345,["bar"]]} ]