psyntax uses define-syntax-rule

[bpt/guile.git] / module / texinfo.scm

;;;; (texinfo) -- parsing of texinfo into SXML
;;;;
;;;; 	Copyright (C) 2009, 2010, 2011  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
\f
;;; 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 throw 'parser-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}.

In addition, @code{ALIAS} can alias one command to another.  The alias
will never be seen in parsed stexinfo.

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)
    (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))
    (url                ALIAS       . uref)
    (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))
    (paragraphindent    EOL-ARGS . (indent))

    ;; 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 (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 port "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
      ((ALIAS)
       (complete-start-command arg-names port))
      ((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