mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-08 10:42:27 +02:00
Code Activity

(display-outline-tree): No longer export this proc.

Browse source 
(*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
display-outline-tree): Delete these vars and procs.

(??, msub, ??-predicates, make-line-parser,
make-text-outline-reader): New procs.

(make-text-outline-reader): Export.
(read-text-outline-silently): Rewrite
using `make-text-outline-reader'.
This commit is contained in:
Thien-Thi Nguyen 2002-04-06 01:55:20 +00:00
parent eb4311e620
commit 088b528512
1 changed files with 160 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

235
scripts/read-text-outline
View file

@ -31,7 +31,7 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;; Scan OUTLINE file and display a list of trees, the structure of ;; Scan OUTLINE file and display a list of trees, the structure of
;; each reflecting the "levels" in OUTLINE. The recognized outline ;; each reflecting the "levels" in OUTLINE. The recognized outline
;; format (used to indicate outline headings) is zero or more pairs of ;; format (used to indicate outline headings) is zero or more pairs of
;; leading spaces followed by "-" or "+". Something like: ;; leading spaces followed by "-". Something like:
;; ;;
;; - a 0 ;; - a 0
;; - b 1 ;; - b 1
@ -40,22 +40,60 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;; - e 0 ;; - e 0
;; - f 1 ;; - f 1
;; - g 2 ;; - g 2
;; -h 1 ;; - h 1
;; ;;
;; In this example the levels are shown to the right. The output for ;; In this example the levels are shown to the right. The output for
;; such a file would be the single line: ;; such a file would be the single line:
;; ;;
;; (("a" ("b" "c") "d") ("e" ("f" "g") "h")) ;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
;; ;;
;; Basically, anything at the beginning of a list is a parent, and the
;; remaining elements of that list are its children.
;; ;;
;; Usage from a Scheme program: These three procs are exported: ;;
;; Usage from a Scheme program: These two procs are exported:
;; ;;
;; (read-text-outline . args) ; only first arg is used ;; (read-text-outline . args) ; only first arg is used
;; (read-text-outline-silently port) ;; (read-text-outline-silently port)
;; (display-outline-tree tree) ;; (make-text-outline-reader re specs)
;; ;;
;; Don't forget to iterate (say, `display-outline-tree') over the list of ;; `make-text-outline-reader' returns a proc that reads from PORT and
;; trees that `read-text-outline-silently' returns. ;; returns a list of trees (similar to `read-text-outline-silently').
;;
;; RE is a regular expression (string) that is used to identify a header
;; line of the outline (as opposed to a whitespace line or intervening
;; text). RE must begin w/ a sub-expression to match the "level prefix"
;; of the line. You can use `level-submatch-number' in SPECS (explained
;; below) to specify a number other than 1, the default.
;;
;; Normally, the level of the line is taken directly as the length of
;; its level prefix. This often results in adjacent levels not mapping
;; to adjacent numbers, which confuses the tree-building portion of the
;; program, which expects top-level to be 0, first sub-level to be 1,
;; etc. You can use `level-substring-divisor' or `compute-level' in
;; SPECS to specify a constant scaling factor or specify a completely
;; alternative procedure, respectively.
;;
;; SPECS is an alist which may contain the following key/value pairs:
;;
;; - level-submatch-number NUMBER
;; - level-substring-divisor NUMBER
;; - compute-level PROC
;; - body-submatch-number NUMBER
;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
;;
;; The PROC value associated with key `compute-level' should take a
;; Scheme match structure (as returned by `regexp-exec') and return a
;; number, the normalized level for that line. If this is specified,
;; it takes precedence over other level-computation methods.
;;
;; Use `body-submatch-number' if RE specifies the whole body, or if you
;; want to make use of the extra fields parsing. The `extra-fields'
;; value is a sub-alist, whose keys name additional fields that are to
;; be recognized. These fields along with `level' are set as object
;; properties of the final string ("body") that is consed into the tree.
;; If a field name ends in "?" the field value is set to be #t if there
;; is a match and the result is not an empty string, and #f otherwise.
;; ;;
;; ;;
;; Bugs and caveats: ;; Bugs and caveats:
@ -73,96 +111,143 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;; ;;
;; TODO: Determine what's the right thing to do for skips. ;; TODO: Determine what's the right thing to do for skips.
;; Handle TABs. ;; Handle TABs.
;; Handle follow-on lines. ;; Make line format customizable via longopts.
;; Make line/display format customizable via longopts.
;;; Code: ;;; Code:
(define-module (scripts read-text-outline) (define-module (scripts read-text-outline)
:export (read-text-outline read-text-outline-silently display-outline-tree) :export (read-text-outline
read-text-outline-silently
make-text-outline-reader)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (ice-9 rdelim)) :autoload (ice-9 rdelim) (read-line)
:autoload (ice-9 getopt-long) (getopt-long))
;; todo: make customizable (define (?? symbol)
(define *depth-cue-rx* (make-regexp "(([ ][ ])*)[-+] *")) (let ((name (symbol->string symbol)))
(define *subm-number* 1) (string=? "?" (substring name (1- (string-length name))))))
(define *level-divisor* 2)
(define (>> level line) (define (msub n)
(format #t "\t~A\t~A- ~A\n" level (make-string level #\space) line)) (lambda (m)
(match:substring m n)))
(define (display-outline-tree level tree) (define (??-predicates pair)
(cond ((list? tree) (cons (car pair)
(>> level (car tree)) (if (?? (car pair))
(for-each (lambda (kid) (lambda (m)
(display-outline-tree (+ *level-divisor* level) kid)) (not (string=? "" (match:substring m (cdr pair)))))
(cdr tree))) (msub (cdr pair)))))
(else (>> level tree))))
(define (read-text-outline-silently port) (define (make-line-parser re specs)
(let* ((all '(start)) (let* ((rx (let ((fc (substring re 0 1)))
(pchain (list))) ; parents chain (make-regexp (if (string=? "^" fc)
(let loop ((line (read-line port)) re
(prev-level -1) ; how this relates to the first input (string-append "^" re)))))
(check (lambda (key)
(assq-ref specs key)))
(level-substring (msub (or (check 'level-submatch-number) 1)))
(extract-level (cond ((check 'compute-level)
=> (lambda (proc)
(lambda (m)
(proc m))))
((check 'level-substring-divisor)
=> (lambda (n)
(lambda (m)
(/ (string-length (level-substring m))
n))))
(else
(lambda (m)
(string-length (level-substring m))))))
(extract-body (cond ((check 'body-submatch-number)
=> msub)
(else
(lambda (m) (match:suffix m)))))
(misc-props! (cond ((check 'extra-fields)
=> (lambda (alist)
(let ((new (map ??-predicates alist)))
(lambda (obj m)
(for-each
(lambda (pair)
(set-object-property!
obj (car pair)
((cdr pair) m)))
new)))))
(else
(lambda (obj m) #t)))))
;; retval
(lambda (line)
(cond ((regexp-exec rx line)
=> (lambda (m)
(let ((level (extract-level m))
(body (extract-body m)))
(set-object-property! body 'level level)
(misc-props! body m)
body)))
(else #f)))))
(define (make-text-outline-reader re specs)
(let ((parse-line (make-line-parser re specs)))
;; retval
(lambda (port)
(let* ((all '(start))
(pchain (list))) ; parents chain
(let loop ((line (read-line port))
(prev-level -1) ; how this relates to the first input
; level determines whether or not we ; level determines whether or not we
; start in "sibling" or "child" mode. ; start in "sibling" or "child" mode.
; in the end, `start' is ignored and ; in the end, `start' is ignored and
; it's much easier to ignore parents ; it's much easier to ignore parents
; than siblings (sometimes). this is ; than siblings (sometimes). this is
; not to encourage ignorance, however. ; not to encourage ignorance, however.
(tp all)) ; tail pointer (tp all)) ; tail pointer
(or (eof-object? line) (or (eof-object? line)
(cond ((regexp-exec *depth-cue-rx* line) (cond ((parse-line line)
=> (lambda (m) => (lambda (w)
(let* ((words (list (match:suffix m))) (let* ((words (list w))
(level (/ (string-length (level (object-property w 'level))
(or (match:substring m *subm-number*) (diff (- level prev-level)))
"")) (cond
*level-divisor*))
(diff (- level prev-level)))
(cond
;; sibling ;; sibling
((zero? diff) ((zero? diff)
;; just extend the chain ;; just extend the chain
(set-cdr! tp words)) (set-cdr! tp words))
;; child ;; child
((positive? diff) ((positive? diff)
(or (= 1 diff) (or (= 1 diff)
(error "unhandled diff not 1:" diff line)) (error "unhandled diff not 1:" diff line))
;; parent may be contacted by uncle later (kids ;; parent may be contacted by uncle later (kids
;; these days!) so save its level ;; these days!) so save its level
(set-object-property! tp 'level prev-level) (set-object-property! tp 'level prev-level)
(set! pchain (cons tp pchain)) (set! pchain (cons tp pchain))
;; "push down" car into hierarchy ;; "push down" car into hierarchy
(set-car! tp (cons (car tp) words))) (set-car! tp (cons (car tp) words)))
;; uncle ;; uncle
((negative? diff) ((negative? diff)
;; prune back to where levels match ;; prune back to where levels match
(do ((p pchain (cdr p))) (do ((p pchain (cdr p)))
((= level (object-property (car p) 'level)) ((= level (object-property (car p) 'level))
(set! pchain p))) (set! pchain p)))
;; resume at this level ;; resume at this level
(set-cdr! (car pchain) words) (set-cdr! (car pchain) words)
(set! pchain (cdr pchain)))) (set! pchain (cdr pchain))))
(loop (read-line port) level words)))) (loop (read-line port) level words))))
(else (loop (read-line port) prev-level tp))))) (else (loop (read-line port) prev-level tp)))))
(set! all (car all)) (set! all (car all))
(if (eq? 'start all) (if (eq? 'start all)
'() ; wasteland '() ; wasteland
(cdr all)))) (cdr all))))))
(define read-text-outline-silently
(make-text-outline-reader "(([ ][ ])*)- *"
'((level-substring-divisor . 2))))
(define (read-text-outline . args) (define (read-text-outline . args)
(let ((trees (read-text-outline-silently (open-file (car args) "r")))) (write (read-text-outline-silently (open-file (car args) "r")))
;; try this (newline)
;; (for-each (lambda (tree)
;; (display-outline-tree 0 tree))
;; trees))
(write trees)
(newline))
#t) ; exit val #t) ; exit val
(define main read-text-outline) (define main read-text-outline)