1 ;;;; (texinfo) -- parsing of texinfo into SXML
3 ;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
4 ;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
5 ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
7 ;;;; This file is based on SSAX's SSAX.scm.
9 ;;;; This library is free software; you can redistribute it and/or
10 ;;;; modify it under the terms of the GNU Lesser General Public
11 ;;;; License as published by the Free Software Foundation; either
12 ;;;; version 3 of the License, or (at your option) any later version.
14 ;;;; This library is distributed in the hope that it will be useful,
15 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;;; Lesser General Public License for more details.
19 ;;;; You should have received a copy of the GNU Lesser General Public
20 ;;;; License along with this library; if not, write to the Free Software
21 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 ;; @subheading Texinfo processing in scheme
27 ;; This module parses texinfo into SXML. TeX will always be the
28 ;; processor of choice for print output, of course. However, although
29 ;; @code{makeinfo} works well for info, its output in other formats is
30 ;; not very customizable, and the program is not extensible as a whole.
31 ;; This module aims to provide an extensible framework for texinfo
32 ;; processing that integrates texinfo into the constellation of SXML
35 ;; @subheading Notes on the SXML vocabulary
37 ;; Consider the following texinfo fragment:
40 ;; @@deffn Primitive set-car! pair value
45 ;; Logically, the category (Primitive), name (set-car!), and arguments
46 ;; (pair value) are ``attributes'' of the deffn, with the description as
47 ;; the content. However, texinfo allows for @@-commands within the
48 ;; arguments to an environment, like @code{@@deffn}, which means that
49 ;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand,
50 ;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are
51 ;; called ``arguments'', and are grouped under the special element, `%'.
53 ;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In
54 ;; the interests of interoperability, this module provides a conversion
55 ;; function to replace the `%' with `texinfo-arguments'.
59 ;; Comparison to xml output of texinfo (which is rather undocumented):
60 ;; Doesn't conform to texinfo dtd
61 ;; No DTD at all, in fact :-/
62 ;; Actually outputs valid xml, after transforming %
63 ;; Slower (although with caching the SXML that problem can go away)
64 ;; Doesn't parse menus (although menus are shite)
65 ;; Args go in a dedicated element, FBOFW
66 ;; Definitions are handled a lot better
67 ;; Does parse comments
68 ;; Outputs only significant line breaks (a biggie!)
69 ;; Nodes are treated as anchors, rather than content organizers (a biggie)
70 ;; (more book-like, less info-like)
73 ;; Integration: help, indexing, plain text
75 (define-module (texinfo)
76 #:use-module (sxml simple)
77 #:use-module (sxml transform)
78 #:use-module (sxml ssax input-parse)
79 #:use-module (srfi srfi-1)
80 #:use-module (srfi srfi-13)
81 #:export (call-with-file-and-dir
90 (define (parser-error port message . rest)
91 (apply throw 'parser-error port message rest))
93 (define (call-with-file-and-dir filename proc)
94 "Call the one-argument procedure @var{proc} with an input port that
95 reads from @var{filename}. During the dynamic extent of @var{proc}'s
96 execution, the current directory will be @code{(dirname
97 @var{filename})}. This is useful for parsing documents that can include
98 files by relative path name."
99 (let ((current-dir (getcwd)))
101 (lambda () (chdir (dirname filename)))
103 (call-with-input-file (basename filename) proc))
104 (lambda () (chdir current-dir)))))
106 ;; Define this version here, because (srfi srfi-11)'s definition uses
107 ;; syntax-rules, which is really damn slow
108 (define-macro (let*-values bindings . body)
109 (if (null? bindings) (cons 'begin body)
111 (lambda (vars initializer)
114 (cons (cdr bindings) body))))
116 ((not (pair? vars)) ; regular let case, a single var
117 `(let ((,vars ,initializer)) ,cont))
118 ((null? (cdr vars)) ; single var, see the prev case
119 `(let ((,(car vars) ,initializer)) ,cont))
120 (else ; the most generic case
121 `(call-with-values (lambda () ,initializer)
122 (lambda ,vars ,cont))))))
125 ;;========================================================================
126 ;; Reflection on the XML vocabulary
128 (define texi-command-specs
130 "A list of (@var{name} @var{content-model} . @var{args})
134 The name of an @@-command, as a symbol.
137 A symbol indicating the syntactic type of the @@-command:
140 No content, and no @code{@@end} is coming
142 Unparsed arguments until end of line
144 Parsed arguments until end of line
146 Unparsed arguments ending with @code{#\\@}}
148 Parsed arguments ending with @code{#\\@}}
150 The tag is an environment tag, expect @code{@@end foo}.
152 Like ENVIRON, but with special parsing rules for its arguments.
154 For @code{*fragment*}, the command used for parsing fragments of
158 @code{INLINE-TEXT} commands will receive their arguments within their
159 bodies, whereas the @code{-ARGS} commands will receive them in their
162 @code{EOF-TEXT} receives its arguments in its body.
164 @code{ENVIRON} commands have both: parsed arguments until the end of
165 line, received through their attribute list, and parsed text until the
166 @code{@@end}, received in their bodies.
168 @code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in
171 There are four @@-commands that are treated specially. @code{@@include}
172 is a low-level token that will not be seen by higher-level parsers, so
173 it has no content-model. @code{@@para} is the paragraph command, which
174 is only implicit in the texinfo source. @code{@@item} has special
175 syntax, as noted above, and @code{@@entry} is how this parser treats
176 @code{@@item} commands within @code{@@table}, @code{@@ftable}, and
179 Also, indexing commands (@code{@@cindex}, etc.) are treated specially.
180 Their arguments are parsed, but they are needed before entering the
181 element so that an anchor can be inserted into the text before the index
185 Named arguments to the command, in the same format as the formals for a
186 lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
187 @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
189 '(;; Special commands
190 (include #f) ;; this is a low-level token
193 (entry ENTRY . heading)
194 (noindent EMPTY-COMMAND)
195 (*fragment* FRAGMENT)
197 ;; Inline text commands
198 (*braces* INLINE-TEXT) ;; FIXME: make me irrelevant
208 (command INLINE-TEXT)
219 (titlefont INLINE-TEXT)
224 (sansserif INLINE-TEXT)
225 (slanted INLINE-TEXT)
228 ;; Inline args commands
229 (value INLINE-ARGS . (key))
230 (ref INLINE-ARGS . (node #:opt name section info-file manual))
231 (xref INLINE-ARGS . (node #:opt name section info-file manual))
232 (pxref INLINE-ARGS . (node #:opt name section info-file manual))
233 (uref INLINE-ARGS . (url #:opt title replacement))
234 (anchor INLINE-ARGS . (name))
235 (dots INLINE-ARGS . ())
236 (result INLINE-ARGS . ())
237 (bullet INLINE-ARGS . ())
238 (copyright INLINE-ARGS . ())
239 (tie INLINE-ARGS . ())
240 (image INLINE-ARGS . (file #:opt width height alt-text extension))
243 (node EOL-ARGS . (name #:opt next previous up))
245 (comment EOL-ARGS . all)
246 (setchapternewpage EOL-ARGS . all)
249 (vskip EOL-ARGS . all)
250 (syncodeindex EOL-ARGS . all)
251 (contents EOL-ARGS . ())
252 (shortcontents EOL-ARGS . ())
253 (summarycontents EOL-ARGS . ())
254 (insertcopying EOL-ARGS . ())
255 (dircategory EOL-ARGS . (category))
256 (top EOL-ARGS . (title))
257 (printindex EOL-ARGS . (type))
260 (*ENVIRON-ARGS* EOL-TEXT)
270 (appendixsec EOL-TEXT)
271 (unnumbered EOL-TEXT)
272 (unnumberedsec EOL-TEXT)
273 (subsection EOL-TEXT)
274 (subsubsection EOL-TEXT)
275 (appendixsubsec EOL-TEXT)
276 (appendixsubsubsec EOL-TEXT)
277 (unnumberedsubsec EOL-TEXT)
278 (unnumberedsubsubsec EOL-TEXT)
279 (chapheading EOL-TEXT)
280 (majorheading EOL-TEXT)
282 (subheading EOL-TEXT)
283 (subsubheading EOL-TEXT)
285 (deftpx EOL-TEXT-ARGS . (category name . attributes))
286 (defcvx EOL-TEXT-ARGS . (category class name))
287 (defivarx EOL-TEXT-ARGS . (class name))
288 (deftypeivarx EOL-TEXT-ARGS . (class data-type name))
289 (defopx EOL-TEXT-ARGS . (category class name . arguments))
290 (deftypeopx EOL-TEXT-ARGS . (category class data-type name . arguments))
291 (defmethodx EOL-TEXT-ARGS . (class name . arguments))
292 (deftypemethodx EOL-TEXT-ARGS . (class data-type name . arguments))
293 (defoptx EOL-TEXT-ARGS . (name))
294 (defvrx EOL-TEXT-ARGS . (category name))
295 (defvarx EOL-TEXT-ARGS . (name))
296 (deftypevrx EOL-TEXT-ARGS . (category data-type name))
297 (deftypevarx EOL-TEXT-ARGS . (data-type name))
298 (deffnx EOL-TEXT-ARGS . (category name . arguments))
299 (deftypefnx EOL-TEXT-ARGS . (category data-type name . arguments))
300 (defspecx EOL-TEXT-ARGS . (name . arguments))
301 (defmacx EOL-TEXT-ARGS . (name . arguments))
302 (defunx EOL-TEXT-ARGS . (name . arguments))
303 (deftypefunx EOL-TEXT-ARGS . (data-type name . arguments))
306 (cindex INDEX . entry)
307 (findex INDEX . entry)
308 (vindex INDEX . entry)
309 (kindex INDEX . entry)
310 (pindex INDEX . entry)
311 (tindex INDEX . entry)
313 ;; Environment commands (those that need @end)
314 (texinfo ENVIRON . title)
315 (ignore ENVIRON . ())
316 (ifinfo ENVIRON . ())
318 (ifhtml ENVIRON . ())
320 (ifplaintext ENVIRON . ())
321 (ifnotinfo ENVIRON . ())
322 (ifnottex ENVIRON . ())
323 (ifnothtml ENVIRON . ())
324 (ifnotxml ENVIRON . ())
325 (ifnotplaintext ENVIRON . ())
326 (titlepage ENVIRON . ())
328 (direntry ENVIRON . ())
329 (copying ENVIRON . ())
330 (example ENVIRON . ())
331 (smallexample ENVIRON . ())
332 (display ENVIRON . ())
333 (smalldisplay ENVIRON . ())
334 (verbatim ENVIRON . ())
335 (format ENVIRON . ())
336 (smallformat ENVIRON . ())
338 (smalllisp ENVIRON . ())
339 (cartouche ENVIRON . ())
340 (quotation ENVIRON . ())
342 (deftp ENVIRON . (category name . attributes))
343 (defcv ENVIRON . (category class name))
344 (defivar ENVIRON . (class name))
345 (deftypeivar ENVIRON . (class data-type name))
346 (defop ENVIRON . (category class name . arguments))
347 (deftypeop ENVIRON . (category class data-type name . arguments))
348 (defmethod ENVIRON . (class name . arguments))
349 (deftypemethod ENVIRON . (class data-type name . arguments))
350 (defopt ENVIRON . (name))
351 (defvr ENVIRON . (category name))
352 (defvar ENVIRON . (name))
353 (deftypevr ENVIRON . (category data-type name))
354 (deftypevar ENVIRON . (data-type name))
355 (deffn ENVIRON . (category name . arguments))
356 (deftypefn ENVIRON . (category data-type name . arguments))
357 (defspec ENVIRON . (name . arguments))
358 (defmac ENVIRON . (name . arguments))
359 (defun ENVIRON . (name . arguments))
360 (deftypefun ENVIRON . (data-type name . arguments))
362 (table TABLE-ENVIRON . (formatter))
363 (itemize TABLE-ENVIRON . (formatter))
364 (enumerate TABLE-ENVIRON . (start))
365 (ftable TABLE-ENVIRON . (formatter))
366 (vtable TABLE-ENVIRON . (formatter))))
368 (define command-depths
369 '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4)
370 (top . 0) (unnumbered . 1) (unnumberedsec . 2)
371 (unnumberedsubsec . 3) (unnumberedsubsubsec . 4)
372 (appendix . 1) (appendixsec . 2) (appendixsection . 2)
373 (appendixsubsec . 3) (appendixsubsubsec . 4)))
374 (define (texi-command-depth command max-depth)
375 "Given the texinfo command @var{command}, return its nesting level, or
376 @code{#f} if it nests too deep for @var{max-depth}.
380 (texi-command-depth 'chapter 4) @result{} 1
381 (texi-command-depth 'top 4) @result{} 0
382 (texi-command-depth 'subsection 4) @result{} 3
383 (texi-command-depth 'appendixsubsec 4) @result{} 3
384 (texi-command-depth 'subsection 2) @result{} #f
386 (let ((depth (and=> (assq command command-depths) cdr)))
387 (and depth (<= depth max-depth) depth)))
389 ;; The % is for arguments
390 (define (space-significant? command)
392 '(example smallexample verbatim lisp smalllisp menu %)))
394 ;; Like a DTD for texinfo
395 (define (command-spec command)
396 (or (assq command texi-command-specs)
397 (parser-error #f "Unknown command" command)))
399 (define (inline-content? content)
400 (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS)))
403 ;;========================================================================
404 ;; Lower-level parsers and scanners
406 ;; They deal with primitive lexical units (Names, whitespaces, tags) and
407 ;; with pieces of more generic productions. Most of these parsers must
408 ;; be called in appropriate context. For example, complete-start-command
409 ;; must be called only when the @-command start has been detected and
410 ;; its name token has been read.
412 ;; Test if a string is made of only whitespace
413 ;; An empty string is considered made of whitespace as well
414 (define (string-whitespace? str)
415 (or (string-null? str)
416 (string-every char-whitespace? str)))
418 ;; Like read-text-line, but allows EOF.
419 (define read-eof-breaks '(*eof* #\return #\newline))
420 (define (read-eof-line port)
421 (if (eof-object? (peek-char port))
423 (let* ((line (next-token '() read-eof-breaks
424 "reading a line" port))
425 (c (read-char port))) ; must be either \n or \r or EOF
426 (if (and (eq? c #\return) (eq? (peek-char port) #\newline))
427 (read-char port)) ; skip \n that follows \r
430 (define (skip-whitespace port)
431 (skip-while '(#\space #\tab #\return #\newline) port))
433 (define (skip-horizontal-whitespace port)
434 (skip-while '(#\space #\tab) port))
436 ;; command ::= Letter+
438 ;; procedure: read-command PORT
440 ;; Read a command starting from the current position in the PORT and
441 ;; return it as a symbol.
442 (define (read-command port)
443 (let ((first-char (peek-char port)))
444 (or (char-alphabetic? first-char)
445 (parser-error port "Nonalphabetic @-command char: '" first-char "'")))
451 ((char-alphabetic? c) c)
455 ;; A token is a primitive lexical unit. It is a record with two fields,
456 ;; token-head and token-kind.
459 ;; END The end of a texinfo command. If the command is ended by },
460 ;; token-head will be #f. Otherwise if the command is ended by
461 ;; @end COMMAND, token-head will be COMMAND. As a special case,
462 ;; @bye is the end of a special @texinfo command.
463 ;; START The start of a texinfo command. The token-head will be a
464 ;; symbol of the @-command name.
465 ;; INCLUDE An @include directive. The token-head will be empty -- the
466 ;; caller is responsible for reading the include file name.
467 ;; ITEM @item commands have an irregular syntax. They end at the
468 ;; next @item, or at the end of the environment. For that
469 ;; read-command-token treats them specially.
471 (define (make-token kind head) (cons kind head))
472 (define token? pair?)
473 (define token-kind car)
474 (define token-head cdr)
476 ;; procedure: read-command-token PORT
478 ;; This procedure starts parsing of a command token. The current
479 ;; position in the stream must be #\@. This procedure scans enough of
480 ;; the input stream to figure out what kind of a command token it is
481 ;; seeing. The procedure returns a token structure describing the token.
483 (define (read-command-token port)
484 (assert-curr-char '(#\@) "start of the command" port)
485 (let ((peeked (peek-char port)))
487 ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\}))
488 ;; @-commands that escape characters
489 (make-token 'STRING (string (read-char port))))
491 (let ((name (read-command port)))
495 (let ((command (string-trim-both
496 (read-eof-line port))))
497 (or (and (not (string-null? command))
498 (string-every char-alphabetic? command))
499 (parser-error port "malformed @end" command))
500 (make-token 'END (string->symbol command))))
502 ;; the end of the top
503 (make-token 'END 'texinfo))
505 (make-token 'ITEM 'item))
507 (make-token 'INCLUDE #f))
509 (make-token 'START name))))))))
511 ;; procedure+: read-verbatim-body PORT STR-HANDLER SEED
513 ;; This procedure must be called after we have read a string
514 ;; "@verbatim\n" that begins a verbatim section. The current position
515 ;; must be the first position of the verbatim body. This function reads
516 ;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a
517 ;; character data consumer.
519 ;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
520 ;; The first STRING1 argument to STR-HANDLER never contains a newline.
521 ;; The second STRING2 argument often will. On the first invocation of the
522 ;; STR-HANDLER, the seed is the one passed to read-verbatim-body
523 ;; as the third argument. The result of this first invocation will be
524 ;; passed as the seed argument to the second invocation of the line
525 ;; consumer, and so on. The result of the last invocation of the
526 ;; STR-HANDLER is returned by the read-verbatim-body. Note a
527 ;; similarity to the fundamental 'fold' iterator.
529 ;; Within a verbatim section all characters are taken at their face
530 ;; value. It ends with "\n@end verbatim(\r)?\n".
532 ;; Must be called right after the newline after @verbatim.
533 (define (read-verbatim-body port str-handler seed)
534 (let loop ((seed seed))
535 (let ((fragment (next-token '() '(#\newline)
536 "reading verbatim" port)))
537 ;; We're reading the char after the 'fragment', which is
540 (if (string=? fragment "@end verbatim")
542 (loop (str-handler fragment "\n" seed))))))
544 ;; procedure+: read-arguments PORT
546 ;; This procedure reads and parses a production ArgumentList.
547 ;; ArgumentList ::= S* Argument (S* , S* Argument)* S*
548 ;; Argument ::= ([^@{},])*
550 ;; Arguments are the things in braces, i.e @ref{my node} has one
551 ;; argument, "my node". Most commands taking braces actually don't have
552 ;; arguments, they process text. For example, in
553 ;; @emph{@strong{emphasized}}, the emph takes text, because the parse
554 ;; continues into the braces.
556 ;; Any whitespace within Argument is replaced with a single space.
557 ;; Whitespace around an Argument is trimmed.
559 ;; The procedure returns a list of arguments. Afterwards the current
560 ;; character will be after the final #\}.
562 (define (read-arguments port stop-char)
564 (read-char port) ;; eat the delimiter
565 (let ((ret (map (lambda (x) (if (string-null? x) #f x))
566 (map string-trim-both (string-split str #\,)))))
567 (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret)))
570 (split (next-token '() (list stop-char)
571 "arguments of @-command" port)))
573 ;; procedure+: complete-start-command COMMAND PORT
575 ;; This procedure is to complete parsing of an @-command. The procedure
576 ;; must be called after the command token has been read. COMMAND is a
579 ;; This procedure returns several values:
580 ;; COMMAND: a symbol.
581 ;; ARGUMENTS: command's arguments, as an alist.
582 ;; CONTENT-MODEL: the content model of the command.
584 ;; On exit, the current position in PORT will depend on the CONTENT-MODEL.
586 ;; Content model Port position
587 ;; ============= =============
588 ;; INLINE-TEXT One character after the #\{.
589 ;; INLINE-ARGS The first character after the #\}.
590 ;; EOL-TEXT The first non-whitespace character after the command.
591 ;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT
592 ;; The first character on the next line.
593 ;; PARAGRAPH, ITEM, EMPTY-COMMAND
594 ;; The first character after the command.
596 (define (arguments->attlist port args arg-names)
597 (let loop ((in args) (names arg-names) (opt? #f) (out '()))
599 ((symbol? names) ;; a rest arg
600 (reverse (if (null? in) out (acons names in out))))
601 ((and (not (null? names)) (eq? (car names) #:opt))
602 (loop in (cdr names) #t out))
604 (if (or (null? names) opt?)
606 (parser-error port "@-command expected more arguments:"
607 args arg-names names)))
609 (parser-error port "@-command didn't expect more arguments:" in))
611 (or (and opt? (loop (cdr in) (cdr names) opt? out))
612 (parser-error "@-command missing required argument"
615 (loop (cdr in) (cdr names) opt?
616 (cons (list (car names) (car in)) out))))))
618 (define (parse-table-args command port)
619 (let* ((line (string-trim-both (read-text-line port)))
620 (length (string-length line)))
621 (define (get-formatter)
622 (or (and (not (zero? length))
623 (eq? (string-ref line 0) #\@)
624 (let ((f (string->symbol (substring line 1))))
625 (or (inline-content? (cadr (command-spec f)))
627 port "@item formatter must be INLINE" f))
629 (parser-error port "Invalid @item formatter" line)))
635 ,(if (or (and (eq? length 1)
636 (char-alphabetic? (string-ref line 0)))
637 (string-every char-numeric? line))
640 port "Invalid enumerate start" line))))))
643 ,(or (and (eq? length 1) line)
644 (and (string-null? line) '(bullet))
645 (list (get-formatter))))))
646 (else ;; tables of various varieties
647 `((formatter (,(get-formatter))))))))
649 (define (complete-start-command command port)
650 (define (get-arguments type arg-names stop-char)
651 (arguments->attlist port (read-arguments port stop-char) arg-names))
653 (let* ((spec (command-spec command))
655 (arg-names (cddr spec)))
658 (assert-curr-char '(#\{) "Inline element lacks {" port)
659 (values command '() type))
661 (assert-curr-char '(#\{) "Inline element lacks {" port)
662 (values command (get-arguments type arg-names #\}) type))
664 (values command (get-arguments type arg-names #\newline) type))
665 ((ENVIRON ENTRY INDEX)
666 (skip-horizontal-whitespace port)
667 (values command (parse-environment-args command port) type))
669 (skip-horizontal-whitespace port)
670 (values command (parse-table-args command port) type))
672 (skip-horizontal-whitespace port)
673 (values command '() type))
675 (skip-horizontal-whitespace port)
676 (values command (parse-eol-text-args command port) type))
677 ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT)
678 (values command '() type))
679 (else ;; INCLUDE shouldn't get here
680 (parser-error port "can't happen")))))
682 ;;-----------------------------------------------------------------------------
683 ;; Higher-level parsers and scanners
685 ;; They parse productions corresponding entire @-commands.
687 ;; Only reads @settitle, leaves it to the command parser to finish
688 ;; reading the title.
689 (define (take-until-settitle port)
690 (or (find-string-from-port? "\n@settitle " port)
691 (parser-error port "No \\n@settitle found"))
692 (skip-horizontal-whitespace port)
693 (and (eq? (peek-char port) #\newline)
694 (parser-error port "You have a @settitle, but no title")))
696 ;; procedure+: read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
698 ;; This procedure is to read the CharData of a texinfo document.
700 ;; text ::= (CharData | Command)*
702 ;; The procedure reads CharData and stops at @-commands (or
703 ;; environments). It also stops at an open or close brace.
708 ;; a boolean indicating if EOF is normal, i.e., the character
709 ;; data may be terminated by the EOF. EOF is normal
710 ;; while processing the main document.
712 ;; a boolean indicating if we are within a whitespace-preserving
713 ;; environment. If #t, suppress paragraph detection.
715 ;; a STR-HANDLER, see read-verbatim-body
717 ;; an argument passed to the first invocation of STR-HANDLER.
719 ;; The procedure returns two results: SEED and TOKEN. The SEED is the
720 ;; result of the last invocation of STR-HANDLER, or the original seed if
721 ;; STR-HANDLER was never called.
723 ;; TOKEN can be either an eof-object (this can happen only if expect-eof?
724 ;; was #t), or a texinfo token denoting the start or end of a tag.
726 ;; read-char-data port expect-eof? preserve-ws? str-handler seed
727 (define read-char-data
728 (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline)))
729 (define (handle str-handler str1 str2 seed)
730 (if (and (string-null? str1) (string-null? str2))
732 (str-handler str1 str2 seed)))
734 (lambda (port expect-eof? preserve-ws? str-handler seed)
735 (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof)))
736 (let loop ((seed seed))
737 (let* ((fragment (next-token '() end-chars "reading char data" port))
738 (term-char (peek-char port))) ; one of end-chars
740 ((eof-object? term-char) ; only if expect-eof?
741 (values (handle str-handler fragment "" seed) term-char))
742 ((memq term-char '(#\@ #\{ #\}))
743 (values (handle str-handler fragment "" seed)
745 ((#\@) (read-command-token port))
746 ((#\{) (make-token 'START '*braces*))
747 ((#\}) (read-char port) (make-token 'END #f)))))
748 ((eq? term-char #\newline)
749 ;; Always significant, unless directly before an end token.
750 (let ((c (peek-next-char port)))
754 (parser-error port "EOF while reading char data"))
755 (values (handle str-handler fragment "" seed) c))
757 (let* ((token (read-command-token port))
758 (end? (eq? (token-kind token) 'END)))
760 (handle str-handler fragment (if end? "" " ") seed)
762 ((and (not preserve-ws?) (eq? c #\newline))
763 ;; paragraph-separator ::= #\newline #\newline+
764 (skip-while '(#\newline) port)
765 (skip-horizontal-whitespace port)
766 (values (handle str-handler fragment "" seed)
767 (make-token 'PARA 'para)))
769 (loop (handle str-handler fragment
770 (if preserve-ws? "\n" " ") seed)))))))))))))
772 ; procedure+: assert-token TOKEN KIND NAME
773 ; Make sure that TOKEN is of anticipated KIND and has anticipated NAME
774 (define (assert-token token kind name)
775 (or (and (token? token)
776 (eq? kind (token-kind token))
777 (equal? name (token-head token)))
778 (parser-error #f "Expecting @end for " name ", got " token)))
780 ;;========================================================================
781 ;; Highest-level parsers: Texinfo to SXML
783 ;; These parsers are a set of syntactic forms to instantiate a SSAX
784 ;; parser. The user tells what to do with the parsed character and
785 ;; element data. These latter handlers determine if the parsing follows a
786 ;; SAX or a DOM model.
788 ;; syntax: make-command-parser fdown fup str-handler
790 ;; Create a parser to parse and process one element, including its
791 ;; character content or children elements. The parser is typically
792 ;; applied to the root element of a document.
795 ;; procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED
797 ;; This procedure is to generate the seed to be passed to handlers
798 ;; that process the content of the element. This is the function
799 ;; identified as 'fdown' in the denotational semantics of the XML
800 ;; parser given in the title comments to (sxml ssax).
803 ;; procedure COMMAND ARGUMENTS PARENT-SEED SEED
805 ;; This procedure is called when parsing of COMMAND is finished.
806 ;; The SEED is the result from the last content parser (or from
807 ;; fdown if the element has the empty content). PARENT-SEED is the
808 ;; same seed as was passed to fdown. The procedure is to generate a
809 ;; seed that will be the result of the element parser. This is the
810 ;; function identified as 'fup' in the denotational semantics of
811 ;; the XML parser given in the title comments to (sxml ssax).
814 ;; A STR-HANDLER, see read-verbatim-body
817 ;; The generated parser is a
818 ;; procedure COMMAND PORT SEED
820 ;; The procedure must be called *after* the command token has been read.
822 (define (read-include-file-name port)
823 (let ((x (string-trim-both (read-eof-line port))))
825 (error "no file listed")
826 x))) ;; fixme: should expand @value{} references
828 (define (sxml->node-name sxml)
829 "Turn some sxml string into a valid node name."
830 (let loop ((in (string->list (sxml->string sxml))) (out '()))
832 (apply string (reverse out))
833 (if (memq (car in) '(#\{ #\} #\@ #\,))
835 (loop (cdr in) (cons (car in) out))))))
837 (define (index command arguments fdown fup parent-seed)
839 ((deftp defcv defivar deftypeivar defop deftypeop defmethod
840 deftypemethod defopt defvr defvar deftypevr deftypevar deffn
841 deftypefn defspec defmac defun deftypefun)
842 (let ((args `((name ,(string-append (symbol->string command) "-"
843 (cadr (assq 'name arguments)))))))
844 (fup 'anchor args parent-seed
845 (fdown 'anchor args 'INLINE-ARGS '()))))
846 ((cindex findex vindex kindex pindex tindex)
847 (let ((args `((name ,(string-append (symbol->string command) "-"
849 (assq 'entry arguments)))))))
850 (fup 'anchor args parent-seed
851 (fdown 'anchor args 'INLINE-ARGS '()))))
854 (define (make-command-parser fdown fup str-handler)
855 (lambda (command port seed)
856 (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed))
857 (let*-values (((command arguments expected-content)
858 (complete-start-command command port)))
859 (let* ((parent-seed (index command arguments fdown fup parent-seed))
860 (seed (fdown command arguments expected-content parent-seed))
861 (eof-closes? (or (memq command '(texinfo para *fragment*))
862 (eq? expected-content 'EOL-TEXT)))
863 (sig-ws? (or sig-ws? (space-significant? command)))
864 (up (lambda (s) (fup command arguments parent-seed s)))
865 (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s)))
866 (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s)))))
868 (define (port-for-content)
869 (if (eq? expected-content 'EOL-TEXT)
870 (call-with-input-string (read-text-line port) identity)
874 ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX
876 ;; empty or finished by complete-start-command
878 ((eq? command 'verbatim)
879 (up (read-verbatim-body port str-handler seed)))
881 (let loop ((port (port-for-content))
882 (expect-eof? eof-closes?)
884 (need-break? (and (not sig-ws?)
885 (memq expected-content
886 '(ENVIRON TABLE-ENVIRON
887 ENTRY ITEM FRAGMENT))))
890 ((and need-break? (or sig-ws? (skip-whitespace port))
891 (not (memq (peek-char port) '(#\@ #\})))
892 (not (eof-object? (peek-char port))))
893 ;; Even if we have an @, it might be inline -- check
895 (let ((seed (end-para seed)))
896 (loop port expect-eof? (make-end-para seed) #f
899 (let*-values (((seed token)
901 port expect-eof? sig-ws? str-handler seed)))
905 ((include #f) (end-para seed))
906 (else (up (end-para seed)))))
908 (case (token-kind token)
910 ;; this is only @-commands that escape
911 ;; characters: @}, @@, @{ -- new para if need-break
912 (let ((seed ((if need-break? end-para identity) seed)))
913 (loop port expect-eof?
914 (if need-break? (make-end-para seed) end-para) #f
915 (str-handler (token-head token) ""
916 ((if need-break? new-para identity)
919 ;; The end will only have a name if it's for an
922 ((memq command '(item entry))
923 (let ((spec (command-spec (token-head token))))
924 (or (eq? (cadr spec) 'TABLE-ENVIRON)
926 port "@item not ended by @end table/enumerate/itemize"
928 ((eq? expected-content 'ENVIRON)
929 (assert-token token 'END command)))
930 (up (end-para seed)))
933 ((memq command '(enumerate itemize))
934 (up (visit 'item port sig-ws? (end-para seed))))
935 ((eq? expected-content 'TABLE-ENVIRON)
936 (up (visit 'entry port sig-ws? (end-para seed))))
937 ((memq command '(item entry))
938 (visit command port sig-ws? (up (end-para seed))))
941 port "@item must be within a table environment"
944 ;; examine valid paragraphs?
945 (loop port expect-eof? end-para (not sig-ws?) seed))
947 ;; Recurse for include files
948 (let ((seed (call-with-file-and-dir
949 (read-include-file-name port)
951 (loop port 'include end-para
952 need-break? seed)))))
953 (loop port expect-eof? end-para need-break? seed)))
954 ((START) ; Start of an @-command
955 (let* ((head (token-head token))
956 (type (cadr (command-spec head)))
957 (inline? (inline-content? type))
958 (seed ((if (and inline? (not need-break?))
959 identity end-para) seed))
960 (end-para (if inline?
961 (if need-break? (make-end-para seed)
964 (new-para (if (and inline? need-break?)
966 (loop port expect-eof? end-para (not inline?)
967 (visit head port sig-ws? (new-para seed)))))
969 (parser-error port "Unknown token type" token))))))))))))))))
971 ;; procedure: reverse-collect-str-drop-ws fragments
973 ;; Given the list of fragments (some of which are text strings), reverse
974 ;; the list and concatenate adjacent text strings. We also drop
975 ;; "unsignificant" whitespace, that is, whitespace in front, behind and
976 ;; between elements. The whitespace that is included in character data
978 (define (reverse-collect-str-drop-ws fragments)
980 ((null? fragments) ; a shortcut
982 ((and (string? (car fragments)) ; another shortcut
983 (null? (cdr fragments)) ; remove single ws-only string
984 (string-whitespace? (car fragments)))
987 (let loop ((fragments fragments) (result '()) (strs '())
988 (all-whitespace? #t))
992 result ; remove leading ws
993 (cons (apply string-append strs) result)))
994 ((string? (car fragments))
995 (loop (cdr fragments) result (cons (car fragments) strs)
997 (string-whitespace? (car fragments)))))
999 (loop (cdr fragments)
1003 ((null? strs) result)
1006 result ; remove trailing whitespace
1007 (cons " " result))); replace interstitial ws with
1010 (cons (apply string-append strs) result))))
1013 (define (make-dom-parser)
1014 (make-command-parser
1015 (lambda (command args content seed) ; fdown
1017 (lambda (command args parent-seed seed) ; fup
1018 (let ((seed (reverse-collect-str-drop-ws seed)))
1020 (if (null? args) seed (acons '% args seed))
1022 (lambda (string1 string2 seed) ; str-handler
1023 (if (string-null? string2)
1025 (cons* string2 string1 seed)))))
1027 (define parse-environment-args
1028 (let ((parser (make-dom-parser)))
1029 ;; duplicate arguments->attlist to avoid unnecessary splitting
1030 (lambda (command port)
1031 (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
1032 (arg-names (cddr (command-spec command))))
1035 (if (null? args) '()
1036 (parser-error port "@-command doesn't take args" command)))
1038 (list (cons 'arguments args)))
1040 (let loop ((args args) (arg-names arg-names) (out '()))
1043 (if (null? args) (reverse! out)
1044 (parser-error port "@-command didn't expect more args"
1046 ((symbol? arg-names)
1047 (reverse! (acons arg-names args out)))
1049 (parser-error port "@-command expects more args"
1051 ((and (string? (car args)) (string-index (car args) #\space))
1053 (let ((rest (substring/shared (car args) (1+ i))))
1055 (loop (cons rest (cdr args)) arg-names out)
1056 (loop (cons rest (cdr args)) (cdr arg-names)
1057 (cons (list (car arg-names)
1058 (substring (car args) 0 i))
1061 (loop (cdr args) (cdr arg-names)
1062 (if (and (pair? (car args)) (eq? (caar args) '*braces*))
1063 (acons (car arg-names) (cdar args) out)
1064 (cons (list (car arg-names) (car args)) out))))))))))))
1066 (define (parse-eol-text-args command port)
1067 ;; perhaps parse-environment-args should be named more
1069 (parse-environment-args command port))
1071 ;; procedure: texi-fragment->stexi STRING
1073 ;; A DOM parser for a texinfo fragment STRING.
1075 ;; The procedure returns an SXML tree headed by the special tag,
1078 (define (texi-fragment->stexi string-or-port)
1079 "Parse the texinfo commands in @var{string-or-port}, and return the
1080 resultant stexi tree. The head of the tree will be the special command,
1082 (define (parse port)
1083 (postprocess (car ((make-dom-parser) '*fragment* port '()))))
1084 (if (input-port? string-or-port)
1085 (parse string-or-port)
1086 (call-with-input-string string-or-port parse)))
1088 ;; procedure: texi->stexi PORT
1090 ;; This is an instance of a SSAX parser above that returns an SXML
1091 ;; representation of the texinfo document ready to be read at PORT.
1093 ;; The procedure returns an SXML tree. The port points to the
1094 ;; first character after the @bye, or to the end of the file.
1096 (define (texi->stexi port)
1097 "Read a full texinfo document from @var{port} and return the parsed
1098 stexi tree. The parsing will start at the @code{@@settitle} and end at
1099 @code{@@bye} or EOF."
1100 (let ((parser (make-dom-parser)))
1101 (take-until-settitle port)
1102 (postprocess (car (parser 'texinfo port '())))))
1104 (define (car-eq? x y) (and (pair? x) (eq? (car x) y)))
1105 (define (make-contents tree)
1106 (define (lp in out depth)
1108 ((null? in) (values in (cons 'enumerate (reverse! out))))
1109 ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4))
1110 => (lambda (new-depth)
1111 (let ((node-name (and (car-eq? (car in) 'node)
1112 (cadr (assq 'name (cdadar in))))))
1114 ((< new-depth depth)
1115 (values in (cons 'enumerate (reverse! out))))
1116 ((> new-depth depth)
1117 (let ((out-cdr (if (null? out) '() (cdr out)))
1118 (out-car (if (null? out) (list 'item) (car out))))
1119 (let*-values (((new-in new-out) (lp in '() (1+ depth))))
1121 (cons (append out-car (list new-out)) out-cdr)
1128 `((ref (% (node ,node-name))))
1132 (else (lp (cdr in) out depth))))
1133 (let*-values (((_ contents) (lp tree '() 1)))
1134 `((chapheading "Table of Contents") ,contents)))
1136 (define (trim-whitespace str trim-left? trim-right?)
1137 (let* ((left-space? (and (not trim-left?)
1138 (string-prefix? " " str)))
1139 (right-space? (and (not trim-right?)
1140 (string-suffix? " " str)))
1141 (tail (append! (string-tokenize str)
1142 (if right-space? '("") '()))))
1143 (string-join (if left-space? (cons "" tail) tail))))
1145 (define (postprocess tree)
1146 (define (loop in out state first? sig-ws?)
1149 (values (reverse! out) state))
1152 (cons (if sig-ws? (car in)
1153 (trim-whitespace (car in) first? (null? (cdr in))))
1159 (if (null? (cdar in)) (error "@set missing arguments" in))
1160 (if (string? (cadar in))
1161 (let ((i (string-index (cadar in) #\space)))
1164 (acons (substring (cadar in) 0 i)
1165 (cons (substring (cadar in) (1+ i)) (cddar in))
1168 (loop (cdr in) out (acons (cadar in) (cddar in) state)
1170 (error "expected a constant to define for @set" in)))
1172 (loop (fold-right cons (cdr in)
1174 (assoc (cadr (assq 'key (cdadar in))) state) cdr)
1175 (error "unknown value" (cdadar in) state)))
1179 (loop (cdr in) out (cons (car in) state) #f sig-ws?))
1181 (loop (fold-right cons (cdr in)
1182 (or (cdr (assoc 'copying state))
1183 (error "copying isn't set yet")))
1187 (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?))
1189 (let*-values (((kid-out state)
1190 (loop (car in) '() state #t
1191 (or sig-ws? (space-significant? (caar in))))))
1192 (loop (cdr in) (cons kid-out out) state #f sig-ws?)))))
1194 (loop (cdr in) (cons (car in) out) state #t sig-ws?))))
1197 (lambda () (loop tree '() '() #t #f))
1198 (lambda (out state) out)))
1200 ;; Replace % with texinfo-arguments.
1201 (define (stexi->sxml tree)
1202 "Transform the stexi tree @var{tree} into sxml. This involves
1203 replacing the @code{%} element that keeps the texinfo arguments with an
1204 element for each argument.
1206 FIXME: right now it just changes % to @code{texinfo-arguments} -- that
1207 doesn't hang with the idea of making a dtd at some point"
1210 `((% . ,(lambda (x . t) (cons 'texinfo-arguments t)))
1211 (*text* . ,(lambda (x t) t))
1212 (*default* . ,(lambda (x . t) (cons x t))))))
1214 ;;; arch-tag: 73890afa-597c-4264-ae70-46fe7756ffb5
1215 ;;; texinfo.scm ends here