; typeclass.scm

(module typeclass mzscheme

  (provide define-class with import lambda=> define=>)

  (require (lib "list.ss" "mzlib"))
  (require-for-syntax (lib "list.ss" "mzlib") ; for filter
                      "macrosupport.scm")

(define-syntax define-class
  (lambda (stx)
    (syntax-case stx ()
      ((_ name field ...)
       (with-syntax 
           ([ctor (make-prefixed-id (syntax name) "make-" 
                                    (syntax-object->datum (syntax name)))]
            [(formal ...) (generate-temporaries (syntax (field ...)))])
         (syntax
          (begin
            (define ctor
              (lambda (formal ...)
                (lambda (k) (k formal ...))))
            (define-syntax name
              (let ([fields (syntax-object->datum (syntax (field ...)))])
                (lambda (x)
                  (syntax-case x ()
                    ((_ scope k prefix-str-stx instance arg (... ...))
                     (let ([prefix-str (syntax-object->datum (syntax prefix-str-stx))])
                       (with-syntax 
                           ([labels (map (lambda (stx)
                                           (make-prefixed-id (syntax scope) 
                                                             prefix-str
                                                             (syntax-object->datum
                                                              (syntax-case stx ()
                                                                ((super label) (syntax label))
                                                                (label (syntax label))))))
                                         (syntax-e (syntax (field ...))))]
                            [supers (map (lambda (class-label)
                                           (with-syntax 
                                               ([class (datum->syntax-object (syntax scope) (car class-label))]
                                                [label (make-prefixed-id (syntax scope) prefix-str (cadr class-label))]
                                                [prefix-sym (string->symbol prefix-str)])
                                             (syntax (class label prefix-sym))))
                                         (filter pair? fields))])
                         (syntax (k "descriptor" scope instance labels supers arg (... ...)))))))))))))))))

(define-syntax with
  (lambda (stx)
    (syntax-case stx ()
      ((k (instance-form ...) exp ...)
       (syntax (with/scope k (instance-form ...) exp ...))))))

(define-syntax with/scope
  (lambda (stx)
    (syntax-case stx ()
      ((_ scope () exp ...)
       (syntax (begin exp ...)))
      ((_ scope ((name instance) rest ...) exp ...)
       (syntax (name scope with/scope "" instance (rest ...) exp ...)))
      ((_ scope ((name instance prefix) rest ...) exp ...)
       (with-syntax ([prefix-str (symbol->string (syntax-object->datum (syntax prefix)))])
         (syntax (name scope with/scope prefix-str instance (rest ...) exp ...))))
      ((_ "descriptor" scope instance pre-labels super-bindings rest ...)
       (syntax 
        (instance 
         (lambda pre-labels
           (with/scope scope super-bindings
                       (with/scope scope rest ...)))))))))

(define-syntax import
  (lambda (stx)
    (syntax-case stx ()
      ((k (name instance ...) rest ...)
       (syntax (import/scope k (name instance ...) rest ...))))))

(define-syntax import/scope
  (lambda (stx)
    (syntax-case stx ()
      ((_ scope)
       (syntax "Bindings imported"))
      ((_ scope (name instance) rest ...)
       (syntax (name scope import/scope "" instance (rest ...))))
      ((_ scope (name instance prefix) rest ...)
       (with-syntax ((prefix-str (symbol->string (syntax-object->datum (syntax prefix)))))
         (syntax (name scope import/scope prefix-str instance (rest ...)))))
      ((_ "descriptor" scope instance (pre-label ...) (super-binding ...) (rest ...))
       (with-syntax ([(temp ...) (generate-temporaries (syntax (pre-label ...)))])
         (syntax 
          (begin
            (define pre-label #f) ...
            (instance (lambda (temp ...)
                        (set! pre-label temp) ...))
            (import/scope scope super-binding ...)
            (import/scope scope rest ...))))))))

(define-syntax lambda=>
  (lambda (stx)
    (syntax-case stx ()
      ((k (class-form ...) body ...)
       (syntax (lambda=> k (class-form ...) body ...)))
      ((_ scope quals body ...)
       (let ([quals-binds (map (lambda (qual tmp)
                                 (with-syntax ((tmp tmp))
                                   (syntax-e
                                    (syntax-case qual ()
                                      ((cls prefix) (syntax (cls tmp prefix)))
                                      (cls          (syntax (cls tmp)))))))
                               (syntax-e (syntax quals))
                               (generate-temporaries (syntax quals)))])
         (with-syntax 
             ([formals (map cadr quals-binds)]
              [quals-binds-stx quals-binds])
           (syntax
            (lambda formals
              (with/scope scope quals-binds-stx
                          body ...)))))))))

(define-syntax define=>
  (lambda (stx)
    (syntax-case stx ()
      ((k (name quals ...) body ...)
       (syntax (define name (lambda=> k (quals ...) body ...)))))))
)