From a5049e9d03c643e178af7bdc99321b8a2092b458 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 10 Sep 2009 01:26:50 +0000 Subject: [PATCH] profj is gone, profjWizard follows svn: r15949 --- collects/profjWizard/assoc-list.scm | 83 ---- collects/profjWizard/aux-class.scm | 14 - collects/profjWizard/aux-contract.scm | 23 - collects/profjWizard/aux-syntax.scm | 32 -- collects/profjWizard/class.scm | 385 --------------- collects/profjWizard/data-defs.scm | 159 ------- collects/profjWizard/data-defs0.scm | 129 ------ collects/profjWizard/design-history | 45 -- collects/profjWizard/draw-txt.ss | 466 ------------------- collects/profjWizard/draw-txt0.ss | 333 ------------- collects/profjWizard/info.ss | 11 - collects/profjWizard/macro-class.scm | 46 -- collects/profjWizard/todo | 59 --- collects/profjWizard/tool.ss | 108 ----- collects/profjWizard/union.ss | 239 ---------- collects/profjWizard/view.scm | 642 -------------------------- collects/profjWizard/view0.scm | 402 ---------------- 17 files changed, 3176 deletions(-) delete mode 100644 collects/profjWizard/assoc-list.scm delete mode 100644 collects/profjWizard/aux-class.scm delete mode 100644 collects/profjWizard/aux-contract.scm delete mode 100644 collects/profjWizard/aux-syntax.scm delete mode 100644 collects/profjWizard/class.scm delete mode 100644 collects/profjWizard/data-defs.scm delete mode 100644 collects/profjWizard/data-defs0.scm delete mode 100644 collects/profjWizard/design-history delete mode 100644 collects/profjWizard/draw-txt.ss delete mode 100644 collects/profjWizard/draw-txt0.ss delete mode 100644 collects/profjWizard/info.ss delete mode 100644 collects/profjWizard/macro-class.scm delete mode 100644 collects/profjWizard/todo delete mode 100644 collects/profjWizard/tool.ss delete mode 100644 collects/profjWizard/union.ss delete mode 100644 collects/profjWizard/view.scm delete mode 100644 collects/profjWizard/view0.scm diff --git a/collects/profjWizard/assoc-list.scm b/collects/profjWizard/assoc-list.scm deleted file mode 100644 index 860202519b..0000000000 --- a/collects/profjWizard/assoc-list.scm +++ /dev/null @@ -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) '()) - |# - - ) diff --git a/collects/profjWizard/aux-class.scm b/collects/profjWizard/aux-class.scm deleted file mode 100644 index 631e2e4866..0000000000 --- a/collects/profjWizard/aux-class.scm +++ /dev/null @@ -1,14 +0,0 @@ -(module aux-class mzscheme - (require mzlib/class) - - (provide - (all-from mzlib/class) - define/abstract ; (define/abstract ) :: - ) - - (define-syntax define/abstract - (syntax-rules () - [(define/abstract id) - (define/public id (lambda x (error 'id "abstract")))])) - - ) diff --git a/collects/profjWizard/aux-contract.scm b/collects/profjWizard/aux-contract.scm deleted file mode 100644 index 1bc52801c7..0000000000 --- a/collects/profjWizard/aux-contract.scm +++ /dev/null @@ -1,23 +0,0 @@ -(module aux-contract mzscheme - - (require-for-syntax (file "aux-syntax.scm")) - (require mzlib/contract) - - (provide - define-as-contract ;; - ) - - ;; (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)))))])) - - ) diff --git a/collects/profjWizard/aux-syntax.scm b/collects/profjWizard/aux-syntax.scm deleted file mode 100644 index c4c1bb52cc..0000000000 --- a/collects/profjWizard/aux-syntax.scm +++ /dev/null @@ -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))))) - |# - - ) diff --git a/collects/profjWizard/class.scm b/collects/profjWizard/class.scm deleted file mode 100644 index 5af0d3ccb4..0000000000 --- a/collects/profjWizard/class.scm +++ /dev/null @@ -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"))) - |# - ) - diff --git a/collects/profjWizard/data-defs.scm b/collects/profjWizard/data-defs.scm deleted file mode 100644 index cc8bfc229f..0000000000 --- a/collects/profjWizard/data-defs.scm +++ /dev/null @@ -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 "" (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 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 l) - (and (list? l) (andmap is-method? l))) - - (define-as-contract "" (method l) - (and (list? l) (>= (length l) 2) (andmap java-id? l))) - - (define-as-contract "" (fields l) - (and (list? l) (andmap is-field? l))) - - (define-as-contract "" (field l) - (and (list? l) (= (length l) 2) (andmap java-id? l))) - - (define-as-contract "" (union l) (dt? l)) - - (define (is-variants? l) (andmap is-variant? l)) - - (define-as-contract "" (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) -|# - ) diff --git a/collects/profjWizard/data-defs0.scm b/collects/profjWizard/data-defs0.scm deleted file mode 100644 index 24f5fbf068..0000000000 --- a/collects/profjWizard/data-defs0.scm +++ /dev/null @@ -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 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 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 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) - |# - ) diff --git a/collects/profjWizard/design-history b/collects/profjWizard/design-history deleted file mode 100644 index ffc19c9448..0000000000 --- a/collects/profjWizard/design-history +++ /dev/null @@ -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 diff --git a/collects/profjWizard/draw-txt.ss b/collects/profjWizard/draw-txt.ss deleted file mode 100644 index 31af507787..0000000000 --- a/collects/profjWizard/draw-txt.ss +++ /dev/null @@ -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 | +----------+ " - " +-----------+ " - " " - " " - ))) - - - |# - ) diff --git a/collects/profjWizard/draw-txt0.ss b/collects/profjWizard/draw-txt0.ss deleted file mode 100644 index ff798a87b2..0000000000 --- a/collects/profjWizard/draw-txt0.ss +++ /dev/null @@ -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)))) - - ) diff --git a/collects/profjWizard/info.ss b/collects/profjWizard/info.ss deleted file mode 100644 index 6fbc66c821..0000000000 --- a/collects/profjWizard/info.ss +++ /dev/null @@ -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")) diff --git a/collects/profjWizard/macro-class.scm b/collects/profjWizard/macro-class.scm deleted file mode 100644 index b145e31549..0000000000 --- a/collects/profjWizard/macro-class.scm +++ /dev/null @@ -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))])) - - - ) diff --git a/collects/profjWizard/todo b/collects/profjWizard/todo deleted file mode 100644 index a9426a688b..0000000000 --- a/collects/profjWizard/todo +++ /dev/null @@ -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 - diff --git a/collects/profjWizard/tool.ss b/collects/profjWizard/tool.ss deleted file mode 100644 index 875900858b..0000000000 --- a/collects/profjWizard/tool.ss +++ /dev/null @@ -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) - )) - - ) diff --git a/collects/profjWizard/union.ss b/collects/profjWizard/union.ss deleted file mode 100644 index b2691f8e16..0000000000 --- a/collects/profjWizard/union.ss +++ /dev/null @@ -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") - |# - ) diff --git a/collects/profjWizard/view.scm b/collects/profjWizard/view.scm deleted file mode 100644 index 55ac2c11fa..0000000000 --- a/collects/profjWizard/view.scm +++ /dev/null @@ -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 , 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 "") - (send name set-value "") - (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 "") - ;; --------------------------------------------------------------------- - ;; 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 "")) - (define nam (make-text-field this "" void "")) - (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))))) - |# - ) diff --git a/collects/profjWizard/view0.scm b/collects/profjWizard/view0.scm deleted file mode 100644 index bc9cf7f4db..0000000000 --- a/collects/profjWizard/view0.scm +++ /dev/null @@ -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 ) :: - ;; 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))) - |# - - )