serialize.scm 9.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279
  1. ;;;; (texinfo serialize) -- rendering stexinfo as texinfo
  2. ;;;;
  3. ;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc.
  4. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
  5. ;;;;
  6. ;;;; This library is free software; you can redistribute it and/or
  7. ;;;; modify it under the terms of the GNU Lesser General Public
  8. ;;;; License as published by the Free Software Foundation; either
  9. ;;;; version 3 of the License, or (at your option) any later version.
  10. ;;;;
  11. ;;;; This library is distributed in the hope that it will be useful,
  12. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;;; Lesser General Public License for more details.
  15. ;;;;
  16. ;;;; You should have received a copy of the GNU Lesser General Public
  17. ;;;; License along with this library; if not, write to the Free Software
  18. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19. ;;;;
  20. ;;; Commentary:
  21. ;;
  22. ;;Serialization of @code{stexi} to plain texinfo.
  23. ;;
  24. ;;; Code:
  25. (define-module (texinfo serialize)
  26. #:use-module (texinfo)
  27. #:use-module (texinfo string-utils)
  28. #:use-module (sxml transform)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-13)
  31. #:export (stexi->texi))
  32. (define (list-intersperse src-l elem)
  33. (if (null? src-l) src-l
  34. (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
  35. (if (null? l) (reverse dest)
  36. (loop (cdr l) (cons (car l) (cons elem dest)))))))
  37. ;; converts improper lists to proper lists.
  38. (define (filter* pred l)
  39. (let lp ((in l) (out '()))
  40. (cond ((null? in)
  41. (reverse! out))
  42. ((pair? in)
  43. (lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
  44. (else
  45. (lp '() (if (pred in) (cons in out) out))))))
  46. ;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
  47. (define (list* . args)
  48. (let* ((args (reverse args))
  49. (tail (car args)))
  50. (let lp ((in (cdr args)) (out tail))
  51. (cond ((null? in) out)
  52. ((pair? (car in)) (lp (cdr in) (append (car in) out)))
  53. ((null? (car in)) (lp (cdr in) out))
  54. (else (lp (cdr in) (cons (car in) out)))))))
  55. ;; Why? Well, because syntax-case defines `include', and carps about its
  56. ;; wrong usage below...
  57. (eval-when (eval load compile)
  58. (define (include exp lp command type formals args accum)
  59. (list* "\n"
  60. (list-intersperse
  61. args
  62. " ")
  63. " " command "@" accum)))
  64. (define (empty-command exp lp command type formals args accum)
  65. (list* " " command "@" accum))
  66. (define (inline-text exp lp command type formals args accum)
  67. (if (not (string=? command "*braces*")) ;; fixme :(
  68. (list* "}"
  69. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  70. "{" command "@" accum)
  71. (list* "@}"
  72. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  73. "@{" accum)))
  74. (define (inline-args exp lp command type formals args accum)
  75. (list* "}"
  76. (if (not args) ""
  77. (list-intersperse
  78. (map
  79. (lambda (x)
  80. (cond ((not x) "")
  81. ((pair? x)
  82. (if (pair? (cdr x))
  83. (warn "Strange inline-args!" args))
  84. (car x))
  85. (else (error "Invalid inline-args" args))))
  86. (drop-while not
  87. (map (lambda (x) (assq-ref args x))
  88. (reverse formals))))
  89. ","))
  90. "{" command "@" accum))
  91. (define (inline-text-args exp lp command type formals args accum)
  92. (list* "}"
  93. (if (not args) ""
  94. (apply
  95. append
  96. (list-intersperse
  97. (map
  98. (lambda (x) (append-map (lambda (x) (lp x '())) (reverse x)))
  99. (drop-while not
  100. (map (lambda (x) (assq-ref args x))
  101. (reverse formals))))
  102. '(","))))
  103. "{" command "@" accum))
  104. (define (serialize-text-args lp formals args)
  105. (apply
  106. append
  107. (list-intersperse
  108. (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg))
  109. (map
  110. reverse
  111. (drop-while
  112. not (map (lambda (x) (assq-ref args x))
  113. (reverse formals)))))
  114. '(" "))))
  115. (define (eol-text-args exp lp command type formals args accum)
  116. (list* "\n"
  117. (serialize-text-args lp formals args)
  118. " " command "@" accum))
  119. (define (eol-text exp lp command type formals args accum)
  120. (list* "\n"
  121. (append-map (lambda (x) (lp x '()))
  122. (reverse (if args (cddr exp) (cdr exp))))
  123. " " command "@" accum))
  124. (define (eol-args exp lp command type formals args accum)
  125. (list* "\n"
  126. (list-intersperse
  127. (apply append
  128. (drop-while not
  129. (map (lambda (x) (assq-ref args x))
  130. (reverse formals))))
  131. ", ")
  132. " " command "@" accum))
  133. (define (environ exp lp command type formals args accum)
  134. (case (car exp)
  135. ((texinfo)
  136. (list* "@bye\n"
  137. (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
  138. "\n@c %**end of header\n\n"
  139. (reverse (assq-ref args 'title)) "@settitle "
  140. (or (and=> (assq-ref args 'filename)
  141. (lambda (filename)
  142. (cons "\n" (reverse (cons "@setfilename " filename)))))
  143. "")
  144. "\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n"
  145. accum))
  146. (else
  147. (list* "\n\n" command "@end "
  148. (let ((body (append-map (lambda (x) (lp x '()))
  149. (reverse (if args (cddr exp) (cdr exp))))))
  150. (if (or (null? body)
  151. (eqv? (string-ref (car body)
  152. (1- (string-length (car body))))
  153. #\newline))
  154. body
  155. (cons "\n" body)))
  156. "\n"
  157. (serialize-text-args lp formals args)
  158. " " command "@" accum))))
  159. (define (table-environ exp lp command type formals args accum)
  160. (list* "\n\n" command "@end "
  161. (append-map (lambda (x) (lp x '()))
  162. (reverse (if args (cddr exp) (cdr exp))))
  163. "\n"
  164. (let* ((arg (if args (cadar args) ""))) ;; zero or one args
  165. (if (pair? arg)
  166. (list (symbol->string (car arg)) "@")
  167. arg))
  168. " " command "@" accum))
  169. (define (wrap strings)
  170. (fill-string (string-concatenate strings)
  171. #:line-width 72))
  172. (define (paragraph exp lp command type formals args accum)
  173. (list* "\n\n"
  174. (wrap
  175. (reverse
  176. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
  177. accum))
  178. (define (item exp lp command type formals args accum)
  179. (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  180. "@item\n"
  181. accum))
  182. (define (entry exp lp command type formals args accum)
  183. (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
  184. "\n"
  185. (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
  186. "@item "
  187. accum))
  188. (define (fragment exp lp command type formals args accum)
  189. (list* "\n@c %end of fragment\n"
  190. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  191. "\n@c %start of fragment\n\n"
  192. accum))
  193. (define serializers
  194. `((EMPTY-COMMAND . ,empty-command)
  195. (INLINE-TEXT . ,inline-text)
  196. (INLINE-ARGS . ,inline-args)
  197. (INLINE-TEXT-ARGS . ,inline-text-args)
  198. (EOL-TEXT . ,eol-text)
  199. (EOL-TEXT-ARGS . ,eol-text-args)
  200. (INDEX . ,eol-text-args)
  201. (EOL-ARGS . ,eol-args)
  202. (ENVIRON . ,environ)
  203. (TABLE-ENVIRON . ,table-environ)
  204. (ENTRY . ,entry)
  205. (ITEM . ,item)
  206. (PARAGRAPH . ,paragraph)
  207. (FRAGMENT . ,fragment)
  208. (#f . ,include))) ; support writing include statements
  209. (define (serialize exp lp command type formals args accum)
  210. ((or (assq-ref serializers type)
  211. (error "Unknown command type" exp type))
  212. exp lp command type formals args accum))
  213. (define escaped-chars '(#\} #\{ #\@))
  214. (define (escape str)
  215. "Escapes any illegal texinfo characters (currently @{, @}, and @@)."
  216. (let loop ((in (string->list str)) (out '()))
  217. (if (null? in)
  218. (apply string (reverse out))
  219. (if (memq (car in) escaped-chars)
  220. (loop (cdr in) (cons* (car in) #\@ out))
  221. (loop (cdr in) (cons (car in) out))))))
  222. (define (stexi->texi tree)
  223. "Serialize the stexi @var{tree} into plain texinfo."
  224. (string-concatenate-reverse
  225. (let lp ((in tree) (out '()))
  226. (cond
  227. ((or (not in) (null? in)) out)
  228. ((string? in) (cons (escape in) out))
  229. ((pair? in)
  230. (let ((command-spec (assq (car in) texi-command-specs)))
  231. (if (not command-spec)
  232. (begin
  233. (warn "Unknown stexi command, not rendering" in)
  234. out)
  235. (serialize in
  236. lp
  237. (symbol->string (car in))
  238. (cadr command-spec)
  239. (filter* symbol? (cddr command-spec))
  240. (cond
  241. ((and (pair? (cdr in)) (pair? (cadr in))
  242. (eq? (caadr in) '%))
  243. (cdadr in))
  244. ((not (cadr command-spec))
  245. ;; include
  246. (cdr in))
  247. (else
  248. #f))
  249. out))))
  250. (else
  251. (error "Invalid stexi" in))))))
  252. ;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5