(define-module util.history
  (use util.list)
  (export make-history))
(select-module util.history)

;; Simple history-list data-type.  Unlike other basic data-types a
;; history list is inherently stateful, and therefore here represented
;; as a dispatch closure.  The basic operations are 'push, 'back and
;; 'forward.

(define (make-history . keys)
  (define (load-history file)
    (with-error-handler
        (lambda (err) (warn "error loading history: ~S" err) '())
      (lambda () (and (file-exists? file) (with-input-from-file file read)))))
  (let* ((file (get-keyword :file keys #f))
         (history (get-keyword* :init keys (or (and file (load-history file)) '())))
         (future '())
         (limit (get-keyword :limit keys #f))
         (count (length history)))
    (define (reset)
      (when (pair? future)
        (if (pair? history)
          (set! history (cons (car history) (append future (cdr history))))
          (set! history future))
        (set! future '())))
    (lambda (command . args)
      (case command
        ((push)     (reset) (push! history (car args)))
        ((pop)      (if (pair? history)
                      (pop! history)
                      (get-optional args #f)))
        ((set)      (set-car! history (car args)))
        ((current)  (if (pair? history) (car history) (get-optional args #f)))
        ((back)
         (cond
           ((and (pair? history) (pair? (cdr history)))
            (push! future (pop! history))
            (car history))
           (else
            (get-optional args #f))))
        ((forward)
         (cond
           ((pair? future)
            (push! history (pop! future))
            (car history))
           (else
            (get-optional args #f))))
        ((empty?)         (or (null? history) (null? (cdr history))))
        ((empty-forward?) (null? future))
        ((delete)         (reset) (set! history (delete! (car args) history)))
        ((delete-back)    (set! history (delete! (car args) history)))
        ((delete-forward) (set! future (delete! (car args) future)))
        ((remove)         (reset) (set! history (remove! (car args) history)))
        ((remove-back)    (set! history (remove! (car args) history)))
        ((remove-forward) (set! future (remove! (car args) future)))
        ((list)           (reset) history)
        ((list-back)      history)
        ((list-forward)   future)
        ((reset)          (reset))
        ((clear)          (set! history '()) (set! future '()))
        ((save)           (let ((f (get-optional args file)))
                            (with-output-to-file f (cut write history))))
        (else
         (error "unknown history command: ~S" command))))))

(provide "util/history")