(module semantic-object mzscheme
  (require (planet "class.ss" ("dherman" "struct.plt" 1)))
  (require (lib "string.ss" "srfi" "13"))
  (require (lib "class.ss"))
  (require (lib "contract.ss"))
  (require "class-resolver.ss")

  ;; TODO: OK. Here's how I want to get rid of the union types.
  ;;       Everything should just accept type-name, and return type-name.
  ;;       Period. Then there will never be any forced resolution of
  ;;       anything unless it's explicitly requested with lookup-type.
  ;;       Keep resolve-all, though, as a convenient way of doing the
  ;;       transitive closure of lookup-type.

  ;; TODO: will have to allow type-name to deal with array types

  ;; TODO: move type-name to this module?

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

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

  ;; TODO: type-check that lookup-type only ever gets passed a type-name

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

  ;; resolve-all : () -> ()
  (define resolvable<%>
    (interface () resolve-all))

  (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 resolve-all)

      (init-private package name)
      (define (get-package) package)
      (define (get-name) name)
      (define (resolve-all) (void))
      (define (to-string) (format "~a" name))

      (super-new)))

  ;; TODO: get rid of unknown-type%?

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

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

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

  ;; TODO: left off here....

  ;; package-name : (listof symbol)
  ;; type-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 resolve-all)

      (init package-name type-name)
      (init-private modifiers interfaces elements)
      (define the-interfaces (delay (map lookup-type interfaces)))

      (define (get-modifiers) modifiers)
      (define (get-interfaces) (force the-interfaces))
      (define (get-elements) elements)
      (define (resolve-all)
        (get-interfaces)
        (for-each (lambda (elt) (when elt (send elt resolve-all)))
                  (get-elements))
        (void))
      (super-make-object package-name type-name)))

  (define class%
    (class declared-type%
      (public get-superclass)
      (init package-name type-name)
      (init modifiers interfaces elements)
      (init superclass)
      (define superclass-type (delay (lookup-type superclass)))
      (define (get-superclass) (force superclass-type))
      (super-make-object package-name type-name modifiers interfaces elements)))

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

  ;; base-type : (union type<%> type-name)
  (define array-type%
    (class* object% (type<%>)
      (public get-base-type resolve-all to-string)
      (init base-type)

      (define original-base-type base-type)
      (define the-base-type
        (delay (maybe-lookup-type base-type)))

      (define (get-base-type)
        (force the-base-type))
      (define (get-dimension)
        (let ([bt (get-base-type)])
          (if (is-a? bt array-type%)
              (add1 (send bt get-dimension))
              1)))
      (define (resolve-all)
        (send (get-base-type) resolve-all))
      (define (to-string)
        (format "~a[]"
                (if (type-name? original-base-type)
                    (type-name->string original-base-type)
                    (send original-base-type to-string))))
      (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 resolve-all to-string)
      (init-private name)
      (define (get-name) name)
      (define (resolve-all) (void))
      (define (to-string)
        (format "~a" name))
      (super-new)))

  ;; name : string
  ;; modifiers : (listof access-flag)
  ;; type : (union type<%> type-name)
  (define field%
    (class type-element%
      (public get-modifiers get-type)
      (override resolve-all to-string)
      (inherit get-name)
      (init name)
      (init-private modifiers)
      (init type)
      (define the-type (delay (maybe-lookup-type type)))
      (define (get-modifiers) modifiers)
      (define (get-type)
        (force the-type))
      (define (resolve-all)
        (get-type)
        (void))
      (define (to-string)
        (format "~a ~a"
                (send (force the-type) to-string)
                (get-name)))
      (super-make-object name)))

  ;; name : string
  ;; formals : (listof (union type-name type<%>))
  ;; exceptions : (listof (union type-name type<%>))
  (define behavior%
    (class type-element%
      (public get-formals get-exceptions)
      (override resolve-all)
      (inherit get-name)
      (init name)
      (init formals exceptions)
      (define the-formals (delay (map maybe-lookup-type formals)))
      (define the-exceptions (delay (map maybe-lookup-type exceptions)))
      (define (get-formals)
        (force the-formals))
      (define (get-exceptions)
        (force the-exceptions))
      (define (resolve-all)
        (get-formals)
        (get-exceptions)
        (void))
      (define (to-string)
        ;; TODO: what type is the name?
        (format "~a" (get-name)))
      (super-make-object name)))

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

  ;; name : string
  ;; formals : (listof (union type<%> type-name))
  ;; exceptions : (listof (union type<%> type-name))
  (define constructor%
    (class behavior%
      (override to-string)
      (inherit get-name get-formals get-exceptions)
      (init name)
      (init formals exceptions)
      (define (to-string)
        ;; TODO: is this right?
        (format "~a(~a) throws ~a"
                (get-name)
                (string-join (map (lambda (fml)
                                    (send fml to-string))
                                  (get-formals))
                             ", "
                             'infix)
                (string-join (map (lambda (exn)
                                    (send exn to-string))
                                  (get-exceptions)))))
      (super-make-object name formals exceptions)))

  ;; name : string
  ;; formals : (listof (union type<%> type-name))
  ;; exceptions : (listof (union type<%> type-name))
  ;; modifiers : (listof access-flag)
  ;; return-type : (optional (union type<%> type-name))
  (define method%
    (class behavior%
      (public get-return-type get-modifiers)
      (override resolve-all to-string)
      (inherit get-name get-formals get-exceptions)
      (init name)
      (init formals exceptions)
      (init-private modifiers)
      (init return-type)
      (define the-return-type
        (delay (and return-type (maybe-lookup-type return-type))))
      (define (get-return-type)
        (force the-return-type))
      (define (get-modifiers) modifiers)
      (define (resolve-all)
        (send this get-formals)
        (send this get-exceptions)
        (get-return-type)
        (void))
      (define (to-string)
        ;; TODO: is this right?
        (format "~a ~a(~a) throws ~a"
                (send (get-return-type) to-string)
                (get-name)
                (string-join (map (lambda (fml)
                                    (send fml to-string))
                                  (get-formals))
                             ", "
                             'infix)
                (string-join (map (lambda (exn)
                                    (send exn to-string))
                                  (get-exceptions)))))
      (super-make-object name formals exceptions)))

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

  ;; name : string
  ;; type : (union type<%> type-name)
  (define inner-type%
    (class type-element%
      (public get-type)
      (override resolve-all)
      (init name)
      (init type)
      (define the-type
        (delay (maybe-lookup-type type)))
      (define (get-type)
        (force the-type))
      (define (resolve-all)
        (get-type)
        (void))
      (super-make-object name)))

  (provide semantic-object<%> type<%> resolvable<%>
           package%
           ground-type% unknown-type% primitive-type% declared-type% array-type%
           class% interface%
           type-element% field% initializer% behavior% constructor% method%
           inner-type%))