643 lines
26 KiB
Scheme
643 lines
26 KiB
Scheme
(module view mzscheme
|
|
|
|
(require "assoc-list.scm"
|
|
"aux-class.scm"
|
|
"data-defs.scm"
|
|
"class.scm"
|
|
"union.ss"
|
|
mred
|
|
mzlib/class
|
|
mzlib/etc
|
|
mzlib/list
|
|
srfi/13/string
|
|
mzlib/contract)
|
|
|
|
(provide/contract
|
|
[get-class-info (opt->* () [Language] [boolean? (union false/c (list/c Class boolean? boolean?))])]
|
|
[get-union-info (opt->* () [Language] [boolean? (union false/c (list/c Union boolean? boolean?))])])
|
|
|
|
(define CLASS-WIZARD "The Class Wizard")
|
|
(define UNION-WIZARD "The Union Wizard")
|
|
(define VARIANT-WIZD "The Variant Wizard")
|
|
(define VARIANT "Variant")
|
|
(define INSERT-CLASS "Insert Class")
|
|
(define INSERT-UNION "Insert Union")
|
|
(define INSERT-VARNT "Insert Variant")
|
|
(define ADD-FIELD "Add Field")
|
|
(define ADD-VARIANT "Add Variant")
|
|
(define ADD-INTERF "Add Interface Method")
|
|
(define ADD-TOSTRING "add toString()")
|
|
(define ADD-TEMPLATE "add method template")
|
|
(define ADD-DIAGRAM "add class diagram")
|
|
(define PURPOSE-CLASS "// purpose of class: ")
|
|
(define PURPOSE-UNION "// purpose of union: ")
|
|
(define CLASS "class")
|
|
(define SUPER "super")
|
|
(define IMPLEMENTS "implements")
|
|
(define EXTENDS "extends")
|
|
(define CHECK-NAME-F "check name of ~a")
|
|
(define CHECK-TYPE-F "check type for ~a")
|
|
(define CHECK-FIELD-NAME-F "check field name for ~a")
|
|
(define TYPE "type")
|
|
(define NAME "name")
|
|
(define ABORT "Cancel")
|
|
(define ERROR "Error")
|
|
(define DELETE "Delete")
|
|
(define EDIT "Edit")
|
|
|
|
#|
|
|
present a dialog to create a single class;
|
|
if programmer aborts, return #f
|
|
otherwise, produce a class and two booleans, requesting toString and draft
|
|
templates, respectively
|
|
|#
|
|
|
|
(define (get-class-info . opt)
|
|
(define ci (new class-info% (title CLASS-WIZARD)
|
|
(switches? (and (pair? opt) (not (eq? (car opt) BEGINNER))))
|
|
(insert-str INSERT-CLASS) (add-str ADD-FIELD)))
|
|
(send ci call))
|
|
|
|
(define (get-union-info . opt)
|
|
(define ui (new union-info% (title UNION-WIZARD)
|
|
(switches? (and (pair? opt) (not (eq? (car opt) BEGINNER))))
|
|
(insert-str INSERT-UNION) (add-str ADD-VARIANT)))
|
|
(send ui call))
|
|
|
|
#|
|
|
*---------------------*
|
|
| dialog% |
|
|
*---------------------*
|
|
|
|
|
|
|
|
/ \
|
|
*---------------------*
|
|
| class-union-wizard% |
|
|
*---------------------*
|
|
| tostring? |
|
|
| template? |
|
|
| error-message |
|
|
| call |
|
|
| A: produce |
|
|
| A: make-class-cb |
|
|
*---------------------*
|
|
|
|
|
|
|
|
/ \
|
|
--------------------------------------------
|
|
| |
|
|
*---------------------* *---------------------*
|
|
| class-info% | | union-info% |
|
|
*---------------------* *---------------------*
|
|
| |--+ | vart-panel |--+
|
|
*---------------------* *---------------------* |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
*---------------------* *---------------------* |
|
|
| vertical-panel% | | horizontal-panel% | |
|
|
*---------------------* *---------------------* |
|
|
| | |
|
|
| | |
|
|
/ \ / \ |
|
|
*---------------------* *---------------------*
|
|
| field-panel% | | variant-panel% |
|
|
*---------------------* *---------------------*
|
|
| add | | add |
|
|
| add-on-return | | produce |
|
|
| produce | *---------------------*
|
|
*---------------------* | acquired: |
|
|
| acquired: | | get-type |
|
|
| window (?) | | error-message |
|
|
| error-message | *---------------------*
|
|
*---------------------*
|
|
|
|
|#
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; Set up the frame, including the info-panel where subclasses can
|
|
;; request specific information. The frame includes buttons for aborting
|
|
;; the edit process, for packaging up the information in the edit, and for
|
|
;; adding some component (field, variant)
|
|
|
|
;; String String String -> ClassUnionWizard
|
|
(define class-union-wizard%
|
|
(class dialog% (init-field title insert-str add-str (switches? #t) (no-diagram #f))
|
|
(super-new (label title) (width 500) (height 400))
|
|
|
|
(define p (new vertical-pane% (parent this)))
|
|
|
|
;; switches for toString methods and template in comments
|
|
(define switch-pane (add-horizontal-panel p))
|
|
(define-values (string #;template diagram)
|
|
(cond
|
|
[switches?
|
|
(values (make-checkbox switch-pane ADD-TOSTRING)
|
|
#;
|
|
(let ([c (make-checkbox switch-pane ADD-TEMPLATE)])
|
|
(send c set-value #t)
|
|
c)
|
|
(make-checkbox switch-pane ADD-DIAGRAM))]
|
|
[no-diagram (values #f #;#f #f)]
|
|
[else (values #f #;#f (make-checkbox switch-pane ADD-DIAGRAM))]))
|
|
(define (get-switch x)
|
|
(cond
|
|
[(eq? x diagram) (and (not no-diagram) (send x get-value))]
|
|
[switches? (send x get-value)]
|
|
[else #f]))
|
|
(define/public (tostring?) (get-switch string))
|
|
(define/public (template?) #;(get-switch template) #f)
|
|
(define/public (diagram?) (get-switch diagram))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; info panel
|
|
(field (info-pane (new vertical-panel% (parent p) (style '(border)))))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; error handling
|
|
|
|
;; String -> false
|
|
(define/public (error-message ctl m)
|
|
(when (ctl . is-a? . text-field%)
|
|
(send ctl focus)
|
|
(let ([e (send ctl get-editor)])
|
|
(send e set-position 0 (send e last-position))))
|
|
(message-box ERROR
|
|
m
|
|
(send ctl get-top-level-window)
|
|
'(ok stop))
|
|
(raise an-error))
|
|
|
|
;; TextField (union false String) -> java-id?
|
|
(define/public (produce-name-from-text name msg)
|
|
(let ([x (string-trim-both (send name get-value))])
|
|
(cond
|
|
[(not msg) x]
|
|
[(java-id? x) x]
|
|
[else (error-message name (format CHECK-NAME-F msg))])))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; Buttons
|
|
|
|
(define button-panel
|
|
(new horizontal-panel% (parent p) (stretchable-height #f) (alignment '(right center))))
|
|
|
|
(define abort? #t) ;; assume bad things happen
|
|
(define (quit x e) (send this show #f))
|
|
(add-button button-panel ABORT quit)
|
|
|
|
(define/abstract make-class-cb)
|
|
(new button% (label insert-str) (parent button-panel)
|
|
(style '(border))
|
|
(callback
|
|
(lambda (x e)
|
|
(when (make-class-cb x e)
|
|
(set! abort? #f)))))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; call in
|
|
(define/public (call)
|
|
(send this show #t)
|
|
(values (diagram?) (if abort? #f (produce))))
|
|
|
|
(define/abstract produce)))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; String String String [String] [String] -> ClassUnionWizard
|
|
;; get information about a class (fields, purpose statement, ...)
|
|
(define class-info%
|
|
(class class-union-wizard%
|
|
(init-field (a-super null) (a-v-class null))
|
|
(super-new)
|
|
(inherit-field info-pane)
|
|
(inherit tostring? template? diagram? error-message produce-name-from-text)
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; filling the info-pane
|
|
|
|
;; Information about the class in general:
|
|
(define purpose
|
|
;; it is not the kind of textbox that make-text-field creates
|
|
(new text-field% (parent info-pane) (label PURPOSE-CLASS) (callback void)))
|
|
|
|
(define class-pane (add-horizontal-panel info-pane))
|
|
; (define class-privacy (make-modifier-menu class-pane))
|
|
(define class-name (make-text-field class-pane CLASS))
|
|
(define (super-cb x e) (send field-panel add-on-return x e))
|
|
(define super-name (make-text-field class-pane IMPLEMENTS super-cb))
|
|
|
|
;; Information about the class's fields:
|
|
(define field-pane (new vertical-panel% (parent info-pane) (style '(border))))
|
|
(define field++ (add-button field-pane ADD-FIELD (lambda (x y) (send field-panel add))))
|
|
(define field-panel
|
|
(new field-panel%
|
|
(parent field-pane) (window this)
|
|
(error-message (lambda (ctl x) (error-message ctl x)))))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; creating the class from the specification
|
|
|
|
;; -> (union false (list Class boolean? boolean?))
|
|
(define/override (produce)
|
|
(with-handlers ([an-error? (lambda _ #f)])
|
|
(list (list (produce-name-from-text class-name CLASS)
|
|
(produce-name-from-text
|
|
super-name (if (null? a-super) #f SUPER))
|
|
(send field-panel produce)
|
|
(send purpose get-value))
|
|
(tostring?)
|
|
(template?))))
|
|
|
|
;; if the class specification is proper, hide dialog
|
|
(define/override (make-class-cb x e)
|
|
(and (produce) (send this show #f)))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; setting it all up
|
|
|
|
;; String -> Void
|
|
;; set up the super class, uneditable
|
|
(define (setup-super a-super)
|
|
(send super-name set-value a-super)
|
|
(send (send super-name get-editor) lock #t))
|
|
|
|
;; init depending on inputs ...
|
|
(cond
|
|
[(and (null? a-super) (null? a-v-class))
|
|
(send field-panel add)]
|
|
[(null? a-v-class)
|
|
(send field-panel add)
|
|
(setup-super a-super)]
|
|
[(null? a-super)
|
|
(error 'internal "can't happen: no super, but class provided")]
|
|
[else ;
|
|
(setup-super a-super)
|
|
(let ([name (car a-v-class)]
|
|
[the-fields (cadr a-v-class)])
|
|
(send class-name set-value name)
|
|
(for-each (lambda (f) (send field-panel add f)) the-fields)
|
|
(send purpose set-value (variant-purpose a-v-class)))])))
|
|
|
|
;; Panel Window (String -> Void) -> FieldPanel
|
|
;; manage text fields to add fields to the class in a stack like fashion;
|
|
;; add one on <return>, allow users to delete one
|
|
;; produce the field specs on demand
|
|
(define field-panel%
|
|
(class vertical-panel%
|
|
(init-field window error-message)
|
|
(super-new)
|
|
|
|
;; (Listof TextField)
|
|
;; the list of name TextFields that have been added via (add)
|
|
;; a stack in that the bottom field is always at beginning of list
|
|
;; if empty, there are no fields
|
|
(define the-last-field-name '())
|
|
|
|
;; TextField -> Void
|
|
;; push f on the-last-field-name
|
|
(define (add-field-name f)
|
|
(set! the-last-field-name (cons f the-last-field-name)))
|
|
|
|
;; TextField -> Void
|
|
;; remove from "stack"
|
|
(define (remove-field-name f)
|
|
(set! the-last-field-name (remove f the-last-field-name)))
|
|
|
|
;; TextField Event -> Void
|
|
;; a callback that on return creates a new "add field" panel when
|
|
;; it's the bottom most text field
|
|
(define/public (add-on-return x e)
|
|
(when (eq? (send e get-event-type) 'text-field-enter)
|
|
(when (or (null? the-last-field-name)
|
|
(eq? (car the-last-field-name) x))
|
|
(add))
|
|
(send window on-traverse-char (new key-event% (key-code #\tab)))))
|
|
|
|
;; -> TextField TextField
|
|
;; (list String String) -> TextField TextField
|
|
;; add a field panel so that a new field for the class can be specified
|
|
;; if one argument, it consists of two strings:
|
|
;; one for the type, one for name
|
|
(define/public add
|
|
(case-lambda
|
|
[()
|
|
(send window begin-container-sequence)
|
|
(let* ([fp (add-horizontal-panel this)]
|
|
; [modi (make-modifier-menu fp)]
|
|
[type (make-text-field fp " ")]
|
|
[name (make-text-field fp "" (lambda (x e) (add-on-return x e)))]
|
|
[get-values
|
|
(lambda () ; (send modi get-string-selection)
|
|
(list type name))])
|
|
(send type set-value "<field type>")
|
|
(send name set-value "<field name>")
|
|
(add-field-name name)
|
|
(send fields add type get-values)
|
|
(make-delete-button this fp (lambda ()
|
|
(send fields remove type)
|
|
(remove-field-name name)))
|
|
(send window end-container-sequence)
|
|
(values type name))]
|
|
[(a-field)
|
|
(let-values ([(type name) (add)])
|
|
(send type set-value (car a-field))
|
|
(send name set-value (cadr a-field)))]))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; managing the fields of the class
|
|
|
|
(define fields (new assoc%))
|
|
|
|
(define/public (produce)
|
|
(foldr ;; r gives me the right order
|
|
(lambda (v r)
|
|
(let* ([type-ctl (car v)]
|
|
[name-ctl (cadr v)]
|
|
[type (string-trim-both (send type-ctl get-value))]
|
|
[name (string-trim-both (send name-ctl get-value))])
|
|
(cond
|
|
[(and (java-id? type) (java-id? name))
|
|
(cons (list type name) r)]
|
|
[(java-id? type)
|
|
(error-message name-ctl (format CHECK-FIELD-NAME-F type))]
|
|
[(java-id? name)
|
|
(error-message type-ctl (format CHECK-TYPE-F name))]
|
|
[else r])))
|
|
'()
|
|
(map (lambda (th) (th)) (send fields list))))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; -> UnionInfo
|
|
;; get information about a datatype union
|
|
(define union-info%
|
|
(class class-union-wizard%
|
|
(super-new)
|
|
(inherit-field info-pane switches?)
|
|
(inherit tostring? template? error-message produce-name-from-text)
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; filling in the info-pane
|
|
|
|
(define type-pane
|
|
(new vertical-panel% (parent info-pane)
|
|
(alignment '(center center)) (style '(border))
|
|
(min-height 50) (stretchable-height #f)))
|
|
|
|
(define purpose
|
|
(new text-field%
|
|
(parent type-pane) (label PURPOSE-UNION) (callback void)))
|
|
(define type-text (make-text-field type-pane TYPE))
|
|
;; -> String
|
|
(define (get-type) (produce-name-from-text type-text TYPE))
|
|
|
|
;; --- the variants of the union
|
|
(define meth-pane (new vertical-panel% (parent info-pane) (style '(border))))
|
|
(add-button meth-pane ADD-INTERF (lambda (x y) (send methods add)))
|
|
(define methods (new methods-pane% (window meth-pane) (error-message (lambda (ctl x) (error-message ctl x)))))
|
|
(send methods add)
|
|
(unless switches?
|
|
(send info-pane change-children (lambda (x) (remq meth-pane x))))
|
|
|
|
;; --- the variants of the union
|
|
(define vart-pane (new vertical-panel% (parent info-pane) (style '(border))))
|
|
(add-button vart-pane ADD-VARIANT (lambda (x y) (send vart-panel add)))
|
|
(define vart-panel
|
|
(new variant-panel%
|
|
(parent vart-pane)
|
|
(get-type (lambda () (get-type)))
|
|
(error-message (lambda (ctl x) (error-message ctl x)))))
|
|
|
|
|
|
;; -> Union
|
|
(define/override (produce)
|
|
(with-handlers ([an-error? (lambda _ #f)])
|
|
(define m (send methods produce))
|
|
(list
|
|
(make-dt (get-type)
|
|
m
|
|
(send vart-panel produce)
|
|
(send purpose get-value))
|
|
(tostring?)
|
|
(template?))))
|
|
|
|
(define/override (make-class-cb x e)
|
|
(and (produce) (send this show #f)))
|
|
|
|
;; make two variants to boot
|
|
;; allow people to add and delete a variant
|
|
(send vart-panel add)
|
|
(send vart-panel add)))
|
|
|
|
;; get information about all panels
|
|
(define methods-pane%
|
|
(class vertical-panel%
|
|
(init-field window error-message)
|
|
(super-new (parent window) (min-height 10) (stretchable-height #f))
|
|
|
|
(define methods (new assoc%))
|
|
|
|
;; add a pane to the window for specifying one method signature
|
|
(define/public (add)
|
|
(send window begin-container-sequence)
|
|
(new method-panel%
|
|
(parent window) (style '(border))
|
|
(window window) (error-message error-message) (methods methods))
|
|
(send window end-container-sequence))
|
|
|
|
(define/public (produce) (send methods list))))
|
|
|
|
;; get information about a single method signature
|
|
(define method-panel%
|
|
(class horizontal-panel%
|
|
(init-field window error-message methods)
|
|
(super-new)
|
|
|
|
;; -----------------------------------------------------------------------
|
|
;; the callbacks
|
|
;; remove this pane from the window and its information from the table
|
|
(define (remove _1 _2)
|
|
(send methods remove this)
|
|
(send this begin-container-sequence)
|
|
(send window change-children (lambda (x) (remq this x)))
|
|
(send window container-flow-modified)
|
|
(send this end-container-sequence))
|
|
|
|
;; [Listof TextField%]
|
|
(define pa* '())
|
|
;; (union false '_) '_ -> Void
|
|
;; add this parameter TextField% to pane
|
|
(define (add-parameter-field button-or-false _2)
|
|
(define _ (send this begin-container-sequence))
|
|
(define x (make-text-field this (if button-or-false "," "") void pt))
|
|
(set! pa* (append pa* (list x)))
|
|
(send this change-children
|
|
(lambda (y)
|
|
(remq y pa*)))
|
|
(send this end-container-sequence))
|
|
|
|
;; re-establish this pane so that programmers can edit the method info
|
|
(define (edit _1 _2)
|
|
(send this begin-container-sequence)
|
|
(send this change-children
|
|
(lambda (y) (append (list (car y)) (list ret nam opn) pa* end)))
|
|
(send this end-container-sequence))
|
|
|
|
;; retrieve, check, add method signature to table
|
|
(define (convert-info-to-signature button event)
|
|
(with-handlers ([an-error? (lambda (x) #f)])
|
|
(define sig
|
|
(let ([ctls (cons nam (cons ret pa*))])
|
|
(check-sig
|
|
(map (lambda (x) (send x get-value)) ctls)
|
|
ctls)))
|
|
(define _ (send this begin-container-sequence))
|
|
(define t (new message% (parent this) (label (method sig))))
|
|
(define e (new button% (parent this) (label EDIT) (callback edit)))
|
|
(send this change-children (lambda (y) (cons (car y) (list t e))))
|
|
(send e focus)
|
|
(send methods add this sig)
|
|
(send this end-container-sequence)))
|
|
;; (cons String (cons String (Listof String))) -> Method
|
|
;; check signature
|
|
(define (check-sig sig ctls)
|
|
(define name (string-trim-both (car sig)))
|
|
(define typ* (map string-trim-both (cdr sig)))
|
|
(unless (java-id? name)
|
|
(error-message (car ctls) (format "not a java id: ~s" name)))
|
|
(let ([typ*
|
|
(let loop ([types* typ*][ctls (cdr ctls)])
|
|
(cond
|
|
[(null? types*) '()]
|
|
[(string=? (car types*) "")
|
|
(if (null? (cdr types*))
|
|
'()
|
|
(error-message (car ctls) bad-para))]
|
|
[else
|
|
(if (java-id? (car types*))
|
|
(cons (car types*) (loop (cdr types*) (cdr ctls)))
|
|
(error-message (car ctls) (format no-type (car types*))))]))])
|
|
(cons (car typ*) (cons name (cdr typ*)))))
|
|
(define bad-para
|
|
"\"\" parameter type found, but not at the end of the parameter list")
|
|
(define no-type "not a java type: ~s")
|
|
|
|
(define pt "<parameter type>")
|
|
;; ---------------------------------------------------------------------
|
|
;; now set up the one-line pane for specifying a method signature
|
|
(send window begin-container-sequence)
|
|
(define sub (new button% (parent this) (label "-") (callback remove)))
|
|
;; (make-delete-button ... when purpose statement is added/?
|
|
(define ret (make-text-field this "" void "<return type>"))
|
|
(define nam (make-text-field this "" void "<method name>"))
|
|
(define opn (new message% (parent this) (label "(")))
|
|
(define pa+ (new button% (parent this) (label ", ...") (callback add-parameter-field)))
|
|
(define cls (new message% (parent this) (label ")")))
|
|
(define add (new button% (parent this) (label "+") (callback convert-info-to-signature)))
|
|
(define end (list pa+ cls add))
|
|
;; ---------------------------------------------------------------------
|
|
(add-parameter-field #f '__)
|
|
(send window end-container-sequence)))
|
|
|
|
;; (-> String) (String -> Void) (Any -> Boolean) -> VariantPanel
|
|
;; manage the variant panels and their content for union
|
|
(define variant-panel%
|
|
(class horizontal-panel%
|
|
(super-new (alignment '(center center)) (min-height 150) (stretchable-height #f))
|
|
(init get-type error-message)
|
|
|
|
;; -> Void
|
|
(define/public (add)
|
|
(send this begin-container-sequence)
|
|
(let* ([vp (new vertical-panel% (parent this)(style '(border)))]
|
|
[ms (new message% (parent vp) (label VARIANT))]
|
|
[bt (new button% (parent vp) (label EDIT)
|
|
(callback (create-variant ms)))])
|
|
(send variants add bt #f)
|
|
(make-delete-button this vp (lambda () (send variants remove bt)))
|
|
(send this end-container-sequence)))
|
|
|
|
;; Message -> (Button Event -> Void)
|
|
(define (create-variant ms)
|
|
(lambda (bt evt)
|
|
(with-handlers ([an-error? void])
|
|
(let*-values
|
|
([(type) (get-type)] ;; may raise an error message
|
|
[(class-in) (send variants lookup bt)]
|
|
[(b a-class) (send (new class-info%
|
|
(title VARIANT-WIZD)
|
|
(insert-str INSERT-VARNT)
|
|
(switches? #f) (no-diagram #t)
|
|
(add-str ADD-FIELD)
|
|
(a-super type)
|
|
(a-v-class (if class-in class-in '())))
|
|
call)])
|
|
(when a-class
|
|
(let* ([a-class (car a-class)]
|
|
[name (car a-class)])
|
|
;; no supertype needed: ;; remove (cadr a-class)
|
|
;; comments, if any, are in: (cadddr a-class)
|
|
(send variants update bt
|
|
(list name (caddr a-class) (class-purpose a-class)))
|
|
(send ms set-label name)))))))
|
|
|
|
;; --------------------------------------------------------------------
|
|
;; Managing the datatype: (list name fields [comment])
|
|
(define variants (new assoc%))
|
|
|
|
(define/public (produce)
|
|
(foldr (lambda (f r) (if f (cons f r) r)) '()
|
|
(send variants list)))))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; Pane -> HorizontalPanel
|
|
;; add a fixed-width horizontal panel (50) to p
|
|
(define (add-horizontal-panel p)
|
|
(new horizontal-panel% (parent p) (min-height 50) (stretchable-height #f)))
|
|
|
|
;; String CallBack -> Button
|
|
(define (add-button bp l cb) ;; to button-panel
|
|
(new button% (label l) (parent bp) (callback cb)))
|
|
|
|
;; Panel String -> CheckBox
|
|
(define (make-checkbox p l)
|
|
(new check-box% (parent p) (label l) (callback void)))
|
|
|
|
;; Panel String [Callback] -> TextField
|
|
(define make-text-field
|
|
(opt-lambda (p l (c void) (init ""))
|
|
(new text-field%
|
|
(parent p) (label l) (callback c) (init-value init)
|
|
(min-width 50) (stretchable-width #f))))
|
|
|
|
;; Panel (-> Void) -> Button
|
|
;; create a button that deletes the button's immediate container from this
|
|
(define (make-delete-button this vp delete-from-model)
|
|
(new button% (parent vp) (label DELETE)
|
|
(callback (lambda (x e)
|
|
(delete-from-model)
|
|
(send this change-children
|
|
(lambda (cs)
|
|
(filter (lambda (c) (not (eq? vp c))) cs)))))))
|
|
|
|
(define an-error (cons 1 2))
|
|
;; Any -> Boolean
|
|
(define (an-error? x) (eq? an-error x))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
#| Run, program, run:
|
|
|
|
(require (file "draw-txt.ss"))
|
|
|
|
#| |#
|
|
(define-values (b x) (get-class-info BEGINNER))
|
|
(if (and x b) (printf "/*~n~a~n*/~n" (class-draw (car x))))
|
|
(if x (printf "~a~n" (apply make-class x)))
|
|
|
|
#||#
|
|
(define-values (c y) (get-union-info #;BEGINNER INTERMEDIATE))
|
|
(if (and y c) (printf "/*~n~a~n*/~n" (dt-draw (car y))))
|
|
(if y (printf "~a~n" (apply make-union (append y (list INTERMEDIATE)))))
|
|
|#
|
|
)
|