;;;; interfaces.scm


(module interfaces ((interface unimplemented)
		    (implementation unimplemented))
  (import scheme (chicken base))
  (import-for-syntax  (chicken format) (chicken keyword)
                      (only srfi-1 append-map))


;;; (interface INAME DEFINITION ...)
;
;   DEFINITION = (define (NAME . LLIST) [BODY ...])
;              | (define NAME [VALUE])

(define-syntax extract-definitions
  (syntax-rules (define)
    ((_ k name () (defs ...))
     (k name defs ...) )
    ((_ k name ((define (defname . llist)) more ...) (defs ...))
     (extract-definitions
      k name
      (more ...)
      (defs ... (defname (unimplemented 'defname 'name)))))
    ((_ k name ((define (defname . llist) x1 body ...) more ...) (defs ...))
     (extract-definitions
      k name
      (more ...)
      (defs ... (defname (lambda llist x1 body ...)))))
    ((_ k name ((define defname val) more ...) (defs ...))
     (extract-definitions
      k name
      (more ...)
      (defs ... (defname val))))
    ((_ k name ((define defname) more ...) (defs ...))
     (extract-definitions
      k name
      (more ...)
      (defs ... (defname (void)))))))

(define-syntax interface
  (syntax-rules ()
    ((_ name defs ...)
     (extract-definitions create-interface name (defs ...) ()))))

(define-syntax create-interface
  (er-macro-transformer
   (lambda (x r c)
     (let* ((iname (cadr x))
            (defs (cddr x))
            (defnames (map car defs))
            (%begin (r 'begin))
            (%define (r 'define))
            (%lambda (r 'lambda))
            (%define-record (r 'define-record))
            (%quote (r 'quote))
            (constructor (string->symbol (sprintf "make-~A" iname)))
            (base-constructor (string->symbol (sprintf "base-~A" iname))))
       `(,%begin
         (,%define-record ,iname . ,defnames)
         (,%define ,base-constructor ,constructor)
         (,%define 
          ,constructor
            (,%lambda (#!key ,@defs)
                      (,base-constructor ,@defnames)))
         ,@(map (lambda (def)
                  `(,%define ,(car def) ,(string->symbol (sprintf "~A-~A" iname (car def)))))
                defs))))
   ))

(define ((unimplemented def iname) . args)
  (error def "unimplemented interface method" iname args))


;;; (implementation INAME DEFINITION ...) -> IMPLEMENTATION

(define-syntax implementation
  (syntax-rules ()
    ((_ name def ...)
     (extract-definitions create-implementation name (def ...) ()))))

(define-syntax create-implementation
  (er-macro-transformer
   (lambda (x r c)
     (let* ((name (cadr x))
            (defs (cddr x)) 
            (%constructor (string->symbol (sprintf "make-~A" name))))
       `(,%constructor
         ,@(append-map
            (lambda (def)
              (list (string->keyword (symbol->string (car def)))
                    (cadr def)))
            defs) ) ) )
   ))

)