132 lines
4.0 KiB
Scheme
132 lines
4.0 KiB
Scheme
#| 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 Fields 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
|
|
|
|
(define-struct dt (type fields variants purpose))
|
|
|
|
;; 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 (make-dt "ATree" '() (list vc1 vc2) "a tree for ints"))
|
|
|
|
(require (file "aux-contract.scm"))
|
|
(require (lib "contract.ss"))
|
|
|
|
(provide
|
|
Class ;; flat-contract
|
|
Union ;; flat-contract
|
|
Variant ;; flat-contract
|
|
Fields ;; flat-contract
|
|
java-id? ;; Any -> Boolean
|
|
class-purpose ;; Class -> String
|
|
variant-purpose ;; Variant -> String
|
|
)
|
|
|
|
;; DataType -> String
|
|
;; (define (union-purpose dt) (if (null? (cddr dt)) "" (caddr dt)))
|
|
|
|
;; Class -> String
|
|
(define (class-purpose c) (if (null? (cdddr c)) "" (cadddr c)))
|
|
|
|
;; Variant -> String
|
|
(define (variant-purpose c) (if (null? (cddr c)) "" (caddr c)))
|
|
|
|
;; Any -> Boolean
|
|
;; the string isn't empty and contains no spaces
|
|
;; I should really import this from Kathy's parser or whatever
|
|
;; so I get qualified names and whatever right
|
|
(define (java-id? s)
|
|
(and (string? s) (not (string=? "" s)) (not (regexp-match "[ |\t|\n]" s))))
|
|
|
|
(define-as-contract "<Class>" (class c)
|
|
(and (pair? c) (pair? (cdr c)) (pair? (cddr c))
|
|
(or (null? (cdddr c))
|
|
(and (pair? (cdddr c))
|
|
(null? (cddddr c))
|
|
(string? (cadddr c))))
|
|
; (list? c) (= (length c) 3)
|
|
(java-id? (car c))
|
|
(let ([super (cadr c)])
|
|
(or (java-id? super) (string=? super "")))
|
|
(is-fields? (caddr c))))
|
|
|
|
(define-as-contract "<Fields>" (fields l)
|
|
(and (list? l) (andmap is-field? l)))
|
|
|
|
(define-as-contract "<Field in Class>" (field l)
|
|
(and (pair? l) (pair? (cdr l)) (null? (cddr l))
|
|
(java-id? (car l)) (java-id? (cadr l))))
|
|
|
|
(define-as-contract "<Union>" (union l) (dt? l))
|
|
|
|
(define (is-variants? l) (andmap is-variant? l))
|
|
|
|
(define-as-contract "<Variant>" (variant c)
|
|
(and (pair? c) (pair? (cdr c))
|
|
(or
|
|
(null? (cddr c))
|
|
(and
|
|
(pair? (cddr c))
|
|
(null? (cdddr c))
|
|
(string? (caddr c)))
|
|
; (list? c) (= (length c) 2)
|
|
(java-id? (car c))
|
|
(is-fields? (cadr c)))))
|
|
|
|
(provide/contract
|
|
(struct dt ((type java-id?)
|
|
(fields (listof is-field?))
|
|
(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)
|
|
|#
|
|
|
|
)
|