Artifact c2e7afc0e9bdc05ab4705a4739c23db1d5125442:

• File help_json.tcl — part of check-in [f853a46223] at 2014-08-26 19:45:03 on branch global-options — Updated help generation to show global options in categorized help. General update to handle officers now appearing in the help structures. Bumped version numbers. All parts done. Notes removed. (user: andreask size: 5566) [more...]

## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Help - JSON format. Not available by default.
## Require this package before creation a commander, so that the
## mdr::help heuristics see and automatically integrate the format.

# @@ Meta Begin
# Package cmdr::help::json 1.0.1
# Meta author   {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary     Formatting help as JSON object.
# Meta description Formatting help as JSON object.
# Meta subject {command line}
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require {cmdr::help 1}
# Meta require {cmdr::util 1}
# Meta require json::write
# @@ Meta End

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require debug
package require debug::caller
package require cmdr::help 1
package require cmdr::util 1
package require json::write

# # ## ### ##### ######## ############# #####################

debug define cmdr/help/json
debug level  cmdr/help/json
debug prefix cmdr/help/json {[debug caller] | }

# # ## ### ##### ######## ############# #####################
## Definition

# # ## ### ##### ######## ############# #####################

namespace eval ::cmdr::help::format {
    namespace export json
    namespace ensemble create

    namespace import ::cmdr::help::query
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::help::format::json {root width help} {
    debug.cmdr/help/json {}
    # help = dict (name -> command)

    # Step 1. Command mapping.
    set dict {}
    dict for {cmd desc} $help {
	lappend dict $cmd [JSON $desc]
    }
    set commands [json::write object {*}$dict]


    # Step 2. Section Tree. This is very similar to
    # cmdr::help::format::by-category, and re-uses its frontend helper
    # commands.

    lassign [SectionTree $help \000 0] subc cmds
    foreach c [SectionOrder $root $subc] {
	lappend sections [JSON::acategory [::list $c] $cmds $subc]
    }

    return [json::write object \
		sections [json::write array {*}$sections] \
		commands $commands]
}

# # ## ### ##### ######## ############# #####################

namespace eval ::cmdr::help::format::JSON {}

proc ::cmdr::help::format::JSON::acategory {path cmds subc} {
    set name [lindex $path end]

    # With struct::list map we could then also re-use alist.
    set commands {}
    if {[dict exists $cmds $path]} {
	foreach def [lsort -dict -unique [dict get $cmds $path]] {
	    lassign $def cname _
	    lappend commands [json::write string $cname]
	}
    }

    set sections {}
    if {[dict exists $subc $path]} {
	# Add the sub-categories, if any.
	foreach c [lsort -dict -unique [dict get $subc $path]] {
	    lappend sections [acategory [linsert $path end $c] $cmds $subc]
	}
    }

    return [json::write object \
		name     [json::write string $name] \
		commands [json::write array {*}$commands] \
		sections [json::write array {*}$sections]]
}

proc ::cmdr::help::format::JSON {command} {
    # Data structure: see config.tcl,  method 'help'.
    # Data structure: see private.tcl, method 'help'.

    dict with command {}
    # -> action, desc, options, arguments, parameters, states, sections

    lappend dict description [JSON::astring    $desc]
    if {[info exists action]} {
	# Missing for officers.
	lappend dict action [JSON::alist $action]
    }
    lappend dict arguments   [JSON::alist      $arguments]
    lappend dict options     [JSON::adict      $options]
    lappend dict opt2para    [JSON::adict      $opt2para]
    lappend dict states      [JSON::alist      $states]
    lappend dict parameters  [JSON::parameters $parameters]
    lappend dict sections    [JSON::alist      $sections]
    
    return [json::write object {*}$dict]
}

proc ::cmdr::help::format::JSON::parameters {parameters} {
    set dict {}
    foreach {name def} [::cmdr util dictsort $parameters] {
	set tmp {}
	foreach {xname xdef} [::cmdr util dictsort $def] {
	    switch -glob -- $xname {
		cmdline -
		defered -
		documented -
		interactive -
		isbool -
		list -
		ordered -
		presence -
		required -
		@bool {
		    # normalize to boolean
		    set value [expr {!!$xdef}]
		}
		threshold {
		    # null|integer
		    set value [expr {($xdef eq {}) ? "null" : $xdef}]
		}
		code -
		default -
		description -
		prompt -
		type -
		label -
		@string {
		    set value [astring $xdef]
		}
		generator -
		validator -
		@cmdprefix { 
		    set value [alist $xdef]
		}
		flags -
		@dict {
		    set value [adict $xdef]
		}
		* {
		    error "Unknown key \"$xname\", do not know how to format"
		    #lappend tmp $xname [astring $xdef]
		}
	    }
	    lappend tmp $xname $value
	}
	lappend dict $name [json::write object {*}$tmp]
    }
    return [json::write object {*}$dict]
}

# # ## ### ##### ######## ############# #####################

proc ::cmdr::help::format::JSON::alist {thelist} {
    set tmp {}
    foreach w $thelist {
	lappend tmp [json::write string $w]
    }
    return [json::write array {*}$tmp]
}

proc ::cmdr::help::format::JSON::adict {thedict} {
    set tmp {}
    foreach {k v} [::cmdr util dictsort $thedict] {
	lappend tmp $k [json::write string $v]
    }
    return [json::write object {*}$tmp]
}

proc ::cmdr::help::format::JSON::astring {string} {
    regsub -all -- {[ \n\t]+} $string { } string
    return [json::write string [string trim $string]]
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::json 1.1