Value history implementation

[Neil Jerram]

Well, a value history implementation has been on the Guile wish list
for some time, and I couldn't resist having a go at it.

Here's a sample session to illustrate how it works:

address@hidden neil]$ guile
guile> "test without history"
"test without history"
guile> (use-modules (ice-9 value-history))
guile> (activate-value-history)
guile> "test with history"
##1 "test with history"
guile> (string-append "abd" "hhh")
##2 "abdhhh"
guile> (string-append ##1 ##2)
##3 "test with historyabdhhh"
guile> (string-length ##3)
##4 23
guile> 

The implementation is below.  All comments, suggestions and feedback
are very welcome.

        Neil


Implementation consists of a new module (ice-9 value-history) and a
small patch to boot-9.scm.  Patch first.

Index: boot-9.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/boot-9.scm,v
retrieving revision 1.216
diff -r1.216 boot-9.scm
2506a2507,2508
> (define before-print-value-hook (make-hook 1))
> (define after-print-value-hook (make-hook 1))
2588a2591
>                                             (run-hook before-print-value-hook 
> result)
2590c2593,2594
<                                             (newline))))))
---
>                                             (newline)
>                                             (run-hook after-print-value-hook 
> result))))))

;;;; value-history.scm --- value history for use in Guile REPL
;;;;
;;;;    Copyright (C) 2000 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; 

(define-module (ice-9 value-history))

;;; A straightforward ring buffer implementation.

(define (make-ring k)
  (let ((ring (make-vector (+ k 1) #f)))
    (vector-set! ring 0 1)
    ring))

(define (ring-add ring val)
  (let ((next-slot-index (vector-ref ring 0)))
    (vector-set! ring next-slot-index val)
    (vector-set! ring 0 (let ((n (+ next-slot-index 1)))
                          (if (= n (vector-length ring))
                              1
                              n)))
    next-slot-index))

(define (ring-get ring pos)
  (let ((vector-size (vector-length ring)))
    (cond ((not (integer? pos))
           (error "Invalid ring index!"))
          ((and (>= pos 1)
                (<  pos vector-size))
           (vector-ref ring pos))
          ((and (>= (- pos) 0)
                (<  (- pos) vector-size))
           (vector-ref ring (let ((n (+ (vector-ref ring 0) pos)))
                              (if (< n 1)
                                  (- (+ vector-size n) 1)
                                  n))))
          (else
           (error "Ring index out of range!")))))

;;; Clearly we want to have separate value histories for separate
;;; simultaneously running REPLs.  We can achieve this by making
;;; *value-history* a fluid, since separate simultaneously running
;;; REPLs must be running in different fluid contexts.  In future, we
;;; may think of additional per-REPL properties, in which case it
;;; might be neater to make a fluid called *REPL* and use the
;;; make-object-property mechanism to associate a value history with
;;; one of that fluid's values.

(define *default-value-history-size* 10)

(define *value-history* (make-fluid))

(define (get-value-history-value index)
  (cond
   ((fluid-ref *value-history*)
    =>
    (lambda (ring)
      (ring-get ring index)))
   (else
    (error "Value history has not been activated!"))))

(define (add-to-value-history val)
  (cond
   ((fluid-ref *value-history*)
    =>
    (lambda (ring)
      (ring-add ring val)))
   (else
    (error "Value history has not been activated!"))))

(define (add-to-value-history-and-print-index val)
  (let ((value-history-index (add-to-value-history val)))
    (display "##")
    (display value-history-index)
    (display " ")))

(define activate-value-history
  (let ((print-value-hooks-modified #f))
    (lambda args
      (if (fluid-ref *value-history*)
          (error "Value history is already activated!"))
      (fluid-set! *value-history*
                  (make-ring (if (= (length args) 1)
                                 (car args)
                                 *default-value-history-size*)))
      (or print-value-hooks-modified
          (begin
            (add-hook! before-print-value-hook
                       add-to-value-history-and-print-index)
            (set! print-value-hooks-modified #t))))))

(read-hash-extend #\#
                  (lambda (c port)
                    (get-value-history-value (read port))))

(export activate-value-history)

;;; The following additional function and exports may be of interest
;;; when using a value history independently of a REPL.

(define (value-history-activated)
  (not (not (fluid-ref *value-history*))))

(export add-to-value-history
        get-value-history-value
        value-history-activated)

;;; value-history.scm ends here