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->list
         lru-clear
         )

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

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

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

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

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

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

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

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

(define/contract (lru->list lru #:with-expire [we #f])
  (->* (lru*?) (#:with-expire boolean?) list?)
  (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-count lru)
  (-> lru*? larger-equal0?)
  (cleanup-expired lru)
  (length (unbox (lru*-cache lru))))

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

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

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

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

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

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