mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Texinfo serialization: add braces when needed

Browse source 
* module/texinfo/serialize.scm (include, empty-command, inline-text):
  (inline-args, inline-text-args, eol-text-args, eol-text, eol-args)
  (environ, table-environ, paragraph, item, entry, fragment, serialize)
  (stexi->texi): Pass extra rest? parameter around to indicate arguments
  that can take any number of subforms without being surrounded by
  braces.
  (embrace, serialize-text-args): Surround non-rest arguments with
  braces.
* test-suite/tests/texinfo.serialize.test: Add tests.
This commit is contained in:
Andy Wingo 2016-10-11 22:08:03 +02:00
parent 67a0b7d3ff
commit 06e4091c9c
2 changed files with 58 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

79
module/texinfo/serialize.scm
View file

@ -28,6 +28,7 @@
#:use-module (texinfo) #:use-module (texinfo)
#:use-module (texinfo string-utils) #:use-module (texinfo string-utils)
#:use-module (sxml transform) #:use-module (sxml transform)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-13) #:use-module (srfi srfi-13)
#:export (stexi->texi)) #:export (stexi->texi))
@ -61,17 +62,17 @@
;; Why? Well, because syntax-case defines `include', and carps about its ;; Why? Well, because syntax-case defines `include', and carps about its
;; wrong usage below... ;; wrong usage below...
(eval-when (expand load eval) (eval-when (expand load eval)
(define (include exp lp command type formals args accum) (define (include exp lp command type formals rest? args accum)
(list* "\n" (list* "\n"
(list-intersperse (list-intersperse
args args
" ") " ")
" " command "@" accum))) " " command "@" accum)))
(define (empty-command exp lp command type formals args accum) (define (empty-command exp lp command type formals rest? args accum)
(list* " " command "@" accum)) (list* " " command "@" accum))
(define (inline-text exp lp command type formals args accum) (define (inline-text exp lp command type formals rest? args accum)
(if (not (string=? command "*braces*")) ;; fixme :( (if (not (string=? command "*braces*")) ;; fixme :(
(list* "}" (list* "}"
(append-map (lambda (x) (lp x '())) (reverse (cdr exp))) (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
@ -80,7 +81,7 @@
(append-map (lambda (x) (lp x '())) (reverse (cdr exp))) (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"@{" accum))) "@{" accum)))
(define (inline-args exp lp command type formals args accum) (define (inline-args exp lp command type formals rest? args accum)
(list* "}" (list* "}"
(if (not args) "" (if (not args) ""
(list-intersperse (list-intersperse
@ -98,7 +99,7 @@
",")) ","))
"{" command "@" accum)) "{" command "@" accum))
(define (inline-text-args exp lp command type formals args accum) (define (inline-text-args exp lp command type formals rest? args accum)
(list* "}" (list* "}"
(if (not args) "" (if (not args) ""
(apply (apply
@ -112,30 +113,49 @@
'(",")))) '(","))))
"{" command "@" accum)) "{" command "@" accum))
(define (serialize-text-args lp formals args) (define (embrace x)
(apply (define (needs-embrace? x)
append (define (has-space? x)
(list-intersperse (and (string? x)
(map (lambda (arg) (append-map (lambda (x) (lp x '())) arg)) (string-index x char-set:whitespace)))
(map (or (null? x) (or-map has-space? x)))
reverse (if (needs-embrace? x)
(drop-while (append '("}") x '("{"))
not (map (lambda (x) (assq-ref args x)) x))
(reverse formals)))))
'(" "))))
(define (eol-text-args exp lp command type formals args accum) (define (serialize-text-args lp formals rest? args)
(define (serialize-arg formal rest?)
(let ((val (assq-ref args formal)))
(if val
(let ((out (append-map (lambda (x) (lp x '()))
(reverse val))))
(if rest?
out
(embrace out)))
#f)))
(define (serialize-args rformals rest?)
(match rformals
(() '())
((formal . rformals)
(cons (serialize-arg formal rest?)
(serialize-args rformals #f)))))
(apply append
(list-intersperse
(filter identity (serialize-args (reverse formals) rest?))
'(" "))))
(define (eol-text-args exp lp command type formals rest? args accum)
(list* "\n" (list* "\n"
(serialize-text-args lp formals args) (serialize-text-args lp formals rest? args)
" " command "@" accum)) " " command "@" accum))
(define (eol-text exp lp command type formals args accum) (define (eol-text exp lp command type formals rest? args accum)
(list* "\n" (list* "\n"
(append-map (lambda (x) (lp x '())) (append-map (lambda (x) (lp x '()))
(reverse (if args (cddr exp) (cdr exp)))) (reverse (if args (cddr exp) (cdr exp))))
" " command "@" accum)) " " command "@" accum))
(define (eol-args exp lp command type formals args accum) (define (eol-args exp lp command type formals rest? args accum)
(list* "\n" (list* "\n"
(list-intersperse (list-intersperse
(apply append (apply append
@ -145,7 +165,7 @@
", ") ", ")
" " command "@" accum)) " " command "@" accum))
(define (environ exp lp command type formals args accum) (define (environ exp lp command type formals rest? args accum)
(case (car exp) (case (car exp)
((texinfo) ((texinfo)
(list* "@bye\n" (list* "@bye\n"
@ -169,10 +189,10 @@
body body
(cons "\n" body))) (cons "\n" body)))
"\n" "\n"
(serialize-text-args lp formals args) (serialize-text-args lp formals rest? args)
" " command "@" accum)))) " " command "@" accum))))
(define (table-environ exp lp command type formals args accum) (define (table-environ exp lp command type formals rest? args accum)
(list* "\n\n" command "@end " (list* "\n\n" command "@end "
(append-map (lambda (x) (lp x '())) (append-map (lambda (x) (lp x '()))
(reverse (if args (cddr exp) (cdr exp)))) (reverse (if args (cddr exp) (cdr exp))))
@ -188,26 +208,26 @@
#:line-width 72 #:line-width 72
#:break-long-words? #f)) #:break-long-words? #f))
(define (paragraph exp lp command type formals args accum) (define (paragraph exp lp command type formals rest? args accum)
(list* "\n\n" (list* "\n\n"
(wrap (wrap
(reverse (reverse
(append-map (lambda (x) (lp x '())) (reverse (cdr exp))))) (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
accum)) accum))
(define (item exp lp command type formals args accum) (define (item exp lp command type formals rest? args accum)
(list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"@item\n" "@item\n"
accum)) accum))
(define (entry exp lp command type formals args accum) (define (entry exp lp command type formals rest? args accum)
(list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
"\n" "\n"
(append-map (lambda (x) (lp x '())) (reverse (cdar args))) (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
"@item " "@item "
accum)) accum))
(define (fragment exp lp command type formals args accum) (define (fragment exp lp command type formals rest? args accum)
(list* "\n@c %end of fragment\n" (list* "\n@c %end of fragment\n"
(append-map (lambda (x) (lp x '())) (reverse (cdr exp))) (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
"\n@c %start of fragment\n\n" "\n@c %start of fragment\n\n"
@ -230,10 +250,10 @@
(FRAGMENT . ,fragment) (FRAGMENT . ,fragment)
(#f . ,include))) ; support writing include statements (#f . ,include))) ; support writing include statements
(define (serialize exp lp command type formals args accum) (define (serialize exp lp command type formals rest? args accum)
((or (assq-ref serializers type) ((or (assq-ref serializers type)
(error "Unknown command type" exp type)) (error "Unknown command type" exp type))
exp lp command type formals args accum)) exp lp command type formals rest? args accum))
(define escaped-chars '(#\} #\{ #\@)) (define escaped-chars '(#\} #\{ #\@))
(define (escape str) (define (escape str)
@ -263,6 +283,7 @@
(symbol->string (car in)) (symbol->string (car in))
(cadr command-spec) (cadr command-spec)
(filter* symbol? (cddr command-spec)) (filter* symbol? (cddr command-spec))
(not (list? (cddr command-spec)))
(cond (cond
((and (pair? (cdr in)) (pair? (cadr in)) ((and (pair? (cdr in)) (pair? (cadr in))
(eq? (caadr in) '%)) (eq? (caadr in) '%))

9
test-suite/tests/texinfo.serialize.test
View file

@ -28,7 +28,7 @@
(with-test-prefix "test-serialize" (with-test-prefix "test-serialize"
(define (assert-serialize stexi str) (define (assert-serialize stexi str)
(pass-if str (equal? str (stexi->texi stexi)))) (pass-if-equal stexi str (stexi->texi stexi)))
(assert-serialize '(para) (assert-serialize '(para)
" "
@ -182,4 +182,11 @@ foo
"@deffnx bar foo (x @code{int}) "@deffnx bar foo (x @code{int})
") ")
(assert-serialize '(deffnx (% (name "foo") (category "bar baz") (arguments "(" "x" " " (code "int") ")")))
"@deffnx {bar baz} foo (x @code{int})
")
(assert-serialize '(deffnx (% (name "foo") (category (code "bar") " baz") (arguments "(" "x" " " (code "int") ")")))
"@deffnx {@code{bar} baz} foo (x @code{int})
")
) )