stk/Lib/console-customize.stk

;;;; console-customize.stk 		--  console customization stuff
;;;;
;;;; 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: 19-Dec-1998 16:39
;;;; Last file update:  3-Sep-1999 19:49 (eg)


(require "console")
(require "edit")   			; for *editor-font*
(require "font-chooser")

(select-module Tk)

(define make-font-chooser (with-module STklos+Tk make-font-chooser)) ; kludge


(define (make-console-color-button parent name var env)
  (let* ((col (eval var env))
	 (f   (frame (& parent (gensym ".f"))))
	 (n   (label (& f ".n") :text name :justify 'right :width 12 :anchor 'e))
	 (v   (entry (& f ".v") :bg "white"  :width 30 :fg col))
	 (c   (button (& f ".c")  :image (make-image "colors.gif")
		      :command (lambda () 
				 (let ((c (Tk:choose-color 
					   :initial-color col
					   :title (string-append  name " Color"))))
				   (when c 
				     (v 'delete 0 'end)
				     (v 'insert 0 c)
				     (event 'gen v "<<Choose-Color>>")))))))
    (pack n v c :side 'left :padx 2)
    ;; Fill the entry with the name of the current color
    (v 'insert 0 col)
    (bind c "<Return>" (lambda () (event 'generate v "<<Choose-Color>>")))
    (bind v "<<Choose-Color>>" (lambda ()
				 (let ((value (v 'get)))
				   (catch 
				    (tk-set! v :fg value)
				    (eval `(set! ,var ,value) env)))))
    f))

(define (make-console-font-button parent name var env)
  (let* ((font (eval var env))
	 (f    (frame (& parent (gensym ".f"))))
	 (n    (label (& f ".n")  :text name :justify 'right :width 12 :anchor 'e))
	 (v    (entry (& f ".v")  :bg "white"  :width 30))
	 (new  (lambda ()
		 (let ((f (make-font-chooser font)))
		   (when f
		     (v 'delete 0 'end)
		     (v 'insert 0 f)
		     (eval `(set! ,var ',f) env)))))
	 (c    (button (& f ".c") :image (make-image "font.gif") :command new)))
    (pack n v c :side 'left :padx 2)
    (bind v "<Return>" (lambda () (eval `(set! ,var ',(v 'get)) env)))
    ;; Fill the entry with the name of the current color
    (v 'insert 0 font)
    f))


(define (console-save-n-apply file)
  ;; Write variables in the given file
  (with-output-to-file file
    (lambda ()
      (format #t "; This file isautomatically generated\n; ****DO NOT EDIT ***\n")
      (format #t "(select-module STk)\n")
      (format #t "(set! *show-splash-screen*    ~A)\n" *show-splash-screen*)
      (format #t "(set! *print-banner*          ~A)\n" *print-banner*)
      (format #t "(set! *load-verbose*          ~A)\n" *load-verbose*)
      (format #t "(set! *fontify-keyword-color* ~S)\n" *fontify-keyword-color*)
      (format #t "(set! *fontify-class-color*   ~S)\n" *fontify-class-color*)
      (format #t "(set! *fontify-syntax-color*  ~S)\n" *fontify-syntax-color*)
      (format #t "(set! *fontify-comment-color* ~S)\n" *fontify-comment-color*)
      (format #t "(set! *fontify-string-color*  ~S)\n" *fontify-string-color*)
      (format #t "(set! *console-font*          '~S)\n" *console-font*)
      ;; Use a define for *editor-font* since the editor is possibly not loaded
      (format #t "(define *editor-font*         '~S)\n" *editor-font*))))

;=============================================================================
;
;  console-customize-save
;
;=============================================================================
(define (console-customize-save)
  (console-save-n-apply (expand-file-name "~/.stkvars")))
			       

;=============================================================================
;
; console-customize 
;
;=============================================================================
(define (console-customize)
  (destroy ".__cons_customize")
  (let* ((top   (toplevel ".__cons_customize"))
	 (env   (global-environment))
	 (f1    (frame (& top ".f1") :bd 3 :relief "groove" :bg "white"))
	 (f2    (frame (& top ".f2") :bd 3 :relief "groove"))
	 (f3    (frame (& top ".f3") :bd 3 :relief "groove"))
	 (lab   (label (& f1 ".lab")
		       :text (string-append 
			      "This is the customization window for STk.\n\n"
			      "Change the following values to customize\n"
			      "the behavior of consoles and editors.")
		       :bg "white" 
		       :justify 'left))
	 (logo   (label (& f1 ".lab2") :bd 0 :relief "flat"
			:image (make-image "STk-logo.gif")))
	 (clab   (label (& f2 ".clab") :text "General Options"
			:fg "IndianRed3"))
	 (splash (checkbutton (& f2 ".splash") :text "Display the splash screen"
			      :env env :variable '*show-splash-screen* :anchor 'w))
	 (cprwt  (checkbutton (& f2 ".cprwt") 
			      :text "Display the STk version when starting"
			      :env env :variable '*print-banner* :anchor 'w))
	 (verb   (checkbutton (& f2 ".verb")
			      :text "Load verbose"
			      :env env :variable '*load-verbose* :anchor 'w))
	 (hlab   (label (& f2 ".hlab") :text "Syntax Hilighting"
			:fg "IndianRed3"))
	 (flab   (label (& f2 ".flab") :text "Fonts" :fg "IndianRed3")))
	 
    ;; Change window title
    (wm 'title top "STk Customization Window")

    ;; *** The upper frame ***
    (pack logo lab :side 'left :fill 'x :pady '3m :padx '3m)
    (pack f1 :side 'top :fill 'x :padx 5 :pady 5)
    ;; *** The lower-frame ***
    ;   G e n e r a l   O p t i o n s
    (pack clab :side 'top :fill 'x)
    (pack splash cprwt verb :side 'top :fill 'x  :padx '3m)

    ;  S y n t a x   h i g h l i g h t i n g
    (pack hlab :side 'top :fill 'x)
    (pack (make-console-color-button f2 "Comments" '*fontify-comment-color* env)
	  (make-console-color-button f2 "Keywords" '*fontify-keyword-color* env)
	  (make-console-color-button f2 "Classes"  '*fontify-class-color*   env)
	  (make-console-color-button f2 "Strings"  '*fontify-string-color*  env)
	  (make-console-color-button f2 "Syntax"   '*fontify-syntax-color*  env)
	  :side 'top :fill 'x :padx '3m)
    
    ; F o n t s
    (pack flab :side 'top :fill 'x)
    (pack (make-console-font-button f2 "Console" '*console-font* env)
	  (make-console-font-button f2 "Editor"  '*editor-font*  env)
	  :side 'top :fill 'x :padx '3m)

    
    (pack f2 :side 'top :fill 'x :padx 5 :pady 5)
    
    ;; *** The buttons ***
    (let ((b1 (button (& f3 ".save") :text "Save" :bd 2 
		      :command console-customize-save))
	  (b2 (button (& f3 ".exit") :text "Cancel" :bd 2
		      :command (lambda () (destroy top)))))
      (pack b1 b2 :side 'left :padx 3 :pady 3 :fill 'y)
      (pack f3 :fill 'x :side 'bottom))))


(provide "console-customize")