| 1 | ;;;; (texinfo html) -- translating stexinfo into shtml |
| 2 | ;;;; |
| 3 | ;;;; Copyright (C) 2009, 2010 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 | \f |
| 21 | ;;; Commentary: |
| 22 | ;; |
| 23 | ;;This module implements transformation from @code{stexi} to HTML. Note |
| 24 | ;;that the output of @code{stexi->shtml} is actually SXML with the HTML |
| 25 | ;;vocabulary. This means that the output can be further processed, and |
| 26 | ;;that it must eventually be serialized by |
| 27 | ;;@ref{sxml simple sxml->xml,sxml->xml}. |
| 28 | ;; |
| 29 | ;;References (i.e., the @code{@@ref} family of commands) are resolved by |
| 30 | ;;a @dfn{ref-resolver}. |
| 31 | ;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more |
| 32 | ;;information. |
| 33 | ;; |
| 34 | ;;; Code: |
| 35 | |
| 36 | ;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove |
| 37 | ;; margin-top on dd > p) |
| 38 | |
| 39 | (define-module (texinfo html) |
| 40 | :use-module (texinfo) |
| 41 | :use-module (sxml transform) |
| 42 | :use-module (srfi srfi-13) |
| 43 | :export (stexi->shtml add-ref-resolver! urlify)) |
| 44 | |
| 45 | ;; The caller is responsible for carring the returned list. |
| 46 | (define (arg-ref key %-args) |
| 47 | (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x))))) |
| 48 | (define (arg-req key %-args) |
| 49 | (or (arg-ref key %-args) |
| 50 | (error "Missing argument:" key %-args))) |
| 51 | (define (car* x) (and x (car x))) |
| 52 | |
| 53 | (define (urlify str) |
| 54 | (string-downcase |
| 55 | (string-map |
| 56 | (lambda (c) |
| 57 | (case c |
| 58 | ((#\space #\/ #\:) #\-) |
| 59 | (else c))) |
| 60 | str))) |
| 61 | |
| 62 | (define ref-resolvers |
| 63 | (list |
| 64 | (lambda (node-name manual-name) ;; the default |
| 65 | (urlify (string-append (or manual-name "") "#" node-name))))) |
| 66 | |
| 67 | (define (add-ref-resolver! proc) |
| 68 | "Add @var{proc} to the head of the list of ref-resolvers. @var{proc} |
| 69 | will be expected to take the name of a node and the name of a manual and |
| 70 | return the URL of the referent, or @code{#f} to pass control to the next |
| 71 | ref-resolver in the list. |
| 72 | |
| 73 | The default ref-resolver will return the concatenation of the manual |
| 74 | name, @code{#}, and the node name." |
| 75 | (set! ref-resolvers (cons proc ref-resolvers))) |
| 76 | |
| 77 | (define (resolve-ref node manual) |
| 78 | (or (or-map (lambda (x) (x node manual)) ref-resolvers) |
| 79 | (error "Could not resolve reference" node manual))) |
| 80 | |
| 81 | (define (ref tag args) |
| 82 | (let* ((node (car (arg-req 'node args))) |
| 83 | (section (or (car* (arg-ref 'section args)) node)) |
| 84 | (manual (car* (arg-ref 'manual args))) |
| 85 | (target (resolve-ref node manual))) |
| 86 | `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr) |
| 87 | (a (@ (href ,target)) ,section)))) |
| 88 | |
| 89 | (define (uref tag args) |
| 90 | (let ((url (car (arg-req 'url args)))) |
| 91 | `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url)))) |
| 92 | |
| 93 | ;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an |
| 94 | ;; empty string here to placate the reptile. |
| 95 | (define (node tag args) |
| 96 | `(a (@ (name ,(urlify (car (arg-req 'name args))))) "")) |
| 97 | |
| 98 | (define (def tag args . body) |
| 99 | (define (code x) (and x (cons 'code x))) |
| 100 | (define (var x) (and x (cons 'var x))) |
| 101 | (define (b x) (and x (cons 'b x))) |
| 102 | (define (list/spaces . elts) |
| 103 | (let lp ((in elts) (out '())) |
| 104 | (cond ((null? in) (reverse! out)) |
| 105 | ((null? (car in)) (lp (cdr in) out)) |
| 106 | (else (lp (cdr in) |
| 107 | (cons (car in) |
| 108 | (if (null? out) out (cons " " out)))))))) |
| 109 | (define (left-td-contents) |
| 110 | (list/spaces (code (arg-ref 'data-type args)) |
| 111 | (b (list (code (arg-ref 'class args)))) ;; is this right? |
| 112 | (b (list (code (arg-ref 'name args)))) |
| 113 | (if (memq tag '(deftypeop deftypefn deftypefun)) |
| 114 | (code (arg-ref 'arguments args)) |
| 115 | (var (list (code (arg-ref 'arguments args))))))) |
| 116 | |
| 117 | (let* ((category (case tag |
| 118 | ((defun) "Function") |
| 119 | ((defspec) "Special Form") |
| 120 | ((defvar) "Variable") |
| 121 | (else (car (arg-req 'category args)))))) |
| 122 | `(div |
| 123 | (table |
| 124 | (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def")) |
| 125 | (tr (td ,@(left-td-contents)) |
| 126 | (td (div (@ (class "right")) "[" ,category "]")))) |
| 127 | (div (@ (class "description")) ,@body)))) |
| 128 | |
| 129 | (define (enumerate tag . elts) |
| 130 | (define (tonumber start) |
| 131 | (let ((c (string-ref start 0))) |
| 132 | (cond ((number? c) (string->number start)) |
| 133 | (else (1+ (- (char->integer c) |
| 134 | (char->integer (if (char-upper-case? c) #\A #\a)))))))) |
| 135 | `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%)) |
| 136 | (cons `(@ (start ,@(tonumber (arg-req 'start (car elts))))) |
| 137 | ;; (type ,(type (arg-ref 'start (car elts))))) |
| 138 | (cdr elts)) |
| 139 | elts))) |
| 140 | |
| 141 | (define (table tag args . body) |
| 142 | (let ((formatter (caar (arg-req 'formatter args)))) |
| 143 | (cons 'dl |
| 144 | (map (lambda (x) |
| 145 | (cond ((and (pair? x) (eq? (car x) 'dt)) |
| 146 | (list (car x) (cons formatter (cdr x)))) |
| 147 | (else x))) |
| 148 | (apply append body))))) |
| 149 | |
| 150 | (define (entry tag args . body) |
| 151 | `((dt ,@(arg-req 'heading args)) |
| 152 | (dd ,@body))) |
| 153 | |
| 154 | (define tag-replacements |
| 155 | '((titlepage div (@ (class "titlepage"))) |
| 156 | (title h2 (@ (class "title"))) |
| 157 | (subtitle h3 (@ (class "subtitle"))) |
| 158 | (author h3 (@ (class "author"))) |
| 159 | (example pre) |
| 160 | (lisp pre) |
| 161 | (smallexample pre (@ (class "smaller"))) |
| 162 | (smalllisp pre (@ (class "smaller"))) |
| 163 | (cartouche div (@ (class "cartouche"))) |
| 164 | (verbatim pre (@ (class "verbatim"))) |
| 165 | (chapter h2) |
| 166 | (section h3) |
| 167 | (subsection h4) |
| 168 | (subsubsection h5) |
| 169 | (appendix h2) |
| 170 | (appendixsec h3) |
| 171 | (appendixsubsec h4) |
| 172 | (appendixsubsubsec h5) |
| 173 | (unnumbered h2) |
| 174 | (unnumberedsec h3) |
| 175 | (unnumberedsubsec h4) |
| 176 | (unnumberedsubsubsec h5) |
| 177 | (majorheading h2) |
| 178 | (chapheading h2) |
| 179 | (heading h3) |
| 180 | (subheading h4) |
| 181 | (subsubheading h5) |
| 182 | (quotation blockquote) |
| 183 | (itemize ul) |
| 184 | (item li) ;; itemx ? |
| 185 | (para p) |
| 186 | (*fragment* div) ;; should be ok |
| 187 | |
| 188 | (asis span) |
| 189 | (bold b) |
| 190 | (sample samp) |
| 191 | (samp samp) |
| 192 | (code code) |
| 193 | (kbd kbd) |
| 194 | (key code (@ (class "key"))) |
| 195 | (var var) |
| 196 | (env code (@ (class "env"))) |
| 197 | (file code (@ (class "file"))) |
| 198 | (command code (@ (class "command"))) |
| 199 | (option code (@ (class "option"))) |
| 200 | (url code (@ (class "url"))) |
| 201 | (dfn dfn) |
| 202 | (cite cite) |
| 203 | (acro acronym) |
| 204 | (email code (@ (class "email"))) |
| 205 | (emph em) |
| 206 | (strong strong) |
| 207 | (sc span (@ (class "small-caps"))))) |
| 208 | |
| 209 | (define ignore-list |
| 210 | '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip |
| 211 | menu ignore syncodeindex comment c dircategory direntry top shortcontents |
| 212 | cindex printindex)) |
| 213 | |
| 214 | (define rules |
| 215 | `((% *preorder* . ,(lambda args args)) ;; Keep these around... |
| 216 | (texinfo . ,(lambda (tag args . body) |
| 217 | (pre-post-order |
| 218 | `(html |
| 219 | (@ (xmlns "http://www.w3.org/1999/xhtml")) |
| 220 | (head (title ,(car (arg-req 'title args)))) |
| 221 | (body ,@body)) |
| 222 | `((% *preorder* . ,(lambda args #f)) ;; ... filter out. |
| 223 | (*text* . ,(lambda (tag x) x)) |
| 224 | (*default* . ,(lambda (tag . body) |
| 225 | (cons tag body))))))) |
| 226 | (copyright . ,(lambda args '(*ENTITY* "copy"))) |
| 227 | (result . ,(lambda args '(*ENTITY* "rArr"))) |
| 228 | (xref . ,ref) (ref . ,ref) (pxref . ,ref) |
| 229 | (uref . ,uref) |
| 230 | (node . ,node) (anchor . ,node) |
| 231 | (table . ,table) |
| 232 | (enumerate . ,enumerate) |
| 233 | (entry . ,entry) |
| 234 | |
| 235 | (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def) |
| 236 | (defop . ,def) (deftypeop . ,def) (defmethod . ,def) |
| 237 | (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def) |
| 238 | (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def) |
| 239 | (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def) |
| 240 | (deftypefun . ,def) |
| 241 | (ifnottex . ,(lambda (tag . body) body)) |
| 242 | (*text* . ,(lambda (tag x) x)) |
| 243 | (*default* . ,(lambda (tag . body) |
| 244 | (let ((subst (assq tag tag-replacements))) |
| 245 | (cond |
| 246 | (subst (append (cdr subst) body)) |
| 247 | ((memq tag ignore-list) #f) |
| 248 | (else |
| 249 | (warn "Don't know how to convert" tag "to HTML") |
| 250 | body))))))) |
| 251 | |
| 252 | (define (stexi->shtml tree) |
| 253 | "Transform the stexi @var{tree} into shtml, resolving references via |
| 254 | ref-resolvers. See the module commentary for more details." |
| 255 | (pre-post-order tree rules)) |
| 256 | |
| 257 | ;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6 |