stk/Lib/method-editor.stklos

;;;;
;;;; m e t h o d - e d i t o r . s t k l o s -- Editor for STklos methods and gf
;;;;
;;;; 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: 24-Sep-1998 16:32
;;;; Last file update:  3-Sep-1999 19:53 (eg)

(require "Tk-classes")

;;;
;;; Utilities
;;;

(define (method->list  m)
  (let ((gf (method-generic-function m)))
    (if gf
	(let ((proc (uncode (procedure-body (method-procedure m))))
	      (spec (map* class-name (method-specializers m))))
	  `(define-method ,(generic-function-name gf) ,(map* list (cdadr proc) spec)
	     ,@(cddr proc)))
	;; Method with no associated method
	'())))

;=============================================================================
;
; 			m e t h o d - e d i t o r 
;
;=============================================================================
(define-method  method-editor ((m <method>) parent)
  
  (define (make-buttons parent edit env)
    (let* ((f (make <Frame>  :parent parent :border-width 2 :relief "ridge"))
	   (e (make <Button> :parent f :text "Eval" :border-width 0
		    	     :command (lambda () 
					(eval-string (value edit) env))))
	   (c (make <Button> :parent f :text "Close" :border-width 0
		    	     :command (lambda () (destroy parent)))))
      (pack c e :side 'left)
      f))

  (let* ((class (if (is-a? parent <Multiple-window>) <Inner-Window> <Toplevel>))
	 (top   (make class :title m :parent parent))
	 (body  (pp (method->list m) 75 #f))
	 (env   (procedure-environment (method-procedure m)))
	 (edit  (make <Scheme-Text> :parent top :width 80 :background "white" 
		      		    :value body))
	 (but  (make-buttons top edit env)))
    (pack but  :expand #f :fill "x")
    (pack edit :expand #t :fill "both")
    top))


(define-method method-editor ((m <method>))	; without parent
  (method-editor m *top-root*))

;=============================================================================
;
; 			     g f - e d i t o r 
;
;=============================================================================
(define-method gf-editor ((gf <generic>))

  (define (make-buttons parent)
    (let* ((f (make <Frame> :parent parent :border-width 2 :relief "ridge"))
	   (t (make <Label> :parent f :anchor 'w
		    :text (format #f "Methods of `~S'" (generic-function-name gf))))
	   (e (make <Button> :parent f :text "Close" 
		    	     :command (lambda () (destroy parent)))))
      (pack t :fill 'x :expand #t :side 'left :padx 5)
      (pack e :side 'left)
      f))

  (let* ((top  (make <Toplevel> :title "Generic Function Editor"))
	 (win  (make <Multiple-Window> :parent top :background "wheat3"))
	 (but  (make-buttons top)))
    (pack but  :side "top" :expand #f :fill 'x)
    (pack win  :expand #t :fill "both")
    
    (let loop ((x 20) (y 20) (l (generic-function-methods gf)))
      (when (pair? l)
	(let ((ed (method-editor (car l) win)))
	  (place ed :x x :y y)
	  (loop (+ x 20) (+ y 20) (cdr l)))))))

(provide "method-editor")