wizard adopted to interfaces
svn: r2885
This commit is contained in:
Matthias Felleisen
parent
3f3a8e6497
commit
f81804cbe3
|
|
@ -1,53 +1,45 @@
|
|||
#cs
|
||||
(module draw-txt mzscheme
|
||||
(require (lib "etc.ss")
|
||||
(require "data-defs.scm"
|
||||
"class.scm"
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "contract.ss")
|
||||
(file "data-defs.scm"))
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[dt-draw (Union . -> . string?)]
|
||||
[class-draw (Class . -> . string?)])
|
||||
[class-draw ((Class) (listof Method) . opt-> . string?)])
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Deal with a Union of classes
|
||||
|
||||
;; DataType -> String
|
||||
(define (dt-draw dt)
|
||||
(let ([spr (dt-type dt)]
|
||||
[vts (dt-variants dt)])
|
||||
(if (null? vts)
|
||||
(class-draw (list spr "" (dt-fields dt)))
|
||||
(let*-values
|
||||
([(vts-as-strings recursive?) (variants*-to-strings vts spr)]
|
||||
[(width)
|
||||
(apply + (map (lambda (x) (string-length (car x))) vts-as-strings))]
|
||||
;; calculate the connection point for the first and last variant
|
||||
;; then create a line that connects those two points
|
||||
[(last) (caar (last-pair vts-as-strings))]
|
||||
[(fst-bar) (find-bar (caar vts-as-strings))]
|
||||
[(last-bar) (find-bar last)]
|
||||
[(width-of-last) (string-length last)]
|
||||
[(center-of-last) (+ (- width width-of-last) (find-bar last))])
|
||||
(strings->string-as-lines
|
||||
(add-recursion-connector
|
||||
recursive?
|
||||
(append
|
||||
(abstract-to-string spr (dt-fields dt) width recursive?)
|
||||
(map (lambda (x) (centered x width)) REFINEMENT-ARROW)
|
||||
(list (string-append
|
||||
(make-string fst-bar #\space)
|
||||
(make-string (- width fst-bar (- width-of-last +1 last-bar)) #\-)
|
||||
(make-string (- width-of-last +1 last-bar) #\space)))
|
||||
(flatten-string-matrix vts-as-strings))))))))
|
||||
(define spr (dt-type dt))
|
||||
(define vts (dt-variants dt))
|
||||
(define mt* (dt-methods dt))
|
||||
;; String -> Number
|
||||
(define (vbar-pos s)
|
||||
(let loop ([i (- (string-length s) 1)])
|
||||
(cond [(< i 0) (error 'find-bar "can't happen: ~e" s)]
|
||||
[(char=? (string-ref s i) #\|) i]
|
||||
[else (loop (- i 1))])))
|
||||
(if (null? vts)
|
||||
(class-draw (list spr "" '()))
|
||||
(let-values ([(vts:str rec?) (variants*-to-strings vts spr mt*)])
|
||||
(define wth (sum (map (lambda (x) (string-length (car x))) vts:str)))
|
||||
(define fst-vrt (car (car vts:str)))
|
||||
(define lst-vrt (car (last vts:str)))
|
||||
(define fst-bar (vbar-pos fst-vrt))
|
||||
(define lst-bar (vbar-pos lst-vrt))
|
||||
(define diagram
|
||||
(append
|
||||
(type-to-string spr mt* wth rec?)
|
||||
(refinement-connector wth fst-bar (string-length lst-vrt) lst-bar)
|
||||
(flatten-string-matrix vts:str)))
|
||||
(define d/recur (if rec? (add-recursion-connector diagram) diagram))
|
||||
(strings->string-as-lines d/recur))))
|
||||
|
||||
;; String -> Number
|
||||
(define (find-bar s)
|
||||
(let loop ([i (- (string-length s) 1)])
|
||||
(cond [(< i 0) (error 'find-bar "can't happen: ~e" s)]
|
||||
[(char=? (string-ref s i) #\|) i]
|
||||
[else (loop (- i 1))])))
|
||||
|
||||
;; (Listof String) -> (Listof String)
|
||||
;; add
|
||||
;;
|
||||
|
|
@ -55,49 +47,62 @@
|
|||
;; |
|
||||
;; --+ // on last line
|
||||
;; to los
|
||||
(define/contract add-recursion-connector
|
||||
(boolean?
|
||||
(and/c (listof string?) (lambda (los) (>= (length los) 3)))
|
||||
. -> .
|
||||
any)
|
||||
(lambda (r los)
|
||||
(if (not r) los
|
||||
(let* ([fst (car los)]
|
||||
[snd (cadr los)]
|
||||
[lst (car (last-pair los))]
|
||||
[BLK " "]
|
||||
[CON "--+"]
|
||||
[LIN " |"])
|
||||
(cons (string-append fst BLK)
|
||||
(cons (string-append snd CON)
|
||||
(let loop ([l (cddr los)])
|
||||
(cond
|
||||
[(null? (cdr l)) (list (string-append lst CON))]
|
||||
[else (cons (string-append (car l) LIN)
|
||||
(loop (cdr l)))]))))))))
|
||||
(define (add-recursion-connector los)
|
||||
(unless (and (andmap string? los) (>= (length los) 3))
|
||||
(error 'add-recursive-connector "bad inputs: ~s\n" los))
|
||||
|
||||
(let* ([fst (car los)]
|
||||
[snd (cadr los)]
|
||||
[lst (last los)]
|
||||
[BLK " "]
|
||||
[CON "--+"]
|
||||
[LIN " |"])
|
||||
(define (frame l)
|
||||
(cond
|
||||
[(null? (cdr l)) (list (string-append lst CON))]
|
||||
[else (cons (string-append (car l) LIN) (frame (cdr l)))]))
|
||||
(cons (string-append fst BLK)
|
||||
(cons (string-append snd CON) (frame (cddr los))))))
|
||||
|
||||
(define REFINEMENT-ARROW
|
||||
(list "/ \\"
|
||||
"---"
|
||||
" | "))
|
||||
;; Number Number Number Number -> (Listof String)
|
||||
;; create a refinement connector of the proper width like this
|
||||
;;
|
||||
;; |
|
||||
;; / \
|
||||
;; ---
|
||||
;; |
|
||||
;; +----------+
|
||||
;; | |
|
||||
;;
|
||||
(define (refinement-connector width frst-bar width-of-last last-bar)
|
||||
(define REFINEMENT-ARROW
|
||||
(list " | "
|
||||
"/ \\"
|
||||
"---"
|
||||
" | "))
|
||||
(append
|
||||
(map (lambda (x) (centered x width)) REFINEMENT-ARROW)
|
||||
(list (string-append
|
||||
(make-string frst-bar #\space)
|
||||
(make-string (- width frst-bar (- width-of-last +1 last-bar)) #\-)
|
||||
(make-string (- width-of-last +1 last-bar) #\space)))))
|
||||
|
||||
;; Class Fields Number Boolean-> (Listof String)
|
||||
;; create a list of strings that represent the abstract class of a union
|
||||
;; center the strings with respect to width, add a "recursion" arrow (needed?)
|
||||
(define/contract abstract-to-string
|
||||
(string? Fields natural-number/c boolean?
|
||||
. ->d .
|
||||
(lambda (_1 _2 n _3)
|
||||
(lambda (out) (= (string-length (car out)) n))))
|
||||
(lambda (spr fields width recursive)
|
||||
(let* ([class-as-strings (class-to-strings (list spr "" fields))]
|
||||
[width-of-classes (string-length (car class-as-strings))]
|
||||
[super-line (centered (cadr class-as-strings) width)])
|
||||
(cons
|
||||
(centered (car class-as-strings) width)
|
||||
(cons (if recursive (add-<-- super-line) super-line)
|
||||
(map (lambda (x) (centered x width))
|
||||
(cddr class-as-strings)))))))
|
||||
(define (type-to-string spr methods width recursive)
|
||||
(define (range-contract result)
|
||||
(unless (= (string-length (car result)) width)
|
||||
(error 'type-to-string "bad result: ~s\n" result))
|
||||
result)
|
||||
(define class-as-strings (class-to-strings (list spr "" '()) methods))
|
||||
(define width-of-classes (string-length (car class-as-strings)))
|
||||
(define super-line (centered (cadr class-as-strings) width))
|
||||
(range-contract
|
||||
(cons
|
||||
(centered (car class-as-strings) width)
|
||||
(cons (if recursive (add-<-- super-line) super-line)
|
||||
(map (lambda (x) (centered x width)) (cddr class-as-strings))))))
|
||||
|
||||
;; String -> String
|
||||
;; add the containment arrow to an abstract class from the right fringe
|
||||
|
|
@ -111,39 +116,38 @@
|
|||
|
||||
;; VariantClasses Super -> (Listof String)
|
||||
;; for testing and printing only
|
||||
(define (variants*-draw variants spr)
|
||||
(let-values ([(s b) (variants*-to-strings variants spr)])
|
||||
(define (variants*-draw variants spr methods)
|
||||
(let-values ([(s b) (variants*-to-strings variants spr methods)])
|
||||
(flatten-string-matrix s)))
|
||||
|
||||
;; VariantClasses Super -> (Listof (Listof String)) Boolean
|
||||
;; VariantClasses Super (Listof Method) -> (Listof (Listof String)) Boolean
|
||||
;; turns a list of Variants into a list of strings, one per line
|
||||
(define (variants*-to-strings variants spr)
|
||||
(define (variants*-to-strings variants spr methods)
|
||||
(let* ([d (apply max (map (lambda (vc) (length (second vc))) variants))]
|
||||
[recursion #f])
|
||||
(values
|
||||
(let loop ([v variants][cnnctd #f])
|
||||
(cond
|
||||
[(null? v) (set! recursion cnnctd) '()]
|
||||
[else (let-values ([(s b) (variant-to-strings (car v) spr cnnctd d)])
|
||||
[else (let-values ([(s b) (variant-to-strings (car v) spr cnnctd d methods)])
|
||||
(cons s (loop (cdr v) (or cnnctd b))))]))
|
||||
;; ordering: begin
|
||||
recursion)))
|
||||
|
||||
;; VariantClass Super Boolean Number -> String
|
||||
(define (variant-draw class super left-connected depth)
|
||||
(let-values ([(s b) (variant-to-strings class super left-connected depth)])
|
||||
(strings->string-as-lines s)))
|
||||
#;(define (variant-draw class super left-connected depth)
|
||||
(define-values (s b) (variant-to-strings class super left-connected depth))
|
||||
(strings->string-as-lines s))
|
||||
|
||||
;; VariantClass Super Boolean Number ->* String Boolean
|
||||
;; VariantClass Super Boolean Number (Listof Method) ->* String Boolean
|
||||
;; turns a variant class into a list of strings,
|
||||
;; computes whether the class points to super
|
||||
;; with hooks for refinement arrows and for recursive containment arrows
|
||||
;; with depth :: max number of fields in a variant class of the uion
|
||||
;; with left-connected :: whether or not a variant to the left is already rec
|
||||
;; with super :: the name of the datatype
|
||||
(define (variant-to-strings variant super left-connected depth)
|
||||
(let* ([cs
|
||||
(class-to-strings (cons (car variant) (cons super (cdr variant))))]
|
||||
(define (variant-to-strings variant super left-connected depth methods)
|
||||
(let* ([cs (class-to-strings (cons (car variant) (cons super (cdr variant))) methods)]
|
||||
[head (list (car cs) (cadr cs) (caddr cs))]
|
||||
[tail (cdddr cs)]
|
||||
[fields (second variant)]
|
||||
|
|
@ -154,7 +158,7 @@
|
|||
[STG "--"] ;; (= (string-length CON) (string-length BLK))
|
||||
[BLK " "] ;; (= (string-length CON) (string-length BLK))
|
||||
[LIN " |"] ;; (= (string-length CON) (string-length LIN))
|
||||
[junk (lambda _ (symbol->string (gensym)))]
|
||||
[junk (lambda _ (symbol->string (gensym)))]
|
||||
[width (string-length (car cs))]
|
||||
[mkln (lambda (lft ch str)
|
||||
(string-append lft (make-string width ch) str))])
|
||||
|
|
@ -170,7 +174,9 @@
|
|||
[else BLK])))
|
||||
cs
|
||||
;; pad types with junk lines for class header and class bottom
|
||||
(append (map junk head) types (list (junk))))
|
||||
(append (map junk head) types (list (junk))
|
||||
(map junk methods)
|
||||
(if (null? methods) '() (list (junk)))))
|
||||
(build-list (- depth -1 (length fields))
|
||||
(lambda _ (mkln BLK #\space (if recursion LIN BLK))))
|
||||
(list
|
||||
|
|
@ -182,13 +188,13 @@
|
|||
;; ---------------------------------------------------------------------------
|
||||
;; Deal with a single class
|
||||
|
||||
;; Class -> String
|
||||
(define (class-draw class)
|
||||
(strings->string-as-lines (class-to-strings class)))
|
||||
;; Class [(listof Method)] opt-> String
|
||||
(define (class-draw class . ms)
|
||||
(strings->string-as-lines (apply class-to-strings class ms)))
|
||||
|
||||
;; Class -> (cons String (cons String (cons String (Listof String))))
|
||||
;; Class [(Listof Method)] opt-> (cons String (cons String (cons String (Listof String))))
|
||||
;; turns a class into a list of strings that represents the class
|
||||
(define (class-to-strings class)
|
||||
(define (class-to-strings class . ms)
|
||||
(let* ([name (first class)]
|
||||
[super (second class)]
|
||||
[fields (third class)]
|
||||
|
|
@ -196,13 +202,16 @@
|
|||
[names (map second fields)]
|
||||
;; start drawing
|
||||
[fields (create-field-declarations fields)]
|
||||
[width (width-class name fields)]
|
||||
[methds (if (pair? ms) (apply create-method-declarations ms) ms)]
|
||||
[width (width-class name (append methds fields))]
|
||||
[separat (make-separator-line width)])
|
||||
`(,separat
|
||||
,((make-line width) name)
|
||||
,separat
|
||||
,@(map (make-line width) fields)
|
||||
,separat)))
|
||||
,((make-line width) name)
|
||||
,separat
|
||||
,@(map (make-line width) fields)
|
||||
,separat
|
||||
,@(if (null? methds) '() (map (make-line width) methds))
|
||||
,@(if (null? methds) '() (list separat)))))
|
||||
|
||||
;; (Listof Field) -> (Listof String)
|
||||
;; create text lines from Fields
|
||||
|
|
@ -210,6 +219,10 @@
|
|||
(map (lambda (f) (string-append (string-append (first f) " " (second f))))
|
||||
fields))
|
||||
|
||||
;; (Listof Method) -> (Listof String)
|
||||
;; create text lines from Methods
|
||||
(define (create-method-declarations fields) (map method fields))
|
||||
|
||||
;; Number -> String
|
||||
;; make a separator line (+----+) of width
|
||||
(define (make-separator-line width)
|
||||
|
|
@ -253,7 +266,7 @@
|
|||
(define (flatten-string-matrix smatrix)
|
||||
(apply map (lambda l (apply string-append l)) smatrix))
|
||||
|
||||
|
||||
|
||||
;; String Number -> String
|
||||
;; place str in the center of an otherwise blank string
|
||||
(define (centered str width)
|
||||
|
|
@ -261,7 +274,13 @@
|
|||
[lft (quotient (- width len-str) 2)]
|
||||
[rgt (- width len-str lft)])
|
||||
(string-append (make-string lft #\space) str (make-string rgt #\space))))
|
||||
|
||||
|
||||
;; (cons X (listof X)) -> X
|
||||
(define (last l) (car (last-pair l)))
|
||||
|
||||
;; (Listof Number) -> Number
|
||||
(define (sum l) (foldr + 0 l))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Constants
|
||||
|
||||
|
|
@ -274,10 +293,10 @@
|
|||
|
||||
#|Tests:
|
||||
(require (lib "testing.scm" "testing"))
|
||||
|
||||
|
||||
(test== (centered "|" 2) "| ")
|
||||
(test== (centered "|" 3) " | ")
|
||||
|
||||
|
||||
"testing classes"
|
||||
(define class1 (list "Class" "Super" '(("int" "capacity") ("hello" "world"))))
|
||||
(define class2 (list "Class" "Super" '()))
|
||||
|
|
@ -298,8 +317,8 @@
|
|||
"+-------+"
|
||||
"+-------+"))
|
||||
|
||||
(test== (class-draw class1) (strings->string-as-lines expected-class))
|
||||
(test== (class-draw class2) (strings->string-as-lines expected-class2))
|
||||
(test== (class-draw class1 '()) (strings->string-as-lines expected-class))
|
||||
(test== (class-draw class2 '()) (strings->string-as-lines expected-class2))
|
||||
|
||||
; (printf "~a~n" (class-draw class1))
|
||||
|
||||
|
|
@ -347,33 +366,33 @@
|
|||
" |"
|
||||
"---------------+"))
|
||||
|
||||
(test== (let-values ([(s b) (variant-to-strings vclass1 "Super" #f 3)]) s)
|
||||
(test== (let-values ([(s b) (variant-to-strings vclass1 "Super" #f 3 '())]) s)
|
||||
expected-variant1)
|
||||
(test== (variant-draw vclass1 "Super" #f 3)
|
||||
#;(test== (variant-draw vclass1 "Super" #f 3)
|
||||
(strings->string-as-lines expected-variant1))
|
||||
(test== (variant-draw vclass2 "Super" #f 3)
|
||||
#;(test== (variant-draw vclass2 "Super" #f 3)
|
||||
(strings->string-as-lines expected-variant2))
|
||||
(test== (variant-draw vclass3 "Super" #t 3)
|
||||
#;(test== (variant-draw vclass3 "Super" #t 3)
|
||||
(strings->string-as-lines expected-variant3))
|
||||
|
||||
|
||||
(test== (let-values
|
||||
([(s b)
|
||||
(variants*-to-strings (list vclass1 vclass2 vclass3) "Super")])
|
||||
(variants*-to-strings (list vclass1 vclass2 vclass3) "Super" '())])
|
||||
s)
|
||||
(list expected-variant1 expected-variant2 expected-variant3))
|
||||
|
||||
(test== (variants*-draw (list vclass1 vclass2 vclass3) "Super")
|
||||
(test== (variants*-draw (list vclass1 vclass2 vclass3) "Super" '())
|
||||
(flatten-string-matrix
|
||||
(list expected-variant1 expected-variant2 expected-variant3)))
|
||||
|
||||
|
||||
(define aclass-exp ;; 19
|
||||
(list " +-------+ "
|
||||
" | Super |<----"
|
||||
" +-------+ "
|
||||
" +-------+ "))
|
||||
|
||||
(test== (abstract-to-string "Super" '() 19 #t)
|
||||
(test== (type-to-string "Super" '() 19 #t)
|
||||
aclass-exp)
|
||||
|
||||
(test== (dt-draw
|
||||
|
|
@ -383,31 +402,35 @@
|
|||
""))
|
||||
(strings->string-as-lines expected-class2))
|
||||
|
||||
(dt-draw (make-dt "Super" '() (list vclass1 vclass2 vclass3) ""))
|
||||
|
||||
(test== (dt-draw
|
||||
(make-dt "Super" '() (list vclass1 vclass2 vclass3) ""))
|
||||
(strings->string-as-lines
|
||||
'(
|
||||
" +-------+ "
|
||||
" | Super |<---------------------+"
|
||||
" +-------+ |"
|
||||
" +-------+ |"
|
||||
" / \\ |" ;; note escape
|
||||
" --- |"
|
||||
" | |"
|
||||
" ---------------------------------- |"
|
||||
" | | | |"
|
||||
" +----------+ +-----------+ +----------+ |"
|
||||
" | Variant1 | | Variant2 | | Variant3 | |"
|
||||
" +----------+ +-----------+ +----------+ |"
|
||||
" +----------+ | int x | | String x | |"
|
||||
" | boolean y | | Super y |-+ |"
|
||||
" | Super z |-+ | Super z |-+ |"
|
||||
" +-----------+ | +----------+ | |"
|
||||
" | | |"
|
||||
" +---------------+--+"
|
||||
" +-------+ "
|
||||
" | Super |<---------------------+"
|
||||
" +-------+ |"
|
||||
" +-------+ |"
|
||||
" | |"
|
||||
" / \\ |" ;; note escape
|
||||
" --- |"
|
||||
" | |"
|
||||
" ---------------------------------- |"
|
||||
" | | | |"
|
||||
" +----------+ +-----------+ +----------+ |"
|
||||
" | Variant1 | | Variant2 | | Variant3 | |"
|
||||
" +----------+ +-----------+ +----------+ |"
|
||||
" +----------+ | int x | | String x | |"
|
||||
" | boolean y | | Super y |-+ |"
|
||||
" | Super z |-+ | Super z |-+ |"
|
||||
" +-----------+ | +----------+ | |"
|
||||
" | | |"
|
||||
" +---------------+--+"
|
||||
)))
|
||||
|
||||
(test== (dt-draw
|
||||
|
||||
(string-delta (dt-draw
|
||||
(make-dt "Super"
|
||||
'(("int" "x"))
|
||||
'(("VC1" (("int" "x")))
|
||||
|
|
@ -415,26 +438,29 @@
|
|||
("VC3" (("String" "s"))))
|
||||
""))
|
||||
(strings->string-as-lines
|
||||
'(
|
||||
" +-------+ "
|
||||
" | Super | "
|
||||
" +-------+ "
|
||||
" | int x | "
|
||||
" +-------+ "
|
||||
" / \\ "
|
||||
" --- "
|
||||
" | "
|
||||
" -------------------------------- "
|
||||
" | | | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | VC1 | | VC2 | | VC3 | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | int x | | boolean b | | String s | "
|
||||
" +-------+ | int y | +----------+ "
|
||||
" +-----------+ "
|
||||
" "
|
||||
" "
|
||||
)))
|
||||
'(
|
||||
" +---------+ "
|
||||
" | Super | "
|
||||
" +---------+ "
|
||||
" +---------+ "
|
||||
" | int x() | "
|
||||
" +---------+ "
|
||||
" | "
|
||||
" / \\ "
|
||||
" --- "
|
||||
" | "
|
||||
" -------------------------------- "
|
||||
" | | | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | VC1 | | VC2 | | VC3 | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | int x | | boolean b | | String s | "
|
||||
" +-------+ | int y | +----------+ "
|
||||
" +-----------+ "
|
||||
" "
|
||||
" "
|
||||
)))
|
||||
|
||||
|
||||
|#
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,9 +2,12 @@
|
|||
(define name "ProfessorJ Wizard")
|
||||
(define tools (list (list "tool.ss")))
|
||||
(define comment '(define compile-subcollections (list (list "profj" "parsers")
|
||||
(list "profj" "libs" "java" "lang")
|
||||
(list "profj" "libs" "java" "io"))))
|
||||
(list "profj" "libs" "java" "lang")
|
||||
(list "profj" "libs" "java" "io"))))
|
||||
(define compile-omit-files
|
||||
'("draw-txt0.ss" "macro-class.scm" "view0.scm" "data-defs0.scm"))
|
||||
|
||||
'("draw-txt0.ss"
|
||||
"macro-class.scm"
|
||||
"view0.scm"
|
||||
"data-defs0.scm"))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,66 +1,92 @@
|
|||
#cs
|
||||
(module tool mzscheme
|
||||
(require (lib "tool.ss" "drscheme")
|
||||
(require "class.scm"
|
||||
"union.ss"
|
||||
"view.scm"
|
||||
"draw-txt.ss"
|
||||
"data-defs.scm"
|
||||
(lib "tool.ss" "drscheme")
|
||||
(only (lib "drsig.ss" "drscheme" "private") drscheme:language-configuration^)
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "unitsig.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "class.ss")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
|
||||
(file "class.scm")
|
||||
(file "view.scm")
|
||||
(file "draw-txt.ss"))
|
||||
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(provide tool@)
|
||||
|
||||
;; Strings
|
||||
(define insert-java-class "Insert Java Class")
|
||||
(define insert-java-union "Insert Java Union")
|
||||
|
||||
(define INSERT-JAVA-CLASS "Insert Java Class")
|
||||
(define INSERT-JAVA-UNION "Insert Java Union")
|
||||
|
||||
(define tool@
|
||||
(unit/sig drscheme:tool-exports^
|
||||
(import drscheme:tool^)
|
||||
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Wire up to DrScheme
|
||||
;;
|
||||
|
||||
|
||||
;; insert a Java Class
|
||||
|
||||
|
||||
(define (java-class-wizard-mixin %)
|
||||
(class %
|
||||
(inherit get-special-menu get-edit-target-object)
|
||||
|
||||
(super-new)
|
||||
|
||||
;; String (-> X) (X -> String) -> Void
|
||||
(define (make-menu-item% insert-what get-class-info make-what draw-what)
|
||||
(new menu-item%
|
||||
(label insert-what) (parent (get-special-menu))
|
||||
(callback
|
||||
(lambda (menu event)
|
||||
(let*-values
|
||||
([(editor) (get-edit-target-object)]
|
||||
[(b class-as-info) (get-class-info)]
|
||||
[(class-as-strn) (if (boolean? class-as-info)
|
||||
""
|
||||
(apply make-what class-as-info))]
|
||||
[(class-as-dia) (if (and class-as-info b)
|
||||
(format
|
||||
"/*~n~a~n*/~n~n"
|
||||
(draw-what (car class-as-info)))
|
||||
"")])
|
||||
(send editor insert class-as-dia)
|
||||
(send editor insert class-as-strn))))))
|
||||
(define (tee x) x)
|
||||
|
||||
(make-menu-item% insert-java-class get-class-info make-class class-draw)
|
||||
(make-menu-item% insert-java-union get-union-info make-union dt-draw)
|
||||
))
|
||||
#;(define-syntax tee
|
||||
(syntax-rules ()
|
||||
((_ x)
|
||||
(let* ([a (format "--> ~a\n" 'x)]
|
||||
[y x]
|
||||
[b (format "==> ~a\n" y)])
|
||||
(message-box "error" (format "~a~a" a b))
|
||||
y))))
|
||||
|
||||
;; String (LANGUAGE-LEVEL -> X) (X ... -> String) (X ... -> String) -> Void
|
||||
;; create a menu item for inserting classes and interfaces
|
||||
(define (make-menu-item% descr get-info make draw)
|
||||
(define (A menu event)
|
||||
;; ---------------------------------------------------------------
|
||||
;; does the current language need 'public' for 'interface methods'
|
||||
(define foo (send this get-current-tab))
|
||||
(define bar (send foo get-defs))
|
||||
(define moo (send bar get-next-settings))
|
||||
(define koo
|
||||
(drscheme:language-configuration:language-settings-language moo))
|
||||
(define current-language* (tee (send koo get-language-position)))
|
||||
;; ---------------------------------------------------------------
|
||||
|
||||
(define language-level
|
||||
(let ([simple* (member "ProfessorJ" current-language*)])
|
||||
(cond
|
||||
[(boolean? simple*) PROFESSIONAL]
|
||||
[(eq? (cadr simple*) BEGINNER) BEGINNER]
|
||||
[(eq? (cadr simple*) INTERMEDIATE) INTERMEDIATE]
|
||||
[else PROFESSIONAL])))
|
||||
|
||||
;; get the editor and insert the desired items ...
|
||||
(define editor (get-edit-target-object))
|
||||
(define-values (b class-as-info) (get-info language-level))
|
||||
;; ... the class
|
||||
(when class-as-info
|
||||
(let ([class-as-text (apply make (append class-as-info (list language-level)))])
|
||||
(when b
|
||||
;; ... the diagram
|
||||
(send editor insert (format "/*~n~a~n*/~n~n" (draw (car class-as-info)))))
|
||||
(send editor insert class-as-text))))
|
||||
(new menu-item% (label descr) (parent (get-special-menu)) (callback A)))
|
||||
|
||||
(make-menu-item% INSERT-JAVA-CLASS get-class-info make-class class-draw)
|
||||
(make-menu-item% INSERT-JAVA-UNION get-union-info make-union dt-draw)))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame java-class-wizard-mixin)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,22 +1,21 @@
|
|||
#cs
|
||||
(module view mzscheme
|
||||
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(require "assoc-list.scm"
|
||||
"aux-class.scm"
|
||||
"data-defs.scm"
|
||||
"class.scm"
|
||||
"union.ss"
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "string.ss" "srfi" "13")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(require (file "assoc-list.scm")
|
||||
(file "data-defs.scm")
|
||||
(file "aux-class.scm"))
|
||||
|
||||
(provide/contract
|
||||
[get-class-info (->* []
|
||||
[boolean? (union false/c (list/c Class boolean? boolean?))])]
|
||||
[get-union-info (->* []
|
||||
[boolean? (union false/c (list/c Union boolean? boolean?))])])
|
||||
[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")
|
||||
|
|
@ -27,6 +26,7 @@
|
|||
(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")
|
||||
|
|
@ -34,6 +34,7 @@
|
|||
(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")
|
||||
|
|
@ -43,25 +44,26 @@
|
|||
(define ABORT "Abort")
|
||||
(define ERROR: "Error: ")
|
||||
(define DELETE "Delete")
|
||||
(define EDIT "edit")
|
||||
(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)
|
||||
(let ([ci (new class-info% (title CLASS-WIZARD)
|
||||
(insert-str INSERT-CLASS) (add-str ADD-FIELD))])
|
||||
(send ci call)))
|
||||
(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)
|
||||
(let ([ui (new union-info% (title UNION-WIZARD)
|
||||
(insert-str INSERT-UNION) (add-str ADD-VARIANT))])
|
||||
(send ui 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))
|
||||
|
||||
#|
|
||||
*---------------------*
|
||||
|
|
@ -76,11 +78,9 @@
|
|||
| tostring? |
|
||||
| template? |
|
||||
| error-message |
|
||||
| an-error? |
|
||||
| call |
|
||||
| A: produce |
|
||||
| A: make-class-cb |
|
||||
| A: add-field-cb |
|
||||
*---------------------*
|
||||
|
|
||||
|
|
||||
|
|
@ -90,18 +90,18 @@
|
|||
*---------------------* *---------------------*
|
||||
| class-info% | | union-info% |
|
||||
*---------------------* *---------------------*
|
||||
| field-panel |--+ | vart-panel |--+
|
||||
*---------------------* | *---------------------* |
|
||||
| |
|
||||
| |
|
||||
| |
|
||||
| |
|
||||
*---------------------* | *---------------------* |
|
||||
| vertical-panel% | | | horizontal-panel% | |
|
||||
*---------------------* | *---------------------* |
|
||||
| | | |
|
||||
| | | |
|
||||
/ \ | / \ |
|
||||
| |--+ | vart-panel |--+
|
||||
*---------------------* *---------------------* |
|
||||
|
|
||||
|
|
||||
|
|
||||
|
|
||||
*---------------------* *---------------------* |
|
||||
| vertical-panel% | | horizontal-panel% | |
|
||||
*---------------------* *---------------------* |
|
||||
| | |
|
||||
| | |
|
||||
/ \ / \ |
|
||||
*---------------------* *---------------------*
|
||||
| field-panel% | | variant-panel% |
|
||||
*---------------------* *---------------------*
|
||||
|
|
@ -111,8 +111,8 @@
|
|||
*---------------------* | acquired: |
|
||||
| acquired: | | get-type |
|
||||
| window (?) | | error-message |
|
||||
| error-message | | an-error? |
|
||||
*---------------------* *---------------------*
|
||||
| error-message | *---------------------*
|
||||
*---------------------*
|
||||
|
||||
|#
|
||||
|
||||
|
|
@ -124,8 +124,8 @@
|
|||
|
||||
;; String String String -> ClassUnionWizard
|
||||
(define class-union-wizard%
|
||||
(class dialog% (init-field title insert-str add-str (switches? #t))
|
||||
(super-new (label title) (width 500) (height 300))
|
||||
(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)))
|
||||
|
||||
|
|
@ -134,23 +134,28 @@
|
|||
(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)
|
||||
(add-button button-panel insert-str
|
||||
(lambda (x e) (set! abort? #f) (make-class-cb x e)))
|
||||
|
||||
(define/abstract add-field-cb)
|
||||
(add-button button-panel add-str (lambda (x e) (add-field-cb x e)))
|
||||
|
||||
|
||||
;; switches for toString methods and template in comments
|
||||
(define switch-pane (add-horizontal-panel p))
|
||||
(define-values (string template diagram)
|
||||
(if switches?
|
||||
(let ([switch-pane (add-horizontal-panel p)])
|
||||
(values (make-checkbox switch-pane ADD-TOSTRING)
|
||||
(make-checkbox switch-pane ADD-TEMPLATE)
|
||||
(make-checkbox switch-pane ADD-DIAGRAM)))
|
||||
(values #f #f #f)))
|
||||
(define (get-switch x) (and switches? (send x get-value)))
|
||||
(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))
|
||||
(define/public (diagram?) (get-switch diagram))
|
||||
|
|
@ -163,7 +168,6 @@
|
|||
;; error panel
|
||||
|
||||
(define message-size 100)
|
||||
(define an-error (cons 1 2))
|
||||
(define message
|
||||
(new message% (parent (add-horizontal-panel p))
|
||||
(label (make-string message-size #\space))))
|
||||
|
|
@ -172,9 +176,7 @@
|
|||
(define/public (error-message m)
|
||||
(send message set-label (string-append ERROR: m))
|
||||
(raise an-error))
|
||||
;; Any -> Boolean
|
||||
(define/public (an-error? x) (eq? an-error x ))
|
||||
|
||||
|
||||
;; TextField (union false String) -> java-id?
|
||||
(define/public (produce-name-from-text name msg)
|
||||
(let ([x (string-trim-both (send name get-value))])
|
||||
|
|
@ -199,9 +201,7 @@
|
|||
(init-field (a-super null) (a-v-class null))
|
||||
(super-new)
|
||||
(inherit-field info-pane)
|
||||
(inherit
|
||||
tostring? template? diagram?
|
||||
error-message an-error? produce-name-from-text)
|
||||
(inherit tostring? template? diagram? error-message produce-name-from-text)
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
;; filling the info-pane
|
||||
|
|
@ -209,36 +209,35 @@
|
|||
;; 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)))
|
||||
(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 EXTENDS super-cb))
|
||||
(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 info-pane) (window this)
|
||||
(parent field-pane) (window this)
|
||||
(error-message (lambda (x) (error-message x)))))
|
||||
|
||||
(define/override (add-field-cb x e) (send field-panel add))
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
;; creating the class from the specification
|
||||
|
||||
;; -> (union false (list Class boolean? boolean?))
|
||||
(define/override (produce)
|
||||
(with-handlers ([(lambda (x) (an-error? x)) (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?))))
|
||||
(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)
|
||||
|
|
@ -268,10 +267,8 @@
|
|||
[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)))])
|
||||
|
||||
))
|
||||
|
||||
(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
|
||||
|
|
@ -315,19 +312,22 @@
|
|||
(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 TYPE)]
|
||||
[name (make-text-field
|
||||
fp NAME (lambda (x e) (add-on-return x e)))]
|
||||
[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 (send type get-value) (send name get-value)))])
|
||||
(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)])
|
||||
|
|
@ -355,18 +355,16 @@
|
|||
'()
|
||||
(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)
|
||||
(inherit
|
||||
tostring? template? error-message an-error? produce-name-from-text)
|
||||
(inherit-field info-pane switches?)
|
||||
(inherit tostring? template? error-message produce-name-from-text)
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
;; -----------------------------------------------------------------------
|
||||
;; filling in the info-pane
|
||||
|
||||
(define type-pane
|
||||
|
|
@ -381,28 +379,31 @@
|
|||
;; -> 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 (x) (error-message 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 info-pane)
|
||||
(parent vart-pane)
|
||||
(get-type (lambda () (get-type)))
|
||||
(error-message (lambda (x) (error-message x)))
|
||||
(an-error? (lambda (x) (an-error? x)))))
|
||||
|
||||
;; Information about the union's common fields:
|
||||
(add-button info-pane "Add Common Field"
|
||||
(lambda (x e) (send field-panel add)))
|
||||
(define field-panel
|
||||
(new field-panel%
|
||||
(parent info-pane) (window this)
|
||||
(error-message (lambda (x) (error-message x)))))
|
||||
(send field-panel add)
|
||||
|
||||
|
||||
;; -> Union
|
||||
(define/override (produce)
|
||||
(with-handlers ([(lambda (x) (an-error? x)) (lambda _ #f)])
|
||||
(with-handlers ([an-error? (lambda _ #f)])
|
||||
(define m (send methods produce))
|
||||
(list
|
||||
(make-dt (get-type)
|
||||
(send field-panel produce)
|
||||
m
|
||||
(send vart-panel produce)
|
||||
(send purpose get-value))
|
||||
(tostring?)
|
||||
|
|
@ -411,30 +412,140 @@
|
|||
(define/override (make-class-cb x e)
|
||||
(when (produce) (send this show #f)))
|
||||
|
||||
(define/override (add-field-cb x e)
|
||||
(send vart-panel add))
|
||||
|
||||
;; 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)
|
||||
(let loop ([y y])
|
||||
(if (eq? (cadr y) pa+)
|
||||
(set-cdr! y (cons x end))
|
||||
(loop (cdr y))))
|
||||
y))
|
||||
(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
|
||||
(check-sig
|
||||
(map (lambda (x) (send x get-value)) (cons nam (cons ret pa*)))))
|
||||
(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)
|
||||
(define name (string-trim-both (car sig)))
|
||||
(define typ* (map string-trim-both (cdr sig)))
|
||||
(unless (java-id? name)
|
||||
(error-message (format "not a java id: ~s" name)))
|
||||
(let ([typ*
|
||||
(let loop ([types* typ*])
|
||||
(cond
|
||||
[(null? types*) '()]
|
||||
[(string=? (car types*) "")
|
||||
(if (null? (cdr types*))
|
||||
'()
|
||||
(error-message bad-para))]
|
||||
[else
|
||||
(if (java-id? (car types*))
|
||||
(cons (car types*) (loop (cdr types*)))
|
||||
(error-message (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)) (style '(border))
|
||||
(min-height 150) (stretchable-height #f))
|
||||
(init get-type error-message an-error?)
|
||||
(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)))))
|
||||
(make-delete-button this vp (lambda () (send variants remove bt)))
|
||||
(send this end-container-sequence)))
|
||||
|
||||
;; Message -> (Button Event -> Void)
|
||||
(define (create-variant ms)
|
||||
|
|
@ -446,7 +557,7 @@
|
|||
[(b a-class) (send (new class-info%
|
||||
(title VARIANT-WIZD)
|
||||
(insert-str INSERT-VARNT)
|
||||
(switches? #f)
|
||||
(switches? #f) (no-diagram #t)
|
||||
(add-str ADD-FIELD)
|
||||
(a-super type)
|
||||
(a-v-class (if class-in class-in '())))
|
||||
|
|
@ -484,9 +595,9 @@
|
|||
|
||||
;; Panel String [Callback] -> TextField
|
||||
(define make-text-field
|
||||
(opt-lambda (p l (c void))
|
||||
(opt-lambda (p l (c void) (init ""))
|
||||
(new text-field%
|
||||
(parent p) (label l) (callback c)
|
||||
(parent p) (label l) (callback c) (init-value init)
|
||||
(min-width 50) (stretchable-width #f))))
|
||||
|
||||
;; Panel (-> Void) -> Button
|
||||
|
|
@ -499,18 +610,23 @@
|
|||
(lambda (cs)
|
||||
(filter (lambda (c) (not (eq? vp c))) cs)))))))
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
#| Run, program, run:
|
||||
|
||||
(require (file "class.scm") (file "draw-txt.ss"))
|
||||
(define an-error (cons 1 2))
|
||||
;; Any -> Boolean
|
||||
(define (an-error? x) (eq? an-error x))
|
||||
|
||||
(define-values (b x) (get-class-info))
|
||||
;; ------------------------------------------------------------------------
|
||||
#| 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))
|
||||
|
||||
#||#
|
||||
(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 y)))
|
||||
(if y (printf "~a~n" (apply make-union (append y (list INTERMEDIATE)))))
|
||||
|
||||
|#
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user