;;;; (texinfo) -- parsing of texinfo into SXML
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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>
;;;;
#: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
(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
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
@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.
+@code{INLINE-TEXT-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
@end table"
'(;; Special commands
(include #f) ;; this is a low-level token
(sample INLINE-TEXT)
(samp INLINE-TEXT)
(code INLINE-TEXT)
+ (math INLINE-TEXT)
(kbd INLINE-TEXT)
(key INLINE-TEXT)
(var 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-ARGS . (node #:opt name section info-file manual))
+ (pxref INLINE-TEXT-ARGS
+ . (node #:opt name section info-file manual))
(url ALIAS . uref)
- (uref INLINE-ARGS . (url #:opt title replacement))
+ (uref INLINE-TEXT-ARGS . (url #:opt title replacement))
(anchor INLINE-ARGS . (name))
(dots INLINE-ARGS . ())
(result INLINE-ARGS . ())
(tie INLINE-ARGS . ())
(image INLINE-ARGS . (file #:opt width height alt-text extension))
+ ;; Inline parsed args commands
+ (acronym INLINE-TEXT-ARGS . (acronym #:opt meaning))
+
;; EOL args elements
(node EOL-ARGS . (name #:opt next previous up))
(c EOL-ARGS . all)
;; Like a DTD for texinfo
(define (command-spec command)
- (or (assq command texi-command-specs)
- (parser-error #f "Unknown command" 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)
- (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS)))
+ (case content
+ ((INLINE-TEXT INLINE-ARGS INLINE-TEXT-ARGS) #t)
+ (else #f)))
;;========================================================================
(assert-curr-char '(#\@) "start of the command" port)
(let ((peeked (peek-char port)))
(cond
- ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\}))
+ ((memq peeked '(#\! #\: #\. #\? #\@ #\\ #\{ #\}))
;; @-commands that escape characters
(make-token 'STRING (string (read-char port))))
(else
;; Content model Port position
;; ============= =============
;; INLINE-TEXT One character after the #\{.
+;; INLINE-TEXT-ARGS 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
(car names))))
(else
(loop (cdr in) (cdr names) opt?
- (cons (list (car names) (car in)) out))))))
+ (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)))
(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
- ((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))
+ ((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)
(let* ((token (read-command-token port))
(end? (eq? (token-kind token) 'END)))
(values
- (handle str-handler fragment (if end? "" " ") seed)
+ (handle str-handler fragment
+ (if end? "" (if preserve-ws? "\n" " "))
+ seed)
token)))
((and (not preserve-ws?) (eq? c #\newline))
;; paragraph-separator ::= #\newline #\newline+
(loop port expect-eof? end-para need-break? seed)))
((START) ; Start of an @-command
(let* ((head (token-head token))
- (type (cadr (command-spec head)))
+ (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))
(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) ; 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)))
+ (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) ; str-handler
(if (string-null? string2)
(cons string1 seed)
(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))))
+ (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) '()
HCoop / bpt / guile.git / blobdiff