;;;; source-registration.scm
;;;; Kon Lovett, Sep '23
;;;; Kon Lovett, Feb '17
;;;; Kon Lovett, Oct '09

(module source-registration

(;export
  make-source-registration
  source-registration? check-source-registration error-source-registration
  @source-registration-key
  @source-registration-ref @source-registration-deref!
  @source-registration-register!)

(import scheme
  (chicken base)
  (chicken type)
  (only (srfi 1) alist-delete!)
  (only type-checks-basic define-check+error-type)
  (only type-checks-atoms check-symbol)
  (only type-checks-structured check-list check-procedure))

;;;

(include-relative "srfi-27-common-types")

(: make-source-registration (source-registration-name list -> source-registration))
(: source-registration? (* -> boolean : source-registration))
(: check-source-registration ((or false symbol string) * #!optional (or symbol string) -> source-registration))
(: error-source-registration ((or false symbol string) * #!optional (or symbol string) -> void))
(: @source-registration-key (source-registration -> procedure))
(: @source-registration-ref (source-registration -> procedure))
(: @source-registration-deref! (source-registration -> procedure))
(: @source-registration-register! (source-registration -> procedure))

;;; Utilities

(define (alist-keys alist) (map car alist))
(define (alist-values alist) (map cdr alist))

;;;

(: *make-source-registration (source-registration-name alist procedure procedure procedure procedure -> source-registration))
(: *source-registration-name (source-registration -> source-registration-name))
(: *source-registration-sources (source-registration -> alist))
(: *source-registration-sources-set! (source-registration alist -> void))

(define-record-type source-registration
  (*make-source-registration nam srcs keys ref deref! reg!)
  source-registration?
  (nam    *source-registration-name)
  (srcs   *source-registration-sources *source-registration-sources-set!)
  (keys   @source-registration-key)
  (ref    @source-registration-ref)
  (deref! @source-registration-deref!)
  (reg!   @source-registration-register!) )

(define-check+error-type source-registration)

;;

(define (make-source-registration name sources)
  (letrec ((reg
            (*make-source-registration
              ;
              (check-symbol 'make-source-registration name)
              ;
              (check-list 'make-source-registration sources)
              ;
              (lambda ()
                (alist-keys (*source-registration-sources reg)) )
              ;
              (lambda (key)
                (alist-ref
                  (check-symbol 'source-registration-ref key)
                  (*source-registration-sources reg)
                  eq?
                  #f) )
              ;
              (lambda (key)
                (*source-registration-sources-set!
                  reg
                  (alist-delete!
                    (check-symbol 'source-registration-deref! key)
                    (*source-registration-sources reg)
                    eq?)) )
              ;
              (lambda (key ctor)
                (*source-registration-sources-set!
                  reg
                  (alist-update!
                    (check-symbol 'source-registration-register! key)
                    (check-procedure 'source-registration-register! ctor)
                    (*source-registration-sources reg)
                    eq?)))) ) )
    reg ) )

) ;module source-registration