serialize.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301
  1. ;;;; (texinfo serialize) -- rendering stexinfo as texinfo
  2. ;;;;
  3. ;;;; Copyright (C) 2009, 2012, 2013 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 (ice-9 match)
  30. #:use-module (srfi srfi-1)
  31. #:use-module (srfi srfi-13)
  32. #:export (stexi->texi))
  33. (define (list-intersperse src-l elem)
  34. (if (null? src-l) src-l
  35. (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
  36. (if (null? l) (reverse dest)
  37. (loop (cdr l) (cons (car l) (cons elem dest)))))))
  38. ;; converts improper lists to proper lists.
  39. (define (filter* pred l)
  40. (let lp ((in l) (out '()))
  41. (cond ((null? in)
  42. (reverse! out))
  43. ((pair? in)
  44. (lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
  45. (else
  46. (lp '() (if (pred in) (cons in out) out))))))
  47. ;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
  48. (define (list* . args)
  49. (let* ((args (reverse args))
  50. (tail (car args)))
  51. (let lp ((in (cdr args)) (out tail))
  52. (cond ((null? in) out)
  53. ((pair? (car in)) (lp (cdr in) (append (car in) out)))
  54. ((null? (car in)) (lp (cdr in) out))
  55. (else (lp (cdr in) (cons (car in) out)))))))
  56. ;; Why? Well, because syntax-case defines `include', and carps about its
  57. ;; wrong usage below...
  58. (eval-when (expand load eval)
  59. (define (include exp lp command type formals rest? args accum)
  60. (list* "\n"
  61. (list-intersperse
  62. args
  63. " ")
  64. " " command "@" accum)))
  65. (define (empty-command exp lp command type formals rest? args accum)
  66. (list* " " command "@" accum))
  67. (define (inline-text exp lp command type formals rest? args accum)
  68. (if (not (string=? command "*braces*")) ;; fixme :(
  69. (list* "}"
  70. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  71. "{" command "@" accum)
  72. (list* "@}"
  73. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  74. "@{" accum)))
  75. (define (inline-args exp lp command type formals rest? args accum)
  76. (list* "}"
  77. (if (not args) ""
  78. (list-intersperse
  79. (map
  80. (lambda (x)
  81. (cond ((not x) "")
  82. ((pair? x)
  83. (if (pair? (cdr x))
  84. (warn "Strange inline-args!" args))
  85. (car x))
  86. (else (error "Invalid inline-args" args))))
  87. (drop-while not
  88. (map (lambda (x) (assq-ref args x))
  89. (reverse formals))))
  90. ","))
  91. "{" command "@" accum))
  92. (define (inline-text-args exp lp command type formals rest? args accum)
  93. (list* "}"
  94. (if (not args) ""
  95. (apply
  96. append
  97. (list-intersperse
  98. (map
  99. (lambda (x) (append-map (lambda (x) (lp x '())) (reverse x)))
  100. (drop-while not
  101. (map (lambda (x) (assq-ref args x))
  102. (reverse formals))))
  103. '(","))))
  104. "{" command "@" accum))
  105. (define (embrace x)
  106. (define (needs-embrace? x)
  107. (define (has-space? x)
  108. (and (string? x)
  109. (string-index x char-set:whitespace)))
  110. (or (null? x) (or-map has-space? x)))
  111. (if (needs-embrace? x)
  112. (append '("}") x '("{"))
  113. x))
  114. (define (serialize-text-args lp formals rest? args)
  115. (define (serialize-arg formal rest?)
  116. (let ((val (assq-ref args formal)))
  117. (if val
  118. (let ((out (append-map (lambda (x) (lp x '()))
  119. (reverse val))))
  120. (if rest?
  121. out
  122. (embrace out)))
  123. #f)))
  124. (define (serialize-args rformals rest?)
  125. (match rformals
  126. (() '())
  127. ((formal . rformals)
  128. (cons (serialize-arg formal rest?)
  129. (serialize-args rformals #f)))))
  130. (apply append
  131. (list-intersperse
  132. (filter identity (serialize-args (reverse formals) rest?))
  133. '(" "))))
  134. (define (eol-text-args exp lp command type formals rest? args accum)
  135. (list* "\n"
  136. (serialize-text-args lp formals rest? args)
  137. " " command "@" accum))
  138. (define (eol-text exp lp command type formals rest? args accum)
  139. (list* "\n"
  140. (append-map (lambda (x) (lp x '()))
  141. (reverse (if args (cddr exp) (cdr exp))))
  142. " " command "@" accum))
  143. (define (eol-args exp lp command type formals rest? args accum)
  144. (list* "\n"
  145. (list-intersperse
  146. (apply append
  147. (drop-while not
  148. (map (lambda (x) (assq-ref args x))
  149. (reverse formals))))
  150. ", ")
  151. " " command "@" accum))
  152. (define (environ exp lp command type formals rest? args accum)
  153. (case (car exp)
  154. ((texinfo)
  155. (list* "@bye\n"
  156. (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
  157. "\n@c %**end of header\n\n"
  158. (reverse (assq-ref args 'title)) "@settitle "
  159. (or (and=> (assq-ref args 'filename)
  160. (lambda (filename)
  161. (cons "\n" (reverse (cons "@setfilename " filename)))))
  162. "")
  163. "\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n"
  164. accum))
  165. (else
  166. (list* "\n\n" command "@end "
  167. (let ((body (append-map (lambda (x) (lp x '()))
  168. (reverse (if args (cddr exp) (cdr exp))))))
  169. (if (or (null? body)
  170. (eqv? (string-ref (car body)
  171. (1- (string-length (car body))))
  172. #\newline))
  173. body
  174. (cons "\n" body)))
  175. "\n"
  176. (serialize-text-args lp formals rest? args)
  177. " " command "@" accum))))
  178. (define (table-environ exp lp command type formals rest? args accum)
  179. (list* "\n\n" command "@end "
  180. (append-map (lambda (x) (lp x '()))
  181. (reverse (if args (cddr exp) (cdr exp))))
  182. "\n"
  183. (let* ((arg (if args (cadar args) ""))) ;; zero or one args
  184. (if (pair? arg)
  185. (list (symbol->string (car arg)) "@")
  186. arg))
  187. " " command "@" accum))
  188. (define (wrap strings)
  189. (fill-string (string-concatenate strings)
  190. #:line-width 72
  191. #:break-long-words? #f))
  192. (define (paragraph exp lp command type formals rest? args accum)
  193. (list* "\n\n"
  194. (wrap
  195. (reverse
  196. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
  197. accum))
  198. (define (item exp lp command type formals rest? args accum)
  199. (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  200. "@item\n"
  201. accum))
  202. (define (entry exp lp command type formals rest? args accum)
  203. (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
  204. "\n"
  205. (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
  206. "@item "
  207. accum))
  208. (define (fragment exp lp command type formals rest? args accum)
  209. (list* "\n@c %end of fragment\n"
  210. (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
  211. "\n@c %start of fragment\n\n"
  212. accum))
  213. (define serializers
  214. `((EMPTY-COMMAND . ,empty-command)
  215. (INLINE-TEXT . ,inline-text)
  216. (INLINE-ARGS . ,inline-args)
  217. (INLINE-TEXT-ARGS . ,inline-text-args)
  218. (EOL-TEXT . ,eol-text)
  219. (EOL-TEXT-ARGS . ,eol-text-args)
  220. (INDEX . ,eol-text-args)
  221. (EOL-ARGS . ,eol-args)
  222. (ENVIRON . ,environ)
  223. (TABLE-ENVIRON . ,table-environ)
  224. (ENTRY . ,entry)
  225. (ITEM . ,item)
  226. (PARAGRAPH . ,paragraph)
  227. (FRAGMENT . ,fragment)
  228. (#f . ,include))) ; support writing include statements
  229. (define (serialize exp lp command type formals rest? args accum)
  230. ((or (assq-ref serializers type)
  231. (error "Unknown command type" exp type))
  232. exp lp command type formals rest? args accum))
  233. (define escaped-chars '(#\} #\{ #\@))
  234. (define (escape str)
  235. "Escapes any illegal texinfo characters (currently @{, @}, and @@)."
  236. (let loop ((in (string->list str)) (out '()))
  237. (if (null? in)
  238. (apply string (reverse out))
  239. (if (memq (car in) escaped-chars)
  240. (loop (cdr in) (cons* (car in) #\@ out))
  241. (loop (cdr in) (cons (car in) out))))))
  242. (define (stexi->texi tree)
  243. "Serialize the stexi @var{tree} into plain texinfo."
  244. (string-concatenate-reverse
  245. (let lp ((in tree) (out '()))
  246. (cond
  247. ((or (not in) (null? in)) out)
  248. ((string? in) (cons (escape in) out))
  249. ((pair? in)
  250. (let ((command-spec (assq (car in) texi-command-specs)))
  251. (if (not command-spec)
  252. (begin
  253. (warn "Unknown stexi command, not rendering" in)
  254. out)
  255. (serialize in
  256. lp
  257. (symbol->string (car in))
  258. (cadr command-spec)
  259. (filter* symbol? (cddr command-spec))
  260. (not (list? (cddr command-spec)))
  261. (cond
  262. ((and (pair? (cdr in)) (pair? (cadr in))
  263. (eq? (caadr in) '%))
  264. (cdadr in))
  265. ((not (cadr command-spec))
  266. ;; include
  267. (cdr in))
  268. (else
  269. #f))
  270. out))))
  271. (else
  272. (error "Invalid stexi" in))))))
  273. ;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5