stk/Lib/method-editor.stklos

97 lines
3.4 KiB
Plaintext
Raw Normal View History

1998-09-30 07:11:02 -04:00
;;;;
;;;; m e t h o d - e d i t o r . s t k l o s -- Editor for STklos methods and gf
;;;;
1999-09-05 07:16:41 -04:00
;;;; Copyright <20> 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1998-09-30 07:11:02 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; 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.
1998-09-30 07:11:02 -04:00
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 24-Sep-1998 16:32
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:53 (eg)
1998-09-30 07:11:02 -04:00
(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")