1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264 |
- (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-11)
- #:use-module (srfi srfi-13)
- #:export (call-with-file-and-dir
- texi-command-specs
- texi-command-depth
- texi-fragment->stexi
- texi->stexi
- stexi->sxml))
- (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 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 INLINE-TEXT-ARGS
- 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{INLINE-TEXT-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
- @end table"
- '(
- (include #f)
- (para PARAGRAPH)
- (item ITEM)
- (entry ENTRY . heading)
- (noindent EMPTY-COMMAND)
- (*fragment* FRAGMENT)
-
- (*braces* INLINE-TEXT)
- (bold INLINE-TEXT)
- (sample INLINE-TEXT)
- (samp INLINE-TEXT)
- (code INLINE-TEXT)
- (math 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)
-
- (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-TEXT-ARGS
- . (node #:opt name section info-file manual))
- (url ALIAS . uref)
- (uref INLINE-TEXT-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))
-
- (acronym INLINE-TEXT-ARGS . (acronym #:opt meaning))
-
- (node EOL-ARGS . (name #:opt next previous up))
- (c EOL-ARGS . all)
- ( 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))
-
- (*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))
-
- (cindex INDEX . entry)
- (findex INDEX . entry)
- (vindex INDEX . entry)
- (kindex INDEX . entry)
- (pindex INDEX . entry)
- (tindex INDEX . entry)
-
- (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)))
- (define (space-significant? command)
- (memq command
- '(example smallexample verbatim lisp smalllisp menu %)))
- (define (command-spec command)
- (let ((spec (assq command texi-command-specs)))
- (cond
- ((not spec)
- (parser-error #f "Unknown command" command))
- ((eq? (cadr spec) 'ALIAS)
- (command-spec (cddr spec)))
- (else
- spec))))
- (define (inline-content? content)
- (case content
- ((INLINE-TEXT INLINE-ARGS INLINE-TEXT-ARGS) #t)
- (else #f)))
- (define (string-whitespace? str)
- (or (string-null? str)
- (string-every char-whitespace? str)))
- (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)))
- (if (and (eq? c #\return) (eq? (peek-char port) #\newline))
- (read-char port))
- line)))
- (define (skip-whitespace port)
- (skip-while '(#\space #\tab #\return #\newline) port))
- (define (skip-horizontal-whitespace port)
- (skip-while '(#\space #\tab) port))
- (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)))
- (define (make-token kind head) (cons kind head))
- (define token? pair?)
- (define token-kind car)
- (define token-head cdr)
- (define (read-command-token port)
- (assert-curr-char '(#\@) "start of the command" port)
- (let ((peeked (peek-char port)))
- (cond
- ((memq peeked '(#\! #\: #\. #\? #\@ #\\ #\{ #\}))
-
- (make-token 'STRING (string (read-char port))))
- (else
- (let ((name (read-command port)))
- (case name
- ((end)
-
- (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)
-
- (make-token 'END 'texinfo))
- ((item)
- (make-token 'ITEM 'item))
- ((include)
- (make-token 'INCLUDE #f))
- (else
- (make-token 'START name))))))))
- (define (read-verbatim-body port str-handler seed)
- (let loop ((seed seed))
- (let ((fragment (next-token '() '(#\newline)
- "reading verbatim" port)))
-
-
- (read-char port)
- (if (string=? fragment "@end verbatim")
- seed
- (loop (str-handler fragment "\n" seed))))))
- (define (read-arguments port stop-char)
- (define (split str)
- (read-char port)
- (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)))
- (define (arguments->attlist port args arg-names)
- (let loop ((in args) (names arg-names) (opt? #f) (out '()))
- (cond
- ((symbol? names)
- (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?
- (acons (car names)
- (if (list? (car in)) (car in) (list (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
- `((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))
- (command (car spec))
- (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))
- ((INLINE-TEXT-ARGS)
- (assert-curr-char '(#\{) "Inline element lacks {" port)
- (values command '() 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
- (parser-error port "can't happen")))))
- (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")))
- (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)))
- (cond
- ((eof-object? term-char)
- (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)
-
- (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? "" (if preserve-ws? "\n" " "))
- seed)
- token)))
- ((and (not preserve-ws?) (eq? c #\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)))))))))))))
- (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)))
- (define (read-include-file-name port)
- (let ((x (string-trim-both (read-eof-line port))))
- (if (string-null? x)
- (error "no file listed")
- x)))
- (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))
-
- (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))))
-
-
- (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)
-
-
- (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)
-
-
- (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)
-
- (loop port expect-eof? end-para (not sig-ws?) seed))
- ((INCLUDE)
-
- (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)
- (let* ((head (token-head token))
- (spec (command-spec head))
- (head (car spec))
- (type (cadr spec))
- (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))))))))))))))))
- (define (reverse-collect-str-drop-ws fragments)
- (cond
- ((null? fragments)
- '())
- ((and (string? (car fragments))
- (null? (cdr fragments))
- (string-whitespace? (car fragments)))
- '())
- (else
- (let loop ((fragments fragments) (result '()) (strs '())
- (all-whitespace? #t))
- (cond
- ((null? fragments)
- (if all-whitespace?
- result
- (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
- (cons " " result)))
-
- (else
- (cons (apply string-append strs) result))))
- '() #t)))))))
- (define (parse-inline-text-args port spec text)
- (let lp ((in text) (cur '()) (out '()))
- (cond
- ((null? in)
- (if (and (pair? cur)
- (string? (car cur))
- (string-whitespace? (car cur)))
- (lp in (cdr cur) out)
- (let ((args (reverse (if (null? cur)
- out
- (cons (reverse cur) out)))))
- (arguments->attlist port args (cddr spec)))))
- ((pair? (car in))
- (lp (cdr in) (cons (car in) cur) out))
- ((string-index (car in) #\,)
- (let* ((parts (string-split (car in) #\,))
- (head (string-trim-right (car parts)))
- (rev-tail (reverse (cdr parts)))
- (last (string-trim (car rev-tail))))
- (lp (cdr in)
- (if (string-null? last) cur (cons last cur))
- (append (cdr rev-tail)
- (cons (reverse (if (string-null? head) cur (cons head cur)))
- out)))))
- (else
- (lp (cdr in)
- (cons (if (null? cur) (string-trim (car in)) (car in)) cur)
- out)))))
- (define (make-dom-parser)
- (make-command-parser
- (lambda (command args content seed)
- '())
- (lambda (command args parent-seed seed)
- (let* ((seed (reverse-collect-str-drop-ws seed))
- (spec (command-spec command))
- (command (car spec)))
- (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
- (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
- parent-seed)
- (acons command
- (if (null? args) seed (acons '% args seed))
- parent-seed))))
- (lambda (string1 string2 seed)
- (if (string-null? string2)
- (cons string1 seed)
- (cons* string2 string1 seed)))))
- (define parse-environment-args
- (let ((parser (make-dom-parser)))
-
- (lambda (command port)
- (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
- (spec (command-spec command))
- (command (car spec))
- (arg-names (cddr spec)))
- (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)
-
-
- (parse-environment-args command port))
- (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)))
- (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
- (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
- (loop (cdr in) (cons (car in) out) state #t sig-ws?))))
- (call-with-values
- (lambda () (loop tree '() '() #t #f))
- (lambda (out state) out)))
- (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))))))
|