This is the mail archive of the
guile@sources.redhat.com
mailing list for the Guile project.
Emacs-like text buffer
- To: guile at sourceware dot cygnus dot com
- Subject: Emacs-like text buffer
- From: Keisuke Nishida <kxn30 at po dot cwru dot edu>
- Date: 10 Jul 2000 15:17:26 -0400
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