(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 (lib "contract.ss"))
  (require (lib "struct.ss"))

  ;; TODO: get-related-types should be done with inner instead of super

  ;; TODO: (how) can this eventually work with generics?

  ;; TODO: put this utility in a separate planet library
  (define-syntax syntax-for-each
    (syntax-rules ()
      [(_ transformer (arg ...))
       (begin
         (define-syntax anonymous transformer)
         (anonymous arg)
         ...)]))

  ;; ===========================================================================
  ;; DATA DEFINITIONS
  ;; ===========================================================================

  (with-public-inspector
    (define-struct/opt type-name (package type [dimension 0]))
    ;; TODO: provide with contracts
    (provide (struct type-name (package type dimension))))
;    (provide/contract (struct type-name ([package (listof symbol?)]
;                                         [type symbol?]))))

  ;; build-type-name : (listof symbol) -> type-name
  (define (build-type-name name)
    (let ([rev (reverse name)])
      (make-type-name (reverse (cdr rev))
                      (car rev))))

  ;; dot-notation : (listof symbol) -> string
  (define (dot-notation los)
    (string-join (map symbol->string los) "." 'infix))

  ;; type-name->string : (optional type-name) -> string
  (define (type-name->string name)
    (if (not name)
        "void"
        (string-append
         (dot-notation (type-name-package name))
         "."
         (symbol->string (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?)])

  ;; ===========================================================================
  ;; CLASSES AND INTERFACES
  ;; ===========================================================================

  (define semantic-object<%>
    (interface () to-string))

  ;; package-name : (listof symbol)
  (define package%
    (class* object% (semantic-object<%>)
      (init-private name)
      (define/public (to-string)
        (dot-notation name))
      (super-new)))

  ;; get-related-types : -> (listof type-name)
  (define resolvable<%>
    (interface () get-related-types))

  ;; get-type-name : -> type-name
  (define type<%>
    (interface (semantic-object<%> resolvable<%>) get-type-name))

  ;; base-type : type-name
  (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)))

  ;; package : (listof symbol)
  ;; name : type-name
  (define ground-type%
    (class* object% (type<%>)
      (init-private package name)
      (define/public (get-package) package)
      (define/public (get-type-name) name)
      (define/public (get-related-types) null)
      (define/public (to-string) (format "~a" name))
      (super-new)))

  (define primitive-type%
    (class ground-type%
      (init name)
      (super-make-object null name)))

  ;; package : (listof symbol)
  ;; name : type-name
  ;; modifiers : (listof access-flag)
  ;; interfaces : (listof type-name)
  ;; elements : (listof type-element%)
  (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/override (get-related-types)
        (lset-union equal?
                    interfaces
                    (apply lset-union
                           equal?
                           (map (lambda (elt) (send elt get-related-types))
                                elements))))
      (super-make-object package name)))

  ;; superclass : (optional type-name)
  (define class%
    (class declared-type%
      (init package name modifiers interfaces elements)
      (init-private superclass)
      (define/public (get-superclass) superclass)
      (define/override (get-related-types)
        (let ([most (super get-related-types)])
          (if superclass
              (lset-union equal? most (list superclass))
              most)))
      (super-make-object package name modifiers interfaces elements)))

  (define interface%
    (class declared-type%
      (init package name init modifiers interfaces elements)
      (super-make-object package name modifiers interfaces elements)))

  ;; TODO: do I really want strings, and not symbols? this is Scheme, after all

  ;; name : string
  (define type-element%
    (class* object% (semantic-object<%> resolvable<%>)
      (init-private name)
      (define/public (get-name) name)
      (define/public (get-related-types) null)
      (define/public (to-string)
        (format "~a" name))
      (super-new)))

  ;; name : string
  ;; modifiers : (listof access-flag)
  ;; type : type-name
  (define field%
    (class type-element%
      (inherit get-name)
      (init name)
      (init-private modifiers type)
      (define/public (get-modifiers) modifiers)
      (define/public (get-type) type)
      (define/override (get-related-types)
        (list type))
      (define/override (to-string)
        (format "~a ~a" (type-name->string type) (get-name)))
      (super-make-object name)))

  ;; name : string
  ;; formals : (listof type-name)
  ;; exceptions : (listof type-name)
  (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/override (get-related-types)
        (lset-union equal? formals exceptions))
      (define (to-string) (get-name))
      (super-make-object name)))

  (define initializer%
    (class type-element%
      (super-make-object #f)))

  ;; name : string
  ;; formals : (listof type-name)
  ;; exceptions : (listof type-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)))

  ;; name : string
  ;; formals : (listof type-name)
  ;; exceptions : (listof type-name)
  ;; modifiers : (listof access-flag)
  ;; return-type : (optional type-name)
  (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/override (get-related-types)
        (lset-union equal?
                    (let ([formals+exceptions (append (get-formals)
                                                      (get-exceptions))])
                      (if return-type
                          (cons return-type formals+exceptions)
                          formals+exceptions))))
      (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)))

  ;; TODO: make this a type<%>?

  ;; name : string
  ;; type : type-name
  (define inner-type%
    (class type-element%
      (init name)
      (init-private type)
      (define/public (get-type) type)
      (define/override (get-related-types)
        (list type))
      (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%))