#f tcl-mode.tcl - mode stead for editing tcl code
# 
# diam =  Maurice DIAMANTINI (diam@ensta.fr)
# 
# 29/11/01 (diam) : début de refonte
# 05/12/96 (diam) : modif (légères) des procédures de coloriage
# 13/09/96-17/09/96 : Modification du principe de coloriage. (Modifs 
#                     par David Carqueij (carqueij@ensta.fr))
# 27/06/95 : correction bug coloris. de global (bug) + uplevel et upvar
# 30/05/95 : 
# 

## mode_tcl_init --
# 
proc mode_tcl_init {} {

    global stead
    global EDITPREFS
    
    # Les commandes à exécuter si on quitte ce mode
    set stead(mode,cleanupCmds) [list]

    # définit le préfixe pour le mode matlab (pour mettre en commentaires)
    set EDITPREFS(prefix) "# "
    
    set EDITPREFS(autobreak) 0
    
    # Une liste de fichier fréquement éditer (à personaliser par l'utilisateur)
    # On peut utiliser les métacaracteres ou les variables d'environnement)
    set stead(mode,tcl,favorFiles) {
        /insert/here/you/favorite/list/of/files/modeles
        $::stead(install)/lib/etc/*.tcl
        $::stead(install)/lib/stead/core/main.tcl
        ~/.stead/steadrc
        /home/uma/diam/.stead_alpha/steadrc
    }
    
    # 
    # Définition du menu de navigation A REFONDRE
    # 
    global TE_MODE_SEARCH_STRING TE_MODE_NAVIG_SHOW_TEXT  
    set TE_MODE_SEARCH_STRING \
      {\n[ \t]*(?:proc|typemethod|method|type|class)[ \t]*([^ \t\n\{]+)};#bal \}
    set TE_MODE_NAVIG_SHOW_TEXT "procs" ;# nom de menu de navigation

    proc te:mode:navig_sort_hook {list} {
        return [lsort -command te:mode:sort_command $list]
    }
}

## mode_tcl_defineStyles -
# 
proc mode_tcl_defineStyles {} {
    global stead
    upvar #0 stead(text) w
    
    # # # # On commence par supprimer tout style précédent du jeu "tcl"
    # # # xtext_style $w delete tcl

    lappend stead(mode,cleanupCmds) \
                        [list xtext_style $w delete $stead(mode)]

    # Patternes utiles dans ce qui suit
    # preCmdPat : debut de fichier, de ligne ou apres une bracket
    set preCmdPat {(?:(?:^|\n|;|\[)\s*)\m}    ;#\]

    xtext_style $w define tcl  keywordsAll  [list   \
            -type regexpLine                        \
            -config {-foreground blue}              \
            -pat "${preCmdPat}(\[a-z\]+)\\s"             \
    ]                                               
    # La specList peut etre de la forme :
    # - soit une liste paire comme dans l'exemple "proc" du mode tcl
    # - soit un singleton dont l'élément unique est une liste paire
    # 
    set procPat   $preCmdPat
    append procPat {(proc[ \t]+[-\w_\.:]+)}
    xtext_style $w define tcl proc [list  \
        -type regexpLine                  \
        -config {-foreground red}         \
        -pat $procPat                     \
    ]
    # Balance stead : \]
    set  keywords1   { 
        exit  error return break continue catch
        global variable uplevel upvar 
        send source 
        update vwait after
        "namespace eval" "namespace export" namespace
        "package require" "package provide" package
        default  
    }
    xtext_style $w define tcl scope [list       \
        -type wordList                          \
        -config {-foreground red}               \
        -prePat $preCmdPat                      \
        -postPat {\M}                           \
        -values $keywords1                      \
    ]
    
    set  keywords2   { 
           set unset foreach 
           
           list lappend concat lindex lrange linsert llength lsearch
           lreplace 
           
           while if then else elseif for switch default
           
           puts expr close open  subst incr 
           eof flush gets read seek tell fconfigure fileevent socket
           
           regexp regsub glob scan append
           
           eval pwd cd  
           
           "array exists" "array get" "array names" "array set" 
           "array size" "array startsearch" "array nextelement" 
           "array anymore" "array donesearch" 
           
           info 
           "info proc" "info body" "info command" "info args"
           "info complete" "info exists" "info global" "info library" 
           
           "trace variable" "trace vdelete" "trace vinfo" 
           
           "string match" "string compare" "string index" 
           "string last" "string range" "string length" "string tolower" 
           "string toupper" "string trim" "string trimleft" 
           "string trimright"  "string wordend" "string worstart" 
           "string equal"  
           
           "file atime" "file dirname"  "file executable" "file exists" 
           "file extension" "file isdirectory" "file isfile" "file lstat" 
           "file mtime" "file owned" "file readable" "file readlink" 
           "file rootname" "file size" "file stat" "file tail" 
           "file type" "file writable" 
           
           "interp create" "interp alias" 
           
           bind pack frame radiobutton entry label 
           checkbutton frame button unset "wm title" wm
    }
    # xtext_style $w define tcl  keywords2  [list   \
    #         -type wordList                        \
    #         -config {-foreground blue}            \
    #         -prePat $preCmdPat                    \
    #         -postPat {\M}                         \
    #         -values $keywords2                    \
    # ]                                               
                            
    
    # Traitement <Control-C> si précédé de "bind" ou de "event"
    # Traitement des guillemets
    # 
    xtext_style $w define tcl {
        bindings {
            -type regexpLine
            -config {-foreground red4}
            -pat {(?:(?:bind|event)\s+.*?(<.*?>))}
        }
        quotes {
            -type regexpLight
            -config {-foreground #700}
            -pat {(".*?")}
        }
        singleQuotes {
            -type regexpLine
            -config {-foreground red -font bold}
            -pat {^(?:[^"]*)(")(?:[^"]*)$}
        }
    }
        
    set pat   {(?:^|;|\[)(?:\s*)(#.*)} ;# pour balance dans stead : \]
    set config  "-foreground #070 "
    set stead(tagSpec,shell_comment) [list  \
        -type   regexpLine                  \
        -pat    $pat                        \
        -config $config                     \
    ]
    xtext_style $w define tcl comment   $stead(tagSpec,shell_comment)    


    # Mise en valeur des backslash important (en fin de ligne)
    xtext_style $w define tcl {
        lineEndedBacklash {
            -type regexpLine
            -pat {(\B$)}
            -config {
                -foreground red -font bold
            }
        }
        errorBacklash {
            -type regexpLine
            -pat {(\B[ \t]+$)}
            -config {
                -background red -foreground yellow
            }
        }
    }
    # erreur légère (rose claire)
    # J'en ai mare des tabulations qu'on trouve dans le code source
    # et qui perturbe l'indentation
    xtext_style $w define tcl {
        tabulation {
            -type regexpLight
            -pat {\t}
            -config {
                -background "#FDD"
            }
        }
    }
    
    xtext_style $w enable tcl
    
}



## mode_tcl_getHelp - retourne une chaine d'info spécifique au mode tcl
# 
proc mode_tcl_getHelp {} {

  set help {\

    Aide du mode Tcl :  CE QUI SUIT EST OBSOLÈTE !
    
    Le menu "proc" permet d'accéder rapidement à une procédure du fichier.

    Colorisation :
    -------------
    Mots mots-clés important    Rouge
    Structure (if,then,...)     Bleu
    Commentaires                Vert
    
    Abbréviation statiques : 
    ------------------------
    Taper l'abrév. suivis de <Meta-Espace>, 
    
    for            boucle for
    fe             boucle foreach
    while          boucle while
    if             if
    
    proc           bloc interactif procedure

        
    A l'intérieur de ces structures <Control-j> permet de sauter d'une
    marque à l'autre. 
    
    Raccourcis claviers : (à compléter)
    ---------------------
    <meta-1>       insertion d'un séparateur "###..."

  }
  return $help
}


## mode_tcl_defineSabbrev -
# 
proc mode_tcl_defineSabbrev {} {
    ########################################################################
    # pour simplifier l'ecriture des electric-alias en déclarant :
    #    M : Marque temporaire
    #    B : début de postcommande 
    #    E : fin de postcommande
    #    V : Inclusion d'une variable TCL
    electricAlias-use8bitsCars
        
    ## diam 21/08/00 essai d'un nouvelle API pour les electricAlias
    #  On n'utilise plus que les caractere spéciaux TCL [ ] et $
    # 
    
    set    tmp {[askVar "Function name" NAME]}
    append tmp {## [getVar NAME] -- [setStop]\n}
    append tmp {# \n}
    append tmp {# \n}
    append tmp {proc [getVar NAME] { [setStop] } \{\n}
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl proc $tmp
    
    set    tmp {[askVar "procedure name" NAME]}
    append tmp {## [getVar NAME] -- [setStop]\n}
    append tmp {# \n}
    append tmp {# arguments:\n}
    append tmp {# \n}
    append tmp {#   - \n}
    append tmp {# \n}
    append tmp {# results:\n}
    append tmp {# \n}
    append tmp {# \n}
    append tmp {# \n}
    append tmp {# examples\n}
    append tmp {# \n}
    append tmp {# \n}
    append tmp {# \n}
    append tmp {proc [getVar NAME] { [setStop] } \{\n}
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    # # # electricAlias-def ${M}tcl proc2 $tmp
    # # # electricAlias-defSol tcl proc2 $tmp
    defAlias -sol  tcl proc2 $tmp
    
    # Pour information : ceci est l'ancienne méthode
    set    tmp "${B}askalias {procedure name} NAME${E}"
    append tmp "## $V{NAME} -- $M\n"
    append tmp "# \n"
    append tmp "# \n"
    append tmp "# \n"
    append tmp "proc $V{NAME} \{$M\} \{\n"
    append tmp "${B}i${E}$M\n"
    append tmp "\}\n"
    append tmp "$M"
    electricAlias-def ${M}tcl procold $tmp
    
    
    # # electricAlias-def ${M}tcl tclsh   "${B}insert_tclsh_header insert${E}"
    # # electricAlias-def ${M}tcl wish    "${B}insert_wish_header  insert${E}"
    # # electricAlias-def ${M}tcl tclsh   {[insert_tclsh_header insert]}
    # # electricAlias-def ${M}tcl wish    {[insert_wish_header  insert]}
    defAlias tcl tclsh   {[insert_tclsh_header 1.0]}
    defAlias tcl wish    {[insert_wish_header  insert]}
    
    # # Test d'un alias neutre pour dépister les espaces parasites FONCTIONNENT
    # defAlias tcl nop     {PONPON}
    # defAlias tcl nop1    {\bPONPON}
    # defAlias tcl nop2    {\b\bPONPON}
    # defAlias tcl nop3    {\b\b\bPONPON}
    # defAlias tcl nop4    {PONPON\b\b\b}
    
    # # La commande set "" "" est un hack pour pouvoir utiliser xtext_setCursor
    # # sans recevoir sa valeur de retour ! 
    # # 
    # # 
    # # 
    # #  A FAIRE : CREER UNE PROCEDURE "nop" QUI FAIT CELA
    # #  
    # #  
    # #  
    # #  
    # set    tmp {[xtext_setCursor $::stead(text) 1.0; set "" ""]}
    # append tmp {#!/bin/sh\n}
    # append tmp {# the next line restarts using tclsh \\\n}
    # append tmp {exec tclsh "\$0"    $\{1+"\$@"\}}
    # append tmp {\n\n}
    # defAlias  tcl tclsh $tmp
    # # 
    # set    tmp {[xtext_setCursor $::stead(text) 1.0; set "" ""]}
    # append tmp {#!/bin/sh\n}
    # append tmp {# the next line restarts using wish \\\n}
    # append tmp {exec wish "\$0" --  $\{1+"\$@"\}}
    # append tmp {\n\n}
    # defAlias  tcl wish $tmp
    
    ## alias switch multiplateform
    # global tcl_platform
    # 
    # switch -- $tcl_platform(platform) {
    #     macintosh {
    #        CODE pour Mac
    #     }
    #     windows -
    #     default {
    #         CODE pour windows et unix
    #     }
    # }
    # 
    set    tmp {global tcl_platform\n}
    append tmp {switch -exact -- \$tcl_platform(platform) \{\n}
    append tmp {  macintosh \{\n}
    append tmp {  [i][setStop]\n}
    append tmp {  \}\n}
    append tmp {  windows \{\n}
    append tmp {  [i][setStop]\n}
    append tmp {  \}\n}
    append tmp {  unix \{\n}
    append tmp {  [i][setStop]\n}
    append tmp {  \}\n}
    append tmp {\}\n}
    append tmp {[setStop]\n}
    # 
    electricAlias-def ${M}tcl plat $tmp
    
    
    # foreach sans ";# endforeach"
    set t1 {foreach [setStop]  [setStop]  \{\n[i][setStop]\n}
    set t2 {\}\n[setStop]}
    electricAlias-def ${M}tcl foreach $t1$t2
    electricAlias-def ${M}tcl fe      $t1$t2
    
    # foreach avec ";# endforeach"
    set t1 {foreach [setStop]  [setStop]  \{\n[i][setStop]\n}
    set t2 {\} ;# endforeach\n[setStop]}
    electricAlias-def ${M}tcl Foreach $t1$t2
    electricAlias-def ${M}tcl Fe      $t1$t2
    
    # for sans "endfor"
    set    tmp {for \{[setStop]\} \{[setStop]\} \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl for $tmp
    
    # for avec "endfor"
    set    tmp {for \{[setStop]\} \{[setStop]\} \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}  ;# endfor\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl For $tmp
    
    # for sans "endwhile"
    set    tmp {while \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl while $tmp
    electricAlias-def ${M}tcl w     $tmp
    
    # for avec "endwhile"
    set    tmp {while \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}  ;# endwhile\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl While $tmp
    electricAlias-def ${M}tcl W     $tmp
    
    # if sans "endif"
    set    tmp {if \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl if $tmp
    
    # if avec "endif"
    set    tmp {if \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\}  ;# endif\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl If $tmp
    
    # if/else sans "endif"
    set    tmp {if \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\} else \{\n}
    append tmp {[i][setStop]\n}
    append tmp {\}\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl ife $tmp
    
    # if/else avec "endif"
    set    tmp {if \{[setStop]\} \{\n} 
    append tmp {[i][setStop]\n}
    append tmp {\} else \{\n}
    append tmp {[i][setStop]\n}
    append tmp {\}  ;# endif\n}
    append tmp {[setStop]}
    electricAlias-def ${M}tcl Ife $tmp
    
    
    set    tmp {switch -exact -- [setStop] \{\n}
    append tmp {[i][setStop] \{\n}
    append tmp {[i][i][setStop]\n}
    append tmp {[i]\}\n}
    append tmp {[i][setStop] \{\n}
    append tmp {[i][i][setStop]\n}
    append tmp {[i]\}\n}
    append tmp {[i]default \{\n}
    append tmp {[i][i][setStop]\n}
    append tmp {[i]\}\n}
    append tmp {\}\n}
    append tmp {[setStop]\n}
    # 
    electricAlias-def ${M}tcl switch $tmp
    electricAlias-def ${M}tcl sw     $tmp
        
    
    electricAlias-def tcl "=" "=="
    electricAlias-def tcl backwordWord backwardWord
    
    
    electricAlias-def ${M}tcl "${M}file" {# FILE: $stead(filename)
    # 
    # LAST UPDATE:  [now] 
    # \
    }
    electricAlias-def ${M} "${M}procs" {# This file contains the following tcl procedure(s):
    #
    #       ¤Çaskalias "tcl Proc" procÈ¤{proc} -- 
    }
}

proc insert_tclsh_header { {idx 1.0} } {
    global stead
    set w $stead(text)
    
    set    txt {#!/bin/sh\n}
    append txt {# the next line restarts using tclsh \\\n}
    append txt {exec tclsh "$0"    $\{1+"$@"\}}
    append txt {\n\n}
    xtext_setCursor $w 1.0
    xtext_insert $w -index $idx -- [subst -novariables $txt] 
}
proc insert_wish_header { {idx 1.0} } {
    global stead
    set w $stead(text)
    
    set    txt {#!/bin/sh\n}
    append txt {# the next line restarts using tclsh \\\n}
    append txt {exec wish "$0"  --  $\{1+"$@"\}}
    append txt {\n\n}
    xtext_setCursor $w 1.0
    xtext_insert $w -index $idx -- [subst -novariables $txt] 
}
## insert_switch_platform_header -
# 
proc insert_switch_platform_header { {idx insert} } {
    set    txt "global tcl_platform\n"
    append txt "[i]switch -exact -- \$tcl_platform(platform) \{\n"
    append txt "[i]  macintosh \{\n"
    append txt "[i]  \} \n"
    append txt "[i]  windows \{\n"
    append txt "[i]  \} \n"
    append txt "[i]  unix \{\n"
    append txt "[i]  \} \n"
    append txt "[i]\} \n"
    append txt \n
    insert $txt $idx
}

## insert_library
# 
proc insert_library { {lib  "~/lib/tcl"} } {
    # on veut générer une ligne de la forme :
    # set auto_path [concat [list [glob ~/lib/tk]] $auto_path]
    set    txt {set auto_path [concat [list [ glob }
    append txt "$lib"
    append txt { ] ] $auto_path ]}
    append txt "\n"
    insert $txt 
}


## mode_tcl_defineMenu_tcl - défini le menu principale de tcl
# 
# 
proc mode_tcl_defineMenu_tcl {} {
    global stead
    
    set menubutton  .menu.$stead(mode)
    set m           .menu.$stead(mode).m
    
    if {[winfo exists $menubutton]} {
        destroy $menubutton
    }
    # Création d'un bouton de menu (ce qu'on voit)
    menubutton $menubutton \
            -text [string totitle $stead(mode)] \
            -menu .menu.$stead(mode).m
            
    lappend stead(mode,cleanupCmds) [list destroy  $menubutton]

    # On positionne ce bouton
    pack append .menu $menubutton left
  
    # Création d'un menu (ce qui ce déroule quand on clique sur le menubutton)
    set m [menu $m]
    # 
    ####################################################################
    

    
    $m add command \
            -label {search selected proc (in this file or in this stead)} \
            -command {stead:searchTclProc $stead(text)}
   
    $m add command \
            -label {Lancer wish sur ce fichier} \
            -command {mode_tcl_execWish}
            
              
    $m add separator

    ## Sous menu pour les fichiers modèles de ce mode
    $m add cascade \
            -label {Fichiers modèles}  \
            -menu "$m.files"
          
    menu $m.files
    foreach pat $::stead(mode,tcl,favorFiles) {
        foreach file [glob -nocomplain  $pat] {
            $m.files add command \
                 -label $file \
                 -command "stead $file"
        }  
    }
    
    ## Sous menu pour les fichiers tcl du répertoire courant
    menu:makeEditSubmenuFromDirectory2  $m $m.files[xtcl_uid]  \
           "Current directory Tcl files"  \
          [file dirname $stead(file)]/*.tcl


}

## mode_tcl_defineMenu_templates - défini le menu Templates de tcl
# 
# 
proc mode_tcl_defineMenu_templates {} {
    global stead
    
    ###########################################################################
    # On crée le menu template s'il n'existe pas
    # 
    set menubutton  .menu.template
    set m           .menu.template.m
    
    if {[winfo exists $menubutton]} {
        destroy $menubutton
    }
    # Création d'un bouton de menu (ce qu'on voit)
    menubutton $menubutton  \
            -text Templates \
            -menu $m
            
    lappend stead(mode,cleanupCmds) [list destroy  $menubutton]

    # On positionne ce bouton
    pack append .menu $menubutton left
  
    # Création d'un menu (ce qui ce déroule quand on clique sur le menubutton)
    set m [menu $m]
    
    # 
    ##################################################################
      

    $m add command \
            -label "Insérer un separateur \"#...\"" \
            -command {separator 1}
    
    $m add command \
            -label {proc...} \
            -command {electricAlias-wrap proc}
    
    $m add separator
    $m add command \
            -label {Switch multiplatform} \
            -command {insert_switch_platform_header}
                   
    $m add separator
    $m add command \
            -label {En-tête "#!..wish"} \
            -command {insert_wish_header 1.0}
    $m add command \
            -label {En-tête "#!..tclsh"} \
            -command {insert_tclsh_header 1.0}
            
    $m add command \
            -label {Add library  ~/lib/tcl"} \
            -command {insert_library ~/lib/tcl}
    $m add command \
            -label {Add library  ~/lib/tk"} \
            -command {insert_library ~/lib/tk}
    
    $m add separator
    
    $m add command \
            -label {boucle for} \
            -command {electricAlias-wrap for}
    $m add command \
            -label {boucle foreach} \
            -command {electricAlias-wrap foreach}
    $m add command \
            -label {boucle while} \
            -command {electricAlias-wrap while}
                   
    $m add command \
            -label {if} \
            -command {electricAlias-wrap if}
    
    $m add separator
    
    $m add cascade  -label Alias  -menu $m.alias
    menu $m.alias
    foreach alias [electricAlias-softNames] {
        $m.alias add command   \
             -label $alias \
             -command "electricAlias-insert $stead(text) [te:no_interp $alias]"
    }

    $m add cascade  -label Alias2  -menu $m.alias2
    menu $m.alias2
    foreach alias [electricAlias-softNames] {
        # On n'ajoute que les alias commençant par un majuscule (filtrage)
        set tmp [string index $alias 0]
        if {$tmp == [string toupper $tmp]} {
            $m.alias2 add command \
                -label $alias    \
                -command "electricAlias-insert $stead(text) $alias"
        }
    }

}


## stead:modeStart_tcl - lancement du mode tcl
# 
# 
proc stead:modeStart_tcl {} {
    mode_tcl_init
    mode_tcl_defineSabbrev
    mode_tcl_defineMenu_tcl
    mode_tcl_defineMenu_templates
    mode_tcl_defineStyles
}
## stead:modeQuit_gvt - Nettoyage quand on quitte ce mode
# 
proc stead:modeQuit_tcl {} {
    catch {eval [join $::stead(mode,cleanupCmds) ";"]}
}

## Cette procédure est appelé automatiquement (sera refondu)
proc stead:modeCleanup {} {
    stead:modeQuit_tcl
}

# Ceci sera géré automatiquement par stead (via auto_load)
stead:modeStart_tcl

#./
