profj is gone, profjWizard follows
svn: r15949
This commit is contained in:
Eli Barzilay
parent
eda69b472a
commit
a5049e9d03
|
|
@ -1,83 +0,0 @@
|
|||
(module assoc-list mzscheme
|
||||
|
||||
(require mzlib/class)
|
||||
|
||||
(provide assoc%)
|
||||
|
||||
(define assoc<%>
|
||||
(interface ()
|
||||
;; type X, Y
|
||||
add ;; X Y -> Void
|
||||
;; add (cons x y) to fields or update the existing association
|
||||
remove ;; X -> Void
|
||||
list ;; -> [Listof Y]
|
||||
lookup ;; X -> Y
|
||||
update ;; X Y -> Void
|
||||
))
|
||||
|
||||
(define assoc%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
||||
;; (Listof (Cons X Y))
|
||||
(define fields '())
|
||||
|
||||
;; X Y -> Void
|
||||
(define/public (add type name)
|
||||
(define a (assq type fields))
|
||||
(if a
|
||||
(send this update type name)
|
||||
(set! fields (cons (cons type name) fields))))
|
||||
|
||||
;; X -> Void
|
||||
(define/public (remove type)
|
||||
(set! fields
|
||||
(let loop ([fields fields])
|
||||
(cond
|
||||
[(null? fields) '()]
|
||||
[(eq? (caar fields) type) (cdr fields)]
|
||||
[else (cons (car fields) (loop (cdr fields)))]))))
|
||||
|
||||
;; -> (Listof Y)
|
||||
;; extract all y in the order in which they were entered
|
||||
(define/public (list) (reverse (map (lambda (f) (cdr f)) fields)))
|
||||
|
||||
;; X -> Y
|
||||
(define/public (lookup to-edit)
|
||||
(let loop ([v fields])
|
||||
(cond
|
||||
[(null? v) (error 'internal "can't find field")]
|
||||
[(eq? (caar v) to-edit) (cdar v)]
|
||||
[else (loop (cdr v))])))
|
||||
|
||||
;; X Y -> Void
|
||||
(define/public (update to-edit new-v)
|
||||
(set! fields
|
||||
(let loop ([v fields])
|
||||
(cond
|
||||
[(null? v) (error 'internal "can't find variant")]
|
||||
[(eq? (caar v) to-edit) (cons (cons (caar v) new-v) (cdr v))]
|
||||
[else (cons (car v) (loop (cdr v)))]))))))
|
||||
|
||||
#| Tests:
|
||||
(require (lib "testing.scm" "testing"))
|
||||
|
||||
(define al (new assoc%))
|
||||
|
||||
(send al add 0 1)
|
||||
(test== (send al list) (list 1))
|
||||
|
||||
(send al add 'a 'b)
|
||||
(test== (send al list) (list 1 'b))
|
||||
|
||||
(send al update 0 33)
|
||||
(test== (send al lookup 0) 33)
|
||||
|
||||
(send al remove 0)
|
||||
(test== (send al list) (list 'b))
|
||||
|
||||
(send al remove 'a)
|
||||
(test== (send al list) '())
|
||||
|#
|
||||
|
||||
)
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
(module aux-class mzscheme
|
||||
(require mzlib/class)
|
||||
|
||||
(provide
|
||||
(all-from mzlib/class)
|
||||
define/abstract ; (define/abstract <identifier>) :: <definition>
|
||||
)
|
||||
|
||||
(define-syntax define/abstract
|
||||
(syntax-rules ()
|
||||
[(define/abstract id)
|
||||
(define/public id (lambda x (error 'id "abstract")))]))
|
||||
|
||||
)
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
(module aux-contract mzscheme
|
||||
|
||||
(require-for-syntax (file "aux-syntax.scm"))
|
||||
(require mzlib/contract)
|
||||
|
||||
(provide
|
||||
define-as-contract ;; <definition>
|
||||
)
|
||||
|
||||
;; (define-as-contract string (id x ...) body ...)
|
||||
;; introduces id for export as a contract and
|
||||
;; is-id? for local testing as a function
|
||||
(define-syntax (define-as-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ message (name . args) . body)
|
||||
(with-syntax ([is-name (prefix-id-suffix "is-" (syntax name) "?")]
|
||||
[ct-name (cap-id (syntax name))])
|
||||
(syntax
|
||||
(begin
|
||||
(define (is-name . args) . body)
|
||||
(define ct-name (flat-named-contract message is-name)))))]))
|
||||
|
||||
)
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#cs(module aux-syntax mzscheme
|
||||
|
||||
(provide
|
||||
prefix-id-suffix ; String Identifier String -> Identifier
|
||||
add? ; Identifier -> Identifier
|
||||
cap-id ; Identifier -> Identifier
|
||||
)
|
||||
|
||||
(require mzlib/string)
|
||||
|
||||
(define (prefix-id-suffix prefix e suffix)
|
||||
(datum->syntax-object
|
||||
e (string->symbol (format "~a~a~a" prefix (syntax-e e) suffix))))
|
||||
|
||||
;; to add a ? at the end of an identifier
|
||||
(define (add? e) (prefix-id-suffix "" e "?"))
|
||||
|
||||
(define (cap-id id-e)
|
||||
(let* ([id-s (symbol->string (syntax-e id-e))]
|
||||
[fst (substring id-s 0 1)]
|
||||
[rst (substring id-s 1 (string-length id-s))])
|
||||
(string-uppercase! fst)
|
||||
(datum->syntax-object id-e (string->symbol (string-append fst rst)))))
|
||||
|
||||
#| Tests:
|
||||
(define e (datum->syntax-object #f 'e))
|
||||
(printf "~s~n" (eq? 'set-e! (syntax-e (prefix-id-suffix "set-" e "!"))))
|
||||
(printf "~s~n" (eq? 'e? (syntax-e (add? e))))
|
||||
(printf "~s~n" (eq? 'Hello (syntax-e (cap-id (datum->syntax-object #f 'hello)))))
|
||||
|#
|
||||
|
||||
)
|
||||
|
|
@ -1,385 +0,0 @@
|
|||
(module class mzscheme
|
||||
(require "data-defs.scm"
|
||||
mzlib/contract
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
srfi/13/string
|
||||
(only srfi/1 zip))
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
(provide/contract
|
||||
[make-class ((Class) (boolean? boolean? string? Fields (listof Method)) . opt-> . string?)]
|
||||
[method (Method . -> . string?)]
|
||||
)
|
||||
|
||||
#| Usage:
|
||||
(make-class a-class toString? template? language? Fields Methods)
|
||||
create a Java class from the class specification (a-class) and add
|
||||
Fields from super and Methods from the implementing interface.
|
||||
|
||||
The first optional boolean parameter specifies whether we want toString
|
||||
in the class hiearchy. Default: true
|
||||
|
||||
The second optional boolean parameter specifies whether we want
|
||||
a draft method template in comments. Default: true
|
||||
|
||||
The third optinal determines the language level.
|
||||
|#
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
;; Construct individual Java classes
|
||||
|
||||
;; create class definition (as string) from name, super and list of fields
|
||||
(define make-class
|
||||
(opt-lambda (the-class [toString? #t][template? #t][language BEGINNER][super-fields '()][method-sigs '()])
|
||||
(define no-public (or (eq? language BEGINNER) (or (eq? language INTERMEDIATE))))
|
||||
(let ([type (car the-class)]
|
||||
[super (cadr the-class)]
|
||||
[fields (caddr the-class)]
|
||||
[prps (class-purpose the-class)])
|
||||
(define templates
|
||||
(if (or (not template?) (eq? language BEGINNER))
|
||||
""
|
||||
(enumerate-with-separator
|
||||
(map (lambda (ms)
|
||||
(apply string-append (make-template ms super fields template? (not no-public))))
|
||||
method-sigs)
|
||||
"\n")))
|
||||
(apply string-append
|
||||
`( ,@(purpose-statement prps)
|
||||
,(format classf type (implements super))
|
||||
;; fields
|
||||
,@(map (lambda (f) (format declaf (car f) (cadr f))) fields)
|
||||
"\n"
|
||||
;; constructor
|
||||
,(class-constructor type fields super-fields)
|
||||
;; optional template draft:
|
||||
,templates
|
||||
;; optional toString method:
|
||||
,@(toString type fields no-public toString?)
|
||||
,endclf)))))
|
||||
|
||||
;; String -> String
|
||||
(define (implements super) (if (string=? "" super) "" (format implementsf super)))
|
||||
|
||||
;; String Fields Fields -> String
|
||||
(define (class-constructor type fields super-fields)
|
||||
(apply string-append
|
||||
`( ,(format constf type (parameters (append super-fields fields)))
|
||||
#| When we switch to super in beginner, this will need to change.
|
||||
;; call to super(super-fields)
|
||||
,@(if (null? super-fields) '()
|
||||
(list (format superf (commas (map cadr super-fields)))))
|
||||
|#
|
||||
;; init for fields
|
||||
,@(map (lambda (f) (format initif (cadr f) (cadr f)))
|
||||
;; When we switch to super in beginner, ...
|
||||
(append super-fields fields))
|
||||
,endMet)))
|
||||
|
||||
|
||||
;; Fields -> String
|
||||
;; create a paremeter list from a field specifications
|
||||
(define (parameters fs)
|
||||
(enumerate-with-separator
|
||||
(map (lambda (f) (format paraf (car f) (cadr f))) fs)))
|
||||
|
||||
;; String String Fields Boolean -> (listof String)
|
||||
(define (make-template sig super fields template? public?)
|
||||
(define head (format contef (method sig)))
|
||||
(if (not template?)
|
||||
(list "")
|
||||
`("\n"
|
||||
;; template method
|
||||
,cmnt/*
|
||||
,warnin
|
||||
,(if public? (string-append " public " (string-trim head)) head)
|
||||
,@(map (lambda (f) (if (string=? (car f) super)
|
||||
(format temprf (cadr f) (cadr sig))
|
||||
(format tempsf (cadr f))))
|
||||
fields)
|
||||
,endMet
|
||||
,cmnt*/)))
|
||||
|
||||
;; Method -> String
|
||||
(define (method m)
|
||||
(define m+n (zip (cddr m) PARAS))
|
||||
(define sig (map (lambda (x) (format "~a ~a" (car x) (cadr x))) m+n))
|
||||
(format intff (car m) (cadr m) (enumerate-with-separator sig ",")))
|
||||
|
||||
(define PARAS '("x" "y" "z" "u" "v" "w" "s" "t"))
|
||||
|
||||
;; String Fields -> (cons String (listof String))
|
||||
;; create a toString method for class type with _fields_
|
||||
(define toString
|
||||
(opt-lambda (type fields [special? #f][toString? #t])
|
||||
(if (not toString?)
|
||||
(list "")
|
||||
(list "\n"
|
||||
(string-append
|
||||
(if special? toStrf pbStrf)
|
||||
(format prefix type)
|
||||
; (apply string-append)
|
||||
(if (null? fields)
|
||||
" + "
|
||||
(format
|
||||
" + ~a + " (enumerate-with-separator (map addToString fields) infix)))
|
||||
postfix
|
||||
endMet)))))
|
||||
|
||||
;(provide toString)
|
||||
|
||||
;; Field -> String
|
||||
;; create a call to toString, if necessary
|
||||
(define (addToString f)
|
||||
(let ([t (car f)] [s (cadr f)])
|
||||
(if (member t StringNative) s (format "~a.toString()" s))))
|
||||
|
||||
|
||||
;; String -> (list String)
|
||||
(provide/contract
|
||||
[purpose-statement (-> string? (listof string?))])
|
||||
|
||||
(define (purpose-statement prps)
|
||||
(if (string=? "" prps) '("") (list (format "// ~a~n" prps))))
|
||||
|
||||
;; identifiers ending in f are format strings, and require ~n for newline
|
||||
|
||||
;; Abstract Template
|
||||
(define purpos " // purpose statement \n")
|
||||
;; Class
|
||||
(define classf "class ~a ~a{~n") (define implementsf "implements ~a ")
|
||||
;; Fields
|
||||
(define declaf " ~a ~a;~n")
|
||||
;; Constructor
|
||||
(define constf " ~a(~a) {~n") (define paraf "~a ~a")
|
||||
(define superf " super(~a);~n")
|
||||
(define initif " this.~a = ~a;~n")
|
||||
(define endMet " }\n")
|
||||
|
||||
(provide endclf cmnt/* cmnt*/ warnin purpos)
|
||||
(define endclf "}\n")
|
||||
;; Concrete Template
|
||||
(define warnin " // ** DRAFT TEMPLATE ** Edit as needed.\n")
|
||||
(define intff "~a ~a(~a)")
|
||||
(define contef " ~a {\n")
|
||||
(define tempsf " ... this.~a ...\n")
|
||||
(define temprf " ... this.~a.~a(...) ...\n")
|
||||
;; toString
|
||||
(define pbStrf " public String toString() {\n")
|
||||
(define toStrf " String toString() {\n")
|
||||
(define prefix " return \"new ~a(\"")
|
||||
(define infix " + \",\" + ")
|
||||
(define postfix "\")\";\n")
|
||||
(define StringNative '("int" "boolean" "String" "double")) ;; and others
|
||||
;; Comments
|
||||
(define cmnt/* "/*\n")
|
||||
(define cmnt*/ "*/\n")
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
;; Library
|
||||
|
||||
(provide/contract
|
||||
[enumerate-with-separator (opt-> ((listof string?)) (string?) string?)])
|
||||
|
||||
;; (Listof String) -> String
|
||||
;; create a comma-separated string from a list of strings
|
||||
(define (enumerate-with-separator l . comma)
|
||||
(let ([comma (if (null? comma) ", " (car comma))])
|
||||
(if (null? l) ""
|
||||
(apply string-append (car l)
|
||||
(map (lambda (x) (string-append comma x)) (cdr l))))))
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
;; TESTS:
|
||||
|
||||
(define empty-template
|
||||
`("/*\n"
|
||||
,warnin
|
||||
" ??? mmm() {\n"
|
||||
" }\n"
|
||||
"*/\n"
|
||||
"\n"))
|
||||
|
||||
(define public-empty-template
|
||||
`("/*\n"
|
||||
,warnin
|
||||
" public ??? mmm() {\n"
|
||||
" }\n"
|
||||
"*/\n"
|
||||
"\n"))
|
||||
|
||||
#| Tests :
|
||||
(require (lib "testing.scm" "testing"))
|
||||
|
||||
(test== (enumerate-with-separator '()) "")
|
||||
(test== (enumerate-with-separator '("x" "y") ) "x, y")
|
||||
(test== (enumerate-with-separator '("x" "y") " + ") "x + y")
|
||||
|
||||
(test== (parameters '()) "")
|
||||
(test== (parameters '(("int" "x"))) "int x")
|
||||
(test== (parameters '(("int" "x") ("foo" "y"))) "int x, foo y")
|
||||
(test== (enumerate-with-separator '("x" "y") " + ") "x + y")
|
||||
(test== (enumerate-with-separator '("x" "y" "z") " + ") "x + y + z")
|
||||
|
||||
(test== (cadr (toString "foo" '()))
|
||||
(string-append
|
||||
pbStrf
|
||||
" return \"new foo(\" + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "foo" '() #t))
|
||||
(string-append
|
||||
toStrf
|
||||
" return \"new foo(\" + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "Foo" '(("Foo" "x") ("Moo" "y"))))
|
||||
(string-append
|
||||
pbStrf
|
||||
" return \"new Foo(\" + x.toString() + \",\" + y.toString() + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "Foo" '(("Foo" "x") ("Moo" "y")) #t))
|
||||
(string-append
|
||||
toStrf
|
||||
" return \"new Foo(\" + x.toString() + \",\" + y.toString() + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "Foo" '(("int" "x"))))
|
||||
(string-append
|
||||
pbStrf
|
||||
" return \"new Foo(\" + x + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "Foo" '(("Boolean" "x"))))
|
||||
(string-append
|
||||
pbStrf
|
||||
" return \"new Foo(\" + x.toString() + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (cadr (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z"))))
|
||||
(string-append
|
||||
pbStrf
|
||||
" return \"new Foo(\" + x.toString() + \",\" + y + \",\" + z.toString() + \")\";\n"
|
||||
endMet))
|
||||
|
||||
(test== (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z")) #f #f)
|
||||
(list ""))
|
||||
|
||||
(test== (class-constructor "Node" '(("int" "x")) '(("Info" "i") ("ATree" "parent")))
|
||||
(string-append
|
||||
" Node(Info i, ATree parent, int x) {\n"
|
||||
" this.i = i;\n"
|
||||
" this.parent = parent;\n"
|
||||
" this.x = x;\n"
|
||||
" }\n"
|
||||
)
|
||||
"class constructor with super fields")
|
||||
|
||||
|
||||
(test== (make-class (list "foo" "" '()) #t #t INTERMEDIATE '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`( "class foo {\n"
|
||||
"\n"
|
||||
" foo() {\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,@empty-template
|
||||
,toStrf
|
||||
" return \"new foo(\" + \")\";\n"
|
||||
" }\n"
|
||||
"}\n"))
|
||||
"class with template in INTERMEDIATE")
|
||||
|
||||
(test== (make-class (list "moo" "foo" '()) #t #t PROFESSIONAL '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`("class moo implements foo {\n"
|
||||
"\n"
|
||||
" moo() {\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,@public-empty-template
|
||||
,pbStrf
|
||||
" return \"new moo(\" + \")\";\n"
|
||||
" }\n"
|
||||
"}\n")))
|
||||
|
||||
(test== (make-class (list "moo" "foo" '(("int" "x") ("foo" "f"))) #t #t PROFESSIONAL '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`("class moo implements foo {\n"
|
||||
" int x;\n"
|
||||
" foo f;\n"
|
||||
"\n"
|
||||
" moo(int x, foo f) {\n"
|
||||
" this.x = x;\n"
|
||||
" this.f = f;\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,cmnt/*
|
||||
,warnin
|
||||
" public ??? mmm() {\n"
|
||||
" ... this.x ...\n"
|
||||
" ... this.f.mmm(...) ...\n"
|
||||
" }\n"
|
||||
,cmnt*/
|
||||
"\n"
|
||||
,pbStrf
|
||||
" return \"new moo(\" + x + \",\" + f.toString() + \")\";\n"
|
||||
" }\n"
|
||||
"}\n")))
|
||||
|
||||
(test== (make-class (list "CartPt" "" '(("int" "x") ("int" "y"))) #t #t PROFESSIONAL '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`("class CartPt {\n"
|
||||
" int x;\n"
|
||||
" int y;\n"
|
||||
"\n"
|
||||
" CartPt(int x, int y) {\n"
|
||||
" this.x = x;\n"
|
||||
" this.y = y;\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,cmnt/*
|
||||
,warnin
|
||||
" public ??? mmm() {\n"
|
||||
" ... this.x ...\n"
|
||||
" ... this.y ...\n"
|
||||
" }\n"
|
||||
,cmnt*/
|
||||
"\n"
|
||||
,pbStrf
|
||||
" return \"new CartPt(\" + x + \",\" + y + \")\";\n"
|
||||
" }\n"
|
||||
"}\n")))
|
||||
|
||||
(test== (make-class (list "foo" "" '() "hello world") #t #t PROFESSIONAL '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`( "// hello world\n"
|
||||
"class foo {\n"
|
||||
"\n"
|
||||
" foo() {\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,@public-empty-template
|
||||
,pbStrf
|
||||
" return \"new foo(\" + \")\";\n"
|
||||
" }\n"
|
||||
"}\n")))
|
||||
|
||||
(test== (make-class (list "foo" "" '() "hello world") #t #t INTERMEDIATE '() '(("???" "mmm")))
|
||||
(apply string-append
|
||||
`( "// hello world\n"
|
||||
"class foo {\n"
|
||||
"\n"
|
||||
" foo() {\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
,@empty-template
|
||||
,toStrf
|
||||
" return \"new foo(\" + \")\";\n"
|
||||
" }\n"
|
||||
"}\n")))
|
||||
|#
|
||||
)
|
||||
|
||||
|
|
@ -1,159 +0,0 @@
|
|||
#| Data Defs
|
||||
|
||||
Class = (list Name SuperClass Fields [Comment])
|
||||
;; the name of the class, the name of the supertype ("" if none), and
|
||||
;; the class's fields
|
||||
|
||||
DataType = (make-union TypeName Methods VariantClasses Comment)
|
||||
;; the name of the type and its variants
|
||||
|
||||
VariantClasses = (Listof VariantClass)
|
||||
VariantClass = (list Name Fields [Comment])
|
||||
|
||||
Name = String
|
||||
TypeName = String
|
||||
SuperClass = String
|
||||
Methods = (Listof Method)
|
||||
Method = (cons String (cons String (listof String)))
|
||||
Fields = (Listof Field)
|
||||
Field = (list String String)
|
||||
|#
|
||||
|
||||
#cs
|
||||
(module data-defs mzscheme
|
||||
|
||||
(require string-constants)
|
||||
|
||||
;; Those languages for which methods that satisfy an interface
|
||||
;; don't have to be decorated with public ---
|
||||
(define BEGINNER (string-constant profj-beginner-lang))
|
||||
(define INTERMEDIATE (string-constant profj-intermediate-lang))
|
||||
(define PROFESSIONAL (string-constant profj-full-lang))
|
||||
(define *languages* (list BEGINNER INTERMEDIATE PROFESSIONAL))
|
||||
(define Language
|
||||
(flat-named-contract "<Language>" (lambda (x) (member x *languages*))))
|
||||
|
||||
(provide BEGINNER INTERMEDIATE PROFESSIONAL Language)
|
||||
|
||||
(define-struct dt (type methods variants purpose))
|
||||
|
||||
(define (dt-fields . x) (error 'dt-fields "not implemented yet: ~a\n" x))
|
||||
(provide dt-fields)
|
||||
|
||||
;; Examples
|
||||
(define method1 '("int" "x"))
|
||||
(define method2 '("int" "y" "boolean"))
|
||||
(define method3 '("boolean" "b" "Foo" "Bar"))
|
||||
(define methods (list method1 method2 method3))
|
||||
(define vc1 (list "Leaf"))
|
||||
(define vc2 (list "Node" '(("ATree" "left") ("ATree" "right"))))
|
||||
(define datat1 (make-dt "ATree" methods (list vc1 vc2) "a tree for ints"))
|
||||
|
||||
(require "aux-contract.scm")
|
||||
(require mzlib/contract)
|
||||
|
||||
(provide
|
||||
Class ;; flat-contract
|
||||
Union ;; flat-contract
|
||||
Variant ;; flat-contract
|
||||
Fields ;; flat-contract
|
||||
Method ;; flat-contract
|
||||
java-id? ;; Any -> Boolean
|
||||
class-purpose ;; Class -> String
|
||||
variant-purpose ;; Variant -> String
|
||||
)
|
||||
|
||||
;; DataType -> String
|
||||
;; (define (union-purpose dt) (if (null? (cddr dt)) "" (caddr dt)))
|
||||
|
||||
;; Class -> String
|
||||
(define (class-purpose c) (if (null? (cdddr c)) "" (cadddr c)))
|
||||
|
||||
;; Variant -> String
|
||||
(define (variant-purpose c) (if (null? (cddr c)) "" (caddr c)))
|
||||
|
||||
;; Any -> Boolean
|
||||
;; the string isn't empty and contains no spaces
|
||||
;; I should really import this from Kathy's parser or whatever
|
||||
;; so I get qualified names and whatever right
|
||||
(define (java-id? s)
|
||||
(and (string? s) (not (string=? "" s)) (not (regexp-match "[ |\t|\n]" s))))
|
||||
|
||||
(define-as-contract "<Class>" (class c)
|
||||
(and (pair? c) (pair? (cdr c)) (pair? (cddr c))
|
||||
(or (null? (cdddr c))
|
||||
(and (pair? (cdddr c))
|
||||
(null? (cddddr c))
|
||||
(string? (cadddr c))))
|
||||
; (list? c) (= (length c) 3)
|
||||
(java-id? (car c))
|
||||
(let ([super (cadr c)])
|
||||
(or (java-id? super) (string=? super "")))
|
||||
(is-fields? (caddr c))))
|
||||
|
||||
(define-as-contract "<Methods>" (methods l)
|
||||
(and (list? l) (andmap is-method? l)))
|
||||
|
||||
(define-as-contract "<Method>" (method l)
|
||||
(and (list? l) (>= (length l) 2) (andmap java-id? l)))
|
||||
|
||||
(define-as-contract "<Fields>" (fields l)
|
||||
(and (list? l) (andmap is-field? l)))
|
||||
|
||||
(define-as-contract "<Field in Class>" (field l)
|
||||
(and (list? l) (= (length l) 2) (andmap java-id? l)))
|
||||
|
||||
(define-as-contract "<Union>" (union l) (dt? l))
|
||||
|
||||
(define (is-variants? l) (andmap is-variant? l))
|
||||
|
||||
(define-as-contract "<Variant>" (variant c)
|
||||
(and (pair? c) (pair? (cdr c))
|
||||
(or
|
||||
(null? (cddr c))
|
||||
(and
|
||||
(pair? (cddr c))
|
||||
(null? (cdddr c))
|
||||
(string? (caddr c)))
|
||||
; (list? c) (= (length c) 2)
|
||||
(java-id? (car c))
|
||||
(is-fields? (cadr c)))))
|
||||
|
||||
(provide/contract
|
||||
(struct dt ((type java-id?)
|
||||
(methods (listof is-method?))
|
||||
(variants (listof is-variant?))
|
||||
(purpose string?))))
|
||||
|
||||
|
||||
#| Tests:
|
||||
(require (lib "testing.scm" "testing"))
|
||||
|
||||
(test== (java-id? "oops no") #f)
|
||||
(test== (java-id? " oops 2") #f)
|
||||
(test== (java-id? " oops2 ") #f)
|
||||
(test== (java-id? "") #f)
|
||||
(test== (java-id? (string #\tab)) #f)
|
||||
(test== (java-id? (string #\newline)) #f)
|
||||
|
||||
(test== (is-class? '("Foo" "" ())) #t)
|
||||
(test== (is-class? '("Foo" "" () "hello world")) #t)
|
||||
(test== (is-class? '("Foo" "Moo" (("int" "x") ("int" "y")) "hello world")) #t)
|
||||
|
||||
(test== (is-class? '("Foo" "Moo")) #f "no fields")
|
||||
(test== (is-class? '("Foo" "Moo Oops" ())) #f "space in super name")
|
||||
|
||||
(test== (class-purpose '("a" "b" ())) "")
|
||||
(test== (class-purpose '("a" "b" () "hello world")) "hello world")
|
||||
|
||||
(test== (is-variant? (list "B" '())) #t "variant class")
|
||||
(test== (andmap is-variant? (list (list "B" '()) (list "C" '()))) #t "variants")
|
||||
(test== (java-id? "A") #t)
|
||||
(test== (is-union? (make-dt "A" '() (list (list "B" '()) (list "C" '())) "")) #t)
|
||||
|
||||
(test== (is-method? method1) #t)
|
||||
(test== (is-method? method2) #t)
|
||||
(test== (is-method? method3) #t)
|
||||
(test== (is-methods? methods) #t)
|
||||
|#
|
||||
)
|
||||
|
|
@ -1,129 +0,0 @@
|
|||
#| Data Defs
|
||||
|
||||
Class = (list Name SuperClass Fields [Comment])
|
||||
;; the name of the class, the name of the supertype ("" if none), and
|
||||
;; the class's fields
|
||||
|
||||
DataType = (list TypeName VariantClasses [Comment])
|
||||
;; the name of the type and its variants
|
||||
|
||||
VariantClasses = (Listof VariantClass)
|
||||
VariantClass = (list Name Fields [Comment])
|
||||
|
||||
Name = String
|
||||
TypeName = String
|
||||
SuperClass = String
|
||||
Fields = (Listof Field)
|
||||
Field = (list String String)
|
||||
|#
|
||||
|
||||
#cs
|
||||
(module data-defs mzscheme
|
||||
|
||||
;; Examples
|
||||
(define field1 '("int" "x"))
|
||||
(define field2 '("int" "y"))
|
||||
(define field3 '("boolean" "b"))
|
||||
(define fields (list field1 field2 field3))
|
||||
(define vc1 (list "Leaf" (list field1)))
|
||||
(define vc2 (list "Node" '(("ATree" "left") ("ATree" "right"))))
|
||||
(define datat1 (list "ATree" (list vc1 vc2) "a tree for ints"))
|
||||
|
||||
|
||||
(require "aux-contract.scm")
|
||||
(require mzlib/contract)
|
||||
|
||||
(provide
|
||||
Class ;; flat-contract
|
||||
Union ;; flat-contract
|
||||
Variant ;; flat-contract
|
||||
java-id? ;; Any -> Boolean
|
||||
class-purpose ;; Class -> String
|
||||
union-purpose ;; Union -> String
|
||||
variant-purpose ;; Variant -> String
|
||||
)
|
||||
|
||||
;; DataType -> String
|
||||
(define (union-purpose dt) (if (null? (cddr dt)) "" (caddr dt)))
|
||||
|
||||
;; Class -> String
|
||||
(define (class-purpose c) (if (null? (cdddr c)) "" (cadddr c)))
|
||||
|
||||
;; Variant -> String
|
||||
(define (variant-purpose c) (if (null? (cddr c)) "" (caddr c)))
|
||||
|
||||
;; Any -> Boolean
|
||||
;; the string isn't empty and contains no spaces
|
||||
;; I should really import this from Kathy's parser or whatever
|
||||
;; so I get qualified names and whatever right
|
||||
(define (java-id? s)
|
||||
(and (string? s) (not (string=? "" s)) (not (regexp-match "[ |\t|\n]" s))))
|
||||
|
||||
(define-as-contract "<Class representation>" (class c)
|
||||
(and (pair? c) (pair? (cdr c)) (pair? (cddr c))
|
||||
(or (null? (cdddr c))
|
||||
(and (pair? (cdddr c))
|
||||
(null? (cddddr c))
|
||||
(string? (cadddr c))))
|
||||
; (list? c) (= (length c) 3)
|
||||
(java-id? (car c))
|
||||
(let ([super (cadr c)])
|
||||
(or (java-id? super) (string=? super "")))
|
||||
(is-fields? (caddr c))))
|
||||
|
||||
(define (is-fields? l)
|
||||
(and (list? l) (andmap is-field? l)))
|
||||
|
||||
(define (is-field? l)
|
||||
(and (pair? l) (pair? (cdr l)) (null? (cddr l))
|
||||
(java-id? (car l)) (java-id? (cadr l))))
|
||||
|
||||
(define-as-contract "<Union (datatype) representation>" (union l)
|
||||
(and (pair? l) (pair? (cdr l))
|
||||
(or (null? (cddr l))
|
||||
(and (pair? (cddr l))
|
||||
(null? (cdddr l))
|
||||
(string? (caddr l))))
|
||||
(java-id? (car l))
|
||||
(andmap is-variant? (cadr l))))
|
||||
|
||||
(define-as-contract "<Variant (in a union)>" (variant c)
|
||||
(and (pair? c) (pair? (cdr c))
|
||||
(or
|
||||
(null? (cddr c))
|
||||
(and
|
||||
(pair? (cddr c))
|
||||
(null? (cdddr c))
|
||||
(string? (caddr c)))
|
||||
; (list? c) (= (length c) 2)
|
||||
(java-id? (car c))
|
||||
(is-fields? (cadr c)))))
|
||||
|
||||
|
||||
|
||||
#| Tests:
|
||||
(require (lib "testing.scm" "testing"))
|
||||
|
||||
(test== (java-id? "oops no") #f)
|
||||
(test== (java-id? " oops 2") #f)
|
||||
(test== (java-id? " oops2 ") #f)
|
||||
(test== (java-id? "") #f)
|
||||
(test== (java-id? (string #\tab)) #f)
|
||||
(test== (java-id? (string #\newline)) #f)
|
||||
|
||||
(test== (is-class? '("Foo" "" ())) #t)
|
||||
(test== (is-class? '("Foo" "" () "hello world")) #t)
|
||||
(test== (is-class? '("Foo" "Moo" (("int" "x") ("int" "y")) "hello world")) #t)
|
||||
|
||||
(test== (is-class? '("Foo" "Moo")) #f "no fields")
|
||||
(test== (is-class? '("Foo" "Moo Oops" ())) #f "space in super name")
|
||||
|
||||
(test== (class-purpose '("a" "b" ())) "")
|
||||
(test== (class-purpose '("a" "b" () "hello world")) "hello world")
|
||||
|
||||
(test== (is-variant? (list "B" '())) #t "variant class")
|
||||
(test== (andmap is-variant? (list (list "B" '()) (list "C" '()))) #t "variants")
|
||||
(test== (java-id? "A") #t)
|
||||
(test== (is-union? (list "A" (list (list "B" '()) (list "C" '())))) #t)
|
||||
|#
|
||||
)
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
TODO:
|
||||
|
||||
- purpose statement for each interface method
|
||||
|
||||
- one day, not now: blank out error messages somehow on the next event
|
||||
- one day, not now: a common abstract class
|
||||
;; 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)))))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
adapted wizard to interfaces (from abstract classes)
|
||||
unions are interfaces plus implementing classes
|
||||
signatures of common methods
|
||||
|
||||
| construction attributes --- presentation only
|
||||
|
|
||||
Languages | template toString diagram
|
||||
------------------------------------------------------------------
|
||||
BEGINNER | -- -- okay
|
||||
INTERMEDIATE | no "public" no "public" okay
|
||||
PROFESSIONAL | okay okay okay
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
view0:
|
||||
design interfaces by hand
|
||||
abstract into functions
|
||||
abstract common pieces via multiple values
|
||||
|
||||
view:
|
||||
replace the multiple values abstraction with classes
|
||||
|
||||
data-def0
|
||||
everything is a list
|
||||
|
||||
data-def
|
||||
unions (dt) becomes a struct so that I could add common fields
|
||||
|
||||
draw-txt0
|
||||
explorative prototype
|
||||
|
|
@ -1,466 +0,0 @@
|
|||
#cs
|
||||
(module draw-txt mzscheme
|
||||
(require "data-defs.scm"
|
||||
"class.scm"
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
mzlib/contract)
|
||||
|
||||
(provide/contract
|
||||
[dt-draw (Union . -> . string?)]
|
||||
[class-draw ((Class) (listof Method) . opt-> . string?)])
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Deal with a Union of classes
|
||||
|
||||
;; DataType -> String
|
||||
(define (dt-draw dt)
|
||||
(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))))
|
||||
|
||||
;; (Listof String) -> (Listof String)
|
||||
;; add
|
||||
;;
|
||||
;; --+ // on second line
|
||||
;; |
|
||||
;; --+ // on last line
|
||||
;; to los
|
||||
(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))))))
|
||||
|
||||
;; 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 (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
|
||||
(define (add-<-- x0)
|
||||
(list->string
|
||||
(reverse
|
||||
(let loop ([x (reverse (string->list x0))])
|
||||
(cond
|
||||
[(char=? (cadr x) #\|) (cons #\< (cdr x))]
|
||||
[else (cons #\- (loop (cdr x)))])))))
|
||||
|
||||
;; VariantClasses Super -> (Listof String)
|
||||
;; for testing and printing only
|
||||
(define (variants*-draw variants spr methods)
|
||||
(let-values ([(s b) (variants*-to-strings variants spr methods)])
|
||||
(flatten-string-matrix s)))
|
||||
|
||||
;; 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 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 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)
|
||||
(define-values (s b) (variant-to-strings class super left-connected depth))
|
||||
(strings->string-as-lines s))
|
||||
|
||||
;; 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 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)]
|
||||
[types (map first fields)]
|
||||
[recursion #f]
|
||||
[CON "-+"]
|
||||
[CN2 " +"]
|
||||
[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)))]
|
||||
[width (string-length (car cs))]
|
||||
[mkln (lambda (lft ch str)
|
||||
(string-append lft (make-string width ch) str))])
|
||||
(values
|
||||
(append
|
||||
(list (string-append BLK (centered "|" width) BLK))
|
||||
(map (lambda (line type)
|
||||
(string-append BLK
|
||||
line
|
||||
(cond
|
||||
[(string=? type super) (set! recursion #t) CON]
|
||||
[recursion LIN]
|
||||
[else BLK])))
|
||||
cs
|
||||
;; pad types with junk lines for class header and class bottom
|
||||
(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
|
||||
(if left-connected
|
||||
(mkln STG #\- (if recursion CON STG))
|
||||
(mkln BLK #\space (if recursion CN2 BLK)))))
|
||||
recursion)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Deal with a single class
|
||||
|
||||
;; Class [(listof Method)] opt-> String
|
||||
(define (class-draw class . ms)
|
||||
(strings->string-as-lines (apply class-to-strings class ms)))
|
||||
|
||||
;; 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 . ms)
|
||||
(let* ([name (first class)]
|
||||
[super (second class)]
|
||||
[fields (third class)]
|
||||
[types (map first fields)]
|
||||
[names (map second fields)]
|
||||
;; start drawing
|
||||
[fields (create-field-declarations 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
|
||||
,@(if (null? methds) '() (map (make-line width) methds))
|
||||
,@(if (null? methds) '() (list separat)))))
|
||||
|
||||
;; (Listof Field) -> (Listof String)
|
||||
;; create text lines from Fields
|
||||
(define (create-field-declarations fields)
|
||||
(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)
|
||||
(string-append
|
||||
LFT+
|
||||
(make-string (- width (string-length LFT+) (string-length RGT+)) #\-)
|
||||
RGT+))
|
||||
|
||||
;; Number -> (String -> String)
|
||||
;; make one line in class of width from txt
|
||||
(define (make-line width)
|
||||
(lambda (txt)
|
||||
(string-append
|
||||
LEFT
|
||||
txt
|
||||
(make-string
|
||||
(- width (string-length txt) (string-length LEFT) (string-length RIGHT))
|
||||
#\space)
|
||||
RIGHT)))
|
||||
|
||||
;; String (Cons String (Listof String)) -> Number
|
||||
;; compute width of class as the widest field/name
|
||||
(define (width-class name fields)
|
||||
(+ (string-length LEFT)
|
||||
;; longest field spec of name/class and fields
|
||||
(apply max (map string-length (cons name fields)))
|
||||
(string-length RIGHT)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Library
|
||||
|
||||
;; (Listof String) -> String
|
||||
;; turn the list of strings into a single string, separating lines with newline
|
||||
(define (strings->string-as-lines s)
|
||||
(apply string-append (map (lambda (x) (string-append x "\n")) s)))
|
||||
|
||||
|
||||
;; (Listof (Listof String)) -> (Listof String)
|
||||
;; contract: (apply = (map length smatrix))
|
||||
;; this requires Pretty Big, it could be written in Intermediate
|
||||
(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)
|
||||
(let* ([len-str (string-length str)]
|
||||
[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
|
||||
|
||||
(define LEFT "| ")
|
||||
(define LFT+ "+-")
|
||||
(define RIGHT " |")
|
||||
(define RGT+ "-+") ; (= (string-length RIGHT) (string-length RGT+))
|
||||
; (define HOOK " |-o") ; (= (string-length RIGHT) (string-length HOOK))
|
||||
|
||||
|
||||
#|Tests:
|
||||
(require (lib "testing/testing.scm"))
|
||||
|
||||
(test== (centered "|" 2) "| ")
|
||||
(test== (centered "|" 3) " | ")
|
||||
|
||||
"testing classes"
|
||||
(define class1 (list "Class" "Super" '(("int" "capacity") ("hello" "world"))))
|
||||
(define class2 (list "Class" "Super" '()))
|
||||
|
||||
(define expected-class
|
||||
(list
|
||||
"+--------------+"
|
||||
"| Class |"
|
||||
"+--------------+"
|
||||
"| int capacity |"
|
||||
"| hello world |"
|
||||
"+--------------+"))
|
||||
|
||||
(define expected-class2
|
||||
(list
|
||||
"+-------+"
|
||||
"| Class |"
|
||||
"+-------+"
|
||||
"+-------+"))
|
||||
|
||||
(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))
|
||||
|
||||
"testing variants"
|
||||
(define vclass1 (list "Variant1" '()))
|
||||
(define vclass2 (list "Variant2" '(("int" "x") ("boolean" "y") ("Super" "z"))))
|
||||
(define vclass3 (list "Variant3" '(("String" "x") ("Super" "y") ("Super" "z"))))
|
||||
|
||||
(define expected-variant1
|
||||
(list
|
||||
" | "
|
||||
" +----------+ "
|
||||
" | Variant1 | "
|
||||
" +----------+ "
|
||||
" +----------+ "
|
||||
" "
|
||||
" "
|
||||
" "
|
||||
" "
|
||||
" "))
|
||||
|
||||
(define expected-variant2
|
||||
(list
|
||||
" | "
|
||||
" +-----------+ "
|
||||
" | Variant2 | "
|
||||
" +-----------+ "
|
||||
" | int x | "
|
||||
" | boolean y | "
|
||||
" | Super z |-+"
|
||||
" +-----------+ |"
|
||||
" |"
|
||||
" +"))
|
||||
|
||||
(define expected-variant3
|
||||
(list
|
||||
" | "
|
||||
" +----------+ "
|
||||
" | Variant3 | "
|
||||
" +----------+ "
|
||||
" | String x | "
|
||||
" | Super y |-+"
|
||||
" | Super z |-+"
|
||||
" +----------+ |"
|
||||
" |"
|
||||
"---------------+"))
|
||||
|
||||
(test== (let-values ([(s b) (variant-to-strings vclass1 "Super" #f 3 '())]) s)
|
||||
expected-variant1)
|
||||
#;(test== (variant-draw vclass1 "Super" #f 3)
|
||||
(strings->string-as-lines expected-variant1))
|
||||
#;(test== (variant-draw vclass2 "Super" #f 3)
|
||||
(strings->string-as-lines expected-variant2))
|
||||
#;(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" '())])
|
||||
s)
|
||||
(list expected-variant1 expected-variant2 expected-variant3))
|
||||
|
||||
(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== (type-to-string "Super" '() 19 #t)
|
||||
aclass-exp)
|
||||
|
||||
(test== (dt-draw
|
||||
(make-dt "Class"
|
||||
'()
|
||||
'()
|
||||
""))
|
||||
(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 |-+ |"
|
||||
" +-----------+ | +----------+ | |"
|
||||
" | | |"
|
||||
" +---------------+--+"
|
||||
)))
|
||||
|
||||
|
||||
(string-delta (dt-draw
|
||||
(make-dt "Super"
|
||||
'(("int" "x"))
|
||||
'(("VC1" (("int" "x")))
|
||||
("VC2" (("boolean" "b") ("int" "y")))
|
||||
("VC3" (("String" "s"))))
|
||||
""))
|
||||
(strings->string-as-lines
|
||||
'(
|
||||
" +---------+ "
|
||||
" | Super | "
|
||||
" +---------+ "
|
||||
" +---------+ "
|
||||
" | int x() | "
|
||||
" +---------+ "
|
||||
" | "
|
||||
" / \\ "
|
||||
" --- "
|
||||
" | "
|
||||
" -------------------------------- "
|
||||
" | | | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | VC1 | | VC2 | | VC3 | "
|
||||
" +-------+ +-----------+ +----------+ "
|
||||
" | int x | | boolean b | | String s | "
|
||||
" +-------+ | int y | +----------+ "
|
||||
" +-----------+ "
|
||||
" "
|
||||
" "
|
||||
)))
|
||||
|
||||
|
||||
|#
|
||||
)
|
||||
|
|
@ -1,333 +0,0 @@
|
|||
#| Class Representation:
|
||||
|
||||
Class = (list String (Listof Field))
|
||||
Field = (list String String)
|
||||
|
||||
|#
|
||||
(module draw-txt mzscheme
|
||||
(require mzlib/etc
|
||||
mzlib/list)
|
||||
|
||||
;; Class (Listof Classes) -> (Listof String)
|
||||
(define (class-union-to-strings utype variants)
|
||||
(let* ([ac (class-to-strings utype)]
|
||||
[classes (classes-to-strings variants (car utype))]
|
||||
[v (flatten-string-matrix classes)]
|
||||
[Lv (string-length (first v))]
|
||||
[the-core
|
||||
(append
|
||||
(center-picture Lv ac)
|
||||
(center-picture Lv REFINEMENT-ARROW)
|
||||
(center-picture Lv (refinement-connectors classes))
|
||||
v)]
|
||||
[foo 0])
|
||||
(map (lambda (x)
|
||||
(set! foo (+ foo 1))
|
||||
(cond
|
||||
[(> foo 2) (string-append x "|")]
|
||||
[(= foo 1) x]
|
||||
[(= foo 2) (replace-end-with-back-arrow x)]))
|
||||
the-core)))
|
||||
|
||||
;; String -> String
|
||||
;; add the containment arrow to an abstract class from the right fringe
|
||||
(define (replace-end-with-back-arrow x0)
|
||||
(list->string
|
||||
(reverse!
|
||||
(cons #\+
|
||||
(let loop ([x (reverse (string->list x0))])
|
||||
(cond
|
||||
[(char=? (cadr x) #\|) (cons #\< (cdr x))]
|
||||
[else (cons #\- (loop (cdr x)))]))))))
|
||||
|
||||
;; (Listof String) -> (Listof String)
|
||||
(define (refinement-connectors class-pictures)
|
||||
(let ([center-char
|
||||
(lambda (line c l r)
|
||||
(car (center-picture (string-length line) (list c) l r)))])
|
||||
(list
|
||||
(string-append
|
||||
(center-char (caar class-pictures) "+" #\space #\-)
|
||||
(let loop ([cp (rest class-pictures)])
|
||||
(cond
|
||||
[(null? (rest cp))
|
||||
(center-char (caar cp) "+" #\- #\space)]
|
||||
[else (string-append (center-char (caar cp) "+" #\- #\-)
|
||||
(loop (rest cp)))])))
|
||||
(foldr (lambda (f r)
|
||||
(string-append (car (center-picture (string-length (car f)) (list "|"))) r))
|
||||
""
|
||||
class-pictures)
|
||||
)))
|
||||
|
||||
;; Number (Listof String) -> (Listof String)
|
||||
(define center-picture
|
||||
(opt-lambda (Lv ac (l #\space)[r #\space])
|
||||
(let* ([delta (- Lv (string-length (first ac)))]
|
||||
[lft (quotient delta 2)])
|
||||
(map (pad-lines (make-string lft l) (make-string (- delta lft) r)) ac))))
|
||||
|
||||
(define REFINEMENT-ARROW
|
||||
(list "/ \\"
|
||||
"---"
|
||||
" | "))
|
||||
|
||||
;; Class String *-> String
|
||||
(define (classes-draw classes . super)
|
||||
(strings->string-as-lines (apply classes-to-strings classes super)))
|
||||
|
||||
;; Class -> String
|
||||
(define (class-draw class)
|
||||
(strings->string-as-lines (class-to-strings class)))
|
||||
|
||||
;; (Listof Class) String *-> (Listof (Listof String))
|
||||
;; take a list of classes and produce a single "line" (listof string-lines)
|
||||
(define (classes-to-strings classes0 . super)
|
||||
(let* (;; (Listof (Listof String))
|
||||
[classes (map (lambda (c) (apply class-to-strings c super)) classes0)]
|
||||
[L (apply max (map length classes))]
|
||||
[FOO " "]
|
||||
[classes (foldr (lambda (class-los is-self-recursive rest)
|
||||
(if (null? super)
|
||||
(map (pad-lines FOO FOO)
|
||||
(if (>= (length class-los) L)
|
||||
class-los
|
||||
(pad-class-with-blank-lines L class-los)))
|
||||
(cons
|
||||
(append
|
||||
(map (pad-lines FOO FOO)
|
||||
(if (>= (length class-los) L)
|
||||
class-los
|
||||
(pad-class-with-blank-lines L class-los)))
|
||||
(list
|
||||
(case is-self-recursive
|
||||
[(long)
|
||||
(string-append
|
||||
"--"
|
||||
(make-string (string-length (first class-los)) #\-)
|
||||
CROSS
|
||||
(if (null? rest) "--" ""))]
|
||||
[(short)
|
||||
(string-append
|
||||
" "
|
||||
(make-string (string-length (first class-los)) #\space)
|
||||
CROSS
|
||||
(if (null? rest) "--" ""))]
|
||||
[(conn)
|
||||
(string-append
|
||||
"--"
|
||||
(make-string (string-length (first class-los)) #\-)
|
||||
NOCROSS
|
||||
(if (null? rest) "--" ""))
|
||||
]
|
||||
[(none)
|
||||
(string-append
|
||||
" "
|
||||
(make-string (string-length (first class-los)) #\space)
|
||||
FOO)])))
|
||||
rest)))
|
||||
'()
|
||||
classes
|
||||
(let loop ([c classes0][prior #f])
|
||||
(cond
|
||||
[(null? c) '()]
|
||||
[else (let ([self-recursive (apply is-recursive? (car c) super)])
|
||||
(cond
|
||||
[(and self-recursive prior) (cons 'long (loop (cdr c) #t))]
|
||||
[self-recursive (cons 'short (loop (cdr c) #t))]
|
||||
[prior (cons 'conn (loop (cdr c) #t))]
|
||||
[else (cons 'none (loop (cdr c) #f))]))])))])
|
||||
classes))
|
||||
|
||||
|
||||
|
||||
(define is-recursive?
|
||||
(case-lambda
|
||||
[(class) #f]
|
||||
[(class super)
|
||||
(let* ([name (first class)]
|
||||
[fields (second class)]
|
||||
[types (map first fields)])
|
||||
(member super types))]))
|
||||
|
||||
|
||||
(define CROSS "-+-")
|
||||
(define NOCROSS "---")
|
||||
|
||||
;; Number (Cons String (Listof String)) -> (Listof String)
|
||||
(define (pad-class-with-blank-lines n l)
|
||||
(let ([blanks (make-string (string-length (first l)) #\space)])
|
||||
(append l (build-list (- n (length l)) (lambda (i) blanks)))))
|
||||
|
||||
;; Class String *-> (Listof String)
|
||||
;; the presence of super suggests that we want to draw a line to super
|
||||
(define (class-to-strings class . super)
|
||||
(let* ([is-super? (if (null? super)
|
||||
(lambda (x) false)
|
||||
(lambda (x) (string=? (car super) x)))]
|
||||
[name (first class)]
|
||||
[fields (second class)]
|
||||
[types (map first fields)]
|
||||
[names (map second fields)]
|
||||
[fields (create-field-declarations fields)]
|
||||
[width (width-class name fields)]
|
||||
[separat (make-separator-line width)]
|
||||
[separat-hasa (make-separator-line width #t)]
|
||||
[start-hasa #f])
|
||||
(cond
|
||||
[(and (cons? super) (ormap is-super? types))
|
||||
`(,separat
|
||||
,((make-line width) name)
|
||||
,separat
|
||||
,@(map (lambda (line type)
|
||||
(cond
|
||||
[(is-super? type) (set! start-hasa #t) [(make-line width HOOK) line]]
|
||||
[start-hasa [(make-line width HASA) line]]
|
||||
[else ((make-line width) line)]))
|
||||
fields types)
|
||||
,separat-hasa)]
|
||||
[else
|
||||
`(,separat
|
||||
,((make-line width) name)
|
||||
,separat
|
||||
,@(map (make-line width) fields)
|
||||
,separat)])))
|
||||
|
||||
;; (Listof Field) -> (Listof String)
|
||||
(define (create-field-declarations fields)
|
||||
(map (lambda (f) (string-append (string-append (first f) " " (second f))))
|
||||
fields))
|
||||
|
||||
;; String Boolean *-> String
|
||||
(define (make-separator-line width . hasa)
|
||||
(string-append LFT+ (make-string (- width (string-length LFT+) (string-length RGT+)) #\-)
|
||||
(if (null? hasa) RGT+ HASA+)))
|
||||
|
||||
;; Number String -> String
|
||||
;; make one line in class of width from txt
|
||||
(define (make-line width . rgt)
|
||||
(lambda (txt)
|
||||
(string-append
|
||||
LEFT
|
||||
txt
|
||||
(make-string
|
||||
(- width (string-length txt) (string-length LEFT) (string-length RIGHT))
|
||||
#\space)
|
||||
(if (null? rgt) RIGHT (car rgt)))))
|
||||
|
||||
(define LEFT " | ")
|
||||
(define LFT+ " +-")
|
||||
(define RIGHT " | ")
|
||||
(define HOOK " |-o") ; (= (string-length RIGHT) (string-length HOOK))
|
||||
(define RGT+ "-+ ") ; (= (string-length RIGHT) (string-length RGT+))
|
||||
(define HASA " | |") ; (= (string-length RIGHT) (string-length HASA))
|
||||
(define HASA+ "-+ |") ; (= (string-length RIGHT) (string-length RGT+))
|
||||
|
||||
;; String (Cons String (Listof String)) -> Number
|
||||
;; compute width of class as the widest field/name
|
||||
(define (width-class name fields)
|
||||
(+ (string-length LEFT)
|
||||
;; longest field spec of name/class and fields
|
||||
(apply max (map string-length (cons name fields)))
|
||||
(string-length RIGHT)))
|
||||
|
||||
;; String String -> (String -> String)
|
||||
;; add lft and rgt to txt
|
||||
(define (pad-lines lft rgt) (lambda (txt) (string-append lft txt rgt)))
|
||||
|
||||
;; (Listof (Listof String)) -> (Listof String)
|
||||
;; contract: (apply = (map length smatrix))
|
||||
;; this requires Pretty Big, it could be written in Intermediate
|
||||
(define (flatten-string-matrix smatrix)
|
||||
(apply map (lambda l (apply string-append l)) smatrix))
|
||||
|
||||
;; (Listof String) -> String
|
||||
;; turn the list of strings into a single string, separating lines with newline
|
||||
(define (strings->string-as-lines s)
|
||||
(apply string-append (map (lambda (x) (string-append x "\n")) s)))
|
||||
|
||||
;; Basic Tests:
|
||||
|
||||
|
||||
(equal?
|
||||
(flatten-string-matrix
|
||||
(list (list "a1" "a2" "a3") (list "b1" "b2" "b3") (list "c1" "c2" "c3")))
|
||||
(list "a1b1c1" "a2b2c2" "a3b3c3"))
|
||||
|
||||
;; Tests
|
||||
|
||||
|
||||
(define aTrain (list"Train"'(("int" "capacity") ("hello" "world"))))
|
||||
(define sTrain (list"Train"'(("int" "capacity"))))
|
||||
|
||||
(test== (width-class (car aTrain) (create-field-declarations (cadr aTrain)))
|
||||
(+ 12 (string-length LEFT) (string-length RIGHT)))
|
||||
|
||||
(test== ([make-line (+ 12 (string-length LEFT) (string-length RIGHT))] "int capacity")
|
||||
" | int capacity | ")
|
||||
|
||||
(test== (make-separator-line (+ 12 (string-length LEFT) (string-length RIGHT)))
|
||||
" +--------------+ ")
|
||||
|
||||
(define expected-class
|
||||
(list
|
||||
" +--------------+ \n"
|
||||
" | Train | \n"
|
||||
" +--------------+ \n"
|
||||
" | int capacity | \n"
|
||||
" | hello world | \n"
|
||||
" +--------------+ \n"))
|
||||
|
||||
(test== (class-draw aTrain)
|
||||
(apply string-append expected-class))
|
||||
|
||||
(test== (classes-to-strings (list sTrain aTrain))
|
||||
'((" +--------------+ "
|
||||
" | Train | "
|
||||
" +--------------+ "
|
||||
" | int capacity | "
|
||||
" +--------------+ "
|
||||
" ")
|
||||
(" +--------------+ "
|
||||
" | Train | "
|
||||
" +--------------+ "
|
||||
" | int capacity | "
|
||||
" | hello world | "
|
||||
" +--------------+ ")))
|
||||
|
||||
;; Union: ARiver = Source(Location) | Confluence(Location, ARiver, ARiver)
|
||||
(define ARiver
|
||||
(list "ARiver" '()))
|
||||
(define Source
|
||||
(list "Source" '(("Location" "loc"))))
|
||||
(define Confluence
|
||||
(list "Confluence" '(("Location" "loc") ("ARiver" "left") ("ARiver" "right"))))
|
||||
|
||||
(test== (strings->string-as-lines
|
||||
(class-union-to-strings ARiver (list Source Confluence)))
|
||||
(strings->string-as-lines
|
||||
'(" +--------+ "
|
||||
" | ARiver |<---------------------+"
|
||||
" +--------+ |"
|
||||
" +--------+ |"
|
||||
" / \\ |" ;; note escape
|
||||
" --- |"
|
||||
" | |"
|
||||
" +--------------------------+ |"
|
||||
" | | |"
|
||||
" +--------------+ +--------------+ |"
|
||||
" | Source | | Confluence | |"
|
||||
" +--------------+ +--------------+ |"
|
||||
" | Location loc | | Location loc | |"
|
||||
" +--------------+ | ARiver left |-o |"
|
||||
" | ARiver right |-o |"
|
||||
" +--------------+ | |"
|
||||
" -+----|")))
|
||||
|
||||
(test== (replace-end-with-back-arrow "| ARiver | ")
|
||||
"| ARiver |<----+"
|
||||
"replace end with back arrow")
|
||||
|
||||
(printf "~a" (strings->string-as-lines (class-union-to-strings ARiver (list Source Confluence))))
|
||||
|
||||
)
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define name "ProfessorJ Wizard")
|
||||
(define tools '(("tool.ss")))
|
||||
(define tool-names '("ProfessorJ Wizard"))
|
||||
|
||||
(define compile-omit-paths
|
||||
'("draw-txt0.ss"
|
||||
"macro-class.scm"
|
||||
"view0.scm"
|
||||
"data-defs0.scm"))
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
#cs(module macro-class mzscheme
|
||||
(require-for-syntax (file "class.scm") (file "aux-syntax.scm"))
|
||||
|
||||
(provide
|
||||
class ;; (class Name Super (Type Name) ...)
|
||||
union ;; (union Type [Class (Type Name) ...] ...)
|
||||
)
|
||||
|
||||
(define-syntax (class stx)
|
||||
(syntax-case stx ()
|
||||
[(class Name Super (FType FName) ...)
|
||||
(printf
|
||||
(make-class
|
||||
(list (identifier->string (syntax Name))
|
||||
(identifier->string (syntax Super))
|
||||
(map (lambda (x)
|
||||
(let* ([x (syntax-e x)]
|
||||
[type (identifier->string (car x))]
|
||||
[name (identifier->string (cadr x))])
|
||||
(list type name)))
|
||||
(syntax->list (syntax ((FType FName) ...)))))))
|
||||
(syntax (void))]))
|
||||
|
||||
(define-syntax (union stx)
|
||||
(syntax-case stx (withToString withTemplate)
|
||||
[(union Type [Class (FType FName) ...] ... withToString)
|
||||
(syntax 10)]
|
||||
[(union Type [Class (FType FName) ...] ...)
|
||||
(printf
|
||||
(make-union
|
||||
(list (identifier->string (syntax Type))
|
||||
(map (lambda (x)
|
||||
(let* ([x (syntax-e x)]
|
||||
[class (identifier->string (car x))]
|
||||
[fields (map (lambda (f)
|
||||
(let* ([x (syntax->list f)]
|
||||
[type (identifier->string (car x))]
|
||||
[name (identifier->string (cadr x))])
|
||||
`(,type ,name)))
|
||||
(cdr x))])
|
||||
(cons class fields)))
|
||||
(syntax->list (syntax ((Class (FType FName) ...) ...)))))))
|
||||
(syntax (void))]))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
#|
|
||||
The Java Wizard helps programmers create
|
||||
* classes
|
||||
* datatypes via classes.
|
||||
|
||||
The class wizard requests class name, superclass, and field specifications.
|
||||
From these, it generates a class, its constructor, and optionally a partial
|
||||
template for methods, a toString method, and a diagram.
|
||||
|
||||
The union wizard requests a union name and specifications for the variants.
|
||||
From these, it generates an abstract class (for the union name) and one
|
||||
variant class that extends the abstract class per variant specification.
|
||||
Again, it optionally adds templates, a toString method, and a diagram.
|
||||
|
||||
Both wizards generate their text in a language-sensitive manner. For
|
||||
Beginner and Intermediate, they omit privacy specifications.
|
||||
|
||||
The wizards are added to the Special menu and insert text at the current
|
||||
point.
|
||||
|
||||
At the moment they cannot read back code and help with natural program
|
||||
edits and transformations.
|
||||
|
||||
The two major files are:
|
||||
wizard.ss, which is the view and provides the user interaction
|
||||
class.scm, which is the model and provides the functions for turning
|
||||
a spec into a string that represents a class or a union.
|
||||
|
||||
Also, class.scm does not use the Java implementation to perform basic
|
||||
checks on the information. It just leaves this to the programmer. So, for
|
||||
example, if a programmer says a field has type "moo" and "moo" doesn't
|
||||
exist as a class, then the wizard inserts a buggy class.
|
||||
|#
|
||||
|
||||
BUGS:
|
||||
|
||||
* union:
|
||||
|
||||
** when a programmer changes the name of the Union after the variants have
|
||||
been specified, the wizard fails to change the type name in the
|
||||
variants.
|
||||
|
||||
* drawing:
|
||||
|
||||
** the Union wizard draws the method specs into the boxes for the
|
||||
classes. The book "thinks" of them as inherited.
|
||||
|
||||
view
|
||||
|
||||
FEATURES:
|
||||
|
||||
** re-enable the method template creation in view
|
||||
== the creation of method stubs depends on language level
|
||||
|
||||
** allow the introduction of an abstract class for common features in
|
||||
Unions (common fields, common methods)
|
||||
|
||||
** specification of mutually recursive features
|
||||
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
(module tool mzscheme
|
||||
(require "class.scm"
|
||||
"union.ss"
|
||||
"view.scm"
|
||||
"draw-txt.ss"
|
||||
"data-defs.scm"
|
||||
drscheme/tool
|
||||
(only drscheme/private/drsig drscheme:language-configuration^)
|
||||
framework
|
||||
mred
|
||||
mzlib/unit
|
||||
mzlib/etc
|
||||
mzlib/class
|
||||
string-constants
|
||||
mzlib/contract)
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Wire up to DrScheme
|
||||
;;
|
||||
|
||||
;; insert a Java Class
|
||||
|
||||
(define (java-class-wizard-mixin %)
|
||||
(class %
|
||||
(inherit get-insert-menu get-edit-target-object register-capability-menu-item)
|
||||
|
||||
(super-new)
|
||||
|
||||
#;
|
||||
(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))))
|
||||
|
||||
(define (tee x) x)
|
||||
|
||||
;; 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* (tee (member "ProfessorJ" current-language*))]
|
||||
[begin-> (tee (and simple* (cadr simple*)))])
|
||||
(tee
|
||||
(cond
|
||||
[begin-> begin->]
|
||||
[(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))))
|
||||
(define (enable mi)
|
||||
(send mi enable ((get-edit-target-object) . is-a? . text%)))
|
||||
(new menu-item%
|
||||
(label descr)
|
||||
(parent (get-insert-menu))
|
||||
(callback A)
|
||||
(demand-callback enable)))
|
||||
|
||||
(make-menu-item% (string-constant profjWizward-insert-java-class) get-class-info make-class class-draw)
|
||||
(register-capability-menu-item 'profjWizard:special:java-class
|
||||
(get-insert-menu))
|
||||
(make-menu-item% (string-constant profjWizard-insert-java-union) get-union-info make-union dt-draw)
|
||||
(register-capability-menu-item 'profjWizard:special:java-union
|
||||
(get-insert-menu))))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame java-class-wizard-mixin)
|
||||
(drscheme:language:register-capability 'profjWizard:special:java-class
|
||||
(flat-contract boolean?) #f)
|
||||
(drscheme:language:register-capability 'profjWizard:special:java-union
|
||||
(flat-contract boolean?) #f)
|
||||
))
|
||||
|
||||
)
|
||||
|
|
@ -1,239 +0,0 @@
|
|||
#cs
|
||||
(module union mzscheme
|
||||
(require "data-defs.scm"
|
||||
"class.scm"
|
||||
mzlib/contract
|
||||
mzlib/etc
|
||||
mzlib/list)
|
||||
|
||||
|
||||
(provide/contract
|
||||
[make-union ((Union) (boolean? boolean? string?) . opt-> . string?)]
|
||||
)
|
||||
|
||||
#| Usage:
|
||||
(make-union a-union toString? template?)
|
||||
create a Java implementation of a datatype specification using an
|
||||
interface and N variants.
|
||||
|
||||
The first optional boolean parameter specifies whether we want toString
|
||||
in the class hiearchy. Default: true
|
||||
|
||||
The second optional boolean parameter specifies whether we want
|
||||
a draft method template in comments. Default: true
|
||||
|#
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
;; Construct a union as a collection of Java classes
|
||||
|
||||
;; String (Listof VariantClass) -> String
|
||||
(define make-union
|
||||
(opt-lambda (the-union [toString? #t][template? #t][language BEGINNER])
|
||||
(define type (dt-type the-union))
|
||||
(define met* (dt-methods the-union))
|
||||
(string-append
|
||||
(car (purpose-statement (dt-purpose the-union)))
|
||||
(interface type template? met*)
|
||||
"\n"
|
||||
(enumerate-with-separator
|
||||
(map (lambda (sc)
|
||||
(make-class `(,(car sc) ,type ,(cadr sc) ,(variant-purpose sc))
|
||||
toString?
|
||||
template?
|
||||
language
|
||||
'()
|
||||
met*))
|
||||
(dt-variants the-union))
|
||||
"\n"))))
|
||||
|
||||
;; String Boolean [Listof Method] -> String
|
||||
(define (interface type template? methods)
|
||||
(apply string-append
|
||||
`(,(format abstractF type)
|
||||
;; constant fields, e.g.,
|
||||
;; int NORTH = 0;
|
||||
;; shouldn't be allowed yet
|
||||
,@(map (lambda (x) (format " ~a;\n" (method x))) methods)
|
||||
;; optional abstract template
|
||||
""
|
||||
,endclf)))
|
||||
|
||||
;; String (listof Field) Boolean? -> String
|
||||
(define (abstractClass type fields template?)
|
||||
`(...
|
||||
,@(if (not template?)
|
||||
(list "")
|
||||
`( ,cmnt/*
|
||||
,warnin
|
||||
,purpos
|
||||
,absteg
|
||||
,cmnt*/))
|
||||
...))
|
||||
|
||||
;; Abstract Class
|
||||
(define abstractF "interface ~a {\n")
|
||||
(define absteg " abstract ??? mmm();\n")
|
||||
|
||||
#| Tests:
|
||||
|
||||
(require (lib "testing/testing.scm"))
|
||||
|
||||
(test== (interface "Foo" #f '())
|
||||
(string-append
|
||||
"interface Foo {\n"
|
||||
"}\n")
|
||||
"simple interface")
|
||||
|
||||
(test== (interface "Foo" #f '(("double" "distance" "int" "int")))
|
||||
(string-append
|
||||
"interface Foo {\n"
|
||||
" double distance(int x,int y);\n"
|
||||
"}\n")
|
||||
"simple interface with methods")
|
||||
|
||||
(make-union
|
||||
(make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "")
|
||||
#f #f)
|
||||
(test==
|
||||
(make-union
|
||||
(make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "")
|
||||
#f #f)
|
||||
(apply string-append
|
||||
`(
|
||||
"interface AList {\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class MT implements AList {\n"
|
||||
"\n"
|
||||
" MT() {\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class Cons implements AList {\n"
|
||||
" int first;\n"
|
||||
" AList rest;\n"
|
||||
"\n"
|
||||
" Cons(int first, AList rest) {\n"
|
||||
" this.first = first;\n"
|
||||
" this.rest = rest;\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
)
|
||||
)
|
||||
"partial make union")
|
||||
|
||||
(test==
|
||||
(make-union
|
||||
(make-dt "AList"
|
||||
;; common methods:
|
||||
'(("???" "mmm"))
|
||||
;; variants:
|
||||
'(("MT" ())
|
||||
("Cons" (("int" "first") ("AList" "rest")))) "")
|
||||
#t #t PROFESSIONAL)
|
||||
(apply string-append
|
||||
`(
|
||||
"interface AList {\n"
|
||||
" ??? mmm();\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class MT implements AList {\n"
|
||||
"\n"
|
||||
" MT() {\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
"/*\n"
|
||||
,warnin
|
||||
" public ??? mmm() {\n"
|
||||
" }\n"
|
||||
"*/\n"
|
||||
"\n"
|
||||
" public String toString() {\n"
|
||||
" return \"new MT(\" + \")\";\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class Cons implements AList {\n"
|
||||
" int first;\n"
|
||||
" AList rest;\n"
|
||||
"\n"
|
||||
" Cons(int first, AList rest) {\n"
|
||||
" this.first = first;\n"
|
||||
" this.rest = rest;\n"
|
||||
" }\n"
|
||||
"\n"
|
||||
"/*\n"
|
||||
,warnin
|
||||
" public ??? mmm() {\n"
|
||||
" ... this.first ...\n"
|
||||
" ... this.rest.mmm(...) ...\n"
|
||||
" }\n"
|
||||
"*/\n"
|
||||
"\n"
|
||||
" public String toString() {\n"
|
||||
" return \"new Cons(\" + first + \",\" + rest.toString() + \")\";\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
)
|
||||
)
|
||||
"full make union")
|
||||
|
||||
(test==
|
||||
(make-union
|
||||
(make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "hello world")
|
||||
#f #f)
|
||||
(apply string-append
|
||||
`("// hello world\n"
|
||||
"interface AList {\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class MT implements AList {\n"
|
||||
"\n"
|
||||
" MT() {\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class Cons implements AList {\n"
|
||||
" int first;\n"
|
||||
" AList rest;\n"
|
||||
"\n"
|
||||
" Cons(int first, AList rest) {\n"
|
||||
" this.first = first;\n"
|
||||
" this.rest = rest;\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
)
|
||||
)
|
||||
"make union with purpose statement")
|
||||
|
||||
(test==
|
||||
(make-union
|
||||
(make-dt
|
||||
"AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")) "pair")) "hello world")
|
||||
#f #f)
|
||||
(apply string-append
|
||||
`("// hello world\n"
|
||||
"interface AList {\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"class MT implements AList {\n"
|
||||
"\n"
|
||||
" MT() {\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
"\n"
|
||||
"// pair\n"
|
||||
"class Cons implements AList {\n"
|
||||
" int first;\n"
|
||||
" AList rest;\n"
|
||||
"\n"
|
||||
" Cons(int first, AList rest) {\n"
|
||||
" this.first = first;\n"
|
||||
" this.rest = rest;\n"
|
||||
" }\n"
|
||||
"}\n"
|
||||
)
|
||||
)
|
||||
"make union with purpose statement for variants")
|
||||
|#
|
||||
)
|
||||
|
|
@ -1,642 +0,0 @@
|
|||
(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)))))
|
||||
|#
|
||||
)
|
||||
|
|
@ -1,402 +0,0 @@
|
|||
#cs(module wizard mzscheme
|
||||
(require mred
|
||||
mzlib/class
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
srfi/13/string
|
||||
mzlib/contract)
|
||||
|
||||
(require (file "assoc-list.scm")
|
||||
(file "data-defs.scm"))
|
||||
|
||||
(require-for-syntax (file "aux-syntax.scm"))
|
||||
|
||||
(provide/contract
|
||||
[get-class-info
|
||||
(() (string? Class) . opt-> . (union false? (list/p Class boolean? boolean?)))]
|
||||
[get-union-info
|
||||
(-> (union false? (list/p Union boolean? boolean?)))]
|
||||
)
|
||||
|
||||
;; (define/abstract <identifier>) :: <definition>
|
||||
;; introduce x as an abstract call back that raises an error
|
||||
;; and set-x as a setter that defines the function finally
|
||||
;; (mimic overriding)
|
||||
(define-syntax (define/abstract e)
|
||||
(syntax-case e ()
|
||||
[(_ x)
|
||||
(with-syntax ([set-x (prefix-id-suffix "set-" (syntax x) "")])
|
||||
(syntax
|
||||
(define-values (x set-x)
|
||||
(let ([real-x (lambda y (error 'x "not initialized yet"))])
|
||||
(values
|
||||
(lambda y (apply real-x y))
|
||||
(lambda (v) (set! real-x v)))))))]))
|
||||
|
||||
#|
|
||||
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-lambda ([a-super null][a-v-class null])
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Managing the class
|
||||
|
||||
;; (union false (list Class Boolean Boolean))
|
||||
;; should the dialog return a class representation at the end
|
||||
(define the-class #f)
|
||||
|
||||
(define fields (new assoc%))
|
||||
|
||||
;; (Listof (-> (list String String)) -> (list Class Boolean Boolean)
|
||||
;; produce a class from fields
|
||||
(define (produce-class-from-fields fields)
|
||||
(with-handlers ([spec-error? (lambda _ #f)])
|
||||
(let* ([class (string-trim-both (send class-name get-value))]
|
||||
[super (string-trim-both (send super-name get-value))]
|
||||
[field (map (lambda (th) (th)) (send fields list))]
|
||||
[field
|
||||
(foldr ;; r gives me the right order
|
||||
(lambda (x r)
|
||||
(let* ([v x] ; the privacy information isn't collecte
|
||||
; [v (cdr x)] ; cdr means skip privacy attribute
|
||||
[type (string-trim-both (car v))]
|
||||
[name (string-trim-both (cadr v))])
|
||||
(cond
|
||||
[(and (java-id? type) (java-id? name))
|
||||
(cons (list type name) r)]
|
||||
[(java-id? type)
|
||||
(error-message (format "check field name for ~a" type))]
|
||||
[(java-id? name)
|
||||
(error-message (format "check type for ~a" name))]
|
||||
[else r])))
|
||||
'()
|
||||
field)])
|
||||
(if (java-id? class)
|
||||
(list (list class super field)
|
||||
(send tostring? get-value)
|
||||
(send template? get-value))
|
||||
(error-message "check class name")))))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; the layout
|
||||
|
||||
(define-values (f p tostring? template? set-make-class set-add-field)
|
||||
(make-top "Class Wizard" "Insert Class" "Add Field"
|
||||
(lambda (x e) (set! the-class #f) (send f show #f))))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; information about the class
|
||||
|
||||
(define privacy-modifiers '("no modifier" "public" "private" "protected"))
|
||||
|
||||
;; Panel -> Choice
|
||||
(define (make-modifier-menu p)
|
||||
(new choice%
|
||||
(label "") (choices privacy-modifiers) (parent p) (callback void)))
|
||||
|
||||
|
||||
;; TextField Event -> Void
|
||||
;; a callback that on return creates a new "add field" panel when
|
||||
;; it's the bottom most text field
|
||||
(define/abstract send/create-field)
|
||||
|
||||
;; Information about the class in general:
|
||||
(define info-pane (new vertical-panel% (parent p) (style '(border))))
|
||||
(define purpose
|
||||
(new text-field%
|
||||
(parent info-pane) (label "// purpose of 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-name (make-text-field class-pane "extends" send/create-field))
|
||||
|
||||
;; Information about the class's fields:
|
||||
(define field-panel (new vertical-panel% (parent info-pane)))
|
||||
|
||||
;; (list Modifier String String) *-> Void
|
||||
;; add a field panel so that a new field for the class can be specified
|
||||
;; if rest arguments, it consists of two strings:
|
||||
;; one for the type, one for name
|
||||
(define (add-field-panel . a-field)
|
||||
(let* ([fp (add-horizontal-panel field-panel)]
|
||||
; [modi (make-modifier-menu fp)]
|
||||
[type (make-text-field fp "type:")]
|
||||
[name (make-text-field fp "name:" send/create-field)]
|
||||
[get-values (lambda ()
|
||||
(list ;(send modi get-string-selection)
|
||||
(send type get-value)
|
||||
(send name get-value)))])
|
||||
(when (pair? a-field)
|
||||
(send type set-value (car a-field))
|
||||
(send name set-value (cadr a-field)))
|
||||
(add-field-name name)
|
||||
(send fields add type get-values)
|
||||
(new button%
|
||||
(label "Delete Field") (parent fp)
|
||||
(callback
|
||||
(lambda (x e)
|
||||
(send fields remove type)
|
||||
(remove-field-name name)
|
||||
(send field-panel change-children (remove-panel fp)))))))
|
||||
|
||||
;; Managing the creation of new "add field" panels
|
||||
|
||||
;; (Listof TextField)
|
||||
;; the list of name TextFields that have been added via (add-field-panel)
|
||||
;; 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 -> Boolean
|
||||
;; what is the current last
|
||||
(define (should-create-new-add-field? x)
|
||||
(or (null? the-last-field-name) (eq? (car the-last-field-name) x)))
|
||||
|
||||
;; 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)))
|
||||
|
||||
(define _stupid_effect
|
||||
(set-send/create-field
|
||||
(lambda (x e)
|
||||
(when (eq? (send e get-event-type) 'text-field-enter)
|
||||
(when (should-create-new-add-field? x) (add-field-panel))
|
||||
(send f on-traverse-char (new key-event% (key-code #\tab)))))))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define-values (error-message spec-error?) (add-error-panel p))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; 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))
|
||||
|
||||
(cond
|
||||
[(and (null? a-super) (null? a-v-class))
|
||||
(add-field-panel)]
|
||||
[(null? a-v-class)
|
||||
(add-field-panel)
|
||||
(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)]
|
||||
[fields (cdr a-v-class)])
|
||||
(send class-name set-value name)
|
||||
(for-each (lambda (f) (apply add-field-panel f)) fields))])
|
||||
|
||||
(set-add-field (lambda (x e) (add-field-panel)))
|
||||
|
||||
(set-make-class
|
||||
(lambda (x e)
|
||||
(set! the-class (produce-class-from-fields fields))
|
||||
(when the-class (send f show #f))))
|
||||
|
||||
(send f show #t)
|
||||
|
||||
the-class
|
||||
))
|
||||
|
||||
|
||||
#| -> (union #f (list Class Boolean Boolean)
|
||||
present a modal dialog to create a union;
|
||||
if programmer aborts, return #f
|
||||
otherwise, produce a datatype and two booleans, requesting toString and draft
|
||||
templates, respectively, for the entire datatype
|
||||
|#
|
||||
(define (get-union-info)
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
;; Managing the datatype
|
||||
(define the-type #f)
|
||||
|
||||
(define variants (new assoc%))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
;; GUI Layout
|
||||
|
||||
(define-values (f p toString? template? set-make-union set-add-var)
|
||||
(make-top "Union Wizard" "Insert Union" "Add Variant"
|
||||
(lambda (x e) (set! the-type #f) (send f show #f))))
|
||||
|
||||
(define type-pane
|
||||
(new vertical-panel%
|
||||
(parent p)
|
||||
(alignment '(center center)) (style '(border))
|
||||
(min-height 50) (stretchable-height #f)))
|
||||
|
||||
(define purpose
|
||||
(new text-field%
|
||||
(parent type-pane) (label "// purpose of union: ") (callback void)))
|
||||
|
||||
(define type-text (make-text-field type-pane "Type"))
|
||||
|
||||
(define vart-pane
|
||||
(new horizontal-panel%
|
||||
(parent p) (alignment '(center center)) (style '(border))
|
||||
(min-height 150) (stretchable-height #f)))
|
||||
|
||||
(define-values (error-message spec-error?) (add-error-panel p))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
;; Accessing and Mutating GUIs
|
||||
|
||||
;; -> String
|
||||
(define (get-type)
|
||||
(let ([t (string-trim-both (send type-text get-value))])
|
||||
(if (java-id? t) t (error-message "check type name"))))
|
||||
|
||||
;; -> Void
|
||||
(define add-variant-panel
|
||||
(make-add-variant-panel vart-pane spec-error? variants get-type))
|
||||
|
||||
;; make two variants to boot
|
||||
;; allow people to add and delete a variant
|
||||
(add-variant-panel)
|
||||
(add-variant-panel)
|
||||
|
||||
(set-make-union
|
||||
(lambda (x e)
|
||||
(set! the-type
|
||||
(with-handlers ([spec-error? (lambda _ #f)])
|
||||
(list
|
||||
(list (get-type)
|
||||
(foldr (lambda (f r) (if f (cons f r) r)) '()
|
||||
(send variants list)))
|
||||
(send toString? get-value)
|
||||
(send template? get-value))))
|
||||
(send f show #f)))
|
||||
|
||||
(set-add-var (lambda (x e) (add-variant-panel)))
|
||||
|
||||
(send f show #t)
|
||||
|
||||
the-type
|
||||
)
|
||||
|
||||
|
||||
;; Pane (Any -> Boolean) Assoc -> (-> Void)
|
||||
;; create a function that adds "variant" panels to the get-union-info dialog
|
||||
(define (make-add-variant-panel vart-pane spec-error? variants get-type)
|
||||
(lambda ()
|
||||
(let* ([vp (new vertical-panel% (parent vart-pane)(style '(border)))]
|
||||
[ms (new message% (parent vp) (label "Variant"))]
|
||||
[bt (new button% (parent vp) (label "Edit")
|
||||
(callback
|
||||
(lambda (bt evt)
|
||||
(with-handlers ([spec-error? void])
|
||||
(let* ([type (get-type)]
|
||||
[class-in (send variants lookup bt)]
|
||||
[a-class (if class-in
|
||||
(get-class-info type class-in)
|
||||
(get-class-info type))])
|
||||
(when a-class
|
||||
(let* ([a-class (car a-class)]
|
||||
[name (car a-class)]
|
||||
[fields (caddr a-class)])
|
||||
;; no supertype needed: remove (cadr a-class)
|
||||
(send variants update bt (list name fields))
|
||||
(send ms set-label name))))))))])
|
||||
(send variants add bt #f)
|
||||
(new button% (parent vp) (label "Delete")
|
||||
(callback
|
||||
(lambda (x e)
|
||||
(send variants remove bt)
|
||||
(send vart-pane change-children (remove-panel vp))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; String String String CallBack
|
||||
;; ->
|
||||
;; Frame Pane CheckBox CheckBox (Callback -> Void) (Callback -> Void)
|
||||
;; set up the top of the frame
|
||||
(define (make-top title insert add quit-cb)
|
||||
(define f (new dialog% (label title) (width 500) (height 300)))
|
||||
(define p (new vertical-pane% (parent f)))
|
||||
|
||||
(define button-panel (add-horizontal-panel p))
|
||||
|
||||
(define quit (add-button button-panel "Abort" quit-cb))
|
||||
|
||||
(define/abstract make-class-cb)
|
||||
(define class-button (add-button button-panel insert make-class-cb))
|
||||
|
||||
(define/abstract add-field-cb)
|
||||
(define add-field-button (add-button button-panel add add-field-cb))
|
||||
|
||||
(define switch-pane (add-horizontal-panel p))
|
||||
(define toString-check (make-checkbox switch-pane "add toString()"))
|
||||
(define template-check (make-checkbox switch-pane "add method template"))
|
||||
|
||||
(values f p toString-check template-check set-make-class-cb set-add-field-cb))
|
||||
|
||||
;; Panel String [Callback] -> TextField
|
||||
(define make-text-field
|
||||
(opt-lambda (p l (c void))
|
||||
(new text-field%
|
||||
(parent p) (label l) (callback c)
|
||||
(min-width 50) (stretchable-width #f))))
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; Panel -> (Panels -> Panels)
|
||||
;; remove vp from cs
|
||||
(define (remove-panel vp)
|
||||
(lambda (cs) (filter (lambda (c) (not (eq? vp c))) cs)))
|
||||
|
||||
;; 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 -> Void) (Any -> Boolean)
|
||||
(define (add-error-panel p)
|
||||
(define message-size 100)
|
||||
(define spec-error (cons 1 2))
|
||||
(define message
|
||||
(new message%
|
||||
(parent (add-horizontal-panel p)) (label (make-string 100 #\space))))
|
||||
;; String -> false
|
||||
(define (error-message m)
|
||||
(send message set-label (string-append "error: "m))
|
||||
(raise spec-error))
|
||||
;; Any -> Boolean
|
||||
(define (spec-error? x) (eq? spec-error x ))
|
||||
(values error-message spec-error?))
|
||||
|
||||
|
||||
#| run: emulate the actual wizard
|
||||
(require (file "class.scm"))
|
||||
|
||||
(provide x y)
|
||||
|
||||
(define x (get-class-info))
|
||||
(if x (printf "~a~n" (apply make-class x)))
|
||||
|
||||
(define y (get-union-info))
|
||||
(if y (printf "~a~n" (apply make-union y)))
|
||||
|#
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user