texinfo.scm 51 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265
  1. ;;;; (texinfo) -- parsing of texinfo into SXML
  2. ;;;;
  3. ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2020 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>
  6. ;;;;
  7. ;;;; This file is based on SSAX's SSAX.scm.
  8. ;;;;
  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.
  13. ;;;;
  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.
  18. ;;;;
  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
  22. ;;; Commentary:
  23. ;;
  24. ;; @subheading Texinfo processing in scheme
  25. ;;
  26. ;; This module parses texinfo into SXML. TeX will always be the
  27. ;; processor of choice for print output, of course. However, although
  28. ;; @code{makeinfo} works well for info, its output in other formats is
  29. ;; not very customizable, and the program is not extensible as a whole.
  30. ;; This module aims to provide an extensible framework for texinfo
  31. ;; processing that integrates texinfo into the constellation of SXML
  32. ;; processing tools.
  33. ;;
  34. ;; @subheading Notes on the SXML vocabulary
  35. ;;
  36. ;; Consider the following texinfo fragment:
  37. ;;
  38. ;;@example
  39. ;; @@deffn Primitive set-car! pair value
  40. ;; This function...
  41. ;; @@end deffn
  42. ;;@end example
  43. ;;
  44. ;; Logically, the category (Primitive), name (set-car!), and arguments
  45. ;; (pair value) are ``attributes'' of the deffn, with the description as
  46. ;; the content. However, texinfo allows for @@-commands within the
  47. ;; arguments to an environment, like @code{@@deffn}, which means that
  48. ;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand,
  49. ;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are
  50. ;; called ``arguments'', and are grouped under the special element, `%'.
  51. ;;
  52. ;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In
  53. ;; the interests of interoperability, this module provides a conversion
  54. ;; function to replace the `%' with `texinfo-arguments'.
  55. ;;
  56. ;;; Code:
  57. ;; Comparison to xml output of texinfo (which is rather undocumented):
  58. ;; Doesn't conform to texinfo dtd
  59. ;; No DTD at all, in fact :-/
  60. ;; Actually outputs valid xml, after transforming %
  61. ;; Slower (although with caching the SXML that problem can go away)
  62. ;; Doesn't parse menus (although menus are shite)
  63. ;; Args go in a dedicated element, FBOFW
  64. ;; Definitions are handled a lot better
  65. ;; Does parse comments
  66. ;; Outputs only significant line breaks (a biggie!)
  67. ;; Nodes are treated as anchors, rather than content organizers (a biggie)
  68. ;; (more book-like, less info-like)
  69. ;; TODO
  70. ;; Integration: help, indexing, plain text
  71. (define-module (texinfo)
  72. #:use-module (sxml simple)
  73. #:use-module (sxml transform)
  74. #:use-module (sxml ssax input-parse)
  75. #:use-module (srfi srfi-1)
  76. #:use-module (srfi srfi-11)
  77. #:use-module (srfi srfi-13)
  78. #:export (call-with-file-and-dir
  79. texi-command-specs
  80. texi-command-depth
  81. texi-fragment->stexi
  82. texi->stexi
  83. stexi->sxml))
  84. ;; Some utilities
  85. (define (parser-error port message . rest)
  86. (apply throw 'parser-error port message rest))
  87. (define (call-with-file-and-dir filename proc)
  88. "Call the one-argument procedure @var{proc} with an input port that
  89. reads from @var{filename}. During the dynamic extent of @var{proc}'s
  90. execution, the current directory will be @code{(dirname
  91. @var{filename})}. This is useful for parsing documents that can include
  92. files by relative path name."
  93. (let ((current-dir (getcwd)))
  94. (dynamic-wind
  95. (lambda () (chdir (dirname filename)))
  96. (lambda ()
  97. (call-with-input-file (basename filename) proc))
  98. (lambda () (chdir current-dir)))))
  99. ;;========================================================================
  100. ;; Reflection on the XML vocabulary
  101. (define texi-command-specs
  102. #;
  103. "A list of (@var{name} @var{content-model} . @var{args})
  104. @table @var
  105. @item name
  106. The name of an @@-command, as a symbol.
  107. @item content-model
  108. A symbol indicating the syntactic type of the @@-command:
  109. @table @code
  110. @item EMPTY-COMMAND
  111. No content, and no @code{@@end} is coming
  112. @item EOL-ARGS
  113. Unparsed arguments until end of line
  114. @item EOL-TEXT
  115. Parsed arguments until end of line
  116. @item INLINE-ARGS
  117. Unparsed arguments ending with @code{#\\@}}
  118. @item INLINE-TEXT
  119. Parsed arguments ending with @code{#\\@}}
  120. @item INLINE-TEXT-ARGS
  121. Parsed arguments ending with @code{#\\@}}
  122. @item ENVIRON
  123. The tag is an environment tag, expect @code{@@end foo}.
  124. @item TABLE-ENVIRON
  125. Like ENVIRON, but with special parsing rules for its arguments.
  126. @item FRAGMENT
  127. For @code{*fragment*}, the command used for parsing fragments of
  128. texinfo documents.
  129. @end table
  130. @code{INLINE-TEXT} commands will receive their arguments within their
  131. bodies, whereas the @code{-ARGS} commands will receive them in their
  132. attribute list.
  133. @code{EOF-TEXT} receives its arguments in its body.
  134. @code{ENVIRON} commands have both: parsed arguments until the end of
  135. line, received through their attribute list, and parsed text until the
  136. @code{@@end}, received in their bodies.
  137. @code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in
  138. @code{ENVIRON}.
  139. In addition, @code{ALIAS} can alias one command to another. The alias
  140. will never be seen in parsed stexinfo.
  141. There are four @@-commands that are treated specially. @code{@@include}
  142. is a low-level token that will not be seen by higher-level parsers, so
  143. it has no content-model. @code{@@para} is the paragraph command, which
  144. is only implicit in the texinfo source. @code{@@item} has special
  145. syntax, as noted above, and @code{@@entry} is how this parser treats
  146. @code{@@item} commands within @code{@@table}, @code{@@ftable}, and
  147. @code{@@vtable}.
  148. Also, indexing commands (@code{@@cindex}, etc.) are treated specially.
  149. Their arguments are parsed, but they are needed before entering the
  150. element so that an anchor can be inserted into the text before the index
  151. entry.
  152. @item args
  153. Named arguments to the command, in the same format as the formals for a
  154. lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
  155. @code{INLINE-TEXT-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
  156. @end table"
  157. '(;; Special commands
  158. (include #f) ;; this is a low-level token
  159. (para PARAGRAPH)
  160. (item ITEM)
  161. (entry ENTRY . heading)
  162. (noindent EMPTY-COMMAND)
  163. (*fragment* FRAGMENT)
  164. ;; Inline text commands
  165. (*braces* INLINE-TEXT) ;; FIXME: make me irrelevant
  166. (bold INLINE-TEXT)
  167. (sample INLINE-TEXT)
  168. (samp INLINE-TEXT)
  169. (code INLINE-TEXT)
  170. (math INLINE-TEXT)
  171. (kbd INLINE-TEXT)
  172. (key INLINE-TEXT)
  173. (var INLINE-TEXT)
  174. (env INLINE-TEXT)
  175. (file INLINE-TEXT)
  176. (command INLINE-TEXT)
  177. (option INLINE-TEXT)
  178. (dfn INLINE-TEXT)
  179. (cite INLINE-TEXT)
  180. (acro INLINE-TEXT)
  181. (email INLINE-TEXT)
  182. (emph INLINE-TEXT)
  183. (strong INLINE-TEXT)
  184. (sample INLINE-TEXT)
  185. (sc INLINE-TEXT)
  186. (titlefont INLINE-TEXT)
  187. (asis INLINE-TEXT)
  188. (b INLINE-TEXT)
  189. (i INLINE-TEXT)
  190. (r INLINE-TEXT)
  191. (sansserif INLINE-TEXT)
  192. (slanted INLINE-TEXT)
  193. (t INLINE-TEXT)
  194. (w INLINE-TEXT)
  195. ;; Inline args commands
  196. (value INLINE-ARGS . (key))
  197. (ref INLINE-ARGS . (node #:opt name section info-file manual))
  198. (xref INLINE-ARGS . (node #:opt name section info-file manual))
  199. (pxref INLINE-TEXT-ARGS
  200. . (node #:opt name section info-file manual))
  201. (url ALIAS . uref)
  202. (uref INLINE-TEXT-ARGS . (url #:opt title replacement))
  203. (anchor INLINE-ARGS . (name))
  204. (dots INLINE-ARGS . ())
  205. (result INLINE-ARGS . ())
  206. (bullet INLINE-ARGS . ())
  207. (copyright INLINE-ARGS . ())
  208. (tie INLINE-ARGS . ())
  209. (image INLINE-ARGS . (file #:opt width height alt-text extension))
  210. ;; Inline parsed args commands
  211. (acronym INLINE-TEXT-ARGS . (acronym #:opt meaning))
  212. ;; EOL args elements
  213. (node EOL-ARGS . (name #:opt next previous up))
  214. (c EOL-ARGS . all)
  215. (comment EOL-ARGS . all)
  216. (setchapternewpage EOL-ARGS . all)
  217. (sp EOL-ARGS . all)
  218. (page EOL-ARGS . ())
  219. (vskip EOL-ARGS . all)
  220. (syncodeindex EOL-ARGS . all)
  221. (contents EOL-ARGS . ())
  222. (shortcontents EOL-ARGS . ())
  223. (summarycontents EOL-ARGS . ())
  224. (insertcopying EOL-ARGS . ())
  225. (dircategory EOL-ARGS . (category))
  226. (top EOL-ARGS . (title))
  227. (printindex EOL-ARGS . (type))
  228. (paragraphindent EOL-ARGS . (indent))
  229. ;; EOL text commands
  230. (*ENVIRON-ARGS* EOL-TEXT)
  231. (itemx EOL-TEXT)
  232. (set EOL-TEXT)
  233. (center EOL-TEXT)
  234. (title EOL-TEXT)
  235. (subtitle EOL-TEXT)
  236. (author EOL-TEXT)
  237. (chapter EOL-TEXT)
  238. (section EOL-TEXT)
  239. (appendix EOL-TEXT)
  240. (appendixsec EOL-TEXT)
  241. (unnumbered EOL-TEXT)
  242. (unnumberedsec EOL-TEXT)
  243. (subsection EOL-TEXT)
  244. (subsubsection EOL-TEXT)
  245. (appendixsubsec EOL-TEXT)
  246. (appendixsubsubsec EOL-TEXT)
  247. (unnumberedsubsec EOL-TEXT)
  248. (unnumberedsubsubsec EOL-TEXT)
  249. (chapheading EOL-TEXT)
  250. (majorheading EOL-TEXT)
  251. (heading EOL-TEXT)
  252. (subheading EOL-TEXT)
  253. (subsubheading EOL-TEXT)
  254. (deftpx EOL-TEXT-ARGS . (category name . attributes))
  255. (defcvx EOL-TEXT-ARGS . (category class name))
  256. (defivarx EOL-TEXT-ARGS . (class name))
  257. (deftypeivarx EOL-TEXT-ARGS . (class data-type name))
  258. (defopx EOL-TEXT-ARGS . (category class name . arguments))
  259. (deftypeopx EOL-TEXT-ARGS . (category class data-type name . arguments))
  260. (defmethodx EOL-TEXT-ARGS . (class name . arguments))
  261. (deftypemethodx EOL-TEXT-ARGS . (class data-type name . arguments))
  262. (defoptx EOL-TEXT-ARGS . (name))
  263. (defvrx EOL-TEXT-ARGS . (category name))
  264. (defvarx EOL-TEXT-ARGS . (name))
  265. (deftypevrx EOL-TEXT-ARGS . (category data-type name))
  266. (deftypevarx EOL-TEXT-ARGS . (data-type name))
  267. (deffnx EOL-TEXT-ARGS . (category name . arguments))
  268. (deftypefnx EOL-TEXT-ARGS . (category data-type name . arguments))
  269. (defspecx EOL-TEXT-ARGS . (name . arguments))
  270. (defmacx EOL-TEXT-ARGS . (name . arguments))
  271. (defunx EOL-TEXT-ARGS . (name . arguments))
  272. (deftypefunx EOL-TEXT-ARGS . (data-type name . arguments))
  273. ;; Indexing commands
  274. (cindex INDEX . entry)
  275. (findex INDEX . entry)
  276. (vindex INDEX . entry)
  277. (kindex INDEX . entry)
  278. (pindex INDEX . entry)
  279. (tindex INDEX . entry)
  280. ;; Environment commands (those that need @end)
  281. (texinfo ENVIRON . title)
  282. (ignore ENVIRON . ())
  283. (ifinfo ENVIRON . ())
  284. (iftex ENVIRON . ())
  285. (ifhtml ENVIRON . ())
  286. (ifxml ENVIRON . ())
  287. (ifplaintext ENVIRON . ())
  288. (ifnotinfo ENVIRON . ())
  289. (ifnottex ENVIRON . ())
  290. (ifnothtml ENVIRON . ())
  291. (ifnotxml ENVIRON . ())
  292. (ifnotplaintext ENVIRON . ())
  293. (titlepage ENVIRON . ())
  294. (menu ENVIRON . ())
  295. (direntry ENVIRON . ())
  296. (copying ENVIRON . ())
  297. (example ENVIRON . ())
  298. (smallexample ENVIRON . ())
  299. (display ENVIRON . ())
  300. (smalldisplay ENVIRON . ())
  301. (verbatim ENVIRON . ())
  302. (format ENVIRON . ())
  303. (smallformat ENVIRON . ())
  304. (lisp ENVIRON . ())
  305. (smalllisp ENVIRON . ())
  306. (cartouche ENVIRON . ())
  307. (quotation ENVIRON . ())
  308. (deftp ENVIRON . (category name . attributes))
  309. (defcv ENVIRON . (category class name))
  310. (defivar ENVIRON . (class name))
  311. (deftypeivar ENVIRON . (class data-type name))
  312. (defop ENVIRON . (category class name . arguments))
  313. (deftypeop ENVIRON . (category class data-type name . arguments))
  314. (defmethod ENVIRON . (class name . arguments))
  315. (deftypemethod ENVIRON . (class data-type name . arguments))
  316. (defopt ENVIRON . (name))
  317. (defvr ENVIRON . (category name))
  318. (defvar ENVIRON . (name))
  319. (deftypevr ENVIRON . (category data-type name))
  320. (deftypevar ENVIRON . (data-type name))
  321. (deffn ENVIRON . (category name . arguments))
  322. (deftypefn ENVIRON . (category data-type name . arguments))
  323. (defspec ENVIRON . (name . arguments))
  324. (defmac ENVIRON . (name . arguments))
  325. (defun ENVIRON . (name . arguments))
  326. (deftypefun ENVIRON . (data-type name . arguments))
  327. (table TABLE-ENVIRON . (formatter))
  328. (itemize TABLE-ENVIRON . (formatter))
  329. (enumerate TABLE-ENVIRON . (start))
  330. (ftable TABLE-ENVIRON . (formatter))
  331. (vtable TABLE-ENVIRON . (formatter))))
  332. (define command-depths
  333. '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4)
  334. (top . 0) (unnumbered . 1) (unnumberedsec . 2)
  335. (unnumberedsubsec . 3) (unnumberedsubsubsec . 4)
  336. (appendix . 1) (appendixsec . 2) (appendixsection . 2)
  337. (appendixsubsec . 3) (appendixsubsubsec . 4)))
  338. (define (texi-command-depth command max-depth)
  339. "Given the texinfo command @var{command}, return its nesting level, or
  340. @code{#f} if it nests too deep for @var{max-depth}.
  341. Examples:
  342. @example
  343. (texi-command-depth 'chapter 4) @result{} 1
  344. (texi-command-depth 'top 4) @result{} 0
  345. (texi-command-depth 'subsection 4) @result{} 3
  346. (texi-command-depth 'appendixsubsec 4) @result{} 3
  347. (texi-command-depth 'subsection 2) @result{} #f
  348. @end example"
  349. (let ((depth (and=> (assq command command-depths) cdr)))
  350. (and depth (<= depth max-depth) depth)))
  351. ;; The % is for arguments
  352. (define (space-significant? command)
  353. (memq command
  354. '(example smallexample verbatim lisp smalllisp menu w %)))
  355. ;; Like a DTD for texinfo
  356. (define (command-spec command)
  357. (let ((spec (assq command texi-command-specs)))
  358. (cond
  359. ((not spec)
  360. (parser-error #f "Unknown command" command))
  361. ((eq? (cadr spec) 'ALIAS)
  362. (command-spec (cddr spec)))
  363. (else
  364. spec))))
  365. (define (inline-content? content)
  366. (case content
  367. ((INLINE-TEXT INLINE-ARGS INLINE-TEXT-ARGS) #t)
  368. (else #f)))
  369. ;;========================================================================
  370. ;; Lower-level parsers and scanners
  371. ;;
  372. ;; They deal with primitive lexical units (Names, whitespaces, tags) and
  373. ;; with pieces of more generic productions. Most of these parsers must
  374. ;; be called in appropriate context. For example, complete-start-command
  375. ;; must be called only when the @-command start has been detected and
  376. ;; its name token has been read.
  377. ;; Test if a string is made of only whitespace
  378. ;; An empty string is considered made of whitespace as well
  379. (define (string-whitespace? str)
  380. (or (string-null? str)
  381. (string-every char-whitespace? str)))
  382. ;; Like read-text-line, but allows EOF.
  383. (define read-eof-breaks '(*eof* #\return #\newline))
  384. (define (read-eof-line port)
  385. (if (eof-object? (peek-char port))
  386. (peek-char port)
  387. (let* ((line (next-token '() read-eof-breaks
  388. "reading a line" port))
  389. (c (read-char port))) ; must be either \n or \r or EOF
  390. (if (and (eq? c #\return) (eq? (peek-char port) #\newline))
  391. (read-char port)) ; skip \n that follows \r
  392. line)))
  393. (define (skip-whitespace port)
  394. (skip-while '(#\space #\tab #\return #\newline) port))
  395. (define (skip-horizontal-whitespace port)
  396. (skip-while '(#\space #\tab) port))
  397. ;; command ::= Letter+
  398. ;; procedure: read-command PORT
  399. ;;
  400. ;; Read a command starting from the current position in the PORT and
  401. ;; return it as a symbol.
  402. (define (read-command port)
  403. (let ((first-char (peek-char port)))
  404. (or (char-alphabetic? first-char)
  405. (parser-error port "Nonalphabetic @-command char: '" first-char "'")))
  406. (string->symbol
  407. (next-token-of
  408. (lambda (c)
  409. (cond
  410. ((eof-object? c) #f)
  411. ((char-alphabetic? c) c)
  412. (else #f)))
  413. port)))
  414. ;; A token is a primitive lexical unit. It is a record with two fields,
  415. ;; token-head and token-kind.
  416. ;;
  417. ;; Token types:
  418. ;; END The end of a texinfo command. If the command is ended by },
  419. ;; token-head will be #f. Otherwise if the command is ended by
  420. ;; @end COMMAND, token-head will be COMMAND. As a special case,
  421. ;; @bye is the end of a special @texinfo command.
  422. ;; START The start of a texinfo command. The token-head will be a
  423. ;; symbol of the @-command name.
  424. ;; INCLUDE An @include directive. The token-head will be empty -- the
  425. ;; caller is responsible for reading the include file name.
  426. ;; ITEM @item commands have an irregular syntax. They end at the
  427. ;; next @item, or at the end of the environment. For that
  428. ;; read-command-token treats them specially.
  429. (define (make-token kind head) (cons kind head))
  430. (define token? pair?)
  431. (define token-kind car)
  432. (define token-head cdr)
  433. ;; procedure: read-command-token PORT
  434. ;;
  435. ;; This procedure starts parsing of a command token. The current
  436. ;; position in the stream must be #\@. This procedure scans enough of
  437. ;; the input stream to figure out what kind of a command token it is
  438. ;; seeing. The procedure returns a token structure describing the token.
  439. (define (read-command-token port)
  440. (assert-curr-char '(#\@) "start of the command" port)
  441. (let ((peeked (peek-char port)))
  442. (cond
  443. ((memq peeked '(#\! #\: #\. #\? #\@ #\\ #\{ #\}))
  444. ;; @-commands that escape characters
  445. (make-token 'STRING (string (read-char port))))
  446. (else
  447. (let ((name (read-command port)))
  448. (case name
  449. ((end)
  450. ;; got an ending tag
  451. (let ((command (string-trim-both
  452. (read-eof-line port))))
  453. (or (and (not (string-null? command))
  454. (string-every char-alphabetic? command))
  455. (parser-error port "malformed @end" command))
  456. (make-token 'END (string->symbol command))))
  457. ((bye)
  458. ;; the end of the top
  459. (make-token 'END 'texinfo))
  460. ((item)
  461. (make-token 'ITEM 'item))
  462. ((include)
  463. (make-token 'INCLUDE #f))
  464. (else
  465. (make-token 'START name))))))))
  466. ;; procedure+: read-verbatim-body PORT STR-HANDLER SEED
  467. ;;
  468. ;; This procedure must be called after we have read a string
  469. ;; "@verbatim\n" that begins a verbatim section. The current position
  470. ;; must be the first position of the verbatim body. This function reads
  471. ;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a
  472. ;; character data consumer.
  473. ;;
  474. ;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
  475. ;; The first STRING1 argument to STR-HANDLER never contains a newline.
  476. ;; The second STRING2 argument often will. On the first invocation of the
  477. ;; STR-HANDLER, the seed is the one passed to read-verbatim-body
  478. ;; as the third argument. The result of this first invocation will be
  479. ;; passed as the seed argument to the second invocation of the line
  480. ;; consumer, and so on. The result of the last invocation of the
  481. ;; STR-HANDLER is returned by the read-verbatim-body. Note a
  482. ;; similarity to the fundamental 'fold' iterator.
  483. ;;
  484. ;; Within a verbatim section all characters are taken at their face
  485. ;; value. It ends with "\n@end verbatim(\r)?\n".
  486. ;; Must be called right after the newline after @verbatim.
  487. (define (read-verbatim-body port str-handler seed)
  488. (let loop ((seed seed))
  489. (let ((fragment (next-token '() '(#\newline)
  490. "reading verbatim" port)))
  491. ;; We're reading the char after the 'fragment', which is
  492. ;; #\newline.
  493. (read-char port)
  494. (if (string=? fragment "@end verbatim")
  495. seed
  496. (loop (str-handler fragment "\n" seed))))))
  497. ;; procedure+: read-arguments PORT
  498. ;;
  499. ;; This procedure reads and parses a production ArgumentList.
  500. ;; ArgumentList ::= S* Argument (S* , S* Argument)* S*
  501. ;; Argument ::= ([^@{},])*
  502. ;;
  503. ;; Arguments are the things in braces, i.e @ref{my node} has one
  504. ;; argument, "my node". Most commands taking braces actually don't have
  505. ;; arguments, they process text. For example, in
  506. ;; @emph{@strong{emphasized}}, the emph takes text, because the parse
  507. ;; continues into the braces.
  508. ;;
  509. ;; Any whitespace within Argument is replaced with a single space.
  510. ;; Whitespace around an Argument is trimmed.
  511. ;;
  512. ;; The procedure returns a list of arguments. Afterwards the current
  513. ;; character will be after the final #\}.
  514. (define (read-arguments port stop-char)
  515. (define (split str)
  516. (read-char port) ;; eat the delimiter
  517. (let ((ret (map (lambda (x) (if (string-null? x) #f x))
  518. (map string-trim-both (string-split str #\,)))))
  519. (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret)))
  520. '()
  521. ret)))
  522. (split (next-token '() (list stop-char)
  523. "arguments of @-command" port)))
  524. ;; procedure+: complete-start-command COMMAND PORT
  525. ;;
  526. ;; This procedure is to complete parsing of an @-command. The procedure
  527. ;; must be called after the command token has been read. COMMAND is a
  528. ;; TAG-NAME.
  529. ;;
  530. ;; This procedure returns several values:
  531. ;; COMMAND: a symbol.
  532. ;; ARGUMENTS: command's arguments, as an alist.
  533. ;; CONTENT-MODEL: the content model of the command.
  534. ;;
  535. ;; On exit, the current position in PORT will depend on the CONTENT-MODEL.
  536. ;;
  537. ;; Content model Port position
  538. ;; ============= =============
  539. ;; INLINE-TEXT One character after the #\{.
  540. ;; INLINE-TEXT-ARGS One character after the #\{.
  541. ;; INLINE-ARGS The first character after the #\}.
  542. ;; EOL-TEXT The first non-whitespace character after the command.
  543. ;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT
  544. ;; The first character on the next line.
  545. ;; PARAGRAPH, ITEM, EMPTY-COMMAND
  546. ;; The first character after the command.
  547. (define (arguments->attlist port args arg-names)
  548. (let loop ((in args) (names arg-names) (opt? #f) (out '()))
  549. (cond
  550. ((symbol? names) ;; a rest arg
  551. (reverse (if (null? in) out (acons names in out))))
  552. ((and (not (null? names)) (eq? (car names) #:opt))
  553. (loop in (cdr names) #t out))
  554. ((null? in)
  555. (if (or (null? names) opt?)
  556. (reverse out)
  557. (parser-error port "@-command expected more arguments:"
  558. args arg-names names)))
  559. ((null? names)
  560. (parser-error port "@-command didn't expect more arguments:" in))
  561. ((not (car in))
  562. (or (and opt? (loop (cdr in) (cdr names) opt? out))
  563. (parser-error "@-command missing required argument"
  564. (car names))))
  565. (else
  566. (loop (cdr in) (cdr names) opt?
  567. (acons (car names)
  568. (if (list? (car in)) (car in) (list (car in)))
  569. out))))))
  570. (define (parse-table-args command port)
  571. (let* ((line (string-trim-both (read-text-line port)))
  572. (length (string-length line)))
  573. (define (get-formatter)
  574. (or (and (not (zero? length))
  575. (eq? (string-ref line 0) #\@)
  576. (let ((f (string->symbol (substring line 1))))
  577. (or (inline-content? (cadr (command-spec f)))
  578. (parser-error
  579. port "@item formatter must be INLINE" f))
  580. f))
  581. (parser-error port "Invalid @item formatter" line)))
  582. (case command
  583. ((enumerate)
  584. (if (zero? length)
  585. '()
  586. `((start
  587. ,(if (or (and (eq? length 1)
  588. (char-alphabetic? (string-ref line 0)))
  589. (string-every char-numeric? line))
  590. line
  591. (parser-error
  592. port "Invalid enumerate start" line))))))
  593. ((itemize)
  594. `((bullet
  595. ,(or (and (eq? length 1) line)
  596. (and (string-null? line) '(bullet))
  597. (list (get-formatter))))))
  598. (else ;; tables of various varieties
  599. `((formatter (,(get-formatter))))))))
  600. (define (complete-start-command command port)
  601. (define (get-arguments type arg-names stop-char)
  602. (arguments->attlist port (read-arguments port stop-char) arg-names))
  603. (let* ((spec (command-spec command))
  604. (command (car spec))
  605. (type (cadr spec))
  606. (arg-names (cddr spec)))
  607. (case type
  608. ((INLINE-TEXT)
  609. (assert-curr-char '(#\{) "Inline element lacks {" port)
  610. (values command '() type))
  611. ((INLINE-ARGS)
  612. (assert-curr-char '(#\{) "Inline element lacks {" port)
  613. (values command (get-arguments type arg-names #\}) type))
  614. ((INLINE-TEXT-ARGS)
  615. (assert-curr-char '(#\{) "Inline element lacks {" port)
  616. (values command '() type))
  617. ((EOL-ARGS)
  618. (values command (get-arguments type arg-names #\newline) type))
  619. ((ENVIRON ENTRY INDEX)
  620. (skip-horizontal-whitespace port)
  621. (values command (parse-environment-args command port) type))
  622. ((TABLE-ENVIRON)
  623. (skip-horizontal-whitespace port)
  624. (values command (parse-table-args command port) type))
  625. ((EOL-TEXT)
  626. (skip-horizontal-whitespace port)
  627. (values command '() type))
  628. ((EOL-TEXT-ARGS)
  629. (skip-horizontal-whitespace port)
  630. (values command (parse-eol-text-args command port) type))
  631. ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT)
  632. (values command '() type))
  633. (else ;; INCLUDE shouldn't get here
  634. (parser-error port "can't happen")))))
  635. ;;-----------------------------------------------------------------------------
  636. ;; Higher-level parsers and scanners
  637. ;;
  638. ;; They parse productions corresponding entire @-commands.
  639. ;; Only reads @settitle, leaves it to the command parser to finish
  640. ;; reading the title.
  641. (define (take-until-settitle port)
  642. (or (find-string-from-port? "\n@settitle " port)
  643. (parser-error port "No \\n@settitle found"))
  644. (skip-horizontal-whitespace port)
  645. (and (eq? (peek-char port) #\newline)
  646. (parser-error port "You have a @settitle, but no title")))
  647. ;; procedure+: read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
  648. ;;
  649. ;; This procedure is to read the CharData of a texinfo document.
  650. ;;
  651. ;; text ::= (CharData | Command)*
  652. ;;
  653. ;; The procedure reads CharData and stops at @-commands (or
  654. ;; environments). It also stops at an open or close brace.
  655. ;;
  656. ;; port
  657. ;; a PORT to read
  658. ;; expect-eof?
  659. ;; a boolean indicating if EOF is normal, i.e., the character
  660. ;; data may be terminated by the EOF. EOF is normal
  661. ;; while processing the main document.
  662. ;; preserve-ws?
  663. ;; a boolean indicating if we are within a whitespace-preserving
  664. ;; environment. If #t, suppress paragraph detection.
  665. ;; str-handler
  666. ;; a STR-HANDLER, see read-verbatim-body
  667. ;; seed
  668. ;; an argument passed to the first invocation of STR-HANDLER.
  669. ;;
  670. ;; The procedure returns two results: SEED and TOKEN. The SEED is the
  671. ;; result of the last invocation of STR-HANDLER, or the original seed if
  672. ;; STR-HANDLER was never called.
  673. ;;
  674. ;; TOKEN can be either an eof-object (this can happen only if expect-eof?
  675. ;; was #t), or a texinfo token denoting the start or end of a tag.
  676. ;; read-char-data port expect-eof? preserve-ws? str-handler seed
  677. (define read-char-data
  678. (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline)))
  679. (define (handle str-handler str1 str2 seed)
  680. (if (and (string-null? str1) (string-null? str2))
  681. seed
  682. (str-handler str1 str2 seed)))
  683. (lambda (port expect-eof? preserve-ws? str-handler seed)
  684. (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof)))
  685. (let loop ((seed seed))
  686. (let* ((fragment (next-token '() end-chars "reading char data" port))
  687. (term-char (peek-char port))) ; one of end-chars
  688. (cond
  689. ((eof-object? term-char) ; only if expect-eof?
  690. (values (handle str-handler fragment "" seed) term-char))
  691. ((memq term-char '(#\@ #\{ #\}))
  692. (values (handle str-handler fragment "" seed)
  693. (case term-char
  694. ((#\@) (read-command-token port))
  695. ((#\{) (make-token 'START '*braces*))
  696. ((#\}) (read-char port) (make-token 'END #f)))))
  697. ((eq? term-char #\newline)
  698. ;; Always significant, unless directly before an end token.
  699. (let ((c (peek-next-char port)))
  700. (cond
  701. ((eof-object? c)
  702. (or expect-eof?
  703. (parser-error port "EOF while reading char data"))
  704. (values (handle str-handler fragment "" seed) c))
  705. ((eq? c #\@)
  706. (let* ((token (read-command-token port))
  707. (end? (eq? (token-kind token) 'END)))
  708. (values
  709. (handle str-handler fragment
  710. (if end? "" (if preserve-ws? "\n" " "))
  711. seed)
  712. token)))
  713. ((and (not preserve-ws?) (eq? c #\newline))
  714. ;; paragraph-separator ::= #\newline #\newline+
  715. (skip-while '(#\newline) port)
  716. (skip-horizontal-whitespace port)
  717. (values (handle str-handler fragment "" seed)
  718. (make-token 'PARA 'para)))
  719. (else
  720. (loop (handle str-handler fragment
  721. (if preserve-ws? "\n" " ") seed)))))))))))))
  722. ; procedure+: assert-token TOKEN KIND NAME
  723. ; Make sure that TOKEN is of anticipated KIND and has anticipated NAME
  724. (define (assert-token token kind name)
  725. (or (and (token? token)
  726. (eq? kind (token-kind token))
  727. (equal? name (token-head token)))
  728. (parser-error #f "Expecting @end for " name ", got " token)))
  729. ;;========================================================================
  730. ;; Highest-level parsers: Texinfo to SXML
  731. ;; These parsers are a set of syntactic forms to instantiate a SSAX
  732. ;; parser. The user tells what to do with the parsed character and
  733. ;; element data. These latter handlers determine if the parsing follows a
  734. ;; SAX or a DOM model.
  735. ;; syntax: make-command-parser fdown fup str-handler
  736. ;; Create a parser to parse and process one element, including its
  737. ;; character content or children elements. The parser is typically
  738. ;; applied to the root element of a document.
  739. ;; fdown
  740. ;; procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED
  741. ;;
  742. ;; This procedure is to generate the seed to be passed to handlers
  743. ;; that process the content of the element. This is the function
  744. ;; identified as 'fdown' in the denotational semantics of the XML
  745. ;; parser given in the title comments to (sxml ssax).
  746. ;;
  747. ;; fup
  748. ;; procedure COMMAND ARGUMENTS PARENT-SEED SEED
  749. ;;
  750. ;; This procedure is called when parsing of COMMAND is finished.
  751. ;; The SEED is the result from the last content parser (or from
  752. ;; fdown if the element has the empty content). PARENT-SEED is the
  753. ;; same seed as was passed to fdown. The procedure is to generate a
  754. ;; seed that will be the result of the element parser. This is the
  755. ;; function identified as 'fup' in the denotational semantics of
  756. ;; the XML parser given in the title comments to (sxml ssax).
  757. ;;
  758. ;; str-handler
  759. ;; A STR-HANDLER, see read-verbatim-body
  760. ;;
  761. ;; The generated parser is a
  762. ;; procedure COMMAND PORT SEED
  763. ;;
  764. ;; The procedure must be called *after* the command token has been read.
  765. (define (read-include-file-name port)
  766. (let ((x (string-trim-both (read-eof-line port))))
  767. (if (string-null? x)
  768. (error "no file listed")
  769. x))) ;; fixme: should expand @value{} references
  770. (define (sxml->node-name sxml)
  771. "Turn some sxml string into a valid node name."
  772. (let loop ((in (string->list (sxml->string sxml))) (out '()))
  773. (if (null? in)
  774. (apply string (reverse out))
  775. (if (memq (car in) '(#\{ #\} #\@ #\,))
  776. (loop (cdr in) out)
  777. (loop (cdr in) (cons (car in) out))))))
  778. (define (index command arguments fdown fup parent-seed)
  779. (case command
  780. ((deftp defcv defivar deftypeivar defop deftypeop defmethod
  781. deftypemethod defopt defvr defvar deftypevr deftypevar deffn
  782. deftypefn defspec defmac defun deftypefun)
  783. (let ((args `((name ,(string-append (symbol->string command) "-"
  784. (cadr (assq 'name arguments)))))))
  785. (fup 'anchor args parent-seed
  786. (fdown 'anchor args 'INLINE-ARGS '()))))
  787. ((cindex findex vindex kindex pindex tindex)
  788. (let ((args `((name ,(string-append (symbol->string command) "-"
  789. (sxml->node-name
  790. (assq 'entry arguments)))))))
  791. (fup 'anchor args parent-seed
  792. (fdown 'anchor args 'INLINE-ARGS '()))))
  793. (else parent-seed)))
  794. (define (make-command-parser fdown fup str-handler)
  795. (lambda (command port seed)
  796. (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed))
  797. (let*-values (((command arguments expected-content)
  798. (complete-start-command command port)))
  799. (let* ((parent-seed (index command arguments fdown fup parent-seed))
  800. (seed (fdown command arguments expected-content parent-seed))
  801. (eof-closes? (or (memq command '(texinfo para *fragment*))
  802. (eq? expected-content 'EOL-TEXT)))
  803. (sig-ws? (or sig-ws? (space-significant? command)))
  804. (up (lambda (s) (fup command arguments parent-seed s)))
  805. (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s)))
  806. (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s)))))
  807. (define (port-for-content)
  808. (if (eq? expected-content 'EOL-TEXT)
  809. (call-with-input-string (read-text-line port) identity)
  810. port))
  811. (cond
  812. ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX
  813. EOL-TEXT-ARGS))
  814. ;; empty or finished by complete-start-command
  815. (up seed))
  816. ((eq? command 'verbatim)
  817. (up (read-verbatim-body port str-handler seed)))
  818. (else
  819. (let loop ((port (port-for-content))
  820. (expect-eof? eof-closes?)
  821. (end-para identity)
  822. (need-break? (and (not sig-ws?)
  823. (memq expected-content
  824. '(ENVIRON TABLE-ENVIRON
  825. ENTRY ITEM FRAGMENT))))
  826. (seed seed))
  827. (cond
  828. ((and need-break? (or sig-ws? (skip-whitespace port))
  829. (not (memq (peek-char port) '(#\@ #\})))
  830. (not (eof-object? (peek-char port))))
  831. ;; Even if we have an @, it might be inline -- check
  832. ;; that later
  833. (let ((seed (end-para seed)))
  834. (loop port expect-eof? (make-end-para seed) #f
  835. (new-para seed))))
  836. (else
  837. (let*-values (((seed token)
  838. (read-char-data
  839. port expect-eof? sig-ws? str-handler seed)))
  840. (cond
  841. ((eof-object? token)
  842. (case expect-eof?
  843. ((include #f) (end-para seed))
  844. (else (up (end-para seed)))))
  845. (else
  846. (case (token-kind token)
  847. ((STRING)
  848. ;; this is only @-commands that escape
  849. ;; characters: @}, @@, @{ -- new para if need-break
  850. (let ((seed ((if need-break? end-para identity) seed)))
  851. (loop port expect-eof?
  852. (if need-break? (make-end-para seed) end-para) #f
  853. (str-handler (token-head token) ""
  854. ((if need-break? new-para identity)
  855. seed)))))
  856. ((END)
  857. ;; The end will only have a name if it's for an
  858. ;; environment
  859. (cond
  860. ((memq command '(item entry))
  861. (let ((spec (command-spec (token-head token))))
  862. (or (eq? (cadr spec) 'TABLE-ENVIRON)
  863. (parser-error
  864. port "@item not ended by @end table/enumerate/itemize"
  865. token))))
  866. ((eq? expected-content 'ENVIRON)
  867. (assert-token token 'END command)))
  868. (up (end-para seed)))
  869. ((ITEM)
  870. (cond
  871. ((memq command '(enumerate itemize))
  872. (up (visit 'item port sig-ws? (end-para seed))))
  873. ((eq? expected-content 'TABLE-ENVIRON)
  874. (up (visit 'entry port sig-ws? (end-para seed))))
  875. ((memq command '(item entry))
  876. (visit command port sig-ws? (up (end-para seed))))
  877. (else
  878. (parser-error
  879. port "@item must be within a table environment"
  880. command))))
  881. ((PARA)
  882. ;; examine valid paragraphs?
  883. (loop port expect-eof? end-para (not sig-ws?) seed))
  884. ((INCLUDE)
  885. ;; Recurse for include files
  886. (let ((seed (call-with-file-and-dir
  887. (read-include-file-name port)
  888. (lambda (port)
  889. (loop port 'include end-para
  890. need-break? seed)))))
  891. (loop port expect-eof? end-para need-break? seed)))
  892. ((START) ; Start of an @-command
  893. (let* ((head (token-head token))
  894. (spec (command-spec head))
  895. (head (car spec))
  896. (type (cadr spec))
  897. (inline? (inline-content? type))
  898. (seed ((if (and inline? (not need-break?))
  899. identity end-para) seed))
  900. (end-para (if inline?
  901. (if need-break? (make-end-para seed)
  902. end-para)
  903. identity))
  904. (new-para (if (and inline? need-break?)
  905. new-para identity)))
  906. (loop port expect-eof? end-para (not inline?)
  907. (visit head port sig-ws? (new-para seed)))))
  908. (else
  909. (parser-error port "Unknown token type" token))))))))))))))))
  910. ;; procedure: reverse-collect-str-drop-ws fragments
  911. ;;
  912. ;; Given the list of fragments (some of which are text strings), reverse
  913. ;; the list and concatenate adjacent text strings. We also drop
  914. ;; "unsignificant" whitespace, that is, whitespace in front, behind and
  915. ;; between elements. The whitespace that is included in character data
  916. ;; is not affected.
  917. (define (reverse-collect-str-drop-ws fragments)
  918. (cond
  919. ((null? fragments) ; a shortcut
  920. '())
  921. ((and (string? (car fragments)) ; another shortcut
  922. (null? (cdr fragments)) ; remove single ws-only string
  923. (string-whitespace? (car fragments)))
  924. '())
  925. (else
  926. (let loop ((fragments fragments) (result '()) (strs '())
  927. (all-whitespace? #t))
  928. (cond
  929. ((null? fragments)
  930. (if all-whitespace?
  931. result ; remove leading ws
  932. (cons (apply string-append strs) result)))
  933. ((string? (car fragments))
  934. (loop (cdr fragments) result (cons (car fragments) strs)
  935. (and all-whitespace?
  936. (string-whitespace? (car fragments)))))
  937. (else
  938. (loop (cdr fragments)
  939. (cons
  940. (car fragments)
  941. (cond
  942. ((null? strs) result)
  943. (all-whitespace?
  944. (if (null? result)
  945. result ; remove trailing whitespace
  946. (cons " " result))); replace interstitial ws with
  947. ; one space
  948. (else
  949. (cons (apply string-append strs) result))))
  950. '() #t)))))))
  951. (define (parse-inline-text-args port spec text)
  952. (let lp ((in text) (cur '()) (out '()))
  953. (cond
  954. ((null? in)
  955. (if (and (pair? cur)
  956. (string? (car cur))
  957. (string-whitespace? (car cur)))
  958. (lp in (cdr cur) out)
  959. (let ((args (reverse (if (null? cur)
  960. out
  961. (cons (reverse cur) out)))))
  962. (arguments->attlist port args (cddr spec)))))
  963. ((pair? (car in))
  964. (lp (cdr in) (cons (car in) cur) out))
  965. ((string-index (car in) #\,)
  966. (let* ((parts (string-split (car in) #\,))
  967. (head (string-trim-right (car parts)))
  968. (rev-tail (reverse (cdr parts)))
  969. (last (string-trim (car rev-tail))))
  970. (lp (cdr in)
  971. (if (string-null? last) cur (cons last cur))
  972. (append (cdr rev-tail)
  973. (cons (reverse (if (string-null? head) cur (cons head cur)))
  974. out)))))
  975. (else
  976. (lp (cdr in)
  977. (cons (if (null? cur) (string-trim (car in)) (car in)) cur)
  978. out)))))
  979. (define (make-dom-parser)
  980. (make-command-parser
  981. (lambda (command args content seed) ; fdown
  982. '())
  983. (lambda (command args parent-seed seed) ; fup
  984. (let* ((seed (reverse-collect-str-drop-ws seed))
  985. (spec (command-spec command))
  986. (command (car spec)))
  987. (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
  988. (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
  989. parent-seed)
  990. (acons command
  991. (if (null? args) seed (acons '% args seed))
  992. parent-seed))))
  993. (lambda (string1 string2 seed) ; str-handler
  994. (if (string-null? string2)
  995. (cons string1 seed)
  996. (cons* string2 string1 seed)))))
  997. (define parse-environment-args
  998. (let ((parser (make-dom-parser)))
  999. ;; duplicate arguments->attlist to avoid unnecessary splitting
  1000. (lambda (command port)
  1001. (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
  1002. (spec (command-spec command))
  1003. (command (car spec))
  1004. (arg-names (cddr spec)))
  1005. (cond
  1006. ((not arg-names)
  1007. (if (null? args) '()
  1008. (parser-error port "@-command doesn't take args" command)))
  1009. ((eq? arg-names #t)
  1010. (list (cons 'arguments args)))
  1011. (else
  1012. (let loop ((args args) (arg-names arg-names) (out '()))
  1013. (cond
  1014. ((null? arg-names)
  1015. (if (null? args) (reverse! out)
  1016. (parser-error port "@-command didn't expect more args"
  1017. command args)))
  1018. ((symbol? arg-names)
  1019. (reverse! (acons arg-names args out)))
  1020. ((null? args)
  1021. (parser-error port "@-command expects more args"
  1022. command arg-names))
  1023. ((and (string? (car args)) (string-index (car args) #\space))
  1024. => (lambda (i)
  1025. (let ((rest (substring/shared (car args) (1+ i))))
  1026. (if (zero? i)
  1027. (loop (cons rest (cdr args)) arg-names out)
  1028. (loop (cons rest (cdr args)) (cdr arg-names)
  1029. (cons (list (car arg-names)
  1030. (substring (car args) 0 i))
  1031. out))))))
  1032. (else
  1033. (loop (cdr args) (cdr arg-names)
  1034. (if (and (pair? (car args)) (eq? (caar args) '*braces*))
  1035. (acons (car arg-names) (cdar args) out)
  1036. (cons (list (car arg-names) (car args)) out))))))))))))
  1037. (define (parse-eol-text-args command port)
  1038. ;; perhaps parse-environment-args should be named more
  1039. ;; generically.
  1040. (parse-environment-args command port))
  1041. ;; procedure: texi-fragment->stexi STRING
  1042. ;;
  1043. ;; A DOM parser for a texinfo fragment STRING.
  1044. ;;
  1045. ;; The procedure returns an SXML tree headed by the special tag,
  1046. ;; *fragment*.
  1047. (define (texi-fragment->stexi string-or-port)
  1048. "Parse the texinfo commands in @var{string-or-port}, and return the
  1049. resultant stexi tree. The head of the tree will be the special command,
  1050. @code{*fragment*}."
  1051. (define (parse port)
  1052. (postprocess (car ((make-dom-parser) '*fragment* port '()))))
  1053. (if (input-port? string-or-port)
  1054. (parse string-or-port)
  1055. (call-with-input-string string-or-port parse)))
  1056. ;; procedure: texi->stexi PORT
  1057. ;;
  1058. ;; This is an instance of a SSAX parser above that returns an SXML
  1059. ;; representation of the texinfo document ready to be read at PORT.
  1060. ;;
  1061. ;; The procedure returns an SXML tree. The port points to the
  1062. ;; first character after the @bye, or to the end of the file.
  1063. (define (texi->stexi port)
  1064. "Read a full texinfo document from @var{port} and return the parsed
  1065. stexi tree. The parsing will start at the @code{@@settitle} and end at
  1066. @code{@@bye} or EOF."
  1067. (let ((parser (make-dom-parser)))
  1068. (take-until-settitle port)
  1069. (postprocess (car (parser 'texinfo port '())))))
  1070. (define (car-eq? x y) (and (pair? x) (eq? (car x) y)))
  1071. (define (make-contents tree)
  1072. (define (lp in out depth)
  1073. (cond
  1074. ((null? in) (values in (cons 'enumerate (reverse! out))))
  1075. ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4))
  1076. => (lambda (new-depth)
  1077. (let ((node-name (and (car-eq? (car in) 'node)
  1078. (cadr (assq 'name (cdadar in))))))
  1079. (cond
  1080. ((< new-depth depth)
  1081. (values in (cons 'enumerate (reverse! out))))
  1082. ((> new-depth depth)
  1083. (let ((out-cdr (if (null? out) '() (cdr out)))
  1084. (out-car (if (null? out) (list 'item) (car out))))
  1085. (let*-values (((new-in new-out) (lp in '() (1+ depth))))
  1086. (lp new-in
  1087. (cons (append out-car (list new-out)) out-cdr)
  1088. depth))))
  1089. (else ;; same depth
  1090. (lp (cddr in)
  1091. (cons
  1092. `(item (para
  1093. ,@(if node-name
  1094. `((ref (% (node ,node-name))))
  1095. (cdadr in))))
  1096. out)
  1097. depth))))))
  1098. (else (lp (cdr in) out depth))))
  1099. (let*-values (((_ contents) (lp tree '() 1)))
  1100. `((chapheading "Table of Contents") ,contents)))
  1101. (define (trim-whitespace str trim-left? trim-right?)
  1102. (let* ((left-space? (and (not trim-left?)
  1103. (string-prefix? " " str)))
  1104. (right-space? (and (not trim-right?)
  1105. (string-suffix? " " str)))
  1106. (tail (append! (string-tokenize str)
  1107. (if right-space? '("") '()))))
  1108. (string-join (if left-space? (cons "" tail) tail))))
  1109. (define (postprocess tree)
  1110. (define (loop in out state first? sig-ws?)
  1111. (cond
  1112. ((null? in)
  1113. (values (reverse! out) state))
  1114. ((string? (car in))
  1115. (loop (cdr in)
  1116. (cons (if sig-ws? (car in)
  1117. (trim-whitespace (car in) first? (null? (cdr in))))
  1118. out)
  1119. state #f sig-ws?))
  1120. ((pair? (car in))
  1121. (case (caar in)
  1122. ((set)
  1123. (if (null? (cdar in)) (error "@set missing arguments" in))
  1124. (if (string? (cadar in))
  1125. (let ((i (string-index (cadar in) #\space)))
  1126. (if i
  1127. (loop (cdr in) out
  1128. (acons (substring (cadar in) 0 i)
  1129. (cons (substring (cadar in) (1+ i)) (cddar in))
  1130. state)
  1131. #f sig-ws?)
  1132. (loop (cdr in) out (acons (cadar in) (cddar in) state)
  1133. #f sig-ws?)))
  1134. (error "expected a constant to define for @set" in)))
  1135. ((value)
  1136. (loop (fold-right cons (cdr in)
  1137. (or (and=>
  1138. (assoc (cadr (assq 'key (cdadar in))) state) cdr)
  1139. (error "unknown value" (cdadar in) state)))
  1140. out
  1141. state #f sig-ws?))
  1142. ((copying)
  1143. (loop (cdr in) out (cons (car in) state) #f sig-ws?))
  1144. ((insertcopying)
  1145. (loop (fold-right cons (cdr in)
  1146. (or (cdr (assoc 'copying state))
  1147. (error "copying isn't set yet")))
  1148. out
  1149. state #f sig-ws?))
  1150. ((contents)
  1151. (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?))
  1152. (else
  1153. (let*-values (((kid-out state)
  1154. (loop (car in) '() state #t
  1155. (or sig-ws? (space-significant? (caar in))))))
  1156. (loop (cdr in) (cons kid-out out) state #f sig-ws?)))))
  1157. (else ; a symbol
  1158. (loop (cdr in) (cons (car in) out) state #t sig-ws?))))
  1159. (call-with-values
  1160. (lambda () (loop tree '() '() #t #f))
  1161. (lambda (out state) out)))
  1162. ;; Replace % with texinfo-arguments.
  1163. (define (stexi->sxml tree)
  1164. "Transform the stexi tree @var{tree} into sxml. This involves
  1165. replacing the @code{%} element that keeps the texinfo arguments with an
  1166. element for each argument.
  1167. FIXME: right now it just changes % to @code{texinfo-arguments} -- that
  1168. doesn't hang with the idea of making a dtd at some point"
  1169. (pre-post-order
  1170. tree
  1171. `((% . ,(lambda (x . t) (cons 'texinfo-arguments t)))
  1172. (*text* . ,(lambda (x t) t))
  1173. (*default* . ,(lambda (x . t) (cons x t))))))
  1174. ;;; arch-tag: 73890afa-597c-4264-ae70-46fe7756ffb5
  1175. ;;; texinfo.scm ends here