387 lines
13 KiB
Scheme
387 lines
13 KiB
Scheme
#cs
|
|
(module class mzscheme
|
|
(require "data-defs.scm"
|
|
(lib "contract.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "string.ss" "srfi" "13")
|
|
(only (lib "1.ss" "srfi") 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")))
|
|
|#
|
|
)
|
|
|