lru-cache/private/lru-cache.rkt

#lang racket/base

(require racket/contract
         )

(provide make-lru
         lru?
         lru-max-count
         set-lru-max-count!
         lru-expires?
         lru-expire
         set-lru-expire!
         lru-has?
         lru-add!
         lru-count
         lru-empty?
         lru->list
         lru-clear
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Struct
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-struct lru*
  (cache
   compare
   [max-count #:mutable]
   [expire-in-seconds #:mutable]
   sem
   )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (max-count? c)
  (and (integer? c) (> c 0)))

(define (larger-equal0? c)
  (and (integer? c) (>= c 0)))

(define (cmp-procedure? cmp-f)
  (procedure? cmp-f))

(define (expire? e)
  (or (eq? e #f) (max-count? e)))

(define (find-and-bubble count max-count e cache cmp expire-s current-s el)
  (if (or (null? cache)
          (>= count max-count))
      '()
      (let ((front (car cache)))
        (if (and (not (eq? expire-s #f))
                 (< (cadr front) expire-s))
            (find-and-bubble count max-count e (cdr cache) cmp expire-s current-s el)
            (if (cmp e (car front))
                (find-and-bubble count max-count e (cdr cache) cmp expire-s current-s (car front))
                (cons front
                      (find-and-bubble (+ count 1) max-count
                                       e (cdr cache) cmp expire-s current-s el))
                )
            )
        )
      )
  )

(define (find cache cmp-f el)
  (if (null? cache)
      #f
      (if (cmp-f el (caar cache))
          #t
          (find (cdr cache) cmp-f el)
          )
      )
  )

(define (cleanup-expired lru)
  (if (eq? (lru*-expire-in-seconds lru) #f)
      'done
      (let ((expire-s (- (current-seconds) (lru*-expire-in-seconds lru)))
            (lcache (unbox (lru*-cache lru))))
        (letrec ((f (λ (cache)
                      (if (null? cache)
                          '()
                          (if (< (cadar cache) expire-s)
                              (f (cdr cache))
                              (cons (car cache) (f (cdr cache))))))))
          (set-box! (lru*-cache lru) (f lcache)))
        'cleaned)))

(define (find-and/or-add lru el)
  (let ((ncache (find-and-bubble
                 1 (lru*-max-count lru)
                 el (unbox (lru*-cache lru))
                 (lru*-compare lru)
                 (if (eq? (lru*-expire-in-seconds lru) #f)
                     #f
                     (- (current-seconds) (lru*-expire-in-seconds lru)))
                 (current-seconds)
                 #f)))
    (set-box! (lru*-cache lru) (cons (list el (current-seconds)) ncache)))
  lru)

(define-syntax with-lock
  (syntax-rules ()
    ((_ lru code ...)
     (dynamic-wind
      (λ () (semaphore-wait (lru*-sem lru)))
      (λ () (begin code ...))
      (λ () (semaphore-post (lru*-sem lru)))
      )
     )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define/contract (make-lru max-count #:cmp [compare equal?] #:expire [expire-in-seconds #f])
  (->* (max-count?) (#:cmp cmp-procedure? #:expire expire?) lru*?)
  (let ((sem (make-semaphore 1)))
    (make-lru* (box '()) compare max-count expire-in-seconds sem)))

(define/contract (lru-has? lru el)
  (-> lru*? any/c boolean?)
  (with-lock lru
    (cleanup-expired lru)
    (find (unbox (lru*-cache lru)) (lru*-compare lru) el)
    )
  )

(define/contract (lru-add! lru el)
  (-> lru*? any/c lru*?)
  (with-lock lru
    (find-and/or-add lru el)
    lru))

(define/contract (lru-clear lru)
  (-> lru*? lru*?)
  (with-lock lru
    (set-box! (lru*-cache lru) '())
    lru))

(define/contract (lru->list lru #:with-expire [we #f])
  (->* (lru*?) (#:with-expire boolean?) list?)
  (with-lock lru
    (cleanup-expired lru)
    (let ((c (current-seconds)))
      (map (λ (e)
             (if we
                 (list (car e) (- c (cadr e)))
                 (car e))) (unbox (lru*-cache lru))))
    )
  )

(define/contract (lru-empty? l)
  (-> lru*? boolean?)
  (= (lru-count l) 0))

(define/contract (lru-count lru)
  (-> lru*? larger-equal0?)
  (with-lock lru
    (cleanup-expired lru)
    (length (unbox (lru*-cache lru))))
  )

(define (lru? l)
  (lru*? l))

(define/contract (lru-max-count l)
  (-> lru*? max-count?)
  (with-lock l (lru*-max-count l)))

(define/contract (lru-expire l)
  (-> lru*? expire?)
  (with-lock l (lru*-expire-in-seconds l)))

(define/contract (set-lru-max-count! l c)
  (-> lru*? max-count? lru*?)
  (with-lock l
        (set-lru*-max-count! l c)
        l))

(define/contract (set-lru-expire! l e)
  (-> lru*? expire? lru*?)
  (with-lock l
    (set-lru*-expire-in-seconds! l e)
    l))

(define/contract (lru-expires? l)
  (-> lru*? boolean?)
  (with-lock l
    (let ((e (lru*-expire-in-seconds l)))
      (if e
          (and (integer? e) (> e 0))
          #f))))