593 lines
20 KiB
Scheme
593 lines
20 KiB
Scheme
#cs(module class mzscheme
|
|
(require (lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "contract.ss")
|
|
(file "data-defs.scm"))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
(provide/contract
|
|
[make-class ((Class) (boolean? boolean?) . opt-> . string?)]
|
|
)
|
|
|
|
#| Usage:
|
|
(make-class a-class toString? template?)
|
|
create a Java class from the class specification (a-class).
|
|
|
|
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
|
|
|#
|
|
|
|
(provide/contract
|
|
[make-union ((Union) (boolean? boolean?) . opt-> . string?)]
|
|
)
|
|
|
|
#| Usage:
|
|
(make-union a-union toString? template?)
|
|
create a Java implementation of a datatype specification using an
|
|
abstract class 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])
|
|
(let ([type (dt-type the-union)][type-fields (dt-fields the-union)])
|
|
(string-append
|
|
(car (purpose-statement (dt-purpose the-union)))
|
|
(abstractClass type type-fields template?)
|
|
"\n"
|
|
(commas
|
|
(map (lambda (sc)
|
|
(make-class
|
|
`(,(car sc) ,type ,(cadr sc) ,(variant-purpose sc))
|
|
toString?
|
|
template?
|
|
type-fields))
|
|
(dt-variants the-union))
|
|
"\n")))))
|
|
|
|
;; String -> String
|
|
(define (abstractClass type type-fields template?)
|
|
(apply string-append
|
|
`(,(format abstractF type)
|
|
;; fields
|
|
,@(map (lambda (f) (format declaf (car f) (cadr f))) type-fields)
|
|
;; optional abstract template
|
|
,@(if (not template?)
|
|
(list "")
|
|
`( ,cmnt/*
|
|
,warnin
|
|
,purpos
|
|
,absteg
|
|
,cmnt*/))
|
|
,endclf)))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; 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][super-fields '()])
|
|
(let ([type (car the-class)]
|
|
[super (cadr the-class)]
|
|
[fields (caddr the-class)]
|
|
[prps (class-purpose the-class)])
|
|
(apply string-append
|
|
`( ,@(purpose-statement prps)
|
|
,(format classf type (extends super))
|
|
;; fields
|
|
,@(map (lambda (f) (format declaf (car f) (cadr f))) fields)
|
|
"\n"
|
|
;; constructor
|
|
,(class-constructor type fields super-fields)
|
|
;; optional template draft:
|
|
,@(make-template super fields template?)
|
|
;; optional toString method:
|
|
,@(toString type fields toString?)
|
|
,endclf)))))
|
|
|
|
;; String -> String
|
|
(define (extends super) (if (string=? "" super) "" (format extendsf 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)
|
|
(commas (map (lambda (f) (format paraf (car f) (cadr f))) fs)))
|
|
|
|
;; String Fields Boolean -> (listof String)
|
|
(define (make-template super fields template?)
|
|
(if (not template?)
|
|
(list "")
|
|
`("\n"
|
|
;; template method
|
|
,cmnt/*
|
|
,warnin
|
|
,contef
|
|
,@(map (lambda (f) (format (if (string=? (car f) super)
|
|
temprf
|
|
tempsf)
|
|
(cadr f)))
|
|
fields)
|
|
,endMet
|
|
,cmnt*/)))
|
|
|
|
;; String Fields -> (cons String (listof String))
|
|
;; create a toString method for class type with _fields_
|
|
(define toString
|
|
(opt-lambda (type fields [toString? #t])
|
|
(if (not toString?)
|
|
(list "")
|
|
(list "\n"
|
|
(string-append
|
|
toStrf
|
|
(format prefix type)
|
|
; (apply string-append)
|
|
(if (null? fields)
|
|
" + "
|
|
(format
|
|
" + ~a + " (commas (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)
|
|
(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 Class
|
|
(define abstractF "abstract class ~a {\n")
|
|
;; Abstract Template
|
|
(define purpos " // purpose statement \n")
|
|
(define absteg " abstract ??? mmm();\n")
|
|
;; Class
|
|
(define classf "class ~a ~a{~n") (define extendsf "extends ~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")
|
|
(define endclf "}\n")
|
|
;; Concrete Template
|
|
(define warnin " // ** DRAFT TEMPLATE ** Edit as needed.\n")
|
|
(define contef " ??? mmm() {\n")
|
|
(define tempsf " ... this.~a ...\n")
|
|
(define temprf " ... this.~a.mmm() ...\n")
|
|
;; toString
|
|
(define toStrf " public 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
|
|
|
|
;; (Listof String) -> String
|
|
;; create a comma-separated string from a list of strings
|
|
(define (commas 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"))
|
|
|
|
#| Tests :
|
|
(require (lib "testing.scm" "testing"))
|
|
|
|
(test== (commas '()) "")
|
|
(test== (commas '("x" "y") ) "x, y")
|
|
(test== (commas '("x" "y") " + ") "x + y")
|
|
|
|
(test== (parameters '()) "")
|
|
(test== (parameters '(("int" "x"))) "int x")
|
|
(test== (parameters '(("int" "x") ("foo" "y"))) "int x, foo y")
|
|
(test== (commas '("x" "y") " + ") "x + y")
|
|
(test== (commas '("x" "y" "z") " + ") "x + y + z")
|
|
|
|
(test== (cadr (toString "foo" '()))
|
|
(string-append
|
|
toStrf
|
|
" return \"new foo(\" + \")\";\n"
|
|
endMet))
|
|
|
|
(test== (cadr (toString "Foo" '(("Foo" "x") ("Moo" "y"))))
|
|
(string-append
|
|
toStrf
|
|
" return \"new Foo(\" + x.toString() + \",\" + y.toString() + \")\";\n"
|
|
endMet))
|
|
|
|
(test== (cadr (toString "Foo" '(("int" "x"))))
|
|
(string-append
|
|
toStrf
|
|
" return \"new Foo(\" + x + \")\";\n"
|
|
endMet))
|
|
|
|
(test== (cadr (toString "Foo" '(("Boolean" "x"))))
|
|
(string-append
|
|
toStrf
|
|
" return \"new Foo(\" + x.toString() + \")\";\n"
|
|
endMet))
|
|
|
|
(test== (cadr (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z"))))
|
|
(string-append
|
|
toStrf
|
|
" return \"new Foo(\" + x.toString() + \",\" + y + \",\" + z.toString() + \")\";\n"
|
|
endMet))
|
|
|
|
(test== (toString "Foo" '(("Foo" "x") ("int" "y") ("Z" "z")) #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== (class-constructor "Node" '(("int" "x")) '(("Info" "i") ("ATree" "parent")))
|
|
(string-append
|
|
" Node(Info i, ATree parent, int x) {\n"
|
|
" super(i, parent);\n"
|
|
" this.x = x;\n"
|
|
" }\n"
|
|
)
|
|
"class constructor with super fields")
|
|
|
|
(test== (make-class (list "foo" "" '()))
|
|
(apply string-append
|
|
`( "class foo {\n"
|
|
"\n"
|
|
" foo() {\n"
|
|
" }\n"
|
|
"\n"
|
|
,@empty-template
|
|
" public String toString() {\n"
|
|
" return \"new foo(\" + \")\";\n"
|
|
" }\n"
|
|
"}\n")))
|
|
|
|
(test== (make-class (list "moo" "foo" '()))
|
|
(apply string-append
|
|
`("class moo extends foo {\n"
|
|
"\n"
|
|
" moo() {\n"
|
|
" }\n"
|
|
"\n"
|
|
,@empty-template
|
|
" public String toString() {\n"
|
|
" return \"new moo(\" + \")\";\n"
|
|
" }\n"
|
|
"}\n")))
|
|
|
|
(test== (make-class (list "moo" "foo" '(("int" "x") ("foo" "f"))))
|
|
(apply string-append
|
|
`("class moo extends 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
|
|
" ??? mmm() {\n"
|
|
" ... this.x ...\n"
|
|
" ... this.f.mmm() ...\n"
|
|
" }\n"
|
|
,cmnt*/
|
|
"\n"
|
|
" public String toString() {\n"
|
|
" return \"new moo(\" + x + \",\" + f.toString() + \")\";\n"
|
|
" }\n"
|
|
"}\n")))
|
|
|
|
(test== (make-class (list "CartPt" "" '(("int" "x") ("int" "y"))))
|
|
(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
|
|
" ??? mmm() {\n"
|
|
" ... this.x ...\n"
|
|
" ... this.y ...\n"
|
|
" }\n"
|
|
,cmnt*/
|
|
"\n"
|
|
" public String toString() {\n"
|
|
" return \"new CartPt(\" + x + \",\" + y + \")\";\n"
|
|
" }\n"
|
|
"}\n")))
|
|
|
|
(test== (abstractClass "Foo" '() #f)
|
|
(string-append
|
|
"abstract class Foo {\n"
|
|
"}\n"))
|
|
|
|
(test== (abstractClass "Foo" '(("int" "x")) #f)
|
|
(string-append
|
|
"abstract class Foo {\n"
|
|
" int x;\n"
|
|
"}\n")
|
|
"abstract class with fields")
|
|
|
|
(test== (abstractClass "Foo" '() #t)
|
|
(apply string-append
|
|
`("abstract class Foo {\n"
|
|
,cmnt/*
|
|
,warnin
|
|
,purpos
|
|
" abstract ??? mmm();\n"
|
|
,cmnt*/
|
|
"}\n")))
|
|
|
|
(test== (abstractClass "Foo" '(("int" "x")) #t)
|
|
(apply string-append
|
|
`("abstract class Foo {\n"
|
|
" int x;\n"
|
|
,cmnt/*
|
|
,warnin
|
|
,purpos
|
|
" abstract ??? mmm();\n"
|
|
,cmnt*/
|
|
"}\n"))
|
|
"abstract class with fields and template")
|
|
|
|
(test==
|
|
(make-union
|
|
(make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) ""))
|
|
(apply string-append
|
|
`(
|
|
"abstract class AList {\n"
|
|
"/*\n"
|
|
,warnin
|
|
" // purpose statement \n"
|
|
" abstract ??? mmm();\n"
|
|
"*/\n"
|
|
"}\n"
|
|
"\n"
|
|
"class MT extends AList {\n"
|
|
"\n"
|
|
" MT() {\n"
|
|
" }\n"
|
|
"\n"
|
|
"/*\n"
|
|
,warnin
|
|
" ??? mmm() {\n"
|
|
" }\n"
|
|
"*/\n"
|
|
"\n"
|
|
" public String toString() {\n"
|
|
" return \"new MT(\" + \")\";\n"
|
|
" }\n"
|
|
"}\n"
|
|
"\n"
|
|
"class Cons extends 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
|
|
" ??? 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")))) "")
|
|
#f #f)
|
|
(apply string-append
|
|
`(
|
|
"abstract class AList {\n"
|
|
"}\n"
|
|
"\n"
|
|
"class MT extends AList {\n"
|
|
"\n"
|
|
" MT() {\n"
|
|
" }\n"
|
|
"}\n"
|
|
"\n"
|
|
"class Cons extends 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-class (list "foo" "" '() "hello world"))
|
|
(apply string-append
|
|
`( "// hello world\n"
|
|
"class foo {\n"
|
|
"\n"
|
|
" foo() {\n"
|
|
" }\n"
|
|
"\n"
|
|
,@empty-template
|
|
" public String toString() {\n"
|
|
" return \"new foo(\" + \")\";\n"
|
|
" }\n"
|
|
"}\n")))
|
|
|
|
(test==
|
|
(make-union
|
|
(make-dt "AList" '() '(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")))) "hello world")
|
|
#f #f)
|
|
(apply string-append
|
|
`("// hello world\n"
|
|
"abstract class AList {\n"
|
|
"}\n"
|
|
"\n"
|
|
"class MT extends AList {\n"
|
|
"\n"
|
|
" MT() {\n"
|
|
" }\n"
|
|
"}\n"
|
|
"\n"
|
|
"class Cons extends 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"
|
|
"abstract class AList {\n"
|
|
"}\n"
|
|
"\n"
|
|
"class MT extends AList {\n"
|
|
"\n"
|
|
" MT() {\n"
|
|
" }\n"
|
|
"}\n"
|
|
"\n"
|
|
"// pair\n"
|
|
"class Cons extends 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")
|
|
|
|
(test==
|
|
(make-union
|
|
(make-dt
|
|
"AList"
|
|
'(("Common" "field") ("Common" "field2"))
|
|
'(("MT" ()) ("Cons" (("int" "first") ("AList" "rest")) "pair"))
|
|
"hello world")
|
|
#f #f)
|
|
(apply string-append
|
|
`("// hello world\n"
|
|
"abstract class AList {\n"
|
|
" Common field;\n"
|
|
" Common field2;\n"
|
|
"}\n"
|
|
"\n"
|
|
"class MT extends AList {\n"
|
|
"\n"
|
|
" MT(Common field, Common field2) {\n"
|
|
" this.field = field;\n"
|
|
" this.field2 = field2;\n"
|
|
" }\n"
|
|
"}\n"
|
|
"\n"
|
|
"// pair\n"
|
|
"class Cons extends AList {\n"
|
|
" int first;\n"
|
|
" AList rest;\n"
|
|
"\n"
|
|
" Cons(Common field, Common field2, int first, AList rest) {\n"
|
|
" this.field = field;\n"
|
|
" this.field2 = field2;\n"
|
|
" this.first = first;\n"
|
|
" this.rest = rest;\n"
|
|
" }\n"
|
|
"}\n"
|
|
)
|
|
)
|
|
"make union with common fields")
|
|
|#
|
|
)
|
|
|