tedit

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. It now supports creating slave interpreters and sending the selection to the interpreter.
 package require Tk
  
  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 send-sel-inf-tcl {interp} {
      set buffer [get-active]
      set ::*mini-buffer* "Sent selection to $interp"
      if {[catch {$interp eval [$buffer get {*}[lrange [$buffer tag ranges sel] 0 1 ]]} error]} {
        set ::*mini-buffer* $error
      }
      return -code break
    }
  
    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 ewns
      grid rowconfigure    . 0 -weight 1
      grid columnconfigure . 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-Alt-t" {
      set ::*mini-buffer* "Inferior Tcl [::app::create-inferior-tcl] created"
      break;
   }
  
   ::kb::add-binding scratch-mode "Control-Alt-j" {
     ::buffer::send-sel-inf-tcl interp0
     break;
   }
  
   ::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 -sticky ew    
     .mini configure -state disabled
     .mini configure -textvar *mini-buffer*
  
     ::kb::add-binding .mini <<CollectKeys>> {
       bindtags .mini [list collect-keys {*}[bindtags .mini]]
       focus .mini
       set *mini-buffer* %d
       puts %d
     }
  
     ::kb::add-binding collect-keys <KeyPress> {
       if {%k > 63 } {
         set *mini-buffer* [list {*}[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
     }
   }
  
  namespace eval app {
    proc create-inferior-tcl {} {
      return [interp create]
    }
  }
  
   ::buffer::major-mode $buff scratch-mode
Category Word and Text Processing