summaryrefslogtreecommitdiff
path: root/scripts/read-text-outline
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/read-text-outline')
-rwxr-xr-xscripts/read-text-outline255
1 files changed, 0 insertions, 255 deletions
diff --git a/scripts/read-text-outline b/scripts/read-text-outline
deleted file mode 100755
index 1a88f205e..000000000
--- a/scripts/read-text-outline
+++ /dev/null
@@ -1,255 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; read-text-outline --- Read a text outline and display it as a sexp
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; 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
-
-;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
-
-;;; Commentary:
-
-;; Usage: read-text-outline OUTLINE
-;;
-;; Scan OUTLINE file and display a list of trees, the structure of
-;; each reflecting the "levels" in OUTLINE. The recognized outline
-;; format (used to indicate outline headings) is zero or more pairs of
-;; leading spaces followed by "-". Something like:
-;;
-;; - a 0
-;; - b 1
-;; - c 2
-;; - d 1
-;; - e 0
-;; - f 1
-;; - g 2
-;; - h 1
-;;
-;; In this example the levels are shown to the right. The output for
-;; such a file would be the single line:
-;;
-;; (("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 two procs are exported:
-;;
-;; (read-text-outline . args) ; only first arg is used
-;; (read-text-outline-silently port)
-;; (make-text-outline-reader re specs)
-;;
-;; `make-text-outline-reader' returns a proc that reads from PORT and
-;; 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:
-;;
-;; (1) Only the first file specified on the command line is scanned.
-;; (2) TAB characters at the beginnings of lines are not recognized.
-;; (3) Outlines that "skip" levels signal an error. In other words,
-;; this will fail:
-;;
-;; - a 0
-;; - b 1
-;; - c 3 <-- skipped 2 -- error!
-;; - d 1
-;;
-;;
-;; TODO: Determine what's the right thing to do for skips.
-;; Handle TABs.
-;; Make line format customizable via longopts.
-
-;;; Code:
-
-(define-module (scripts read-text-outline)
- :export (read-text-outline
- read-text-outline-silently
- make-text-outline-reader)
- :use-module (ice-9 regex)
- :autoload (ice-9 rdelim) (read-line)
- :autoload (ice-9 getopt-long) (getopt-long))
-
-(define (?? symbol)
- (let ((name (symbol->string symbol)))
- (string=? "?" (substring name (1- (string-length name))))))
-
-(define (msub n)
- (lambda (m)
- (match:substring m n)))
-
-(define (??-predicates pair)
- (cons (car pair)
- (if (?? (car pair))
- (lambda (m)
- (not (string=? "" (match:substring m (cdr pair)))))
- (msub (cdr pair)))))
-
-(define (make-line-parser re specs)
- (let* ((rx (let ((fc (substring re 0 1)))
- (make-regexp (if (string=? "^" fc)
- re
- (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
- ; start in "sibling" or "child" mode.
- ; in the end, `start' is ignored and
- ; it's much easier to ignore parents
- ; than siblings (sometimes). this is
- ; not to encourage ignorance, however.
- (tp all)) ; tail pointer
- (or (eof-object? line)
- (cond ((parse-line line)
- => (lambda (w)
- (let* ((words (list w))
- (level (object-property w 'level))
- (diff (- level prev-level)))
- (cond
-
- ;; sibling
- ((zero? diff)
- ;; just extend the chain
- (set-cdr! tp words))
-
- ;; child
- ((positive? diff)
- (or (= 1 diff)
- (error "unhandled diff not 1:" diff line))
- ;; parent may be contacted by uncle later (kids
- ;; these days!) so save its level
- (set-object-property! tp 'level prev-level)
- (set! pchain (cons tp pchain))
- ;; "push down" car into hierarchy
- (set-car! tp (cons (car tp) words)))
-
- ;; uncle
- ((negative? diff)
- ;; prune back to where levels match
- (do ((p pchain (cdr p)))
- ((= level (object-property (car p) 'level))
- (set! pchain p)))
- ;; resume at this level
- (set-cdr! (car pchain) words)
- (set! pchain (cdr pchain))))
-
- (loop (read-line port) level words))))
- (else (loop (read-line port) prev-level tp)))))
- (set! all (car all))
- (if (eq? 'start all)
- '() ; wasteland
- (cdr all))))))
-
-(define read-text-outline-silently
- (make-text-outline-reader "(([ ][ ])*)- *"
- '((level-substring-divisor . 2))))
-
-(define (read-text-outline . args)
- (write (read-text-outline-silently (open-file (car args) "r")))
- (newline)
- #t) ; exit val
-
-(define main read-text-outline)
-
-;;; read-text-outline ends here