LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/scripts/read-scheme-source.scm

@@ -0,0 +1,282 @@
+;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: read-scheme-source FILE1 FILE2 ...
+;;
+;; This program parses each FILE and writes to stdout sexps that describe the
+;; top-level structures of the file: scheme forms, single-line comments, and
+;; hash-bang comments.  You can further process these (to associate comments
+;; w/ scheme forms as a kind of documentation, for example).
+;;
+;; The output sexps have one of these forms:
+;;
+;;    (quote (filename FILENAME))
+;;
+;;    (quote (comment :leading-semicolons N
+;;                    :text LINE))
+;;
+;;    (quote (whitespace :text LINE))
+;;
+;;    (quote (hash-bang-comment :line LINUM
+;;                              :line-count N
+;;                              :text-list (LINE1 LINE2 ...)))
+;;
+;;    (quote (following-form-properties :line LINUM
+;;                                      :line-count N)
+;;                                      :type TYPE
+;;                                      :signature SIGNATURE
+;;                                      :std-int-doc DOCSTRING))
+;;
+;;    SEXP
+;;
+;; The first four are straightforward (both FILENAME and LINE are strings sans
+;; newline, while LINUM and N are integers).  The last two always go together,
+;; in that order.  SEXP is scheme code processed only by `read' and then
+;; `write'.
+;;
+;; The :type field may be omitted if the form is not recognized.  Otherwise,
+;; TYPE may be one of: procedure, alias, define-module, variable.
+;;
+;; The :signature field may be omitted if the form is not a procedure.
+;; Otherwise, SIGNATURE is a list showing the procedure's signature.
+;;
+;; If the type is `procedure' and the form has a standard internal docstring
+;; (first body form a string), that is extracted in full -- including any
+;; embedded newlines -- and recorded by field :std-int-doc.
+;;
+;;
+;; Usage from a program: The output list of sexps can be retrieved by scheme
+;; programs w/o having to capture stdout, like so:
+;;
+;;    (use-modules (scripts read-scheme-source))
+;;    (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
+;;
+;; There are also two convenience procs exported for use by Scheme programs:
+;;
+;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
+;;                   have the same number of leading semicolons.
+;;
+;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
+;;                        the ":tags", and return alist of (TAG . VAL) elems.
+;;
+;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
+;;       Make `annotate!' extensible.
+
+;;; Code:
+
+(define-module (scripts read-scheme-source)
+  :use-module (ice-9 rdelim)
+  :export (read-scheme-source
+           read-scheme-source-silently
+           quoted?
+           clump))
+
+(define %include-in-guild-list #f)
+(define %summary "Print a parsed representation of a Scheme file.")
+
+;; Try to figure out what FORM is and its various attributes.
+;; Call proc NOTE! with key (a symbol) and value.
+;;
+(define (annotate! form note!)
+  (cond ((and (list? form)
+              (< 2 (length form))
+              (eq? 'define (car form))
+              (pair? (cadr form))
+              (symbol? (caadr form)))
+         (note! ':type 'procedure)
+         (note! ':signature (cadr form))
+         (and (< 3 (length form))
+              (string? (caddr form))
+              (note! ':std-int-doc (caddr form))))
+        ((and (list? form)
+              (< 2 (length form))
+              (eq? 'define (car form))
+              (symbol? (cadr form))
+              (list? (caddr form))
+              (< 3 (length (caddr form)))
+              (eq? 'lambda (car (caddr form)))
+              (string? (caddr (caddr form))))
+         (note! ':type 'procedure)
+         (note! ':signature (cons (cadr form) (cadr (caddr form))))
+         (note! ':std-int-doc (caddr (caddr form))))
+        ((and (list? form)
+              (= 3 (length form))
+              (eq? 'define (car form))
+              (symbol? (cadr form))
+              (symbol? (caddr form)))
+         (note! ':type 'alias))
+        ((and (list? form)
+              (eq? 'define-module (car form)))
+         (note! ':type 'define-module))
+        ;; Add other types here.
+        (else (note! ':type 'variable))))
+
+;; Process FILE, calling NB! on parsed top-level elements.
+;; Recognized: #!-!# and regular comments in addition to normal forms.
+;;
+(define (process file nb!)
+  (nb! `'(filename ,file))
+  (let ((hash-bang-rx (make-regexp "^#!"))
+        (bang-hash-rx (make-regexp "^!#"))
+        (all-comment-rx (make-regexp "^[ \t]*(;+)"))
+        (all-whitespace-rx (make-regexp "^[ \t]*$"))
+        (p (open-input-file file)))
+    (let loop ((n (1+ (port-line p))) (line (read-line p)))
+      (or (not n)
+          (eof-object? line)
+          (begin
+            (cond ((regexp-exec hash-bang-rx line)
+                   (let loop ((line (read-line p))
+                              (text (list line)))
+                     (if (or (eof-object? line)
+                             (regexp-exec bang-hash-rx line))
+                         (nb! `'(hash-bang-comment
+                                 :line ,n
+                                 :line-count ,(1+ (length text))
+                                 :text-list ,(reverse
+                                              (cons line text))))
+                         (loop (read-line p)
+                               (cons line text)))))
+                  ((regexp-exec all-whitespace-rx line)
+                   (nb! `'(whitespace :text ,line)))
+                  ((regexp-exec all-comment-rx line)
+                   => (lambda (m)
+                        (nb! `'(comment
+                                :leading-semicolons
+                                ,(let ((m1 (vector-ref m 1)))
+                                   (- (cdr m1) (car m1)))
+                                :text ,line))))
+                  (else
+                   (unread-string line p)
+                   (let* ((form (read p))
+                          (count (- (port-line p) n))
+                          (props (let* ((props '())
+                                        (prop+ (lambda args
+                                                 (set! props
+                                                       (append props args)))))
+                                   (annotate! form prop+)
+                                   props)))
+                     (or (= count 1)    ; ugh
+                         (begin
+                           (read-line p)
+                           (set! count (1+ count))))
+                     (nb! `'(following-form-properties
+                             :line ,n
+                             :line-count ,count
+                             ,@props))
+                     (nb! form))))
+            (loop (1+ (port-line p)) (read-line p)))))))
+
+;;; entry points
+
+(define (read-scheme-source-silently . files)
+  "See commentary in module (scripts read-scheme-source)."
+  (let* ((res '()))
+    (for-each (lambda (file)
+                (process file (lambda (e) (set! res (cons e res)))))
+              files)
+    (reverse res)))
+
+(define (read-scheme-source . files)
+  "See commentary in module (scripts read-scheme-source)."
+  (for-each (lambda (file)
+              (process file (lambda (e) (write e) (newline))))
+            files))
+
+;; Recognize:          (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
+;; and return alist:   ((TAG1 . VAL1) (TAG2 . VAL2) ...)
+;; where the tags are symbols.
+;;
+(define (quoted? sym form)
+  (and (list? form)
+       (= 2 (length form))
+       (eq? 'quote (car form))
+       (let ((inside (cadr form)))
+         (and (list? inside)
+              (< 0 (length inside))
+              (eq? sym (car inside))
+              (let loop ((ls (cdr inside)) (alist '()))
+                (if (null? ls)
+                    alist               ; retval
+                    (let ((first (car ls)))
+                      (or (symbol? first)
+                          (error "bad list!"))
+                      (loop (cddr ls)
+                            (acons (string->symbol
+                                    (substring (symbol->string first) 1))
+                                   (cadr ls)
+                                   alist)))))))))
+
+;; Filter FORMS, combining contiguous comment forms that have the same number
+;; of leading semicolons.  Do not include in them whitespace lines.
+;; Whitespace lines outside of such comment groupings are ignored, as are
+;; hash-bang comments.  All other forms are passed through unchanged.
+;;
+(define (clump forms)
+  (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
+    (if (null? forms)
+        (reverse acc)                   ; retval
+        (let ((form (car forms)))
+          (cond (pass-this-one-through?
+                 (loop (cdr forms) (cons form acc) #f))
+                ((quoted? 'following-form-properties form)
+                 (loop (cdr forms) (cons form acc) #t))
+                ((quoted? 'whitespace form)             ;;; ignore
+                 (loop (cdr forms) acc #f))
+                ((quoted? 'hash-bang-comment form)      ;;; ignore for now
+                 (loop (cdr forms) acc #f))
+                ((quoted? 'comment form)
+                 => (lambda (alist)
+                      (let cloop ((inner-forms (cdr forms))
+                                  (level (assq-ref alist 'leading-semicolons))
+                                  (text (list (assq-ref alist 'text))))
+                        (let ((up (lambda ()
+                                    (loop inner-forms
+                                          (cons (cons level (reverse text))
+                                                acc)
+                                          #f))))
+                          (if (null? inner-forms)
+                              (up)
+                              (let ((inner-form (car inner-forms)))
+                                (cond ((quoted? 'comment inner-form)
+                                       => (lambda (inner-alist)
+                                            (let ((new-level
+                                                   (assq-ref
+                                                    inner-alist
+                                                    'leading-semicolons)))
+                                              (if (= new-level level)
+                                                  (cloop (cdr inner-forms)
+                                                         level
+                                                         (cons (assq-ref
+                                                                inner-alist
+                                                                'text)
+                                                               text))
+                                                  (up)))))
+                                      (else (up)))))))))
+                (else (loop (cdr forms) (cons form acc) #f)))))))
+
+;;; script entry point
+
+(define main read-scheme-source)
+
+;;; read-scheme-source ends here

data/share/guile/2.2/scripts/read-text-outline.scm

@@ -0,0 +1,253 @@
+;;; read-text-outline --- Read a text outline and display it as a sexp
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 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 %include-in-guild-list #f)
+(define %summary "Convert textual outlines to s-expressions.")
+
+(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