;;;; procedure-decoration.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '24
;;;; Kon Lovett, Jan '08

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

(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)
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import (only (chicken memory representation) object-become!))
(import (only type-checks-basic define-check+error-type))
(import (only type-checks-structured check-procedure)) ;uses argnam

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

(: decorated-lambda? (procedure procedure -> boolean))
(: lambda-decoration (procedure procedure -> *))
(: decorate-lambda (procedure procedure procedure -> procedure))

(: make-procedure-decorator (procedure procedure procedure #!key (initializer (or false procedure)) (replace? *) -> procedure-decorator))
(: decorated-procedure? (procedure procedure-decorator -> boolean))
(: procedure-decorator-getter-and-setter (procedure-decorator -> procedure))
(: procedure-decoration (procedure procedure-decorator #!rest -> *))
(: decorate-procedure (procedure procedure-decorator #!rest -> procedure))

(: make-procedure-extender (* -> procedure-decorator))

;;(std-prelude)

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

;;;

(: update-lambda-decoration! (procedure procedure procedure -> procedure))
(: procedure-become (procedure procedure -> void))

;;

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

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

;;

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

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

(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-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 (_) (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))
  (*make-procedure-decorator
    (check-procedure 'make-procedure-decorator pred 'predicate)
    (check-procedure 'make-procedure-decorator decr 'decorator)
    (check-procedure 'make-procedure-decorator retr 'retriever)
    (and initializer
         (check-procedure 'make-procedure-decorator 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)
  (and (procedure? proc)
       (boolean
         (##sys#lambda-decoration
           proc
           (procedure-decorator-predicate
             (check-procedure-decorator 'decorated-procedure? dctr))))) )

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

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

;;;

;; 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 (hyphen-name tag suff) (symbol-append 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 (hyphen-name ?tag 'decoration))
                              (?predname (hyphen-name ?tag 'decorated?)) )
          (let ((dctrname (hyphen-name ?tag 'decorator)))
            `(,_begin
               ;(,_: ,dctrname (struct ,_procedure-decorator))
               ;(,_: ,?getrname procedure)
               ;(,_: ,?predname (* -> boolean : procedure))
               (,_define ,dctrname (,_make-procedure-extender ',?tag))
               (,_define ,?getrname
                         (,_procedure-decorator-getter-and-setter ,dctrname))
               (,_define ,?predname
                         (cut ,_decorated-procedure? <> ,dctrname)) ) ) ) ) ) ) ) )

) ;module procedure-decoration