abbrev-tree.scm

[thi <ttn@mingle.glug.org>]

hi guile folks,

gdb's ability to recognize "i b" as "info breakpoints" and "h i b" as
"help info breakpoints" is pretty cool.  i think it would be nice to
have that kind of behavior in thud and perhaps elsewhere as well.
					 
please see below for some guile scheme that allows emulation of that
behavior.  it is functional but relatively unpolished.  i'm writing to
solicit feedback on interface and possible usage (perhaps this module
will become `(ice-9 abbrev-tree)' if the guile maintainers accept it),
especially to the questions: "would you use it?", "how would you use
it?", "what changes would you make to make it more useful?".

to play with it, start guile interactively and then do:

	guile> (load 'abbrev-tree.scm)
	guile> (define-module (abbrev-tree))
	guile> (test)

this will go into a repl, type "q" to quit.  see procedure `test',
variable `menu' for things to play with (this is also displayed in full
by the repl, as a reminder).

lastly, the license is GPL at this time, but don't worry about that yet.

i look forward to your feedback.

thi


----------
RCS/abbrev-tree.scm,v  -->  standard output
revision 1.2
;;;; abbrev-tree.scm --- hierarchical abbreviations
;;;; ID: abbrev-tree.scm,v 1.2 1999/06/13 00:38:21 ttn Exp
;;;;
;;;; Copyright (C) 1999 Thien-Thi Nguyen
;;;;
;;;; 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

;;;; Please send bug-reports and other correspondance concerning this file
;;;; to the author: Thien-Thi Nguyen <ttn@netcom.com>.

;;; Commentary:

;; This is modeled after gdb's help system, which I greatly admire.

;; Some issues:
;; - How to have record-constructor use different default slot values?
;;   Basically, ab-children should default to an empty list, not #f.

;;; Code:

(define-module (abbrev-tree)
  :use-module (ice-9 string-fun))

;;
;; Fundamental types
;;

(define ab				; abbrev node
  (make-record-type
   'ab
   '(fullname children data)
   (lambda (ab p)
     (with-output-to-port p
       (lambda ()
	 (display "#<ab")
	 (display " ") (display (ab-fullname ab))
	 (display " ") (display (ab-children ab))
	 (display ">\n"))))))

(define make-ab (record-constructor ab '(fullname)))
(define ab?     (record-predicate ab))

(define ab-fullname (record-accessor ab 'fullname))
(define ab-children (record-accessor ab 'children))
(define ab-data     (record-accessor ab 'data))

(define ab-children-set! (record-modifier ab 'children))
(define ab-data-set!     (record-modifier ab 'data))

(define aba				; ab alias
  (make-record-type
   'aba
   '(alias ab)
   (lambda (aba p)
     (with-output-to-port p
       (lambda ()
	 (display "#<aba")
	 (display " ") (display (aba-alias aba))
	 (display " ") (display (let ((hmm (aba-ab aba)))
				  (if (ab? hmm)
				      (ab-fullname hmm)
				      hmm)))
	 (display ">\n"))))))

(define make-aba (record-constructor aba '(alias ab)))
(define aba?     (record-predicate aba))

(define aba-alias (record-accessor aba 'alias))
(define aba-ab   (record-accessor aba 'ab))

;;
;; Support funcs
;;

(define scrub
  (lambda (string)
    (sans-surrounding-whitespace
     (list->string
      (let ((first #t) (ret '()))
	(map (lambda (c)
	       (if (memq c '(#\space #\tab #\newline))
		   (and first
			(begin
			  (set! ret (cons #\space ret))
			  (set! first #f)))
		   (begin
		     (set! ret (cons c ret))
		     (set! first #t))))
	     (reverse (string->list string)))
	ret)))))

(define split-first-word
  (lambda (scrubbed-string)
    (split-discarding-char #\space scrubbed-string cons)))

(define gdb-style-ambiguous
  (lambda (name tree choices)
    (display "Ambiguous ")
    (let ((fn (ab-fullname tree)))
      (or (string=? "" fn)
	  (begin (display fn) (display " "))))
    (display "command \"")
    (display name)
    (display "\": ")
    (let loop ((choices choices))
      (and (pair? choices)
	   (begin
	     (display (car choices))
	     (display (if (pair? (cdr choices)) ", " "."))
	     (loop (cdr choices)))))
    (newline)))

(define gdb-style-undefined
  (lambda (name tree)
    (display "Undefined")
    (let* ((fulln (ab-fullname tree))
	   (fn (if (string=? "" fulln)
		   ""
		   (string-append " " fulln))))
      (display fn)
      (display " command: \"")
      (display name)
      (display "\".  Try \"help")
      (display fn)
      (display "\".")
      (newline))))

;;
;; Searching the tree
;;

(define search-for-abbrev
  (lambda (name tree show-options oops)
    (catch 'found-abbrev
	   (lambda ()
	     (for-each
	      (lambda (child)
		(cond ((ab? child)
		       (let ((fn (ab-fullname child)))
			 (and (string=? name fn)
			      (throw 'found-abbrev child))))
		      ((aba? child)
		       (let ((fn (aba-ab child)))
			 (and (string=? name (aba-alias child))
			      (if (list? fn)
				  (begin
				    (show-options name tree fn)
				    (throw 'found-abbrev #f))
				  (throw 'found-abbrev fn)))))
		      (else #f)))
	      (or (ab-children tree) '()))
	     (oops name tree))
	   (lambda args			; found-abbrev handler
	     (and (list? args)
		  (cadr args))))))

;;
;; Adding to the tree
;;

(define add-to-abbrev-tree		; kind of like `mkdir -p'
  (lambda (tree fullname-path)
    (let* ((split (split-first-word (scrub fullname-path)))
	   (word (car split)))
      (display "adding ") (write-line split)
      (or (string=? "" word)
	  (let ((lookup (search-for-abbrev word tree
					   (lambda (name tree choices)
					     (error name tree choices))
					   (lambda (name tree) #f))))
	    (if lookup
		(and (string=? "" (cdr split))
		     (error "already have it!"))
		(begin
		  (set! lookup (make-ab word))
		  (ab-children-set! tree (cons lookup
					       (or (ab-children tree) '())))))
	    (add-to-abbrev-tree lookup (cdr split)))))))

(define make-abbrev-tree
  (lambda (in-data)
    (if (list? in-data)
	(let ((ret (make-ab (car in-data))))
	  (ab-children-set! ret (map make-abbrev-tree (cdr in-data)))
	  ret)
	(make-ab in-data))))

(define triangle
  (lambda (name)
    (let ((len (string-length name)))
      (if (= 1 len)
	  (list name)
	  (cons name (triangle (make-shared-substring name 0 (1- len))))))))

(define expand-abbrev-tree
  (lambda (tree)
    (or (ab? tree) (error "bad tree error"))
    (for-each
     (lambda (elem)
       (ab-children-set! tree (cons (make-aba (car elem) (cdr elem))
				    (ab-children tree))))
     (let ((alias-alist '()))
       (for-each
	(lambda (child)
	  (and (ab? child)
	       (begin
		 (expand-abbrev-tree child)
		 (for-each
		  (lambda (tri)
		    (let ((seen (assoc tri alias-alist))) ; assq doesn't work
		      (if seen
			  (set-cdr! seen
				    (cons (ab-fullname child)
					  (let ((rest (cdr seen)))
					    (if (ab? rest)
						(list (ab-fullname rest))
						rest))))
			  (set! alias-alist
				(cons (cons tri child) alias-alist)))))
		  (cdr (triangle (ab-fullname child)))))))
	(or (ab-children tree) '()))
       alias-alist))
    tree))

;;
;; test
;;

(define test
  (lambda ()
    (let ((menu
	   '("help"
	     "info breakpoints"
	     "info lines"
	     "info locals"
	     "show language"
	     "show listsize"
	     "show lisp story"
	     "show lisp shortage"
	     "show listshape"
	     "set up"
	     "set out"
	     "set over"
	     "set about")))
      (define readline (lambda ()
			 (for-each (lambda (item)
				     (display "[")
				     (display item)
				     (display "]"))
				   menu)
			 (display "\n(go ahead make my day) ")
			 (force-output)
			 (read-delimited "\n")))
      (let ((root (make-ab "")))
	(for-each (lambda (command-sequence)
		    (add-to-abbrev-tree root command-sequence))
		  menu)
	(set! root (expand-abbrev-tree root))
	(let loop ((cmd (readline)))
	  (or (eof-object? cmd)
	      (string=? cmd "q")
	      (begin
		(let wloop ((split (split-first-word (scrub cmd)))
			    (tree root))
		  (let ((word (car split)))
		    (or (string=? "" word)
			(let ((lookup (search-for-abbrev word
							 tree
							 gdb-style-ambiguous
							 gdb-style-undefined)))
			  (and lookup
			       (not (unspecified? lookup))
			       (begin
				 (write-line lookup)
				 (wloop (split-first-word (cdr split))
					lookup)))))))
		(loop (readline)))))))))

;;; abbrev-tree.scm,v1.2 ends here