;;;; 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)
(use
  (only data-structures conc)
  (only lolevel object-become!)
  (only type-checks
    check-procedure check-cardinal-fixnum
    define-check+error-type))

(declare
  (bound-to-procedure
    ##sys#lambda-decoration
    ##sys#decorate-lambda))

;;;

;;

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

;;

(: update-lambda-decoration! (procedure procedure procedure -> procedure))
;
(define (update-lambda-decoration! proc pred decr)
  (##sys#decorate-lambda
    proc
    pred
    (lambda (proc i)
      (##sys#setslot proc i (decr (##sys#slot proc i)))
      proc)) )

(: procedure-become (procedure procedure -> void))
;
(define (procedure-become old new)
  (object-become! `((,old . ,new))) )

;;

(: decorated-lambda? (procedure procedure --> boolean))
;
(define (decorated-lambda? proc pred)
  (and
    (procedure? proc)
    (->boolean
      (##sys#lambda-decoration
        proc
        (check-procedure 'decorated-lambda? pred 'predicate)))) )

(: lambda-decoration (procedure procedure --> *))
;
(define (lambda-decoration proc pred)
  (##sys#lambda-decoration
    (check-procedure 'lambda-decoration proc 'procedure)
    (check-procedure 'lambda-decoration pred 'predicate)) )

(: decorate-lambda (procedure procedure procedure -> procedure))
;
(define (decorate-lambda proc pred decr)
  (update-lambda-decoration!
    (check-procedure 'decorate-lambda proc 'procedure)
    (check-procedure 'decorate-lambda pred 'predicate)
    (check-procedure 'decorate-lambda decr 'decorator)) )

;;;

;;

(define-type procedure-decorator (struct procedure-decorator))

(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)) )

;;

(: make-procedure-decorator (procedure procedure procedure #!rest -> procedure-decorator))
;
(define (make-procedure-decorator pred decr retr #!key (initializer #f) (replace? #f))
  (when initializer (check-procedure 'make-procedure-decorator initializer))
  (*make-procedure-decorator
    (check-procedure 'make-procedure-decorator pred 'predicate)
    (check-procedure 'make-procedure-decorator decr 'decorator)
    (check-procedure 'make-procedure-decorator retr 'retriever)
    initializer
    replace?) )

(: procedure-decorator-getter-and-setter (procedure -> procedure))
;
(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)))) )

;;

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

(: procedure-decoration (procedure procedure-decorator #!rest -> *))
;
(define (procedure-decoration proc dctr . args)
  ((procedure-decorator-retriever (check-procedure-decorator 'procedure-decoration dctr))
    (check-procedure 'procedure-decoration proc)
    args) )

(: decorate-procedure (procedure procedure-decorator #!rest -> procedure))
;
(define (decorate-procedure proc dctr . args)
  ((procedure-decorator-mutator (check-procedure-decorator 'decorate-procedure dctr))
    (check-procedure 'decorate-procedure proc)
    args) )

;;;

;; A simple procedure decorator

(: make-procedure-extender (* -> 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 (hypen-name 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 (
        (_: (rnm ':))
        (_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?))
        (_procedure-decorator (rnm 'procedure-decorator')) )
      (let (
        (?tag (cadr frm))
        (?rest (cddr frm)) )
        (let-optionals ?rest (
          (?getrname (hypen-name ?tag 'decoration))
          (?predname (hypen-name ?tag 'decorated?)))
          (let (
            (dctrname (hypen-name ?tag 'decorator)) )
            `(,_begin
               (,_: ,dctrname (struct ,_procedure-decorator))
               (,_define ,dctrname (,_make-procedure-extender ',?tag))
               (,_: ,?getrname procedure)
               (,_define ,?getrname (,_procedure-decorator-getter-and-setter ,dctrname))
               (,_: ,?predname (* -> boolean : procedure))
               (,_define ,?predname (cut ,_decorated-procedure? <> ,dctrname)) ) ) ) ) ) ) ) )

) ;module procedure-decoration