2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
3 main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
6 ;;; read-text-outline --- Read a text outline and display it as a sexp
8 ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or
13 ;; (at your option) any later version.
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this software; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301 USA
25 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
29 ;; Usage: read-text-outline OUTLINE
31 ;; Scan OUTLINE file and display a list of trees, the structure of
32 ;; each reflecting the "levels" in OUTLINE. The recognized outline
33 ;; format (used to indicate outline headings) is zero or more pairs of
34 ;; leading spaces followed by "-". Something like:
45 ;; In this example the levels are shown to the right. The output for
46 ;; such a file would be the single line:
48 ;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
50 ;; Basically, anything at the beginning of a list is a parent, and the
51 ;; remaining elements of that list are its children.
54 ;; Usage from a Scheme program: These two procs are exported:
56 ;; (read-text-outline . args) ; only first arg is used
57 ;; (read-text-outline-silently port)
58 ;; (make-text-outline-reader re specs)
60 ;; `make-text-outline-reader' returns a proc that reads from PORT and
61 ;; returns a list of trees (similar to `read-text-outline-silently').
63 ;; RE is a regular expression (string) that is used to identify a header
64 ;; line of the outline (as opposed to a whitespace line or intervening
65 ;; text). RE must begin w/ a sub-expression to match the "level prefix"
66 ;; of the line. You can use `level-submatch-number' in SPECS (explained
67 ;; below) to specify a number other than 1, the default.
69 ;; Normally, the level of the line is taken directly as the length of
70 ;; its level prefix. This often results in adjacent levels not mapping
71 ;; to adjacent numbers, which confuses the tree-building portion of the
72 ;; program, which expects top-level to be 0, first sub-level to be 1,
73 ;; etc. You can use `level-substring-divisor' or `compute-level' in
74 ;; SPECS to specify a constant scaling factor or specify a completely
75 ;; alternative procedure, respectively.
77 ;; SPECS is an alist which may contain the following key/value pairs:
79 ;; - level-submatch-number NUMBER
80 ;; - level-substring-divisor NUMBER
81 ;; - compute-level PROC
82 ;; - body-submatch-number NUMBER
83 ;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
85 ;; The PROC value associated with key `compute-level' should take a
86 ;; Scheme match structure (as returned by `regexp-exec') and return a
87 ;; number, the normalized level for that line. If this is specified,
88 ;; it takes precedence over other level-computation methods.
90 ;; Use `body-submatch-number' if RE specifies the whole body, or if you
91 ;; want to make use of the extra fields parsing. The `extra-fields'
92 ;; value is a sub-alist, whose keys name additional fields that are to
93 ;; be recognized. These fields along with `level' are set as object
94 ;; properties of the final string ("body") that is consed into the tree.
95 ;; If a field name ends in "?" the field value is set to be #t if there
96 ;; is a match and the result is not an empty string, and #f otherwise.
101 ;; (1) Only the first file specified on the command line is scanned.
102 ;; (2) TAB characters at the beginnings of lines are not recognized.
103 ;; (3) Outlines that "skip" levels signal an error. In other words,
108 ;; - c 3 <-- skipped 2 -- error!
112 ;; TODO: Determine what's the right thing to do for skips.
114 ;; Make line format customizable via longopts.
118 (define-module (scripts read-text-outline)
119 :export (read-text-outline
120 read-text-outline-silently
121 make-text-outline-reader)
122 :use-module (ice-9 regex)
123 :autoload (ice-9 rdelim) (read-line)
124 :autoload (ice-9 getopt-long) (getopt-long))
127 (let ((name (symbol->string symbol)))
128 (string=? "?" (substring name (1- (string-length name))))))
132 (match:substring m n)))
134 (define (??-predicates pair)
138 (not (string=? "" (match:substring m (cdr pair)))))
141 (define (make-line-parser re specs)
142 (let* ((rx (let ((fc (substring re 0 1)))
143 (make-regexp (if (string=? "^" fc)
145 (string-append "^" re)))))
147 (assq-ref specs key)))
148 (level-substring (msub (or (check 'level-submatch-number) 1)))
149 (extract-level (cond ((check 'compute-level)
153 ((check 'level-substring-divisor)
156 (/ (string-length (level-substring m))
160 (string-length (level-substring m))))))
161 (extract-body (cond ((check 'body-submatch-number)
164 (lambda (m) (match:suffix m)))))
165 (misc-props! (cond ((check 'extra-fields)
167 (let ((new (map ??-predicates alist)))
171 (set-object-property!
176 (lambda (obj m) #t)))))
179 (cond ((regexp-exec rx line)
181 (let ((level (extract-level m))
182 (body (extract-body m)))
183 (set-object-property! body 'level level)
188 (define (make-text-outline-reader re specs)
189 (let ((parse-line (make-line-parser re specs)))
192 (let* ((all '(start))
193 (pchain (list))) ; parents chain
194 (let loop ((line (read-line port))
195 (prev-level -1) ; how this relates to the first input
196 ; level determines whether or not we
197 ; start in "sibling" or "child" mode.
198 ; in the end, `start' is ignored and
199 ; it's much easier to ignore parents
200 ; than siblings (sometimes). this is
201 ; not to encourage ignorance, however.
202 (tp all)) ; tail pointer
203 (or (eof-object? line)
204 (cond ((parse-line line)
206 (let* ((words (list w))
207 (level (object-property w 'level))
208 (diff (- level prev-level)))
213 ;; just extend the chain
219 (error "unhandled diff not 1:" diff line))
220 ;; parent may be contacted by uncle later (kids
221 ;; these days!) so save its level
222 (set-object-property! tp 'level prev-level)
223 (set! pchain (cons tp pchain))
224 ;; "push down" car into hierarchy
225 (set-car! tp (cons (car tp) words)))
229 ;; prune back to where levels match
230 (do ((p pchain (cdr p)))
231 ((= level (object-property (car p) 'level))
233 ;; resume at this level
234 (set-cdr! (car pchain) words)
235 (set! pchain (cdr pchain))))
237 (loop (read-line port) level words))))
238 (else (loop (read-line port) prev-level tp)))))
244 (define read-text-outline-silently
245 (make-text-outline-reader "(([ ][ ])*)- *"
246 '((level-substring-divisor . 2))))
248 (define (read-text-outline . args)
249 (write (read-text-outline-silently (open-file (car args) "r")))
253 (define main read-text-outline)
255 ;;; read-text-outline ends here