Emacs-like text buffer

[Keisuke Nishida <kxn30 at po dot cwru dot edu>]

Hello,

I want to use Emacs-like text buffers with Guile.  I've written a tiny,
inefficient, but working version of it in Scheme.  It works like this:

  % guile
  guile> (use-modules (elib buffer))
  guile> (set! (current-buffer) (make-buffer))
  guile> (insert "Hello, ")
  guile> (insert "world")
  guile> (buffer-string)
  "Hello, world"
  guile> (goto-min)
  guile> (search-forward ", ")
  #("Hello, world" (5 . 7))
  guile> (insert "\n")
  guile> (buffer-string)
  "Hello, 
  world"
  guile> 

Before continuing working on this, I'd like to ask if someone is doing
(or has done) a similar work.  I know there is Greg Harvey's tbuffer,
but it looks different from what I want. (I prefer using current-buffer).

If nobody is working on this, I want to write some Emacs's features for
Guile.  (I'll use Scheme rather than C.  I want convenience before
efficiency.)

Anyway, this is the current version of my text buffer (two-hour job).

------------------------------------------------------------------------
;;; buffer.scm --- A tiny text buffer implementation

;; Copyright (C) 2000 Keisuke Nishida <kxn30@po.cwru.edu>

;; 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 program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(define-module (elib buffer)
  :use-module (oop goops)
  :use-module (ice-9 regex))

(define (assert predicate obj)
  (if (not (predicate obj))
      (scm-error 'wrong-type-arg #f
		 "Wrong type argument: ~S, ~S"
		 (list (procedure-name predicate) obj) #f)))
;;;
;;; Buffer class
;;;

(define-class <buffer> ()
  (text #:accessor %buffer-text #:init-value "")
  (point #:accessor %buffer-point #:init-value 0))

(define-public (make-buffer) (make <buffer>))

(define-public (buffer? obj) (is-a? obj <buffer>))

(define (%buffer-point-min buffer)
  0)

(define (%buffer-point-max buffer)
  (string-length (%buffer-text buffer)))

(define (%buffer-goto-point buffer point)
  (set! (%buffer-point buffer)
	(cond ((< point (%buffer-point-min buffer))
	       (%buffer-point-min buffer))
	      ((> point (%buffer-point-max buffer))
	       (%buffer-point-max buffer))
	      (else point))))

(define (%buffer-char-at buffer point)
  (string-ref (%buffer-text buffer) point))

(define (%buffer-insert buffer text)
  (let* ((point (%buffer-point buffer))
	 (old-text (%buffer-text buffer))
	 (new-text (string-append (make-shared-substring old-text 0 point)
				  text
				  (make-shared-substring old-text point))))
    (set! (%buffer-text buffer) new-text)
    (set! (%buffer-point buffer) (+ point (string-length text)))))

(define (%buffer-delete buffer start end)
  (let* ((pos (%buffer-point buffer))
	 (old-text (%buffer-text buffer))
	 (new-text (string-append (make-shared-substring old-text 0 start)
				  (make-shared-substring old-text end)))
	 (new-pos (cond ((and (< start pos) (<= pos end)) start)
			((< end pos) (+ start (- pos end)))
			(else pos))))
    (set! (%buffer-point buffer) new-pos)
    (set! (%buffer-text buffer) new-text)))

(define (%buffer-re-search-forward buffer pattern)
  (let ((match (regexp-exec (make-regexp pattern)
			    (%buffer-text buffer)
			    (%buffer-point buffer))))
    (if match
	(set! (%buffer-point buffer) (match:end match)))
    match))

(define (%buffer-re-search-backward buffer pattern)
  ;; FIXME: This is incomplete and horribly inefficient.
  (let ((regexp (make-regexp pattern))
	(substr (make-shared-substring (%buffer-text buffer) 0
					(%buffer-point buffer)))
	(last-match #f))
    (do ((start 0 (1+ (match:start match)))
	 (match (regexp-exec regexp substr) (regexp-exec regexp substr start)))
	((not match) last-match)
      (%buffer-goto-point buffer (match:start match))
      (set! last-match match))))

;;;
;;; Buffer procedures
;;;

(define *current-buffer* (make-buffer))

(define-public current-buffer
  (make-procedure-with-setter
   (lambda () *current-buffer*)
   (lambda (val)
     (assert buffer? val)
     (set! *current-buffer* val))))

(define-public (point)
  (%buffer-point *current-buffer*))

(define-public (point-min)
  (%buffer-point-min *current-buffer*))

(define-public (point-max)
  (%buffer-point-max *current-buffer*))

(define-public (point-bol)
  (save-buffer-point (lambda () (goto-bol) (point))))

(define-public (point-eol)
  (save-buffer-point (lambda () (goto-eol) (point))))

(define-public (line)
  (save-buffer-point
   (lambda ()
     (goto-bol)
     (do ((n 0 (1+ n)))
	 ((bob?) n)
       (backward-line)))))

(define-public (column)
  (save-buffer-point
   (lambda ()
     (do ((n 0 (1+ n)))
	 ((bol?) n)
       (backward-char)))))

(define-public (goto-point point)
  (%buffer-goto-point *current-buffer* point))

(define-public (goto-min)
  (goto-point (point-min)))

(define-public (goto-max)
  (goto-point (point-max)))

(define-public (goto-bol)
  (if (search-backward "\n")
      (forward-char)
      (goto-min)))

(define-public (goto-eol)
  (if (search-forward "\n")
      (backward-char)
      (goto-max)))

(define-public (goto-line n)
  (goto-min)
  (forward-line n))

(define-public (goto-column n)
  (goto-bol)
  (forward-char n))

(define-public (forward-char . args)
  (let ((n (if (null? args) 1 (car args))))
    (goto-point (+ (point) n))))

(define-public (backward-char . args)
  (let ((n (if (null? args) 1 (car args))))
    (goto-point (- (point) n))))

(define-public (forward-line . args)
  (do ((n (if (null? args) 1 (car args)) (1- n)))
      ((= n 0))
    (or (search-forward "\n")
	(goto-max))))

(define-public (backward-line . args)
  (do ((n (if (null? args) 1 (car args)) (1- n)))
      ((= n 0))
    (search-backward "\n"))
  (goto-bol))

(define-public (bob?)
  (= (point) (point-min)))

(define-public (eob?)
  (= (point) (point-max)))

(define-public (bol?)
  (or (eqv? (char-before) #\newline) (bob?)))

(define-public (eol?)
  (or (eqv? (char-after) #\newline) (eob?)))

(define-public (char-after . args)
  (let ((p (if (null? args) (point) (car args))))
    (if (and (<= (point-min) p) (<= p (point-max)))
	(%buffer-char-at *current-buffer* p)
	#f)))

(define-public (char-before . args)
  (let ((p (1- (if (null? args) (point) (car args)))))
    (char-after p)))

(define-public (buffer-string)
  (%buffer-text *current-buffer*))

(define-public (buffer-substring start end)
  (substring (buffer-string) start end))

(define-public (insert . args)
  (do ((list args (cdr args)))
      ((null? list))
    (%buffer-insert *current-buffer* (car list))))

(define-public (delete-char n)
  (let ((p (point)))
    (%buffer-delete *current-buffer* p (+ p n))))

(define-public (delete-region start end)
  (%buffer-delete *current-buffer* start end))

(define-public (search-forward text)
  (re-search-forward (regexp-quote text)))

(define-public (search-backward text)
  (re-search-backward (regexp-quote text)))

(define-public (re-search-forward pattern)
  (%buffer-re-search-forward *current-buffer* pattern))

(define-public (re-search-backward pattern)
  (%buffer-re-search-backward *current-buffer* pattern))

(define-public (save-buffer-point thunk)
  (let ((orig-point #f))
    (dynamic-wind
	(lambda () (set! orig-point (point)))
	thunk
	(lambda () (goto-point orig-point)))))

;;; buffer.scm ends here