#lang scheme

(define class-or-interface/c (or/c class? interface?))

(define (subclass-or-implements/c class-or-iface)
  (cond
   [(class? class-or-iface) (subclass?/c class-or-iface)]
   [(interface? class-or-iface) (implementation?/c class-or-iface)]
   [else (error 'subclass-or-implements/c
                "not a class or interface: ~s"
                class-or-iface)]))

(define (object/c . class-or-ifaces)
  (apply and/c object? (map is-a?/c class-or-ifaces)))

(define (class/c . class-or-ifaces)
  (apply and/c class? (map subclass-or-implements/c class-or-ifaces)))

(define-syntax (mixin/c stx)
  (syntax-case stx ()
    [(form (super-in ...)
           (other-in ...)
           (sub-out ...))
     (with-syntax ([(super-var ...)
                    (generate-temporaries (syntax (super-in ...)))]
                   [(other-var ...)
                    (generate-temporaries (syntax (other-in ...)))]
                   [(dummy ...)
                    (generate-temporaries (syntax (other-in ...)))]
                   [(sub-var ...)
                    (generate-temporaries (syntax (sub-out ...)))])
       (syntax/loc stx
         (let* ([super-var super-in] ...
                [other-var other-in] ...
                [sub-var sub-out] ...)
           (->d ([super (class/c super-var ...)]
                 [dummy other-var] ...)
                ()
                [_ (class/c super sub-var ...)]))))]))

(define-syntax (send+ stx)
  (syntax-case stx ()
    [(s+ expr clause ...)
     (syntax/loc stx
       (let* ([obj expr])
         (send obj . clause) ...
         obj))]))

(define-syntax (send-each stx)
  (syntax-case stx ()
    [(se objs-expr method arg-expr ...)
     (with-syntax ([(arg-var ...) (generate-temporaries #'(arg-expr ...))])
       (syntax/loc stx
         (let ([objs-var objs-expr]
               [arg-var arg-expr]
               ...)
           (for-each (lambda (obj)
                       (send obj method arg-var ...))
                     objs-var))))]))

(define (ensure-interface iface<%> mx class%)
  (if (implementation? class% iface<%>)
      class%
      (mx class%)))

(provide/contract
 [class-or-interface/c flat-contract?]
 [object/c (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)]
 [class/c (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)]
 [ensure-interface (->d ([the-interface interface?]
                         [the-mixin (mixin/c [] [] [the-interface])]
                         [the-class class?])
                        ()
                        [_ (class/c the-class the-interface)])])

(provide mixin/c send+ send-each)