[bpt/guile.git] / module / texinfo / html.scm

;;;; (texinfo html) -- translating stexinfo into shtml
;;;;
;;;; 	Copyright (C) 2009, 2010  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
;;;; 
\f
;;; 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 (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 (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)
  `((dt ,@(arg-req 'heading args))
    (dd ,@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)
    (itemize      ul)
    (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)
    (entry . ,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
Commit	Line	Data
47f3ce52 AW	1	;;;; (texinfo html) -- translating stexinfo into shtml
47f3ce52 AW	2	;;;;
6734191c	3	;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
47f3ce52 AW	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))
47f3ce52 AW	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