summaryrefslogtreecommitdiff
path: root/module/texinfo/serialize.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/texinfo/serialize.scm')
-rw-r--r--module/texinfo/serialize.scm300
1 files changed, 300 insertions, 0 deletions
diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm
new file mode 100644
index 000000000..05d3facae
--- /dev/null
+++ b/module/texinfo/serialize.scm
@@ -0,0 +1,300 @@
+;;;; (texinfo serialize) -- rendering stexinfo as texinfo
+;;;;
+;;;; Copyright (C) 2009, 2012, 2013 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+;;
+;;Serialization of @code{stexi} to plain texinfo.
+;;
+;;; Code:
+
+(define-module (texinfo serialize)
+ #:use-module (texinfo)
+ #:use-module (texinfo string-utils)
+ #:use-module (sxml transform)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (stexi->texi))
+
+(define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+;; converts improper lists to proper lists.
+(define (filter* pred l)
+ (let lp ((in l) (out '()))
+ (cond ((null? in)
+ (reverse! out))
+ ((pair? in)
+ (lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
+ (else
+ (lp '() (if (pred in) (cons in out) out))))))
+
+;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
+(define (list* . args)
+ (let* ((args (reverse args))
+ (tail (car args)))
+ (let lp ((in (cdr args)) (out tail))
+ (cond ((null? in) out)
+ ((pair? (car in)) (lp (cdr in) (append (car in) out)))
+ ((null? (car in)) (lp (cdr in) out))
+ (else (lp (cdr in) (cons (car in) out)))))))
+
+;; Why? Well, because syntax-case defines `include', and carps about its
+;; wrong usage below...
+(eval-when (expand load eval)
+ (define (include exp lp command type formals rest? args accum)
+ (list* "\n"
+ (list-intersperse
+ args
+ " ")
+ " " command "@" accum)))
+
+(define (empty-command exp lp command type formals rest? args accum)
+ (list* " " command "@" accum))
+
+(define (inline-text exp lp command type formals rest? args accum)
+ (if (not (string=? command "*braces*")) ;; fixme :(
+ (list* "}"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "{" command "@" accum)
+ (list* "@}"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "@{" accum)))
+
+(define (inline-args exp lp command type formals rest? args accum)
+ (list* "}"
+ (if (not args) ""
+ (list-intersperse
+ (map
+ (lambda (x)
+ (cond ((not x) "")
+ ((pair? x)
+ (if (pair? (cdr x))
+ (warn "Strange inline-args!" args))
+ (car x))
+ (else (error "Invalid inline-args" args))))
+ (drop-while not
+ (map (lambda (x) (assq-ref args x))
+ (reverse formals))))
+ ","))
+ "{" command "@" accum))
+
+(define (inline-text-args exp lp command type formals rest? 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 (embrace x)
+ (define (needs-embrace? x)
+ (define (has-space? x)
+ (and (string? x)
+ (string-index x char-set:whitespace)))
+ (or (null? x) (or-map has-space? x)))
+ (if (needs-embrace? x)
+ (append '("}") x '("{"))
+ x))
+
+(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"
+ (serialize-text-args lp formals rest? args)
+ " " command "@" accum))
+
+(define (eol-text exp lp command type formals rest? args accum)
+ (list* "\n"
+ (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))
+ " " command "@" accum))
+
+(define (eol-args exp lp command type formals rest? args accum)
+ (list* "\n"
+ (list-intersperse
+ (apply append
+ (drop-while not
+ (map (lambda (x) (assq-ref args x))
+ (reverse formals))))
+ ", ")
+ " " command "@" accum))
+
+(define (environ exp lp command type formals rest? args accum)
+ (case (car exp)
+ ((texinfo)
+ (list* "@bye\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+ "\n@c %**end of header\n\n"
+ (reverse (assq-ref args 'title)) "@settitle "
+ (or (and=> (assq-ref args 'filename)
+ (lambda (filename)
+ (cons "\n" (reverse (cons "@setfilename " filename)))))
+ "")
+ "\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n"
+ accum))
+ (else
+ (list* "\n\n" command "@end "
+ (let ((body (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))))
+ (if (or (null? body)
+ (eqv? (string-ref (car body)
+ (1- (string-length (car body))))
+ #\newline))
+ body
+ (cons "\n" body)))
+ "\n"
+ (serialize-text-args lp formals rest? args)
+ " " command "@" accum))))
+
+(define (table-environ exp lp command type formals rest? args accum)
+ (list* "\n\n" command "@end "
+ (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))
+ "\n"
+ (let* ((arg (if args (cadar args) ""))) ;; zero or one args
+ (if (pair? arg)
+ (list (symbol->string (car arg)) "@")
+ arg))
+ " " command "@" accum))
+
+(define (wrap strings)
+ (fill-string (string-concatenate strings)
+ #:line-width 72
+ #:break-long-words? #f))
+
+(define (paragraph exp lp command type formals rest? args accum)
+ (list* "\n\n"
+ (wrap
+ (reverse
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
+ accum))
+
+(define (item exp lp command type formals rest? args accum)
+ (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "@item\n"
+ accum))
+
+(define (entry exp lp command type formals rest? args accum)
+ (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+ "\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
+ "@item "
+ accum))
+
+(define (fragment exp lp command type formals rest? args accum)
+ (list* "\n@c %end of fragment\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "\n@c %start of fragment\n\n"
+ accum))
+
+(define serializers
+ `((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)
+ (EOL-ARGS . ,eol-args)
+ (ENVIRON . ,environ)
+ (TABLE-ENVIRON . ,table-environ)
+ (ENTRY . ,entry)
+ (ITEM . ,item)
+ (PARAGRAPH . ,paragraph)
+ (FRAGMENT . ,fragment)
+ (#f . ,include))) ; support writing include statements
+
+(define (serialize exp lp command type formals rest? args accum)
+ ((or (assq-ref serializers type)
+ (error "Unknown command type" exp type))
+ exp lp command type formals rest? args accum))
+
+(define escaped-chars '(#\} #\{ #\@))
+(define (escape str)
+ "Escapes any illegal texinfo characters (currently @{, @}, and @@)."
+ (let loop ((in (string->list str)) (out '()))
+ (if (null? in)
+ (apply string (reverse out))
+ (if (memq (car in) escaped-chars)
+ (loop (cdr in) (cons* (car in) #\@ out))
+ (loop (cdr in) (cons (car in) out))))))
+
+(define (stexi->texi tree)
+ "Serialize the stexi @var{tree} into plain texinfo."
+ (string-concatenate-reverse
+ (let lp ((in tree) (out '()))
+ (cond
+ ((or (not in) (null? in)) out)
+ ((string? in) (cons (escape in) out))
+ ((pair? in)
+ (let ((command-spec (assq (car in) texi-command-specs)))
+ (if (not command-spec)
+ (begin
+ (warn "Unknown stexi command, not rendering" in)
+ out)
+ (serialize in
+ lp
+ (symbol->string (car in))
+ (cadr command-spec)
+ (filter* symbol? (cddr command-spec))
+ (not (list? (cddr command-spec)))
+ (cond
+ ((and (pair? (cdr in)) (pair? (cadr in))
+ (eq? (caadr in) '%))
+ (cdadr in))
+ ((not (cadr command-spec))
+ ;; include
+ (cdr in))
+ (else
+ #f))
+ out))))
+ (else
+ (error "Invalid stexi" in))))))
+
+;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5