home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / completions.tcl < prev    next >
Encoding:
Text File  |  1999-01-31  |  17.5 KB  |  575 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "completions.tcl"
  6.  #                                    created: 27/7/97 {12:43:41 am} 
  7.  #                                last update: 31/1/1999 {11:27:08 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  # 
  16.  # Basic parts of the completion package -- to handle word and
  17.  # file completion, but allowing very simple piggy-backing of
  18.  # advanced completions.
  19.  # ###################################################################
  20.  ##
  21.  
  22.  
  23. namespace eval bind {}
  24. namespace eval completion {}
  25.  
  26. # setup two globals
  27. ensureset completion::in_progress_proc error
  28. ensureset completion::in_progress_pos -1
  29.  
  30. ## 
  31.  # -------------------------------------------------------------------------
  32.  #     
  33.  #    "bind::Completion"    --
  34.  #    
  35.  #     If    we're already completing, jump to that procedure, else go through
  36.  #     a mode-dependent list of completion procedures    given by the array
  37.  #     'completions',    these return either    '1'    to indicate    termination, or
  38.  #     '0' to    say    either that    they failed    or that    they succeeded and that
  39.  #     further completion    procedures may be applied.
  40.  #     
  41.  #     If no mode-dependent procedure list exists (as in a basic Alpha
  42.  #     installation), then just the 'user' completions and 'word'
  43.  #     completions are attempted.  
  44.  #     
  45.  #     The list of procedures to try is copied into 'completion::chain',
  46.  #     so completion procs can modify that list if they like.
  47.  # -------------------------------------------------------------------------
  48.  ##
  49. proc bind::Completion {} {
  50.     if {![completion::tabDeleteSelection]} return
  51.     
  52.     global completion::in_progress_proc
  53.     if {[completion::notAlready]} {
  54.     set completion::in_progress_proc error
  55.     if {[completion::user]} return
  56.     set m [modeALike]
  57.     global completions mode completion::chain
  58.     if {[info exists completions($mode)]} {
  59.         set completion::chain $completions($mode)
  60.         while 1 {
  61.         if {[set c [lindex ${completion::chain} 0]] == ""} {
  62.             break
  63.         }
  64.         set completion::chain [lreplace ${completion::chain} 0 0]
  65.         if {[completion $m $c]} return
  66.         }
  67.         message "No further completions exist, perhaps you should write your own."
  68.     } else {
  69.         completion::word actual
  70.     }
  71.     }
  72. }
  73.  
  74. proc completion::user {{cmd ""}} { 
  75.     return 0 
  76. }
  77.  
  78. ## 
  79.  # -------------------------------------------------------------------------
  80.  #     
  81.  #    "completion::fromList" --
  82.  #    
  83.  #     Given a 'cmd' prefix and the name of a    list to    search,    that list
  84.  #     being stored in alphabetical order    and    starting/ending    with 
  85.  #     whitespace, this proc returns a list of all matches with 'cmd',
  86.  #     or    ""    if there were none.  Updated so works with arrays too (Nov'96)
  87.  #     
  88.  #     It's quite an important procedure for completions, and must handle
  89.  #     pretty large lists, so it's worth optimising.
  90.  #     
  91.  #     Note '\\b' = word boundary, '\\s' = whitespace '\\S' = not-whitespace
  92.  # -------------------------------------------------------------------------
  93.  ##
  94. if {[info tclversion] < 8.0} {
  95. proc completion::fromList { __cmd slist } {
  96.     global [lindex [split $slist "\("] 0]
  97.     # Find all matches as a list --- a v. clever trick if I say so myself
  98.     if {[regexp "(^|\\s)(${__cmd}\[^\\S\]*(\\s|\$))+" [set "$slist"] matches]} {
  99.         return [string trim $matches]
  100.     } else {
  101.         return ""
  102.     }
  103. }
  104. } else {
  105. proc completion::fromList { __cmd slist } {
  106.     global [lindex [split $slist "\("] 0]
  107.     regexp {^(.*)(.)$} $__cmd "" _find _last    
  108.     set _find "^[::quote::Regfind $_find]\[^$_last\].*"
  109.     set first [lsearch -glob [set $slist] "${__cmd}*"]
  110.     if {$first == -1} { return "" }
  111.     set first [lrange [set $slist] $first end]
  112.     set last [lsearch -regexp $first $_find]
  113.     if {$last == -1} {
  114.         incr last
  115.         while {[string match "${__cmd}*" [lindex $first $last]]} {
  116.         incr last
  117.         }
  118.     }
  119.     return [lrange $first 0 [incr last -1]]
  120. }
  121. }
  122.  
  123. ## 
  124.  # -------------------------------------------------------------------------
  125.  #     
  126.  #    "completion::notAlready" --
  127.  #    
  128.  #     Call this to check    if we should divert    directly to    a previously
  129.  #     registered    completion procedure instead of    starting from scratch.
  130.  # -------------------------------------------------------------------------
  131.  ##
  132. proc completion::notAlready {} {
  133.     global completion::in_progress_proc completion::in_progress_pos
  134.     # do the old completion if possible
  135.     if {[pos::compare ${completion::in_progress_pos} == [getPos]] } {
  136.     return [catch {completion [modeALike] ${completion::in_progress_proc}} ]
  137.     } else {
  138.     return 1
  139.     }    
  140. }
  141.  
  142. ## 
  143.  # -------------------------------------------------------------------------
  144.  #     
  145.  #    "completion::already"    --
  146.  #    
  147.  #     If a completion routine has been called once, and would like to
  148.  #     be called again (to cycle through a number    of possibilities), then
  149.  #     it should register    itself with    this procedure.
  150.  # -------------------------------------------------------------------------
  151.  ##
  152. proc completion::already { proc } {
  153.     global completion::in_progress_proc completion::in_progress_pos
  154.     # store the given completion
  155.     set completion::in_progress_proc $proc
  156.     set completion::in_progress_pos [getPos]
  157. }
  158.  
  159. ## 
  160.  # -------------------------------------------------------------------------
  161.  #     
  162.  #    "modeALike"    --
  163.  #    
  164.  #     Some modes    are    really equivalent as far as    commands etc. go, so
  165.  #     we    don't bother with duplication.
  166.  # -------------------------------------------------------------------------
  167.  ##
  168. proc modeALike {} {
  169.     global mode
  170.     switch -- $mode {
  171.     "C++" { return "C" }
  172.     "Shel" { return "Tcl" }
  173.     }
  174.     return $mode
  175. }
  176.  
  177.  
  178.  
  179. ## 
  180.  # -------------------------------------------------------------------------
  181.  #     
  182.  #    "completion" --
  183.  #    
  184.  #     Call a    completion,    by trying in order:
  185.  #       1) error
  186.  #       2) 'Type' is    actually a generic completion routine
  187.  #       3) '${mode}::Completion::${Type}' is a mode-specific routine
  188.  #       4) 'completion::${type}' is a generic routine.
  189.  #       
  190.  #     We also check for expansion procedures of the forms:
  191.  #       1) 'expansions::${type}'
  192.  #       2) '${mode}::Expansion::${Type}', where Type begins with 'Ex'
  193.  #
  194.  # -------------------------------------------------------------------------
  195.  ##
  196. proc completion { mode Type {match ""} } {
  197.     if { $Type == "error" } { error "" }
  198.     if {[string match "completion::*" $Type] \
  199.       || [string match "expansions::*" $Type]} {
  200.     return [$Type "${match}"]
  201.     } elseif {[llength [info commands ${mode}::Completion::${Type}]]} {
  202.     return [${mode}::Completion::${Type} "${match}"]
  203.     } elseif {[llength [info commands ${mode}::Expansion::${Type}]]} {
  204.     return [${mode}::Expansion::${Type} "${match}"]
  205.     } else {
  206.     return [eval completion::[string tolower $Type] \"${match}\"]
  207.     }
  208. }
  209.  
  210. proc completion::word {dummy} {
  211.     return [completion::update completion::word]
  212. }
  213.  
  214. proc completion::update { proc {got ""} {looking ""} } {
  215.     if {[completion::general $got $looking]} {
  216.     completion::already $proc
  217.     return 1
  218.     } else {
  219.     completion::already error
  220.     return 0
  221.     }
  222. }    
  223.  
  224. proc completion::general { {got ""} {looking ""} } {
  225.     global __wc__len __wc__prevPos completion::in_progress_pos \
  226.       __wc__prevFound __wc__pat __wc__nextStart __wc__fwd \
  227.       completion::in_progress_proc wordBreak \
  228.       __wc_prevHits
  229.     
  230.     set pos [getPos]
  231.     # Cursor changed place?
  232.     if {[pos::compare $pos == ${completion::in_progress_pos}]} {
  233.     # it is an old search
  234.     set ret [completion::wc__newSearch $pos]
  235.     if { $ret == 1 } {
  236.         return 1
  237.     } elseif { $ret == -1 } {
  238.         select [pos::math $pos + [expr [string length $looking] - \
  239.           [string length $__wc__prevFound] - [string length $got]]] $pos
  240.         return 0
  241.     }
  242.     }
  243.     # Start new search for completion::Word
  244.     if { $got == "" } {    
  245.     # this is a normal completion
  246.     set one [completion::lastWord start]
  247.     
  248.     set __wc__len [string length $one]
  249.     set __wc__pat [quote::Regfind $one]
  250.     append __wc__pat $wordBreak
  251.     } else {
  252.     # here we complete 'got' with something beginning 'looking'
  253.     set start [pos::math $pos - [string length $got]]
  254.     set one $looking
  255.     set __wc__len [string length $one]
  256.     set __wc__pat [quote::Regfind $one]
  257.     
  258.          # we want to find anything else which continues a 'word'
  259.     append __wc__pat $wordBreak
  260.     }    
  261.     set start [pos::math $start - 1]
  262.     set __wc_prevHits {}
  263.     
  264.     if {![catch {search -s -f 0 -r 1 -i 0 -m 1 -- $__wc__pat $start} data]} {
  265.     set d00 [lindex $data 0]
  266.     set beg [pos::math $d00 + $__wc__len]
  267.     set end [lindex $data 1]
  268.     set __wc__prevFound [getText $d00 $end]
  269.     lappend __wc_prevHits $__wc__prevFound
  270.     set txt [getText $beg $end]
  271.     goto $pos
  272.     insertText $txt
  273.     message "Found above."
  274.     # Set a number of globals for possible next go-around
  275.     set completion::in_progress_pos [getPos]
  276.     set __wc__prevPos $pos
  277.     set __wc__nextStart [pos::math $d00 - $__wc__len]
  278.     set __wc__fwd 0
  279.     return 1
  280.     }
  281.     if {![catch {search -s -f 1 -r 1 -i 0 -m 1 -- $__wc__pat $pos} data]} {
  282.     set __wc__prevFound [getText [lindex $data 0] [lindex $data 1] ]
  283.     lappend __wc_prevHits $__wc__prevFound
  284.     set beg [pos::math [lindex $data 0] + $__wc__len]
  285.     set end [lindex $data 1]
  286.     set txt [getText $beg $end]
  287.     goto $pos
  288.     insertText $txt
  289.     message "Found below."
  290.     # Set a number of globals for possible next go-around
  291.     set completion::in_progress_pos [getPos]
  292.     set __wc__prevPos $pos
  293.     set __wc__nextStart $end
  294.     set __wc__fwd 1
  295.     return 1
  296.     }
  297.     goto $pos
  298.     return 0
  299. }
  300.  
  301. # returns '1' if it succeeded 
  302. # or -1 if failed completely
  303.  
  304. proc completion::wc__newSearch { pos } {
  305.     global __wc__len __wc__prevPos completion::in_progress_pos \
  306.       __wc__prevFound __wc__pat __wc__nextStart __wc__fwd \
  307.       __wc_prevHits 
  308.     
  309.     while 1 {    
  310.     if {$__wc__fwd} {
  311.         set fndMsg "Found below."
  312.     } else {
  313.         set fndMsg "Found above."
  314.     }
  315.     if {![catch {search -s -f $__wc__fwd -r 1 -i 0 -m 1 -- $__wc__pat $__wc__nextStart} data]} {
  316.         set d00 [lindex $data 0]
  317.         set beg [pos::math $d00 + $__wc__len]
  318.         set end [lindex $data 1]
  319.         set Hit [getText $d00 $end]
  320.         
  321.         #if (this Hit is not the same as the last one)
  322.         if {[lsearch -exact $__wc_prevHits $Hit] == -1} {
  323.         
  324.         #add the hit to the list of previous hits
  325.         lappend __wc_prevHits $Hit
  326.         set __wc__prevFound $Hit
  327.         
  328.         set txt [getText $beg $end]
  329.         deleteText $__wc__prevPos ${completion::in_progress_pos}
  330.         goto $__wc__prevPos
  331.         insertText $txt
  332.         message $fndMsg
  333.         # Set a number of globals for possible next go-around
  334.         set completion::in_progress_pos [getPos]
  335.         if {$__wc__fwd} {
  336.             # Search Forwards
  337.             set __wc__nextStart $end
  338.             # End of found word
  339.         } else {
  340.             # Search Backwards
  341.             set __wc__nextStart [pos::math $d00 - $__wc__len]
  342.             # Before start of found word
  343.             if {[pos::compare $__wc__nextStart <= [minPos]]} {
  344.             set __wc__fwd 1
  345.             set __wc__nextStart ${completion::in_progress_pos}
  346.             }
  347.         }
  348.         return 1
  349.         } else {
  350.         # Move start of search after finding string again
  351.         if {$__wc__fwd} {
  352.             # Searching Forwards
  353.             set __wc__nextStart $end
  354.             # End of found word
  355.         } else {
  356.             # Still Searching Backwards
  357.             set __wc__nextStart [pos::math $d00 - $__wc__len]
  358.             # Before start of found word
  359.             if {[pos::compare $__wc__nextStart <= [minPos]]} {
  360.             set __wc__fwd 1
  361.             set __wc__nextStart ${completion::in_progress_pos}
  362.             }
  363.         }
  364.         }
  365.         # End if hit is the same as a previous hit
  366.     } else {
  367.         # Search string not found
  368.         if {$__wc__fwd} {
  369.         # We were already looking forward, so the word is not in the file
  370.         message "Not found."
  371.         set completion::in_progress_pos -1
  372.         goto $pos
  373.         return -1
  374.         } else {
  375.         # start looking forward
  376.         set __wc__fwd 1
  377.         set __wc__nextStart ${completion::in_progress_pos}
  378.         }
  379.     }
  380.     
  381.     }
  382.     return 0
  383. }
  384.  
  385. ## 
  386.  # -------------------------------------------------------------------------
  387.  #     
  388.  #    "completion::lastWord"    --
  389.  #    
  390.  #     Return    the    last word, without moving the cursor. If a variable    name
  391.  #     is    given, it is returned containing the position of the start of the
  392.  #     last word.
  393.  #     
  394.  #     Future extensions to this proc (in packages) may include further
  395.  #     optional arguments.
  396.  # -------------------------------------------------------------------------
  397.  ##
  398. proc completion::lastWord {{st ""}} {
  399.     set pos [getPos]
  400.     backwardWord
  401.     if {$st != ""} {upvar $st beg}
  402.     set beg [getPos]
  403.     goto $pos
  404.     if {[pos::compare $beg < [lineStart $pos]] \
  405.       || [pos::compare $beg == $pos]} {error ""}
  406.     return [getText $beg $pos]
  407. }
  408.  
  409.  
  410. ## 
  411.  # -------------------------------------------------------------------------
  412.  # 
  413.  # "completion::lastTwoWords" --
  414.  # 
  415.  #  Get last two words: returns the previous word, and sets the given var
  416.  #  to the word before that.  Note that the 'word before that' actually
  417.  #  means all text from the start of that word up to the beginning of the
  418.  #  word which is returned.  i.e. 'prev' will normally end in some sort of
  419.  #  space/punctuation.
  420.  #     
  421.  #    Future extensions to this proc (in packages) may include further
  422.  #    optional arguments.
  423.  # -------------------------------------------------------------------------
  424.  ##
  425. proc completion::lastTwoWords {prev} {
  426.     set pos [getPos]
  427.     backwardWord
  428.     set beg_rhw [getPos]
  429.     backwardWord
  430.     set beg_lhw [getPos]
  431.     goto $pos
  432.     upvar $prev lhw
  433.     if {[pos::compare $beg_lhw < [lineStart $pos]] \
  434.       || [pos::compare $beg_lhw == $beg_rhw] } { 
  435.     set lhw { } 
  436.     } else {
  437.     set lhw [getText $beg_lhw $beg_rhw]
  438.     }
  439.     return [getText $beg_rhw $pos]
  440. }
  441.  
  442. ## 
  443.  # -------------------------------------------------------------------------
  444.  #     
  445.  #    "completion::tabDeleteSelection" --
  446.  #    
  447.  #     If    there is a selection, this procedure is    called by completion
  448.  #     routines to ask the user if it    should be deleted (or if the 
  449.  #     appropriate flag is set, to delete    automatically).
  450.  # -------------------------------------------------------------------------
  451.  ##
  452. proc completion::tabDeleteSelection {} {
  453.     global completion::in_progress_proc askDeleteSelection elecStopMarker
  454.     if {([regexp "^\$|^$elecStopMarker" [getSelect]] || !$askDeleteSelection)} {
  455.     deleteText [getPos] [selEnd]
  456.     } else {
  457.     if {[dialog::yesno "Delete selection?"]} {
  458.         deleteText [getPos] [selEnd]
  459.         set completion::in_progress_proc error
  460.     } else {
  461.         return 0
  462.     }
  463.     }
  464.     return 1
  465. }
  466.  
  467.  
  468.  
  469. ## 
  470.  # -------------------------------------------------------------------------
  471.  #     
  472.  # "completion::file" --
  473.  #    
  474.  #    Look back, see if there's a    file/dir name and try and extend it.
  475.  #    Useful for Shel    mode.  This    improves on    the    one    that comes with
  476.  #    Alpha by default, and is much simpler.
  477.  # -------------------------------------------------------------------------
  478.  ##
  479. proc completion::filename { {dummy ""}} {
  480.     set pos [getPos]
  481.     set res [search -s -f 0 -i 0 -m 0 -r 1 -n -- "\[\"\{ \t\r\n\]" [pos::math $pos - 1]]
  482.     if {[string length $res]} {
  483.     set from [lindex $res 1]
  484.     if {[pos::compare $from < $pos]} {
  485.         set pre ":"
  486.         set text [getText $from $pos]
  487.         if {[catch {glob ":${text}*"} globbed]} {
  488.         if {[catch {glob "${text}*"} globbed]} {
  489.             return 0
  490.         }
  491.         set pre ""
  492.         }
  493.         completion::Find "$pre$text" $globbed
  494.         return 1
  495.     }
  496.     }
  497. }
  498.  
  499. ## 
  500.  # -------------------------------------------------------------------------
  501.  #     
  502.  #    "completion::Find" --
  503.  #    
  504.  #     Insert    the    completion of 'cmd'    from the list 'matches', and return
  505.  #     the complete match    if there was one.
  506.  #    
  507.  #     'cmd' is what we have, 'matches' is a list of things which can complete
  508.  #     it, and 'forcequery' says don't bother with partial completions: if
  509.  #     we can't finish the command off, present the user with a list.
  510.  # -------------------------------------------------------------------------
  511.  ##
  512. proc completion::Find { cmd matches {isdbllist 0} {forcequery 0} {addQuery ""} {addAction ""}} {
  513.     global listPickIfMultCmps __univ_NotBlocked listPickIfNonUniqueStuckCmp
  514.     
  515.     set cmdlen [string length $cmd]
  516.     set mquery [set match [lindex $matches 0]]
  517.     if {$isdbllist} { set match [lindex [lindex $match 0] 0]}
  518.     if { [set cmdnum [llength $matches]] == 1 || $match == $cmd } {
  519.     # It's unique or already a command, so insert it 
  520.     # and turn off cmd completion.
  521.     if {$cmdnum != 1 && $listPickIfNonUniqueStuckCmp \
  522.       && (![catch { set match [listpick -p "Pick a completion" -L $mquery $matches]}])} {
  523.         if {$isdbllist} { set match [lindex [lindex $match 0] 0]}                    
  524.     } else {
  525.         message "Text is now a maximal completion."
  526.         # so we move on
  527.     }
  528.     set maxcompletion [string range $match $cmdlen end]
  529.     insertText $maxcompletion
  530.     # so we move on
  531.     return $match
  532.     } else {
  533.     set item [lindex $matches [incr cmdnum -1]]
  534.     if {$isdbllist} { set item [lindex [lindex $item 0] 0] }
  535.     set p [string length [largestPrefix [list $match $item]]]
  536.     #set p $cmdlen
  537.     #while {[string index $match $p]==[string index $item $p]} {incr p}
  538.     if { $p == $cmdlen || $forcequery } {
  539.         beep
  540.         if {$listPickIfMultCmps || $forcequery} {
  541.         if {$addQuery != ""} {
  542.             lappend matches "————————————————————————" $addQuery
  543.         }
  544.         if {[catch { set match [listpick -p "Pick a completion" -L $mquery $matches]}] \
  545.           || $match == "————————————————————————" } {
  546.             message "Cancelled"
  547.             return 1
  548.         } else {
  549.             if {$match == $addQuery} {
  550.             $addAction
  551.             return 1
  552.             }
  553.             if {$isdbllist} { set match [lindex [lindex $match 0] 0]}                    
  554.             set maxcompletion [string range $match $cmdlen end]
  555.             insertText $maxcompletion
  556.             # so we move on
  557.             return $match
  558.         }
  559.         
  560.         } else {
  561.         message "Can't extend --- ${matches}"
  562.         set __univ_NotBlocked 0
  563.         }
  564.     } else { 
  565.         set maxcompletion [string range $match $cmdlen [incr p -1]]
  566.         insertText $maxcompletion
  567.         message "Matching: ${matches}"
  568.     }        
  569.     return ""
  570.     }
  571.     
  572. }
  573.  
  574.  
  575.