summaryrefslogtreecommitdiff
path: root/module/texinfo/html.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/texinfo/html.scm')
-rw-r--r--module/texinfo/html.scm275
1 files changed, 275 insertions, 0 deletions
diff --git a/module/texinfo/html.scm b/module/texinfo/html.scm
new file mode 100644
index 000000000..6a07cffce
--- /dev/null
+++ b/module/texinfo/html.scm
@@ -0,0 +1,275 @@
+;;;; (texinfo html) -- translating stexinfo into shtml
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011 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:
+;;
+;;This module implements transformation from @code{stexi} to HTML. Note
+;;that the output of @code{stexi->shtml} is actually SXML with the HTML
+;;vocabulary. This means that the output can be further processed, and
+;;that it must eventually be serialized by
+;;@ref{sxml simple sxml->xml,sxml->xml}.
+;;
+;;References (i.e., the @code{@@ref} family of commands) are resolved by
+;;a @dfn{ref-resolver}.
+;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
+;;information.
+;;
+;;; Code:
+
+;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove
+;; margin-top on dd > p)
+
+(define-module (texinfo html)
+ #:use-module (texinfo)
+ #:use-module (sxml transform)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-13)
+ #:export (stexi->shtml add-ref-resolver! urlify))
+
+;; The caller is responsible for carring the returned list.
+(define (arg-ref key %-args)
+ (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
+(define (arg-req key %-args)
+ (or (arg-ref key %-args)
+ (error "Missing argument:" key %-args)))
+(define (car* x) (and x (car x)))
+
+(define (urlify str)
+ (string-downcase
+ (string-map
+ (lambda (c)
+ (case c
+ ((#\space #\/ #\:) #\-)
+ (else c)))
+ str)))
+
+(define ref-resolvers
+ (list
+ (lambda (node-name manual-name) ;; the default
+ (urlify (string-append (or manual-name "") "#" node-name)))))
+
+(define (add-ref-resolver! proc)
+ "Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
+will be expected to take the name of a node and the name of a manual and
+return the URL of the referent, or @code{#f} to pass control to the next
+ref-resolver in the list.
+
+The default ref-resolver will return the concatenation of the manual
+name, @code{#}, and the node name."
+ (set! ref-resolvers (cons proc ref-resolvers)))
+
+(define (resolve-ref node manual)
+ (or (or-map (lambda (x) (x node manual)) ref-resolvers)
+ (error "Could not resolve reference" node manual)))
+
+(define (ref tag args)
+ (let* ((node (car (arg-req 'node args)))
+ (section (or (car* (arg-ref 'section args)) node))
+ (manual (car* (arg-ref 'manual args)))
+ (target (resolve-ref node manual)))
+ `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
+ (a (@ (href ,target)) ,section))))
+
+(define (uref tag args)
+ (let ((url (car (arg-req 'url args))))
+ `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
+
+;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
+;; empty string here to placate the reptile.
+(define (node tag args)
+ `(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
+
+(define (def tag args . body)
+ (define (code x) (and x (cons 'code x)))
+ (define (var x) (and x (cons 'var x)))
+ (define (b x) (and x (cons 'b x)))
+ (define (list/spaces . elts)
+ (let lp ((in elts) (out '()))
+ (cond ((null? in) (reverse! out))
+ ((null? (car in)) (lp (cdr in) out))
+ (else (lp (cdr in)
+ (cons (car in)
+ (if (null? out) out (cons " " out))))))))
+ (define (left-td-contents)
+ (list/spaces (code (arg-ref 'data-type args))
+ (b (list (code (arg-ref 'class args)))) ;; is this right?
+ (b (list (code (arg-ref 'name args))))
+ (if (memq tag '(deftypeop deftypefn deftypefun))
+ (code (arg-ref 'arguments args))
+ (var (list (code (arg-ref 'arguments args)))))))
+
+ (let* ((category (case tag
+ ((defun) "Function")
+ ((defspec) "Special Form")
+ ((defvar) "Variable")
+ (else (car (arg-req 'category args))))))
+ `(div
+ (table
+ (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
+ (tr (td ,@(left-td-contents))
+ (td (div (@ (class "right")) "[" ,category "]"))))
+ (div (@ (class "description")) ,@body))))
+
+(define (enumerate tag . elts)
+ (define (tonumber start)
+ (let ((c (string-ref start 0)))
+ (cond ((number? c) (string->number start))
+ (else (1+ (- (char->integer c)
+ (char->integer (if (char-upper-case? c) #\A #\a))))))))
+ `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
+ (cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
+ ;; (type ,(type (arg-ref 'start (car elts)))))
+ (cdr elts))
+ elts)))
+
+(define (itemize tag . elts)
+ `(ul ,@(match elts
+ ;; Strip `bullet' attribute.
+ ((('% . attrs) . elts) elts)
+ (elts elts))))
+
+(define (acronym tag . elts)
+ (match elts
+ ;; FIXME: Need attribute matcher that doesn't depend on attribute
+ ;; order.
+ ((('% ('acronym text) . _)) `(acronym ,text))))
+
+(define (table tag args . body)
+ (let ((formatter (caar (arg-req 'formatter args))))
+ (cons 'dl
+ (map (lambda (x)
+ (cond ((and (pair? x) (eq? (car x) 'dt))
+ (list (car x) (cons formatter (cdr x))))
+ (else x)))
+ (apply append body)))))
+
+(define (entry tag args . body)
+ (let lp ((out `((dt ,@(arg-req 'heading args))))
+ (body body))
+ (if (and (pair? body) (pair? (car body)) (eq? (caar body) 'itemx))
+ (lp (append out `(dt ,@(map stexi->shtml (cdar body))))
+ (cdr body))
+ (append out `((dd ,@(map stexi->shtml body)))))))
+
+(define tag-replacements
+ '((titlepage div (@ (class "titlepage")))
+ (title h2 (@ (class "title")))
+ (subtitle h3 (@ (class "subtitle")))
+ (author h3 (@ (class "author")))
+ (example pre)
+ (lisp pre)
+ (smallexample pre (@ (class "smaller")))
+ (smalllisp pre (@ (class "smaller")))
+ (cartouche div (@ (class "cartouche")))
+ (verbatim pre (@ (class "verbatim")))
+ (chapter h2)
+ (section h3)
+ (subsection h4)
+ (subsubsection h5)
+ (appendix h2)
+ (appendixsec h3)
+ (appendixsubsec h4)
+ (appendixsubsubsec h5)
+ (unnumbered h2)
+ (unnumberedsec h3)
+ (unnumberedsubsec h4)
+ (unnumberedsubsubsec h5)
+ (majorheading h2)
+ (chapheading h2)
+ (heading h3)
+ (subheading h4)
+ (subsubheading h5)
+ (quotation blockquote)
+ (item li) ;; itemx ?
+ (para p)
+ (*fragment* div) ;; should be ok
+
+ (asis span)
+ (bold b)
+ (sample samp)
+ (samp samp)
+ (code code)
+ (kbd kbd)
+ (key code (@ (class "key")))
+ (var var)
+ (env code (@ (class "env")))
+ (file code (@ (class "file")))
+ (command code (@ (class "command")))
+ (option code (@ (class "option")))
+ (url code (@ (class "url")))
+ (dfn dfn)
+ (cite cite)
+ (acro acronym)
+ (email code (@ (class "email")))
+ (emph em)
+ (strong strong)
+ (sc span (@ (class "small-caps")))))
+
+(define ignore-list
+ '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
+ menu ignore syncodeindex comment c dircategory direntry top shortcontents
+ cindex printindex))
+
+(define rules
+ `((% *preorder* . ,(lambda args args)) ;; Keep these around...
+ (texinfo . ,(lambda (tag args . body)
+ (pre-post-order
+ `(html
+ (@ (xmlns "http://www.w3.org/1999/xhtml"))
+ (head (title ,(car (arg-req 'title args))))
+ (body ,@body))
+ `((% *preorder* . ,(lambda args #f)) ;; ... filter out.
+ (*text* . ,(lambda (tag x) x))
+ (*default* . ,(lambda (tag . body)
+ (cons tag body)))))))
+ (copyright . ,(lambda args '(*ENTITY* "copy")))
+ (result . ,(lambda args '(*ENTITY* "rArr")))
+ (xref . ,ref) (ref . ,ref) (pxref . ,ref)
+ (uref . ,uref)
+ (node . ,node) (anchor . ,node)
+ (table . ,table)
+ (enumerate . ,enumerate)
+ (itemize . ,itemize)
+ (acronym . ,acronym)
+ (entry *preorder* . ,entry)
+
+ (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
+ (defop . ,def) (deftypeop . ,def) (defmethod . ,def)
+ (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
+ (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def)
+ (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
+ (deftypefun . ,def)
+ (ifnottex . ,(lambda (tag . body) body))
+ (*text* . ,(lambda (tag x) x))
+ (*default* . ,(lambda (tag . body)
+ (let ((subst (assq tag tag-replacements)))
+ (cond
+ (subst (append (cdr subst) body))
+ ((memq tag ignore-list) #f)
+ (else
+ (warn "Don't know how to convert" tag "to HTML")
+ body)))))))
+
+(define (stexi->shtml tree)
+ "Transform the stexi @var{tree} into shtml, resolving references via
+ref-resolvers. See the module commentary for more details."
+ (pre-post-order tree rules))
+
+;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6