Greetings earthlings,
Guile-BAUX[0] can extract docstrings for Scheme items from Scheme and C,
but does not support extraction of C items from C code (like doxygen et
al). However, its program tsin[1] can be (ab)used to handle the (easy)
interpolation duties, as the recent GNU Serveez[2] move from awk+sed to
s3as+tsin shows[3].
As it stands, s3as is not completely generalized (otherwise it would
have been added to Guile-BAUX proper), so i'm posting it here for now.
#!/bin/sh
exec ${GUILE-guile} -e '(guile-baux s3as)' -s $0 "$@" # -*- scheme -*-
!#
;;; s3as --- "slash star star" and Scheme for doc comments from C code
;; Copyright (C) 2011 Thien-Thi Nguyen
;;
;; 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 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
;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Usage: s3as [-o outfile] [file...]
;;
;; Scan FILE... for regions that look like:
;;
;; /**
;; * DOCSTRING
;; */
;; ITEM
;;
;; where ITEM is one of:
;;
;; #define NAME(...) (1 line) preprocessor macro
;;
;; TYPE NAME; (1 line) variable declaration
;;
;; RET-TYPE (3+ lines) function definition
;; NAME (...)
;; {
;; ...
;;
;; and display a tsar file (to OUTFILE if specified) composed entirely of
;; "titled text block" entries. The entry title is a string of the form
;; "C NAME", where C ∈ {M, V, F} (for macro, variable and function,
;; respectively) and NAME is as above. The entry blurb is DOCSTRING,
;; preceded by an appropriately formatted texinfo directive, one of
;; ‘@defmac’, ‘@deftypevar’ or ‘@deftypefun’, respectively, and followed
;; by the matching "@end foo" directive. The entry category is ‘#f’.
;;
;; Options processing in DOCSTRING a la tsar and c-tsar is not supported.
;; The tsar coding is unconditionally ‘utf-8’.
;;
;; Note: The input must not contain trailing whitespace.
;;; Code:
(define-module (guile-baux s3as)
#:export (main)
#:use-module ((guile-baux common) #:select (fs check-hv qop<-args))
#:use-module ((guile-baux ts-base) #:select (split-filename
make-ts))
#:use-module ((guile-baux ts-output) #:select (ar<-snippets
write-ar))
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module ((srfi srfi-13) #:select (string-concatenate
(string-trim-both . tight)
string-tokenize
string-skip-right
string-suffix?
string-join))
#:use-module ((srfi srfi-14) #:select (char-set-complement
char-set-adjoin
char-set
char-set:graphic
char-set:letter+digit))
#:use-module ((ice-9 regex) #:select (match:substring))
#:use-module ((ice-9 rdelim) #:select (read-line)))
(define V-RX (make-regexp (string-append
"^([[:alnum:]_ ]+[[:alnum:]_])"
"[[:space:]]+"
"([[:alnum:]_]+);$")))
(define M-RX (make-regexp (string-append
"^#[[:space:]]*define[[:space:]]"
"([[:alnum:]_]+)"
"(\\([^()]*\\))")))
(define arglist
(let ((surrounding (char-set #\space #\( #\)))
(except-comma (char-set-complement (char-set #\,))))
;; arglist
(lambda (s)
(map tight (string-tokenize (tight s surrounding) except-comma)))))
(define type-pair
(let ((identifier (char-set-adjoin char-set:letter+digit
#\_ #\[ #\])))
;; type-pair
(lambda (s)
(cond ((string-skip-right s identifier)
=> (lambda (pos)
(set! pos (1+ pos))
(cons (tight (substring s 0 pos))
(tight (substring s pos)))))
(else (string->symbol s))))))
(define (lfsep . ls)
(string-join ls "\n"))
(define (scan filename)
(let ((p (open-input-file filename))
(ents '()))
(define (next)
(let ((line (read-line p)))
(cond ((eof-object? line)
(close-port p)
#f)
(else
line))))
(define (get-details)
(let ((first (next))
(lno (port-line p)))
(cond
;; variable
((regexp-exec V-RX first)
=> (lambda (m)
(list 'V lno
(string->symbol (match:substring m 2))
(match:substring m 1))))
;; macro
((regexp-exec M-RX first)
=> (lambda (m)
(cons* 'M lno (string->symbol (match:substring m 1))
(arglist (match:substring m 2)))))
;; function
(else
(let* ((ret-type first)
(name (read p))
(args (let more ((acc (list (next))))
(if (string=? "{" (car acc))
(string-concatenate (reverse! (cdr acc)))
(more (cons (next) acc))))))
(cons* 'F (1+ lno) name
(if (string-index ret-type #\space)
ret-type
(string->symbol ret-type))
(map type-pair (arglist args))))))))
(define (ent! head doc)
(set! ents (acons head doc ents)))
(define (un-prefix line)
;; Strip leading " * " or " *" as the case may be. We make
;; do with ‘string-length’ because options processing is not
;; supported. If/when that happens, this needs to be changed
;; to use ‘string-prefix?’.
(substring line (min 3 (string-length line))))
(let loop ((line (next)))
(cond ((not line)
;; rv
ents)
((string=? "/**" line)
(let more ((acc (list (next))))
(if (string=? " */" (car acc))
(ent! (get-details)
(apply lfsep (map un-prefix (reverse! (cdr acc)))))
(more (cons (next) acc))))
(loop (next)))
(else (loop (next)))))))
(define (prettily ents)
(define (title detail)
(fs "~A ~A"
;; one of: V, M, F
(car detail)
;; name
(caddr detail)))
(define (csep ls)
(string-join ls ", "))
(define (render-typed-arg arg)
(define (at-var s)
(cond ((string-index s #\[)
=> (lambda (pos)
;; Say "@var{NAME}[FOO]" instead of "@var{NAME[FOO]}",
;; which elicits an "unlikely char [ in @var" warning
;; from makeinfo.
(fs "@var{~A}~A"
(substring s 0 pos)
(substring s pos))))
(else
(fs "@var{~A}" s))))
(cond ((not (pair? arg))
(fs "~A" arg))
((equal? '("..." . "") arg)
"@dots{}")
(else
(let* ((type (car arg))
(name (at-var (cdr arg)))
;; Say "TYPE *NAME" instead of "TYPE * NAME".
(full (if (string-suffix? "*" type)
(string-append type name)
(fs "~A ~A" type name)))
;; Replace all spaces with unbreakable space.
(ls (string-tokenize full char-set:graphic)))
(string-join ls "@tie{}")))))
(let ((renderers
`((V deftypevar
,(lambda (name type)
(fs "{~A} ~A" type name)))
(M defmac
,(lambda (name . args)
(fs "~A (~A)" name (csep args))))
(F deftypefun
,(lambda (name ret-type . args)
(fs "{~A} ~A (~A)"
ret-type name
(csep (map render-typed-arg args))))))))
(define (render det doc)
(list (vector (cadr det) 0 0 0)
(title det)
(let* ((label+top (assq-ref renderers (car det)))
(label (car label+top))
(top (cadr label+top)))
(lfsep (fs "@~A ~A" label (apply top (cddr det)))
doc
(fs "@end ~A" label)))))
(map render
(map car ents)
(map cdr ents))))
(define (collect filename)
(let ((ents (prettily (scan filename)))
(two (split-filename filename)))
(define (proper at name blurb)
(make-ts name '(-- s3as sez thx tsin --) two blurb #f #f at '()))
(map (lambda (ent)
(apply proper ent))
ents)))
(define (main/qop qop)
(qop 'output (lambda (filename)
(set-current-output-port
(open-output-file filename))))
(let* ((ar (ar<-snippets 'utf-8 (append-map collect (qop '())))))
(write-ar ar (current-output-port))))
(define (main args)
(check-hv args '((package . "GNU Serveez")
(version . "1.0")
(help . commentary)))
(main/qop (qop<-args
args '((output (single-char #\o) (value #t))))))
;;; s3as ends here
Comments welcome (but please exclude guile-sources from the reply).
Happy hacking,
thi
_______________________________________________________________
[0] http://www.gnuvola.org/software/guile-baux/
[1] http://www.gnuvola.org/software/guile-baux/guile-baux.html.gz#tsin
[2] https://savannah.gnu.org/projects/serveez
[3] http://git.savannah.gnu.org/cgit/serveez.git/commit/?id=eaad5886
--
a sig, not big, i fig, you dig?
