(module semantic-object mzscheme
  (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 "string.ss" "srfi" "13"))
  (require (lib "class.ss"))
  (require (lib "contract.ss"))

  ;; 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))

  (define (type-name->string name)
    (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 (type-name? . -> . string?)])

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

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

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

  (define type<%>
    (interface (semantic-object<%> resolvable<%>)))

  ;; package : (listof symbol)
  ;; name : type-name
  (define ground-type%
    (class* object% (semantic-object<%> type<%>)
      (public get-package get-name to-string get-related-types)

      (init-private package name)
      (define (get-package) package)
      (define (get-name) name)
      (define (get-related-types) null)
      (define (to-string) (format "~a" name))

      (super-new)))

  ;; package : (listof symbol)
  ;; name : type-name
;  (define unknown-type%
;    (class ground-type%
;      (init package name)
;      (super-make-object package name)))

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

  (syntax-for-each (syntax-rules ()
                     [(_ prim)
                      (begin
                        (define prim (make-object primitive-type% 'prim))
                        (provide/contract (prim (is-a?/c primitive-type%))))])
                   (byte char double float int long short boolean))

  ;; package : (listof symbol)
  ;; name : type-name
  ;; modifiers : (listof access-flag)
  ;; interfaces : (listof type-name)
  ;; elements : (listof type-element%)
  (define declared-type%
    (class ground-type%
      (public get-modifiers get-interfaces get-elements)
      (override get-related-types)
      (init package name)
      (init-private modifiers interfaces elements)
      (define (get-modifiers) modifiers)
      (define (get-interfaces) interfaces)
      (define (get-elements) elements)
      (define (get-related-types)
        (append interfaces
                (map (lambda (elt) (send elt get-related-types))
                     elements)))
      (super-make-object package name)))

  (define class%
    (class declared-type%
      (public get-superclass)
      (init package name modifiers interfaces elements)
      (init-private superclass)
      (define (get-superclass) superclass)
      (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)))

  ;; base-type : type-name
  (define array-type%
    (class* object% (type<%>)
      (public get-base-type get-related-types to-string)
      (init-private base-type)

      (define (get-base-type) base-type)
      (define (get-dimension)
        (add1 (type-name-dimension base-type)))
      (define (get-related-types)
        (list base-type))
      (define (to-string)
        (format "~a[]" (type-name->string base-type)))
      (super-new)))

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

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

  ;; name : string
  ;; modifiers : (listof access-flag)
  ;; type : type-name
  (define field%
    (class type-element%
      (public get-modifiers get-type)
      (override get-related-types to-string)
      (inherit get-name)
      (init name)
      (init-private modifiers type)
      (define (get-modifiers) modifiers)
      (define (get-type) type)
      (define (get-related-types)
        (list type))
      (define (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%
      (public get-formals get-exceptions)
      (override get-related-types)
      (inherit get-name)
      (init name)
      (init-private formals exceptions)
      (define (get-formals) formals)
      (define (get-exceptions) exceptions)
      (define (get-related-types)
        (append 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%
      (public get-return-type get-modifiers)
      (override get-related-types to-string)
      (inherit get-name get-formals get-exceptions)
      (init name formals exceptions)
      (init-private modifiers return-type)
      (define (get-return-type) return-type)
      (define (get-modifiers) modifiers)
      (define (get-related-types)
        (cons return-type
              (append (get-formals) (get-exceptions))))
      (define (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%
      (public get-type)
      (override get-related-types)
      (init name)
      (init-private type)
      (define (get-type) type)
      (define (get-related-types)
        (list type))
      (super-make-object name)))

  (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%))