;;;; edit.stk -- A small editor for STk
;;;;
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 8-Dec-1998 08:47
;;;; Last file update: 3-Sep-1999 19:50 (eg)
(require "font-lock")
(require "butbar")
;;;
;;; Variables which which can be overloaded by the user file ~/.stkvars
;;;
(define-module STk
(define *editor-font* '(Courier -12)))
;;;
;;; The rest of the file is in the Tk module
;;;
(select-module Tk)
;=============================================================================
;
; I/O functions
;
;=============================================================================
(define (new-file txt . file)
(let ((file (if (null? file)
(Tk:get-open-file :title "Open File ...")
(car file))))
(when file
(let ((port (open-file file "r")))
(unless port (error "Cannot open file ~S for reading" file))
(txt 'delete "1.0" "end")
(do ((l (read-line port) (read-line port)))
((eof-object? l))
(txt 'insert "insert" l "" "\n" ""))
(fontify-whole-buffer txt)
;; retain this name as the default save name for this file
(set-widget-property! txt :default-file file)))))
(define (save-file-as txt)
(let* ((default (get-widget-property txt :default-file #f))
(dd (if default (dirname default) (getcwd)))
(df (if default (basename default) ""))
(file (Tk:get-save-file :title "Save File ..."
:initial-file df :initial-dir dd)))
(when file (save-file txt file))))
(define (save-file txt . file)
(let ((file (if (null? file)
(get-widget-property txt :default-file #f)
(car file))))
(if file
(let ((port (open-file file "w")))
(unless port (error "Cannot open file ~S for writing" file))
(display (txt 'get "1.0" "end") port)
(close-port port)
;; retain this name as the default save name for this file
(set-widget-property! txt :default-file file))
;; no file provided and no default value. Do the same thing as a "Save as ..."
(save-file-as txt))))
;=============================================================================
;
; Evaluation functions
;
; Only works if we have a standard console
;
;=============================================================================
(define (fill-standard-input s)
(if (complete-sexpr? s)
(%fill-stdin s)
(begin
(bell)
(error "Selected region is not a complete (or complete set of) sexpr"))))
(define (evaluate-buffer txt)
(unless (catch %fill-stdin)
;; We have a console
(fill-standard-input (txt 'get "1.0" "end"))))
(define (evaluate-region txt)
(unless (catch %fill-stdin)
;; We have a console
(let ((s #f))
(catch (set! s (txt 'get "sel.first" "sel.last")))
(and s (fill-standard-input s)))))
(define (evaluate-previous-sexpr txt)
(catch (let ((prev (find-previous-sexpr txt)))
(and prev (%fill-stdin prev)))))
;=============================================================================
;
; Editor -- menubar
;
;=============================================================================
(define (make-menubar parent txt)
(let* ((f (frame (& parent ".menu") :relief "ridge" :bd 1))
(b (make-bordered-frame f))
(file (menubutton (& b ".file") :text "File"))
(edit (menubutton (& b ".edit") :text "Edit"))
(evil (menubutton (& b ".eval") :text "Evaluate"))
(hlp (menubutton (& b ".help") :text "Help")))
;; File
(let ((m (menu (& file ".m") :tearoff #f)))
(tk-set! file :menu m)
(m 'add 'command :label "Open ..." :command (lambda () (new-file txt)))
(m 'add 'command :label "New Editor" :command make-editor-window)
(m 'add 'separator)
(m 'add 'command :label "Save" :command (lambda () (save-file txt)))
(m 'add 'command :label "Save as ..." :command (lambda () (save-file-as txt)))
(m 'add 'separator)
(m 'add 'command :label "Close" :command (lambda () (destroy parent)))
(m 'add 'command :label "Exit STk" :command (lambda () (exit 0))))
;; Edit
(let ((m (menu (& edit ".m") :tearoff #f)))
(tk-set! edit :menu m)
(m 'add 'command :label "Cut" :accel "Ctrl-X"
:command (lambda () (event 'gen txt "<<Cut>>")))
(m 'add 'command :label "Copy" :accel "Ctrl-C"
:command (lambda () (event 'gen txt "<<Copy>>")))
(m 'add 'command :label "Paste" :accel "Ctrl-V"
:command (lambda () (event 'gen txt "<<Paste>>")))
(m 'add 'command :label "Clear" :accel "Del"
:command (lambda () (event 'gen txt "<<Clear>>"))))
;; Evaluate
(let ((m (menu (& evil ".m") :tearoff #f)))
(tk-set! evil :menu m)
(m 'add 'command :label "Buffer"
:command (lambda () (evaluate-buffer txt)))
(m 'add 'command :label "Selection"
:command (lambda () (evaluate-region txt)))
(m 'add 'command :label "Previous Sexpr" :accel "KP-Enter"
:command (lambda () (evaluate-previous-sexpr txt))))
;; Help
(let ((m (menu (& hlp ".m") :tearoff #f)))
(tk-set! hlp :menu m)
(m 'add 'command :label "STk" :command (lambda () ; Indirect to avoid
(help))) ; autoloads
(m 'add 'command :label "Editor" :command (lambda () (help "ed"))))
(pack file edit evil :side "left")
(pack hlp :side "right")
f))
;=============================================================================
;
; Editor -- button bar
;
;=============================================================================
(define (make-buttonbar parent txt)
(let* ((f (frame (& parent ".butbar") :relief "ridge" :bd 1)))
(make-button-bar f
(list 5
(list "tb_edit.gif"
"New Editor"
make-editor-window)
(list "tb_fileopen.gif"
"Open File"
(lambda () (new-file txt)))
(list "tb_floppy.gif"
"Save File"
(lambda () (save-file txt)))
20
(list "tb_copy.gif"
"Copy"
(lambda () (event 'gen txt "<<Copy>>")))
(list "tb_paste.gif"
"Paste"
(lambda () (event 'gen txt "<<Paste>>")))
(list "tb_cut.gif"
"Cut"
(lambda () (event 'gen txt "<<Cut>>")))
20
(list "tb_evalbuf.gif"
"Eval buffer"
(lambda () (evaluate-buffer txt)))
(list "tb_evalreg.gif"
"Eval region"
(lambda () (evaluate-region txt)))
20
(list "tb_info.gif"
"Help on Editor"
(lambda () (help "ed")))))
f))
;=============================================================================
;
; Editor -- bottom bar
;
;=============================================================================
(define (make-bottombar parent txt)
(let* ((f (frame (& parent ".botbar") :bd 1 :relief "ridge"))
(l1 (label (& f ".l1") :width 10 :font '(Courier -12) :anchor 'w))
(l2 (label (& f ".l2") :width 10 :font '(Courier -12) :anchor 'w))
(updt (lambda ()
(let ((pos (txt 'index "insert")))
(tk-set! l1 :text (format #f " Line: ~A" (car pos)))
(tk-set! l2 :text (format #f " Col: ~A" (cdr pos)))))))
(set-widget-property! txt :idle-hook updt)
(updt) ; to set the first value
(pack l2 l1 :side "right")
f))
;=============================================================================
;
; Editor -- special bindings for Scheme text
;
;=============================================================================
(define (add-scheme-editor-binding txt)
(bind txt "<KP_Enter>" (lambda ()
(evaluate-previous-sexpr txt)
(event 'generate txt "<Return>")))
(bind txt "<Control-Return>" (lambda ()
(evaluate-previous-sexpr txt)))
(bind txt "<Return>" (lambda ()
(after 'idle (lambda () (font-lock-indent txt ""))))))
(define (make-editor-window)
(let* ((top (toplevel (gensym "._ed__") :class "STkEdit"))
(f (frame (& top ".f")))
(txt (text (& f ".txt") :background "ivory2" :font *editor-font*))
(sb (scrollbar (& f ".scroll" :width 10)))
(menubar (make-menubar top txt))
(buttonbar (make-buttonbar top txt))
(botbar (make-bottombar top txt)))
;; Set title and the mode of the text-widget to scheme
(wm 'title top "STk editor")
(make-fontifiable txt)
(add-scheme-editor-binding txt)
;; Associate the scrollbar commands
(tk-set! sb :command (lambda l (apply txt 'yview l)))
(tk-set! txt :yscroll (lambda l (apply sb 'set l)))
;; Pack stuff
(pack txt :expand #t :fill "both" :side "left")
(pack sb :expand #f :fill "y" :side "left")
(pack menubar buttonbar :fill "x")
(pack f :expand #t :fill "both")
(pack botbar :fill "x")
txt))
(define (ed . file)
(let ((txt (make-editor-window)))
(unless (null? file)
(new-file txt (car file))))
(make-undefined))
(provide "edit")