guile18/scripts/read-scheme-source

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3 main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
   7
   8 ;;      Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   9 ;;
  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.
  14 ;;
  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.
  19 ;;
  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
  24
  25 ;;; Author: Thien-Thi Nguyen
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: read-scheme-source FILE1 FILE2 ...
  30 ;;
  31 ;; This program parses each FILE and writes to stdout sexps that describe the
  32 ;; top-level structures of the file: scheme forms, single-line comments, and
  33 ;; hash-bang comments.  You can further process these (to associate comments
  34 ;; w/ scheme forms as a kind of documentation, for example).
  35 ;;
  36 ;; The output sexps have one of these forms:
  37 ;;
  38 ;;    (quote (filename FILENAME))
  39 ;;
  40 ;;    (quote (comment :leading-semicolons N
  41 ;;                    :text LINE))
  42 ;;
  43 ;;    (quote (whitespace :text LINE))
  44 ;;
  45 ;;    (quote (hash-bang-comment :line LINUM
  46 ;;                              :line-count N
  47 ;;                              :text-list (LINE1 LINE2 ...)))
  48 ;;
  49 ;;    (quote (following-form-properties :line LINUM
  50 ;;                                      :line-count N)
  51 ;;                                      :type TYPE
  52 ;;                                      :signature SIGNATURE
  53 ;;                                      :std-int-doc DOCSTRING))
  54 ;;
  55 ;;    SEXP
  56 ;;
  57 ;; The first four are straightforward (both FILENAME and LINE are strings sans
  58 ;; newline, while LINUM and N are integers).  The last two always go together,
  59 ;; in that order.  SEXP is scheme code processed only by `read' and then
  60 ;; `write'.
  61 ;;
  62 ;; The :type field may be omitted if the form is not recognized.  Otherwise,
  63 ;; TYPE may be one of: procedure, alias, define-module, variable.
  64 ;;
  65 ;; The :signature field may be omitted if the form is not a procedure.
  66 ;; Otherwise, SIGNATURE is a list showing the procedure's signature.
  67 ;;
  68 ;; If the type is `procedure' and the form has a standard internal docstring
  69 ;; (first body form a string), that is extracted in full -- including any
  70 ;; embedded newlines -- and recorded by field :std-int-doc.
  71 ;;
  72 ;;
  73 ;; Usage from a program: The output list of sexps can be retrieved by scheme
  74 ;; programs w/o having to capture stdout, like so:
  75 ;;
  76 ;;    (use-modules (scripts read-scheme-source))
  77 ;;    (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
  78 ;;
  79 ;; There are also two convenience procs exported for use by Scheme programs:
  80 ;;
  81 ;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
  82 ;;                   have the same number of leading semicolons.
  83 ;;
  84 ;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
  85 ;;                        the ":tags", and return alist of (TAG . VAL) elems.
  86 ;;
  87 ;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
  88 ;;       Make `annotate!' extensible.
  89
  90 ;;; Code:
  91
  92 (define-module (scripts read-scheme-source)
  93   :use-module (ice-9 rdelim)
  94   :export (read-scheme-source
  95            read-scheme-source-silently
  96            quoted?
  97            clump))
  98
  99 ;; Try to figure out what FORM is and its various attributes.
 100 ;; Call proc NOTE! with key (a symbol) and value.
 101 ;;
 102 (define (annotate! form note!)
 103   (cond ((and (list? form)
 104               (< 2 (length form))
 105               (eq? 'define (car form))
 106               (pair? (cadr form))
 107               (symbol? (caadr form)))
 108          (note! ':type 'procedure)
 109          (note! ':signature (cadr form))
 110          (and (< 3 (length form))
 111               (string? (caddr form))
 112               (note! ':std-int-doc (caddr form))))
 113         ((and (list? form)
 114               (< 2 (length form))
 115               (eq? 'define (car form))
 116               (symbol? (cadr form))
 117               (list? (caddr form))
 118               (< 3 (length (caddr form)))
 119               (eq? 'lambda (car (caddr form)))
 120               (string? (caddr (caddr form))))
 121          (note! ':type 'procedure)
 122          (note! ':signature (cons (cadr form) (cadr (caddr form))))
 123          (note! ':std-int-doc (caddr (caddr form))))
 124         ((and (list? form)
 125               (= 3 (length form))
 126               (eq? 'define (car form))
 127               (symbol? (cadr form))
 128               (symbol? (caddr form)))
 129          (note! ':type 'alias))
 130         ((and (list? form)
 131               (eq? 'define-module (car form)))
 132          (note! ':type 'define-module))
 133         ;; Add other types here.
 134         (else (note! ':type 'variable))))
 135
 136 ;; Process FILE, calling NB! on parsed top-level elements.
 137 ;; Recognized: #!-!# and regular comments in addition to normal forms.
 138 ;;
 139 (define (process file nb!)
 140   (nb! `'(filename ,file))
 141   (let ((hash-bang-rx (make-regexp "^#!"))
 142         (bang-hash-rx (make-regexp "^!#"))
 143         (all-comment-rx (make-regexp "^[ \t]*(;+)"))
 144         (all-whitespace-rx (make-regexp "^[ \t]*$"))
 145         (p (open-input-file file)))
 146     (let loop ((n (1+ (port-line p))) (line (read-line p)))
 147       (or (not n)
 148           (eof-object? line)
 149           (begin
 150             (cond ((regexp-exec hash-bang-rx line)
 151                    (let loop ((line (read-line p))
 152                               (text (list line)))
 153                      (if (or (eof-object? line)
 154                              (regexp-exec bang-hash-rx line))
 155                          (nb! `'(hash-bang-comment
 156                                  :line ,n
 157                                  :line-count ,(1+ (length text))
 158                                  :text-list ,(reverse
 159                                               (cons line text))))
 160                          (loop (read-line p)
 161                                (cons line text)))))
 162                   ((regexp-exec all-whitespace-rx line)
 163                    (nb! `'(whitespace :text ,line)))
 164                   ((regexp-exec all-comment-rx line)
 165                    => (lambda (m)
 166                         (nb! `'(comment
 167                                 :leading-semicolons
 168                                 ,(let ((m1 (vector-ref m 1)))
 169                                    (- (cdr m1) (car m1)))
 170                                 :text ,line))))
 171                   (else
 172                    (unread-string line p)
 173                    (let* ((form (read p))
 174                           (count (- (port-line p) n))
 175                           (props (let* ((props '())
 176                                         (prop+ (lambda args
 177                                                  (set! props
 178                                                        (append props args)))))
 179                                    (annotate! form prop+)
 180                                    props)))
 181                      (or (= count 1)    ; ugh
 182                          (begin
 183                            (read-line p)
 184                            (set! count (1+ count))))
 185                      (nb! `'(following-form-properties
 186                              :line ,n
 187                              :line-count ,count
 188                              ,@props))
 189                      (nb! form))))
 190             (loop (1+ (port-line p)) (read-line p)))))))
 191
 192 ;;; entry points
 193
 194 (define (read-scheme-source-silently . files)
 195   "See commentary in module (scripts read-scheme-source)."
 196   (let* ((res '()))
 197     (for-each (lambda (file)
 198                 (process file (lambda (e) (set! res (cons e res)))))
 199               files)
 200     (reverse res)))
 201
 202 (define (read-scheme-source . files)
 203   "See commentary in module (scripts read-scheme-source)."
 204   (for-each (lambda (file)
 205               (process file (lambda (e) (write e) (newline))))
 206             files))
 207
 208 ;; Recognize:          (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
 209 ;; and return alist:   ((TAG1 . VAL1) (TAG2 . VAL2) ...)
 210 ;; where the tags are symbols.
 211 ;;
 212 (define (quoted? sym form)
 213   (and (list? form)
 214        (= 2 (length form))
 215        (eq? 'quote (car form))
 216        (let ((inside (cadr form)))
 217          (and (list? inside)
 218               (< 0 (length inside))
 219               (eq? sym (car inside))
 220               (let loop ((ls (cdr inside)) (alist '()))
 221                 (if (null? ls)
 222                     alist               ; retval
 223                     (let ((first (car ls)))
 224                       (or (symbol? first)
 225                           (error "bad list!"))
 226                       (loop (cddr ls)
 227                             (acons (string->symbol
 228                                     (substring (symbol->string first) 1))
 229                                    (cadr ls)
 230                                    alist)))))))))
 231
 232 ;; Filter FORMS, combining contiguous comment forms that have the same number
 233 ;; of leading semicolons.  Do not include in them whitespace lines.
 234 ;; Whitespace lines outside of such comment groupings are ignored, as are
 235 ;; hash-bang comments.  All other forms are passed through unchanged.
 236 ;;
 237 (define (clump forms)
 238   (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
 239     (if (null? forms)
 240         (reverse acc)                   ; retval
 241         (let ((form (car forms)))
 242           (cond (pass-this-one-through?
 243                  (loop (cdr forms) (cons form acc) #f))
 244                 ((quoted? 'following-form-properties form)
 245                  (loop (cdr forms) (cons form acc) #t))
 246                 ((quoted? 'whitespace form)             ;;; ignore
 247                  (loop (cdr forms) acc #f))
 248                 ((quoted? 'hash-bang-comment form)      ;;; ignore for now
 249                  (loop (cdr forms) acc #f))
 250                 ((quoted? 'comment form)
 251                  => (lambda (alist)
 252                       (let cloop ((inner-forms (cdr forms))
 253                                   (level (assq-ref alist 'leading-semicolons))
 254                                   (text (list (assq-ref alist 'text))))
 255                         (let ((up (lambda ()
 256                                     (loop inner-forms
 257                                           (cons (cons level (reverse text))
 258                                                 acc)
 259                                           #f))))
 260                           (if (null? inner-forms)
 261                               (up)
 262                               (let ((inner-form (car inner-forms)))
 263                                 (cond ((quoted? 'comment inner-form)
 264                                        => (lambda (inner-alist)
 265                                             (let ((new-level
 266                                                    (assq-ref
 267                                                     inner-alist
 268                                                     'leading-semicolons)))
 269                                               (if (= new-level level)
 270                                                   (cloop (cdr inner-forms)
 271                                                          level
 272                                                          (cons (assq-ref
 273                                                                 inner-alist
 274                                                                 'text)
 275                                                                text))
 276                                                   (up)))))
 277                                       (else (up)))))))))
 278                 (else (loop (cdr forms) (cons form acc) #f)))))))
 279
 280 ;;; script entry point
 281
 282 (define main read-scheme-source)
 283
 284 ;;; read-scheme-source ends here