;;;;
;;;; console.stk -- A simple console written in 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: 29-Oct-1998 18:51
;;;; Last file update: 3-Sep-1999 19:50 (eg)
(require "font-lock")
(require "butbar")
(require "edit")
;;;
;;; Variables which which can be overloaded by the user file ~/.stkvars
;;;
(define-module STk
(define *show-splash-screen* #t)
(define *console-font* '(courier)))
;;;
;;; The rest of the file is in the Tk module
;;;
(select-module Tk)
(export make-console)
(autoload "console-customize" console-customize console-customize-save)
;=============================================================================
;
; Globals
;
;=============================================================================
(define *console-version-message*
(string-append "STk version" (version)
"\n(Tk version is " *tk-patch-level* ")\n\n"
"Copyright © 1993-1999\nErick Gallesio - I3S-CNRS/ESSI\n"
"<eg@unice.fr>"))
;=============================================================================
;
; Utilities
;
;=============================================================================
(define (bad-port . _)
(error "console is not tied to a standard input port"))
(define (set-cursor console pos)
(let ((pos (if (console 'compare pos "==" "end") "end - 1 chars" pos)))
(console 'mark 'set 'insert pos)
(console 'tag 'remove 'sel "1.0" "end")
(console 'see "insert")))
;;
;; console-insert --
;; Insert a string into a text at the point of the insertion cursor. If
;; there is a selection in the text, and it covers the point of the
;; insertion cursor, then delete the selection before inserting.
;; Insertion is restricted to the prompt area.
;;
(define (console-insert console s)
(unless (zero? (string-length s))
; 1. Raise window
(raise (winfo 'top console))
; 2. Do text insertion
(catch
(when (and (console 'compare "sel.first" "<=" "insert")
(console 'compare "sel.last" ">=" "insert"))
(console 'tag 'remove 'sel "sel.first" "prompt-end")
(console 'delete "sel.first" "sel.last")))
(if (console 'compare "insert" "<" "prompt-end")
(console 'mark 'set "insert" "end"))
(console 'insert "insert" s "input stdin")
(console 'see "insert")
; 3. Fontify
(idle-fontify console)))
;;
;; console-output --
;; This routine is called directly by the interpreter to cause a string
;; to be displayed in the console.
;;
(define (console-output console string file-type)
(console 'insert "output" string file-type)
(console 'see "insert"))
;;
;; console-load
;;
(define (console-load)
(let ((file (Tk:get-open-file :title "Load File")))
(and file (load file))))
;;
;; console-about
;;
(define (console-about)
(let* ((top (toplevel '.__cons_about__))
(m (label (& top ".m") :justify "center" :foreground "IndianRed4"
:text *console-version-message*))
(img (make-image "STk-big-logo.gif"))
(lab (label (& top ".l") :image img :relief "groove" :bd 5))
(q (button (& top ".b") :text "Close"
:command (lambda ()
(delete-image "STk-big-logo.gif")
(destroy top)))))
(wm 'title top "About STk ...")
(grab top)
(raise top)
(pack lab :padx 20 :pady 20)
(pack m :fill "both" :expand #t)
(pack q :ipadx 10 :pady 10)))
;;
;; console-splash-screen
;;
(define (console-splash-screen)
(let* ((width 400)
(height 300)
(top (toplevel '.__cons_splash__ :bg "white" :relief "solid" :bd 3
:width width :height height))
(m (label (& top ".m") :justify "center" :fg "IndianRed4"
:bg "white" :text *console-version-message*))
(img (make-image "STk-big-logo.gif"))
(lab (label (& top ".l") :image img :bd 0))
(w (winfo 'screenwidth top))
(h (winfo 'screenheight top))
(kill (lambda ()
(catch (delete-image "STk-big-logo.gif"))
(destroy top))))
(wm 'over top #t)
(wm 'geometry top (format #f "+~A+~A" (quotient (- w 400) 2)
(quotient (- h 300) 2)))
(pack 'propagate top #f)
(pack lab m)
(bind top "<1>" kill) ;; for the impatients
(raise top)
(after 2000 kill)))
;;
;; console-logo
;;
(define (console-logo console)
(let ((l0 (label (& console ".l0") :image (make-image "LineLeft.gif") :bd 0))
(l1 (label (& console ".l1") :image (make-image "STk-tiny-logo.gif"):bd 0))
(l2 (label (& console ".l2") :image (make-image "LineRight.gif") :bd 0)))
(console 'insert 'insert "\n")
(console 'window 'create "insert" :window l0 :align "baseline")
(console 'insert 'insert " ")
(console 'window 'create "insert" :window l1 :align "baseline")
(console 'insert 'insert " ")
(console 'window 'create "insert" :window l2 :align "baseline")
(console 'tag 'add "center" "1.0" "insert")
(console 'tag 'configure "center" :justify "center")
(console 'insert "insert" "\n\n")))
;;
;; console-invoke --
;;
;; Processes the command line input. If the command is complete it
;; is evaluated.
;;
(define (console-invoke console module stdin stdout stderr)
(let* ((cmd "")
(mod (or module (%get-selected-module)))
(env (module-environment mod))
(stdcons? (eq? stdin (current-input-port))))
;; Set cmd to be the concatenation of all ranges of text with tag "input"
(let ((hd (console 'tag 'ranges "input")))
(while (not (null? hd))
(set! cmd (string-append cmd (console 'get (car hd) (cadr hd))))
(set! hd (cddr hd))))
(if (complete-sexpr? cmd)
(begin
;; We have a complete set of expression to evaluate
(console 'mark 'set "output" "end")
(console 'tag "delete" "input")
(with-input-from-string cmd
(lambda ()
(do ((sexpr (read) (read)))
((eof-object? sexpr))
(add-history! console (substring cmd 0 (- (string-length cmd) 1)))
(if stdcons?
;; We are on the main console. Directly fill the std buffer
(%fill-stdin cmd)
;; Not the standard console. Use redirection
(dynamic-wind
(lambda () #f)
(lambda ()
(with-input-from-port stdin
(lambda ()
(with-output-to-port stdout
(lambda ()
(with-error-to-port stderr
(lambda ()
(let ((E (eval sexpr env)))
(repl-display-result E)))))))))
(lambda ()
(console-prompt console module stdout stderr)
(console 'yview :pickplace "insert"))))))))
;; Not a complete sexpr. Indent text
(font-lock-indent console "input"))))
;=============================================================================
;
; console-prompt
;
;=============================================================================
(define (console-prompt console module stdout stderr)
(let ((temp (console 'index "end -1 char"))
(mod (or module (%get-selected-module))))
(with-output-to-port stdout
(lambda()
(with-error-to-port stderr
(lambda ()
(repl-display-prompt mod)))))
(console 'mark 'set "output" temp)
(set-cursor console "end")
(console 'mark 'set "prompt-end" "insert") ; FIXME: obligé de mettre
(console 'mark 'gravity "prompt-end" 'left) ; la gravité?
(console 'mark 'set "start_fontify" "insert")
(console 'mark 'gravity "start_fontify" 'left)))
(define console-display-prompt #f)
(define (make-console-display-prompt console stdout stderr)
(set! console-display-prompt
(lambda (module)
(console-prompt console module stdout stderr))))
;=============================================================================
;
; History management
;
;=============================================================================
(define (update-history! console h index)
(set-widget-data! console (list :hist h :index index)))
(define (get-history console)
(let ((data (get-widget-data console)))
(if data
; we have already an history for this console
(values (get-keyword :hist data) (get-keyword :index data))
; make an empty history for this console
(values '() 0))))
(define (add-history! console line)
(call-with-values (lambda () (get-history console))
(lambda (h idx) (update-history! console (cons line h) 0))))
(define(follow-history console oper)
(call-with-values
(lambda () (get-history console))
(lambda (h idx)
(if (null? h)
""
(let ((r (list-ref h idx)))
(update-history! console h (modulo (oper idx 1) (length h)))
r)))))
(define (previous-history console)
(follow-history console +))
(define (next-history console)
(follow-history console -))
;=============================================================================
;
; Init-console-bindings
;
; This is quite unreadable, but who cares?
;
;=============================================================================
(define (init-console-bindings console module stdin stdout stderr)
;; Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
;; Otherwise, if a widget binding for one of these is defined, the
;; <KeyPress> class binding will also fire and insert the character,
;; which is wrong. Ditto for <Escape>.
(bind console "<Alt-KeyPress>" "")
(bind console "<Meta-KeyPress>" "")
(bind console "<Control-KeyPress>" "")
(bind console "<Escape>" "")
(bind console "<KP_Enter>" "")
;; Inserting characters
(bind console "<Tab>" (lambda ()
(console-insert console "\t")
(focus console)
'break))
(bind console "<Return>" (lambda ()
(console 'mark 'set 'insert "end - 1c")
(console-insert console "\n")
(console-invoke console module stdin stdout stderr)
'break))
(bind console "<KeyPress>" (lambda (|A|)
(console-insert console |A|)
'break))
;; Deleting characters
(let ((del (lambda (comparison)
(idle-fontify console)
(if (null? (console 'tag 'nextrange 'sel "1.0" 'end))
(if (console 'compare "insert" comparison "prompt-end") 'break)
(console 'tag 'remove 'sel "sel.first" "prompt-end")))))
(bind console "<Delete>" (lambda () (del "<")))
(bind console "<Control-d>" (lambda () (del "<")))
(bind console "<BackSpace>" (lambda () (del "<=")))
(bind console "<Control-k>" (lambda ()
(idle-fontify console)
(if (console 'compare "insert" "<" "prompt-end")
(console 'mark 'set "insert" "prompt-end"))))
(bind console "<Meta-d>" (lambda ()
(idle-fontify console)
(if (console 'compare "insert" "<" "prompt-end")
'break)))
(bind console "<Meta-BackSpace>"
(lambda ()
(idle-fontify console)
(if (console 'compare "insert" "<=" "prompt-end") 'break))))
;; Moving around
(let ((start (lambda ()
(idle-fontify console)
(let ((pos (if (console 'comp "insert linestart" ">" "prompt-end")
"insert linestart"
"prompt-end")))
(set-cursor console pos)
'break)))
(end (lambda ()
(idle-fontify console)
(set-cursor console "insert lineend")
'break))
(forw (lambda ()
(if (console 'compare "insert" ">=" "prompt-end")
(set-cursor console "insert+1c"))
'break))
(back (lambda ()
(if (console 'compare "insert" ">=" "prompt-end")
(set-cursor console "insert-1c"))
'break))
(nop (lambda () #f)))
(bind console "<Control-a>" start)
(bind console "<Home>" start)
(bind console "<Control-e>" end)
(bind console "<End>" end)
(bind console "<Control-f>" forw)
(bind console "<Right>" forw)
(bind console "<Control-b>" back)
(bind console "<Left>" back)
(bind console "<Control-Left>" nop)
(bind console "<Control-Right>" nop))
;; History
(let ((prev (lambda ()
(when (console 'compare "insert linestart" "<" "prompt-end")
(console 'delete "prompt-end" "end")
(console-insert console (previous-history console))
'break)))
(next (lambda ()
(when (console 'compare "insert linestart" "<" "prompt-end")
(console 'delete "prompt-end" "end")
(console-insert console (next-history console))
'break))))
(bind console "<Control-p>" prev)
(bind console "<Up>" prev)
(bind console "<Control-n>" next)
(bind console "<Down>" next))
(bind console "<<PasteSelection>>" (lambda ()
(catch
(console-insert console
(selection 'get :displayof console)))
(fontify-buffer console "prompt-end")
'break))
(bind console "<<Cut>>" (lambda ()
(catch
(let ((buffer (console 'get "sel.first" "sel.last")))
(clipboard 'clear :displayof console)
(clipboard 'append :displayof console buffer)
(console 'delete "sel.first" "sel.last")))
'break))
(bind console "<<Copy>>" (lambda ()
(catch
(let ((buffer (console 'get "sel.first" "sel.last")))
(clipboard 'clear :displayof console)
(clipboard 'append :displayof console buffer)))
'break))
(bind console "<<Paste>>" (lambda ()
(catch
(let ((clip (selection 'get
:displayof console
:selection "CLIPBOARD")))
(console-insert console clip)
(fontify-buffer console "prompt-end")))
'break))
(bind console "<Control-c>" (lambda ()
(bell)
(send-signal |SIGINT|)))
;; Use fontification for the console (but call it by hand because the console
;; completely manage text insertion)
(make-fontifiable console)
(bindtags console (remove "ScmTxt" (bindtags console)))
)
;=============================================================================
;
; init-console
;
;=============================================================================
(define (init-console module std-console?)
(let* ((top (toplevel (gensym "._cons_") :class "STk"))
(console (text (& top ".txt") :background "white" :setgrid #t
:font *console-font*))
(sb (scrollbar (& top ".sb") :width 10))
(mb (console-make-menubar top console))
(bb (console-make-buttonbar top console))
(stdin (if std-console?
(current-input-port)
(open-input-virtual bad-port bad-port bad-port bad-port)))
(stdout (open-output-virtual
(lambda (c p) (console-output console (string c) "stdout"))
(lambda (s p) (console-output console s "stdout")(update 'idle))
#f
#f))
(stderr (open-output-virtual
(lambda (c p) (console-output console (string c) "stderr"))
(lambda (s p) (console-output console s "stderr")(update 'idle))
#f
#f)))
;; Associate the scrollbar commands
(tk-set! sb :command (lambda l (apply console 'yview l)))
(tk-set! console :yscroll (lambda l (apply sb 'set l)))
;; Pack stuff
(pack bb :fill "x")
(pack console :expand #t :fill "both" :side "left")
(pack sb :expand #f :fill "y" :side "left")
(wm 'title top (if module
(format #f "Console (~A)" (module-name module))
"STk console"))
(if std-console?
(let ((exit (lambda () (exit 0))))
(wm 'protocol top "WM_DELETE_WINDOW" exit)
(bind console "<Destroy>" exit)))
(console 'tag 'configure "stdin" :foreground "black")
(console 'tag 'configure "stdout" :foreground "midnightblue")
(console 'tag 'configure "stderr" :foreground "#ff2e2f") ;; i.e. "DarkRed"
(console 'mark 'set "output" (console 'index "end - 1 char"))
(set-cursor console "end")
(console 'mark 'set "prompt-end" "insert")
(console 'mark 'gravity "prompt-end" "left")
(init-console-bindings console module stdin stdout stderr)
(if std-console?
(begin
(if *show-splash-screen* (console-splash-screen))
(if *print-banner* (console-logo console))
(%change-standard-ports stdin stdout stderr)
(make-console-display-prompt console stdout stderr))
(console-prompt console module stdout stderr))
(focus console)
console))
(define (console-make-buttonbar parent txt)
(let* ((f (frame (& parent ".butbar") :relief "ridge" :bd 1)))
(make-button-bar f
(list 5
(list "tb_console.gif"
"Open New Console"
make-console)
(list "tb_edit.gif"
"Open New Editor"
ed)
(list "tb_customize.gif"
"Customize Environment"
(lambda () (console-customize))) ; delayed to avoid autoload
(list "tb_fileopen.gif"
"Load File"
console-load)
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_info.gif"
"Help on Console"
(lambda () (help "make-console")))))
f))
(define (make-console-in)
(define name ".__cons_module_chooser")
(define (create)
(catch
(make-console :module (string->symbol (selection 'get)))
(after 'idle (lambda () (destroy name)))))
;;;;
;;;; make-console-in starts here
;;;;
(destroy name)
(let* ((all (sort (map module-name (all-modules))
(lambda (x y)
(string<? (symbol->string x) (symbol->string y)))))
(top (toplevel name))
(lab (label (& top ".lab") :text "Choose a module for new console"))
(f0 (frame (& top ".f0")))
(lb (listbox (& f0 ".lb") :bg "white" :fg "RoyalBlue" :width 50))
(sb (scrollbar (& f0 ".sb") :width 10))
(f1 (frame (& top ".f1") :relief "ridge" :bd 2))
(doit (button (& f1 ".doit") :text "Create console" :command create))
(quit (button (& f1 ".quit") :text "Cancel"
:command (lambda () (destroy top)))))
(wm 'title top "Choose module")
;; Fill in the listbox
(apply lb 'insert 0 all)
;; Pack everybody
(pack lab :expand #f :pady 10 :padx 20 :anchor 'w)
(pack lb :fill 'both :side 'left :expand #t)
(pack sb :fill 'y :side 'right)
(pack f0 :padx 20 :pady 10 :expand #t :fill 'both)
(pack doit quit :side 'left :padx 3 :pady 3)
(pack f1 :expand #f :fill 'x)
;; Add command to connect the scrollbar
(tk-set! lb :yscrollcom (lambda l (apply sb 'set l)))
(tk-set! sb :command (lambda l (apply lb 'yview l)))
;; Add binding such as double click on the list create a console
(bind lb "<Double-ButtonRelease-1>" create)))
(define (console-make-menubar top console)
(let* ((f (frame (& top ".f") :relief "ridge" :bd 1))
(b (make-bordered-frame f))
(file (menubutton (& b ".file") :text "File"))
(edit (menubutton (& b ".edit") :text "Edit"))
(conf (menubutton (& b ".conf") :text "Customize"))
(hlp (menubutton (& b ".help") :text "Help")))
;; File Menu
(let ((m (menu (& file ".m") :tearoff #f)))
(m 'add 'command :label "Load ..." :command console-load)
(m 'add 'separator)
(m 'add 'command :label "New Console" :command make-console)
(m 'add 'command :label "New Console in ..." :command make-console-in)
(m 'add 'separator)
(m 'add 'command :label "Hide Console" :command (lambda () (wm 'iconify top)))
(m 'add 'command :label "Close Console" :command (lambda () (destroy top)))
(m 'add 'command :label "Exit STk" :command (lambda () (exit 0)))
(tk-set! file :menu m)
(pack file :side "left"))
;; Edit Menu
(let ((m (menu (& edit ".m") :tearoff #f)))
(m 'add 'command :label "Cut" :accel "Ctrl-X"
:command (lambda () (event 'gen console "<<Cut>>")))
(m 'add 'command :label "Copy"
:command (lambda () (event 'gen console "<<Copy>>")))
(m 'add 'command :label "Paste" :accel "Ctrl-V"
:command (lambda () (event 'gen console "<<Paste>>")))
(m 'add 'command :label "Clear" :accel "Del"
:command (lambda () (event 'gen console "<<Clear>>")))
(m 'add 'separator)
(m 'add 'command :label "Flush Console"
:command (lambda () (console 'delete "1.0" "end")))
(tk-set! edit :menu m)
(pack edit :side "left"))
(let ((m (menu (& conf ".m") :tearoff #f)))
(m 'add 'command :label "Customize"
:command (lambda () (console-customize)))
(m 'add 'command :label "Save Configuration"
:command (lambda () (console-customize-save)))
(tk-set! conf :menu m)
(pack conf :side "left"))
;; Help Menu
(let ((m (menu (& hlp ".m") :tearoff #f)))
(m 'add 'command :label "STk" :command (lambda () ; Indirect to avoid
(help))) ; autoloads
(m 'add 'command :label "Console" :command (lambda ()
(help "make-console")))
(m 'add 'separator)
(m 'add 'command :label "About" :command console-about)
(tk-set! hlp :menu m)
(pack hlp :side "right"))
(pack f :fill "x" :side "top")))
;=============================================================================
;
; make-console
;
;=============================================================================
(define (make-console . args)
(let ((module (get-keyword :module args #f)))
(when module
(if (symbol? module) (set! module (find-module module)))
(if (not (module? module))
(error "make-console: bad module ~S" module)))
(init-console module #f)))
(define (%make-standard-console)
;; Don't use try-load because ~ can yiel an error on Windows if HOME is
;; unset (and console is unproperly initialized in this case).
(catch (load "~/.stkvars"))
(init-console #f #t))
(provide "console")