diff options
Diffstat (limited to 'module/texinfo.scm')
-rw-r--r-- | module/texinfo.scm | 1217 |
1 files changed, 1217 insertions, 0 deletions
diff --git a/module/texinfo.scm b/module/texinfo.scm new file mode 100644 index 000000000..76d79dfab --- /dev/null +++ b/module/texinfo.scm @@ -0,0 +1,1217 @@ +;;;; (texinfo) -- parsing of texinfo into SXML +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com> +;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> +;;;; +;;;; This file is based on SSAX's SSAX.scm. +;;;; +;;;; This library 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 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;; +;; @subheading Texinfo processing in scheme +;; +;; This module parses texinfo into SXML. TeX will always be the +;; processor of choice for print output, of course. However, although +;; @code{makeinfo} works well for info, its output in other formats is +;; not very customizable, and the program is not extensible as a whole. +;; This module aims to provide an extensible framework for texinfo +;; processing that integrates texinfo into the constellation of SXML +;; processing tools. +;; +;; @subheading Notes on the SXML vocabulary +;; +;; Consider the following texinfo fragment: +;; +;;@example +;; @@deffn Primitive set-car! pair value +;; This function... +;; @@end deffn +;;@end example +;; +;; Logically, the category (Primitive), name (set-car!), and arguments +;; (pair value) are ``attributes'' of the deffn, with the description as +;; the content. However, texinfo allows for @@-commands within the +;; arguments to an environment, like @code{@@deffn}, which means that +;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand, +;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are +;; called ``arguments'', and are grouped under the special element, `%'. +;; +;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In +;; the interests of interoperability, this module provides a conversion +;; function to replace the `%' with `texinfo-arguments'. +;; +;;; Code: + +;; Comparison to xml output of texinfo (which is rather undocumented): +;; Doesn't conform to texinfo dtd +;; No DTD at all, in fact :-/ +;; Actually outputs valid xml, after transforming % +;; Slower (although with caching the SXML that problem can go away) +;; Doesn't parse menus (although menus are shite) +;; Args go in a dedicated element, FBOFW +;; Definitions are handled a lot better +;; Does parse comments +;; Outputs only significant line breaks (a biggie!) +;; Nodes are treated as anchors, rather than content organizers (a biggie) +;; (more book-like, less info-like) + +;; TODO +;; Integration: help, indexing, plain text + +(define-module (texinfo) + #:use-module (sxml simple) + #:use-module (sxml transform) + #:use-module (sxml ssax input-parse) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:export (call-with-file-and-dir + texi-command-specs + texi-command-depth + texi-fragment->stexi + texi->stexi + stexi->sxml)) + +;; Some utilities + +(define (parser-error port message . rest) + (apply error port message rest)) + +(define (call-with-file-and-dir filename proc) + "Call the one-argument procedure @var{proc} with an input port that +reads from @var{filename}. During the dynamic extent of @var{proc}'s +execution, the current directory will be @code{(dirname +@var{filename})}. This is useful for parsing documents that can include +files by relative path name." + (let ((current-dir (getcwd))) + (dynamic-wind + (lambda () (chdir (dirname filename))) + (lambda () + (call-with-input-file (basename filename) proc)) + (lambda () (chdir current-dir))))) + +;; Define this version here, because (srfi srfi-11)'s definition uses +;; syntax-rules, which is really damn slow +(define-macro (let*-values bindings . body) + (if (null? bindings) (cons 'begin body) + (apply + (lambda (vars initializer) + (let ((cont + (cons 'let*-values + (cons (cdr bindings) body)))) + (cond + ((not (pair? vars)) ; regular let case, a single var + `(let ((,vars ,initializer)) ,cont)) + ((null? (cdr vars)) ; single var, see the prev case + `(let ((,(car vars) ,initializer)) ,cont)) + (else ; the most generic case + `(call-with-values (lambda () ,initializer) + (lambda ,vars ,cont)))))) + (car bindings)))) + +;;======================================================================== +;; Reflection on the XML vocabulary + +(define texi-command-specs + #; +"A list of (@var{name} @var{content-model} . @var{args}) + +@table @var +@item name +The name of an @@-command, as a symbol. + +@item content-model +A symbol indicating the syntactic type of the @@-command: +@table @code +@item EMPTY-COMMAND +No content, and no @code{@@end} is coming +@item EOL-ARGS +Unparsed arguments until end of line +@item EOL-TEXT +Parsed arguments until end of line +@item INLINE-ARGS +Unparsed arguments ending with @code{#\\@}} +@item INLINE-TEXT +Parsed arguments ending with @code{#\\@}} +@item ENVIRON +The tag is an environment tag, expect @code{@@end foo}. +@item TABLE-ENVIRON +Like ENVIRON, but with special parsing rules for its arguments. +@item FRAGMENT +For @code{*fragment*}, the command used for parsing fragments of +texinfo documents. +@end table + +@code{INLINE-TEXT} commands will receive their arguments within their +bodies, whereas the @code{-ARGS} commands will receive them in their +attribute list. + +@code{EOF-TEXT} receives its arguments in its body. + +@code{ENVIRON} commands have both: parsed arguments until the end of +line, received through their attribute list, and parsed text until the +@code{@@end}, received in their bodies. + +@code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in +@code{ENVIRON}. + +There are four @@-commands that are treated specially. @code{@@include} +is a low-level token that will not be seen by higher-level parsers, so +it has no content-model. @code{@@para} is the paragraph command, which +is only implicit in the texinfo source. @code{@@item} has special +syntax, as noted above, and @code{@@entry} is how this parser treats +@code{@@item} commands within @code{@@table}, @code{@@ftable}, and +@code{@@vtable}. + +Also, indexing commands (@code{@@cindex}, etc.) are treated specially. +Their arguments are parsed, but they are needed before entering the +element so that an anchor can be inserted into the text before the index +entry. + +@item args +Named arguments to the command, in the same format as the formals for a +lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, +@code{ENVIRON}, @code{TABLE-ENVIRON} commands. +@end table" + '(;; Special commands + (include #f) ;; this is a low-level token + (para PARAGRAPH) + (item ITEM) + (entry ENTRY . heading) + (noindent EMPTY-COMMAND) + (*fragment* FRAGMENT) + + ;; Inline text commands + (*braces* INLINE-TEXT) ;; FIXME: make me irrelevant + (bold INLINE-TEXT) + (sample INLINE-TEXT) + (samp INLINE-TEXT) + (code INLINE-TEXT) + (kbd INLINE-TEXT) + (key INLINE-TEXT) + (var INLINE-TEXT) + (env INLINE-TEXT) + (file INLINE-TEXT) + (command INLINE-TEXT) + (option INLINE-TEXT) + (dfn INLINE-TEXT) + (cite INLINE-TEXT) + (acro INLINE-TEXT) + (url INLINE-TEXT) + (email INLINE-TEXT) + (emph INLINE-TEXT) + (strong INLINE-TEXT) + (sample INLINE-TEXT) + (sc INLINE-TEXT) + (titlefont INLINE-TEXT) + (asis INLINE-TEXT) + (b INLINE-TEXT) + (i INLINE-TEXT) + (r INLINE-TEXT) + (sansserif INLINE-TEXT) + (slanted INLINE-TEXT) + (t INLINE-TEXT) + + ;; Inline args commands + (value INLINE-ARGS . (key)) + (ref INLINE-ARGS . (node #:opt name section info-file manual)) + (xref INLINE-ARGS . (node #:opt name section info-file manual)) + (pxref INLINE-ARGS . (node #:opt name section info-file manual)) + (uref INLINE-ARGS . (url #:opt title replacement)) + (anchor INLINE-ARGS . (name)) + (dots INLINE-ARGS . ()) + (result INLINE-ARGS . ()) + (bullet INLINE-ARGS . ()) + (copyright INLINE-ARGS . ()) + (tie INLINE-ARGS . ()) + (image INLINE-ARGS . (file #:opt width height alt-text extension)) + + ;; EOL args elements + (node EOL-ARGS . (name #:opt next previous up)) + (c EOL-ARGS . all) + (comment EOL-ARGS . all) + (setchapternewpage EOL-ARGS . all) + (sp EOL-ARGS . all) + (page EOL-ARGS . ()) + (vskip EOL-ARGS . all) + (syncodeindex EOL-ARGS . all) + (contents EOL-ARGS . ()) + (shortcontents EOL-ARGS . ()) + (summarycontents EOL-ARGS . ()) + (insertcopying EOL-ARGS . ()) + (dircategory EOL-ARGS . (category)) + (top EOL-ARGS . (title)) + (printindex EOL-ARGS . (type)) + + ;; EOL text commands + (*ENVIRON-ARGS* EOL-TEXT) + (itemx EOL-TEXT) + (set EOL-TEXT) + (center EOL-TEXT) + (title EOL-TEXT) + (subtitle EOL-TEXT) + (author EOL-TEXT) + (chapter EOL-TEXT) + (section EOL-TEXT) + (appendix EOL-TEXT) + (appendixsec EOL-TEXT) + (unnumbered EOL-TEXT) + (unnumberedsec EOL-TEXT) + (subsection EOL-TEXT) + (subsubsection EOL-TEXT) + (appendixsubsec EOL-TEXT) + (appendixsubsubsec EOL-TEXT) + (unnumberedsubsec EOL-TEXT) + (unnumberedsubsubsec EOL-TEXT) + (chapheading EOL-TEXT) + (majorheading EOL-TEXT) + (heading EOL-TEXT) + (subheading EOL-TEXT) + (subsubheading EOL-TEXT) + + (deftpx EOL-TEXT-ARGS . (category name . attributes)) + (defcvx EOL-TEXT-ARGS . (category class name)) + (defivarx EOL-TEXT-ARGS . (class name)) + (deftypeivarx EOL-TEXT-ARGS . (class data-type name)) + (defopx EOL-TEXT-ARGS . (category class name . arguments)) + (deftypeopx EOL-TEXT-ARGS . (category class data-type name . arguments)) + (defmethodx EOL-TEXT-ARGS . (class name . arguments)) + (deftypemethodx EOL-TEXT-ARGS . (class data-type name . arguments)) + (defoptx EOL-TEXT-ARGS . (name)) + (defvrx EOL-TEXT-ARGS . (category name)) + (defvarx EOL-TEXT-ARGS . (name)) + (deftypevrx EOL-TEXT-ARGS . (category data-type name)) + (deftypevarx EOL-TEXT-ARGS . (data-type name)) + (deffnx EOL-TEXT-ARGS . (category name . arguments)) + (deftypefnx EOL-TEXT-ARGS . (category data-type name . arguments)) + (defspecx EOL-TEXT-ARGS . (name . arguments)) + (defmacx EOL-TEXT-ARGS . (name . arguments)) + (defunx EOL-TEXT-ARGS . (name . arguments)) + (deftypefunx EOL-TEXT-ARGS . (data-type name . arguments)) + + ;; Indexing commands + (cindex INDEX . entry) + (findex INDEX . entry) + (vindex INDEX . entry) + (kindex INDEX . entry) + (pindex INDEX . entry) + (tindex INDEX . entry) + + ;; Environment commands (those that need @end) + (texinfo ENVIRON . title) + (ignore ENVIRON . ()) + (ifinfo ENVIRON . ()) + (iftex ENVIRON . ()) + (ifhtml ENVIRON . ()) + (ifxml ENVIRON . ()) + (ifplaintext ENVIRON . ()) + (ifnotinfo ENVIRON . ()) + (ifnottex ENVIRON . ()) + (ifnothtml ENVIRON . ()) + (ifnotxml ENVIRON . ()) + (ifnotplaintext ENVIRON . ()) + (titlepage ENVIRON . ()) + (menu ENVIRON . ()) + (direntry ENVIRON . ()) + (copying ENVIRON . ()) + (example ENVIRON . ()) + (smallexample ENVIRON . ()) + (display ENVIRON . ()) + (smalldisplay ENVIRON . ()) + (verbatim ENVIRON . ()) + (format ENVIRON . ()) + (smallformat ENVIRON . ()) + (lisp ENVIRON . ()) + (smalllisp ENVIRON . ()) + (cartouche ENVIRON . ()) + (quotation ENVIRON . ()) + + (deftp ENVIRON . (category name . attributes)) + (defcv ENVIRON . (category class name)) + (defivar ENVIRON . (class name)) + (deftypeivar ENVIRON . (class data-type name)) + (defop ENVIRON . (category class name . arguments)) + (deftypeop ENVIRON . (category class data-type name . arguments)) + (defmethod ENVIRON . (class name . arguments)) + (deftypemethod ENVIRON . (class data-type name . arguments)) + (defopt ENVIRON . (name)) + (defvr ENVIRON . (category name)) + (defvar ENVIRON . (name)) + (deftypevr ENVIRON . (category data-type name)) + (deftypevar ENVIRON . (data-type name)) + (deffn ENVIRON . (category name . arguments)) + (deftypefn ENVIRON . (category data-type name . arguments)) + (defspec ENVIRON . (name . arguments)) + (defmac ENVIRON . (name . arguments)) + (defun ENVIRON . (name . arguments)) + (deftypefun ENVIRON . (data-type name . arguments)) + + (table TABLE-ENVIRON . (formatter)) + (itemize TABLE-ENVIRON . (formatter)) + (enumerate TABLE-ENVIRON . (start)) + (ftable TABLE-ENVIRON . (formatter)) + (vtable TABLE-ENVIRON . (formatter)))) + +(define command-depths + '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4) + (top . 0) (unnumbered . 1) (unnumberedsec . 2) + (unnumberedsubsec . 3) (unnumberedsubsubsec . 4) + (appendix . 1) (appendixsec . 2) (appendixsection . 2) + (appendixsubsec . 3) (appendixsubsubsec . 4))) +(define (texi-command-depth command max-depth) + "Given the texinfo command @var{command}, return its nesting level, or +@code{#f} if it nests too deep for @var{max-depth}. + +Examples: +@example +(texi-command-depth 'chapter 4) @result{} 1 +(texi-command-depth 'top 4) @result{} 0 +(texi-command-depth 'subsection 4) @result{} 3 +(texi-command-depth 'appendixsubsec 4) @result{} 3 +(texi-command-depth 'subsection 2) @result{} #f +@end example" + (let ((depth (and=> (assq command command-depths) cdr))) + (and depth (<= depth max-depth) depth))) + +;; The % is for arguments +(define (space-significant? command) + (memq command + '(example smallexample verbatim lisp smalllisp menu %))) + +;; Like a DTD for texinfo +(define (command-spec command) + (or (assq command texi-command-specs) + (parser-error #f "Unknown command" command))) + +(define (inline-content? content) + (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS))) + + +;;======================================================================== +;; Lower-level parsers and scanners +;; +;; They deal with primitive lexical units (Names, whitespaces, tags) and +;; with pieces of more generic productions. Most of these parsers must +;; be called in appropriate context. For example, complete-start-command +;; must be called only when the @-command start has been detected and +;; its name token has been read. + +;; Test if a string is made of only whitespace +;; An empty string is considered made of whitespace as well +(define (string-whitespace? str) + (or (string-null? str) + (string-every char-whitespace? str))) + +;; Like read-text-line, but allows EOF. +(define read-eof-breaks '(*eof* #\return #\newline)) +(define (read-eof-line port) + (if (eof-object? (peek-char port)) + (peek-char port) + (let* ((line (next-token '() read-eof-breaks + "reading a line" port)) + (c (read-char port))) ; must be either \n or \r or EOF + (if (and (eq? c #\return) (eq? (peek-char port) #\newline)) + (read-char port)) ; skip \n that follows \r + line))) + +(define ascii->char integer->char) + +(define (skip-whitespace port) + (skip-while '(#\space #\tab #\return #\newline) port)) + +(define (skip-horizontal-whitespace port) + (skip-while '(#\space #\tab) port)) + +;; command ::= Letter+ + +;; procedure: read-command PORT +;; +;; Read a command starting from the current position in the PORT and +;; return it as a symbol. +(define (read-command port) + (let ((first-char (peek-char port))) + (or (char-alphabetic? first-char) + (parser-error port "Nonalphabetic @-command char: '" first-char "'"))) + (string->symbol + (next-token-of + (lambda (c) + (cond + ((eof-object? c) #f) + ((char-alphabetic? c) c) + (else #f))) + port))) + +;; A token is a primitive lexical unit. It is a record with two fields, +;; token-head and token-kind. +;; +;; Token types: +;; END The end of a texinfo command. If the command is ended by }, +;; token-head will be #f. Otherwise if the command is ended by +;; @end COMMAND, token-head will be COMMAND. As a special case, +;; @bye is the end of a special @texinfo command. +;; START The start of a texinfo command. The token-head will be a +;; symbol of the @-command name. +;; INCLUDE An @include directive. The token-head will be empty -- the +;; caller is responsible for reading the include file name. +;; ITEM @item commands have an irregular syntax. They end at the +;; next @item, or at the end of the environment. For that +;; read-command-token treats them specially. + +(define (make-token kind head) (cons kind head)) +(define token? pair?) +(define token-kind car) +(define token-head cdr) + +;; procedure: read-command-token PORT +;; +;; This procedure starts parsing of a command token. The current +;; position in the stream must be #\@. This procedure scans enough of +;; the input stream to figure out what kind of a command token it is +;; seeing. The procedure returns a token structure describing the token. + +(define (read-command-token port) + (assert-curr-char '(#\@) "start of the command" port) + (let ((peeked (peek-char port))) + (cond + ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\})) + ;; @-commands that escape characters + (make-token 'STRING (string (read-char port)))) + (else + (let ((name (read-command port))) + (case name + ((end) + ;; got an ending tag + (let ((command (string-trim-both + (read-eof-line port)))) + (or (and (not (string-null? command)) + (string-every char-alphabetic? command)) + (parser-error port "malformed @end" command)) + (make-token 'END (string->symbol command)))) + ((bye) + ;; the end of the top + (make-token 'END 'texinfo)) + ((item) + (make-token 'ITEM 'item)) + ((include) + (make-token 'INCLUDE #f)) + (else + (make-token 'START name)))))))) + +;; procedure+: read-verbatim-body PORT STR-HANDLER SEED +;; +;; This procedure must be called after we have read a string +;; "@verbatim\n" that begins a verbatim section. The current position +;; must be the first position of the verbatim body. This function reads +;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a +;; character data consumer. +;; +;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED. +;; The first STRING1 argument to STR-HANDLER never contains a newline. +;; The second STRING2 argument often will. On the first invocation of the +;; STR-HANDLER, the seed is the one passed to read-verbatim-body +;; as the third argument. The result of this first invocation will be +;; passed as the seed argument to the second invocation of the line +;; consumer, and so on. The result of the last invocation of the +;; STR-HANDLER is returned by the read-verbatim-body. Note a +;; similarity to the fundamental 'fold' iterator. +;; +;; Within a verbatim section all characters are taken at their face +;; value. It ends with "\n@end verbatim(\r)?\n". + +;; Must be called right after the newline after @verbatim. +(define (read-verbatim-body port str-handler seed) + (let loop ((seed seed)) + (let ((fragment (next-token '() '(#\newline) + "reading verbatim" port))) + ;; We're reading the char after the 'fragment', which is + ;; #\newline. + (read-char port) + (if (string=? fragment "@end verbatim") + seed + (loop (str-handler fragment "\n" seed)))))) + +;; procedure+: read-arguments PORT +;; +;; This procedure reads and parses a production ArgumentList. +;; ArgumentList ::= S* Argument (S* , S* Argument)* S* +;; Argument ::= ([^@{},])* +;; +;; Arguments are the things in braces, i.e @ref{my node} has one +;; argument, "my node". Most commands taking braces actually don't have +;; arguments, they process text. For example, in +;; @emph{@strong{emphasized}}, the emph takes text, because the parse +;; continues into the braces. +;; +;; Any whitespace within Argument is replaced with a single space. +;; Whitespace around an Argument is trimmed. +;; +;; The procedure returns a list of arguments. Afterwards the current +;; character will be after the final #\}. + +(define (read-arguments port stop-char) + (define (split str) + (read-char port) ;; eat the delimiter + (let ((ret (map (lambda (x) (if (string-null? x) #f x)) + (map string-trim-both (string-split str #\,))))) + (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret))) + '() + ret))) + (split (next-token '() (list stop-char) + "arguments of @-command" port))) + +;; procedure+: complete-start-command COMMAND PORT +;; +;; This procedure is to complete parsing of an @-command. The procedure +;; must be called after the command token has been read. COMMAND is a +;; TAG-NAME. +;; +;; This procedure returns several values: +;; COMMAND: a symbol. +;; ARGUMENTS: command's arguments, as an alist. +;; CONTENT-MODEL: the content model of the command. +;; +;; On exit, the current position in PORT will depend on the CONTENT-MODEL. +;; +;; Content model Port position +;; ============= ============= +;; INLINE-TEXT One character after the #\{. +;; INLINE-ARGS The first character after the #\}. +;; EOL-TEXT The first non-whitespace character after the command. +;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT +;; The first character on the next line. +;; PARAGRAPH, ITEM, EMPTY-COMMAND +;; The first character after the command. + +(define (arguments->attlist port args arg-names) + (let loop ((in args) (names arg-names) (opt? #f) (out '())) + (cond + ((symbol? names) ;; a rest arg + (reverse (if (null? in) out (acons names in out)))) + ((and (not (null? names)) (eq? (car names) #:opt)) + (loop in (cdr names) #t out)) + ((null? in) + (if (or (null? names) opt?) + (reverse out) + (parser-error port "@-command expected more arguments:" + args arg-names names))) + ((null? names) + (parser-error port "@-command didn't expect more arguments:" in)) + ((not (car in)) + (or (and opt? (loop (cdr in) (cdr names) opt? out)) + (parser-error "@-command missing required argument" + (car names)))) + (else + (loop (cdr in) (cdr names) opt? + (cons (list (car names) (car in)) out)))))) + +(define (parse-table-args command port) + (let* ((line (string-trim-both (read-text-line port))) + (length (string-length line))) + (define (get-formatter) + (or (and (not (zero? length)) + (eq? (string-ref line 0) #\@) + (let ((f (string->symbol (substring line 1)))) + (or (inline-content? (cadr (command-spec f))) + (parser-error + port "@item formatter must be INLINE" f)) + f)) + (parser-error "Invalid @item formatter" line))) + (case command + ((enumerate) + (if (zero? length) + '() + `((start + ,(if (or (and (eq? length 1) + (char-alphabetic? (string-ref line 0))) + (string-every char-numeric? line)) + line + (parser-error + port "Invalid enumerate start" line)))))) + ((itemize) + `((bullet + ,(or (and (eq? length 1) line) + (and (string-null? line) '(bullet)) + (list (get-formatter)))))) + (else ;; tables of various varieties + `((formatter (,(get-formatter)))))))) + +(define (complete-start-command command port) + (define (get-arguments type arg-names stop-char) + (arguments->attlist port (read-arguments port stop-char) arg-names)) + + (let* ((spec (command-spec command)) + (type (cadr spec)) + (arg-names (cddr spec))) + (case type + ((INLINE-TEXT) + (assert-curr-char '(#\{) "Inline element lacks {" port) + (values command '() type)) + ((INLINE-ARGS) + (assert-curr-char '(#\{) "Inline element lacks {" port) + (values command (get-arguments type arg-names #\}) type)) + ((EOL-ARGS) + (values command (get-arguments type arg-names #\newline) type)) + ((ENVIRON ENTRY INDEX) + (skip-horizontal-whitespace port) + (values command (parse-environment-args command port) type)) + ((TABLE-ENVIRON) + (skip-horizontal-whitespace port) + (values command (parse-table-args command port) type)) + ((EOL-TEXT) + (skip-horizontal-whitespace port) + (values command '() type)) + ((EOL-TEXT-ARGS) + (skip-horizontal-whitespace port) + (values command (parse-eol-text-args command port) type)) + ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT) + (values command '() type)) + (else ;; INCLUDE shouldn't get here + (parser-error port "can't happen"))))) + +;;----------------------------------------------------------------------------- +;; Higher-level parsers and scanners +;; +;; They parse productions corresponding entire @-commands. + +;; Only reads @settitle, leaves it to the command parser to finish +;; reading the title. +(define (take-until-settitle port) + (or (find-string-from-port? "\n@settitle " port) + (parser-error port "No \\n@settitle found")) + (skip-horizontal-whitespace port) + (and (eq? (peek-char port) #\newline) + (parser-error port "You have a @settitle, but no title"))) + +;; procedure+: read-char-data PORT EXPECT-EOF? STR-HANDLER SEED +;; +;; This procedure is to read the CharData of a texinfo document. +;; +;; text ::= (CharData | Command)* +;; +;; The procedure reads CharData and stops at @-commands (or +;; environments). It also stops at an open or close brace. +;; +;; port +;; a PORT to read +;; expect-eof? +;; a boolean indicating if EOF is normal, i.e., the character +;; data may be terminated by the EOF. EOF is normal +;; while processing the main document. +;; preserve-ws? +;; a boolean indicating if we are within a whitespace-preserving +;; environment. If #t, suppress paragraph detection. +;; str-handler +;; a STR-HANDLER, see read-verbatim-body +;; seed +;; an argument passed to the first invocation of STR-HANDLER. +;; +;; The procedure returns two results: SEED and TOKEN. The SEED is the +;; result of the last invocation of STR-HANDLER, or the original seed if +;; STR-HANDLER was never called. +;; +;; TOKEN can be either an eof-object (this can happen only if expect-eof? +;; was #t), or a texinfo token denoting the start or end of a tag. + +;; read-char-data port expect-eof? preserve-ws? str-handler seed +(define read-char-data + (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline))) + (define (handle str-handler str1 str2 seed) + (if (and (string-null? str1) (string-null? str2)) + seed + (str-handler str1 str2 seed))) + + (lambda (port expect-eof? preserve-ws? str-handler seed) + (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof))) + (let loop ((seed seed)) + (let* ((fragment (next-token '() end-chars "reading char data" port)) + (term-char (peek-char port))) ; one of end-chars + (cond + ((eof-object? term-char) ; only if expect-eof? + (values (handle str-handler fragment "" seed) term-char)) + ((memq term-char '(#\@ #\{ #\})) + (values (handle str-handler fragment "" seed) + (case term-char + ((#\@) (read-command-token port)) + ((#\{) (make-token 'START '*braces*)) + ((#\}) (read-char port) (make-token 'END #f))))) + ((eq? term-char #\newline) + ;; Always significant, unless directly before an end token. + (let ((c (peek-next-char port))) + (cond + ((eof-object? c) + (or expect-eof? + (parser-error port "EOF while reading char data")) + (values (handle str-handler fragment "" seed) c)) + ((eq? c #\@) + (let* ((token (read-command-token port)) + (end? (eq? (token-kind token) 'END))) + (values + (handle str-handler fragment (if end? "" " ") seed) + token))) + ((and (not preserve-ws?) (eq? c #\newline)) + ;; paragraph-separator ::= #\newline #\newline+ + (skip-while '(#\newline) port) + (skip-horizontal-whitespace port) + (values (handle str-handler fragment "" seed) + (make-token 'PARA 'para))) + (else + (loop (handle str-handler fragment + (if preserve-ws? "\n" " ") seed))))))))))))) + +; procedure+: assert-token TOKEN KIND NAME +; Make sure that TOKEN is of anticipated KIND and has anticipated NAME +(define (assert-token token kind name) + (or (and (token? token) + (eq? kind (token-kind token)) + (equal? name (token-head token))) + (parser-error #f "Expecting @end for " name ", got " token))) + +;;======================================================================== +;; Highest-level parsers: Texinfo to SXML + +;; These parsers are a set of syntactic forms to instantiate a SSAX +;; parser. The user tells what to do with the parsed character and +;; element data. These latter handlers determine if the parsing follows a +;; SAX or a DOM model. + +;; syntax: make-command-parser fdown fup str-handler + +;; Create a parser to parse and process one element, including its +;; character content or children elements. The parser is typically +;; applied to the root element of a document. + +;; fdown +;; procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED +;; +;; This procedure is to generate the seed to be passed to handlers +;; that process the content of the element. This is the function +;; identified as 'fdown' in the denotational semantics of the XML +;; parser given in the title comments to (sxml ssax). +;; +;; fup +;; procedure COMMAND ARGUMENTS PARENT-SEED SEED +;; +;; This procedure is called when parsing of COMMAND is finished. +;; The SEED is the result from the last content parser (or from +;; fdown if the element has the empty content). PARENT-SEED is the +;; same seed as was passed to fdown. The procedure is to generate a +;; seed that will be the result of the element parser. This is the +;; function identified as 'fup' in the denotational semantics of +;; the XML parser given in the title comments to (sxml ssax). +;; +;; str-handler +;; A STR-HANDLER, see read-verbatim-body +;; + +;; The generated parser is a +;; procedure COMMAND PORT SEED +;; +;; The procedure must be called *after* the command token has been read. + +(define (read-include-file-name port) + (let ((x (string-trim-both (read-eof-line port)))) + (if (string-null? x) + (error "no file listed") + x))) ;; fixme: should expand @value{} references + +(define (sxml->node-name sxml) + "Turn some sxml string into a valid node name." + (let loop ((in (string->list (sxml->string sxml))) (out '())) + (if (null? in) + (apply string (reverse out)) + (if (memq (car in) '(#\{ #\} #\@ #\,)) + (loop (cdr in) out) + (loop (cdr in) (cons (car in) out)))))) + +(define (index command arguments fdown fup parent-seed) + (case command + ((deftp defcv defivar deftypeivar defop deftypeop defmethod + deftypemethod defopt defvr defvar deftypevr deftypevar deffn + deftypefn defspec defmac defun deftypefun) + (let ((args `((name ,(string-append (symbol->string command) "-" + (cadr (assq 'name arguments))))))) + (fup 'anchor args parent-seed + (fdown 'anchor args 'INLINE-ARGS '())))) + ((cindex findex vindex kindex pindex tindex) + (let ((args `((name ,(string-append (symbol->string command) "-" + (sxml->node-name + (assq 'entry arguments))))))) + (fup 'anchor args parent-seed + (fdown 'anchor args 'INLINE-ARGS '())))) + (else parent-seed))) + +(define (make-command-parser fdown fup str-handler) + (lambda (command port seed) + (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed)) + (let*-values (((command arguments expected-content) + (complete-start-command command port))) + (let* ((parent-seed (index command arguments fdown fup parent-seed)) + (seed (fdown command arguments expected-content parent-seed)) + (eof-closes? (or (memq command '(texinfo para *fragment*)) + (eq? expected-content 'EOL-TEXT))) + (sig-ws? (or sig-ws? (space-significant? command))) + (up (lambda (s) (fup command arguments parent-seed s))) + (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s))) + (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s))))) + + (define (port-for-content) + (if (eq? expected-content 'EOL-TEXT) + (call-with-input-string (read-text-line port) identity) + port)) + + (cond + ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX + EOL-TEXT-ARGS)) + ;; empty or finished by complete-start-command + (up seed)) + ((eq? command 'verbatim) + (up (read-verbatim-body port str-handler seed))) + (else + (let loop ((port (port-for-content)) + (expect-eof? eof-closes?) + (end-para identity) + (need-break? (and (not sig-ws?) + (memq expected-content + '(ENVIRON TABLE-ENVIRON + ENTRY ITEM FRAGMENT)))) + (seed seed)) + (cond + ((and need-break? (or sig-ws? (skip-whitespace port)) + (not (memq (peek-char port) '(#\@ #\}))) + (not (eof-object? (peek-char port)))) + ;; Even if we have an @, it might be inline -- check + ;; that later + (let ((seed (end-para seed))) + (loop port expect-eof? (make-end-para seed) #f + (new-para seed)))) + (else + (let*-values (((seed token) + (read-char-data + port expect-eof? sig-ws? str-handler seed))) + (cond + ((eof-object? token) + (case expect-eof? + ((include #f) (end-para seed)) + (else (up (end-para seed))))) + (else + (case (token-kind token) + ((STRING) + ;; this is only @-commands that escape + ;; characters: @}, @@, @{ -- new para if need-break + (let ((seed ((if need-break? end-para identity) seed))) + (loop port expect-eof? + (if need-break? (make-end-para seed) end-para) #f + (str-handler (token-head token) "" + ((if need-break? new-para identity) + seed))))) + ((END) + ;; The end will only have a name if it's for an + ;; environment + (cond + ((memq command '(item entry)) + (let ((spec (command-spec (token-head token)))) + (or (eq? (cadr spec) 'TABLE-ENVIRON) + (parser-error + port "@item not ended by @end table/enumerate/itemize" + token)))) + ((eq? expected-content 'ENVIRON) + (assert-token token 'END command))) + (up (end-para seed))) + ((ITEM) + (cond + ((memq command '(enumerate itemize)) + (up (visit 'item port sig-ws? (end-para seed)))) + ((eq? expected-content 'TABLE-ENVIRON) + (up (visit 'entry port sig-ws? (end-para seed)))) + ((memq command '(item entry)) + (visit command port sig-ws? (up (end-para seed)))) + (else + (parser-error + port "@item must be within a table environment" + command)))) + ((PARA) + ;; examine valid paragraphs? + (loop port expect-eof? end-para (not sig-ws?) seed)) + ((INCLUDE) + ;; Recurse for include files + (let ((seed (call-with-file-and-dir + (read-include-file-name port) + (lambda (port) + (loop port 'include end-para + need-break? seed))))) + (loop port expect-eof? end-para need-break? seed))) + ((START) ; Start of an @-command + (let* ((head (token-head token)) + (type (cadr (command-spec head))) + (inline? (inline-content? type)) + (seed ((if (and inline? (not need-break?)) + identity end-para) seed)) + (end-para (if inline? + (if need-break? (make-end-para seed) + end-para) + identity)) + (new-para (if (and inline? need-break?) + new-para identity))) + (loop port expect-eof? end-para (not inline?) + (visit head port sig-ws? (new-para seed))))) + (else + (parser-error port "Unknown token type" token)))))))))))))))) + +;; procedure: reverse-collect-str-drop-ws fragments +;; +;; Given the list of fragments (some of which are text strings), reverse +;; the list and concatenate adjacent text strings. We also drop +;; "unsignificant" whitespace, that is, whitespace in front, behind and +;; between elements. The whitespace that is included in character data +;; is not affected. +(define (reverse-collect-str-drop-ws fragments) + (cond + ((null? fragments) ; a shortcut + '()) + ((and (string? (car fragments)) ; another shortcut + (null? (cdr fragments)) ; remove single ws-only string + (string-whitespace? (car fragments))) + '()) + (else + (let loop ((fragments fragments) (result '()) (strs '()) + (all-whitespace? #t)) + (cond + ((null? fragments) + (if all-whitespace? + result ; remove leading ws + (cons (apply string-append strs) result))) + ((string? (car fragments)) + (loop (cdr fragments) result (cons (car fragments) strs) + (and all-whitespace? + (string-whitespace? (car fragments))))) + (else + (loop (cdr fragments) + (cons + (car fragments) + (cond + ((null? strs) result) + (all-whitespace? + (if (null? result) + result ; remove trailing whitespace + (cons " " result))); replace interstitial ws with + ; one space + (else + (cons (apply string-append strs) result)))) + '() #t))))))) + +(define (make-dom-parser) + (make-command-parser + (lambda (command args content seed) ; fdown + '()) + (lambda (command args parent-seed seed) ; fup + (let ((seed (reverse-collect-str-drop-ws seed))) + (acons command + (if (null? args) seed (acons '% args seed)) + parent-seed))) + (lambda (string1 string2 seed) ; str-handler + (if (string-null? string2) + (cons string1 seed) + (cons* string2 string1 seed))))) + +(define parse-environment-args + (let ((parser (make-dom-parser))) + ;; duplicate arguments->attlist to avoid unnecessary splitting + (lambda (command port) + (let ((args (cdar (parser '*ENVIRON-ARGS* port '()))) + (arg-names (cddr (command-spec command)))) + (cond + ((not arg-names) + (if (null? args) '() + (parser-error port "@-command doesn't take args" command))) + ((eq? arg-names #t) + (list (cons 'arguments args))) + (else + (let loop ((args args) (arg-names arg-names) (out '())) + (cond + ((null? arg-names) + (if (null? args) (reverse! out) + (parser-error port "@-command didn't expect more args" + command args))) + ((symbol? arg-names) + (reverse! (acons arg-names args out))) + ((null? args) + (parser-error port "@-command expects more args" + command arg-names)) + ((and (string? (car args)) (string-index (car args) #\space)) + => (lambda (i) + (let ((rest (substring/shared (car args) (1+ i)))) + (if (zero? i) + (loop (cons rest (cdr args)) arg-names out) + (loop (cons rest (cdr args)) (cdr arg-names) + (cons (list (car arg-names) + (substring (car args) 0 i)) + out)))))) + (else + (loop (cdr args) (cdr arg-names) + (if (and (pair? (car args)) (eq? (caar args) '*braces*)) + (acons (car arg-names) (cdar args) out) + (cons (list (car arg-names) (car args)) out)))))))))))) + +(define (parse-eol-text-args command port) + ;; perhaps parse-environment-args should be named more + ;; generically. + (parse-environment-args command port)) + +;; procedure: texi-fragment->stexi STRING +;; +;; A DOM parser for a texinfo fragment STRING. +;; +;; The procedure returns an SXML tree headed by the special tag, +;; *fragment*. + +(define (texi-fragment->stexi string-or-port) + "Parse the texinfo commands in @var{string-or-port}, and return the +resultant stexi tree. The head of the tree will be the special command, +@code{*fragment*}." + (define (parse port) + (postprocess (car ((make-dom-parser) '*fragment* port '())))) + (if (input-port? string-or-port) + (parse string-or-port) + (call-with-input-string string-or-port parse))) + +;; procedure: texi->stexi PORT +;; +;; This is an instance of a SSAX parser above that returns an SXML +;; representation of the texinfo document ready to be read at PORT. +;; +;; The procedure returns an SXML tree. The port points to the +;; first character after the @bye, or to the end of the file. + +(define (texi->stexi port) + "Read a full texinfo document from @var{port} and return the parsed +stexi tree. The parsing will start at the @code{@@settitle} and end at +@code{@@bye} or EOF." + (let ((parser (make-dom-parser))) + (take-until-settitle port) + (postprocess (car (parser 'texinfo port '()))))) + +(define (car-eq? x y) (and (pair? x) (eq? (car x) y))) +(define (make-contents tree) + (define (lp in out depth) + (cond + ((null? in) (values in (cons 'enumerate (reverse! out)))) + ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4)) + => (lambda (new-depth) + (let ((node-name (and (car-eq? (car in) 'node) + (cadr (assq 'name (cdadar in)))))) + (cond + ((< new-depth depth) + (values in (cons 'enumerate (reverse! out)))) + ((> new-depth depth) + (let ((out-cdr (if (null? out) '() (cdr out))) + (out-car (if (null? out) (list 'item) (car out)))) + (let*-values (((new-in new-out) (lp in '() (1+ depth)))) + (lp new-in + (cons (append out-car (list new-out)) out-cdr) + depth)))) + (else ;; same depth + (lp (cddr in) + (cons + `(item (para + ,@(if node-name + `((ref (% (node ,node-name)))) + (cdadr in)))) + out) + depth)))))) + (else (lp (cdr in) out depth)))) + (let*-values (((_ contents) (lp tree '() 1))) + `((chapheading "Table of Contents") ,contents))) + +(define (trim-whitespace str trim-left? trim-right?) + (let* ((left-space? (and (not trim-left?) + (string-prefix? " " str))) + (right-space? (and (not trim-right?) + (string-suffix? " " str))) + (tail (append! (string-tokenize str) + (if right-space? '("") '())))) + (string-join (if left-space? (cons "" tail) tail)))) + +(define (postprocess tree) + (define (loop in out state first? sig-ws?) + (cond + ((null? in) + (values (reverse! out) state)) + ((string? (car in)) + (loop (cdr in) + (cons (if sig-ws? (car in) + (trim-whitespace (car in) first? (null? (cdr in)))) + out) + state #f sig-ws?)) + ((pair? (car in)) + (case (caar in) + ((set) + (if (null? (cdar in)) (error "@set missing arguments" in)) + (if (string? (cadar in)) + (let ((i (string-index (cadar in) #\space))) + (if i + (loop (cdr in) out + (acons (substring (cadar in) 0 i) + (cons (substring (cadar in) (1+ i)) (cddar in)) + state) + #f sig-ws?) + (loop (cdr in) out (acons (cadar in) (cddar in) state) + #f sig-ws?))) + (error "expected a constant to define for @set" in))) + ((value) + (loop (fold-right cons (cdr in) + (or (and=> + (assoc (cadr (assq 'key (cdadar in))) state) cdr) + (error "unknown value" (cdadar in) state))) + out + state #f sig-ws?)) + ((copying) + (loop (cdr in) out (cons (car in) state) #f sig-ws?)) + ((insertcopying) + (loop (fold-right cons (cdr in) + (or (cdr (assoc 'copying state)) + (error "copying isn't set yet"))) + out + state #f sig-ws?)) + ((contents) + (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?)) + (else + (let*-values (((kid-out state) + (loop (car in) '() state #t + (or sig-ws? (space-significant? (caar in)))))) + (loop (cdr in) (cons kid-out out) state #f sig-ws?))))) + (else ; a symbol + (loop (cdr in) (cons (car in) out) state #t sig-ws?)))) + + (call-with-values + (lambda () (loop tree '() '() #t #f)) + (lambda (out state) out))) + +;; Replace % with texinfo-arguments. +(define (stexi->sxml tree) + "Transform the stexi tree @var{tree} into sxml. This involves +replacing the @code{%} element that keeps the texinfo arguments with an +element for each argument. + +FIXME: right now it just changes % to @code{texinfo-arguments} -- that +doesn't hang with the idea of making a dtd at some point" + (pre-post-order + tree + `((% . ,(lambda (x . t) (cons 'texinfo-arguments t))) + (*text* . ,(lambda (x t) t)) + (*default* . ,(lambda (x . t) (cons x t)))))) + +;;; arch-tag: 73890afa-597c-4264-ae70-46fe7756ffb5 +;;; texinfo.scm ends here |