(define-record-type <cache>
  (%make-cache name mailbox t index state miss hit fulfil valid? delete)
  cache?
  (name cache-name)
  (mailbox cache-mailbox)
  (t cache-thread set-cache-thread!)
  (index cache-index)
  (state cache-state)
  (miss cache-miss)
  (hit cache-hit)
  (fulfil cache-fulfil)
  (valid? cache-valid?)
  (delete cache-delete))

(define (default-hit-handler cache value-state) #f)

(define (default-fulfil-handler cache value-state values-or-false) #f)

(define (default-delete-handler cache-state value-state) #f)

(define (make-cache name eq state miss hit fulfil valid? delete)
  (assert (procedure? miss))
  (assert (procedure? valid?))
  (%make-cache
   name
   (make-mailbox name) #f (make-hash-table eq)
   state miss
   (or hit default-hit-handler)
   (or fulfil default-fulfil-handler)
   valid?
   (or delete default-delete-handler)))

(define-inline (check-cache! cache)
  (or (cache-thread cache)
      (set-cache-thread!
       cache
       (thread-start!
	(make-thread
	 (lambda ()
	   (let loop ()
	     (guard
	      (ex (else (log-condition (cache-name cache) ex)
			(loop)))
	      (let loop ((request (receive-message! (cache-mailbox cache))))
		(send-message! (car request) (call-with-values (cdr request) list))
		(loop (receive-message! (cache-mailbox cache)))))))
	 (dbgname (cache-name cache) "~a-table"))))))

(define (cache-size cache) (hash-table-size (cache-index cache)))

(define-inline (cache-lookup cache key)
  (hash-table-ref/default (cache-index cache) key #f))

(define-inline (cache-lookup/default cache key default)
  (hash-table-ref/default (cache-index cache) key default))

(define-record-type <cache-entry>
  (make-cache-entry mutex avail value)
  cache-entry?
  (mutex cache-entry-mutex)
  (avail cache-entry-avail)
  (value cache-entry-value %set-entry-value!))

(define (set-entry-value! entry old new)
  (with-mutex
   (cache-entry-mutex entry)
   (if (eq? old (cache-entry-value entry))
       (begin
	 (%set-entry-value! entry new)
	 (condition-variable-broadcast! (cache-entry-avail entry))))))

(define-record-type <cache-value>
  (make-cache-value state avail values thunk)
  cache-value?
  (state cache-value-state)
  (avail cache-value-avail)
  (values cache-value-values)
  (thunk cache-value-thunk))

(define (with-cache-index cache thunk)
  (check-cache! cache)
  (let ((m (make-mailbox (cache-name cache))))
    (send-message! (cache-mailbox cache) (cons m thunk))
    (apply values (receive-message! m))))

(define (cache-find! cache key thunk)
  (hash-table-ref
   (cache-index cache) key
   (lambda ()
     (define entry (make-cache-entry
		    (make-mutex (dbgname key "~a-entry"))
		    (make-condition-variable key)
		    (make-cache-value
		     ((cache-miss cache) (cache-state cache) key)
		     (make-mutex (dbgname key "~a-value"))
		     '() thunk)))
     (hash-table-set! (cache-index cache) key entry)
     entry)))

(define-inline (cache-find cache key thunk)
  (hash-table-ref
   (cache-index cache) key
   (lambda ()
     (with-cache-index cache (lambda () (cache-find! cache key thunk))))))

(define-inline (cache-value-fulfiled! cache entry values)
  ((cache-fulfil cache) cache (cache-value-state (cache-entry-value entry)) values))

;; Compute the value, run trigger and signal completion.

(define (cache-entry-force! cache key entry old)
  (guard
   (exception
    (else (let ((new (make-cache-value
		      (cache-value-state old)
		      raise
		      (list (if (condition? exception) exception
				(make-condition
				 &message 'message
				 (format "~a ~a ~a" key (cache-value-thunk old) exception))))
		      (cache-value-thunk old))))
	    (cache-value-fulfiled! cache entry #f)
	    (set-entry-value! entry old new)
	    new)))
   (let ((new (call-with-values (cache-value-thunk old)
		(lambda result
		  (make-cache-value
		   (cache-value-state old)
		   values result
		   (cache-value-thunk old))))))
     (cache-value-fulfiled! cache entry (cache-value-values new))
     (set-entry-value! entry old new)
     new)))

;; Arrange to compute if needed the value and return it.

(define-inline (!cache-entry-force cache key entry)
  (thread-start!
   (make-thread
    (lambda ()
      (let* ((value (cache-entry-value entry))
	     (avail (cache-value-avail value)))
	(if (and (mutex? avail) (not (mutex-owner avail)))
	    (with-mutex
	     avail
	     (if (mutex? (cache-value-avail value))
		 (cache-entry-force! cache key entry value))))))
    (dbgname key "~a-ref"))))

;; Wait for computed value and return it.

(define (cache-entry-wait cache key entry)
  (guard
   (ex (else (if (eq? (mutex-state (cache-entry-mutex entry)) (current-thread))
		 (mutex-unlock! (cache-entry-mutex entry)))
	     (raise ex)))
   (let loop ()
     (mutex-lock! (cache-entry-mutex entry))
     (let* ((value (cache-entry-value entry))
	    (avail (cache-value-avail value)))
       (if (procedure? avail)
	   (begin
	     (mutex-unlock! (cache-entry-mutex entry))
	     (apply avail (cache-value-values value)))
	   (begin
	     (if (not (mutex-owner avail))
		 (!cache-entry-force cache key entry))
	     (mutex-unlock! (cache-entry-mutex entry) (cache-entry-avail entry))
	     (let* ((value (cache-entry-value entry))
		    (avail (cache-value-avail value)))
	       (if (procedure? avail)
		   (apply avail (cache-value-values value))
		   (loop)))))))))

(define-inline (cache-entry-ref cache key entry)
  (let* ((value (cache-entry-value entry))
	 (avail (cache-value-avail value)))
    (if (procedure? avail)
	(if ((cache-valid? cache) (cache-value-state value))
	    (begin
	      ((cache-hit cache) cache (cache-value-state value))
	      (apply avail (cache-value-values value)))
	    (begin
	      (with-mutex
	       (cache-entry-mutex entry)
	       (let* ((value (cache-entry-value entry))
		      (avail (cache-value-avail value)))
		 (if (and (procedure? avail)
			  ((cache-valid? cache) (cache-value-state value)))
		     ((cache-hit cache) cache (cache-value-state value))
		     (begin
		       ((cache-delete cache) (cache-state cache) (cache-value-state value))
		       (%set-entry-value!
			entry
			(make-cache-value
			 ((cache-miss cache) (cache-state cache) key)
			 (make-mutex (dbgname key "~a-value")) #f
			 (cache-value-thunk value)))))))
	      (cache-entry-wait cache key entry)))
	(cache-entry-wait cache key entry))))

(define-inline (cache-entry-ref/default cache key entry default)
  (let* ((value (cache-entry-value entry))
	 (avail (cache-value-avail value)))
    (if (procedure? avail)
	(if ((cache-valid? cache) (cache-value-state value))
	    (begin
	      ((cache-hit cache) cache (cache-value-state value))
	      (apply avail (cache-value-values value)))
	    (with-mutex
	     (cache-entry-mutex entry)
	     (let* ((value (cache-entry-value entry))
		    (avail (cache-value-avail value)))
	       (if (and (procedure? avail)
			((cache-valid? cache) (cache-value-state value)))
		   (begin
		     ((cache-hit cache) cache (cache-value-state value))
		     (apply avail (cache-value-values value)))
		   (begin
		     ((cache-delete cache) (cache-state cache) (cache-value-state value))
		     (%set-entry-value!
		      entry
		      (make-cache-value
		       ((cache-miss cache) (cache-state cache) key)
		       (make-mutex (dbgname key "~a-value")) #f
		       (cache-value-thunk value)))
		     (!cache-entry-force cache key entry)
		     default)))))
	(begin
	  (if (not (mutex-owner avail))
	      (!cache-entry-force cache key entry))
	  default))))

(define (cache-state-update! cache state proc)
  (with-cache-index cache (lambda () (proc (cache-state cache) state))))

(define (raise-deleted-condition message)
  (raise (make-condition &message 'message message)))

(define (cache-entry-delete! cache key entry0)
  (receive
   (entry old)
   (with-cache-index
    cache
    (lambda ()
      (let ((entry (hash-table-ref/default (cache-index cache) key #f)))
	(if entry
	    (let ((value (cache-entry-value entry0)))
	      (if (eq? entry entry0)
		  (hash-table-delete! (cache-index cache) key))
	      ((cache-delete cache) (cache-state cache) (cache-value-state value))
	      (values entry0 value))
	    (values #f #f)))))
   (if entry (set-entry-value!
	      entry old
	      (make-cache-value
	       (cache-value-state old)
	       raise
	       (list (make-condition &message 'message
				     (format "~a[~a] deleted" (cache-name cache) key)))
	       (cache-value-thunk old))))))

(define (%cache-set! cache key job . res)
  (let ((entry (cache-lookup cache key)))
    (if entry
	(let* ((value (cache-entry-value entry))
	       (new (make-cache-value
		     (cache-value-state value)
		     job res
		     (cache-value-thunk value))))
	  (with-mutex
	   (cache-entry-mutex entry)
	   (if (eq? value (cache-entry-value entry))
	       (begin
		 ((cache-delete cache) (cache-state cache) (cache-value-state value))
		 (cache-value-fulfiled! cache entry
					(and (eq? job values) (cache-value-values new)))
		 (%set-entry-value! entry new)
		 (condition-variable-broadcast! (cache-entry-avail entry))))))
	(cache-find! cache key (lambda () (apply job res))))))

;; (cache-set! cache key . job+res)
;;
;; if (null? job+res): remove entry
;; if (null? (cdr job+res)):
;;   (eq? (car job+res) #t): reset to last valid, unfulfiled last thunk
;;   (procedure? (car job+res)): reset to valid, unfilfiled (car job+res)
;; else: set to (apply (car job+res) (cdr job+res))

(define (cache-set! cache key . job+res)  
  (cond
   ((null? job+res)
    (and-let* ((entry (hash-table-ref/default (cache-index cache) key #f)))
	      ;; (!apply cache-entry-delete! (list cache key entry))
	      (cache-entry-delete! cache key entry)))
   ((eq? (car job+res) #t) (cache-invalid! cache key))
   ((null? (cdr job+res)) (cache-invalid! cache key (car job+res)))
   (else (!apply %cache-set! `(,cache ,key . ,job+res)))))

(define (cache-invalid/check! check cache key . thunk)
  (let ((entry (cache-lookup cache key)))
    (if (and entry (check entry))
	(receive
	 (entry old new)
	 (with-cache-index
	  cache
	  (lambda ()
	    (let ((entry (cache-lookup cache key)))
	      (if (and entry (check entry))
		  (let ((old (cache-entry-value entry)))
		    ((cache-delete cache) (cache-state cache) (cache-value-state old))
		    (values
		     entry old
		     (make-cache-value
		      ((cache-miss cache) (cache-state cache) key)
		      (make-mutex (dbgname key "~a-value")) #f
		      (if (pair? thunk) (car thunk) (cache-value-thunk old)))))
		  (values #f #f #f)))))
	 (if entry (set-entry-value! entry old new))
	 entry)
	(begin
	  (if (and (not entry) (pair? thunk))
	      (let ((entry (cache-find cache key (car thunk))))
		(cache-entry-ref/default cache key entry #f)
		entry)
	      entry)))))

;; (cache-invalid! cache key . thunk)
;;
;; Invalidate the cached values.  If there's a running computation,
;; leave it running.  If thunk is given, it's arranged to be called,
;; otherwise default is returned.

(define (cache-invalid! cache key . thunk)
  (define (check entry)
    (and-let* ((val (cache-entry-value entry))
	       (avail (cache-value-avail val))
	       ((not (mutex? avail))))
	      ((cache-valid? cache) (cache-value-state val))))
  (apply cache-invalid/check! check cache key thunk))

;; (cache-invalid/abort! cache key . thunk)
;;
;; Invalidate the cached values and abort any running computation. If
;; thunk is given, it's arranged to be called, otherwise default is
;; returned.

(define (cache-invalid/abort! cache key . thunk)
  (define (check entry)
    (and-let* ((val (cache-entry-value entry))
	       (avail (cache-value-avail val)))
	      (or (mutex? avail)
		  ((cache-valid? cache) (cache-value-state val)))))
  (apply cache-invalid/check! check cache key thunk))

;; (cache-ref/default cache key thunk default)
;;
;; Returns current cached value or default.  Does never wait.  If
;; thunk is given, it's arranged to be called, otherwise default is
;; returned.

(define (cache-ref/default cache key thunk default)
  (if thunk
      (cache-entry-ref/default cache key (cache-find cache key thunk) default)
      (let ((entry (cache-lookup cache key)))
	(if entry (cache-entry-ref/default cache key entry default) default))))

;; (cache-ref cache key thunk . default)
;;
;; If default is given falls back to cache-ref/default.  Otherwise
;; returns the last valid cached values.  Always waits for valid
;; values, possibly arranging thunk to produce them.

(define (cache-ref cache key thunk . default)
  (if (pair? default)
      (cache-ref/default cache key thunk (car default))
      (cache-entry-ref cache key (cache-find cache key thunk))))

(define (cache-reref cache key thunk)
  (cache-entry-ref cache key (cache-invalid! cache key thunk)))

;; (cache-fold cache f nil)
;;
;; fold f(key value nil) over cache content

(define (cache-fold cache f nil)
  (hash-table-fold (cache-index cache)
		   (lambda (k v nil)
		     (if (eq? (cache-value-avail (cache-entry-value v)) values)
			 (f k (car (cache-value-values (cache-entry-value v))) nil)
			 nil))
		   nil))

;; (cache-cleanup! cache [valid?] [used?])
;;
;; valid? : default: (cache-valid cache)
;; used?  : no default; of cache result values arity.
;;
;; Remove all entries, which are not "valid?" and "used?" (if given).
;; Used is applied to the cached values.

(define (cache-cleanup! cache . predicates)
  (let ((valid? (if (and (pair? predicates) (procedure? (car predicates)))
		    (car predicates) (cache-valid? cache)))
	(used? (if (and (pair? predicates) (pair? (cdr predicates)))
		   (cadr predicates) #t))
	(del (cache-delete cache)))
    (for-each
     (lambda (key+entry)
       (define key (car key+entry))
       (define entry (cdr key+entry))
       ;; This appears to be questionable.  We first signal
       ;; the evaluation of an uncached thunk, maybe for no good reason -??-
       ;; then we remove the entry.
       ;;  Questionable: there where pending references when forcing entries.
       ;;    and no good explanation...
       (define value (cache-entry-value entry))
       (if (not (procedure? (cache-value-avail value)))
	   (set-entry-value!
	    entry value
	    (make-cache-value
	     (cache-value-state value)
	     raise
	     (list (make-condition
		    &message 'message
		    (format "~a[~a] deleted in cleanup" (cache-name cache) key)))
	     (cache-value-thunk value)))))
     (with-cache-index
      cache
      (lambda ()
	(let* ((index (cache-index cache))
	       (removable (hash-table-fold
			   index
			   (lambda (key entry init)
			     (if (let ((value (cache-entry-value entry)))
				   (or (mutex? (cache-value-avail value))
				       (and (valid? (cache-value-state value))
					    (or (eq? used? #t)
						(apply used? (cache-value-values value))))))
				 init
				 (begin
				   (guard
				    (ex (else (log-condition (cache-name cache) ex)))
				    (del (cache-state cache) (cache-value-state (cache-entry-value entry))))
				   (cons (cons key entry) init))))
			   '())))
	  (for-each
	   (lambda (key+entry)
	     (hash-table-delete! (cache-index cache) (car key+entry)))
	   removable)
	  removable))))))