stk/Lib/console.stk

;;;;
;;;; console.stk 			-- A simple console written in STk
;;;;
;;;; Copyright <20> 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 <20> 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<69> de mettre 
    (console 'mark 'gravity "prompt-end" 'left)		; la gravit<69>?
    (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")