#lang scheme/base
(require (for-template scheme/base
                       scheme/class)
         stxclass)

(provide static-interface?
         make-static-interface
         static-interface-dynamic
         static-interface-members

         make-checked-binding
         checked-binding?
         checked-binding-dynamic
         checked-binding-iface

         checked-binding
         static-interface

         interface-expander?
         make-interface-expander
         interface-expander-proc

         interface-expander
         method-entry)


(define-struct static-interface (dynamic members)
  #:omit-define-syntaxes
  #:property prop:procedure
             (lambda (self stx)
               (syntax-case stx ()
                 [(ifname . args)
                  (datum->syntax stx (cons #'(#%expression ifname) #'args) stx)]
                 [ifname
                  (identifier? #'ifname)
                  (static-interface-dynamic self)])))

(define-struct raw-checked-binding (dynamic iface)
  #:omit-define-syntaxes
  #:property prop:procedure
             (lambda (self stx)
               (syntax-case stx (set!)
                 [(set! var expr)
                  #`(let ([newval expr])
                      (unless (is-a? newval #,(static-interface-dynamic
                                               (raw-checked-binding-iface self)))
                        (error 'check "interface check failed on: ~e" newval))
                      (set! #,(raw-checked-binding-dynamic self) newval))]
                 [(var . args)
                  (datum->syntax stx (cons #'(#%expression var) #'args) stx)]
                 [var
                  (identifier? #'var)
                  (raw-checked-binding-dynamic self)]
                 [else
                  (raise-syntax-error #f "oops" stx)])))

(define (make-checked-binding dynamic iface)
  (make-set!-transformer
   (make-raw-checked-binding dynamic iface)))

(define (checked-binding? x)
  (and (set!-transformer? x)
       (raw-checked-binding? (set!-transformer-procedure x))))

(define (checked-binding-dynamic x)
  (raw-checked-binding-dynamic (set!-transformer-procedure x)))

(define (checked-binding-iface x)
  (raw-checked-binding-iface (set!-transformer-procedure x)))


(define-struct interface-expander (proc)
  #:omit-define-syntaxes)


;; Syntax

(define-syntax-class static-interface
  (pattern x
           #:declare x (static-of 'static-interface static-interface?)
           #:with value #'x.value))

(define-syntax-class checked-binding
  (pattern x
           #:declare x (static-of 'checked-binding checked-binding?)
           #:with value #'x.value))


(define-syntax-class interface-expander
  (pattern x
           #:declare x (static-of 'interface-expander interface-expander?)
           #:with value #'x.value))

(define-syntax-class method-entry
  (pattern method:id
           #:with methods (list #'method))
  (pattern (macro:interface-expander . args)
           #:with methods
                  (apply append
                         (for/list ([m ((interface-expander-proc #'macro.value)
                                        #'(macro . args))])
                           (syntax-parse m
                             [m:method-entry #'m.methods])))))