tson

#! /usr/bin/env wish
#
# Copyright (c) 2020 Peter Piwowarski <peterjpiwowarski@gmail.com>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

package require Tcl 8.5
package require Tk 8.5

package require sqlite3

sqlite3 parser :memory:
if {[catch {
	parser eval {SELECT json('{"a":"b"}')}
}]} {
	error "this version of sqlite does not include the json1 extension"
}

# "Safe" file-use construct: sets $fdvar to $fd and executes $script, closing
# $fd and, if an error occurs, rethrowing it. The parameter 'as' is ignored as
# syntactic sugar. Example usage:
# with [open /tmp/foo r] as fd {
# 	puts [read $fd]
# }
proc with {fd as fdvar script} {
	try {
		uplevel 1 set $fdvar $fd
		uplevel 1 $script
	} on error {err opts} {
		return -options $opts $err
	} finally {
		uplevel 1 close $fd
	}
}

proc deserialize {value tree {root {}}} {
	foreach item [$tree children $root] {
		$tree delete $item
	}

	parser eval {SELECT * FROM JSON_EACH($value)} {
		set item [$tree insert $root end -text $key -values [list $atom $type]]
		if {$type in {array object}} {
			# Composite objects come with their own trees to
			# deserialize.
			deserialize $value $tree $item
		}
	}
}

proc file_open {} {
	if {[set path [tk_getOpenFile -filetypes {
		{"JSON Files" .json TEXT}
		{"All Files"  *}
	} -title "Open JSON file..."]] ne ""} {
		with [open $path r] as fd {
			deserialize [read $fd] .t
		}
	}
}

tk appname Tson
wm title . Tson

menu .menubar

menu .menubar.file
.menubar.file add command -label Open... -command file_open
.menubar.file add command -label Quit -command exit

.menubar add cascade -label File -menu .menubar.file

. configure -menu .menubar

ttk::treeview .t -columns {
	atom
	type
} -show {tree headings} -yscrollcommand {.s set}
.t heading #0 -text Key
.t heading type -text Type
.t heading atom -text Value

# the longest type name is 'integer'; include some padding
.t column type -width [expr {
	round([font measure TkDefaultFont integer] + (12 * [tk scaling]))
}]

ttk::scrollbar .s -orient vertical -command {.t yview}

grid .t .s -sticky nsew
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1

if {[llength $argv] > 0} {
	with [open [lindex $argv 0]] as fd {
		deserialize [read $fd] .t
	}
}