;;;; interfaces.scm


(module interfaces ((interface unimplemented)
		    (implementation unimplemented))
  (import scheme chicken)

(use records)



;;; (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 x r c)
  (let* ((iname (cadr x))
	 (defs (cddr x))
	 (defnames (map car defs))
	 (%begin (r 'begin))
	 (%define (r 'define))
	 (%lambda (r 'lambda))
	 (%make-record-type (r 'make-record-type))
	 (%record-constructor (r 'record-constructor))
	 (%record-predicate (r 'record-predicate))
	 (%record-accessor (r 'record-accessor))
	 (%quote (r 'quote))
	 (%qiname `(,%quote ,iname))
	 (constructor (string->symbol (conc "make-" iname)))
	 (predicate (r (string->symbol (conc iname "?"))))
	 (base-make (r 'base-make)))
    `(,%begin
      (,%define 
       ,iname
       (,%make-record-type 
	,%qiname
	(,%quote ,defnames)))
      (,%define ,predicate (,%record-predicate ,iname))
      (,%define 
       ,constructor
       (let ((,constructor (,%record-constructor ,iname (,%quote ,defnames))))
	 (,%lambda (#!key ,@defs)
		   (,constructor ,@defnames))))
      ,@(map (lambda (def)
	       `(,%define ,(car def) (,%record-accessor ,iname (,%quote ,(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 x r c)
  (let* ((name (cadr x))
	(defs (cddr x)) 
	(%constructor (string->symbol (conc "make-" name))))
    `(,%constructor
      ,@(append-map
	 (lambda (def)
	   (list (string->keyword (symbol->string (car def)))
		 (cadr def)))
	 defs) ) ) )

)