123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281 |
- ;;;; (texinfo html) -- translating stexinfo into shtml
- ;;;;
- ;;;; Copyright (C) 2009, 2010, 2011, 2020 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)
- (w span (@ (class "verbatim")))
- (bold b)
- (i i)
- (sample samp)
- (samp samp)
- (code code)
- (math em)
- (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")))
- (tie . ,(lambda args '(*ENTITY* "nbsp")))
- (dots . ,(lambda args '(*ENTITY* "hellip")))
- (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
|