Extend text widget by editing features (but no megawidget)

Having updated doubleclick I made an extension of text widget which is intended to be small and stable. For features see comment section.
Have fun.
#!/usr/bin/wish

# file: texteditor-0.1.tm

#
# This package extends Tk's text widget by usual bindings.
# This is done by extend the bindtags of given widget by new tag TextEditor.
# 
# Technically:
# New namespace TextEditorBindings
# New widgets .textEditorContextMenu .textEditorSelContextMenu
# Relies on UNDOCUMENTED array variable ::tk::Priv(selectMode)
#     but this is the ONLY undocumented property to use
# 
# Usage:
# textEditor win - creates extended text widget $win
#     with options on creation: wrap -word, -undo yes
# textToEditor win - extends given text widget $win
# editorToText win - removes extensions from text widget $win
# textEditorQuotes - sets internationaL quotes AND dash bindings
# arguments: de en en-AM fr ch C
# 
# Extensions:
#
# Double-click on opening brace { selects to closing brace }, incl. nesting;
# same on [ to ], ( to ), " to ", opening <XMLtag> to closing </XMLtag>, 
# additionaly selects any international quote, but non-nesting.
#
# Quotes are set according to textEditorQuotes.
# When quotes are set to any of de, fr, en, en-AM, ch, 
# then key sequence Escape-Quote produces computer quotes (#34, #39).
#
# Context menu on <Button-3> to set some HTML tags and remove outermost paired tags
# with NO ACTION if selected tags are NOT PAIRED.
#

package require Tcl 8.6
package require Tk 8.6

package provide texteditor 0.1

namespace eval TextEditorBindings {
  namespace export\
    textEditor\
    textToEditor\
    editorToText\
    textEditorQuotes
}

proc ::TextEditorBindings::selectToClosingChar {w x y} {
  set i0 [$w index @$x,$y]
  set transList [list \u007b \u007d\
                   \" \" ' ' „ “ ‚ ‘  “ ” ‘ ’\
                   \u00bb \u00ab \u00ab \u00bb \u203a \u2039 \u2039 \u203a\
                   \u005b \u005d < > \u0028 \u0029]
  set c0 [$w get $i0]
  set selectTo {{w i0 i1} {
      if {[$w tag ranges sel] eq ""} then {
        $w tag add sel $i0 $i1
        $w mark set insert $i0
      } else {
        $w tag add sel sel.first $i1
        $w mark set insert $i1
      }
    }}
  if {![dict exists $transList $c0]} then {
    return false
  }
  set c1 [dict get $transList $c0]
  if {$c0 ni [list \[ \( \{ \" <]} then {
    # Quotes - non-nestable
    set i1 [$w search $c1 $i0+1chars end]
    if {$i1 eq ""} then {
      return false
    }
    # $w tag add sel $i0 $i1+1chars
    # $w mark set insert $i0
    apply $selectTo $w $i0 $i1+1chars
    return true
  } elseif {$c0 eq "<"} then {
    # HTML tags?
    set i1 [$w search > $i0+1chars end]
    if {$i1 eq ""} then {
      # no closing char > - not an HTML tag
      return false
    }
    set src [$w get $i0 $i1+1chars]
    if {[regexp {<\s*/} $src] ||
        [regexp {/\s*>} $src] ||
        [regexp {<\s*[?!]} $src]} then {
      # closing or empty tag - non-nestable
      apply $selectTo $w $i0 $i1+1chars
      return true
    } else {
      # opening tag - nestable
      set txt [string trim [$w get $i0+1chars $i1]]
      set name [lindex [split $txt] 0]
      set open <\\s*$name\[^>\]*>
      set close <\\s*/\\s*$name\\s*>
      set i1 $i0
      while true {
        set i1 [$w search -regexp $close $i1 end]
        if {$i1 eq ""} then {
          return false
        }
        set i1 [$w index [$w search > $i1 end]+1chars]
        set txt [$w get $i0 $i1]
        set txt [string map [list \{ " " \} " " \" " "] $txt]
        regsub -all $open $txt \{ txt
        regsub -all $close $txt \} txt
        if {[info complete $txt]} then {
          apply $selectTo $w $i0 $i1
          return true
        }
      }
    }
    return false
  } else {
    # braces, brackets - nestable
    if {$c0 in [list \{ \"]} then {
      set map {}
    } else {
      set map [list \{ " " \} " " \" " " $c0 \{ $c1 \}]
    }
    set i1 $i0
    while true {
      set i1 [$w search $c1 $i1+1chars end]
      if {$i1 eq ""} then {
        return false
      }
      if {[info complete [string map $map [$w get $i0 $i1+1chars]]]} then {
        apply $selectTo $w $i0 $i1+1chars
        return true
      }
    }
  }
}

proc ::TextEditorBindings::textEditorQuotes {{lang de}} {
  switch -exact -- $lang {
    de {
      set quotes {„ “ ‚ ‘}
    }
    en - en-AM {
      set quotes {“ ” ‘ ’}
    }
    fr {
      set quotes {» « › ‹}
    }
    ch {
      set quotes {« » ‹ ›}
    }
    default {
      bind TextEditor <Key-quotedbl> ""
      bind TextEditor <Key-quoteright> ""
      bind TextEditor <Escape><Key-quotedbl> ""
      bind TextEditor <Escape><Key-quoteright> ""
      bind TextEditor <Key-minus><Key-space> ""
      return
    }
  }
  lassign $quotes doubleOpen doubleClose singleOpen singleClose
  set insideTag {
    {window index} {
      set idx0 [$window search -backwards < $index 1.0]
      if {$idx0 eq ""} then {
        return false
      }
      set idx1 [$window search -backwards > $index 1.0]
      if {$idx1 eq ""} then {
        return true
      }
      if {[$window compare $idx0 < $idx1]} then {
        return false
      } else {
        return true
      }
    }
  }
  set wordStart {
    {text index} {
      # index am Anfang oder vor Leerzeichen?
      if {[$text compare $index == 1.0] ||
          [regexp {[\s-]} [$text get $index-1chars]]} then {
        return true
      } else {
        return false
      }
    }
  }
  bind TextEditor <Key-quotedbl> [subst -nocommand {
      if {[apply {$insideTag} %W insert]} then continue
      if {[apply {$wordStart} %W insert]} then {
        %W insert insert $doubleOpen
      } else {
        %W insert insert $doubleClose
      }
      break
    }]
  bind TextEditor <Key-quoteright> [subst -nocommand {        
      if {[apply {$insideTag} %W insert]} then continue
      if {[apply {$wordStart} %W insert]} then {
        %W insert insert $singleOpen
      } else {
        %W insert insert $singleClose
      }
      break
    }]
  bind TextEditor <Escape><Key-quotedbl> {
    %W insert insert \"
    break
  }
  bind TextEditor <Escape><Key-quoteright> {
    %W insert insert '
    break
  }
  switch -exact -- $lang {
    en-AM {
      bind TextEditor <Key-minus><Key-space> {
        if {[regexp {\s} [%W get insert-2c]]} then {
          %W delete insert-2c insert
          %W insert insert \u200b—\u200b
          break 
        }
      }
    }
    default {
      bind TextEditor <Key-minus><Key-space> {
        if {[regexp {\s} [%W get insert-2c]]} then {
          %W delete insert-1c
          %W insert insert –
        }
      }
    }
  }
}

namespace eval TextEditorBindings {
  bind TextEditor <Double-Button-1> {
    set tk::Priv(selectMode) word
    if {[TextEditorBindings::selectToClosingChar %W %x %y]} then break
  }
  bind TextEditor <Shift-Button-1> {
    if {$tk::Priv(selectMode) ne "word"} then continue
    if {[TextEditorBindings::selectToClosingChar %W %x %y]} then break
  }
  bind TextEditor <B1-Motion> {
    if {$tk::Priv(selectMode) ne "word"} then continue
    if {[TextEditorBindings::selectToClosingChar %W %x %y]} then break
  }
}

proc ::TextEditorBindings::textToEditor win {
  set idx [lsearch [bindtags $win] TextEditor]
  if {$idx < 0} then {
    bindtags $win [lreplace [bindtags $win] 1 0 TextEditor]
  }
  $win configure -undo yes
}

proc ::TextEditorBindings::editorToText win {
  set idx [lsearch [bindtags $win] TextEditor]
  bindtags $win [lreplace [bindtags $win] $idx $idx]        
  $win configure -undo yes
}

proc ::TextEditorBindings::textEditor {win args} {
  text $win -wrap word {*}$args
  textToEditor $win
  set win
}

proc ::TextEditorBindings::widgetTagIndex {text from to} {
  set startIdx [$text search < $from $to]
  if {$startIdx eq ""} then return
  set endIdx [$text search > $startIdx $to]
  if {$endIdx eq ""} then return
  list [$text get $startIdx $endIdx+1chars] $startIdx
}

proc ::TextEditorBindings::formOfTag tag {
  if {[regexp {<\s*/} $tag]} then {
    return close
  } elseif {[regexp {/\s*>} $tag] ||
            [regexp {<\s*[[:punct:]]} $tag]} then {
    return empty
  } else {
    return open
  }
}

proc ::TextEditorBindings::nameOfTag tag {
  lindex [split [string trim $tag </> ]] 0
}

proc ::TextEditorBindings::openingTagPattern openingTag {
  append pattern < {\s*} [nameOfTag $openingTag] .*? >
}

proc ::TextEditorBindings::closingTagPattern openingTag {
  append pattern < {\s*} / [nameOfTag $openingTag] {\s*} >
}

proc ::TextEditorBindings::widgetTokenList {text idx to {result {}}} {
  while true {
    lassign [widgetTagIndex $text $idx $to] tag idx
    if {$idx eq ""} then break
    lappend result $tag $idx
    set idx [$text index $idx+[string length $tag]chars]
  }
  set result
}

proc ::TextEditorBindings::widgetRangeTagsBalanced {text from to} {
  set level {}
  foreach {tag idx} [widgetTokenList $text $from $to] {
    set name [nameOfTag $tag]
    switch [formOfTag $tag] open {
      dict incr level $name
    } close {
      dict incr level $name -1
      if {[dict get $level $name] < 0} then {
        return false
      }
    }
  }        
  foreach key [dict keys $level] {
    if {[dict get $level $key] != 0} then {
      return false
    }
  }
  return true
}

namespace import\
  ::TextEditorBindings::textEditor\
  ::TextEditorBindings::textToEditor\
  ::TextEditorBindings::editorToText\
  ::TextEditorBindings::textEditorQuotes

proc ::TextEditorBindings::addTag {window tag start end} {
  if {[widgetRangeTagsBalanced $window $start $end]} then {
    while {[regexp {\s} [$window get $start]]} {
      $window tag remove sel $start
      if {[$window tag ranges sel] eq ""} then return
    }
    while {[regexp {\s} [$window get $end-1chars]]} {
      $window tag remove sel $end-1chars
      if {[$window tag ranges sel] eq ""} then return
    }
    $window edit separator
    $window insert $end </$tag> sel
    $window insert $start <$tag> sel
    $window edit separator
    if {[$window compare insert < sel.first]} then {
      $window mark set insert sel.first
    } elseif {[$window compare insert > sel.last]} then {
      $window mark set insert sel.last
    }
  }
}

proc ::TextEditorBindings::delTag {window start end} {
  while {[regexp {\s} [$window get $start]]} {
    $window tag remove sel $start
    if {[$window tag ranges sel] eq ""} then return
  }
  while {[regexp {\s} [$window get $end-1chars]]} {
    $window tag remove sel $end-1chars
    if {[$window tag ranges sel] eq ""} then return
  }
  set tokenList [widgetTokenList $window $start $end]
  if {$tokenList eq ""} then return
  lassign $tokenList tag0 idx0
  if {[$window compare $idx0 != $start]} then return
  lassign [lrange $tokenList end-1 end] tag1 idx1
  if {[$window compare $idx1+[string length $tag1]chars != $end]} then return
  if {[widgetRangeTagsBalanced $window $idx0+[string length $tag0]chars $idx1]} then {
    $window edit separator
    $window del $idx1 $idx1+[string length $tag1]chars
    $window del $idx0 $idx0+[string length $tag0]chars
    $window edit separator
    if {[$window compare insert < sel.first]} then {
      $window mark set insert sel.first
    } elseif {[$window compare insert > sel.last]} then {
      $window mark set insert sel.last
    }
  }
}

bind TextEditor <Button-3> {
  if {[%W tag ranges sel] eq ""} then {
    tk_popup .textEditorContextMenu %X %Y
  } else {
    tk_popup .textEditorSelContextMenu %X %Y
  }
}

destroy .textEditorContextMenu .textEditorSelContextMenu

menu .textEditorContextMenu -tearoff no
.textEditorContextMenu add command -label Paste -command {
  event generate [focus] <<Paste>>
}
.textEditorContextMenu add command -label "select all" -command {
  [focus] tag add sel 1.0 end-1c
}
.textEditorContextMenu add separator
.textEditorContextMenu add cascade\
  -label Quotes\
  -menu [menu .textEditorContextMenu.quotes]
apply {
  args {
    foreach {label sign} $args {
      .textEditorContextMenu.quotes add command\
        -label $label\
        -command "
        ::TextEditorBindings::textEditorQuotes $sign
      "
    }
  }
} German de English en American en-AM French fr Swiss ch None C

menu .textEditorSelContextMenu -tearoff no
.textEditorSelContextMenu add command -label cut -command {
  event generate [focus] <<Cut>>
}
.textEditorSelContextMenu add command -label copy -command {
  event generate [focus] <<Copy>>
}
.textEditorSelContextMenu add command -label "select all" -command {
  [focus] tag add sel 1.0 end-1c
}

.textEditorSelContextMenu add separator

.textEditorSelContextMenu add cascade\
  -label Inline\
  -menu [menu .textEditorSelContextMenu.inlinetag -tearoff no]
apply {
  args {
    foreach tag $args {
      .textEditorSelContextMenu.inlinetag add command\
        -label $tag\
        -command [subst -nocommand {
          ::TextEditorBindings::addTag [focus] $tag sel.first sel.last
        }]
    }
  }
} a q abbr em strong b i span

.textEditorSelContextMenu add cascade\
  -label Block\
  -menu [menu .textEditorSelContextMenu.blocktag -tearoff no]
apply {
  args {
    foreach tag $args {
      .textEditorSelContextMenu.blocktag add command\
        -label $tag\
        -command [subst -nocommand {
          ::TextEditorBindings::addTag [focus] $tag sel.first sel.last
        }]
    }
  }
} p h1 h2 h3 h4 h5 h6 blockquote div

.textEditorSelContextMenu add cascade\
  -label List\
  -menu [menu .textEditorSelContextMenu.listtag -tearoff no]
apply {
  args {
    foreach tag $args {
      .textEditorSelContextMenu.listtag add command\
        -label $tag\
        -command [subst -nocommand {
          ::TextEditorBindings::addTag [focus] $tag sel.first sel.last
        }]
    }
  }
} ul ol dl li dt dd

.textEditorSelContextMenu add cascade\
  -label Document\
  -menu [menu .textEditorSelContextMenu.doctag -tearoff no]
apply {
  args {
    foreach tag $args {
      .textEditorSelContextMenu.doctag add command\
        -label $tag\
        -command [subst -nocommand {
          ::TextEditorBindings::addTag [focus] $tag sel.first sel.last
        }]
    }
  }
} html head title body

.textEditorSelContextMenu add command\
  -label "Remove outermost tags"\
  -command {
  ::TextEditorBindings::delTag [focus] sel.first sel.last
}

.textEditorSelContextMenu add separator

.textEditorSelContextMenu add cascade\
  -label Quotes\
  -menu [.textEditorContextMenu entrycget Quotes -menu]
Category Text Widget