(module semantic-object mzscheme
(require (planet "contract-utils.ss" ("cobbe" "contract-utils.plt" 1)))
(require (planet "inspector.ss" ("dherman" "inspector.plt" 1)))
(require (planet "struct.ss" ("dherman" "struct.plt" 1)))
(require (planet "class.ss" ("dherman" "struct.plt" 1)))
(require (lib "list.ss" "srfi" "1"))
(require (lib "string.ss" "srfi" "13"))
(require (lib "class.ss"))
(require (all-except (lib "contract.ss") union))
(require (lib "struct.ss"))
(define-syntax syntax-for-each
(syntax-rules ()
[(_ transformer (arg ...))
(begin
(define-syntax anonymous transformer)
(anonymous arg)
...)]))
(define-syntax send-map
(syntax-rules ()
[(_ message exp)
(map (lambda (elt) (send elt message)) exp)]))
(define (union . lists)
(apply lset-union equal? lists))
(define (union* lists)
(apply lset-union equal? lists))
(with-public-inspector
(define-struct/opt type-name (package type [dimension 0]))
(provide (struct type-name (package type dimension))))
(define (build-type-name name)
(let ([rev (reverse name)])
(make-type-name (reverse (cdr rev))
(car rev))))
(define (dot-notation los)
(string-join (map symbol->string los) "." 'infix))
(define (type-name->string name)
(if (not name)
"void"
(dot-notation (append (type-name-package name)
(list (type-name-type name))))))
(provide/contract
[build-type-name ((listof symbol?) . -> . type-name?)]
[dot-notation ((listof symbol?) . -> . string?)]
[type-name->string ((optional/c type-name?) . -> . string?)])
(define semantic-object<%>
(interface ()
to-string))
(define resolvable<%>
(interface ()
get-related-types))
(define type<%>
(interface (semantic-object<%> resolvable<%>)
get-type-name))
(define package%
(class* object% (semantic-object<%>)
(init-private name)
(define/public (to-string)
(dot-notation name))
(super-new)))
(define array-type%
(class* object% (type<%>)
(init-private base-type)
(define name
(copy-struct type-name base-type
(type-name-dimension (add1 (type-name-dimension base-type)))))
(define/public (get-type-name) name)
(define/public (get-base-type) base-type)
(define/public (get-dimension)
(type-name-dimension name))
(define/public (get-related-types)
(list base-type))
(define/public (to-string)
(format "~a[]" (type-name->string base-type)))
(super-new)))
(define ground-type%
(class* object% (type<%>)
(init-private package name)
(define/public (get-package) package)
(define/public (get-type-name) name)
(define/pubment (get-related-types) (inner null get-related-types))
(define/public (to-string) (format "~a" name))
(super-new)))
(define primitive-type%
(class ground-type%
(init name)
(super-make-object null name)))
(define declared-type%
(class ground-type%
(init package name)
(init-private modifiers interfaces elements)
(define/public (get-modifiers) modifiers)
(define/public (get-interfaces) interfaces)
(define/public (get-elements) elements)
(define/augment (get-related-types)
(union* (cons interfaces
(cons (inner null get-related-types)
(send-map get-related-types elements)))))
(super-make-object package name)))
(define class%
(class declared-type%
(init package name modifiers interfaces elements)
(init-private superclass)
(define/public (get-superclass) superclass)
(define/augment (get-related-types)
(union (if superclass (list superclass) null)
(inner null get-related-types)))
(super-make-object package name modifiers interfaces elements)))
(define interface%
(class declared-type%
(init package name modifiers interfaces elements)
(super-make-object package name modifiers interfaces elements)))
(define type-element%
(class* object% (semantic-object<%> resolvable<%>)
(init-private name)
(define/public (get-name) name)
(define/pubment (get-related-types) (inner null get-related-types))
(define/public (to-string)
(format "~a" name))
(super-new)))
(define field%
(class type-element%
(init name)
(init-private modifiers type)
(inherit get-name)
(define/public (get-modifiers) modifiers)
(define/public (get-type) type)
(define/augment (get-related-types)
(union (list type) (inner null get-related-types)))
(define/override (to-string)
(format "~a ~a" (type-name->string type) (get-name)))
(super-make-object name)))
(define initializer%
(class type-element%
(super-make-object #f)))
(define behavior%
(class type-element%
(init name)
(init-private formals exceptions)
(inherit get-name)
(define/public (get-formals) formals)
(define/public (get-exceptions) exceptions)
(define/augment (get-related-types)
(union formals exceptions (inner null get-related-types)))
(define (to-string) (get-name))
(super-make-object name)))
(define constructor%
(class behavior%
(override to-string)
(inherit get-name get-formals get-exceptions)
(init name formals exceptions)
(define (to-string)
(format "~a(~a) throws ~a"
(get-name)
(string-join (map type-name->string (get-formals)) ", ")
(string-join (map type-name->string (get-exceptions)) ", ")))
(super-make-object name formals exceptions)))
(define method%
(class behavior%
(init name formals exceptions)
(init-private modifiers return-type)
(inherit get-name get-formals get-exceptions)
(define/public (get-return-type) return-type)
(define/public (get-modifiers) modifiers)
(define/augment (get-related-types)
(union (if return-type (list return-type) null)
(inner null get-related-types)))
(define/override (to-string)
(format "~a ~a(~a) throws ~a"
(type-name->string (get-return-type))
(get-name)
(string-join (map type-name->string (get-formals)) ", ")
(string-join (map type-name->string (get-exceptions)) ", ")))
(super-make-object name formals exceptions)))
(define inner-type%
(class type-element%
(init name)
(init-private type)
(define/public (get-type) type)
(define/augment (get-related-types)
(union (list type) (inner null get-related-types)))
(super-make-object name)))
(syntax-for-each (syntax-rules ()
[(_ prim)
(begin
(define prim (make-object primitive-type% (build-type-name '(prim))))
(provide/contract (prim (is-a?/c primitive-type%))))])
(byte char double float int long short boolean))
(provide semantic-object<%> type<%> resolvable<%>
package%
ground-type% primitive-type% declared-type% array-type%
class% interface%
type-element% field% initializer% behavior% constructor% method%
inner-type%))