;;;; procedure-decoration.scm  -*- Hen -*-

(module procedure-decoration

  (;export
    ;; Checked API
    decorated-lambda?
    lambda-decoration
    decorate-lambda
    ;; 
    make-procedure-decorator
    procedure-decorator?
    procedure-decorator-getter-and-setter
    decorated-procedure?
    procedure-decoration
    decorate-procedure
    ;; Tagged API
    make-procedure-extender
    define-procedure-extender)

  (import scheme
          chicken
          (only data-structures conc)
          (only type-checks
                check-procedure check-cardinal-fixnum
                define-check+error-type))

  (require-library data-structures type-checks)

;;;

;;

(define (->boolean obj) (and obj #t))

;;

(define (update-lambda-decoration! proc pred decr)
  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
  (##sys#decorate-lambda proc pred setter) )

(define (procedure-become old new) (##sys#become! `((,old . ,new))))

;;

(define (check-procedure2 loc obj1 obj2)
  (check-procedure loc obj1)
  (check-procedure loc obj2) )

(define (check-procedure3 loc obj1 obj2 obj3)
  (check-procedure2 loc obj1 obj2)
  (check-procedure loc obj3) )

;;

(define (decorated-lambda? proc pred)
  (check-procedure2 'decorated-lambda? proc pred)
  (->boolean (##sys#lambda-decoration proc pred)) )

(define (lambda-decoration proc pred)
  (check-procedure2 'lambda-decoration proc pred)
  (##sys#lambda-decoration proc pred) )

(define (decorate-lambda proc pred decr)
  (check-procedure3 'decorate-lambda proc pred decr)
  (update-lambda-decoration! proc pred decr) )

;;;

;;

(define-record-type procedure-decorator
  (**make-procedure-decorator pred mutr retr)
  procedure-decorator?
  (pred procedure-decorator-predicate)
  (mutr procedure-decorator-mutator)
  (retr procedure-decorator-retriever))

;;

(define-check+error-type procedure-decorator)

;;

(define ((*mutator-initializer decr) . args) (apply decr (void) args))

(define ((*decorator-maker pred intr) proc args)
  (update-lambda-decoration! proc pred (lambda (obj) (apply intr args))) )

(define ((*decorator-replacer makr) proc args)
  (procedure-become proc (makr proc args)) )

(define (*decorator-initializer pred intr rplc?)
  (let ((makr (*decorator-maker pred intr)))
    (if rplc? (*decorator-replacer makr)
        makr ) ) )

(define ((*decorator-mutator pred decr dctr-intr) proc args)
  (if (not (##sys#lambda-decoration proc pred)) (dctr-intr proc args)
      (update-lambda-decoration! proc pred (lambda (obj) (apply decr obj args))) ) )

;;

(define (*procedure-decorator-mutator pred decr intr rplc?)
  (*decorator-mutator
    pred
    decr
    (*decorator-initializer pred (or intr (*mutator-initializer decr)) rplc?)) )

(define ((*procedure-decorator-retriever pred retr) proc args)
  (and-let* ((deco (##sys#lambda-decoration proc pred)))
    (apply retr deco args) ) )

(define (*make-procedure-decorator pred decr retr intr rplc?)
  (**make-procedure-decorator
    pred
    (*procedure-decorator-mutator pred decr intr rplc?)
    (*procedure-decorator-retriever pred retr)) )

;;

(define (make-procedure-decorator pred decr retr #!key (initializer #f) (replace? #f))
  (check-procedure3 'make-procedure-decorator pred decr retr)
  (when initializer (check-procedure 'make-procedure-decorator initializer))
  (*make-procedure-decorator pred decr retr initializer replace?) )

(define (procedure-decorator-getter-and-setter dctr)
  (check-procedure-decorator 'procedure-decorator-getter-and-setter dctr)
  (getter-with-setter
    (lambda (proc) ((procedure-decorator-retriever dctr) proc '()))
    (lambda (proc obj) ((procedure-decorator-mutator dctr) proc `(,obj)))) )

;;

(define (decorated-procedure? proc dctr)
  (check-procedure 'decorated-procedure? proc)
  (check-procedure-decorator 'decorated-procedure? dctr)
  (->boolean (##sys#lambda-decoration proc (procedure-decorator-predicate dctr))) )

(define (procedure-decoration proc dctr . args)
  (check-procedure 'procedure-decoration proc)
  (check-procedure-decorator 'procedure-decoration dctr)
  ((procedure-decorator-retriever dctr) proc args) )

(define (decorate-procedure proc dctr . args)
  (check-procedure 'decorate-procedure proc)
  (check-procedure-decorator 'decorate-procedure dctr)
  ((procedure-decorator-mutator dctr) proc args) )

;;;

;; A simple procedure decorator

(define (make-procedure-extender tag)
  (*make-procedure-decorator
    (lambda (obj) (and (pair? obj) (eq? tag (car obj))))
    (lambda (old new) (cons tag new))
    cdr
    #f
    #t) )

;; Define procedures for getting, setting, & testing a decorated procedure

(define-for-syntax (procdecrname tag suff) (string->symbol (conc tag #\- suff)))

; TAG [GETTER-NAME [PREDICATE-NAME]]

(define-syntax define-procedure-extender
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_define (rnm 'define))
            (_set! (rnm 'set!))
            (_begin (rnm 'begin))
            (_make-procedure-extender (rnm 'make-procedure-extender))
            (_procedure-decorator-getter-and-setter (rnm 'procedure-decorator-getter-and-setter))
            (_decorated-procedure? (rnm 'decorated-procedure?)) )
      (let ((?tag (cadr frm))
            (?rest (cddr frm)) )
        (let-optionals ?rest ((?getrname (procdecrname ?tag 'decoration))
                              (?predname (procdecrname ?tag 'decorated?)))
          (let ((dctrname (procdecrname ?tag 'decorator)))
            `(,_begin
               (,_define ,dctrname (,_make-procedure-extender ',?tag))
               (,_define ,?getrname (,_procedure-decorator-getter-and-setter ,dctrname))
               (,_define ,?predname (cut ,_decorated-procedure? <> ,dctrname)) ) ) ) ) ) ) ) )

) ;module procedure-decoration