(module interfaces mzscheme

  (require (lib "contract.ss")
           (lib "class.ss"))

  (provide updatee<%>
           editor-util<%>
           pasteboard-util<%>
           editor-canvas-util<%>
           pullable<%>
           ensure-iface
           subclass-or-implements/c
           object/c
           class/c
           mixin/c)

  (define updatee<%>
    (interface () on-update))

  (define editor-util<%>
    (interface ()
      scroll-to/xy
      get-position
      vertical-scroll-step
      horizontal-scroll-step))

  (define pasteboard-util<%>
    (interface (editor-util<%>)
      center-snip))

  (define editor-canvas-util<%>
    (interface ()
      scroll-to/xy
      on-scroll/xy
      get-position))

  (define pullable<%>
    (interface ()
      on-pull))

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

  (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 is-a?/c)

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

  (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 (class/c super-var ...)
                  other-var ...
                  (lambda (super dummy ...)
                    (class/c super sub-var ...))))))]))

  )