;;;; operations.scm


(module operations

    ((object operations:make-object)
     (operation operations:get-handler)
     define-predicate
     define-operation
     define-settable-operation
     join
     print-object
     operation?)

  (import scheme chicken)
  (use srfi-1 lolevel)

(define-syntax object
  (syntax-rules ()
    ((_) (object #f))
    ((_ default methods ...)
     (operations:make-object 
      default 
      (lambda (op)
	(operations:expand-methods op methods ...) ) ) ) ) )

(define-syntax operations:expand-methods
  (syntax-rules ()
    ((_ op) #f)
    ((_ op ((proc . llist) body ...) . more)
     (if (eq? op proc)
	 (lambda llist body ...)
	 (operations:expand-methods op . more) ) ) ) )

(define-syntax operation
  (syntax-rules ()
    ((_) (operation #f))
    ((_ default methods ...)
     (letrec ((opr (object
		    (lambda (self . args)
		      (let* ((handler (operations:get-handler self))
			     (method (and handler (handler opr)))
			     (defaultm default))
			(cond (method (apply method self args))
			      (defaultm (apply defaultm self args))
			      (else (error "operation not handled by object" self)))))
		    ((operation? self) #t)
		    methods ...)))
       opr) ) ) )

(define-syntax define-predicate
  (syntax-rules ()
    ((_ name) (define-operation (name x) #f)) ) )

(define-syntax define-operation
  (syntax-rules ()
    ((_ (name . llist))
     (define name (operation #f)) )
    ((_ (name . llist) x1 body ...)
     (define name (operation (lambda llist x1 body ...)) ) )
    ((_ name)
     (define-operation (name . args)))))

(define-syntax define-settable-operation
  (syntax-rules ()
    ((_ (name . args))
     (define-settable-operation name) )
    ((_ (name . args) x1 body ...)
     (define name
       (let ((the-setter (operation #f)))
         (operation (lambda args x1 body ...)
           ((setter self) the-setter) ) ) ) )
    ((_ name)
     (define name
       (let ((the-setter (operation #f)))
	 (operation #f ((setter self) the-setter)))))))

(define-record t-object handler)

(define (operations:make-object default handler)
  (let ((o (make-t-object handler)))
    (if (procedure? default)
	(extend-procedure default o) 
	o) ) )

(define (operations:get-handler x)
  (cond ((t-object? x) (t-object-handler x))
	((procedure? x) 
	 (let ((data (procedure-data x)))
	   (and data (t-object-handler data)) ) )
	(else #f) ) )

(define-record-printer (t-object x out)
  (print-object x out) )

(define-operation (print-object self #!optional (port (current-output-port)))
  (display "#<t-object>" port) )

(define (join . objects)
  (make-t-object
   (lambda (op)
     (any (lambda (o) ((operations:get-handler o) op)) objects) ) ) )

(define-predicate operation?)

(unless (memq #:setter-operation ##sys#features)
  (set! ##sys#setter (let ((old setter)) (operation old)))
  (set! setter ##sys#setter)
  (register-feature! #:setter-operation))

)