diff options
-rw-r--r-- | module/texinfo.scm | 62 | ||||
-rw-r--r-- | module/texinfo/serialize.scm | 17 | ||||
-rw-r--r-- | test-suite/tests/texinfo.test | 20 |
3 files changed, 87 insertions, 12 deletions
diff --git a/module/texinfo.scm b/module/texinfo.scm index 8798eb3c1..2ffd85393 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -1,6 +1,6 @@ ;;;; (texinfo) -- parsing of texinfo into SXML ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 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> ;;;; @@ -128,6 +128,8 @@ Parsed arguments until end of line 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 @@ -169,7 +171,7 @@ entry. @item args Named arguments to the command, in the same format as the formals for a lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, -@code{ENVIRON}, @code{TABLE-ENVIRON} commands. +@code{INLINE-TEXT-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands. @end table" '(;; Special commands (include #f) ;; this is a low-level token @@ -224,6 +226,9 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-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) @@ -383,7 +388,9 @@ Examples: (parser-error #f "Unknown command" command))) (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))) ;;======================================================================== @@ -572,6 +579,7 @@ Examples: ;; 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 @@ -599,7 +607,9 @@ Examples: (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))) @@ -648,6 +658,9 @@ Examples: ((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) @@ -998,15 +1011,48 @@ Examples: (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))) + (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) diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm index 6a32d2346..1436ad5f9 100644 --- a/module/texinfo/serialize.scm +++ b/module/texinfo/serialize.scm @@ -1,6 +1,6 @@ ;;;; (texinfo serialize) -- rendering stexinfo as texinfo ;;;; -;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -98,6 +98,20 @@ ",")) "{" command "@" accum)) +(define (inline-text-args exp lp command type formals args accum) + (list* "}" + (if (not args) "" + (apply + append + (list-intersperse + (map + (lambda (x) (append-map (lambda (x) (lp x '())) (reverse x))) + (drop-while not + (map (lambda (x) (assq-ref args x)) + (reverse formals)))) + '(",")))) + "{" command "@" accum)) + (define (serialize-text-args lp formals args) (apply append @@ -202,6 +216,7 @@ `((EMPTY-COMMAND . ,empty-command) (INLINE-TEXT . ,inline-text) (INLINE-ARGS . ,inline-args) + (INLINE-TEXT-ARGS . ,inline-text-args) (EOL-TEXT . ,eol-text) (EOL-TEXT-ARGS . ,eol-text-args) (INDEX . ,eol-text-args) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 49d108698..98c44b91b 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -1,6 +1,6 @@ ;;;; texinfo.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -177,8 +177,9 @@ (test (string-append "foo bar baz\n@settitle " title "\n" str) expected-res)) (define (test-body str expected-res) - (pass-if (equal? expected-res - (cddr (try-with-title "zog" str))))) + (pass-if str + (equal? expected-res + (cddr (try-with-title "zog" str))))) (define (list-intersperse src-l elem) (if (null? src-l) src-l @@ -218,6 +219,19 @@ '((para (code "abc " (code))))) (test-body "@code{ arg }" '((para (code "arg")))) + + (test-body "@acronym{GNU}" + '((para (acronym (% (acronym "GNU")))))) + + (test-body "@acronym{GNU, not unix}" + '((para (acronym (% (acronym "GNU") + (meaning "not unix")))))) + + (test-body "@acronym{GNU, @acronym{GNU}'s Not Unix}" + '((para (acronym (% (acronym "GNU") + (meaning (acronym (% (acronym "GNU"))) + "'s Not Unix")))))) + (test-body "@example\n foo asdf asd sadf asd \n@end example\n" '((example " foo asdf asd sadf asd "))) (test-body (join-lines |