MJ - I have just discovered bindtags and what they can do. They allow for some really advanced keyboard handling. An example of this is the base for a Tcl editor below. Keybindings can be associated to certain modes (a la Emacs) This is just a rudimentary basis, but I will expand on this when I have time.
package require Tk
#define globals
namespace eval utils {
proc lremove {list item} {
return [lsearch -all -inline -not -exact $list $item]
}
}
namespace eval buffer {
proc get-point {buffer} {
return [$buffer index insert]
}
proc get-active {} {
return .t
}
proc eval-print-last-exp {} {
set current_buffer [get-active]
set point [get-point $current_buffer]
set line [get-line-with-point $current_buffer]
if {[catch {uplevel #0 $line} result]} {
#display in red
} else {
#display in black
}
$current_buffer insert "$point lineend" "\n$result\n"
return -code break
}
proc get-line-with-point {buffer} {
set point [get-point $buffer]
set line [$buffer get "$point linestart" "$point lineend"]
return $line
}
# return a list with all bindings on buffer (global and buffer)
proc list-bindings {buffer} {
set bindings {}
foreach tag [bindtags $buffer] {
set bindings [concat $bindings [bind $tag]]
}
return $bindings
}
proc create-new {} {
text .t
grid .t -sticky nsew
grid rowconfigure .t 0 -weight 1
grid columnconfigure .t 0 -weight 1
# default bindtags for any new buffer
bindtags .t "fundamental-mode keymap [bindtags .t]"
return .t
}
proc major-mode {buffer mode} {
bindtags ${buffer} "$mode [lrange [bindtags ${buffer}] 1 end]"
# call mode-hook here
wm title . $mode
}
}
namespace eval kb {
# keys that are collected from minibuffer
set *keys-collected* {}
set *active-prefix* {}
# Stuff to detect key modifiers (taken from http://wiki.tcl.tk)
# array of bit masks to recognize the modifers:
# - shift - mod5 masks taken from .../tcl/include/X11/X.h
# - alt mask defined by analysing the status field of Alt-KeyPress
# (analysed on MS Windows)
#
array set masks [list \
shift [list [expr {1 << 0}] "Shift"] \
lock [list [expr {1 << 1}] "Lock"] \
alt [list [expr {1 << 17}] "Alt"] \
control [list [expr {1 << 2}] "Control"] \
mod1 [list [expr {1 << 3}] "Mod1"] \
mod2 [list [expr {1 << 4}] "Mod2"] \
mod3 [list [expr {1 << 5}] "Mod3"] \
mod4 [list [expr {1 << 6}] "Mod4"] \
mod5 [list [expr {1 << 7}] "Mod5"] \
];
# MS Windows modifier name map:
# - Mod1 is identical to "Num"-lock key
# - Mod3 is identical to "Scroll"-lock key
#
set maps [list \
"Mod1" "Num" \
"Mod3" "Scroll" \
];
proc keyModifiers {state {mapToRealName 1}} {
variable masks;
variable maps;
set modifiers [list];
foreach mask [array names masks] {
lassign $masks($mask) bits label;
if {$state & $bits} {
lappend modifiers $label;
}
}
# Remove Shift modifier, is already include in character case
set modifiers [::utils::lremove $modifiers Shift]
set modifiers [join $modifiers "-"];
if {$mapToRealName == 1} {
set modifiers [string map $maps $modifiers];
}
return $modifiers;
}
proc add-binding {tag key proc} {
set keys [split $key]
if {[llength $keys] == 1 } {
if {[llength [split $keys -]]==1 } {
# simple keys
bind $tag ${keys} $proc
} else {
# Key with modifiers
bind $tag <$keys> $proc
}
} else {
# Prefixed key combination
# create binding for the prefix
bind $tag "<[lindex $keys 0]>" {event generate .mini <<CollectKeys>> -data [list %W %s %K]}
# create virtual binding event for the whole shebang
bind $tag "<<${key}>>" $proc
}
}
# minibuffer will handle prefixed commands
proc handle-prefix-binding {buffer state key} {
# here the system can collect keybindings until a binding matches
set prefix "[keyModifiers $state]-$key"
set all_bindings [::buffer::list-bindings $buffer]
# add enable minibuffer bindtag
focus .mini
set ::*mini-buffer* {}
set ::*mini-buffer* "$prefix "
}
}
# scratch mode bindings
::kb::add-binding scratch-mode "a" {puts "in scratch mode"}
::kb::add-binding scratch-mode "Control-j" {::buffer::eval-print-last-exp }
::kb::add-binding scratch-mode "Control-J" {puts "should execute something now without displaying output" ; break }
::kb::add-binding scratch-mode "Control-x Control-b" {puts prefixed}
::kb::add-binding scratch-mode "Control-x Control-c" {puts prefixed}
::kb::add-binding scratch-mode "Control-u a" {puts prefixed}
# global keybindings
::kb::add-binding keymap "Control-space" {puts [::buffer::get-point %W]}
::kb::add-binding keymap "Alt-m" [list ask-user-input %W]
set buff [::buffer::create-new]
# rudimentary minibuffer. The current state of the minibuffer will be determined by the active bindtags
# there will be support for collecting key bindings
# there will be support for collecting user input
# there will be support for displaying status info
namespace eval mini-buffer {
entry .mini
grid .mini
.mini configure -state disabled
.mini configure -textvar *mini-buffer*
grid columnconfigure .mini 0 -weight 1
::kb::add-binding .mini <<CollectKeys>> {
bindtags .mini [list collect-keys {expand}[bindtags .mini]]
focus .mini
set *mini-buffer* %d
puts %d
}
::kb::add-binding collect-keys <KeyPress> {
if {%k > 63 } {
set *mini-buffer* [list {expand}[set *mini-buffer*]\
[::kb::keyModifiers %s]-%K]
}
puts "%A|%s|%K"
break
}
::kb::add-binding collect-keys "Control-g" {
set ::*mini-buffer* Aborted
# remove collect-keys bindtag
bindtags .mini [::utils::lremove [bindtags .mini] collect-keys]
focus .t
}
}
::buffer::major-mode $buff scratch-mode