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