#!/afs/ece/usr/tcl/bin/wisha -f

# To run this program, you should make sure the top line reflects the location
# of wish on your system, and the following variable for beth is set properly.

# Directory for beth source
set beth_dir "/afs/ece/usr/svoboda/src/beth"

# Directory for rmth source
set rmth_dir "$beth_dir/examples/rmth"

set rmth_config_file .rmth

wm minsize . 1 1
wm title . "RMTH"
wm iconname . "rmth"
set dont_change_title 1

# The global variable below keeps track of the remote application
# that we're sending to.  If it's an empty string then we execute
# the commands locally.

set app "local"
set tab_completion_defined 1

# Load up beth with its expected options.
set option 0
set configs "$argv -l regions.tcl -l preventbind.tcl"
set embedded 1
set edit_mode 1
source $beth_dir/beth.tcl
$menu.modules.m entryconfigure "Abbreviation Expansion" -state disabled

# Add an info label, usually empty.
set info ""
label $frame.info -relief raised -textvariable info
label_expand_bind $frame.info info
pack forget $frame.q
pack $frame.info -in $frame -side right
pack $frame.q -side right -expand yes -fill x

# Remove modified button, we're not interested in it.
pack forget $frame.fmb $frame.fnl $frame.fpl


# Like catch, but handles remote interps going down specially.
proc catch_remote_nonresponse {cmd {var ""}} {
	if {$var != ""} {upvar $var result}

	if {[catch $cmd output]} {
		if {($output == "remote interpreter did not respond") ||
			[string match "send to * failed *" $output] ||
			[string match "receiver never heard of *" $output] ||
			[string match "no registered interpreter *" $output]} {
			newApp local
			if {$var != ""} {set result "$output; setting interpreter to local"}
			return 1
		} else {if {$var != ""} {set result $output}
			return 1
	}} else {if {$var != ""} {set result $output}
		return 0
}}


# Keeps the pwd variables up-to-date
proc update_pwd {} {
	global path_head path_tail uplevel_prefix
	while {[catch_remote_nonresponse "$uplevel_prefix pwd" dir]} {}
	set path_head [file dirname $dir]
	set path_tail [file tail $dir]
}

# This is somehow necessary to keep the first event from being lost.
history add "created"

# A slightly fancier version than the one in rmt. This one, if the cmd is not
# legit Tk/tcl, passes it to exec. (just like interactive wish)
# Also removes the '!!' option, that's taken care of elsewhere.
# Don't do gradual if:
#	1. User did not request it
#	2. Executing in a remote  interpreter
proc invoke {t f} {
    global app remote_return_completions info
    complete_cmd $t {{replace_substring string_history_event {!}}} 0
    set shown_cmd [$t get Old.last+1c end]
    complete_cmd $t {{replace_substring string_glob_files { }}} 0
    set cmd [string trim [$t get Old.last+1c end] " \n\t"]
    $t delete Old.last+1c end
    $t insert Old.last+1c "$shown_cmd\n"
    $t mark set insert end
    $t tag add Command Old.last+1c end-1c
    $t tag remove Command end-1c
    $t tag add Old Old.last end

# These routines should try and interpret cmd as best they can. See the
# execute_wish_cmd procedure for format on what values should be set.
# (the output of execute_wish_cmd goes into: result cmd msg info)
    set result 0 ; set msg "" ; set info ""
    $f.info configure -textvariable info

    if {[info complete $cmd]} {
	global uplevel_prefix gradual_io
	$t configure -cursor watch ; update

# Empty line ?
# Considered a successful no-op command
	if {[string length $cmd] == 0} {
		set result 2

# Gradual requested, but in remote interpreter, so no can do. ?
# Indicate command should not be completed.
	} elseif {[string match *\@ $cmd] && [string match "send*" $uplevel_prefix]} {
		set info "Can only do graduated reading in local interpreter"

# Remote interpreter failed to respond ?
# Indicate command should not be completed
	} elseif {[catch_remote_nonresponse "$uplevel_prefix info \
					commands [lindex $cmd 0]" output]} {
		set info $output

# Wish command ?
	} elseif {[llength $output] == 1} {
		set output [execute_wish_cmd $t]
		set result [lindex $output 0] ; set msg [lindex $output 2]
		set cmd [lindex $output 1] ; set info [lindex $output 3]

# Gradual exec command ?
	} elseif {($gradual_io || [string match *\@ $cmd]) &&
![string match *\& $cmd] && ![string match "send*" $uplevel_prefix]} {
		set new_cmd "| [string trimright $cmd \@] |& cat &"
		set result [catch "load_and_insert_file $t end $f [pwd] [list $new_cmd]" msg]
		if {!$result} {set result 2}
		if {$msg == "child process exited abnormally"} {
			set info $msg
			set msg ""}

# Exec command ?
	} else {if {[string match *\& $cmd]} {	set new_cmd $cmd
		} else {set new_cmd "$cmd |& cat"}
		set result [catch_remote_nonresponse \
				"$uplevel_prefix exec [list $new_cmd]" msg]
		if {!$result} {set result 2}}

	$t configure -cursor xterm

	switch $result 0 {
		# Command was incomplete, re-use it.
		$t delete Prompt.last+1c end
		$t insert end $cmd
		$t tag remove Old Prompt.last end
		$t tag remove Command Prompt.last end
		if {$app != [$t get "Prompt.last linestart" Prompt.last-1c]} {
			newApp $app}

		} 1 {
		# Command generated error, do same as if successful.
		if {$msg != ""} {$t insert end "$msg\n"}
		history change $shown_cmd
		history add $shown_cmd
		update_pwd
		prompt $t

		} 2 {
		# Command was successful, add to history, issue prompt.
		if {$msg != ""} {$t insert end "$msg\n"}
		history change $shown_cmd
		history add $shown_cmd
		update_pwd
		prompt $t
		}
    }
    $t yview -pickplace insert
    $t tag remove Old Prompt.last end
}

# execute_wish_cmd should return 4 items in a list. The first one is:
# 0 if cmd didn't get executed (ie was incomplete)
# 1 if cmd got executed & yielded an error
# 2 if cmd executed normally
# The second one is the cmd as it was executed, or completed.
# The third item is the output (either of a successful or failed cmd) to be
# placed in the text widget.
# The fourth item is info to put on the top (outside the text widget.)
proc execute_wish_cmd {t} {
    global uplevel_prefix
    set cmd [string trim [$t get Prompt.last end] " \n\t"]
    set result [catch_remote_nonresponse "$uplevel_prefix [list $cmd]" msg]

# Wish cmd was successful
    if {!$result} {    return [list 2 $cmd $msg ""]}

# Handle incorrect-number-of-argument and unknown-option type errors.
    if {[string match {wrong # args: *} $msg] ||
	[string match {unknown option *} $msg]} {
	return [list 0 $cmd "" $msg]}

    set list [parse_error $msg]
# Cmd generated an error we can't handle
    if {$list == ""} {	return [list 1 $cmd $msg ""]}

# Handle here-are-the-possible-choices type errors.
    set selection [tk_dialog_listbox .option {Option Dialog} [lindex $list 0] \
		[lrange $list 2 end]]
# User didn't request correction.
    if {$selection == ""} {	return [list 0 $cmd "" ""]}

    regsub [lindex $list 1] $cmd $selection new_cmd
# User requested correction.
    return [list 0 $new_cmd "" ""]
}

# We are trying to parse up error messages like:
# bad tag option "foo":  must be add, bind, configure, delete, lower, names, 
# nextrange, raise, ranges, or remove
# Returns list where first item is everything up to "must be", 
# second item is the bad option (foo in this case),
# and remaining itmes are the legitimate options.
proc parse_error {msg} {
    if {![string match "* must be *, or *" $msg] &&
	![string match {* should be *, or *} $msg]} {	return ""}

    set list [split $msg]
    set index 0
    while 1 {
	set index [lsearch [lrange $list $index end] "be"]
	incr index -1
	if {([lindex $list $index] == "should") || ([lindex $list $index] == "must")} {break}
	incr index +2
    }
    incr index
    set result [list "[join [lrange $list 0 $index]]:"]

    set bad_option_index [lsearch $list {"*":}]
    set result [lappend result [string trim [lindex $list $bad_option_index] \
				{":;}]

    incr index
    foreach element [lrange $list $index end] {
	if {$element != "or"} {	lappend result [string trimright $element ","]}}

    return $result
}

# If s is a complete Tcl command or prefix, brings up info on s.
proc filter_info_cmds {s args} {
	global uplevel_prefix info
	catch_remote_nonresponse "$uplevel_prefix info procs [list [list $s]]" strings
	if {$s == $strings} {
		catch_remote_nonresponse "$uplevel_prefix info args $s" args
		set info "Procedure $s takes arguments: $args"
	}
	return [filter_cmds $s]
}

# We want two sets of completions, one for Tab, one for Return
set remote_tab_completions [concat \
	[list 	{complete_string filter_info_cmds {}} \
		{replace_substring string_history_event {!}}] \
	[lreplace $default_completions 3 3 \
		{complete_substring filter_info_cmds {[}}]]

# A completion procedure for the text widget.
proc complete_cmd {t completions {tab 1}} {
	set cmd [$t get Old.last+1c insert]

# Treat tab normally if preceding char is tab, newline, or space.
	if $tab {
		set prev_char [$t get insert-1c]
		if {($prev_char == " ") || ($prev_char == "\n") || ($prev_char == "\t")} {
			$t insert insert \t
			return 1}
	}

# Have to treat '!!' specially
	if {[string match "*!!" $cmd]} {
		set completion [list "[string range $cmd 0 [expr [string length $cmd] -3]][history event [expr [history nextid] -1]]"]
	} else {if {[catch_remote_nonresponse "multiple_completion [list $cmd] \
			[list $completions]" completion]} {error $completion}}

	global completion_message completion_index
	set completion_message [lindex $completion 1]
	set completion_index [lindex $completion 2]
	if {[lindex $completion 0] != ""} {
		$t delete Old.last+1c insert
		$t insert insert "[lindex $completion 0]"
	}
	if {([lindex $completion 1] != "") ||
		([lindex $completion 0] == "")} {return 0 } else { return 1
}}


# Shows list of completions, letting user pick one.
proc t_show_completion_dialog {t} {
	global completion_message completion_index
	if {$completion_message == ""} {beep ; return}
	set prefix [$t get Old.last+1c insert]
	if {[string match {Possible *} $completion_message]} {
		set view [expr [string length $prefix] - $completion_index]
		set completion [eval tk_dialog_listbox .conf \
		   {{Completion Dialog}} [split $completion_message \n] $view]
		if {$completion != ""} {
			$t delete Old.last+1c insert
			$t insert insert "[string range $prefix 0 \
						$completion_index]$completion"}
	} else {tk_dialog .conf Error $completion_message info 0 OK
}}

# The procedure below is used to print out a prompt at the
# insertion point (which should be at the beginning of a line
# right now).
proc prompt {t} {
    global app
    $t insert end "$app: "
    $t tag add Prompt {end linestart} {end -1 char}
    $t tag add Old {end linestart} end-1c
}

# The following procedure is invoked to change the application that
# we're talking to.  It also updates the prompt for the current
# command, unless we're in the middle of executing a command from
# the text item (in which case a new prompt is about to be output
# so there's no need to change the old one).
proc newApp {appName} {
    global app uplevel_prefix text
    set app $appName
    set flag1 [catch {$text compare Old.last == Prompt.last} flag2]
    if {$flag1 || $flag2} {
	set mark [$text index "Prompt.last linestart"]
	$text delete $mark Prompt.last
	$text insert $mark "$appName:"
	$text tag add Prompt $mark "$mark + [string length $appName] c + 1 c"
	$text tag add Old $mark Prompt.last
    }
    if {$app == "local"} {set uplevel_prefix "uplevel #0"
    } else {set uplevel_prefix [list send $app]}
    update_pwd
    return {}
}

# The procedure below will fill in the applications sub-menu with a list
# of all the applications that currently exist.
proc fillAppsMenu {m} {
    catch {$m delete 0 last}
    foreach i [lsort [winfo interps]] {
	$m add command -label $i -command [list newApp $i]
    }
    $m add command -label local -command {newApp local}
}

# This overrides the save-confirm dialog.
proc quit_beth {} {
	global quit_hook
	if {[info exists quit_hook]} {eval $quit_hook}
	exit
}


# Bindings for command traversal...this uses the regions module
# which is automatically loaded by BETH.

proc check_command {t index} {
# Index must have Prompt or collapsed tag.
	if {([lsearch [$t tag names $index] collapsed] < 0) &&
		([lsearch [$t tag names $index] Prompt] < 0)} {return 0}
# Next char must not have either tag
	if {([lsearch [$t tag names "$index +1c"] collapsed] >= 0) &&
		([lsearch [$t tag names "$index +1c"] Prompt] >= 0)} {return 0}
	return 1
}

proc region_prev {t index} {
	while {[set index [text_string_last $t ": " $index]] != ""} {
		if {[check_command $t $index]} {return "$index +2c"}
	}
	return
}

proc region_next {t index} {
	while {[set index [text_string_first $t ": " $index]] != ""} {
		if {[check_command $t $index]} {return "$index +2c"}
		set index "$index +2c"
	}
	return
}

proc region_end {t index} {
	if {[lsearch [$t tag names $index] collapsed] >= 0} {
		return [lindex [tag_thisrange $t collapsed $index] 1]}
	if {[lsearch [$t tag names $index] Command] >= 0} {
		return [lindex [tag_thisrange $t Command $index] 1]}
	return end
}

# For when the collapsing module is available
proc region_collapse_indicate {t start end} {
	set minchars [expr [lindex [$t configure -width] 4] - 15]
	scan $start "%d.%d" row dummy
	if {[$t compare "$row.$minchars" < "$row.0 +$minchars chars"]} {
		set c_end "$row.$minchars -1c"
	} else {set c_end "$row.0 +$minchars chars"}

	if {[$t compare $c_end >= $end]} {return ""
	} else {set num [string range [gensym] 3 end]
		return "[$t get $start $c_end]...\[$num\]"
}}

# Fillers here are the previous prompt and any output from the last command.
# If the output is zero or one lines, don't bother collapsing, otherwise
# collapse output, but leave prompt intact.
proc filler_collapse_indicate {t start end} {
	set result [region_collapse_indicate $t $start "$end -1 line lineend"]
	if {$result == "" } {return ""}
	set prompt [$t get "$end linestart" $end]
	return "$result\n$prompt"
}


# All the bindings for rmth
proc rmth_bind {f t m} {
	region_bind $f $m "Command" 6
	global regions_defined ; set regions_defined 1
	global Keys

# Bindings unique to rmth.
	parse_bindings Text \
Tab		{global remote_tab_completions
			if {![complete_cmd %W $remote_tab_completions]} beep} \
C-Tab		{t_show_completion_dialog %W} \
$Keys(C_m)	"invoke %W $f" \
C-L		{%W delete 1.0 {insert linestart}}

	if {[winfo exists $m]} {parse_menu $m \
{Rmth 0 			{Application 0 "" {}} 
				{"Complete Word" 0 Tab}
				{"Show Completion Info" 0 C-Tab}
				{Invoke 0 Return}
				{"Erase Previous Text" 0 C-L}}

# Remove menu itmes from the entry menu that are duplicated in the rmth menu.
		$m.entry.m delete 2 last

# Arrange to recreate all the information in the
# applications sub-menu whenever it is cascaded to.
		$m.rmth.m entryconfigure Application \
			-command {fillAppsMenu .menu.rmth.m.application}
}}


rmth_bind $frame $text $menu

# We don't want the prompt to be selected or moved over, and we don't want
# anything before the current command editable.
lappend prevent_select_tags Prompt
lappend prevent_move_tags Prompt
lappend prevent_edit_tags Old

prompt $text
set app
update_pwd
focus default $text ; focus $text

# We want rmth's help file brought up, too.
set help_cmd "$beth_exec -b $beth_dir/HELP $rmth_dir/README &"

source_config_file $rmth_config_file
