;;;; 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")