cmdr
Artifact Content
Not logged in

Artifact 739efc11d4d0a3cd9c8bd4b7ca81c877d4c0fff7:


## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## CMDR - Help - Help support.

# @@ Meta Begin
# Package cmdr::help 0
# Meta author   {Andreas Kupries}
# Meta location https://core.tcl.tk/akupries/cmdr
# Meta platform tcl
# Meta summary     Internal. Utilities for help text formatting and setup.
# Meta description Internal. Utilities for help text formatting and setup.
# Meta subject {command line}
# Meta require {Tcl 8.5-}
# Meta require debug
# Meta require debug::caller
# Meta require lambda
# Meta require linenoise
# Meta require textutil::adjust
# Meta require cmdr::util
# Meta require cmdr::pager
# @@ Meta End

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

package require Tcl 8.5
package require debug
package require debug::caller
package require lambda
package require linenoise
package require textutil::adjust
package require cmdr::util
package require cmdr::pager

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

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

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

namespace eval ::cmdr {
    namespace export help
    namespace ensemble create
}

namespace eval ::cmdr::help {
    namespace export query format auto auto-option
    namespace ensemble create

    namespace import ::cmdr::tty
}

# # ## ### ##### ######## ############# #####################
## A helper to resolve a chain of words (i.e. command name path) to
## the actor responsible for that command, starting from the specified
## actor.

proc ::cmdr::help::query {actor words} {
    debug.cmdr/help {}

    set root   [$actor root]
    set prefix $words

    if {![$root exists *in-shell*] ||
	![$root get    *in-shell*]} {
	# Not in the shell, put executable's name into the prefix.
	set prefix [linsert $prefix 0 [$root name]]
    }

    return [[$actor find $words] help $prefix]
}

# # ## ### ##### ######## ############# #####################
## The internal support command dynamically generating and inserting
## the user's --help option. This is restricted to the root actor.

proc ::cmdr::help::auto-option {actor} {
    $actor learn {
	option help {
	    Show the help of the application or of the current
	    command, and stop.
	} {
	    alias h
	    alias ?
	    presence
	    when-set [lambda {p x} {
		# Invoke the help command which will be generated and
		# inserted below.
		set root [$p config context root]

		if {[$root exists *prefix*]} {
		    debug.cmdr/help/short {/prefix $root ([$root get *prefix*])}
		    # Invoke help for the current command.
		    $root do help {*}[$root get *prefix*]
		} else {
		    # Invoke global help.
		    $root do help
		}
		# Prevent any other processing.
		return -code error -errorcode {CMDR QUIT} Quit
	    }]
	}
    }
    return
}

# # ## ### ##### ######## ############# #####################
## The internal support command dynamically generating and inserting
## the user's help command into the specified actor. See officer.tcl,
## method 'Setup' for the place where this gets used. If the actor is
## the root of the hierarchy a global option --help is added as well.

proc ::cmdr::help::auto {actor} {
    debug.cmdr/help {}

    # Auto create options based on the help formats found installed
    foreach c [lsort -dict [info commands {::cmdr::help::format::[a-z]*}]] {
	set format [namespace tail $c]

	# Skip the imported helper commands which are NOT formats
	if {[string match query* $format]} continue

	lappend formats --$format
	lappend options [string map [list @c@ $format] {
	    option @c@ {
		Activate @c@ form of the help.
	    } {
		presence
		when-set [lambda {p x} { $p config @format set @c@ }]
	    }}]
    }

    # Standard options
    # - line width to format against.
    # - disable paging
    lappend options {
	option width {
	    The line width to format the help for.
	    Defaults to the terminal width, or 80 when
	    no terminal is available.
	} {
	    alias w
	    validate integer ;# better: integer > 0, or even > 10
	    generate [lambda {p} { linenoise columns }]
	}
	option no-pager {
	    Disable use of paging.
	} { presence }
    }
    lappend map @formats@ [linsert [join $formats {, }] end-1 and]
    lappend map @options@ [join $options \n]

    $actor extend help [string map $map {
	section *AutoGenerated*
	description {
	    Retrieve help for a command or command set.
	    Without arguments help for all commands is given.
	    The default format is --full.
	}
	@options@
	state format {
	    Format of the help to generate.
	    This field is fed by the options @formats@.
	} { default {} }
	input cmdname {
	    The entire command line, the name of the
	    command to get help for. This can be several
	    words.
	} { optional ; list }
    }] [list ::cmdr::help::auto-help $actor]
    return
}

# # ## ### ##### ######## ############# #####################
## Implementation/back-end of the generated help.
## The bridge between cmd hierarchy and actual generation.

proc ::cmdr::help::auto-help {actor config} {
    debug.cmdr/help {}

    set width  [$config @width]
    set nopage [$config @no-pager]
    set words  [$config @cmdname]
    set format [$config @format]

    if {$format eq {}} {
	# The chosen default format depends on the presence of
	# additional arguments, i.e. if a specific command is asked
	# for, or not, and the general context (root, leaf, inner
	# node).

	if {[llength $words]} {
	    set sub [$actor find $words]
	    if {[llength [$sub children]]} {
		# Interior command node
		set format short
	    } else {
		set format full
	    }
	} else {
	    set format by-category
	}
    }

    set text [format $format \
		  [$actor root] \
		  $width \
		  [cmdr util dictsort \
		       [query $actor $words]]]

    # Determine how to show the help, in a pager, or not ?

    if {$nopage} {
	puts $text
    } else {
	cmdr pager $text
    }

    return
}

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

namespace eval ::cmdr::help::format {
    namespace export full list short by-category
    namespace ensemble create
}

# Alternate formats:
# List
# Short
# By-Category
# ... entirely different formats (json, .rst, docopts, ...)
# ... See help_json.tcl, help_sql.tcl, and help_tcl.tcl for examples.
#

# # ## ### ##### ######## ############# #####################
## Full list of commands, with full description (text and parameters)

proc ::cmdr::help::format::full {root width help} {
    debug.cmdr/help {}

    # help = dict (name -> command)
    set result {}
    dict for {cmd desc} $help {
	lappend result [Full $width $cmd $desc]
    }
    return [join $result \n]
}

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

    dict with command {} ; # -> desc, options, arguments, parameters

    # Short line.
    lappend lines \
	[string trimright \
	     "[join $name] [HasOptions $options][Arguments $arguments $parameters]"]

    if {$desc ne {}} {
	# plus description
	set w [expr {$width - 5}]
	set w [expr {$w < 1 ? 1 : $w}]
	lappend lines [textutil::adjust::indent \
			   [textutil::adjust::adjust $desc \
				-length $w -strictlength 1] \
			   {    }]
    }

    # plus per-option descriptions (sort by flag name)
    if {[dict size $options]} {
	set onames {}
	set odefs  {}
	foreach {oname ohelp} [::cmdr util dictsort $options] {
	    set oname [OptionName $oname parameters opt2para]
	    lappend onames $oname
	    lappend odefs  $ohelp
	}
	DefList $width $onames $odefs
    }

    # plus per-argument descriptions (keep in cmdline order)
    if {[llength $arguments]} {
	set anames {}
	set adefs  {}
	foreach aname $arguments {
	    set v [dict get $parameters $aname]
	    dict with v {} ; # -> code, description, label
	    lappend anames $label
	    lappend adefs  $description
	}
	DefList $width $anames $adefs
    }
    lappend lines ""
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################
## List of commands. Nothing else.

proc ::cmdr::help::format::list {root width help} {
    debug.cmdr/help {}

    # help = dict (name -> command)
    set result {}
    dict for {cmd desc} $help {
	lappend result [List $width $cmd $desc]
    }
    return [join $result \n]
}

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

    dict with command {} ; # -> desc, options, arguments, parameters

    # Short line.
    lappend lines \
	[string trimright \
	     "    [join $name] [HasOptions $options][Arguments $arguments $parameters]"]
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################
## List of commands with basic description. No parameter information.

proc ::cmdr::help::format::short {root width help} {
    debug.cmdr/help {}

    # help = dict (name -> command)
    set result {}
    dict for {cmd desc} $help {
	lappend result [Short $width $cmd $desc]
    }
    return [join $result \n]
}

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

    dict with command {} ; # -> desc, options, arguments, parameters

    # Short line.
    lappend lines \
	[string trimright \
	     "[join $name] [HasOptions $options][Arguments $arguments $parameters]"]

    if {$desc ne {}} {
	# plus description
	set w [expr {$width - 5}]
	set w [expr {$w < 1 ? 1 : $w}]
	lappend lines [textutil::adjust::indent \
			   [textutil::adjust::adjust $desc \
				-length $w -strictlength 1] \
			   {    }]
    }
    lappend lines ""
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################
## Show help by category/ies

proc ::cmdr::help::format::by-category {root width help} {
    debug.cmdr/help {name ([$root name])}

    # I. Extract the category information from the help structure and
    #    generate the tree of categories with their commands.

    lassign [SectionTree $help [$root name]] subc cmds

    # II. Order the main categories. Allow for user influences.
    set categories [SectionOrder $root $subc]

    # III. Take the category tree and do the final formatting.
    set lines {}
    foreach c $categories {
	ShowCategory $width lines [::list $c] ""
    }
    return [join $lines \n]
}

proc ::cmdr::help::format::ShowCategory {width lv path indent} {
    upvar 1 $lv lines cmds cmds subc subc

    # Print category header
    lappend lines "$indent[lindex $path end]"

    # Indent the commands and sub-categories a bit more...
    append indent "    "
    set    sep    "    "

    # Get the commands in the category, preliminary formatting
    # (labels, descriptions).

    set names {}
    set descs {}
    if {[dict exists $cmds $path]} {
	foreach def [lsort -dict -unique -index 0 [dict get $cmds $path]] {
	    lassign $def syntax desc
	    lappend names $syntax
	    lappend descs $desc
	}
    }
    set labels [cmdr util padr $names]

    # With the padding all labels are the same length. We can
    # precompute the blank and the width to format the descriptions
    # into.

    regsub -all {[^\t]}  "$indent[lindex $labels 0]$sep" { } blank
    set w [expr {$width - [string length $blank]}]
    if {$w < 10} {
	# Force a minimum size for the description. This will cause
	# either cutting at the terminal width, and/or wrapping into
	# the next line, depending on the terminal.
	set w 10
    }

    # Print the commands, final formatting.
    set commands 0
    foreach label $labels desc $descs {
	set desc [textutil::adjust::adjust $desc \
		      -length $w \
		      -strictlength 1]
	set desc [textutil::adjust::indent $desc $blank 1]

	lappend lines $indent$label$sep$desc
	set commands 1
    }

    if {$commands} {
	# Separate sub-categories and commands with an empty line.
	lappend lines {}
    }
    if {![dict exists $subc $path]} return

    # Print the sub-categories, if any.
    foreach c [lsort -dict -unique [dict get $subc $path]] {
	ShowCategory $width lines [linsert $path end $c] $indent
    }
    return
}

# # ## ### ##### ######## ############# #####################
## Common utility commands.

proc ::cmdr::help::format::DefList {width labels defs} {
    upvar 1 lines lines

    set labels [cmdr util padr $labels]

    set  nl [string length [lindex $labels 0]]
    incr nl 5
    set blank [string repeat { } $nl]

    lappend lines ""
    foreach l $labels def $defs {
	# FUTURE: Consider paragraph breaks in $def (\n\n),
	#         and format them separately.
	set w [expr {$width - $nl}]
	set w [expr {$w < 1 ? 1 : $w}]
	lappend lines "    $l [textutil::adjust::indent \
		       [textutil::adjust::adjust $def \
			    -length $w -strictlength 1] \
		       $blank 1]"
    }
    return
}

proc ::cmdr::help::format::Arguments {arguments parameters} {
    set result {}
    foreach a $arguments {
	set v [dict get $parameters $a]
	dict with v {} ; # -> code, desc, label
	switch -exact -- $code {
	    +  { set text "<$label>" }
	    ?  { set text "\[<${label}>\]" }
	    +* { set text "<${label}>..." }
	    ?* { set text "\[<${label}>...\]" }
	}
	lappend result $text
    }
    return [join $result]
}

proc ::cmdr::help::format::HasOptions {options} {
    if {[dict size $options]} {
	return "\[OPTIONS\] "
    } else {
	return {}
    }
}

proc ::cmdr::help::format::SectionTree {help root {fmtname 1}} {

    array set opts {} ;# cmd -> option -> odesc
    array set subc {} ;# category path -> list (child category path)
    array set cmds {} ;# category path -> list (cmd)
    #                    cmd = tuple (label description)

    dict for {name def} $help {
	dict with def {} ; # -> desc, arguments, parameters, sections

	# Do not show the auto-generated commands in the categorized help.
	if {"*AutoGenerated*" in $sections} {
	    continue
	}

	# Exclude officers from the categorized help. They can only be
	# a source of shared options. Shared options are collected in
	# a separate structure.
	if {![info exists action] && [dict size $options]} {
	    set opts($name) [::list $options $parameters $opt2para]
	    continue
	}


	if {![llength $sections]} {
	    lappend sections Miscellaneous
	}

	if {$fmtname} {
	    append name " " [Arguments $arguments $parameters]
	}
	set    desc [lindex [split $desc .] 0]
	set    cmd  [::list [string trim $name] $desc]

	foreach category $sections {
	    lappend cmds($category) $cmd
	    LinkParent $category
	}
    }

    # Options for the root => global options, put into the section tree.
    # We are ignoring deeper shared options.

    if {[info exists opts($root)]} {
	lassign $opts($root) options parameters opt2para

	set category {Global Options}
	lappend sections $category
	set category [::list $category]
	foreach {o d} [::cmdr util dictsort $options] {
	    set o [OptionName $o parameters opt2para]
	    lappend cmds($category) [::list $o [string trim $d]]
	    LinkParent $category
	}

	unset opts($root)
    }

    # puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # parray subc
    # parray cmds
    # parray opts
    # puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ::list [array get subc] [array get cmds]
}

proc ::cmdr::help::format::OptionName {oname pv ov} {
    upvar 1 $pv parameters $ov opt2para

    # Inspect the parameter and determine of the option
    # requires an argument. If yes, suitably extend the
    # definition key of the option list.

    set pname [dict get $opt2para $oname]
    set vt    [dict get $parameters $pname validator]

    if {$vt ne "::cmdr::validate::boolean"} {
	if {[dict exists $parameters $pname arglabel]} {
	    set plabel [dict get $parameters $pname arglabel]
	} else {
	    set plabel [dict get $parameters $pname label]
	}
	append oname " [string toupper $plabel]"
    }

    return $oname
}

proc ::cmdr::help::format::LinkParent {category} {
    if {![llength $category]} return
    upvar 1 subc subc
    set parent [lreverse [lassign [lreverse $category] leaf]]
    lappend subc($parent) $leaf
    LinkParent $parent
    return
}

proc ::cmdr::help::format::SectionOrder {root subc} {
    # IIa. Natural order first.
    set categories [lsort -dict -unique [dict get $subc {}]]

    set generated {
	Miscellaneous
	{Global Options}
    }

    # IIb. Look for and apply user overrides.
    if {[$root exists *category-order*]} {
	# Record natural order
	set n 0
	foreach c $categories {
	    dict set map $c $n
	    incr n -10
	}
	# Special treatment of generated categories, move to end.
	set end -10000
	foreach c $generated {
	    if {$c ni $categories} continue
	    dict set map $c $end
	    incr end -10000
	}
	# Overwrite natural with custom ordering.
	dict for {c n} [$root get *category-order*] {
	    if {$c ni $categories} continue
	    dict set map $c $n
	}
	# Rewrite into tuples.
	foreach {c n} $map {
	    lappend tmp [::list $n $c]
	}

	#puts [join [lsort -decreasing -integer -index 0 $tmp] \n]

	# Sort tuples into chosen order, and rewrite back to list of
	# plain categories.
	set categories {}
	foreach item [lsort -decreasing -integer -index 0 $tmp] {
	    lappend categories [lindex $item 1]
	}
    } else {
	# Without a bespoke ordering only the generated categories are
	# treated specially.
	foreach c $generated {
	    set pos [lsearch -exact $categories $c]
	    if {$pos < 0} continue
	    set categories [linsert [lreplace $categories $pos $pos] end $c]
	}
    }

    return $categories
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help 1.3.2