From efea4dc93f2565555e47de0bfd027614a9c8674d Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Fri, 1 Jul 2005 23:55:56 +0000 Subject: Lots of changes, again. Lots of changes, notably the following: * skr/*.skr: Moved engines to `src/guile/skribilo/engine'. * src/guile/skribilo/engine.scm (lookup-engine): Rewritten. Don't use the auto-load alist. * src/guile/skribilo/evaluator.scm: New name of the `eval' module. `eval' couldn't be used as the module base-name because of Guile's recursive module name space. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-2 --- skr/base.skr | 464 ------ skr/context.skr | 1380 ----------------- skr/html.skr | 2271 --------------------------- skr/html4.skr | 165 -- skr/latex-simple.skr | 101 -- skr/latex.skr | 1780 ---------------------- skr/xml.skr | 111 -- src/guile/README | 42 + src/guile/skribilo.scm | 177 ++- src/guile/skribilo/biblio.scm | 2 +- src/guile/skribilo/config.scm.in | 1 - src/guile/skribilo/debug.scm | 3 +- src/guile/skribilo/engine.scm | 50 +- src/guile/skribilo/engine/base.scm | 466 ++++++ src/guile/skribilo/engine/context.scm | 1382 +++++++++++++++++ src/guile/skribilo/engine/html.scm | 2282 ++++++++++++++++++++++++++++ src/guile/skribilo/engine/html4.scm | 167 ++ src/guile/skribilo/engine/latex-simple.scm | 103 ++ src/guile/skribilo/engine/latex.scm | 1780 ++++++++++++++++++++++ src/guile/skribilo/engine/xml.scm | 113 ++ src/guile/skribilo/eval.scm | 186 --- src/guile/skribilo/evaluator.scm | 207 +++ src/guile/skribilo/lib.scm | 75 +- src/guile/skribilo/module.scm | 83 +- src/guile/skribilo/output.scm | 22 +- src/guile/skribilo/reader.scm | 6 +- src/guile/skribilo/resolve.scm | 8 +- src/guile/skribilo/runtime.scm | 11 +- src/guile/skribilo/source.scm | 4 +- src/guile/skribilo/writer.scm | 95 +- 30 files changed, 6845 insertions(+), 6692 deletions(-) delete mode 100644 skr/base.skr delete mode 100644 skr/context.skr delete mode 100644 skr/html.skr delete mode 100644 skr/html4.skr delete mode 100644 skr/latex-simple.skr delete mode 100644 skr/latex.skr delete mode 100644 skr/xml.skr create mode 100644 src/guile/README create mode 100644 src/guile/skribilo/engine/base.scm create mode 100644 src/guile/skribilo/engine/context.scm create mode 100644 src/guile/skribilo/engine/html.scm create mode 100644 src/guile/skribilo/engine/html4.scm create mode 100644 src/guile/skribilo/engine/latex-simple.scm create mode 100644 src/guile/skribilo/engine/latex.scm create mode 100644 src/guile/skribilo/engine/xml.scm delete mode 100644 src/guile/skribilo/eval.scm create mode 100644 src/guile/skribilo/evaluator.scm diff --git a/skr/base.skr b/skr/base.skr deleted file mode 100644 index ec987ec..0000000 --- a/skr/base.skr +++ /dev/null @@ -1,464 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/base.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:39:30 2003 */ -;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* BASE Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* base-engine ... */ -;*---------------------------------------------------------------------*/ -(define base-engine - (default-engine-set! - (make-engine 'base - :version 'plain - :symbol-table '(("iexcl" "!") - ("cent" "c") - ("lguillemet" "\"") - ("not" "!") - ("registered" "(r)") - ("degree" "o") - ("plusminus" "+/-") - ("micro" "o") - ("paragraph" "p") - ("middot" ".") - ("rguillemet" "\"") - ("iquestion" "?") - ("Agrave" "À") - ("Aacute" "A") - ("Acircumflex" "Â") - ("Atilde" "A") - ("Amul" "A") - ("Aring" "A") - ("AEligature" "AE") - ("Oeligature" "OE") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "E") - ("Igrave" "I") - ("Iacute" "I") - ("Icircumflex" "Î") - ("Iuml" "I") - ("ETH" "D") - ("Ntilde" "N") - ("Ograve" "O") - ("Oacute" "O") - ("Ocurcumflex" "O") - ("Otilde" "O") - ("Ouml" "O") - ("times" "x") - ("Oslash" "O") - ("Ugrave" "Ù") - ("Uacute" "U") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Y") - ("agrave" "à") - ("aacute" "a") - ("acircumflex" "â") - ("atilde" "a") - ("amul" "a") - ("aring" "a") - ("aeligature" "æ") - ("oeligature" "oe") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "e") - ("igrave" "i") - ("iacute" "i") - ("icircumflex" "î") - ("iuml" "i") - ("ntilde" "n") - ("ograve" "o") - ("oacute" "o") - ("ocurcumflex" "o") - ("otilde" "o") - ("ouml" "o") - ("divide" "/") - ("oslash" "o") - ("ugrave" "ù") - ("uacute" "u") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "y") - ("ymul" "y") - ;; punctuation - ("bullet" ".") - ("ellipsis" "...") - ("<-" "<-") - ("<--" "<--") - ("uparrow" "^;") - ("->" "->") - ("-->" "-->") - ("downarrow" "v") - ("<->" "<->") - ("<-->" "<-->") - ("<+" "<+") - ("<=" "<=;") - ("<==" "<==") - ("Uparrow" "^") - ("=>" "=>") - ("==>" "==>") - ("Downarrow" "v") - ("<=>" "<=>") - ("<==>" "<==>") - ;; Mathematical operators - ("asterisk" "*") - ("angle" "<") - ("and" "^;") - ("or" "v") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "~") - ("mid" "|") - ("langle" "<") - ("rangle" ">") - ;; LaTeX - ("circ" "o") - ("top" "T") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'symbol - :action (lambda (n e) - (let* ((s (markup-body n)) - (c (assoc s (engine-symbol-table e)))) - (if (pair? c) - (display (cadr c)) - (output s e))))) - -;*---------------------------------------------------------------------*/ -;* unref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'unref - :options 'all - :action (lambda (n e) - (let* ((s (markup-option n :skribe)) - (k (markup-option n 'kind)) - (f (cond - (s - (format "?~a@~a " k s)) - (else - (format "?~a " k)))) - (msg (list f (markup-body n))) - (n (list "[" (color :fg "red" (bold msg)) "]"))) - (skribe-eval n e)))) - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-before w) n e)))) - :action (lambda (n e) - (when (pair? (markup-body n)) - (for-each (lambda (i) (output i e)) (markup-body n)))) - :after (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-after w) n e))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :before (lambda (n e) - (invoke (writer-before (markup-writer-get 'tr e)) n e)) - :action (lambda (n e) - (let ((wtc (markup-writer-get 'tc e))) - ;; the label - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'right) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (invoke (writer-after wtc) n e) - ;; the body - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'left) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-body)) - (invoke (writer-after wtc) n e))) - :after (lambda (n e) - (invoke (writer-after (markup-writer-get 'tr e)) n e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "[" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-body - :action (lambda (n e) - (define (output-fields descr) - (let loop ((descr descr) - (pending #f) - (armed #f)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author " -- " (or title url documenturl) " -- " - number ", " institution ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((article) - `(author " -- " (or title url documenturl) " -- " - journal ", " volume "" ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author " -- " (or title url documenturl) " -- " - booktitle ", " series ", " ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((book) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")) - ((phdthesis) - '(author " -- " (or title url documenturl) " -- " type ", " - school ", " address - ", " month ", " year".")) - ((misc) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year".")) - (else - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-ident ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-ident - :action (lambda (n e) - (output (markup-option n 'number) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-publisher ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-publisher - :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &the-index ... @label the-index@ */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index - :options '(:column) - :before (lambda (n e) - (output (markup-option n 'header) e)) - :action (lambda (n e) - (define (make-mark-entry n fst) - (let ((l (tr :class 'index-mark-entry - (td :colspan 2 :align 'left - (bold (it (sf n))))))) - (if fst - (list l) - (list (tr (td :colspan 2)) l)))) - (define (make-primary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (c (if note - (list b - (it (list " (" note ")"))) - b))) - (when p - (markup-option-add! b :text - (list (markup-option b :text) - ", p.")) - (markup-option-add! b :page #t)) - (tr :class 'index-primary-entry - (td :colspan 2 :valign 'top :align 'left c)))) - (define (make-secondary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (cond - ((not (or bb (is-markup? b 'url-ref))) - (skribe-error 'the-index - "Illegal entry" - b)) - (note - (let ((r (if bb - (it (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p - (list note ", p.") - note))) - (it (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p - (list note ", p.") - note)))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1. " ...") - (td :valign 'top :align 'left r)))) - (else - (let ((r (if bb - (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p " ..., p." " ...")) - (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p " ..., p." " ..."))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1.) - (td :valign 'top :align 'left r))))))) - (define (make-column ie p) - (let loop ((ie ie) - (f #t)) - (cond - ((null? ie) - '()) - ((not (pair? (car ie))) - (append (make-mark-entry (car ie) f) - (loop (cdr ie) #f))) - (else - (cons (make-primary-entry (caar ie) p) - (append (map (lambda (x) - (make-secondary-entry x p)) - (cdar ie)) - (loop (cdr ie) #f))))))) - (define (make-sub-tables ie nc p) - (let* ((l (length ie)) - (w (/ 100. nc)) - (iepc (let ((d (/ l nc))) - (if (integer? d) - (inexact->exact d) - (+ 1 (inexact->exact (truncate d)))))) - (split (list-split ie iepc))) - (tr (map (lambda (ies) - (td :valign 'top :width w - (if (pair? ies) - (table :width 100. (make-column ies p)) - ""))) - split)))) - (let* ((ie (markup-body n)) - (nc (markup-option n :column)) - (loc (ast-loc n)) - (pref (eq? (engine-custom e 'index-page-ref) #t)) - (t (cond - ((null? ie) - "") - ((or (not (integer? nc)) (= nc 1)) - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-column ie pref))) - (else - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-sub-tables ie nc pref)))))) - (output (skribe-eval t e) e)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;* ------------------------------------------------------------- */ -;* The index header is only useful for targets that support */ -;* hyperlinks such as HTML. */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) #f)) - -;*---------------------------------------------------------------------*/ -;* &prog-line ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&prog-line - :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (n (markup-ident (handle-body (markup-body n))))) - (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) - - - -;;;; A VIRER (mais handle-body n'est pas défini) -(markup-writer 'line-ref - :options '(:offset) - :action #f) diff --git a/skr/context.skr b/skr/context.skr deleted file mode 100644 index 5bc5316..0000000 --- a/skr/context.skr +++ /dev/null @@ -1,1380 +0,0 @@ -;;;; -;;;; context.skr -- ConTeXt mode for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 23-Sep-2004 17:21 (eg) -;;;; Last file update: 3-Nov-2004 12:54 (eg) -;;;; - -;;;; ====================================================================== -;;;; context-customs ... -;;;; ====================================================================== -(define context-customs - '((source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - (index-page-ref #t) - (image-format ("jpg")) - (font-size 11) - (font-type "roman") - (user-style #f) - (document-style "book"))) - -;;;; ====================================================================== -;;;; context-encoding ... -;;;; ====================================================================== -(define context-encoding - '((#\# "\\type{#}") - (#\| "\\type{|}") - (#\{ "$\\{$") - (#\} "$\\}$") - (#\~ "\\type{~}") - (#\& "\\type{&}") - (#\_ "\\type{_}") - (#\^ "\\type{^}") - (#\[ "\\type{[}") - (#\] "\\type{]}") - (#\< "\\type{<}") - (#\> "\\type{>}") - (#\$ "\\type{$}") - (#\% "\\%") - (#\\ "$\\backslash$"))) - -;;;; ====================================================================== -;;;; context-pre-encoding ... -;;;; ====================================================================== -(define context-pre-encoding - (append '((#\space "~") - (#\~ "\\type{~}")) - context-encoding)) - - -;;;; ====================================================================== -;;;; context-symbol-table ... -;;;; ====================================================================== -(define (context-symbol-table math) - `(("iexcl" "!`") - ("cent" "c") - ("pound" "\\pounds") - ("yen" "Y") - ("section" "\\S") - ("mul" ,(math "^-")) - ("copyright" "\\copyright") - ("lguillemet" ,(math "\\ll")) - ("not" ,(math "\\neg")) - ("degree" ,(math "^{\\small{o}}")) - ("plusminus" ,(math "\\pm")) - ("micro" ,(math "\\mu")) - ("paragraph" "\\P") - ("middot" ,(math "\\cdot")) - ("rguillemet" ,(math "\\gg")) - ("1/4" ,(math "\\frac{1}{4}")) - ("1/2" ,(math "\\frac{1}{2}")) - ("3/4" ,(math "\\frac{3}{4}")) - ("iquestion" "?`") - ("Agrave" "\\`{A}") - ("Aacute" "\\'{A}") - ("Acircumflex" "\\^{A}") - ("Atilde" "\\~{A}") - ("Amul" "\\\"{A}") - ("Aring" "{\\AA}") - ("AEligature" "{\\AE}") - ("Oeligature" "{\\OE}") - ("Ccedilla" "{\\c{C}}") - ("Egrave" "{\\`{E}}") - ("Eacute" "{\\'{E}}") - ("Ecircumflex" "{\\^{E}}") - ("Euml" "\\\"{E}") - ("Igrave" "{\\`{I}}") - ("Iacute" "{\\'{I}}") - ("Icircumflex" "{\\^{I}}") - ("Iuml" "\\\"{I}") - ("ETH" "D") - ("Ntilde" "\\~{N}") - ("Ograve" "\\`{O}") - ("Oacute" "\\'{O}") - ("Ocurcumflex" "\\^{O}") - ("Otilde" "\\~{O}") - ("Ouml" "\\\"{O}") - ("times" ,(math "\\times")) - ("Oslash" "\\O") - ("Ugrave" "\\`{U}") - ("Uacute" "\\'{U}") - ("Ucircumflex" "\\^{U}") - ("Uuml" "\\\"{U}") - ("Yacute" "\\'{Y}") - ("szlig" "\\ss") - ("agrave" "\\`{a}") - ("aacute" "\\'{a}") - ("acircumflex" "\\^{a}") - ("atilde" "\\~{a}") - ("amul" "\\\"{a}") - ("aring" "\\aa") - ("aeligature" "\\ae") - ("oeligature" "{\\oe}") - ("ccedilla" "{\\c{c}}") - ("egrave" "{\\`{e}}") - ("eacute" "{\\'{e}}") - ("ecircumflex" "{\\^{e}}") - ("euml" "\\\"{e}") - ("igrave" "{\\`{\\i}}") - ("iacute" "{\\'{\\i}}") - ("icircumflex" "{\\^{\\i}}") - ("iuml" "\\\"{\\i}") - ("ntilde" "\\~{n}") - ("ograve" "\\`{o}") - ("oacute" "\\'{o}") - ("ocurcumflex" "\\^{o}") - ("otilde" "\\~{o}") - ("ouml" "\\\"{o}") - ("divide" ,(math "\\div")) - ("oslash" "\\o") - ("ugrave" "\\`{u}") - ("uacute" "\\'{u}") - ("ucircumflex" "\\^{u}") - ("uuml" "\\\"{u}") - ("yacute" "\\'{y}") - ("ymul" "\\\"{y}") - ;; Greek - ("Alpha" "A") - ("Beta" "B") - ("Gamma" ,(math "\\Gamma")) - ("Delta" ,(math "\\Delta")) - ("Epsilon" "E") - ("Zeta" "Z") - ("Eta" "H") - ("Theta" ,(math "\\Theta")) - ("Iota" "I") - ("Kappa" "K") - ("Lambda" ,(math "\\Lambda")) - ("Mu" "M") - ("Nu" "N") - ("Xi" ,(math "\\Xi")) - ("Omicron" "O") - ("Pi" ,(math "\\Pi")) - ("Rho" "P") - ("Sigma" ,(math "\\Sigma")) - ("Tau" "T") - ("Upsilon" ,(math "\\Upsilon")) - ("Phi" ,(math "\\Phi")) - ("Chi" "X") - ("Psi" ,(math "\\Psi")) - ("Omega" ,(math "\\Omega")) - ("alpha" ,(math "\\alpha")) - ("beta" ,(math "\\beta")) - ("gamma" ,(math "\\gamma")) - ("delta" ,(math "\\delta")) - ("epsilon" ,(math "\\varepsilon")) - ("zeta" ,(math "\\zeta")) - ("eta" ,(math "\\eta")) - ("theta" ,(math "\\theta")) - ("iota" ,(math "\\iota")) - ("kappa" ,(math "\\kappa")) - ("lambda" ,(math "\\lambda")) - ("mu" ,(math "\\mu")) - ("nu" ,(math "\\nu")) - ("xi" ,(math "\\xi")) - ("omicron" ,(math "\\o")) - ("pi" ,(math "\\pi")) - ("rho" ,(math "\\rho")) - ("sigmaf" ,(math "\\varsigma")) - ("sigma" ,(math "\\sigma")) - ("tau" ,(math "\\tau")) - ("upsilon" ,(math "\\upsilon")) - ("phi" ,(math "\\varphi")) - ("chi" ,(math "\\chi")) - ("psi" ,(math "\\psi")) - ("omega" ,(math "\\omega")) - ("thetasym" ,(math "\\vartheta")) - ("piv" ,(math "\\varpi")) - ;; punctuation - ("bullet" ,(math "\\bullet")) - ("ellipsis" ,(math "\\ldots")) - ("weierp" ,(math "\\wp")) - ("image" ,(math "\\Im")) - ("real" ,(math "\\Re")) - ("tm" ,(math "^{\\sc\\tiny{tm}}")) - ("alef" ,(math "\\aleph")) - ("<-" ,(math "\\leftarrow")) - ("<--" ,(math "\\longleftarrow")) - ("uparrow" ,(math "\\uparrow")) - ("->" ,(math "\\rightarrow")) - ("-->" ,(math "\\longrightarrow")) - ("downarrow" ,(math "\\downarrow")) - ("<->" ,(math "\\leftrightarrow")) - ("<-->" ,(math "\\longleftrightarrow")) - ("<+" ,(math "\\hookleftarrow")) - ("<=" ,(math "\\Leftarrow")) - ("<==" ,(math "\\Longleftarrow")) - ("Uparrow" ,(math "\\Uparrow")) - ("=>" ,(math "\\Rightarrow")) - ("==>" ,(math "\\Longrightarrow")) - ("Downarrow" ,(math "\\Downarrow")) - ("<=>" ,(math "\\Leftrightarrow")) - ("<==>" ,(math "\\Longleftrightarrow")) - ;; Mathematical operators - ("forall" ,(math "\\forall")) - ("partial" ,(math "\\partial")) - ("exists" ,(math "\\exists")) - ("emptyset" ,(math "\\emptyset")) - ("infinity" ,(math "\\infty")) - ("nabla" ,(math "\\nabla")) - ("in" ,(math "\\in")) - ("notin" ,(math "\\notin")) - ("ni" ,(math "\\ni")) - ("prod" ,(math "\\Pi")) - ("sum" ,(math "\\Sigma")) - ("asterisk" ,(math "\\ast")) - ("sqrt" ,(math "\\surd")) - ("propto" ,(math "\\propto")) - ("angle" ,(math "\\angle")) - ("and" ,(math "\\wedge")) - ("or" ,(math "\\vee")) - ("cap" ,(math "\\cap")) - ("cup" ,(math "\\cup")) - ("integral" ,(math "\\int")) - ("models" ,(math "\\models")) - ("vdash" ,(math "\\vdash")) - ("dashv" ,(math "\\dashv")) - ("sim" ,(math "\\sim")) - ("cong" ,(math "\\cong")) - ("approx" ,(math "\\approx")) - ("neq" ,(math "\\neq")) - ("equiv" ,(math "\\equiv")) - ("le" ,(math "\\leq")) - ("ge" ,(math "\\geq")) - ("subset" ,(math "\\subset")) - ("supset" ,(math "\\supset")) - ("subseteq" ,(math "\\subseteq")) - ("supseteq" ,(math "\\supseteq")) - ("oplus" ,(math "\\oplus")) - ("otimes" ,(math "\\otimes")) - ("perp" ,(math "\\perp")) - ("mid" ,(math "\\mid")) - ("lceil" ,(math "\\lceil")) - ("rceil" ,(math "\\rceil")) - ("lfloor" ,(math "\\lfloor")) - ("rfloor" ,(math "\\rfloor")) - ("langle" ,(math "\\langle")) - ("rangle" ,(math "\\rangle")) - ;; Misc - ("loz" ,(math "\\diamond")) - ("spades" ,(math "\\spadesuit")) - ("clubs" ,(math "\\clubsuit")) - ("hearts" ,(math "\\heartsuit")) - ("diams" ,(math "\\diamondsuit")) - ("euro" "\\euro{}") - ;; ConTeXt - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;;;; ====================================================================== -;;;; context-width -;;;; ====================================================================== -(define (context-width width) - (cond - ((string? width) - width) - ((and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\textwidth")) - (else - (string-append (number->string width) "pt")))) - -;;;; ====================================================================== -;;;; context-dim -;;;; ====================================================================== -(define (context-dim dimension) - (cond - ((string? dimension) - dimension) - ((number? dimension) - (string-append (number->string (inexact->exact (round dimension))) - "pt")))) - -;;;; ====================================================================== -;;;; context-url -;;;; ====================================================================== -(define(context-url url text e) - (let ((name (gensym 'url)) - (text (or text url))) - (printf "\\useURL[~A][~A][][" name url) - (output text e) - (printf "]\\from[~A]" name))) - -;;;; ====================================================================== -;;;; Color Management ... -;;;; ====================================================================== -(define *skribe-context-color-table* (make-hashtable)) - -(define (skribe-color->context-color spec) - (receive (r g b) - (skribe-color->rgb spec) - (let ((ff (exact->inexact #xff))) - (format "r=~a,g=~a,b=~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))) - - -(define (skribe-declare-used-colors) - (printf "\n%%Colors\n") - (for-each (lambda (spec) - (let ((c (hashtable-get *skribe-context-color-table* spec))) - (unless (string? c) - ;; Color was never used before - (let ((name (symbol->string (gensym 'col)))) - (hashtable-put! *skribe-context-color-table* spec name) - (printf "\\definecolor[~A][~A]\n" - name - (skribe-color->context-color spec)))))) - (skribe-get-used-colors)) - (newline)) - -(define (skribe-declare-standard-colors engine) - (for-each (lambda (x) - (skribe-use-color! (engine-custom engine x))) - '(source-comment-color source-define-color source-module-color - source-markup-color source-thread-color source-string-color - source-bracket-color source-type-color))) - -(define (skribe-get-color spec) - (let ((c (and (hashtable? *skribe-context-color-table*) - (hashtable-get *skribe-context-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'context "Can't find color" spec) - c))) - -;;;; ====================================================================== -;;;; context-engine ... -;;;; ====================================================================== -(define context-engine - (default-engine-set! - (make-engine 'context - :version 1.0 - :format "context" - :delegate (find-engine 'base) - :filter (make-string-replace context-encoding) - :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m))) - :custom context-customs))) - -;;;; ====================================================================== -;;;; document ... -;;;; ====================================================================== -(markup-writer 'document - :options '(:title :subtitle :author :ending :env) - :before (lambda (n e) - ;; Prelude - (printf "% interface=en output=pdftex\n") - (display "%%%% -*- TeX -*-\n") - (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" - (skribe-release) (date)) - ;; Make URLs active - (printf "\\setupinteraction[state=start]\n") - ;; Choose the document font - (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) - (engine-custom e 'font-size)) - ;; Color - (display "\\setupcolors[state=start]\n") - ;; Load Style - (printf "\\input skribe-context-~a.tex\n" - (engine-custom e 'document-style)) - ;; Insert User customization - (let ((s (engine-custom e 'user-style))) - (when s (printf "\\input ~a\n" s))) - ;; Output used colors - (skribe-declare-standard-colors e) - (skribe-declare-used-colors) - - (display "\\starttext\n\\StartTitlePage\n") - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&context-title) - (body t) - (options - `((subtitle ,(markup-option n :subtitle))))) - e - :env `((parent ,n))))) - ;; author(s) - (let ((a (markup-option n :author))) - (when a - (if (list? a) - ;; List of authors. Use multi-columns - (begin - (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) - (display "\\startAuthors\n") - (let Loop ((l a)) - (unless (null? l) - (output (car l) e) - (unless (null? (cdr l)) - (display "\\nextAuthors\n") - (Loop (cdr l))))) - (display "\\stopAuthors\n\n")) - ;; One author, that's easy - (output a e)))) - ;; End of the title - (display "\\StopTitlePage\n")) - :after (lambda (n e) - (display "\n\\stoptext\n"))) - - - -;;;; ====================================================================== -;;;; &context-title ... -;;;; ====================================================================== -(markup-writer '&context-title - :before "{\\DocumentTitle{" - :action (lambda (n e) - (output (markup-body n) e) - (let ((sub (markup-option n 'subtitle))) - (when sub - (display "\\\\\n\\switchtobodyfont[16pt]\\it{") - (output sub e) - (display "}\n")))) - :after "}}") - -;;;; ====================================================================== -;;;; author ... -;;;; ====================================================================== -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (out (lambda (n) - (output n e) - (display "\\\\\n")))) - (display "{\\midaligned{") - (when name (out name)) - (when title (out title)) - (when affiliation (out affiliation)) - (when (pair? address) (for-each out address)) - (when phone (out phone)) - (when email (out email)) - (when url (out url)) - (display "}}\n")))) - - -;;;; ====================================================================== -;;;; toc ... -;;;; ====================================================================== -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\placecontent\n"))) - -;;;; ====================================================================== -;;;; context-block-before ... -;;;; ====================================================================== -(define (context-block-before name name-unnum) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a[~a]{" (if num name name-unnum) - (string-canonicalize (markup-ident n))) - (output (markup-option n :title) e) - (display "}\n")))) - - -;;;; ====================================================================== -;;;; chapter, section, ... -;;;; ====================================================================== -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (context-block-before 'chapter 'title)) - - -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (context-block-before 'section 'subject)) - - -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsection 'subsubject)) - - -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsubsection 'subsubsubject)) - -;;;; ====================================================================== -;;;; paragraph ... -;;;; ====================================================================== -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :after "\\par\n") - -;;;; ====================================================================== -;;;; footnote ... -;;;; ====================================================================== -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;;;; ====================================================================== -;;;; linebreak ... -;;;; ====================================================================== -(markup-writer 'linebreak - :action "\\crlf ") - -;;;; ====================================================================== -;;;; hrule ... -;;;; ====================================================================== -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (printf "\\blackrule[width=~A,height=~A]\n" - (context-width (markup-option n :width)) - (context-dim (markup-option n :height))))) - -;;;; ====================================================================== -;;;; color ... -;;;; ====================================================================== -(markup-writer 'color - :options '(:bg :fg :width :margin :border) - :before (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (if (or bg w m b) - (begin - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (if b (context-width b) "0pt")) - (when m - (printf ",offset=~A" (context-width m))) - (when bg - (printf ",background=color,backgroundcolor=~A" - (skribe-get-color bg))) - (when fg - (printf ",foregroundcolor=~A" - (skribe-get-color fg))) - (when c - (display ",framecorner=round")) - (printf "]\n")) - ;; Probably just a foreground was specified - (when fg - (printf "\\startcolor[~A] " (skribe-get-color fg)))))) - :after (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border))) - (if (or bg w m b) - (printf "\\stopframedtext ") - (when fg - (printf "\\stopcolor ")))))) -;;;; ====================================================================== -;;;; frame ... -;;;; ====================================================================== -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (context-dim b)) - (printf ",offset=~A" (context-width m)) - (when c - (display ",framecorner=round")) - (printf "]\n"))) - :after "\\stopframedtext ") - -;;;; ====================================================================== -;;;; font ... -;;;; ====================================================================== -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (engine-custom e 'font-size)) - (ns (cond - ((and (integer? size) (exact? size)) - (if (> size 0) - size - (+ cs size))) - ((and (number? size) (inexact? size)) - (+ cs (inexact->exact size))) - ((string? size) - (let ((nb (string->number size))) - (if (not (number? nb)) - (skribe-error - 'font - (format "Illegal font size ~s" size) - nb) - (+ cs nb)))))) - (ne (make-engine (gensym 'context) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\switchtobodyfont[~apt]" ns) - (output (markup-body n) ne) - (display "}")))) - - -;;;; ====================================================================== -;;;; flush ... -;;;; ====================================================================== -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n\n\\midaligned{")) - ((left) - (display "\n\n\\leftaligned{")) - ((right) - (display "\n\n\\rightaligned{")))) - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\n\n\\midaligned{" - :after "}\n") - -;;;; ====================================================================== -;;;; pre ... -;;;; ====================================================================== -(markup-writer 'pre - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - -;;;; ====================================================================== -;;;; prog ... -;;;; ====================================================================== -(markup-writer 'prog - :options '(:line :mark) - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - - -;;;; ====================================================================== -;;;; itemize, enumerate ... -;;;; ====================================================================== -(define (context-itemization-action n e descr?) - (let ((symbol (markup-option n :symbol))) - (for-each (lambda (item) - (if symbol - (begin - (display "\\sym{") - (output symbol e) - (display "}")) - ;; output a \item iff not a description - (unless descr? - (display " \\item "))) - (output item e) - (newline)) - (markup-body n)))) - -(markup-writer 'itemize - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - - -(markup-writer 'enumerate - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[n][standard]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; description ... -;;;; ====================================================================== -(markup-writer 'description - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #t)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; item ... -;;;; ====================================================================== -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (when k - ;; Output the key(s) - (let Loop ((l (if (pair? k) k (list k)))) - (unless (null? l) - (output (bold (car l)) e) - (unless (null? (cdr l)) - (display "\\crlf\n")) - (Loop (cdr l)))) - (display "\\nowhitespace\\startnarrower[left]\n")) - ;; Output body - (output (markup-body n) e) - ;; Terminate - (when k - (display "\n\\stopnarrower\n"))))) - -;;;; ====================================================================== -;;;; blockquote ... -;;;; ====================================================================== -(markup-writer 'blockquote - :before "\n\\startnarrower[left,right]\n" - :after "\n\\stopnarrower\n") - - -;;;; ====================================================================== -;;;; figure ... -;;;; ====================================================================== -(markup-writer 'figure - :options '(:legend :number :multicolumns) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (unless number - (display "{\\setupcaptions[number=off]\n")) - (display "\\placefigure\n") - (printf " [~a]\n" (string-canonicalize ident)) - (display " {") (output legend e) (display "}\n") - (display " {") (output (markup-body n) e) (display "}") - (unless number - (display "}\n"))))) - -;;;; ====================================================================== -;;;; table ... -;;;; ====================================================================== - ;; width doesn't work -(markup-writer 'table - :options '(:width :border :frame :rules :cellpadding) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (printf "\n{\\bTABLE\n") - (printf "\\setupTABLE[") - (printf "width=~A" (if width (context-width width) "fit")) - (when border - (printf ",rulethickness=~A" (context-dim border))) - (when cp - (printf ",offset=~A" (context-width cp))) - (printf ",frame=off]\n") - - (when rules - (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") - (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n")) - (case rules - ((rows) (display hor)) - ((cols) (display vert)) - ((all) (display hor) (display vert))))) - - (when frame - ;; hsides, vsides, lhs, rhs, box, border - (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n") - (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n") - (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n") - (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n")) - (case frame - ((above) (display top)) - ((below) (display bot)) - ((hsides) (display top) (display bot)) - ((lhs) (display left)) - ((rhs) (display right)) - ((vsides) (display left) (diplay right)) - ((box border) (display top) (display bot) - (display left) (display right))))))) - - :after (lambda (n e) - (printf "\\eTABLE}\n"))) - - -;;;; ====================================================================== -;;;; tr ... -;;;; ====================================================================== -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (display "\\bTR") - (let ((bg (markup-option n :bg))) - (when bg - (printf "[background=color,backgroundcolor=~A]" - (skribe-get-color bg))))) - :after "\\eTR\n") - - -;;;; ====================================================================== -;;;; tc ... -;;;; ====================================================================== -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :before (lambda (n e) - (let ((th? (eq? 'th (markup-option n 'markup))) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (markup-option n :valign)) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "\\bTD[") - (printf "width=~a" (if width (context-width width) "fit")) - (when valign - ;; This is buggy. In fact valign an align can't be both - ;; specified in ConTeXt - (printf ",align=~a" (case valign - ((center) 'lohi) - ((bottom) 'low) - ((top) 'high)))) - (when align - (printf ",align=~a" (case align - ((left) 'right) ; !!!! - ((right) 'left) ; !!!! - (else 'middle)))) - (unless (equal? colspan 1) - (printf ",nx=~a" colspan)) - (display "]") - (when th? - ;; This is a TH, output is bolded - (display "{\\bf{")))) - - :after (lambda (n e) - (when (equal? (markup-option n 'markup) 'th) - ;; This is a TH, output is bolded - (display "}}")) - (display "\\eTD"))) - -;;;; ====================================================================== -;;;; image ... -;;;; ====================================================================== -(markup-writer 'image - :options '(:file :url :width :height :zoom) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (zoom (markup-option n :zoom)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("jpg")))))) - (if (not (string? img)) - (skribe-error 'context "Illegal image" file) - (begin - (printf "\\externalfigure[~A][frame=off" (strip-ref-base img)) - (if zoom (printf ",factor=~a" (inexact->exact zoom))) - (if width (printf ",width=~a" (context-width width))) - (if height (printf ",height=~apt" (context-dim height))) - (display "]")))))) - - -;;;; ====================================================================== -;;;; Ornaments ... -;;;; ====================================================================== -(markup-writer 'roman :before "{\\rm{" :after "}}") -(markup-writer 'bold :before "{\\bf{" :after "}}") -(markup-writer 'underline :before "{\\underbar{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\it{" :after "}}") -(markup-writer 'code :before "{\\tt{" :after "}}") -(markup-writer 'var :before "{\\tt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -;;//(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "{\\low{" :after "}}") -(markup-writer 'sup :before "{\\high{" :after "}}") - - -;;// -;;//(markup-writer 'tt -;;// :before "{\\texttt{" -;;// :action (lambda (n e) -;;// (let ((ne (make-engine -;;// (gensym 'latex) -;;// :delegate e -;;// :filter (make-string-replace latex-tt-encoding) -;;// :custom (engine-customs e) -;;// :symbol-table (engine-symbol-table e)))) -;;// (output (markup-body n) ne))) -;;// :after "}}") - -;;;; ====================================================================== -;;;; q ... -;;;; ====================================================================== -(markup-writer 'q - :before "\\quotation{" - :after "}") - -;;;; ====================================================================== -;;;; mailto ... -;;;; ====================================================================== -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-body n))) - (when (pair? url) - (context-url (format "mailto:~A" (car url)) - (or text - (car url)) - e))))) -;;;; ====================================================================== -;;;; mark ... -;;;; ====================================================================== -(markup-writer 'mark - :before (lambda (n e) - (printf "\\reference[~a]{}\n" - (string-canonicalize (markup-ident n))))) - -;;;; ====================================================================== -;;;; ref ... -;;;; ====================================================================== -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection - :figure :mark :handle :page) - :action (lambda (n e) - (let* ((text (markup-option n :text)) - (page (markup-option n :page)) - (c (handle-ast (markup-body n))) - (id (markup-ident c))) - (cond - (page ;; Output the page only (this is a hack) - (when text (output text e)) - (printf "\\at[~a]" - (string-canonicalize id))) - ((or (markup-option n :chapter) - (markup-option n :section) - (markup-option n :subsection) - (markup-option n :subsubsection)) - (if text - (printf "\\goto{~a}[~a]" (or text id) - (string-canonicalize id)) - (printf "\\in[~a]" (string-canonicalize id)))) - ((markup-option n :mark) - (printf "\\goto{~a}[~a]" - (or text id) - (string-canonicalize id))) - (else ;; Output a little image indicating the direction - (printf "\\in[~a]" (string-canonicalize id))))))) - -;;;; ====================================================================== -;;;; bib-ref ... -;;;; ====================================================================== -(markup-writer 'bib-ref - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) - (let* ((obj (handle-ast (markup-body n))) - (title (markup-option obj :title)) - (ref (markup-option title 'number)) - (ident (markup-ident obj))) - (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) - :after (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; bib-ref+ ... -;;;; ====================================================================== -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (invoke (writer-action (markup-writer-get 'bib-ref e)) - (car rs) - e) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; url-ref ... -;;;; ====================================================================== -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (context-url (markup-option n :url) (markup-option n :text) e))) - -;;//;*---------------------------------------------------------------------*/ -;;//;* line-ref ... */ -;;//;*---------------------------------------------------------------------*/ -;;//(markup-writer 'line-ref -;;// :options '(:offset) -;;// :before "{\\textit{" -;;// :action (lambda (n e) -;;// (let ((o (markup-option n :offset)) -;;// (v (string->number (markup-option n :text)))) -;;// (cond -;;// ((and (number? o) (number? v)) -;;// (display (+ o v))) -;;// (else -;;// (display v))))) -;;// :after "}}") - - -;;;; ====================================================================== -;;;; &the-bibliography ... -;;;; ====================================================================== -(markup-writer '&the-bibliography - :before "\n% Bibliography\n\n") - - -;;;; ====================================================================== -;;;; &bib-entry ... -;;;; ====================================================================== -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (skribe-eval (mark (markup-ident n)) e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n\n") - -;;;; ====================================================================== -;;;; &bib-entry-label ... -;;;; ====================================================================== -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) (output (markup-option n :title) e)) - :after (lambda (n e) (output "] "e))) - -;;;; ====================================================================== -;;;; &bib-entry-title ... -;;;; ====================================================================== -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - - -;;//;*---------------------------------------------------------------------*/ -;;//;* &bib-entry-url ... */ -;;//;*---------------------------------------------------------------------*/ -;;//(markup-writer '&bib-entry-url -;;// :action (lambda (n e) -;;// (let* ((en (handle-ast (ast-parent n))) -;;// (url (markup-option en 'url)) -;;// (t (bold (markup-body url)))) -;;// (skribe-eval (ref :url (markup-body url) :text t) e)))) - - -;;;; ====================================================================== -;;;; &the-index ... -;;;; ====================================================================== -(markup-writer '&the-index - :options '(:column) - :action - (lambda (n e) - (define (make-mark-entry n) - (display "\\blank[medium]\n{\\bf\\it\\tfc{") - (skribe-eval (bold n) e) - (display "}}\\crlf\n")) - - (define (make-primary-entry n) - (let ((b (markup-body n))) - (markup-option-add! b :text (list (markup-option b :text) ", ")) - (markup-option-add! b :page #t) - (output n e))) - - (define (make-secondary-entry n) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (if note - (begin ;; This is another entry - (display "\\crlf\n ... ") - (markup-option-add! b :text (list note ", "))) - (begin ;; another line on an entry - (markup-option-add! b :text ", "))) - (markup-option-add! b :page #t) - (output n e))) - - ;; Writer body starts here - (let ((col (markup-option n :column))) - (when col - (printf "\\startcolumns[n=~a]\n" col)) - (for-each (lambda (item) - ;;(DEBUG "ITEM= ~S" item) - (if (pair? item) - (begin - (make-primary-entry (car item)) - (for-each (lambda (x) (make-secondary-entry x)) - (cdr item))) - (make-mark-entry item)) - (display "\\crlf\n")) - (markup-body n)) - (when col - (printf "\\stopcolumns\n"))))) - -;;;; ====================================================================== -;;;; &source-comment ... -;;;; ====================================================================== -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-line-comment ... -;;;; ====================================================================== -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-keyword ... -;;;; ====================================================================== -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - -;;;; ====================================================================== -;;;; &source-error ... -;;;; ====================================================================== -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'error-color) cc) - (color :fg cc (it n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-define ... -;;;; ====================================================================== -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-module ... -;;;; ====================================================================== -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-markup ... -;;;; ====================================================================== -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-thread ... -;;;; ====================================================================== -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-string ... -;;;; ====================================================================== -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-bracket ... -;;;; ====================================================================== -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-key ... -;;;; ====================================================================== -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - - - -;;;; ====================================================================== -;;;; Context Only Markups -;;;; ====================================================================== - -;;; -;;; Margin -- put text in the margin -;;; -(define-markup (margin #!rest opts #!key (ident #f) (class "margin") - (side 'right) text) - (new markup - (markup 'margin) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -(markup-writer 'margin - :options '(:text) - :before (lambda (n e) - (display - "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n") - (display "\\inright{") - (output (markup-option n :text) e) - (display "}{")) - :after "}") - -;;; -;;; ConTeXt and TeX -;;; -(define-markup (ConTeXt #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\CONTEXT\\ " "\\CONTEXT")) - "ConTeXt")) - -(define-markup (TeX #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\TEX\\ " "\\TEX")) - "ConTeXt")) - -;;;; ====================================================================== -;;;; Restore the base engine -;;;; ====================================================================== -(default-engine-set! (find-engine 'base)) diff --git a/skr/html.skr b/skr/html.skr deleted file mode 100644 index 79186ca..0000000 --- a/skr/html.skr +++ /dev/null @@ -1,2271 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/html.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:28:57 2003 */ -;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* HTML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/htmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html-file-default ... */ -;*---------------------------------------------------------------------*/ -(define html-file-default - ;; Default implementation of the `file-name-proc' custom. - (let ((table '()) - (filename (gensym))) - (define (get-file-name base suf) - (let* ((c (assoc base table)) - (n (if (pair? c) - (let ((n (+ 1 (cdr c)))) - (set-cdr! c n) - n) - (begin - (set! table (cons (cons base 1) table)) - 1)))) - (format "~a-~a.~a" base n suf))) - (lambda (node e) - (let ((f (markup-option node filename)) - (file (markup-option node :file))) - (cond - ((string? f) - f) - ((string? file) - file) - ((or file - (and (is-markup? node 'chapter) - (engine-custom e 'chapter-file)) - (and (is-markup? node 'section) - (engine-custom e 'section-file)) - (and (is-markup? node 'subsection) - (engine-custom e 'subsection-file)) - (and (is-markup? node 'subsubsection) - (engine-custom e 'subsubsection-file))) - (let* ((b (or (and (string? *skribe-dest*) - (prefix *skribe-dest*)) - "")) - (s (or (and (string? *skribe-dest*) - (suffix *skribe-dest*)) - "html")) - (nm (get-file-name b s))) - (markup-option-add! node filename nm) - nm)) - ((document? node) - *skribe-dest*) - (else - (let ((p (ast-parent node))) - (if (container? p) - (let ((file (html-file p e))) - (if (string? file) - (begin - (markup-option-add! node filename file) - file) - #f)) - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* html-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-engine - ;; setup the html engine - (default-engine-set! - (make-engine 'html - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@"))) - :custom `(;; the icon associated with the URL - (favicon #f) - ;; charset used - (charset "ISO-8859-1") - ;; enable/disable Javascript - (javascript #f) - ;; user html head - (head #f) - ;; user CSS - (css ()) - ;; user inlined CSS - (inline-css ()) - ;; user JS - (js ()) - ;; emit-sui - (emit-sui #f) - ;; the body - (background "#ffffff") - (foreground #f) - ;; the margins - (margin-padding 3) - (left-margin #f) - (chapter-left-margin #f) - (section-left-margin #f) - (left-margin-font #f) - (left-margin-size 17.) - (left-margin-background "#dedeff") - (left-margin-foreground #f) - (right-margin #f) - (chapter-right-margin #f) - (section-right-margin #f) - (right-margin-font #f) - (right-margin-size 17.) - (right-margin-background "#dedeff") - (right-margin-foreground #f) - ;; author configuration - (author-font #f) - ;; title configuration - (title-font #f) - (title-background "#8381de") - (title-foreground #f) - (file-title-separator " -- ") - ;; html file naming - (file-name-proc ,html-file-default) - ;; index configuration - (index-header-font-size +2.) - ;; chapter configuration - (chapter-number->string number->string) - (chapter-file #f) - ;; section configuration - (section-title-start "

") - (section-title-stop "

") - (section-title-background "#dedeff") - (section-title-foreground "black") - (section-title-number-separator " ") - (section-number->string number->string) - (section-file #f) - ;; subsection configuration - (subsection-title-start "

") - (subsection-title-stop "

") - (subsection-title-background "#ffffff") - (subsection-title-foreground "#8381de") - (subsection-title-number-separator " ") - (subsection-number->string number->string) - (subsection-file #f) - ;; subsubsection configuration - (subsubsection-title-start "

") - (subsubsection-title-stop "

") - (subsubsection-title-background #f) - (subsubsection-title-foreground "#8381de") - (subsubsection-title-number-separator " ") - (subsubsection-number->string number->string) - (subsubsection-file #f) - ;; source fontification - (source-color #t) - (source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - ;; image - (image-format ("png" "gif" "jpg" "jpeg"))) - :symbol-table '(("iexcl" "¡") - ("cent" "¢") - ("pound" "£") - ("currency" "¤") - ("yen" "¥") - ("section" "§") - ("mul" "¨") - ("copyright" "©") - ("female" "ª") - ("lguillemet" "«") - ("not" "¬") - ("registered" "®") - ("degree" "°") - ("plusminus" "±") - ("micro" "µ") - ("paragraph" "¶") - ("middot" "·") - ("male" "¸") - ("rguillemet" "»") - ("1/4" "¼") - ("1/2" "½") - ("3/4" "¾") - ("iquestion" "¿") - ("Agrave" "À") - ("Aacute" "Á") - ("Acircumflex" "Â") - ("Atilde" "Ã") - ("Amul" "Ä") - ("Aring" "Å") - ("AEligature" "Æ") - ("Oeligature" "Œ") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "Ë") - ("Igrave" "Ì") - ("Iacute" "Í") - ("Icircumflex" "Î") - ("Iuml" "Ï") - ("ETH" "Ð") - ("Ntilde" "Ñ") - ("Ograve" "Ò") - ("Oacute" "Ó") - ("Ocurcumflex" "Ô") - ("Otilde" "Õ") - ("Ouml" "Ö") - ("times" "×") - ("Oslash" "Ø") - ("Ugrave" "Ù") - ("Uacute" "Ú") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Ý") - ("THORN" "Þ") - ("szlig" "ß") - ("agrave" "à") - ("aacute" "á") - ("acircumflex" "â") - ("atilde" "ã") - ("amul" "ä") - ("aring" "å") - ("aeligature" "æ") - ("oeligature" "œ") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "ë") - ("igrave" "ì") - ("iacute" "í") - ("icircumflex" "î") - ("iuml" "ï") - ("eth" "ð") - ("ntilde" "ñ") - ("ograve" "ò") - ("oacute" "ó") - ("ocurcumflex" "ô") - ("otilde" "õ") - ("ouml" "ö") - ("divide" "÷") - ("oslash" "ø") - ("ugrave" "ù") - ("uacute" "ú") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "ý") - ("thorn" "þ") - ("ymul" "ÿ") - ;; Greek - ("Alpha" "Α") - ("Beta" "Β") - ("Gamma" "Γ") - ("Delta" "Δ") - ("Epsilon" "Ε") - ("Zeta" "Ζ") - ("Eta" "Η") - ("Theta" "Θ") - ("Iota" "Ι") - ("Kappa" "Κ") - ("Lambda" "Λ") - ("Mu" "Μ") - ("Nu" "Ν") - ("Xi" "Ξ") - ("Omicron" "Ο") - ("Pi" "Π") - ("Rho" "Ρ") - ("Sigma" "Σ") - ("Tau" "Τ") - ("Upsilon" "Υ") - ("Phi" "Φ") - ("Chi" "Χ") - ("Psi" "Ψ") - ("Omega" "Ω") - ("alpha" "α") - ("beta" "β") - ("gamma" "γ") - ("delta" "δ") - ("epsilon" "ε") - ("zeta" "ζ") - ("eta" "η") - ("theta" "θ") - ("iota" "ι") - ("kappa" "κ") - ("lambda" "λ") - ("mu" "μ") - ("nu" "ν") - ("xi" "ξ") - ("omicron" "ο") - ("pi" "π") - ("rho" "ρ") - ("sigmaf" "ς") - ("sigma" "σ") - ("tau" "τ") - ("upsilon" "υ") - ("phi" "φ") - ("chi" "χ") - ("psi" "ψ") - ("omega" "ω") - ("thetasym" "ϑ") - ("piv" "ϖ") - ;; punctuation - ("bullet" "•") - ("ellipsis" "…") - ("weierp" "℘") - ("image" "ℑ") - ("real" "ℜ") - ("tm" "™") - ("alef" "ℵ") - ("<-" "←") - ("<--" "←") - ("uparrow" "↑") - ("->" "→") - ("-->" "→") - ("downarrow" "↓") - ("<->" "↔") - ("<-->" "↔") - ("<+" "↵") - ("<=" "⇐") - ("<==" "⇐") - ("Uparrow" "⇑") - ("=>" "⇒") - ("==>" "⇒") - ("Downarrow" "⇓") - ("<=>" "⇔") - ("<==>" "⇔") - ;; Mathematical operators - ("forall" "∀") - ("partial" "∂") - ("exists" "∃") - ("emptyset" "∅") - ("infinity" "∞") - ("nabla" "∇") - ("in" "∈") - ("notin" "∉") - ("ni" "∋") - ("prod" "∏") - ("sum" "∑") - ("asterisk" "∗") - ("sqrt" "√") - ("propto" "∝") - ("angle" "∠") - ("and" "∧") - ("or" "∨") - ("cap" "∩") - ("cup" "∪") - ("integral" "∫") - ("therefore" "∴") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "∼") - ("cong" "≅") - ("approx" "≈") - ("neq" "≠") - ("equiv" "≡") - ("le" "≤") - ("ge" "≥") - ("subset" "⊂") - ("supset" "⊃") - ("nsupset" "⊃") - ("subseteq" "⊆") - ("supseteq" "⊇") - ("oplus" "⊕") - ("otimes" "⊗") - ("perp" "⊥") - ("mid" "|") - ("lceil" "⌈") - ("rceil" "⌉") - ("lfloor" "⌊") - ("rfloor" "⌋") - ("langle" "〈") - ("rangle" "〉") - ;; Misc - ("loz" "◊") - ("spades" "♠") - ("clubs" "♣") - ("hearts" "♥") - ("diams" "♦") - ("euro" "ℐ") - ;; LaTeX - ("dag" "dag") - ("ddag" "ddag") - ("circ" "o") - ("top" "T") - ("bottom" "⊥") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* html-file ... */ -;*---------------------------------------------------------------------*/ -(define (html-file n e) - (let ((proc (or (engine-custom e 'file-name-proc) html-file-default))) - (proc n e))) - -;*---------------------------------------------------------------------*/ -;* html-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-title-engine - (copy-engine 'html-title base-engine - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """))))) - -;*---------------------------------------------------------------------*/ -;* html-browser-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-browser-title n) - (and (markup? n) - (or (markup-option n :html-title) - (if (document? n) - (markup-option n :title) - (html-browser-title (ast-parent n)))))) - - -;*---------------------------------------------------------------------*/ -;* html-container-number ... */ -;* ------------------------------------------------------------- */ -;* Returns a string representing the container number */ -;*---------------------------------------------------------------------*/ -(define (html-container-number c e) - (define (html-number n proc) - (cond - ((string? n) - n) - ((number? n) - (if (procedure? proc) - (proc n) - (number->string n))) - (else - ""))) - (define (html-chapter-number c) - (html-number (markup-option c :number) - (engine-custom e 'chapter-number->string))) - (define (html-section-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'section-number->string)))) - (cond - ((is-markup? p 'chapter) - (string-append (html-chapter-number p) "." s)) - (else - (string-append s))))) - (define (html-subsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsection-number->string)))) - (cond - ((is-markup? p 'section) - (string-append (html-section-number p) "." s)) - (else - (string-append "." s))))) - (define (html-subsubsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsubsection-number->string)))) - (cond - ((is-markup? p 'subsection) - (string-append (html-subsection-number p) "." s)) - (else - (string-append ".." s))))) - (define (inner-html-container-number c) - (html-number (markup-option c :number) #f)) - (let ((n (markup-option c :number))) - (if (not n) - "" - (case (markup-markup c) - ((chapter) - (html-chapter-number c)) - ((section) - (html-section-number c)) - ((subsection) - (html-subsection-number c)) - ((subsubsection) - (html-subsubsection-number c)) - (else - (if (container? c) - (inner-html-container-number c) - (skribe-error 'html-container-number - "Not a container" - (markup-markup c)))))))) - -;*---------------------------------------------------------------------*/ -;* html-counter ... */ -;*---------------------------------------------------------------------*/ -(define (html-counter cnts) - (cond - ((not cnts) - "") - ((null? cnts) - "") - ((not (pair? cnts)) - cnts) - ((null? (cdr cnts)) - (format "~a." (car cnts))) - (else - (let loop ((cnts cnts)) - (if (null? (cdr cnts)) - (format "~a" (car cnts)) - (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) - -;*---------------------------------------------------------------------*/ -;* html-width ... */ -;*---------------------------------------------------------------------*/ -(define (html-width width) - (cond - ((and (integer? width) (exact? width)) - (format "~A" width)) - ((real? width) - (format "~A%" (inexact->exact (round width)))) - ((string? width) - width) - (else - (skribe-error 'html-width "bad width" width)))) - -;*---------------------------------------------------------------------*/ -;* html-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-class m) - (if (markup? m) - (let ((c (markup-class m))) - (if (or (string? c) (symbol? c) (number? c)) - (printf " class=\"~a\"" c))))) - -;*---------------------------------------------------------------------*/ -;* html-markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-markup-class m) - (lambda (n e) - (printf "<~a" m) - (html-class n) - (display ">"))) - -;*---------------------------------------------------------------------*/ -;* html-color-spec? ... */ -;*---------------------------------------------------------------------*/ -(define (html-color-spec? v) - (and v - (not (unspecified? v)) - (or (not (string? v)) (> (string-length v) 0)))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :html-title :env) - :action (lambda (n e) - (let* ((id (markup-ident n)) - (title (new markup - (markup '&html-document-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (options `((author ,(markup-option n :author)))) - (body (markup-option n :title))))) - (&html-generic-document n title e))) - :after (lambda (n e) - (if (engine-custom e 'emit-sui) - (document-sui n e)))) - -;*---------------------------------------------------------------------*/ -;* &html-html ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-html - :before " - -\n" - :after "") - -;*---------------------------------------------------------------------*/ -;* &html-head ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-head - :before (lambda (n e) - (printf "\n") - (printf "\n" (engine-custom (find-engine 'html) - 'charset))) - :after "\n\n") - -;*---------------------------------------------------------------------*/ -;* &html-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-body - :before (lambda (n e) - (let ((bg (engine-custom e 'background))) - (display "\n"))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* &html-page ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-page - :action (lambda (n e) - (define (html-margin m fn size bg fg cla) - (printf "" bg) - (display ">")) - (printf "
\n" cla) - (cond - ((and (string? fg) (string? fn)) - (printf "" fg fn)) - ((string? fg) - (printf "" fg)) - ((string? fn) - (printf "" fn))) - (if (procedure? m) - (skribe-eval (m n e) e) - (output m e)) - (if (or (string? fg) (string? fn)) - (display "")) - (display "
\n")) - (let ((body (markup-body n)) - (lm (engine-custom e 'left-margin)) - (lmfn (engine-custom e 'left-margin-font)) - (lms (engine-custom e 'left-margin-size)) - (lmbg (engine-custom e 'left-margin-background)) - (lmfg (engine-custom e 'left-margin-foreground)) - (rm (engine-custom e 'right-margin)) - (rmfn (engine-custom e 'right-margin-font)) - (rms (engine-custom e 'right-margin-size)) - (rmbg (engine-custom e 'right-margin-background)) - (rmfg (engine-custom e 'right-margin-foreground))) - (cond - ((and lm rm) - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "
")) - (lm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (display "
")) - (rm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n")) - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "
")) - (else - (display "
\n") - (output body e) - (display "
\n")))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-header ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-header n e) - (let* ((ic (engine-custom e 'favicon)) - (id (markup-ident n))) - (unless (string? id) - (skribe-error '&html-generic-header - (format "Illegal identifier `~a'" id) - n)) - ;; title - (output (new markup - (markup '&html-header-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (body (markup-body n))) - e) - ;; favicon - (output (new markup - (markup '&html-header-favicon) - (parent n) - (ident (string-append id "-favicon")) - (body (cond - ((string? ic) - ic) - ((procedure? ic) - (ic d e))))) - e) - ;; style - (output (new markup - (markup '&html-header-style) - (parent n) - (ident (string-append id "-style")) - (class (markup-class n))) - e) - ;; css - (output (new markup - (markup '&html-header-css) - (parent n) - (ident (string-append id "-css")) - (body (let ((c (engine-custom e 'css))) - (if (string? c) - (list c) - c)))) - e) - ;; javascript - (output (new markup - (markup '&html-header-javascript) - (parent n) - (ident (string-append id "-javascript"))) - e))) - -(markup-writer '&html-header-title - :before "" - :action (lambda (n e) - (output (markup-body n) html-title-engine)) - :after "\n") - -(markup-writer '&html-header-favicon - :action (lambda (n e) - (let ((i (markup-body n))) - (when i - (printf " \n" i))))) - -(markup-writer '&html-header-css - :action (lambda (n e) - (let ((css (markup-body n))) - (when (pair? css) - (for-each (lambda (css) - (printf " \n" css)) - css))))) - -(markup-writer '&html-header-style - :before " \n") - -(markup-writer '&html-header-javascript - :action (lambda (n e) - (when (engine-custom e 'javascript) - (display " \n")) - (let* ((ejs (engine-custom e 'js)) - (js (cond - ((string? ejs) - (list ejs)) - ((list? ejs) - ejs) - (else - '())))) - (for-each (lambda (s) - (printf "" s)) - js)))) - - -;*---------------------------------------------------------------------*/ -;* &html-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-header :action &html-generic-header) -(markup-writer '&html-chapter-header :action &html-generic-header) -(markup-writer '&html-section-header :action &html-generic-header) -(markup-writer '&html-subsection-header :action &html-generic-header) -(markup-writer '&html-subsubsection-header :action &html-generic-header) - -;*---------------------------------------------------------------------*/ -;* &html-ending ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-ending - :before "
" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval [ -,(hrule) -,(p :class "ending" (font :size -1 [ -This ,(sc "Html") page has been produced by -,(ref :url (skribe-url) :text "Skribe"). -,(linebreak) -Last update ,(it (date)).]))] e)))) - :after "
\n") - -;*---------------------------------------------------------------------*/ -;* &html-generic-title ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (when title - (display "\n") - (if (html-color-spec? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (when title - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "
") - (output title e) - (display "
")))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "")) - (display "
\n")))) - -;*---------------------------------------------------------------------*/ -;* &html-document-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-title :action &html-generic-title) -(markup-writer '&html-chapter-title :action &html-generic-title) -(markup-writer '&html-section-title :action &html-generic-title) -(markup-writer '&html-subsection-title :action &html-generic-title) -(markup-writer '&html-subsubsection-title :action &html-generic-title) - -;*---------------------------------------------------------------------*/ -;* &html-footnotes */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-footnotes - :before (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (display "
") - (display "

\n") - (display "
\n")))) - :action (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (let loop ((fns footnotes)) - (if (pair? fns) - (let ((fn (car fns))) - (printf "" - (string-canonicalize - (container-ident fn))) - (printf "~a: " - (markup-option fn :number)) - (output (markup-body fn) e) - (display "\n
\n") - (loop (cdr fns))))) - (display "
"))))) - -;*---------------------------------------------------------------------*/ -;* html-title-authors ... */ -;*---------------------------------------------------------------------*/ -(define (html-title-authors authors e) - (define (html-authorsN authors cols first) - (define (make-row authors . opt) - (tr (map (lambda (v) - (apply td :align 'center :valign 'top v opt)) - authors))) - (define (make-rows authors) - (let loop ((authors authors) - (rows '()) - (row '()) - (cnum 0)) - (cond - ((null? authors) - (reverse! (cons (make-row (reverse! row)) rows))) - ((= cnum cols) - (loop authors - (cons (make-row (reverse! row)) rows) - '() - 0)) - (else - (loop (cdr authors) - rows - (cons (car authors) row) - (+ cnum 1)))))) - (output (table :cellpadding 10 - (if first - (cons (make-row (list (car authors)) :colspan cols) - (make-rows (cdr authors))) - (make-rows authors))) - e)) - (cond - ((pair? authors) - (display "
\n") - (let ((len (length authors))) - (case len - ((1) - (output (car authors) e)) - ((2 3) - (html-authorsN authors len #f)) - ((4) - (html-authorsN authors 2 #f)) - (else - (html-authorsN authors 3 #t)))) - (display "
\n")) - (else - (html-title-authors (list authors) e)))) - -;*---------------------------------------------------------------------*/ -;* document-sui ... */ -;*---------------------------------------------------------------------*/ -(define (document-sui n e) - (define (sui) - (display "(sui \"") - (skribe-eval (markup-option n :title) html-title-engine) - (display "\"\n") - (printf " :file ~s\n" (sui-referenced-file n e)) - (sui-marks n e) - (sui-blocks 'chapter n e) - (sui-blocks 'section n e) - (sui-blocks 'subsection n e) - (sui-blocks 'subsubsection n e) - (display " )\n")) - (if (string? *skribe-dest*) - (let ((f (format "~a.sui" (prefix *skribe-dest*)))) - (with-output-to-file f sui)) - (sui))) - -;*---------------------------------------------------------------------*/ -;* sui-referenced-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-referenced-file n e) - (let ((file (html-file n e))) - (if (member (suffix file) '("skb" "sui" "skr" "html")) - (string-append (strip-ref-base (prefix file)) ".html") - file))) - -;*---------------------------------------------------------------------*/ -;* sui-marks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-marks n e) - (printf " (marks") - (for-each (lambda (m) - (printf "\n (~s" (markup-ident m)) - (printf " :file ~s" (sui-referenced-file m e)) - (printf " :mark ~s" (markup-ident m)) - (when (markup-class m) - (printf " :class ~s" (markup-class m))) - (display ")")) - (search-down (lambda (n) (is-markup? n 'mark)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* sui-blocks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-blocks kind n e) - (printf " (~as" kind) - (for-each (lambda (chap) - (display "\n (\"") - (skribe-eval (markup-option chap :title) html-title-engine) - (printf "\" :file ~s" (sui-referenced-file chap e)) - (printf " :mark ~s" (markup-ident chap)) - (when (markup-class chap) - (printf " :class ~s" (markup-class chap))) - (display ")")) - (container-search-down (lambda (n) (is-markup? n kind)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (display "\n")) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (define (row n) - (printf "" align) - (output n e) - (display "")) - ;; name - (printf "" align) - (if nfn - (printf "\n" nfn) - (display "\n")) - (output name e) - (if nfn - (printf "\n") - (display "\n")) - (display "") - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after "") - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :predicate (lambda (n e) (markup-option n :photo)) - :before (lambda (n e) - (display "\n")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (display "") - (output photo e) - (display "") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display ""))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options 'all - :action (lambda (n e) - (define (col n) - (let loop ((i 0)) - (if (< i n) - (begin - (display "") - (loop (+ i 1)))))) - (define (toc-entry fe level) - (let* ((c (car fe)) - (ch (cdr fe)) - (t (markup-option c :title)) - (id (markup-ident c)) - (f (html-file c e))) - (unless (string? id) - (skribe-error 'toc - (format "Illegal identifier `~a'" id) - c)) - (display " ") - ;; blank columns - (col level) - ;; number - (printf "~a" - (html-container-number c e)) - ;; title - (printf "" - (- 4 level)) - (printf "" - (if (string=? f *skribe-dest*) - "" - (strip-ref-base (or f *skribe-dest* ""))) - (string-canonicalize id)) - (output (markup-option c :title) e) - (display "") - (display "\n") - ;; the children - (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) - (define (symbol->keyword s) - (cond-expand - (stklos - (make-keyword s)) - (bigloo - (string->keyword (string-append ":" (symbol->string s)))))) - (let* ((c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection)) - (b (markup-body n)) - (bb (if (handle? b) - (handle-ast b) - b))) - (if (not (container? bb)) - (error 'toc - "Illegal body (container expected)" - (if (markup? bb) - (markup-markup bb) - "???")) - (let ((lst (find-down (lambda (x) - (and (markup? x) - (markup-option x :toc) - (or (and sss (is-markup? x 'subsubsection)) - (and ss (is-markup? x 'subsection)) - (and s (is-markup? x 'section)) - (and c (is-markup? x 'chapter)) - (markup-option n (symbol->keyword - (markup-markup x)))))) - (container-body bb)))) - ;; avoid to produce an empty table - (unless (null? lst) - (display "\n\n") - - (for-each (lambda (n) (toc-entry n 0)) lst) - - (display "\n
\n"))))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-document ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-document n title e) - (let* ((id (markup-ident n)) - (header (new markup - (markup '&html-chapter-header) - (ident (string-append id "-header")) - (class (markup-class n)) - (parent n) - (body (html-browser-title n)))) - (head (new markup - (markup '&html-head) - (ident (string-append id "-head")) - (class (markup-class n)) - (parent n) - (body header))) - (ftnote (new markup - (markup '&html-footnotes) - (ident (string-append id "-footnote")) - (class (markup-class n)) - (parent n) - (body (reverse! - (container-env-get n 'footnote-env))))) - (page (new markup - (markup '&html-page) - (ident (string-append id "-page")) - (class (markup-class n)) - (parent n) - (body (list (markup-body n) ftnote)))) - (ending (new markup - (markup '&html-ending) - (ident (string-append id "-ending")) - (class (markup-class n)) - (parent n) - (body (or (markup-option n :ending) - (let ((p (ast-document n))) - (and p (markup-option p :ending))))))) - (body (new markup - (markup '&html-body) - (ident (string-append id "-body")) - (class (markup-class n)) - (parent n) - (body (list title page ending)))) - (html (new markup - (markup '&html-html) - (ident (string-append id "-html")) - (class (markup-class n)) - (parent n) - (body (list head body))))) - ;; No file must be opened for documents. These files are - ;; directly opened by Skribe - (if (document? n) - (output html e) - (with-output-to-file (html-file n e) - (lambda () - (output html e)))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-subdocument ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-subdocument n e) - (let* ((p (ast-document n)) - (id (markup-ident n)) - (ti (let* ((nb (html-container-number n e)) - (tc (markup-option n :title)) - (ti (if (document? p) - (list (markup-option p :title) - (engine-custom e 'file-title-separator) - tc) - tc)) - (sep (engine-custom - e - (symbol-append (markup-markup n) - '-title-number-separator))) - (nti (and tc - (if (and nb (not (equal? nb ""))) - (list nb - (if (unspecified? sep) ". " sep) - ti) - ti)))) - (new markup - (markup (symbol-append '&html- (markup-markup n) '-title)) - (ident (string-append id "-title")) - (parent n) - (options '((author ()))) - (body nti))))) - (case (markup-markup n) - ((chapter) - (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) - ((section) - (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) - (&html-generic-document n ti e))) - -;*---------------------------------------------------------------------*/ -;* chapter ... @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :before (lambda (n e) - (let ((title (markup-option n :title)) - (ident (markup-ident n))) - (display "\n") - (display "\n") - (display "
") - (output (html-container-number n e) e) - (display " ") - (output (markup-option n :title) e) - (display "
"))) - :after "
") - -;; This writer is invoked only for chapters rendered inside separate files! -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'chapter-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* html-section-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-section-title n e) - (let* ((title (markup-option n :title)) - (number (markup-option n :number)) - (c (markup-class n)) - (ident (markup-ident n)) - (kind (markup-markup n)) - (tbg (engine-custom e (symbol-append kind '-title-background))) - (tfg (engine-custom e (symbol-append kind '-title-foreground))) - (tstart (engine-custom e (symbol-append kind '-title-start))) - (tstop (engine-custom e (symbol-append kind '-title-stop))) - (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) - ;; the section header - (display "\n") - (display "\n") - (if c - (printf "
" c) - (printf "
" (markup-markup n))) - (when (html-color-spec? tbg) - (display "") - (printf "
" tbg)) - (display tstart) - (if tfg (printf "" tfg)) - (if number - (begin - (output (html-container-number n e) e) - (output nsep e))) - (output title e) - (if tfg (display "\n")) - (display tstop) - (when (and (string? tbg) (> (string-length tbg) 0)) - (display "
\n")) - (display "
") - (display "")) - (newline)) - -;*---------------------------------------------------------------------*/ -;* section ... @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :before html-section-title - :after "

\n") - -;; on-file section writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'section-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "
\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "
\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsubsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "~a" - (ast-location n))) - ((html-markup-class "p") n e)) - :after "

") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :options '(:number) - :action (lambda (n e) - (printf "~a" - (string-canonicalize (container-ident n)) - (markup-option n :number)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :before (lambda (n e) - (display ""))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (height (markup-option n :height))) - (display " height 1) - (printf " size=\"~a\"" height)) - (display ">")))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when (html-color-spec? bg) - (display "\n") - (display "\n
")) - (when (html-color-spec? fg) - (display "")))) - :after (lambda (n e) - (when (html-color-spec? (markup-option n :fg)) - (display "")) - (when (html-color-spec? (markup-option n :bg)) - (display "
")))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :margin :border) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (b (markup-option n :border)) - (w (markup-option n :width))) - (display "\n\n
"))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size :face) - :before (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "" "")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s)))) - (when (or (and (number? size) (exact? size)) face) - (display "")))) - :after (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (or (and (number? size) (exact? size) (not (= size 0))) - face) - (display "")) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "" "")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s))))))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n")) - ((left) - (display "

\n")) - ((right) - (display "
")) - (else - (skribe-error 'flush - "Illegal side" - (markup-option n :side))))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n")) - ((right) - (display "
\n")) - ((left) - (display "

\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before (html-markup-class "center") - :after "\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre :before (html-markup-class "pre") :after "\n") - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (html-markup-class "pre") - :after "\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before (html-markup-class "ul") - :action (lambda (n e) - (for-each (lambda (item) - (let ((ident (and (markup? item) - (markup-ident item)))) - (display "") - (if ident ;; produce an anchor - (printf "\n\n" - (string-canonicalize ident))) - (output item e) - (display "\n"))) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before (html-markup-class "ol") - :action (lambda (n e) - (for-each (lambda (item) - (let ((ident (and (markup? item) - (markup-ident item)))) - (display "") - (if ident ;; produce an anchor - (printf "\n\n" ident)) - (output item e) - (display "\n"))) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before (html-markup-class "dl") - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " ") - (output i e) - (display "")) - (if (pair? k) k (list k))) - (display "") - (output (markup-body item) e) - (display "\n"))) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "") - (output k e) - (display " ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :options '() - :before (lambda (n e) - (display "
\n")) - :after "\n
\n") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns :legend-width) - :before (html-markup-class "br") - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (display "\n") - (output (markup-body n) e) - (display "
\n") - (output (new markup - (markup '&html-figure-legend) - (parent n) - (ident (string-append ident "-legend")) - (class (markup-class n)) - (options `((:number ,number))) - (body legend)) - e))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* &html-figure-legend ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-legend - :options '(:number) - :before (lambda (n e) - (display "
") - (let ((number (markup-option n :number)) - (legend (markup-option n :legend))) - (if number - (printf "Fig. ~a: " number) - (printf "Fig. : ")))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (display "= cp 0)) - (printf " cellpadding=\"~a\"" cp)) - (if (and (number? cs) (>= cs 0)) - (printf " cellspacing=\"~a\"" cs)) - (cond - ((symbol? cstyle) - (printf " style=\"border-collapse: ~a;\"" cstyle)) - ((string? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) - ((number? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) - (if frame - (printf " frame=\"~a\"" - (if (eq? frame 'none) "void" frame))) - (if (and rules (not (eq? rules 'header))) - (printf " rules=\"~a\"" rules)) - (display ">\n"))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (let ((bg (markup-option n :bg))) - (display ""))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* tc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(markup :width :align :valign :colspan :rowspan :bg) - :before (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td)) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (let ((v (markup-option n :valign))) - (cond - ((or (eq? v 'center) - (equal? v "center")) - "middle") - (else - v)))) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "<~a" markup) - (html-class n) - (if width (printf " width=\"~a\"" (html-width width))) - (if align (printf " align=\"~a\"" align)) - (if valign (printf " valign=\"~a\"" valign)) - (if colspan (printf " colspan=\"~a\"" colspan)) - (if rowspan (printf " rowspan=\"~a\"" rowspan)) - (when (html-color-spec? bg) - (printf " bgcolor=\"~a\"" bg)) - (display ">"))) - :after (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td))) - (printf "" markup)))) - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("gif" "jpg" "png")))))) - (if (not (string? img)) - (skribe-error 'html "Illegal image" file) - (begin - (printf "\"")")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "") -(markup-writer 'bold :before (html-markup-class "strong") :after "") -(markup-writer 'underline :before (html-markup-class "u") :after "") -(markup-writer 'strike :before (html-markup-class "strike") :after "") -(markup-writer 'emph :before (html-markup-class "em") :after "") -(markup-writer 'kbd :before (html-markup-class "kbd") :after "") -(markup-writer 'it :before (html-markup-class "em") :after "") -(markup-writer 'tt :before (html-markup-class "tt") :after "") -(markup-writer 'code :before (html-markup-class "code") :after "") -(markup-writer 'var :before (html-markup-class "var") :after "") -(markup-writer 'samp :before (html-markup-class "samp") :after "") -(markup-writer 'sc :before "" :after "") -(markup-writer 'sf :before "" :after "") -(markup-writer 'sub :before (html-markup-class "sub") :after "") -(markup-writer 'sup :before (html-markup-class "sup") :after "") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "\"" - :after "\"") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text))) - (display ") - (if text - (output text e) - (skribe-eval (tt (markup-body n)) e)) - (display "")))) - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :predicate (lambda (n e) - (and (engine-custom e 'javascript) - (or (string? (markup-body n)) - (and (pair? (markup-body n)) - (null? (cdr (markup-body n))) - (string? (car (markup-body n))))))) - :action (lambda (n e) - (let* ((body (markup-body n)) - (email (if (string? body) body (car body))) - (split (pregexp-split "@" email)) - (na (car split)) - (do (if (pair? (cdr split)) (cadr split) "")) - (nn (pregexp-replace* "[.]" na " ")) - (dd (pregexp-replace* "[.]" do " ")) - (text (markup-option n :text))) - (display "") - (output text e) - (display "\n")))) - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "")) - :after "") - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) - :before (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c)) - (f (html-file c e)) - (class (if (markup-class n) - (markup-class n) - "inbound"))) - (printf ""))) - :action (lambda (n e) - (let ((t (markup-option n :text)) - (m (markup-option n 'mark)) - (f (markup-option n :figure)) - (c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection))) - (cond - (t - (output t e)) - (f - (output (new markup - (markup '&html-figure-ref) - (body (markup-body n))) - e)) - ((or c s ss sss) - (output (new markup - (markup '&html-section-ref) - (body (markup-body n))) - e)) - - ((not m) - (output (new markup - (markup '&html-unmark-ref) - (body (markup-body n))) - e)) - (else - (display m))))) - :after "") - -;*---------------------------------------------------------------------*/ -;* &html-figure-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (or (not (markup? c)) - (not (is-markup? c 'figure))) - (display "???") - (output (markup-option c :number) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-section-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-section-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (output (markup-option c :title) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-unmark-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-unmark-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (let ((t (markup-option c :title))) - (if t - (output t e) - (let ((l (markup-option c :legend))) - (if l - (output t e) - (display - (string-canonicalize - (markup-ident c))))))))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) (output n e (markup-writer-get 'ref e))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* bib-ref+ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (output (car rs) e (markup-writer-get 'ref e)) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :before (lambda (n e) - (let* ((url (markup-option n :url)) - (class (cond - ((markup-class n) - (markup-class n)) - ((not (string? url)) - #f) - (else - (let ((l (string-length url))) - (let loop ((i 0)) - (cond - ((= i l) - #f) - ((char=? (string-ref url i) #\:) - (substring url 0 i)) - (else - (loop (+ i 1)))))))))) - (display ""))) - :action (lambda (n e) - (let ((v (markup-option n :text))) - (output (or v (markup-option n :url)) e))) - :after "") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before (html-markup-class "i") - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (if (and (number? o) (number? v)) - (markup-option-add! n :text (+ o v))) - (output n e (markup-writer-get 'ref e)) - (if (and (number? o) (number? v)) - (markup-option-add! n :text v)))) - :after "") - -;*---------------------------------------------------------------------*/ -;* page-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'page-ref - :options '(:mark :handle) - :action (lambda (n e) - (error 'page-ref:html "Not implemented yet" n))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) - (printf "")) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label base-engine))) - :after "") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (or (markup-option en 'url) - (markup-option en 'documenturl))) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-url ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-url - :action (lambda (n e) - (let* ((en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (t (bold (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) - (display "") - (for-each (lambda (h) - (let ((f (engine-custom e 'index-header-font-size))) - (if f - (skribe-eval (font :size f (bold (it h))) e) - (output h e)) - (display " "))) - (markup-body n)) - (display "") - (skribe-eval (linebreak 2) e))) - -;*---------------------------------------------------------------------*/ -;* &source-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-line-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-keyword ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &source-error ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-define ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-module ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-markup ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-thread ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-string ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-bracket ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-key ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skr/html4.skr b/skr/html4.skr deleted file mode 100644 index acb7068..0000000 --- a/skr/html4.skr +++ /dev/null @@ -1,165 +0,0 @@ -;;;; -;;;; html4.skr -- HTML 4.01 Engine -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 18-Feb-2004 11:58 (eg) -;;;; Last file update: 26-Feb-2004 21:09 (eg) -;;;; - -(define (find-children node) - (define (flat l) - (cond - ((null? l) l) - ((pair? l) (append (flat (car l)) - (flat (cdr l)))) - (else (list l)))) - - (if (markup? node) - (flat (markup-body node)) - node)) - -;;; ====================================================================== - -(let ((le (find-engine 'html))) - ;;---------------------------------------------------------------------- - ;; Customizations - ;;---------------------------------------------------------------------- - (engine-custom-set! le 'html-variant "html4") - (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") - (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") - - ;;---------------------------------------------------------------------- - ;; &html-html ... - ;;---------------------------------------------------------------------- - (markup-writer '&html-html le - :before " -\n" - :after "") - - ;;---------------------------------------------------------------------- - ;; &html-ending - ;;---------------------------------------------------------------------- - (let* ((img (engine-custom le 'html4-logo)) - (url (engine-custom le 'html4-validator)) - (bottom (list (hrule) - (table :width 100. - (tr - (td :align 'left - (font :size -1 [ - This ,(sc "Html") page has been produced by - ,(ref :url (skribe-url) :text "Skribe"). - ,(linebreak) - Last update ,(it (date)).])) - (td :align 'right :valign 'top - (ref :url url - :text (image :url img :width 88 :height 31)))))))) - (markup-writer '&html-ending le - :before "
" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval bottom e)))) - :after "
\n")) - - ;;---------------------------------------------------------------------- - ;; color ... - ;;---------------------------------------------------------------------- - (markup-writer 'color le - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when bg - (display "\n") - (display "\n
")) - (when fg - (display "")))) - :after (lambda (n e) - (when (markup-option n :fg) - (display "")) - (when (markup-option n :bg) - (display "
")))) - - ;;---------------------------------------------------------------------- - ;; font ... - ;;---------------------------------------------------------------------- - (markup-writer 'font le - :options '(:size :face) - :before (lambda (n e) - (let ((face (markup-option n :face)) - (size (let ((sz (markup-option n :size))) - (cond - ((or (unspecified? sz) (not sz)) - #f) - ((and (number? sz) (or (inexact? sz) (negative? sz))) - (format "~a%" - (+ 100 - (* 20 (inexact->exact (truncate sz)))))) - ((number? sz) - sz) - (else - (skribe-error 'font - (format "Illegal font size ~s" sz) - n)))))) - (display ""))) - :after "") - - ;;---------------------------------------------------------------------- - ;; paragraph ... - ;;---------------------------------------------------------------------- - (copy-markup-writer 'paragraph le - :validate (lambda (n e) - (let ((pred (lambda (x) - (and (container? x) - (not (memq (markup-markup x) '(font color))))))) - (not (any pred (find-children n)))))) - - ;;---------------------------------------------------------------------- - ;; roman ... - ;;---------------------------------------------------------------------- - (markup-writer 'roman le - :before "" - :after "") - - ;;---------------------------------------------------------------------- - ;; table ... - ;;---------------------------------------------------------------------- - (let ((old-writer (markup-writer-get 'table le))) - (copy-markup-writer 'table le - :validate (lambda (n e) - (not (null? (markup-body n)))))) -) diff --git a/skr/latex-simple.skr b/skr/latex-simple.skr deleted file mode 100644 index dd2eccb..0000000 --- a/skr/latex-simple.skr +++ /dev/null @@ -1,101 +0,0 @@ -;;; -;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER -;;; CE FICHIER (sion simplifie il ne rest plus grand chose) -;;; Erick 27-10-04 -;;; - - -;*=====================================================================*/ -;* scmws04/src/latex-style.skr */ -;* ------------------------------------------------------------- */ -;* Author : Damien Ciabrini */ -;* Creation : Tue Aug 24 19:17:04 2004 */ -;* Last change : Thu Oct 28 21:45:25 2004 (eg) */ -;* Copyright : 2004 Damien Ciabrini, see LICENCE file */ -;* ------------------------------------------------------------- */ -;* Custom style for Latex... */ -;*=====================================================================*/ - -(let* ((le (find-engine 'latex)) - (oa (markup-writer-get 'author le))) - ; latex class & package for the workshop - (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}") - (engine-custom-set! le 'usepackage - "\\usepackage{epsfig} -\\usepackage{workshop} -\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} - {September 22, 2004, Snowbird, Utah, USA.} -\\CopyrightYear{2004} -\\CopyrightHolder{Damien Ciabrini} -\\renewcommand{\\ttdefault}{cmtt} -") - (engine-custom-set! le 'image-format '("eps")) - (engine-custom-set! le 'source-define-color "#000080") - (engine-custom-set! le 'source-thread-color "#8080f0") - (engine-custom-set! le 'source-string-color "#000000") - - ; hyperref options - (engine-custom-set! le 'hyperref #t) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}") - ; nbsp with ~ char - (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding)) - - ; let latex process citations - (markup-writer 'bib-ref le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) (display (markup-option n :bib))) - :after "}") - (markup-writer 'bib-ref+ le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) - (let loop ((bibs (markup-option n :bib))) - (if (pair? bibs) - (begin - (display (car bibs)) - (if (pair? (cdr bibs)) (display ", ")) - (loop (cdr bibs)))))) - :after "}") - (markup-writer '&the-bibliography le - :action (lambda (n e) - (print "\\bibliographystyle{abbrv}") - (display "\\bibliography{biblio}"))) - - ; ACM-style for authors - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (print "\\numberofauthors{" (length body) "}")) - (print "\\author{"))) - :after "}\n") - (markup-writer 'author le - :options (writer-options oa) - :before "" - :action (lambda (n e) - (let ((name (markup-option n :name)) - (affiliation (markup-option n :affiliation)) - (address (markup-option n :address)) - (email (markup-option n :email))) - (define (row pre n post) - (display pre) - (output n e) - (display post) - (display "\\\\\n")) - ;; name - (if name (row "\\alignauthor " name "")) - ;; affiliation - (if affiliation (row "\\affaddr{" affiliation "}")) - ;; address - (if (pair? address) - (for-each (lambda (x) - (row "\\affaddr{" x "}")) address)) - ;; email - (if email (row "\\email{" email "}")))) - :after "") -) - -(define (include-biblio) - (the-bibliography)) diff --git a/skr/latex.skr b/skr/latex.skr deleted file mode 100644 index bc20493..0000000 --- a/skr/latex.skr +++ /dev/null @@ -1,1780 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/latex.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Thu May 26 12:59:47 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* LaTeX Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/latexe.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* latex-verbatim-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-verbatim-encoding - '((#\\ "{\\char92}") - (#\^ "{\\char94}") - (#\{ "\\{") - (#\} "\\}") - (#\& "\\&") - (#\$ "\\$") - (#\# "\\#") - (#\_ "\\_") - (#\% "\\%") - (#\~ "$_{\\mbox{\\char126}}$") - (#\ç "\\c{c}") - (#\Ç "\\c{C}") - (#\â "\\^{a}") - (#\Â "\\^{A}") - (#\à "\\`{a}") - (#\À "\\`{A}") - (#\é "\\'{e}") - (#\É "\\'{E}") - (#\è "\\`{e}") - (#\È "\\`{E}") - (#\ê "\\^{e}") - (#\Ê "\\^{E}") - (#\ù "\\`{u}") - (#\Ù "\\`{U}") - (#\û "\\^{u}") - (#\Û "\\^{U}") - (#\ø "{\\o}") - (#\ô "\\^{o}") - (#\Ô "\\^{O}") - (#\ö "\\\"{o}") - (#\Ö "\\\"{O}") - (#\î "\\^{\\i}") - (#\Î "\\^{I}") - (#\ï "\\\"{\\i}") - (#\Ï "\\\"{I}") - (#\] "{\\char93}") - (#\[ "{\\char91}") - (#\» "\\,{\\tiny{$^{\\gg}$}}") - (#\« "{\\tiny{$^{\\ll}$}}\\,"))) - -;*---------------------------------------------------------------------*/ -;* latex-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-encoding - (append '((#\| "$|$") - (#\< "$<$") - (#\> "$>$") - (#\: "{\\char58}") - (#\# "{\\char35}") - (#\Newline " %\n")) - latex-verbatim-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-tt-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-tt-encoding - (append '((#\. ".\\-") - (#\/ "/\\-")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-pre-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-pre-encoding - (append '((#\Space "\\ ") - (#\Newline "\\\\\n")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define (latex-symbol-table math) - `(("iexcl" "!`") - ("cent" "c") - ("pound" "\\pounds") - ("yen" "Y") - ("section" "\\S") - ("mul" ,(math "^-")) - ("copyright" "\\copyright") - ("lguillemet" ,(math "\\ll")) - ("not" ,(math "\\neg")) - ("degree" ,(math "^{\\small{o}}")) - ("plusminus" ,(math "\\pm")) - ("micro" ,(math "\\mu")) - ("paragraph" "\\P") - ("middot" ,(math "\\cdot")) - ("rguillemet" ,(math "\\gg")) - ("1/4" ,(math "\\frac{1}{4}")) - ("1/2" ,(math "\\frac{1}{2}")) - ("3/4" ,(math "\\frac{3}{4}")) - ("iquestion" "?`") - ("Agrave" "\\`{A}") - ("Aacute" "\\'{A}") - ("Acircumflex" "\\^{A}") - ("Atilde" "\\~{A}") - ("Amul" "\\\"{A}") - ("Aring" "{\\AA}") - ("AEligature" "{\\AE}") - ("Oeligature" "{\\OE}") - ("Ccedilla" "{\\c{C}}") - ("Egrave" "{\\`{E}}") - ("Eacute" "{\\'{E}}") - ("Ecircumflex" "{\\^{E}}") - ("Euml" "\\\"{E}") - ("Igrave" "{\\`{I}}") - ("Iacute" "{\\'{I}}") - ("Icircumflex" "{\\^{I}}") - ("Iuml" "\\\"{I}") - ("ETH" "D") - ("Ntilde" "\\~{N}") - ("Ograve" "\\`{O}") - ("Oacute" "\\'{O}") - ("Ocurcumflex" "\\^{O}") - ("Otilde" "\\~{O}") - ("Ouml" "\\\"{O}") - ("times" ,(math "\\times")) - ("Oslash" "\\O") - ("Ugrave" "\\`{U}") - ("Uacute" "\\'{U}") - ("Ucircumflex" "\\^{U}") - ("Uuml" "\\\"{U}") - ("Yacute" "\\'{Y}") - ("szlig" "\\ss") - ("agrave" "\\`{a}") - ("aacute" "\\'{a}") - ("acircumflex" "\\^{a}") - ("atilde" "\\~{a}") - ("amul" "\\\"{a}") - ("aring" "\\aa") - ("aeligature" "\\ae") - ("oeligature" "{\\oe}") - ("ccedilla" "{\\c{c}}") - ("egrave" "{\\`{e}}") - ("eacute" "{\\'{e}}") - ("ecircumflex" "{\\^{e}}") - ("euml" "\\\"{e}") - ("igrave" "{\\`{\\i}}") - ("iacute" "{\\'{\\i}}") - ("icircumflex" "{\\^{\\i}}") - ("iuml" "\\\"{\\i}") - ("ntilde" "\\~{n}") - ("ograve" "\\`{o}") - ("oacute" "\\'{o}") - ("ocurcumflex" "\\^{o}") - ("otilde" "\\~{o}") - ("ouml" "\\\"{o}") - ("divide" ,(math "\\div")) - ("oslash" "\\o") - ("ugrave" "\\`{u}") - ("uacute" "\\'{u}") - ("ucircumflex" "\\^{u}") - ("uuml" "\\\"{u}") - ("yacute" "\\'{y}") - ("ymul" "\\\"{y}") - ;; Greek - ("Alpha" "A") - ("Beta" "B") - ("Gamma" ,(math "\\Gamma")) - ("Delta" ,(math "\\Delta")) - ("Epsilon" "E") - ("Zeta" "Z") - ("Eta" "H") - ("Theta" ,(math "\\Theta")) - ("Iota" "I") - ("Kappa" "K") - ("Lambda" ,(math "\\Lambda")) - ("Mu" "M") - ("Nu" "N") - ("Xi" ,(math "\\Xi")) - ("Omicron" "O") - ("Pi" ,(math "\\Pi")) - ("Rho" "P") - ("Sigma" ,(math "\\Sigma")) - ("Tau" "T") - ("Upsilon" ,(math "\\Upsilon")) - ("Phi" ,(math "\\Phi")) - ("Chi" "X") - ("Psi" ,(math "\\Psi")) - ("Omega" ,(math "\\Omega")) - ("alpha" ,(math "\\alpha")) - ("beta" ,(math "\\beta")) - ("gamma" ,(math "\\gamma")) - ("delta" ,(math "\\delta")) - ("epsilon" ,(math "\\varepsilon")) - ("zeta" ,(math "\\zeta")) - ("eta" ,(math "\\eta")) - ("theta" ,(math "\\theta")) - ("iota" ,(math "\\iota")) - ("kappa" ,(math "\\kappa")) - ("lambda" ,(math "\\lambda")) - ("mu" ,(math "\\mu")) - ("nu" ,(math "\\nu")) - ("xi" ,(math "\\xi")) - ("omicron" ,(math "\\o")) - ("pi" ,(math "\\pi")) - ("rho" ,(math "\\rho")) - ("sigmaf" ,(math "\\varsigma")) - ("sigma" ,(math "\\sigma")) - ("tau" ,(math "\\tau")) - ("upsilon" ,(math "\\upsilon")) - ("phi" ,(math "\\varphi")) - ("chi" ,(math "\\chi")) - ("psi" ,(math "\\psi")) - ("omega" ,(math "\\omega")) - ("thetasym" ,(math "\\vartheta")) - ("piv" ,(math "\\varpi")) - ;; punctuation - ("bullet" ,(math "\\bullet")) - ("ellipsis" ,(math "\\ldots")) - ("weierp" ,(math "\\wp")) - ("image" ,(math "\\Im")) - ("real" ,(math "\\Re")) - ("tm" ,(math "^{\\sc\\tiny{tm}}")) - ("alef" ,(math "\\aleph")) - ("<-" ,(math "\\leftarrow")) - ("<--" ,(math "\\longleftarrow")) - ("uparrow" ,(math "\\uparrow")) - ("->" ,(math "\\rightarrow")) - ("-->" ,(math "\\longrightarrow")) - ("downarrow" ,(math "\\downarrow")) - ("<->" ,(math "\\leftrightarrow")) - ("<-->" ,(math "\\longleftrightarrow")) - ("<+" ,(math "\\hookleftarrow")) - ("<=" ,(math "\\Leftarrow")) - ("<==" ,(math "\\Longleftarrow")) - ("Uparrow" ,(math "\\Uparrow")) - ("=>" ,(math "\\Rightarrow")) - ("==>" ,(math "\\Longrightarrow")) - ("Downarrow" ,(math "\\Downarrow")) - ("<=>" ,(math "\\Leftrightarrow")) - ("<==>" ,(math "\\Longleftrightarrow")) - ;; Mathematical operators - ("forall" ,(math "\\forall")) - ("partial" ,(math "\\partial")) - ("exists" ,(math "\\exists")) - ("emptyset" ,(math "\\emptyset")) - ("infinity" ,(math "\\infty")) - ("nabla" ,(math "\\nabla")) - ("in" ,(math "\\in")) - ("notin" ,(math "\\notin")) - ("ni" ,(math "\\ni")) - ("prod" ,(math "\\Pi")) - ("sum" ,(math "\\Sigma")) - ("asterisk" ,(math "\\ast")) - ("sqrt" ,(math "\\surd")) - ("propto" ,(math "\\propto")) - ("angle" ,(math "\\angle")) - ("and" ,(math "\\wedge")) - ("or" ,(math "\\vee")) - ("cap" ,(math "\\cap")) - ("cup" ,(math "\\cup")) - ("integral" ,(math "\\int")) - ("models" ,(math "\\models")) - ("vdash" ,(math "\\vdash")) - ("dashv" ,(math "\\dashv")) - ("sim" ,(math "\\sim")) - ("cong" ,(math "\\cong")) - ("approx" ,(math "\\approx")) - ("neq" ,(math "\\neq")) - ("equiv" ,(math "\\equiv")) - ("le" ,(math "\\leq")) - ("ge" ,(math "\\geq")) - ("subset" ,(math "\\subset")) - ("supset" ,(math "\\supset")) - ("subseteq" ,(math "\\subseteq")) - ("supseteq" ,(math "\\supseteq")) - ("oplus" ,(math "\\oplus")) - ("otimes" ,(math "\\otimes")) - ("perp" ,(math "\\perp")) - ("mid" ,(math "\\mid")) - ("lceil" ,(math "\\lceil")) - ("rceil" ,(math "\\rceil")) - ("lfloor" ,(math "\\lfloor")) - ("rfloor" ,(math "\\rfloor")) - ("langle" ,(math "\\langle")) - ("rangle" ,(math "\\rangle")) - ;; Misc - ("loz" ,(math "\\diamond")) - ("spades" ,(math "\\spadesuit")) - ("clubs" ,(math "\\clubsuit")) - ("hearts" ,(math "\\heartsuit")) - ("diams" ,(math "\\diamondsuit")) - ("euro" "\\euro{}") - ;; LaTeX - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;*---------------------------------------------------------------------*/ -;* latex-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-engine - (default-engine-set! - (make-engine 'latex - :version 1.0 - :format "latex" - :delegate (find-engine 'base) - :filter (make-string-replace latex-encoding) - :custom '((documentclass "\\documentclass{article}") - (usepackage "\\usepackage{epsfig}\n") - (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n") - (postdocument #f) - (maketitle "\\date{}\n\\maketitle") - (%font-size 0) - ;; color - (color #t) - (color-usepackage "\\usepackage{color}\n") - ;; hyperref - (hyperref #t) - (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n") - ;; source fontification - (source-color #t) - (source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - (image-format ("eps")) - (index-page-ref #t)) - :symbol-table (latex-symbol-table - (lambda (m) - (format "\\begin{math}~a\\end{math}" m)))))) - -;*---------------------------------------------------------------------*/ -;* latex-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-title-engine - (make-engine 'latex-title - :version 1.0 - :format "latex-title" - :delegate latex-engine - :filter (make-string-replace latex-encoding) - :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m))))) - -;*---------------------------------------------------------------------*/ -;* latex-color? ... */ -;*---------------------------------------------------------------------*/ -(define (latex-color? e) - (engine-custom e 'color)) - -;*---------------------------------------------------------------------*/ -;* LaTeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (LaTeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\LaTeX\\ " "\\LaTeX")) - "LaTeX")) - -;*---------------------------------------------------------------------*/ -;* TeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (TeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\TeX\\ " "\\TeX")) - "TeX")) - -;*---------------------------------------------------------------------*/ -;* latex ... */ -;*---------------------------------------------------------------------*/ -(define-markup (!latex fmt #!rest opt) - (if (engine-format? "latex") - (apply ! fmt opt) - #f)) - -;*---------------------------------------------------------------------*/ -;* latex-width ... */ -;*---------------------------------------------------------------------*/ -(define (latex-width width) - (if (and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\linewidth") - (string-append (number->string width) "pt"))) - -;*---------------------------------------------------------------------*/ -;* latex-font-size ... */ -;*---------------------------------------------------------------------*/ -(define (latex-font-size size) - (case size - ((4) "Huge") - ((3) "huge") - ((2) "Large") - ((1) "large") - ((0) "normalsize") - ((-1) "small") - ((-2) "footnotesize") - ((-3) "scriptsize") - ((-4) "tiny") - (else (if (number? size) - (if (< size 0) "tiny" "Huge") - "normalsize")))) - -;*---------------------------------------------------------------------*/ -;* *skribe-latex-color-table* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-latex-color-table* #f) - -;*---------------------------------------------------------------------*/ -;* latex-declare-color ... */ -;*---------------------------------------------------------------------*/ -(define (latex-declare-color name rgb) - (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) - -;*---------------------------------------------------------------------*/ -;* skribe-get-latex-color ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-latex-color spec) - (let ((c (and (hashtable? *skribe-latex-color-table*) - (hashtable-get *skribe-latex-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'latex "Can't find color" spec) - c))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->latex-rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->latex-rgb spec) - (receive (r g b) - (skribe-color->rgb spec) - (cond - ((and (= r 0) (= g 0) (= b 0)) - "0.,0.,0.") - ((and (= r #xff) (= g #xff) (= b #xff)) - "1.,1.,1.") - (else - (let ((ff (exact->inexact #xff))) - (format "~a,~a,~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-latex-declare-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-latex-declare-colors colors) - (set! *skribe-latex-color-table* (make-hashtable)) - (for-each (lambda (spec) - (let ((old (hashtable-get *skribe-latex-color-table* spec))) - (if (not (string? old)) - (let ((name (symbol->string (gensym 'c)))) - ;; bind the color - (hashtable-put! *skribe-latex-color-table* spec name) - ;; and emit a latex declaration - (latex-declare-color - name - (skribe-color->latex-rgb spec)))))) - colors)) - -;*---------------------------------------------------------------------*/ -;* &~ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&~ - :before "~" - :action #f) - -;*---------------------------------------------------------------------*/ -;* &latex-table-start */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-start - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (printf "\\begin{tabular*}{~a}" (latex-width width)) - (display "\\begin{tabular}"))))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-stop */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-stop - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (display "\\end{tabular*}\n") - (display "\\end{tabular}\n"))))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :env) - :before (lambda (n e) - ;; documentclass - (let ((dc (engine-custom e 'documentclass))) - (if dc - (begin (display dc) (newline)) - (display "\\documentclass{article}\n"))) - (if (latex-color? e) - (display (engine-custom e 'color-usepackage))) - (if (engine-custom e 'hyperref) - (display (engine-custom e 'hyperref-usepackage))) - ;; usepackage - (let ((pa (engine-custom e 'usepackage))) - (if pa (begin (display pa) (newline)))) - ;; colors - (if (latex-color? e) - (begin - (skribe-use-color! (engine-custom e 'source-comment-color)) - (skribe-use-color! (engine-custom e 'source-define-color)) - (skribe-use-color! (engine-custom e 'source-module-color)) - (skribe-use-color! (engine-custom e 'source-markup-color)) - (skribe-use-color! (engine-custom e 'source-thread-color)) - (skribe-use-color! (engine-custom e 'source-string-color)) - (skribe-use-color! (engine-custom e 'source-bracket-color)) - (skribe-use-color! (engine-custom e 'source-type-color)) - (display "\n%% colors\n") - (skribe-latex-declare-colors (skribe-get-used-colors)) - (display "\n\n"))) - ;; predocument - (let ((pd (engine-custom e 'predocument))) - (when pd (display pd) (newline))) - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&latex-title) - (body t)) - e - :env `((parent ,n))))) - ;; author - (let ((a (markup-option n :author))) - (when a - (skribe-eval (new markup - (markup '&latex-author) - (body a)) - e - :env `((parent ,n))))) - ;; document - (display "\\begin{document}\n") - ;; postdocument - (let ((pd (engine-custom e 'postdocument))) - (if pd (begin (display pd) (newline)))) - ;; maketitle - (let ((mt (engine-custom e 'maketitle))) - (if mt (begin (display mt) (newline))))) - :action (lambda (n e) - (output (markup-body n) e)) - :after (lambda (n e) - (display "\n\\end{document}\n"))) - -;*---------------------------------------------------------------------*/ -;* &latex-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-title - :before "\\title{" - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* &latex-author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-author - :before "\\author{\\centerline{\n" - :action (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (begin - (output (new markup - (markup '&latex-table-start) - (class "&latex-author-table")) - e) - (printf "{~a}\n" (make-string (length body) #\c)) - (let loop ((as body)) - (output (car as) e) - (if (pair? (cdr as)) - (begin - (display " & ") - (loop (cdr as))))) - (display "\\\\\n") - (output (new markup - (markup '&latex-table-stop) - (class "&latex-author-table")) - e)) - (output body e)))) - :after "}}\n") - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{~a}\n" - (case (markup-option n :align) - ((left) "l") - ((right) "r") - (else "c")))) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (cond - ((pair? address) - (for-each row address)) - ((string? address) - (row address))) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :predicate (lambda (n e) (markup-option n :photo)) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{cc}\n")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (output photo e) - (display " & ") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display "\\\\\n"))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\tableofcontents\n"))) - -;*---------------------------------------------------------------------*/ -;* latex-block-before ... */ -;*---------------------------------------------------------------------*/ -(define (latex-block-before m) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a~a{" m (if (not num) "*" "")) - (output (markup-option n :title) latex-title-engine) - (display "}\n") - (when num - (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) - -;*---------------------------------------------------------------------*/ -;* section ... .. @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (latex-block-before 'chapter)) - -;*---------------------------------------------------------------------*/ -;* section ... . @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (latex-block-before 'section)) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsection)) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsubsection)) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" - (ast-location n))) - (display "\\noindent ")) - :after "\\par\n") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :action (lambda (n e) - (display "\\makebox[\\linewidth]{}"))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '() - :before "\\hrulefill" - :action #f) - -;*---------------------------------------------------------------------*/ -;* latex-color-counter */ -;*---------------------------------------------------------------------*/ -(define latex-color-counter 1) - -;*---------------------------------------------------------------------*/ -;* latex-color ... */ -;*---------------------------------------------------------------------*/ -(define latex-color - (lambda (bg fg n e) - (if (not (latex-color? e)) - (output n e) - (begin - (if bg - (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) - (set! latex-color-counter (+ latex-color-counter 1)) - (if fg - (begin - (printf "\\textcolor{~a}{" (skribe-get-latex-color fg)) - (output n e) - (display "}")) - (output n e)) - (set! latex-color-counter (- latex-color-counter 1)) - (if bg - (printf "\\egroup\\colorbox{~a}{\\box~a}%\n" - (skribe-get-latex-color bg) latex-color-counter)))))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width) - :action (lambda (n e) - (let* ((w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (m (markup-option n :margin)) - (tw (cond - ((not w) - #f) - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (when bg - (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" - (latex-width m))) - (output (new markup - (markup '&latex-table-start) - (class "color")) - e) - (if tw - (printf "{p{~a}}\n" tw) - (printf "{l}\n"))) - (latex-color bg fg (markup-body n) e) - (when bg - (output (new markup - (markup '&latex-table-stop) - (class "color")) - e) - (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n"))))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") - (let ((m (markup-option n :margin))) - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) - (newline)) - :action (lambda (n e) - (let* ((b (markup-option n :border)) - (w (markup-option n :width)) - (tw (cond - ((not w) - ".96\\linewidth") - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (output (new markup - (markup '&latex-table-start) - (class "frame")) - e) - (if (and (integer? b) (> b 0)) - (begin - (printf "{|p{~a}|}\\hline\n" tw) - (output (markup-body n) e) - (display "\\\\\\hline\n")) - (begin - (printf "{p{~a}}\n" tw) - (output (markup-body n) e))) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (let ((n (engine-custom e '%font-size))) - (if (number? n) - n - 0))) - (ns (cond - ((and (integer? size) (exact? size)) - (if (> size 0) - size - (+ cs size))) - ((and (number? size) (inexact? size)) - (+ cs (inexact->exact size))) - ((string? size) - (let ((nb (string->number size))) - (if (not (number? nb)) - (skribe-error - 'font - (format "Illegal font size ~s" size) - nb) - (+ cs nb)))))) - (ne (make-engine (gensym 'latex) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((%font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\~a{" (latex-font-size ns)) - (output (markup-body n) ne) - (display "}}")))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\begin{center}\n")) - ((left) - (display "\\begin{flushleft}")) - ((right) - (display "\\begin{flushright}")))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\end{center}\n")) - ((left) - (display "\\end{flushleft}\n")) - ((right) - (display "\\end{flushright}\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\\begin{center}\n" - :after "\\end{center}\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "pre")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "prog")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* &prog-line ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&prog-line - :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) - :after "\\\\\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before "\\begin{itemize}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{itemize} ") - -(markup-writer 'itemize - :predicate (lambda (n e) (markup-option n :symbol)) - :options '(:symbol) - :before (lambda (n e) - (display "\\begin{list}{") - (output (markup-option n :symbol) e) - (display "}{}") - (newline)) - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{list}\n") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before "\\begin{enumerate}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{enumerate}\n") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before "\\begin{description}\n" - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " \\item[") - (output i e) - (display "]\n")) - (if (pair? k) k (list k))) - (output (markup-body item) e))) - (markup-body n))) - :after "\\end{description}\n") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "[") - (output k e) - (display "] ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :before "\n\\begin{quote}\n" - :after "\n\\end{quote}") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend)) - (mc (markup-option n :multicolumns))) - (display (if mc - "\\begin{figure*}[!th]\n" - "\\begin{figure}[ht]\n")) - (output (markup-body n) e) - (printf "\\caption{\\label{~a}" (string-canonicalize ident)) - (output legend e) - (display (if mc - "}\\end{figure*}\n" - "}\\end{figure}\n"))))) - -;*---------------------------------------------------------------------*/ -;* table-column-number ... */ -;* ------------------------------------------------------------- */ -;* Computes how many columns are contained in a table. */ -;*---------------------------------------------------------------------*/ -(define (table-column-number t) - (define (row-columns row) - (let luup ((cells (markup-body row)) - (nbcols 0)) - (cond - ((null? cells) - nbcols) - ((pair? cells) - (luup (cdr cells) - (+ nbcols (markup-option (car cells) :colspan)))) - (else - (skribe-type-error 'tr "Illegal tr body, " row "pair"))))) - (let loop ((rows (markup-body t)) - (nbcols 0)) - (if (null? rows) - nbcols - (loop (cdr rows) - (max (row-columns (car rows)) nbcols))))) - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:width :frame :rules :cellstyle) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (nbcols (table-column-number n)) - (id (markup-ident n)) - (cla (markup-class n)) - (rows (markup-body n))) - ;; the table header - (output (new markup - (markup '&latex-table-start) - (class "table") - (options `((width ,width)))) - e) - ;; store the actual number of columns - (markup-option-add! n '&nbcols nbcols) - ;; compute the table header - (let ((cols (cond - ((= nbcols 0) - (skribe-error 'table - "Illegal empty table" - n)) - ((or (not width) (= nbcols 1)) - (make-string nbcols #\c)) - (else - (let ((v (make-vector - (- nbcols 1) - "@{\\extracolsep{\\fill}}c"))) - (apply string-append - (cons "c" (vector->list v)))))))) - (case frame - ((none) - (printf "{~a}\n" cols)) - ((border box) - (printf "{|~a|}" cols) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((above hsides) - (printf "{~a}" cols) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((vsides) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (printf "{|~a|}\n" cols)) - ((lhs) - (markup-option-add! n '&lhs #t) - (printf "{|~a}\n" cols)) - ((rhs) - (markup-option-add! n '&rhs #t) - (printf "{~a|}\n" cols)) - (else - (printf "{~a}\n" cols))) - ;; mark each row with appropriate '&tl (top-line) - ;; and &bl (bottom-line) options - (when (pair? rows) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&tl #t)))) - (if (eq? rules 'header) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&bl #t)))) - (when (and (pair? (cdr rows)) - (memq rules '(rows all))) - (for-each (lambda (row) - (if (is-markup? row 'tr) - (markup-option-add! row '&bl #t))) - rows) - (markup-option-add! (car (last-pair rows)) '&bl #f)) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((lrow (car (last-pair rows)))) - (if (is-markup? lrow 'tr) - (markup-option-add! lrow '&bl #t)))))))) - :after (lambda (n e) - (case (markup-option n :frame) - ((hsides below box border) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-below" (markup-ident n))) - (class "table-hline-below")) - e))) - (output (new markup - (markup '&latex-table-stop) - (class "table") - (options `((width ,(markup-option n :width))))) - e))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-hline */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-hline - :action "\\hline\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '() - :action (lambda (n e) - (let* ((parent (ast-parent n)) - (_ (if (not (is-markup? parent 'table)) - (skribe-type-error 'tr "Illegal parent, " parent - "#"))) - (nbcols (markup-option parent '&nbcols)) - (lhs (markup-option parent '&lhs)) - (rhs (markup-option parent '&rhs)) - (rules (markup-option parent :rules)) - (collapse (eq? (markup-option parent :cellstyle) - 'collapse)) - (vrules (memq rules '(cols all))) - (cells (markup-body n))) - (if (markup-option n '&tl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e)) - (if (> nbcols 0) - (let laap ((nbc nbcols) - (cs cells)) - (if (null? cs) - (when (> nbc 1) - (display " & ") - (laap (- nbc 1) cs)) - (let* ((c (car cs)) - (nc (- nbc (markup-option c :colspan)))) - (when (= nbcols nbc) - (cond - ((and lhs vrules (not collapse)) - (markup-option-add! c '&lhs "||")) - ((or lhs vrules) - (markup-option-add! c '&lhs #\|)))) - (when (= nc 0) - (cond - ((and rhs vrules (not collapse)) - (markup-option-add! c '&rhs "||")) - ((or rhs vrules) - (markup-option-add! c '&rhs #\|)))) - (when (and vrules (> nc 0) (< nc nbcols)) - (markup-option-add! c '&rhs #\|)) - (output c e) - (when (> nc 0) - (display " & ") - (laap nc (cdr cs))))))))) - :after (lambda (n e) - (display "\\\\") - (if (markup-option n '&bl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e) - (newline)))) - -;*---------------------------------------------------------------------*/ -;* tc */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :action (lambda (n e) - (let ((id (markup-ident n)) - (cla (markup-class n))) - (let* ((o0 (markup-body n)) - (o1 (if (eq? (markup-option n 'markup) 'th) - (new markup - (markup '&latex-th) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o0)) - o0)) - (o2 (if (markup-option n :width) - (new markup - (markup '&latex-tc-parbox) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o1)) - o1)) - (o3 (if (or (> (markup-option n :colspan) 1) - (not (eq? (markup-option n :align) - 'center)) - (markup-option n '&lhs) - (markup-option n '&rhs)) - (new markup - (markup '&latex-tc-multicolumn) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o2)) - o2))) - (output o3 e))))) - -;*---------------------------------------------------------------------*/ -;* &latex-th ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-th - :before "\\textsf{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-parbox ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-parbox - :before (lambda (n e) - (let ((width (markup-option n :width)) - (valign (markup-option n :valign))) - (printf "\\parbox{~a}{" (latex-width width)))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-multicolumn ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-multicolumn - :before (lambda (n e) - (let ((colspan (markup-option n :colspan)) - (lhs (or (markup-option n '&lhs) "")) - (rhs (or (markup-option n '&rhs) "")) - (align (case (markup-option n :align) - ((left) #\l) - ((center) #\c) - ((right) #\r) - (else #\c)))) - (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height :zoom) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (zoom (markup-option n :zoom)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("eps")))))) - (if (not (string? img)) - (skribe-error 'latex "Illegal image" file) - (begin - (printf "\\epsfig{file=~a" (strip-ref-base img)) - (if width (printf ", width=~a" (latex-width width))) - (if height (printf ", height=~apt" height)) - (if zoom (printf ", zoom=\"~a\"" zoom)) - (display "}")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "{\\textrm{" :after "}}") -(markup-writer 'bold :before "{\\textbf{" :after "}}") -(markup-writer 'underline :before "{\\underline{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\textit{" :after "}}") -(markup-writer 'code :before "{\\texttt{" :after "}}") -(markup-writer 'var :before "{\\texttt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}") -(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}") - -(markup-writer 'tt - :before "{\\texttt{" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-tt-encoding) - :custom (engine-customs e) - :symbol-table (engine-symbol-table e)))) - (output (markup-body n) ne))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "``" - :after "''") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :before "{\\texttt{" - :action (lambda (n e) - (let ((text (markup-option n :text))) - (output (or text (markup-body n)) e))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) - :action (lambda (n e) - (let ((t (markup-option n :text))) - (if t - (begin - (output t e) - (output "~" e (markup-writer-get '&~ e)))))) - :after (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c))) - (if (markup-option n :page) - (printf "\\begin{math}{\\pageref{~a}}\\end{math}" - (string-canonicalize id)) - (printf "\\ref{~a}" - (string-canonicalize id)))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (output (markup-option (handle-ast (markup-body n)) :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* bib-ref+ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (invoke (writer-action (markup-writer-get 'bib-ref e)) - (car rs) - e) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-option n :url))) - (if (not text) - (output url e) - (output text e))))) - -;*---------------------------------------------------------------------*/ -;* url-ref hyperref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let ((body (markup-option n :text)) - (url (markup-option n :url))) - (if (and body (not (equal? body url))) - (begin - (display "\\href{") - (display url) - (display "}{") - (output body e) - (display "}")) - (begin - (display "\\href{") - (display url) - (printf "}{~a}" url)))))) - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before "{\\textit{" - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (cond - ((and (number? o) (number? v)) - (display (+ o v))) - (else - (display v))))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[21]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - \\itemsep 0pt - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "\\item[{\\char91}" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "{\\char93}] ") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-url ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-url - :action (lambda (n e) - (let* ((en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (t (bold (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) - -;*---------------------------------------------------------------------*/ -;* &source-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-line-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-keyword ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (underline (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &source-error ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'error-color) cc) - (color :fg cc (underline n1)) - (underline n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-define ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-module ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-markup ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-thread ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-string ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-bracket ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-key ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skr/xml.skr b/skr/xml.skr deleted file mode 100644 index 784b6f0..0000000 --- a/skr/xml.skr +++ /dev/null @@ -1,111 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/xml.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Generic XML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/xmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* xml-engine ... */ -;*---------------------------------------------------------------------*/ -(define xml-engine - ;; setup the xml engine - (default-engine-set! - (make-engine 'xml - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@")))))) - -;*---------------------------------------------------------------------*/ -;* markup ... */ -;*---------------------------------------------------------------------*/ -(let ((xml-margin 0)) - (define (make-margin) - (make-string xml-margin #\space)) - (define (xml-attribute? val) - (cond - ((or (string? val) (number? val) (boolean? val)) - #t) - ((list? val) - (every? xml-attribute? val)) - (else - #f))) - (define (xml-attribute att val) - (let ((s (keyword->string att))) - (printf " ~a=\"" (substring s 1 (string-length s))) - (let loop ((val val)) - (cond - ((or (string? val) (number? val)) - (display val)) - ((boolean? val) - (display (if val "true" "false"))) - ((pair? val) - (for-each loop val)) - (else - #f))) - (display #\"))) - (define (xml-option opt val e) - (let* ((m (make-margin)) - (ks (keyword->string opt)) - (s (substring ks 1 (string-length ks)))) - (printf "~a<~a>\n" m s) - (output val e) - (printf "~a\n" m s))) - (define (xml-options n e) - ;; display the true options - (let ((opts (filter (lambda (o) - (and (keyword? (car o)) - (not (xml-attribute? (cadr o))))) - (markup-options n)))) - (if (pair? opts) - (let ((m (make-margin))) - (display m) - (display "\n") - (set! xml-margin (+ xml-margin 1)) - (for-each (lambda (o) - (xml-option (car o) (cadr o) e)) - opts) - (set! xml-margin (- xml-margin 1)) - (display m) - (display "\n"))))) - (markup-writer #t - :options 'all - :before (lambda (n e) - (printf "~a<~a" (make-margin) (markup-markup n)) - ;; display the xml attributes - (for-each (lambda (o) - (if (and (keyword? (car o)) - (xml-attribute? (cadr o))) - (xml-attribute (car o) (cadr o)))) - (markup-options n)) - (set! xml-margin (+ xml-margin 1)) - (display ">\n")) - :action (lambda (n e) - ;; options - (xml-options n e) - ;; body - (output (markup-body n) e)) - :after (lambda (n e) - (printf "~a\n" (make-margin) (markup-markup n)) - (set! xml-margin (- xml-margin 1))))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/src/guile/README b/src/guile/README new file mode 100644 index 0000000..1b9a6c4 --- /dev/null +++ b/src/guile/README @@ -0,0 +1,42 @@ +Skribilo +======== + +Skribilo is a port of Skribe to GNU Guile. + +Here are a few goals. + +* Usability + +** Integration with Guile's module system + +** Better error handling, automatic back-traces, etc. + +* Font-ends (readers) + +** Implement a new front-end mechanism (see `(skribilo reader)') + +** Skribe front-end (read Skribe syntax) + +** Texinfo front-end + +** Simple markup front-end (à la `txt2tags', Emacs' outline mode, or Wiki) + +* Back-ends (engines) + +** Easier to plug-in new back-ends (no need to modify the source) + +** Better HTML (or XHTML?) back-end + +** Lout back-end (including automatic `lout' invocation?) + +** Info back-end + +* Packages + +** Pie charts + +** Equations + + + +;;; arch-tag: 2d0a6235-5c09-4930-998c-56a4de2c0aca diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm index c352f7f..ae21fab 100755 --- a/src/guile/skribilo.scm +++ b/src/guile/skribilo.scm @@ -1,7 +1,7 @@ #!/bin/sh # aside from this initial boilerplate, this is actually -*- scheme -*- code main='(module-ref (resolve-module '\''(skribilo)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" +exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@" !# ;;;; @@ -42,17 +42,11 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" ;; Allow for this `:style' of keywords. (read-set! keywords 'prefix) -;; Allow for DSSSL-style keywords (i.e. `#!key', etc.). -;; See http://lists.gnu.org/archive/html/guile-devel/2005-06/msg00060.html -;; for details. -(read-hash-extend #\! (lambda (chr port) - (symbol->keyword (read port)))) - (let ((gensym-orig gensym)) ;; In Skribe, `gensym' expects a symbol as its (optional) argument, while ;; Guile's `gensym' expect a string. XXX (set! gensym - (lambda (. args) + (lambda args (if (null? args) (gensym-orig) (let ((the-arg (car args))) @@ -64,45 +58,29 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" (skribe-error 'gensym "Invalid argument type" the-arg)))))))) -; (use-modules (skribe eval) -; (skribe configure) -; (skribe runtime) -; (skribe engine) -; (skribe writer) -; (skribe verify) -; (skribe output) -; (skribe biblio) -; (skribe prog) -; (skribe resolve) -; (skribe source) -; (skribe lisp) -; (skribe xml) -; (skribe c) -; (skribe debug) -; (skribe color)) - -(use-modules (skribe runtime) - (skribe configure) - (skribe eval) - (skribe engine) - (skribe types) ;; because `new' is a macro and refers to classes - - (oop goops) ;; because `new' is a macro - (ice-9 optargs) - (ice-9 getopt-long)) +(set! %load-hook + (lambda (file) + (format #t "~~ loading `~a'...~%" file))) + +(define-module (skribilo)) -(load "skribe/lib.scm") +(use-modules (skribilo module) + (skribilo runtime) + (skribilo evaluator) + (skribilo types) + (skribilo engine) + (skribilo debug) + (skribilo vars) + (skribilo lib) -(load "../common/configure.scm") -(load "../common/param.scm") -(load "../common/lib.scm") -(load "../common/sui.scm") -(load "../common/index.scm") + (ice-9 optargs) + (ice-9 getopt-long)) -;; Markup definitions... -(load "../common/api.scm") + + +;;; FIXME: With my `#:reader' thing added to `define-module', @@ -115,7 +93,7 @@ specifications." ,@(if alternate `((single-char ,(string-ref alternate 0))) '()) - (value #f))) + (value ,(if arg #t #f)))) (define (raw-options->getopt-long options) "Converts @var{options} to a getopt-long-compatible representation." @@ -130,9 +108,9 @@ specifications." (("target" :alternate "t" :arg target :help "sets the output format to ") (set! engine (string->symbol target))) - (("I" :arg path :help "adds to Skribe path") + (("load-path" :alternate "I" :arg path :help "adds to Skribe path") (set! paths (cons path paths))) - (("B" :arg path :help "adds to bibliography path") + (("bib-path" :alternate "B" :arg path :help "adds to bibliography path") (skribe-bib-path-set! (cons path (skribe-bib-path)))) (("S" :arg path :help "adds to source path") (skribe-source-path-set! (cons path (skribe-source-path)))) @@ -247,7 +225,7 @@ Processes a Skribilo/Skribe source file and produces its output. ")) (define (skribilo-show-version) - (format #t "skribilo ~a~%" (skribe-release))) + (format #t "skribilo ~a~%" (skribilo-release))) ;;;; ====================================================================== ;;;; @@ -387,16 +365,20 @@ Processes a Skribilo/Skribe source file and produces its output. ;;;; S K R I B E ;;;; ;;;; ====================================================================== +; (define (doskribe) +; (let ((e (find-engine *skribe-engine*))) +; (if (and (engine? e) (pair? *skribe-precustom*)) +; (for-each (lambda (cv) +; (engine-custom-set! e (car cv) (cdr cv))) +; *skribe-precustom*)) +; (if (pair? *skribe-src*) +; (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) +; *skribe-src*) +; (skribe-eval-port (current-input-port) *skribe-engine*)))) + (define (doskribe) - (let ((e (find-engine *skribe-engine*))) - (if (and (engine? e) (pair? *skribe-precustom*)) - (for-each (lambda (cv) - (engine-custom-set! e (car cv) (cdr cv))) - *skribe-precustom*)) - (if (pair? *skribe-src*) - (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) - *skribe-src*) - (skribe-eval-port (current-input-port) *skribe-engine*)))) + (set-current-module (make-run-time-module)) + (skribe-eval-port (current-input-port) *skribe-engine*)) ;;;; ====================================================================== @@ -404,42 +386,81 @@ Processes a Skribilo/Skribe source file and produces its output. ;;;; M A I N ;;;; ;;;; ====================================================================== -(define (skribilo . args) - (let* ((options (getopt-long (cons "skribilo" args) skribilo-options)) - (target (option-ref options 'target #f)) +(define-public (skribilo . args) + (let* ((options (getopt-long (cons "skribilo" args) + skribilo-options)) + (engine (string->symbol + (option-ref options 'target "html"))) + (debugging-level (option-ref options 'debug 0)) + (load-path (option-ref options 'load-path ".")) + (bib-path (option-ref options 'bib-path ".")) + (preload '()) + (variants '()) + (help-wanted (option-ref options 'help #f)) (version-wanted (option-ref options 'version #f))) + ;; Set up the debugging infrastructure. + (debug-enable 'debug) + (debug-enable 'backtrace) + (debug-enable 'procnames) + (read-enable 'positions) + (cond (help-wanted (begin (skribilo-show-help) (exit 1))) - (version-wanted (begin (skribilo-show-version) (exit 1))) - (target (format #t "target set to `~a'~%" target))) + (version-wanted (begin (skribilo-show-version) (exit 1)))) + + ;; Parse the most important options. + + (set! *skribe-engine* engine) + + (set-skribe-debug! (string->number debugging-level)) + + (set! %skribilo-load-path + (cons load-path %skribilo-load-path)) + (set! %skribilo-bib-path + (cons bib-path %skribilo-bib-path)) + + (if (option-ref options 'verbose #f) + (set! *skribe-verbose* #t)) ;; Load the user rc file - (load-rc) + ;(load-rc) + + ;; load the basic Skribe modules + (load-skribe-modules) ;; Load the base file to bootstrap the system as well as the files - ;; that are in the *skribe-preload* variable - (skribe-load "base.skr" :engine 'base) + ;; that are in the PRELOAD variable. + (find-engine 'base) (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) - *skribe-preload*) + preload) - ;; Load the specified variants + ;; Load the specified variants. (for-each (lambda (x) (skribe-load (format #f "~a.skr" x) :engine *skribe-engine*)) - (reverse! *skribe-variants*)) - - ;; (if (string? *skribe-dest*) - ;; (with-handler (lambda (kind loc msg) - ;; (remove-file *skribe-dest*) - ;; (error loc msg)) - ;; (with-output-to-file *skribe-dest* doskribe)) - ;; (doskribe)) - (if (string? *skribe-dest*) - (with-output-to-file *skribe-dest* doskribe) - (doskribe)))) - -(display "skribilo loaded\n") + (reverse! variants)) + + (let ((files (option-ref options '() '()))) + (if (null? files) + (error "you must specify at least the input file" files)) + (if (> (length files) 2) + (error "you can specify at most one input file and one output file" + files)) + + (let* ((source-file (car files)) + (dest-file (if (null? (cdr files)) #f (cadr files))) + (source-port (open-input-file source-file))) + + (if (and dest-file (file-exists? dest-file)) + (delete-file dest-file)) + + (with-input-from-file source-file + (lambda () + (if (string? dest-file) + (with-output-to-file dest-file doskribe) + (doskribe)))))))) + (define main skribilo) diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index 0a4fc98..d4a644e 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -143,7 +143,7 @@ ;;; ====================================================================== ;; FIXME: Factoriser (define (skribe-open-bib-file file command) - (let ((path (find-path file *skribe-bib-path*))) + (let ((path (search-path *skribe-bib-path* file))) (if (string? path) (begin (when (> *skribe-verbose* 0) diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in index 6e40e7f..a5e3b7c 100644 --- a/src/guile/skribilo/config.scm.in +++ b/src/guile/skribilo/config.scm.in @@ -10,7 +10,6 @@ (define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@") (define-public (skribilo-scheme) "guile") - ;; Compatibility. (define-public skribe-release skribilo-release) diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm index 1a5478e..b880a66 100644 --- a/src/guile/skribilo/debug.scm +++ b/src/guile/skribilo/debug.scm @@ -73,8 +73,7 @@ (define (debug-color col . o) (with-output-to-string (if (and *skribe-debug-color* - (equal? (getenv "TERM") "xterm") - (interactive-port? *debug-port*)) + (equal? (getenv "TERM") "xterm")) (lambda () (format #t "[1;~Am" (+ 31 col)) (for-each display o) diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm index 9584f5e..1b39ec6 100644 --- a/src/guile/skribilo/engine.scm +++ b/src/guile/skribilo/engine.scm @@ -27,9 +27,10 @@ (define-module (skribilo engine) :use-module (skribilo debug) -; :use-module (skribilo eval) +; :use-module (skribilo evaluator) :use-module (skribilo writer) :use-module (skribilo types) + :use-module (skribilo lib) :use-module (oop goops) :use-module (ice-9 optargs) @@ -58,11 +59,14 @@ (define (default-engine-set! e) - (if (not (engine? e)) - (skribe-error 'default-engine-set! "bad engine ~S" e)) - (set! *default-engine* e) - (set! *default-engines* (cons e *default-engines*)) - e) + (with-debug 5 'default-engine-set! + (debug-item "engine=" e) + + (if (not (engine? e)) + (skribe-error 'default-engine-set! "bad engine ~S" e)) + (set! *default-engine* e) + (set! *default-engines* (cons e *default-engines*)) + e)) (define (push-default-engine e) @@ -141,32 +145,22 @@ ;;; ;;; FIND-ENGINE ;;; -(define (%find-loaded-engine id version) - (let loop ((es *engines*)) - (cond - ((null? es) #f) - ((eq? (slot-ref (car es) 'ident) id) - (cond - ((eq? version 'unspecified) (car es)) - ((eq? version (slot-ref (car es) 'version)) (car es)) - (else (Loop (cdr es))))) - (else (loop (cdr es)))))) - -(define* (find-engine id #:key (version 'unspecified)) - (with-debug 5 'find-engine +(define* (lookup-engine id #:key (version 'unspecified)) + "Look for an engine named @var{name} (a symbol) in the @code{(skribilo +engine)} module hierarchy. If no such engine was found, an error is raised, +otherwise the requested engine is returned." + (with-debug 5 'lookup-engine (debug-item "id=" id " version=" version) - (or (%find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and c (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (%find-loaded-engine id version)) - #f))))) + (let* ((engine (symbol-append id '-engine)) + (m (resolve-module `(skribilo engine ,id)))) + (if (module-bound? m engine) + (module-ref m engine) + (error "no such engine" id))))) -(define lookup-engine find-engine) +(define (find-engine . args) + (false-if-exception (apply lookup-engine args))) ;;; diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm new file mode 100644 index 0000000..53d837d --- /dev/null +++ b/src/guile/skribilo/engine/base.scm @@ -0,0 +1,466 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/base.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:39:30 2003 */ +;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* BASE Skribe engine */ +;*=====================================================================*/ + +(define-skribe-module (skribilo engine base)) + +;*---------------------------------------------------------------------*/ +;* base-engine ... */ +;*---------------------------------------------------------------------*/ +(define base-engine + (default-engine-set! + (make-engine 'base + :version 'plain + :symbol-table '(("iexcl" "!") + ("cent" "c") + ("lguillemet" "\"") + ("not" "!") + ("registered" "(r)") + ("degree" "o") + ("plusminus" "+/-") + ("micro" "o") + ("paragraph" "p") + ("middot" ".") + ("rguillemet" "\"") + ("iquestion" "?") + ("Agrave" "À") + ("Aacute" "A") + ("Acircumflex" "Â") + ("Atilde" "A") + ("Amul" "A") + ("Aring" "A") + ("AEligature" "AE") + ("Oeligature" "OE") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "E") + ("Igrave" "I") + ("Iacute" "I") + ("Icircumflex" "Î") + ("Iuml" "I") + ("ETH" "D") + ("Ntilde" "N") + ("Ograve" "O") + ("Oacute" "O") + ("Ocurcumflex" "O") + ("Otilde" "O") + ("Ouml" "O") + ("times" "x") + ("Oslash" "O") + ("Ugrave" "Ù") + ("Uacute" "U") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Y") + ("agrave" "à") + ("aacute" "a") + ("acircumflex" "â") + ("atilde" "a") + ("amul" "a") + ("aring" "a") + ("aeligature" "æ") + ("oeligature" "oe") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "e") + ("igrave" "i") + ("iacute" "i") + ("icircumflex" "î") + ("iuml" "i") + ("ntilde" "n") + ("ograve" "o") + ("oacute" "o") + ("ocurcumflex" "o") + ("otilde" "o") + ("ouml" "o") + ("divide" "/") + ("oslash" "o") + ("ugrave" "ù") + ("uacute" "u") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "y") + ("ymul" "y") + ;; punctuation + ("bullet" ".") + ("ellipsis" "...") + ("<-" "<-") + ("<--" "<--") + ("uparrow" "^;") + ("->" "->") + ("-->" "-->") + ("downarrow" "v") + ("<->" "<->") + ("<-->" "<-->") + ("<+" "<+") + ("<=" "<=;") + ("<==" "<==") + ("Uparrow" "^") + ("=>" "=>") + ("==>" "==>") + ("Downarrow" "v") + ("<=>" "<=>") + ("<==>" "<==>") + ;; Mathematical operators + ("asterisk" "*") + ("angle" "<") + ("and" "^;") + ("or" "v") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "~") + ("mid" "|") + ("langle" "<") + ("rangle" ">") + ;; LaTeX + ("circ" "o") + ("top" "T") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'symbol + :action (lambda (n e) + (let* ((s (markup-body n)) + (c (assoc s (engine-symbol-table e)))) + (if (pair? c) + (display (cadr c)) + (output s e))))) + +;*---------------------------------------------------------------------*/ +;* unref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'unref + :options 'all + :action (lambda (n e) + (let* ((s (markup-option n :skribe)) + (k (markup-option n 'kind)) + (f (cond + (s + (format "?~a@~a " k s)) + (else + (format "?~a " k)))) + (msg (list f (markup-body n))) + (n (list "[" (color :fg "red" (bold msg)) "]"))) + (skribe-eval n e)))) + +;*---------------------------------------------------------------------*/ +;* &the-bibliography ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-bibliography + :before (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-before w) n e)))) + :action (lambda (n e) + (when (pair? (markup-body n)) + (for-each (lambda (i) (output i e)) (markup-body n)))) + :after (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-after w) n e))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :before (lambda (n e) + (invoke (writer-before (markup-writer-get 'tr e)) n e)) + :action (lambda (n e) + (let ((wtc (markup-writer-get 'tc e))) + ;; the label + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'right) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-label e)) + (invoke (writer-after wtc) n e) + ;; the body + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'left) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-body)) + (invoke (writer-after wtc) n e))) + :after (lambda (n e) + (invoke (writer-after (markup-writer-get 'tr e)) n e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before "[" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "]") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-body + :action (lambda (n e) + (define (output-fields descr) + (let loop ((descr descr) + (pending #f) + (armed #f)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author " -- " (or title url documenturl) " -- " + number ", " institution ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((article) + `(author " -- " (or title url documenturl) " -- " + journal ", " volume "" ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author " -- " (or title url documenturl) " -- " + booktitle ", " series ", " ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((book) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")) + ((phdthesis) + '(author " -- " (or title url documenturl) " -- " type ", " + school ", " address + ", " month ", " year".")) + ((misc) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year".")) + (else + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-ident ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-ident + :action (lambda (n e) + (output (markup-option n 'number) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-publisher ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-publisher + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &the-index ... @label the-index@ */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index + :options '(:column) + :before (lambda (n e) + (output (markup-option n 'header) e)) + :action (lambda (n e) + (define (make-mark-entry n fst) + (let ((l (tr :class 'index-mark-entry + (td :colspan 2 :align 'left + (bold (it (sf n))))))) + (if fst + (list l) + (list (tr (td :colspan 2)) l)))) + (define (make-primary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (c (if note + (list b + (it (list " (" note ")"))) + b))) + (when p + (markup-option-add! b :text + (list (markup-option b :text) + ", p.")) + (markup-option-add! b :page #t)) + (tr :class 'index-primary-entry + (td :colspan 2 :valign 'top :align 'left c)))) + (define (make-secondary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (bb (markup-body b))) + (cond + ((not (or bb (is-markup? b 'url-ref))) + (skribe-error 'the-index + "Illegal entry" + b)) + (note + (let ((r (if bb + (it (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p + (list note ", p.") + note))) + (it (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p + (list note ", p.") + note)))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1. " ...") + (td :valign 'top :align 'left r)))) + (else + (let ((r (if bb + (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p " ..., p." " ...")) + (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p " ..., p." " ..."))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1.) + (td :valign 'top :align 'left r))))))) + (define (make-column ie p) + (let loop ((ie ie) + (f #t)) + (cond + ((null? ie) + '()) + ((not (pair? (car ie))) + (append (make-mark-entry (car ie) f) + (loop (cdr ie) #f))) + (else + (cons (make-primary-entry (caar ie) p) + (append (map (lambda (x) + (make-secondary-entry x p)) + (cdar ie)) + (loop (cdr ie) #f))))))) + (define (make-sub-tables ie nc p) + (let* ((l (length ie)) + (w (/ 100. nc)) + (iepc (let ((d (/ l nc))) + (if (integer? d) + (inexact->exact d) + (+ 1 (inexact->exact (truncate d)))))) + (split (list-split ie iepc))) + (tr (map (lambda (ies) + (td :valign 'top :width w + (if (pair? ies) + (table :width 100. (make-column ies p)) + ""))) + split)))) + (let* ((ie (markup-body n)) + (nc (markup-option n :column)) + (loc (ast-loc n)) + (pref (eq? (engine-custom e 'index-page-ref) #t)) + (t (cond + ((null? ie) + "") + ((or (not (integer? nc)) (= nc 1)) + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-column ie pref))) + (else + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-sub-tables ie nc pref)))))) + (output (skribe-eval t e) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;* ------------------------------------------------------------- */ +;* The index header is only useful for targets that support */ +;* hyperlinks such as HTML. */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) #f)) + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&prog-line + :before (lambda (n e) + (let ((n (markup-ident n))) + (if n (skribe-eval (it (list n) ": ") e)))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (n (markup-ident (handle-body (markup-body n))))) + (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) + + + +;;;; A VIRER (mais handle-body n'est pas défini) +(markup-writer 'line-ref + :options '(:offset) + :action #f) diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm new file mode 100644 index 0000000..48a069e --- /dev/null +++ b/src/guile/skribilo/engine/context.scm @@ -0,0 +1,1382 @@ +;;;; +;;;; context.skr -- ConTeXt mode for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 23-Sep-2004 17:21 (eg) +;;;; Last file update: 3-Nov-2004 12:54 (eg) +;;;; + +(define-skribe-module (skribilo engine context)) + +;;;; ====================================================================== +;;;; context-customs ... +;;;; ====================================================================== +(define context-customs + '((source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + (index-page-ref #t) + (image-format ("jpg")) + (font-size 11) + (font-type "roman") + (user-style #f) + (document-style "book"))) + +;;;; ====================================================================== +;;;; context-encoding ... +;;;; ====================================================================== +(define context-encoding + '((#\# "\\type{#}") + (#\| "\\type{|}") + (#\{ "$\\{$") + (#\} "$\\}$") + (#\~ "\\type{~}") + (#\& "\\type{&}") + (#\_ "\\type{_}") + (#\^ "\\type{^}") + (#\[ "\\type{[}") + (#\] "\\type{]}") + (#\< "\\type{<}") + (#\> "\\type{>}") + (#\$ "\\type{$}") + (#\% "\\%") + (#\\ "$\\backslash$"))) + +;;;; ====================================================================== +;;;; context-pre-encoding ... +;;;; ====================================================================== +(define context-pre-encoding + (append '((#\space "~") + (#\~ "\\type{~}")) + context-encoding)) + + +;;;; ====================================================================== +;;;; context-symbol-table ... +;;;; ====================================================================== +(define (context-symbol-table math) + `(("iexcl" "!`") + ("cent" "c") + ("pound" "\\pounds") + ("yen" "Y") + ("section" "\\S") + ("mul" ,(math "^-")) + ("copyright" "\\copyright") + ("lguillemet" ,(math "\\ll")) + ("not" ,(math "\\neg")) + ("degree" ,(math "^{\\small{o}}")) + ("plusminus" ,(math "\\pm")) + ("micro" ,(math "\\mu")) + ("paragraph" "\\P") + ("middot" ,(math "\\cdot")) + ("rguillemet" ,(math "\\gg")) + ("1/4" ,(math "\\frac{1}{4}")) + ("1/2" ,(math "\\frac{1}{2}")) + ("3/4" ,(math "\\frac{3}{4}")) + ("iquestion" "?`") + ("Agrave" "\\`{A}") + ("Aacute" "\\'{A}") + ("Acircumflex" "\\^{A}") + ("Atilde" "\\~{A}") + ("Amul" "\\\"{A}") + ("Aring" "{\\AA}") + ("AEligature" "{\\AE}") + ("Oeligature" "{\\OE}") + ("Ccedilla" "{\\c{C}}") + ("Egrave" "{\\`{E}}") + ("Eacute" "{\\'{E}}") + ("Ecircumflex" "{\\^{E}}") + ("Euml" "\\\"{E}") + ("Igrave" "{\\`{I}}") + ("Iacute" "{\\'{I}}") + ("Icircumflex" "{\\^{I}}") + ("Iuml" "\\\"{I}") + ("ETH" "D") + ("Ntilde" "\\~{N}") + ("Ograve" "\\`{O}") + ("Oacute" "\\'{O}") + ("Ocurcumflex" "\\^{O}") + ("Otilde" "\\~{O}") + ("Ouml" "\\\"{O}") + ("times" ,(math "\\times")) + ("Oslash" "\\O") + ("Ugrave" "\\`{U}") + ("Uacute" "\\'{U}") + ("Ucircumflex" "\\^{U}") + ("Uuml" "\\\"{U}") + ("Yacute" "\\'{Y}") + ("szlig" "\\ss") + ("agrave" "\\`{a}") + ("aacute" "\\'{a}") + ("acircumflex" "\\^{a}") + ("atilde" "\\~{a}") + ("amul" "\\\"{a}") + ("aring" "\\aa") + ("aeligature" "\\ae") + ("oeligature" "{\\oe}") + ("ccedilla" "{\\c{c}}") + ("egrave" "{\\`{e}}") + ("eacute" "{\\'{e}}") + ("ecircumflex" "{\\^{e}}") + ("euml" "\\\"{e}") + ("igrave" "{\\`{\\i}}") + ("iacute" "{\\'{\\i}}") + ("icircumflex" "{\\^{\\i}}") + ("iuml" "\\\"{\\i}") + ("ntilde" "\\~{n}") + ("ograve" "\\`{o}") + ("oacute" "\\'{o}") + ("ocurcumflex" "\\^{o}") + ("otilde" "\\~{o}") + ("ouml" "\\\"{o}") + ("divide" ,(math "\\div")) + ("oslash" "\\o") + ("ugrave" "\\`{u}") + ("uacute" "\\'{u}") + ("ucircumflex" "\\^{u}") + ("uuml" "\\\"{u}") + ("yacute" "\\'{y}") + ("ymul" "\\\"{y}") + ;; Greek + ("Alpha" "A") + ("Beta" "B") + ("Gamma" ,(math "\\Gamma")) + ("Delta" ,(math "\\Delta")) + ("Epsilon" "E") + ("Zeta" "Z") + ("Eta" "H") + ("Theta" ,(math "\\Theta")) + ("Iota" "I") + ("Kappa" "K") + ("Lambda" ,(math "\\Lambda")) + ("Mu" "M") + ("Nu" "N") + ("Xi" ,(math "\\Xi")) + ("Omicron" "O") + ("Pi" ,(math "\\Pi")) + ("Rho" "P") + ("Sigma" ,(math "\\Sigma")) + ("Tau" "T") + ("Upsilon" ,(math "\\Upsilon")) + ("Phi" ,(math "\\Phi")) + ("Chi" "X") + ("Psi" ,(math "\\Psi")) + ("Omega" ,(math "\\Omega")) + ("alpha" ,(math "\\alpha")) + ("beta" ,(math "\\beta")) + ("gamma" ,(math "\\gamma")) + ("delta" ,(math "\\delta")) + ("epsilon" ,(math "\\varepsilon")) + ("zeta" ,(math "\\zeta")) + ("eta" ,(math "\\eta")) + ("theta" ,(math "\\theta")) + ("iota" ,(math "\\iota")) + ("kappa" ,(math "\\kappa")) + ("lambda" ,(math "\\lambda")) + ("mu" ,(math "\\mu")) + ("nu" ,(math "\\nu")) + ("xi" ,(math "\\xi")) + ("omicron" ,(math "\\o")) + ("pi" ,(math "\\pi")) + ("rho" ,(math "\\rho")) + ("sigmaf" ,(math "\\varsigma")) + ("sigma" ,(math "\\sigma")) + ("tau" ,(math "\\tau")) + ("upsilon" ,(math "\\upsilon")) + ("phi" ,(math "\\varphi")) + ("chi" ,(math "\\chi")) + ("psi" ,(math "\\psi")) + ("omega" ,(math "\\omega")) + ("thetasym" ,(math "\\vartheta")) + ("piv" ,(math "\\varpi")) + ;; punctuation + ("bullet" ,(math "\\bullet")) + ("ellipsis" ,(math "\\ldots")) + ("weierp" ,(math "\\wp")) + ("image" ,(math "\\Im")) + ("real" ,(math "\\Re")) + ("tm" ,(math "^{\\sc\\tiny{tm}}")) + ("alef" ,(math "\\aleph")) + ("<-" ,(math "\\leftarrow")) + ("<--" ,(math "\\longleftarrow")) + ("uparrow" ,(math "\\uparrow")) + ("->" ,(math "\\rightarrow")) + ("-->" ,(math "\\longrightarrow")) + ("downarrow" ,(math "\\downarrow")) + ("<->" ,(math "\\leftrightarrow")) + ("<-->" ,(math "\\longleftrightarrow")) + ("<+" ,(math "\\hookleftarrow")) + ("<=" ,(math "\\Leftarrow")) + ("<==" ,(math "\\Longleftarrow")) + ("Uparrow" ,(math "\\Uparrow")) + ("=>" ,(math "\\Rightarrow")) + ("==>" ,(math "\\Longrightarrow")) + ("Downarrow" ,(math "\\Downarrow")) + ("<=>" ,(math "\\Leftrightarrow")) + ("<==>" ,(math "\\Longleftrightarrow")) + ;; Mathematical operators + ("forall" ,(math "\\forall")) + ("partial" ,(math "\\partial")) + ("exists" ,(math "\\exists")) + ("emptyset" ,(math "\\emptyset")) + ("infinity" ,(math "\\infty")) + ("nabla" ,(math "\\nabla")) + ("in" ,(math "\\in")) + ("notin" ,(math "\\notin")) + ("ni" ,(math "\\ni")) + ("prod" ,(math "\\Pi")) + ("sum" ,(math "\\Sigma")) + ("asterisk" ,(math "\\ast")) + ("sqrt" ,(math "\\surd")) + ("propto" ,(math "\\propto")) + ("angle" ,(math "\\angle")) + ("and" ,(math "\\wedge")) + ("or" ,(math "\\vee")) + ("cap" ,(math "\\cap")) + ("cup" ,(math "\\cup")) + ("integral" ,(math "\\int")) + ("models" ,(math "\\models")) + ("vdash" ,(math "\\vdash")) + ("dashv" ,(math "\\dashv")) + ("sim" ,(math "\\sim")) + ("cong" ,(math "\\cong")) + ("approx" ,(math "\\approx")) + ("neq" ,(math "\\neq")) + ("equiv" ,(math "\\equiv")) + ("le" ,(math "\\leq")) + ("ge" ,(math "\\geq")) + ("subset" ,(math "\\subset")) + ("supset" ,(math "\\supset")) + ("subseteq" ,(math "\\subseteq")) + ("supseteq" ,(math "\\supseteq")) + ("oplus" ,(math "\\oplus")) + ("otimes" ,(math "\\otimes")) + ("perp" ,(math "\\perp")) + ("mid" ,(math "\\mid")) + ("lceil" ,(math "\\lceil")) + ("rceil" ,(math "\\rceil")) + ("lfloor" ,(math "\\lfloor")) + ("rfloor" ,(math "\\rfloor")) + ("langle" ,(math "\\langle")) + ("rangle" ,(math "\\rangle")) + ;; Misc + ("loz" ,(math "\\diamond")) + ("spades" ,(math "\\spadesuit")) + ("clubs" ,(math "\\clubsuit")) + ("hearts" ,(math "\\heartsuit")) + ("diams" ,(math "\\diamondsuit")) + ("euro" "\\euro{}") + ;; ConTeXt + ("dag" "\\dag") + ("ddag" "\\ddag") + ("circ" ,(math "\\circ")) + ("top" ,(math "\\top")) + ("bottom" ,(math "\\bot")) + ("lhd" ,(math "\\triangleleft")) + ("rhd" ,(math "\\triangleright")) + ("parallel" ,(math "\\parallel")))) + +;;;; ====================================================================== +;;;; context-width +;;;; ====================================================================== +(define (context-width width) + (cond + ((string? width) + width) + ((and (number? width) (inexact? width)) + (string-append (number->string (/ width 100.)) "\\textwidth")) + (else + (string-append (number->string width) "pt")))) + +;;;; ====================================================================== +;;;; context-dim +;;;; ====================================================================== +(define (context-dim dimension) + (cond + ((string? dimension) + dimension) + ((number? dimension) + (string-append (number->string (inexact->exact (round dimension))) + "pt")))) + +;;;; ====================================================================== +;;;; context-url +;;;; ====================================================================== +(define(context-url url text e) + (let ((name (gensym 'url)) + (text (or text url))) + (printf "\\useURL[~A][~A][][" name url) + (output text e) + (printf "]\\from[~A]" name))) + +;;;; ====================================================================== +;;;; Color Management ... +;;;; ====================================================================== +(define *skribe-context-color-table* (make-hashtable)) + +(define (skribe-color->context-color spec) + (receive (r g b) + (skribe-color->rgb spec) + (let ((ff (exact->inexact #xff))) + (format "r=~a,g=~a,b=~a" + (number->string (/ r ff)) + (number->string (/ g ff)) + (number->string (/ b ff)))))) + + +(define (skribe-declare-used-colors) + (printf "\n%%Colors\n") + (for-each (lambda (spec) + (let ((c (hashtable-get *skribe-context-color-table* spec))) + (unless (string? c) + ;; Color was never used before + (let ((name (symbol->string (gensym 'col)))) + (hashtable-put! *skribe-context-color-table* spec name) + (printf "\\definecolor[~A][~A]\n" + name + (skribe-color->context-color spec)))))) + (skribe-get-used-colors)) + (newline)) + +(define (skribe-declare-standard-colors engine) + (for-each (lambda (x) + (skribe-use-color! (engine-custom engine x))) + '(source-comment-color source-define-color source-module-color + source-markup-color source-thread-color source-string-color + source-bracket-color source-type-color))) + +(define (skribe-get-color spec) + (let ((c (and (hashtable? *skribe-context-color-table*) + (hashtable-get *skribe-context-color-table* spec)))) + (if (not (string? c)) + (skribe-error 'context "Can't find color" spec) + c))) + +;;;; ====================================================================== +;;;; context-engine ... +;;;; ====================================================================== +(define context-engine + (default-engine-set! + (make-engine 'context + :version 1.0 + :format "context" + :delegate (find-engine 'base) + :filter (make-string-replace context-encoding) + :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m))) + :custom context-customs))) + +;;;; ====================================================================== +;;;; document ... +;;;; ====================================================================== +(markup-writer 'document + :options '(:title :subtitle :author :ending :env) + :before (lambda (n e) + ;; Prelude + (printf "% interface=en output=pdftex\n") + (display "%%%% -*- TeX -*-\n") + (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" + (skribe-release) (date)) + ;; Make URLs active + (printf "\\setupinteraction[state=start]\n") + ;; Choose the document font + (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) + (engine-custom e 'font-size)) + ;; Color + (display "\\setupcolors[state=start]\n") + ;; Load Style + (printf "\\input skribe-context-~a.tex\n" + (engine-custom e 'document-style)) + ;; Insert User customization + (let ((s (engine-custom e 'user-style))) + (when s (printf "\\input ~a\n" s))) + ;; Output used colors + (skribe-declare-standard-colors e) + (skribe-declare-used-colors) + + (display "\\starttext\n\\StartTitlePage\n") + ;; title + (let ((t (markup-option n :title))) + (when t + (skribe-eval (new markup + (markup '&context-title) + (body t) + (options + `((subtitle ,(markup-option n :subtitle))))) + e + :env `((parent ,n))))) + ;; author(s) + (let ((a (markup-option n :author))) + (when a + (if (list? a) + ;; List of authors. Use multi-columns + (begin + (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) + (display "\\startAuthors\n") + (let Loop ((l a)) + (unless (null? l) + (output (car l) e) + (unless (null? (cdr l)) + (display "\\nextAuthors\n") + (Loop (cdr l))))) + (display "\\stopAuthors\n\n")) + ;; One author, that's easy + (output a e)))) + ;; End of the title + (display "\\StopTitlePage\n")) + :after (lambda (n e) + (display "\n\\stoptext\n"))) + + + +;;;; ====================================================================== +;;;; &context-title ... +;;;; ====================================================================== +(markup-writer '&context-title + :before "{\\DocumentTitle{" + :action (lambda (n e) + (output (markup-body n) e) + (let ((sub (markup-option n 'subtitle))) + (when sub + (display "\\\\\n\\switchtobodyfont[16pt]\\it{") + (output sub e) + (display "}\n")))) + :after "}}") + +;;;; ====================================================================== +;;;; author ... +;;;; ====================================================================== +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (out (lambda (n) + (output n e) + (display "\\\\\n")))) + (display "{\\midaligned{") + (when name (out name)) + (when title (out title)) + (when affiliation (out affiliation)) + (when (pair? address) (for-each out address)) + (when phone (out phone)) + (when email (out email)) + (when url (out url)) + (display "}}\n")))) + + +;;;; ====================================================================== +;;;; toc ... +;;;; ====================================================================== +(markup-writer 'toc + :options '() + :action (lambda (n e) (display "\\placecontent\n"))) + +;;;; ====================================================================== +;;;; context-block-before ... +;;;; ====================================================================== +(define (context-block-before name name-unnum) + (lambda (n e) + (let ((num (markup-option n :number))) + (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (printf "\\~a[~a]{" (if num name name-unnum) + (string-canonicalize (markup-ident n))) + (output (markup-option n :title) e) + (display "}\n")))) + + +;;;; ====================================================================== +;;;; chapter, section, ... +;;;; ====================================================================== +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :before (context-block-before 'chapter 'title)) + + +(markup-writer 'section + :options '(:title :number :toc :file :env) + :before (context-block-before 'section 'subject)) + + +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :before (context-block-before 'subsection 'subsubject)) + + +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :before (context-block-before 'subsubsection 'subsubsubject)) + +;;;; ====================================================================== +;;;; paragraph ... +;;;; ====================================================================== +(markup-writer 'paragraph + :options '(:title :number :toc :env) + :after "\\par\n") + +;;;; ====================================================================== +;;;; footnote ... +;;;; ====================================================================== +(markup-writer 'footnote + :before "\\footnote{" + :after "}") + +;;;; ====================================================================== +;;;; linebreak ... +;;;; ====================================================================== +(markup-writer 'linebreak + :action "\\crlf ") + +;;;; ====================================================================== +;;;; hrule ... +;;;; ====================================================================== +(markup-writer 'hrule + :options '(:width :height) + :before (lambda (n e) + (printf "\\blackrule[width=~A,height=~A]\n" + (context-width (markup-option n :width)) + (context-dim (markup-option n :height))))) + +;;;; ====================================================================== +;;;; color ... +;;;; ====================================================================== +(markup-writer 'color + :options '(:bg :fg :width :margin :border) + :before (lambda (n e) + (let ((bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (w (markup-option n :width)) + (m (markup-option n :margin)) + (b (markup-option n :border)) + (c (markup-option n :round-corner))) + (if (or bg w m b) + (begin + (printf "\\startframedtext[width=~a" (if w + (context-width w) + "fit")) + (printf ",rulethickness=~A" (if b (context-width b) "0pt")) + (when m + (printf ",offset=~A" (context-width m))) + (when bg + (printf ",background=color,backgroundcolor=~A" + (skribe-get-color bg))) + (when fg + (printf ",foregroundcolor=~A" + (skribe-get-color fg))) + (when c + (display ",framecorner=round")) + (printf "]\n")) + ;; Probably just a foreground was specified + (when fg + (printf "\\startcolor[~A] " (skribe-get-color fg)))))) + :after (lambda (n e) + (let ((bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (w (markup-option n :width)) + (m (markup-option n :margin)) + (b (markup-option n :border))) + (if (or bg w m b) + (printf "\\stopframedtext ") + (when fg + (printf "\\stopcolor ")))))) +;;;; ====================================================================== +;;;; frame ... +;;;; ====================================================================== +(markup-writer 'frame + :options '(:width :border :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (b (markup-option n :border)) + (c (markup-option n :round-corner))) + (printf "\\startframedtext[width=~a" (if w + (context-width w) + "fit")) + (printf ",rulethickness=~A" (context-dim b)) + (printf ",offset=~A" (context-width m)) + (when c + (display ",framecorner=round")) + (printf "]\n"))) + :after "\\stopframedtext ") + +;;;; ====================================================================== +;;;; font ... +;;;; ====================================================================== +(markup-writer 'font + :options '(:size) + :action (lambda (n e) + (let* ((size (markup-option n :size)) + (cs (engine-custom e 'font-size)) + (ns (cond + ((and (integer? size) (exact? size)) + (if (> size 0) + size + (+ cs size))) + ((and (number? size) (inexact? size)) + (+ cs (inexact->exact size))) + ((string? size) + (let ((nb (string->number size))) + (if (not (number? nb)) + (skribe-error + 'font + (format "Illegal font size ~s" size) + nb) + (+ cs nb)))))) + (ne (make-engine (gensym 'context) + :delegate e + :filter (engine-filter e) + :symbol-table (engine-symbol-table e) + :custom `((font-size ,ns) + ,@(engine-customs e))))) + (printf "{\\switchtobodyfont[~apt]" ns) + (output (markup-body n) ne) + (display "}")))) + + +;;;; ====================================================================== +;;;; flush ... +;;;; ====================================================================== +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\n\n\\midaligned{")) + ((left) + (display "\n\n\\leftaligned{")) + ((right) + (display "\n\n\\rightaligned{")))) + :after "}\n") + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before "\n\n\\midaligned{" + :after "}\n") + +;;;; ====================================================================== +;;;; pre ... +;;;; ====================================================================== +(markup-writer 'pre + :before "{\\tt\n\\startlines\n\\fixedspaces\n" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'context) + :delegate e + :filter (make-string-replace context-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after "\n\\stoplines\n}") + +;;;; ====================================================================== +;;;; prog ... +;;;; ====================================================================== +(markup-writer 'prog + :options '(:line :mark) + :before "{\\tt\n\\startlines\n\\fixedspaces\n" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'context) + :delegate e + :filter (make-string-replace context-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after "\n\\stoplines\n}") + + +;;;; ====================================================================== +;;;; itemize, enumerate ... +;;;; ====================================================================== +(define (context-itemization-action n e descr?) + (let ((symbol (markup-option n :symbol))) + (for-each (lambda (item) + (if symbol + (begin + (display "\\sym{") + (output symbol e) + (display "}")) + ;; output a \item iff not a description + (unless descr? + (display " \\item "))) + (output item e) + (newline)) + (markup-body n)))) + +(markup-writer 'itemize + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[serried]\n" + :action (lambda (n e) (context-itemization-action n e #f)) + :after "\\stopitemize\n\\stopnarrower\n") + + +(markup-writer 'enumerate + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[n][standard]\n" + :action (lambda (n e) (context-itemization-action n e #f)) + :after "\\stopitemize\n\\stopnarrower\n") + +;;;; ====================================================================== +;;;; description ... +;;;; ====================================================================== +(markup-writer 'description + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[serried]\n" + :action (lambda (n e) (context-itemization-action n e #t)) + :after "\\stopitemize\n\\stopnarrower\n") + +;;;; ====================================================================== +;;;; item ... +;;;; ====================================================================== +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (when k + ;; Output the key(s) + (let Loop ((l (if (pair? k) k (list k)))) + (unless (null? l) + (output (bold (car l)) e) + (unless (null? (cdr l)) + (display "\\crlf\n")) + (Loop (cdr l)))) + (display "\\nowhitespace\\startnarrower[left]\n")) + ;; Output body + (output (markup-body n) e) + ;; Terminate + (when k + (display "\n\\stopnarrower\n"))))) + +;;;; ====================================================================== +;;;; blockquote ... +;;;; ====================================================================== +(markup-writer 'blockquote + :before "\n\\startnarrower[left,right]\n" + :after "\n\\stopnarrower\n") + + +;;;; ====================================================================== +;;;; figure ... +;;;; ====================================================================== +(markup-writer 'figure + :options '(:legend :number :multicolumns) + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (unless number + (display "{\\setupcaptions[number=off]\n")) + (display "\\placefigure\n") + (printf " [~a]\n" (string-canonicalize ident)) + (display " {") (output legend e) (display "}\n") + (display " {") (output (markup-body n) e) (display "}") + (unless number + (display "}\n"))))) + +;;;; ====================================================================== +;;;; table ... +;;;; ====================================================================== + ;; width doesn't work +(markup-writer 'table + :options '(:width :border :frame :rules :cellpadding) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (cp (markup-option n :cellpadding)) + (cs (markup-option n :cellspacing))) + (printf "\n{\\bTABLE\n") + (printf "\\setupTABLE[") + (printf "width=~A" (if width (context-width width) "fit")) + (when border + (printf ",rulethickness=~A" (context-dim border))) + (when cp + (printf ",offset=~A" (context-width cp))) + (printf ",frame=off]\n") + + (when rules + (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") + (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n")) + (case rules + ((rows) (display hor)) + ((cols) (display vert)) + ((all) (display hor) (display vert))))) + + (when frame + ;; hsides, vsides, lhs, rhs, box, border + (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n") + (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n") + (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n") + (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n")) + (case frame + ((above) (display top)) + ((below) (display bot)) + ((hsides) (display top) (display bot)) + ((lhs) (display left)) + ((rhs) (display right)) + ((vsides) (display left) (diplay right)) + ((box border) (display top) (display bot) + (display left) (display right))))))) + + :after (lambda (n e) + (printf "\\eTABLE}\n"))) + + +;;;; ====================================================================== +;;;; tr ... +;;;; ====================================================================== +(markup-writer 'tr + :options '(:bg) + :before (lambda (n e) + (display "\\bTR") + (let ((bg (markup-option n :bg))) + (when bg + (printf "[background=color,backgroundcolor=~A]" + (skribe-get-color bg))))) + :after "\\eTR\n") + + +;;;; ====================================================================== +;;;; tc ... +;;;; ====================================================================== +(markup-writer 'tc + :options '(:width :align :valign :colspan) + :before (lambda (n e) + (let ((th? (eq? 'th (markup-option n 'markup))) + (width (markup-option n :width)) + (align (markup-option n :align)) + (valign (markup-option n :valign)) + (colspan (markup-option n :colspan)) + (rowspan (markup-option n :rowspan)) + (bg (markup-option n :bg))) + (printf "\\bTD[") + (printf "width=~a" (if width (context-width width) "fit")) + (when valign + ;; This is buggy. In fact valign an align can't be both + ;; specified in ConTeXt + (printf ",align=~a" (case valign + ((center) 'lohi) + ((bottom) 'low) + ((top) 'high)))) + (when align + (printf ",align=~a" (case align + ((left) 'right) ; !!!! + ((right) 'left) ; !!!! + (else 'middle)))) + (unless (equal? colspan 1) + (printf ",nx=~a" colspan)) + (display "]") + (when th? + ;; This is a TH, output is bolded + (display "{\\bf{")))) + + :after (lambda (n e) + (when (equal? (markup-option n 'markup) 'th) + ;; This is a TH, output is bolded + (display "}}")) + (display "\\eTD"))) + +;;;; ====================================================================== +;;;; image ... +;;;; ====================================================================== +(markup-writer 'image + :options '(:file :url :width :height :zoom) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (zoom (markup-option n :zoom)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("jpg")))))) + (if (not (string? img)) + (skribe-error 'context "Illegal image" file) + (begin + (printf "\\externalfigure[~A][frame=off" (strip-ref-base img)) + (if zoom (printf ",factor=~a" (inexact->exact zoom))) + (if width (printf ",width=~a" (context-width width))) + (if height (printf ",height=~apt" (context-dim height))) + (display "]")))))) + + +;;;; ====================================================================== +;;;; Ornaments ... +;;;; ====================================================================== +(markup-writer 'roman :before "{\\rm{" :after "}}") +(markup-writer 'bold :before "{\\bf{" :after "}}") +(markup-writer 'underline :before "{\\underbar{" :after "}}") +(markup-writer 'emph :before "{\\em{" :after "}}") +(markup-writer 'it :before "{\\it{" :after "}}") +(markup-writer 'code :before "{\\tt{" :after "}}") +(markup-writer 'var :before "{\\tt{" :after "}}") +(markup-writer 'sc :before "{\\sc{" :after "}}") +;;//(markup-writer 'sf :before "{\\sf{" :after "}}") +(markup-writer 'sub :before "{\\low{" :after "}}") +(markup-writer 'sup :before "{\\high{" :after "}}") + + +;;// +;;//(markup-writer 'tt +;;// :before "{\\texttt{" +;;// :action (lambda (n e) +;;// (let ((ne (make-engine +;;// (gensym 'latex) +;;// :delegate e +;;// :filter (make-string-replace latex-tt-encoding) +;;// :custom (engine-customs e) +;;// :symbol-table (engine-symbol-table e)))) +;;// (output (markup-body n) ne))) +;;// :after "}}") + +;;;; ====================================================================== +;;;; q ... +;;;; ====================================================================== +(markup-writer 'q + :before "\\quotation{" + :after "}") + +;;;; ====================================================================== +;;;; mailto ... +;;;; ====================================================================== +(markup-writer 'mailto + :options '(:text) + :action (lambda (n e) + (let ((text (markup-option n :text)) + (url (markup-body n))) + (when (pair? url) + (context-url (format "mailto:~A" (car url)) + (or text + (car url)) + e))))) +;;;; ====================================================================== +;;;; mark ... +;;;; ====================================================================== +(markup-writer 'mark + :before (lambda (n e) + (printf "\\reference[~a]{}\n" + (string-canonicalize (markup-ident n))))) + +;;;; ====================================================================== +;;;; ref ... +;;;; ====================================================================== +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection + :figure :mark :handle :page) + :action (lambda (n e) + (let* ((text (markup-option n :text)) + (page (markup-option n :page)) + (c (handle-ast (markup-body n))) + (id (markup-ident c))) + (cond + (page ;; Output the page only (this is a hack) + (when text (output text e)) + (printf "\\at[~a]" + (string-canonicalize id))) + ((or (markup-option n :chapter) + (markup-option n :section) + (markup-option n :subsection) + (markup-option n :subsubsection)) + (if text + (printf "\\goto{~a}[~a]" (or text id) + (string-canonicalize id)) + (printf "\\in[~a]" (string-canonicalize id)))) + ((markup-option n :mark) + (printf "\\goto{~a}[~a]" + (or text id) + (string-canonicalize id))) + (else ;; Output a little image indicating the direction + (printf "\\in[~a]" (string-canonicalize id))))))) + +;;;; ====================================================================== +;;;; bib-ref ... +;;;; ====================================================================== +(markup-writer 'bib-ref + :options '(:text :bib) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) + (let* ((obj (handle-ast (markup-body n))) + (title (markup-option obj :title)) + (ref (markup-option title 'number)) + (ident (markup-ident obj))) + (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) + :after (lambda (n e) (output "]" e))) + +;;;; ====================================================================== +;;;; bib-ref+ ... +;;;; ====================================================================== +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (invoke (writer-action (markup-writer-get 'bib-ref e)) + (car rs) + e) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after (lambda (n e) (output "]" e))) + +;;;; ====================================================================== +;;;; url-ref ... +;;;; ====================================================================== +(markup-writer 'url-ref + :options '(:url :text) + :action (lambda (n e) + (context-url (markup-option n :url) (markup-option n :text) e))) + +;;//;*---------------------------------------------------------------------*/ +;;//;* line-ref ... */ +;;//;*---------------------------------------------------------------------*/ +;;//(markup-writer 'line-ref +;;// :options '(:offset) +;;// :before "{\\textit{" +;;// :action (lambda (n e) +;;// (let ((o (markup-option n :offset)) +;;// (v (string->number (markup-option n :text)))) +;;// (cond +;;// ((and (number? o) (number? v)) +;;// (display (+ o v))) +;;// (else +;;// (display v))))) +;;// :after "}}") + + +;;;; ====================================================================== +;;;; &the-bibliography ... +;;;; ====================================================================== +(markup-writer '&the-bibliography + :before "\n% Bibliography\n\n") + + +;;;; ====================================================================== +;;;; &bib-entry ... +;;;; ====================================================================== +(markup-writer '&bib-entry + :options '(:title) + :action (lambda (n e) + (skribe-eval (mark (markup-ident n)) e) + (output n e (markup-writer-get '&bib-entry-label e)) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n\n") + +;;;; ====================================================================== +;;;; &bib-entry-label ... +;;;; ====================================================================== +(markup-writer '&bib-entry-label + :options '(:title) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) (output (markup-option n :title) e)) + :after (lambda (n e) (output "] "e))) + +;;;; ====================================================================== +;;;; &bib-entry-title ... +;;;; ====================================================================== +(markup-writer '&bib-entry-title + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url)) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + + +;;//;*---------------------------------------------------------------------*/ +;;//;* &bib-entry-url ... */ +;;//;*---------------------------------------------------------------------*/ +;;//(markup-writer '&bib-entry-url +;;// :action (lambda (n e) +;;// (let* ((en (handle-ast (ast-parent n))) +;;// (url (markup-option en 'url)) +;;// (t (bold (markup-body url)))) +;;// (skribe-eval (ref :url (markup-body url) :text t) e)))) + + +;;;; ====================================================================== +;;;; &the-index ... +;;;; ====================================================================== +(markup-writer '&the-index + :options '(:column) + :action + (lambda (n e) + (define (make-mark-entry n) + (display "\\blank[medium]\n{\\bf\\it\\tfc{") + (skribe-eval (bold n) e) + (display "}}\\crlf\n")) + + (define (make-primary-entry n) + (let ((b (markup-body n))) + (markup-option-add! b :text (list (markup-option b :text) ", ")) + (markup-option-add! b :page #t) + (output n e))) + + (define (make-secondary-entry n) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (bb (markup-body b))) + (if note + (begin ;; This is another entry + (display "\\crlf\n ... ") + (markup-option-add! b :text (list note ", "))) + (begin ;; another line on an entry + (markup-option-add! b :text ", "))) + (markup-option-add! b :page #t) + (output n e))) + + ;; Writer body starts here + (let ((col (markup-option n :column))) + (when col + (printf "\\startcolumns[n=~a]\n" col)) + (for-each (lambda (item) + ;;(DEBUG "ITEM= ~S" item) + (if (pair? item) + (begin + (make-primary-entry (car item)) + (for-each (lambda (x) (make-secondary-entry x)) + (cdr item))) + (make-mark-entry item)) + (display "\\crlf\n")) + (markup-body n)) + (when col + (printf "\\stopcolumns\n"))))) + +;;;; ====================================================================== +;;;; &source-comment ... +;;;; ====================================================================== +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-line-comment ... +;;;; ====================================================================== +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-keyword ... +;;;; ====================================================================== +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + +;;;; ====================================================================== +;;;; &source-error ... +;;;; ====================================================================== +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'error-color) cc) + (color :fg cc (it n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-define ... +;;;; ====================================================================== +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-module ... +;;;; ====================================================================== +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-markup ... +;;;; ====================================================================== +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-thread ... +;;;; ====================================================================== +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-string ... +;;;; ====================================================================== +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-bracket ... +;;;; ====================================================================== +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-type ... +;;;; ====================================================================== +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-key ... +;;;; ====================================================================== +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-type ... +;;;; ====================================================================== +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + + + +;;;; ====================================================================== +;;;; Context Only Markups +;;;; ====================================================================== + +;;; +;;; Margin -- put text in the margin +;;; +(define-markup (margin #!rest opts #!key (ident #f) (class "margin") + (side 'right) text) + (new markup + (markup 'margin) + (ident (or ident (symbol->string (gensym 'ident)))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +(markup-writer 'margin + :options '(:text) + :before (lambda (n e) + (display + "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n") + (display "\\inright{") + (output (markup-option n :text) e) + (display "}{")) + :after "}") + +;;; +;;; ConTeXt and TeX +;;; +(define-markup (ConTeXt #!key (space #t)) + (if (engine-format? "context") + (! (if space "\\CONTEXT\\ " "\\CONTEXT")) + "ConTeXt")) + +(define-markup (TeX #!key (space #t)) + (if (engine-format? "context") + (! (if space "\\TEX\\ " "\\TEX")) + "ConTeXt")) + +;;;; ====================================================================== +;;;; Restore the base engine +;;;; ====================================================================== +(default-engine-set! (find-engine 'base)) diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm new file mode 100644 index 0000000..a20ea68 --- /dev/null +++ b/src/guile/skribilo/engine/html.scm @@ -0,0 +1,2282 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/html.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:28:57 2003 */ +;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* HTML Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/htmle.skb:ref@ */ +;*=====================================================================*/ + +(define-skribe-module (skribilo engine html)) + + +;; Keep a reference to the base engine. +(define base-engine (find-engine 'base)) + +;*---------------------------------------------------------------------*/ +;* html-file-default ... */ +;*---------------------------------------------------------------------*/ +(define html-file-default + ;; Default implementation of the `file-name-proc' custom. + (let ((table '()) + (filename (tmpnam))) + (define (get-file-name base suf) + (let* ((c (assoc base table)) + (n (if (pair? c) + (let ((n (+ 1 (cdr c)))) + (set-cdr! c n) + n) + (begin + (set! table (cons (cons base 1) table)) + 1)))) + (format "~a-~a.~a" base n suf))) + (lambda (node e) + (let ((f (markup-option node filename)) + (file (markup-option node :file))) + (cond + ((string? f) + f) + ((string? file) + file) + ((or file + (and (is-markup? node 'chapter) + (engine-custom e 'chapter-file)) + (and (is-markup? node 'section) + (engine-custom e 'section-file)) + (and (is-markup? node 'subsection) + (engine-custom e 'subsection-file)) + (and (is-markup? node 'subsubsection) + (engine-custom e 'subsubsection-file))) + (let* ((b (or (and (string? *skribe-dest*) + (prefix *skribe-dest*)) + "")) + (s (or (and (string? *skribe-dest*) + (suffix *skribe-dest*)) + "html")) + (nm (get-file-name b s))) + (markup-option-add! node filename nm) + nm)) + ((document? node) + *skribe-dest*) + (else + (let ((p (ast-parent node))) + (if (container? p) + (let ((file (html-file p e))) + (if (string? file) + (begin + (markup-option-add! node filename file) + file) + #f)) + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* html-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-engine + ;; setup the html engine + (default-engine-set! + (make-engine 'html + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@"))) + :custom `(;; the icon associated with the URL + (favicon #f) + ;; charset used + (charset "ISO-8859-1") + ;; enable/disable Javascript + (javascript #f) + ;; user html head + (head #f) + ;; user CSS + (css ()) + ;; user inlined CSS + (inline-css ()) + ;; user JS + (js ()) + ;; emit-sui + (emit-sui #f) + ;; the body + (background "#ffffff") + (foreground #f) + ;; the margins + (margin-padding 3) + (left-margin #f) + (chapter-left-margin #f) + (section-left-margin #f) + (left-margin-font #f) + (left-margin-size 17.) + (left-margin-background "#dedeff") + (left-margin-foreground #f) + (right-margin #f) + (chapter-right-margin #f) + (section-right-margin #f) + (right-margin-font #f) + (right-margin-size 17.) + (right-margin-background "#dedeff") + (right-margin-foreground #f) + ;; author configuration + (author-font #f) + ;; title configuration + (title-font #f) + (title-background "#8381de") + (title-foreground #f) + (file-title-separator " -- ") + ;; html file naming + (file-name-proc ,html-file-default) + ;; index configuration + (index-header-font-size +2.) + ;; chapter configuration + (chapter-number->string number->string) + (chapter-file #f) + ;; section configuration + (section-title-start "

") + (section-title-stop "

") + (section-title-background "#dedeff") + (section-title-foreground "black") + (section-title-number-separator " ") + (section-number->string number->string) + (section-file #f) + ;; subsection configuration + (subsection-title-start "

") + (subsection-title-stop "

") + (subsection-title-background "#ffffff") + (subsection-title-foreground "#8381de") + (subsection-title-number-separator " ") + (subsection-number->string number->string) + (subsection-file #f) + ;; subsubsection configuration + (subsubsection-title-start "

") + (subsubsection-title-stop "

") + (subsubsection-title-background #f) + (subsubsection-title-foreground "#8381de") + (subsubsection-title-number-separator " ") + (subsubsection-number->string number->string) + (subsubsection-file #f) + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + ;; image + (image-format ("png" "gif" "jpg" "jpeg"))) + :symbol-table '(("iexcl" "¡") + ("cent" "¢") + ("pound" "£") + ("currency" "¤") + ("yen" "¥") + ("section" "§") + ("mul" "¨") + ("copyright" "©") + ("female" "ª") + ("lguillemet" "«") + ("not" "¬") + ("registered" "®") + ("degree" "°") + ("plusminus" "±") + ("micro" "µ") + ("paragraph" "¶") + ("middot" "·") + ("male" "¸") + ("rguillemet" "»") + ("1/4" "¼") + ("1/2" "½") + ("3/4" "¾") + ("iquestion" "¿") + ("Agrave" "À") + ("Aacute" "Á") + ("Acircumflex" "Â") + ("Atilde" "Ã") + ("Amul" "Ä") + ("Aring" "Å") + ("AEligature" "Æ") + ("Oeligature" "Œ") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "Ë") + ("Igrave" "Ì") + ("Iacute" "Í") + ("Icircumflex" "Î") + ("Iuml" "Ï") + ("ETH" "Ð") + ("Ntilde" "Ñ") + ("Ograve" "Ò") + ("Oacute" "Ó") + ("Ocurcumflex" "Ô") + ("Otilde" "Õ") + ("Ouml" "Ö") + ("times" "×") + ("Oslash" "Ø") + ("Ugrave" "Ù") + ("Uacute" "Ú") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Ý") + ("THORN" "Þ") + ("szlig" "ß") + ("agrave" "à") + ("aacute" "á") + ("acircumflex" "â") + ("atilde" "ã") + ("amul" "ä") + ("aring" "å") + ("aeligature" "æ") + ("oeligature" "œ") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "ë") + ("igrave" "ì") + ("iacute" "í") + ("icircumflex" "î") + ("iuml" "ï") + ("eth" "ð") + ("ntilde" "ñ") + ("ograve" "ò") + ("oacute" "ó") + ("ocurcumflex" "ô") + ("otilde" "õ") + ("ouml" "ö") + ("divide" "÷") + ("oslash" "ø") + ("ugrave" "ù") + ("uacute" "ú") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "ý") + ("thorn" "þ") + ("ymul" "ÿ") + ;; Greek + ("Alpha" "Α") + ("Beta" "Β") + ("Gamma" "Γ") + ("Delta" "Δ") + ("Epsilon" "Ε") + ("Zeta" "Ζ") + ("Eta" "Η") + ("Theta" "Θ") + ("Iota" "Ι") + ("Kappa" "Κ") + ("Lambda" "Λ") + ("Mu" "Μ") + ("Nu" "Ν") + ("Xi" "Ξ") + ("Omicron" "Ο") + ("Pi" "Π") + ("Rho" "Ρ") + ("Sigma" "Σ") + ("Tau" "Τ") + ("Upsilon" "Υ") + ("Phi" "Φ") + ("Chi" "Χ") + ("Psi" "Ψ") + ("Omega" "Ω") + ("alpha" "α") + ("beta" "β") + ("gamma" "γ") + ("delta" "δ") + ("epsilon" "ε") + ("zeta" "ζ") + ("eta" "η") + ("theta" "θ") + ("iota" "ι") + ("kappa" "κ") + ("lambda" "λ") + ("mu" "μ") + ("nu" "ν") + ("xi" "ξ") + ("omicron" "ο") + ("pi" "π") + ("rho" "ρ") + ("sigmaf" "ς") + ("sigma" "σ") + ("tau" "τ") + ("upsilon" "υ") + ("phi" "φ") + ("chi" "χ") + ("psi" "ψ") + ("omega" "ω") + ("thetasym" "ϑ") + ("piv" "ϖ") + ;; punctuation + ("bullet" "•") + ("ellipsis" "…") + ("weierp" "℘") + ("image" "ℑ") + ("real" "ℜ") + ("tm" "™") + ("alef" "ℵ") + ("<-" "←") + ("<--" "←") + ("uparrow" "↑") + ("->" "→") + ("-->" "→") + ("downarrow" "↓") + ("<->" "↔") + ("<-->" "↔") + ("<+" "↵") + ("<=" "⇐") + ("<==" "⇐") + ("Uparrow" "⇑") + ("=>" "⇒") + ("==>" "⇒") + ("Downarrow" "⇓") + ("<=>" "⇔") + ("<==>" "⇔") + ;; Mathematical operators + ("forall" "∀") + ("partial" "∂") + ("exists" "∃") + ("emptyset" "∅") + ("infinity" "∞") + ("nabla" "∇") + ("in" "∈") + ("notin" "∉") + ("ni" "∋") + ("prod" "∏") + ("sum" "∑") + ("asterisk" "∗") + ("sqrt" "√") + ("propto" "∝") + ("angle" "∠") + ("and" "∧") + ("or" "∨") + ("cap" "∩") + ("cup" "∪") + ("integral" "∫") + ("therefore" "∴") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "∼") + ("cong" "≅") + ("approx" "≈") + ("neq" "≠") + ("equiv" "≡") + ("le" "≤") + ("ge" "≥") + ("subset" "⊂") + ("supset" "⊃") + ("nsupset" "⊃") + ("subseteq" "⊆") + ("supseteq" "⊇") + ("oplus" "⊕") + ("otimes" "⊗") + ("perp" "⊥") + ("mid" "|") + ("lceil" "⌈") + ("rceil" "⌉") + ("lfloor" "⌊") + ("rfloor" "⌋") + ("langle" "〈") + ("rangle" "〉") + ;; Misc + ("loz" "◊") + ("spades" "♠") + ("clubs" "♣") + ("hearts" "♥") + ("diams" "♦") + ("euro" "ℐ") + ;; LaTeX + ("dag" "dag") + ("ddag" "ddag") + ("circ" "o") + ("top" "T") + ("bottom" "⊥") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* html-file ... */ +;*---------------------------------------------------------------------*/ +(define (html-file n e) + (let ((proc (or (engine-custom e 'file-name-proc) html-file-default))) + (proc n e))) + +;*---------------------------------------------------------------------*/ +;* html-title-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-title-engine + (copy-engine 'html-title base-engine + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))))) + +;*---------------------------------------------------------------------*/ +;* html-browser-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-browser-title n) + (and (markup? n) + (or (markup-option n :html-title) + (if (document? n) + (markup-option n :title) + (html-browser-title (ast-parent n)))))) + + +;*---------------------------------------------------------------------*/ +;* html-container-number ... */ +;* ------------------------------------------------------------- */ +;* Returns a string representing the container number */ +;*---------------------------------------------------------------------*/ +(define (html-container-number c e) + (define (html-number n proc) + (cond + ((string? n) + n) + ((number? n) + (if (procedure? proc) + (proc n) + (number->string n))) + (else + ""))) + (define (html-chapter-number c) + (html-number (markup-option c :number) + (engine-custom e 'chapter-number->string))) + (define (html-section-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'section-number->string)))) + (cond + ((is-markup? p 'chapter) + (string-append (html-chapter-number p) "." s)) + (else + (string-append s))))) + (define (html-subsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsection-number->string)))) + (cond + ((is-markup? p 'section) + (string-append (html-section-number p) "." s)) + (else + (string-append "." s))))) + (define (html-subsubsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsubsection-number->string)))) + (cond + ((is-markup? p 'subsection) + (string-append (html-subsection-number p) "." s)) + (else + (string-append ".." s))))) + (define (inner-html-container-number c) + (html-number (markup-option c :number) #f)) + (let ((n (markup-option c :number))) + (if (not n) + "" + (case (markup-markup c) + ((chapter) + (html-chapter-number c)) + ((section) + (html-section-number c)) + ((subsection) + (html-subsection-number c)) + ((subsubsection) + (html-subsubsection-number c)) + (else + (if (container? c) + (inner-html-container-number c) + (skribe-error 'html-container-number + "Not a container" + (markup-markup c)))))))) + +;*---------------------------------------------------------------------*/ +;* html-counter ... */ +;*---------------------------------------------------------------------*/ +(define (html-counter cnts) + (cond + ((not cnts) + "") + ((null? cnts) + "") + ((not (pair? cnts)) + cnts) + ((null? (cdr cnts)) + (format "~a." (car cnts))) + (else + (let loop ((cnts cnts)) + (if (null? (cdr cnts)) + (format "~a" (car cnts)) + (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) + +;*---------------------------------------------------------------------*/ +;* html-width ... */ +;*---------------------------------------------------------------------*/ +(define (html-width width) + (cond + ((and (integer? width) (exact? width)) + (format "~A" width)) + ((real? width) + (format "~A%" (inexact->exact (round width)))) + ((string? width) + width) + (else + (skribe-error 'html-width "bad width" width)))) + +;*---------------------------------------------------------------------*/ +;* html-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-class m) + (if (markup? m) + (let ((c (markup-class m))) + (if (or (string? c) (symbol? c) (number? c)) + (printf " class=\"~a\"" c))))) + +;*---------------------------------------------------------------------*/ +;* html-markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-markup-class m) + (lambda (n e) + (printf "<~a" m) + (html-class n) + (display ">"))) + +;*---------------------------------------------------------------------*/ +;* html-color-spec? ... */ +;*---------------------------------------------------------------------*/ +(define (html-color-spec? v) + (and v + (not (unspecified? v)) + (or (not (string? v)) (> (string-length v) 0)))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :html-title :env) + :action (lambda (n e) + (let* ((id (markup-ident n)) + (title (new markup + (markup '&html-document-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (options `((author ,(markup-option n :author)))) + (body (markup-option n :title))))) + (&html-generic-document n title e))) + :after (lambda (n e) + (if (engine-custom e 'emit-sui) + (document-sui n e)))) + +;*---------------------------------------------------------------------*/ +;* &html-html ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-html + :before " + +\n" + :after "") + +;*---------------------------------------------------------------------*/ +;* &html-head ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-head + :before (lambda (n e) + (printf "\n") + (printf "\n" (engine-custom (find-engine 'html) + 'charset))) + :after "\n\n") + +;*---------------------------------------------------------------------*/ +;* &html-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-body + :before (lambda (n e) + (let ((bg (engine-custom e 'background))) + (display "\n"))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* &html-page ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-page + :action (lambda (n e) + (define (html-margin m fn size bg fg cla) + (printf "\n")) + (let ((body (markup-body n)) + (lm (engine-custom e 'left-margin)) + (lmfn (engine-custom e 'left-margin-font)) + (lms (engine-custom e 'left-margin-size)) + (lmbg (engine-custom e 'left-margin-background)) + (lmfg (engine-custom e 'left-margin-foreground)) + (rm (engine-custom e 'right-margin)) + (rmfn (engine-custom e 'right-margin-font)) + (rms (engine-custom e 'right-margin-size)) + (rmbg (engine-custom e 'right-margin-background)) + (rmfg (engine-custom e 'right-margin-foreground))) + (cond + ((and lm rm) + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "
" bg) + (display ">")) + (printf "
\n" cla) + (cond + ((and (string? fg) (string? fn)) + (printf "" fg fn)) + ((string? fg) + (printf "" fg)) + ((string? fn) + (printf "" fn))) + (if (procedure? m) + (skribe-eval (m n e) e) + (output m e)) + (if (or (string? fg) (string? fn)) + (display "")) + (display "
\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "
")) + (lm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (display "
")) + (rm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "\n")) + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "
")) + (else + (display "
\n") + (output body e) + (display "
\n")))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-header ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-header n e) + (let* ((ic (engine-custom e 'favicon)) + (id (markup-ident n))) + (unless (string? id) + (skribe-error '&html-generic-header + (format "Illegal identifier `~a'" id) + n)) + ;; title + (output (new markup + (markup '&html-header-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (body (markup-body n))) + e) + ;; favicon + (output (new markup + (markup '&html-header-favicon) + (parent n) + (ident (string-append id "-favicon")) + (body (cond + ((string? ic) + ic) + ((procedure? ic) + (ic d e))))) + e) + ;; style + (output (new markup + (markup '&html-header-style) + (parent n) + (ident (string-append id "-style")) + (class (markup-class n))) + e) + ;; css + (output (new markup + (markup '&html-header-css) + (parent n) + (ident (string-append id "-css")) + (body (let ((c (engine-custom e 'css))) + (if (string? c) + (list c) + c)))) + e) + ;; javascript + (output (new markup + (markup '&html-header-javascript) + (parent n) + (ident (string-append id "-javascript"))) + e))) + +(markup-writer '&html-header-title + :before "" + :action (lambda (n e) + (output (markup-body n) html-title-engine)) + :after "\n") + +(markup-writer '&html-header-favicon + :action (lambda (n e) + (let ((i (markup-body n))) + (when i + (printf " \n" i))))) + +(markup-writer '&html-header-css + :action (lambda (n e) + (let ((css (markup-body n))) + (when (pair? css) + (for-each (lambda (css) + (printf " \n" css)) + css))))) + +(markup-writer '&html-header-style + :before " \n") + +(markup-writer '&html-header-javascript + :action (lambda (n e) + (when (engine-custom e 'javascript) + (display " \n")) + (let* ((ejs (engine-custom e 'js)) + (js (cond + ((string? ejs) + (list ejs)) + ((list? ejs) + ejs) + (else + '())))) + (for-each (lambda (s) + (printf "" s)) + js)))) + + +;*---------------------------------------------------------------------*/ +;* &html-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-header :action &html-generic-header) +(markup-writer '&html-chapter-header :action &html-generic-header) +(markup-writer '&html-section-header :action &html-generic-header) +(markup-writer '&html-subsection-header :action &html-generic-header) +(markup-writer '&html-subsubsection-header :action &html-generic-header) + +;*---------------------------------------------------------------------*/ +;* &html-ending ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-ending + :before "
" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval + (list (hrule) + (p :class "ending" + (font :size -1 + (list "This HTML page was " + "produced by " + (ref :text "Skribilo" + :url (skribilo-url)) + "." + (linebreak) + "Last update: " (date))))) + e)))) + :after "
\n") + +;*---------------------------------------------------------------------*/ +;* &html-generic-title ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (when title + (display "\n") + (if (html-color-spec? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (when title + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "
") + (output title e) + (display "
")))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "")) + (display "
\n")))) + +;*---------------------------------------------------------------------*/ +;* &html-document-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-title :action &html-generic-title) +(markup-writer '&html-chapter-title :action &html-generic-title) +(markup-writer '&html-section-title :action &html-generic-title) +(markup-writer '&html-subsection-title :action &html-generic-title) +(markup-writer '&html-subsubsection-title :action &html-generic-title) + +;*---------------------------------------------------------------------*/ +;* &html-footnotes */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-footnotes + :before (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (display "
") + (display "

\n") + (display "
\n")))) + :action (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (let loop ((fns footnotes)) + (if (pair? fns) + (let ((fn (car fns))) + (printf "" + (string-canonicalize + (container-ident fn))) + (printf "~a: " + (markup-option fn :number)) + (output (markup-body fn) e) + (display "\n
\n") + (loop (cdr fns))))) + (display "
"))))) + +;*---------------------------------------------------------------------*/ +;* html-title-authors ... */ +;*---------------------------------------------------------------------*/ +(define (html-title-authors authors e) + (define (html-authorsN authors cols first) + (define (make-row authors . opt) + (tr (map (lambda (v) + (apply td :align 'center :valign 'top v opt)) + authors))) + (define (make-rows authors) + (let loop ((authors authors) + (rows '()) + (row '()) + (cnum 0)) + (cond + ((null? authors) + (reverse! (cons (make-row (reverse! row)) rows))) + ((= cnum cols) + (loop authors + (cons (make-row (reverse! row)) rows) + '() + 0)) + (else + (loop (cdr authors) + rows + (cons (car authors) row) + (+ cnum 1)))))) + (output (table :cellpadding 10 + (if first + (cons (make-row (list (car authors)) :colspan cols) + (make-rows (cdr authors))) + (make-rows authors))) + e)) + (cond + ((pair? authors) + (display "
\n") + (let ((len (length authors))) + (case len + ((1) + (output (car authors) e)) + ((2 3) + (html-authorsN authors len #f)) + ((4) + (html-authorsN authors 2 #f)) + (else + (html-authorsN authors 3 #t)))) + (display "
\n")) + (else + (html-title-authors (list authors) e)))) + +;*---------------------------------------------------------------------*/ +;* document-sui ... */ +;*---------------------------------------------------------------------*/ +(define (document-sui n e) + (define (sui) + (display "(sui \"") + (skribe-eval (markup-option n :title) html-title-engine) + (display "\"\n") + (printf " :file ~s\n" (sui-referenced-file n e)) + (sui-marks n e) + (sui-blocks 'chapter n e) + (sui-blocks 'section n e) + (sui-blocks 'subsection n e) + (sui-blocks 'subsubsection n e) + (display " )\n")) + (if (string? *skribe-dest*) + (let ((f (format "~a.sui" (prefix *skribe-dest*)))) + (with-output-to-file f sui)) + (sui))) + +;*---------------------------------------------------------------------*/ +;* sui-referenced-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-referenced-file n e) + (let ((file (html-file n e))) + (if (member (suffix file) '("skb" "sui" "skr" "html")) + (string-append (strip-ref-base (prefix file)) ".html") + file))) + +;*---------------------------------------------------------------------*/ +;* sui-marks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-marks n e) + (printf " (marks") + (for-each (lambda (m) + (printf "\n (~s" (markup-ident m)) + (printf " :file ~s" (sui-referenced-file m e)) + (printf " :mark ~s" (markup-ident m)) + (when (markup-class m) + (printf " :class ~s" (markup-class m))) + (display ")")) + (search-down (lambda (n) (is-markup? n 'mark)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* sui-blocks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-blocks kind n e) + (printf " (~as" kind) + (for-each (lambda (chap) + (display "\n (\"") + (skribe-eval (markup-option chap :title) html-title-engine) + (printf "\" :file ~s" (sui-referenced-file chap e)) + (printf " :mark ~s" (markup-ident chap)) + (when (markup-class chap) + (printf " :class ~s" (markup-class chap))) + (display ")")) + (container-search-down (lambda (n) (is-markup? n kind)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (display "\n")) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (define (row n) + (printf "" align) + (output n e) + (display "")) + ;; name + (printf "" align) + (if nfn + (printf "\n" nfn) + (display "\n")) + (output name e) + (if nfn + (printf "\n") + (display "\n")) + (display "") + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url)))) + :after "") + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :predicate (lambda (n e) (markup-option n :photo)) + :before (lambda (n e) + (display "\n")) + :action (lambda (n e) + (let ((photo (markup-option n :photo))) + (display "") + (output photo e) + (display "") + (markup-option-add! n :photo #f) + (output n e) + (markup-option-add! n :photo photo) + (display ""))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options 'all + :action (lambda (n e) + (define (col n) + (let loop ((i 0)) + (if (< i n) + (begin + (display "") + (loop (+ i 1)))))) + (define (toc-entry fe level) + (let* ((c (car fe)) + (ch (cdr fe)) + (t (markup-option c :title)) + (id (markup-ident c)) + (f (html-file c e))) + (unless (string? id) + (skribe-error 'toc + (format "Illegal identifier `~a'" id) + c)) + (display " ") + ;; blank columns + (col level) + ;; number + (printf "~a" + (html-container-number c e)) + ;; title + (printf "" + (- 4 level)) + (printf "" + (if (string=? f *skribe-dest*) + "" + (strip-ref-base (or f *skribe-dest* ""))) + (string-canonicalize id)) + (output (markup-option c :title) e) + (display "") + (display "\n") + ;; the children + (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) + (define (symbol->keyword s) + (cond-expand + (stklos + (make-keyword s)) + (bigloo + (string->keyword (string-append ":" (symbol->string s)))))) + (let* ((c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection)) + (b (markup-body n)) + (bb (if (handle? b) + (handle-ast b) + b))) + (if (not (container? bb)) + (error 'toc + "Illegal body (container expected)" + (if (markup? bb) + (markup-markup bb) + "???")) + (let ((lst (find-down (lambda (x) + (and (markup? x) + (markup-option x :toc) + (or (and sss (is-markup? x 'subsubsection)) + (and ss (is-markup? x 'subsection)) + (and s (is-markup? x 'section)) + (and c (is-markup? x 'chapter)) + (markup-option n (symbol->keyword + (markup-markup x)))))) + (container-body bb)))) + ;; avoid to produce an empty table + (unless (null? lst) + (display "\n\n") + + (for-each (lambda (n) (toc-entry n 0)) lst) + + (display "\n
\n"))))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-document ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-document n title e) + (let* ((id (markup-ident n)) + (header (new markup + (markup '&html-chapter-header) + (ident (string-append id "-header")) + (class (markup-class n)) + (parent n) + (body (html-browser-title n)))) + (head (new markup + (markup '&html-head) + (ident (string-append id "-head")) + (class (markup-class n)) + (parent n) + (body header))) + (ftnote (new markup + (markup '&html-footnotes) + (ident (string-append id "-footnote")) + (class (markup-class n)) + (parent n) + (body (reverse! + (container-env-get n 'footnote-env))))) + (page (new markup + (markup '&html-page) + (ident (string-append id "-page")) + (class (markup-class n)) + (parent n) + (body (list (markup-body n) ftnote)))) + (ending (new markup + (markup '&html-ending) + (ident (string-append id "-ending")) + (class (markup-class n)) + (parent n) + (body (or (markup-option n :ending) + (let ((p (ast-document n))) + (and p (markup-option p :ending))))))) + (body (new markup + (markup '&html-body) + (ident (string-append id "-body")) + (class (markup-class n)) + (parent n) + (body (list title page ending)))) + (html (new markup + (markup '&html-html) + (ident (string-append id "-html")) + (class (markup-class n)) + (parent n) + (body (list head body))))) + ;; No file must be opened for documents. These files are + ;; directly opened by Skribe + (if (document? n) + (output html e) + (with-output-to-file (html-file n e) + (lambda () + (output html e)))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-subdocument ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-subdocument n e) + (let* ((p (ast-document n)) + (id (markup-ident n)) + (ti (let* ((nb (html-container-number n e)) + (tc (markup-option n :title)) + (ti (if (document? p) + (list (markup-option p :title) + (engine-custom e 'file-title-separator) + tc) + tc)) + (sep (engine-custom + e + (symbol-append (markup-markup n) + '-title-number-separator))) + (nti (and tc + (if (and nb (not (equal? nb ""))) + (list nb + (if (unspecified? sep) ". " sep) + ti) + ti)))) + (new markup + (markup (symbol-append '&html- (markup-markup n) '-title)) + (ident (string-append id "-title")) + (parent n) + (options '((author ()))) + (body nti))))) + (case (markup-markup n) + ((chapter) + (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) + ((section) + (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) + (&html-generic-document n ti e))) + +;*---------------------------------------------------------------------*/ +;* chapter ... @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :before (lambda (n e) + (let ((title (markup-option n :title)) + (ident (markup-ident n))) + (display "\n") + (display "\n") + (display "
") + (output (html-container-number n e) e) + (display " ") + (output (markup-option n :title) e) + (display "
"))) + :after "
") + +;; This writer is invoked only for chapters rendered inside separate files! +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'chapter-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* html-section-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-section-title n e) + (let* ((title (markup-option n :title)) + (number (markup-option n :number)) + (c (markup-class n)) + (ident (markup-ident n)) + (kind (markup-markup n)) + (tbg (engine-custom e (symbol-append kind '-title-background))) + (tfg (engine-custom e (symbol-append kind '-title-foreground))) + (tstart (engine-custom e (symbol-append kind '-title-start))) + (tstop (engine-custom e (symbol-append kind '-title-stop))) + (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) + ;; the section header + (display "\n") + (display "\n") + (if c + (printf "
" c) + (printf "
" (markup-markup n))) + (when (html-color-spec? tbg) + (display "") + (printf "
" tbg)) + (display tstart) + (if tfg (printf "" tfg)) + (if number + (begin + (output (html-container-number n e) e) + (output nsep e))) + (output title e) + (if tfg (display "\n")) + (display tstop) + (when (and (string? tbg) (> (string-length tbg) 0)) + (display "
\n")) + (display "
") + (display "")) + (newline)) + +;*---------------------------------------------------------------------*/ +;* section ... @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :before html-section-title + :after "

\n") + +;; on-file section writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'section-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "
\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "
\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsubsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :before (lambda (n e) + (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) + (printf "~a" + (ast-location n))) + ((html-markup-class "p") n e)) + :after "

") + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:number) + :action (lambda (n e) + (printf "~a" + (string-canonicalize (container-ident n)) + (markup-option n :number)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :before (lambda (n e) + (display ""))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '(:width :height) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (height (markup-option n :height))) + (display " height 1) + (printf " size=\"~a\"" height)) + (display ">")))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when (html-color-spec? bg) + (display "\n") + (display "\n
")) + (when (html-color-spec? fg) + (display "")))) + :after (lambda (n e) + (when (html-color-spec? (markup-option n :fg)) + (display "")) + (when (html-color-spec? (markup-option n :bg)) + (display "
")))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + :options '(:width :margin :border) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (b (markup-option n :border)) + (w (markup-option n :width))) + (display "\n\n
"))) + :after "
") + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size :face) + :before (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "" "")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s)))) + (when (or (and (number? size) (exact? size)) face) + (display "")))) + :after (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (or (and (number? size) (exact? size) (not (= size 0))) + face) + (display "")) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "" "")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s))))))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\n")) + ((left) + (display "

\n")) + ((right) + (display "
")) + (else + (skribe-error 'flush + "Illegal side" + (markup-option n :side))))) + :after (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\n")) + ((right) + (display "
\n")) + ((left) + (display "

\n"))))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before (html-markup-class "center") + :after "\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre :before (html-markup-class "pre") :after "\n") + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before (html-markup-class "pre") + :after "\n") + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'itemize + :options '(:symbol) + :before (html-markup-class "ul") + :action (lambda (n e) + (for-each (lambda (item) + (let ((ident (and (markup? item) + (markup-ident item)))) + (display "") + (if ident ;; produce an anchor + (printf "\n\n" + (string-canonicalize ident))) + (output item e) + (display "\n"))) + (markup-body n))) + :after "") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before (html-markup-class "ol") + :action (lambda (n e) + (for-each (lambda (item) + (let ((ident (and (markup? item) + (markup-ident item)))) + (display "") + (if ident ;; produce an anchor + (printf "\n\n" ident)) + (output item e) + (display "\n"))) + (markup-body n))) + :after "") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) + :before (html-markup-class "dl") + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (for-each (lambda (i) + (display " ") + (output i e) + (display "")) + (if (pair? k) k (list k))) + (display "") + (output (markup-body item) e) + (display "\n"))) + (markup-body n))) + :after "") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (display "") + (output k e) + (display " ")))) + (output (markup-body n) e))) + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :options '() + :before (lambda (n e) + (display "
\n")) + :after "\n
\n") + +;*---------------------------------------------------------------------*/ +;* figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'figure + :options '(:legend :number :multicolumns :legend-width) + :before (html-markup-class "br") + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (display "\n") + (output (markup-body n) e) + (display "
\n") + (output (new markup + (markup '&html-figure-legend) + (parent n) + (ident (string-append ident "-legend")) + (class (markup-class n)) + (options `((:number ,number))) + (body legend)) + e))) + :after "
") + +;*---------------------------------------------------------------------*/ +;* &html-figure-legend ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-legend + :options '(:number) + :before (lambda (n e) + (display "
") + (let ((number (markup-option n :number)) + (legend (markup-option n :legend))) + (if number + (printf "Fig. ~a: " number) + (printf "Fig. : ")))) + :after "
") + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (cp (markup-option n :cellpadding)) + (cs (markup-option n :cellspacing))) + (display "= cp 0)) + (printf " cellpadding=\"~a\"" cp)) + (if (and (number? cs) (>= cs 0)) + (printf " cellspacing=\"~a\"" cs)) + (cond + ((symbol? cstyle) + (printf " style=\"border-collapse: ~a;\"" cstyle)) + ((string? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) + ((number? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) + (if frame + (printf " frame=\"~a\"" + (if (eq? frame 'none) "void" frame))) + (if (and rules (not (eq? rules 'header))) + (printf " rules=\"~a\"" rules)) + (display ">\n"))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '(:bg) + :before (lambda (n e) + (let ((bg (markup-option n :bg))) + (display ""))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* tc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(markup :width :align :valign :colspan :rowspan :bg) + :before (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td)) + (width (markup-option n :width)) + (align (markup-option n :align)) + (valign (let ((v (markup-option n :valign))) + (cond + ((or (eq? v 'center) + (equal? v "center")) + "middle") + (else + v)))) + (colspan (markup-option n :colspan)) + (rowspan (markup-option n :rowspan)) + (bg (markup-option n :bg))) + (printf "<~a" markup) + (html-class n) + (if width (printf " width=\"~a\"" (html-width width))) + (if align (printf " align=\"~a\"" align)) + (if valign (printf " valign=\"~a\"" valign)) + (if colspan (printf " colspan=\"~a\"" colspan)) + (if rowspan (printf " rowspan=\"~a\"" rowspan)) + (when (html-color-spec? bg) + (printf " bgcolor=\"~a\"" bg)) + (display ">"))) + :after (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td))) + (printf "" markup)))) + +;*---------------------------------------------------------------------*/ +;* image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'image + :options '(:file :url :width :height) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("gif" "jpg" "png")))))) + (if (not (string? img)) + (skribe-error 'html "Illegal image" file) + (begin + (printf "\"")")))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'roman :before "") +(markup-writer 'bold :before (html-markup-class "strong") :after "") +(markup-writer 'underline :before (html-markup-class "u") :after "") +(markup-writer 'strike :before (html-markup-class "strike") :after "") +(markup-writer 'emph :before (html-markup-class "em") :after "") +(markup-writer 'kbd :before (html-markup-class "kbd") :after "") +(markup-writer 'it :before (html-markup-class "em") :after "") +(markup-writer 'tt :before (html-markup-class "tt") :after "") +(markup-writer 'code :before (html-markup-class "code") :after "") +(markup-writer 'var :before (html-markup-class "var") :after "") +(markup-writer 'samp :before (html-markup-class "samp") :after "") +(markup-writer 'sc :before "" :after "") +(markup-writer 'sf :before "" :after "") +(markup-writer 'sub :before (html-markup-class "sub") :after "") +(markup-writer 'sup :before (html-markup-class "sup") :after "") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "\"" + :after "\"") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :action (lambda (n e) + (let ((text (markup-option n :text))) + (display ") + (if text + (output text e) + (skribe-eval (tt (markup-body n)) e)) + (display "")))) + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :predicate (lambda (n e) + (and (engine-custom e 'javascript) + (or (string? (markup-body n)) + (and (pair? (markup-body n)) + (null? (cdr (markup-body n))) + (string? (car (markup-body n))))))) + :action (lambda (n e) + (let* ((body (markup-body n)) + (email (if (string? body) body (car body))) + (split (pregexp-split "@" email)) + (na (car split)) + (do (if (pair? (cdr split)) (cadr split) "")) + (nn (pregexp-replace* "[.]" na " ")) + (dd (pregexp-replace* "[.]" do " ")) + (text (markup-option n :text))) + (display "") + (output text e) + (display "\n")))) + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :before (lambda (n e) + (printf "")) + :after "") + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) + :before (lambda (n e) + (let* ((c (handle-ast (markup-body n))) + (id (markup-ident c)) + (f (html-file c e)) + (class (if (markup-class n) + (markup-class n) + "inbound"))) + (printf ""))) + :action (lambda (n e) + (let ((t (markup-option n :text)) + (m (markup-option n 'mark)) + (f (markup-option n :figure)) + (c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection))) + (cond + (t + (output t e)) + (f + (output (new markup + (markup '&html-figure-ref) + (body (markup-body n))) + e)) + ((or c s ss sss) + (output (new markup + (markup '&html-section-ref) + (body (markup-body n))) + e)) + + ((not m) + (output (new markup + (markup '&html-unmark-ref) + (body (markup-body n))) + e)) + (else + (display m))))) + :after "") + +;*---------------------------------------------------------------------*/ +;* &html-figure-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (or (not (markup? c)) + (not (is-markup? c 'figure))) + (display "???") + (output (markup-option c :number) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-section-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-section-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (output (markup-option c :title) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-unmark-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-unmark-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (let ((t (markup-option c :title))) + (if t + (output t e) + (let ((l (markup-option c :legend))) + (if l + (output t e) + (display + (string-canonicalize + (markup-ident c))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) (output n e (markup-writer-get 'ref e))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (output (car rs) e (markup-writer-get 'ref e)) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* url-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :before (lambda (n e) + (let* ((url (markup-option n :url)) + (class (cond + ((markup-class n) + (markup-class n)) + ((not (string? url)) + #f) + (else + (let ((l (string-length url))) + (let loop ((i 0)) + (cond + ((= i l) + #f) + ((char=? (string-ref url i) #\:) + (substring url 0 i)) + (else + (loop (+ i 1)))))))))) + (display ""))) + :action (lambda (n e) + (let ((v (markup-option n :text))) + (output (or v (markup-option n :url)) e))) + :after "") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before (html-markup-class "i") + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (v (string->number (markup-option n :text)))) + (if (and (number? o) (number? v)) + (markup-option-add! n :text (+ o v))) + (output n e (markup-writer-get 'ref e)) + (if (and (number? o) (number? v)) + (markup-option-add! n :text v)))) + :after "") + +;*---------------------------------------------------------------------*/ +;* page-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'page-ref + :options '(:mark :handle) + :action (lambda (n e) + (error 'page-ref:html "Not implemented yet" n))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before (lambda (n e) + (printf "")) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-label base-engine))) + :after "") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url (or (markup-option en 'url) + (markup-option en 'documenturl))) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let* ((en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (t (bold (markup-body url)))) + (skribe-eval (ref :url (markup-body url) :text t) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) + (display "") + (for-each (lambda (h) + (let ((f (engine-custom e 'index-header-font-size))) + (if f + (skribe-eval (font :size f (bold (it h))) e) + (output h e)) + (display " "))) + (markup-body n)) + (display "") + (skribe-eval (linebreak 2) e))) + +;*---------------------------------------------------------------------*/ +;* &source-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-line-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-keyword ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &source-error ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-define ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-module ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-markup ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-thread ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-string ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-key ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm new file mode 100644 index 0000000..614ca99 --- /dev/null +++ b/src/guile/skribilo/engine/html4.scm @@ -0,0 +1,167 @@ +;;;; +;;;; html4.skr -- HTML 4.01 Engine +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 18-Feb-2004 11:58 (eg) +;;;; Last file update: 26-Feb-2004 21:09 (eg) +;;;; + +(define-skribe-module (skribilo engine html4)) + +(define (find-children node) + (define (flat l) + (cond + ((null? l) l) + ((pair? l) (append (flat (car l)) + (flat (cdr l)))) + (else (list l)))) + + (if (markup? node) + (flat (markup-body node)) + node)) + +;;; ====================================================================== + +(let ((le (find-engine 'html))) + ;;---------------------------------------------------------------------- + ;; Customizations + ;;---------------------------------------------------------------------- + (engine-custom-set! le 'html-variant "html4") + (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") + (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") + + ;;---------------------------------------------------------------------- + ;; &html-html ... + ;;---------------------------------------------------------------------- + (markup-writer '&html-html le + :before " +\n" + :after "") + + ;;---------------------------------------------------------------------- + ;; &html-ending + ;;---------------------------------------------------------------------- + (let* ((img (engine-custom le 'html4-logo)) + (url (engine-custom le 'html4-validator)) + (bottom (list (hrule) + (table :width 100. + (tr + (td :align 'left + (font :size -1 [ + This ,(sc "Html") page has been produced by + ,(ref :url (skribe-url) :text "Skribe"). + ,(linebreak) + Last update ,(it (date)).])) + (td :align 'right :valign 'top + (ref :url url + :text (image :url img :width 88 :height 31)))))))) + (markup-writer '&html-ending le + :before "
" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval bottom e)))) + :after "
\n")) + + ;;---------------------------------------------------------------------- + ;; color ... + ;;---------------------------------------------------------------------- + (markup-writer 'color le + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when bg + (display "\n") + (display "\n
")) + (when fg + (display "")))) + :after (lambda (n e) + (when (markup-option n :fg) + (display "")) + (when (markup-option n :bg) + (display "
")))) + + ;;---------------------------------------------------------------------- + ;; font ... + ;;---------------------------------------------------------------------- + (markup-writer 'font le + :options '(:size :face) + :before (lambda (n e) + (let ((face (markup-option n :face)) + (size (let ((sz (markup-option n :size))) + (cond + ((or (unspecified? sz) (not sz)) + #f) + ((and (number? sz) (or (inexact? sz) (negative? sz))) + (format "~a%" + (+ 100 + (* 20 (inexact->exact (truncate sz)))))) + ((number? sz) + sz) + (else + (skribe-error 'font + (format "Illegal font size ~s" sz) + n)))))) + (display ""))) + :after "") + + ;;---------------------------------------------------------------------- + ;; paragraph ... + ;;---------------------------------------------------------------------- + (copy-markup-writer 'paragraph le + :validate (lambda (n e) + (let ((pred (lambda (x) + (and (container? x) + (not (memq (markup-markup x) '(font color))))))) + (not (any pred (find-children n)))))) + + ;;---------------------------------------------------------------------- + ;; roman ... + ;;---------------------------------------------------------------------- + (markup-writer 'roman le + :before "" + :after "") + + ;;---------------------------------------------------------------------- + ;; table ... + ;;---------------------------------------------------------------------- + (let ((old-writer (markup-writer-get 'table le))) + (copy-markup-writer 'table le + :validate (lambda (n e) + (not (null? (markup-body n)))))) +) diff --git a/src/guile/skribilo/engine/latex-simple.scm b/src/guile/skribilo/engine/latex-simple.scm new file mode 100644 index 0000000..638c158 --- /dev/null +++ b/src/guile/skribilo/engine/latex-simple.scm @@ -0,0 +1,103 @@ +(define-skribe-module (skribilo engine latex-simple)) + +;;; +;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER +;;; CE FICHIER (sion simplifie il ne rest plus grand chose) +;;; Erick 27-10-04 +;;; + + +;*=====================================================================*/ +;* scmws04/src/latex-style.skr */ +;* ------------------------------------------------------------- */ +;* Author : Damien Ciabrini */ +;* Creation : Tue Aug 24 19:17:04 2004 */ +;* Last change : Thu Oct 28 21:45:25 2004 (eg) */ +;* Copyright : 2004 Damien Ciabrini, see LICENCE file */ +;* ------------------------------------------------------------- */ +;* Custom style for Latex... */ +;*=====================================================================*/ + +(let* ((le (find-engine 'latex)) + (oa (markup-writer-get 'author le))) + ; latex class & package for the workshop + (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}") + (engine-custom-set! le 'usepackage + "\\usepackage{epsfig} +\\usepackage{workshop} +\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} + {September 22, 2004, Snowbird, Utah, USA.} +\\CopyrightYear{2004} +\\CopyrightHolder{Damien Ciabrini} +\\renewcommand{\\ttdefault}{cmtt} +") + (engine-custom-set! le 'image-format '("eps")) + (engine-custom-set! le 'source-define-color "#000080") + (engine-custom-set! le 'source-thread-color "#8080f0") + (engine-custom-set! le 'source-string-color "#000000") + + ; hyperref options + (engine-custom-set! le 'hyperref #t) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}") + ; nbsp with ~ char + (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding)) + + ; let latex process citations + (markup-writer 'bib-ref le + :options '(:text :bib) + :before "\\cite{" + :action (lambda (n e) (display (markup-option n :bib))) + :after "}") + (markup-writer 'bib-ref+ le + :options '(:text :bib) + :before "\\cite{" + :action (lambda (n e) + (let loop ((bibs (markup-option n :bib))) + (if (pair? bibs) + (begin + (display (car bibs)) + (if (pair? (cdr bibs)) (display ", ")) + (loop (cdr bibs)))))) + :after "}") + (markup-writer '&the-bibliography le + :action (lambda (n e) + (print "\\bibliographystyle{abbrv}") + (display "\\bibliography{biblio}"))) + + ; ACM-style for authors + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (if (pair? body) + (print "\\numberofauthors{" (length body) "}")) + (print "\\author{"))) + :after "}\n") + (markup-writer 'author le + :options (writer-options oa) + :before "" + :action (lambda (n e) + (let ((name (markup-option n :name)) + (affiliation (markup-option n :affiliation)) + (address (markup-option n :address)) + (email (markup-option n :email))) + (define (row pre n post) + (display pre) + (output n e) + (display post) + (display "\\\\\n")) + ;; name + (if name (row "\\alignauthor " name "")) + ;; affiliation + (if affiliation (row "\\affaddr{" affiliation "}")) + ;; address + (if (pair? address) + (for-each (lambda (x) + (row "\\affaddr{" x "}")) address)) + ;; email + (if email (row "\\email{" email "}")))) + :after "") +) + +(define (include-biblio) + (the-bibliography)) diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm new file mode 100644 index 0000000..bc20493 --- /dev/null +++ b/src/guile/skribilo/engine/latex.scm @@ -0,0 +1,1780 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/latex.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 09:46:09 2003 */ +;* Last change : Thu May 26 12:59:47 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* LaTeX Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/latexe.skb:ref@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* latex-verbatim-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-verbatim-encoding + '((#\\ "{\\char92}") + (#\^ "{\\char94}") + (#\{ "\\{") + (#\} "\\}") + (#\& "\\&") + (#\$ "\\$") + (#\# "\\#") + (#\_ "\\_") + (#\% "\\%") + (#\~ "$_{\\mbox{\\char126}}$") + (#\ç "\\c{c}") + (#\Ç "\\c{C}") + (#\â "\\^{a}") + (#\Â "\\^{A}") + (#\à "\\`{a}") + (#\À "\\`{A}") + (#\é "\\'{e}") + (#\É "\\'{E}") + (#\è "\\`{e}") + (#\È "\\`{E}") + (#\ê "\\^{e}") + (#\Ê "\\^{E}") + (#\ù "\\`{u}") + (#\Ù "\\`{U}") + (#\û "\\^{u}") + (#\Û "\\^{U}") + (#\ø "{\\o}") + (#\ô "\\^{o}") + (#\Ô "\\^{O}") + (#\ö "\\\"{o}") + (#\Ö "\\\"{O}") + (#\î "\\^{\\i}") + (#\Î "\\^{I}") + (#\ï "\\\"{\\i}") + (#\Ï "\\\"{I}") + (#\] "{\\char93}") + (#\[ "{\\char91}") + (#\» "\\,{\\tiny{$^{\\gg}$}}") + (#\« "{\\tiny{$^{\\ll}$}}\\,"))) + +;*---------------------------------------------------------------------*/ +;* latex-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-encoding + (append '((#\| "$|$") + (#\< "$<$") + (#\> "$>$") + (#\: "{\\char58}") + (#\# "{\\char35}") + (#\Newline " %\n")) + latex-verbatim-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-tt-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-tt-encoding + (append '((#\. ".\\-") + (#\/ "/\\-")) + latex-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-pre-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-pre-encoding + (append '((#\Space "\\ ") + (#\Newline "\\\\\n")) + latex-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define (latex-symbol-table math) + `(("iexcl" "!`") + ("cent" "c") + ("pound" "\\pounds") + ("yen" "Y") + ("section" "\\S") + ("mul" ,(math "^-")) + ("copyright" "\\copyright") + ("lguillemet" ,(math "\\ll")) + ("not" ,(math "\\neg")) + ("degree" ,(math "^{\\small{o}}")) + ("plusminus" ,(math "\\pm")) + ("micro" ,(math "\\mu")) + ("paragraph" "\\P") + ("middot" ,(math "\\cdot")) + ("rguillemet" ,(math "\\gg")) + ("1/4" ,(math "\\frac{1}{4}")) + ("1/2" ,(math "\\frac{1}{2}")) + ("3/4" ,(math "\\frac{3}{4}")) + ("iquestion" "?`") + ("Agrave" "\\`{A}") + ("Aacute" "\\'{A}") + ("Acircumflex" "\\^{A}") + ("Atilde" "\\~{A}") + ("Amul" "\\\"{A}") + ("Aring" "{\\AA}") + ("AEligature" "{\\AE}") + ("Oeligature" "{\\OE}") + ("Ccedilla" "{\\c{C}}") + ("Egrave" "{\\`{E}}") + ("Eacute" "{\\'{E}}") + ("Ecircumflex" "{\\^{E}}") + ("Euml" "\\\"{E}") + ("Igrave" "{\\`{I}}") + ("Iacute" "{\\'{I}}") + ("Icircumflex" "{\\^{I}}") + ("Iuml" "\\\"{I}") + ("ETH" "D") + ("Ntilde" "\\~{N}") + ("Ograve" "\\`{O}") + ("Oacute" "\\'{O}") + ("Ocurcumflex" "\\^{O}") + ("Otilde" "\\~{O}") + ("Ouml" "\\\"{O}") + ("times" ,(math "\\times")) + ("Oslash" "\\O") + ("Ugrave" "\\`{U}") + ("Uacute" "\\'{U}") + ("Ucircumflex" "\\^{U}") + ("Uuml" "\\\"{U}") + ("Yacute" "\\'{Y}") + ("szlig" "\\ss") + ("agrave" "\\`{a}") + ("aacute" "\\'{a}") + ("acircumflex" "\\^{a}") + ("atilde" "\\~{a}") + ("amul" "\\\"{a}") + ("aring" "\\aa") + ("aeligature" "\\ae") + ("oeligature" "{\\oe}") + ("ccedilla" "{\\c{c}}") + ("egrave" "{\\`{e}}") + ("eacute" "{\\'{e}}") + ("ecircumflex" "{\\^{e}}") + ("euml" "\\\"{e}") + ("igrave" "{\\`{\\i}}") + ("iacute" "{\\'{\\i}}") + ("icircumflex" "{\\^{\\i}}") + ("iuml" "\\\"{\\i}") + ("ntilde" "\\~{n}") + ("ograve" "\\`{o}") + ("oacute" "\\'{o}") + ("ocurcumflex" "\\^{o}") + ("otilde" "\\~{o}") + ("ouml" "\\\"{o}") + ("divide" ,(math "\\div")) + ("oslash" "\\o") + ("ugrave" "\\`{u}") + ("uacute" "\\'{u}") + ("ucircumflex" "\\^{u}") + ("uuml" "\\\"{u}") + ("yacute" "\\'{y}") + ("ymul" "\\\"{y}") + ;; Greek + ("Alpha" "A") + ("Beta" "B") + ("Gamma" ,(math "\\Gamma")) + ("Delta" ,(math "\\Delta")) + ("Epsilon" "E") + ("Zeta" "Z") + ("Eta" "H") + ("Theta" ,(math "\\Theta")) + ("Iota" "I") + ("Kappa" "K") + ("Lambda" ,(math "\\Lambda")) + ("Mu" "M") + ("Nu" "N") + ("Xi" ,(math "\\Xi")) + ("Omicron" "O") + ("Pi" ,(math "\\Pi")) + ("Rho" "P") + ("Sigma" ,(math "\\Sigma")) + ("Tau" "T") + ("Upsilon" ,(math "\\Upsilon")) + ("Phi" ,(math "\\Phi")) + ("Chi" "X") + ("Psi" ,(math "\\Psi")) + ("Omega" ,(math "\\Omega")) + ("alpha" ,(math "\\alpha")) + ("beta" ,(math "\\beta")) + ("gamma" ,(math "\\gamma")) + ("delta" ,(math "\\delta")) + ("epsilon" ,(math "\\varepsilon")) + ("zeta" ,(math "\\zeta")) + ("eta" ,(math "\\eta")) + ("theta" ,(math "\\theta")) + ("iota" ,(math "\\iota")) + ("kappa" ,(math "\\kappa")) + ("lambda" ,(math "\\lambda")) + ("mu" ,(math "\\mu")) + ("nu" ,(math "\\nu")) + ("xi" ,(math "\\xi")) + ("omicron" ,(math "\\o")) + ("pi" ,(math "\\pi")) + ("rho" ,(math "\\rho")) + ("sigmaf" ,(math "\\varsigma")) + ("sigma" ,(math "\\sigma")) + ("tau" ,(math "\\tau")) + ("upsilon" ,(math "\\upsilon")) + ("phi" ,(math "\\varphi")) + ("chi" ,(math "\\chi")) + ("psi" ,(math "\\psi")) + ("omega" ,(math "\\omega")) + ("thetasym" ,(math "\\vartheta")) + ("piv" ,(math "\\varpi")) + ;; punctuation + ("bullet" ,(math "\\bullet")) + ("ellipsis" ,(math "\\ldots")) + ("weierp" ,(math "\\wp")) + ("image" ,(math "\\Im")) + ("real" ,(math "\\Re")) + ("tm" ,(math "^{\\sc\\tiny{tm}}")) + ("alef" ,(math "\\aleph")) + ("<-" ,(math "\\leftarrow")) + ("<--" ,(math "\\longleftarrow")) + ("uparrow" ,(math "\\uparrow")) + ("->" ,(math "\\rightarrow")) + ("-->" ,(math "\\longrightarrow")) + ("downarrow" ,(math "\\downarrow")) + ("<->" ,(math "\\leftrightarrow")) + ("<-->" ,(math "\\longleftrightarrow")) + ("<+" ,(math "\\hookleftarrow")) + ("<=" ,(math "\\Leftarrow")) + ("<==" ,(math "\\Longleftarrow")) + ("Uparrow" ,(math "\\Uparrow")) + ("=>" ,(math "\\Rightarrow")) + ("==>" ,(math "\\Longrightarrow")) + ("Downarrow" ,(math "\\Downarrow")) + ("<=>" ,(math "\\Leftrightarrow")) + ("<==>" ,(math "\\Longleftrightarrow")) + ;; Mathematical operators + ("forall" ,(math "\\forall")) + ("partial" ,(math "\\partial")) + ("exists" ,(math "\\exists")) + ("emptyset" ,(math "\\emptyset")) + ("infinity" ,(math "\\infty")) + ("nabla" ,(math "\\nabla")) + ("in" ,(math "\\in")) + ("notin" ,(math "\\notin")) + ("ni" ,(math "\\ni")) + ("prod" ,(math "\\Pi")) + ("sum" ,(math "\\Sigma")) + ("asterisk" ,(math "\\ast")) + ("sqrt" ,(math "\\surd")) + ("propto" ,(math "\\propto")) + ("angle" ,(math "\\angle")) + ("and" ,(math "\\wedge")) + ("or" ,(math "\\vee")) + ("cap" ,(math "\\cap")) + ("cup" ,(math "\\cup")) + ("integral" ,(math "\\int")) + ("models" ,(math "\\models")) + ("vdash" ,(math "\\vdash")) + ("dashv" ,(math "\\dashv")) + ("sim" ,(math "\\sim")) + ("cong" ,(math "\\cong")) + ("approx" ,(math "\\approx")) + ("neq" ,(math "\\neq")) + ("equiv" ,(math "\\equiv")) + ("le" ,(math "\\leq")) + ("ge" ,(math "\\geq")) + ("subset" ,(math "\\subset")) + ("supset" ,(math "\\supset")) + ("subseteq" ,(math "\\subseteq")) + ("supseteq" ,(math "\\supseteq")) + ("oplus" ,(math "\\oplus")) + ("otimes" ,(math "\\otimes")) + ("perp" ,(math "\\perp")) + ("mid" ,(math "\\mid")) + ("lceil" ,(math "\\lceil")) + ("rceil" ,(math "\\rceil")) + ("lfloor" ,(math "\\lfloor")) + ("rfloor" ,(math "\\rfloor")) + ("langle" ,(math "\\langle")) + ("rangle" ,(math "\\rangle")) + ;; Misc + ("loz" ,(math "\\diamond")) + ("spades" ,(math "\\spadesuit")) + ("clubs" ,(math "\\clubsuit")) + ("hearts" ,(math "\\heartsuit")) + ("diams" ,(math "\\diamondsuit")) + ("euro" "\\euro{}") + ;; LaTeX + ("dag" "\\dag") + ("ddag" "\\ddag") + ("circ" ,(math "\\circ")) + ("top" ,(math "\\top")) + ("bottom" ,(math "\\bot")) + ("lhd" ,(math "\\triangleleft")) + ("rhd" ,(math "\\triangleright")) + ("parallel" ,(math "\\parallel")))) + +;*---------------------------------------------------------------------*/ +;* latex-engine ... */ +;*---------------------------------------------------------------------*/ +(define latex-engine + (default-engine-set! + (make-engine 'latex + :version 1.0 + :format "latex" + :delegate (find-engine 'base) + :filter (make-string-replace latex-encoding) + :custom '((documentclass "\\documentclass{article}") + (usepackage "\\usepackage{epsfig}\n") + (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n") + (postdocument #f) + (maketitle "\\date{}\n\\maketitle") + (%font-size 0) + ;; color + (color #t) + (color-usepackage "\\usepackage{color}\n") + ;; hyperref + (hyperref #t) + (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n") + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + (image-format ("eps")) + (index-page-ref #t)) + :symbol-table (latex-symbol-table + (lambda (m) + (format "\\begin{math}~a\\end{math}" m)))))) + +;*---------------------------------------------------------------------*/ +;* latex-title-engine ... */ +;*---------------------------------------------------------------------*/ +(define latex-title-engine + (make-engine 'latex-title + :version 1.0 + :format "latex-title" + :delegate latex-engine + :filter (make-string-replace latex-encoding) + :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m))))) + +;*---------------------------------------------------------------------*/ +;* latex-color? ... */ +;*---------------------------------------------------------------------*/ +(define (latex-color? e) + (engine-custom e 'color)) + +;*---------------------------------------------------------------------*/ +;* LaTeX ... */ +;*---------------------------------------------------------------------*/ +(define-markup (LaTeX #!key (space #t)) + (if (engine-format? "latex") + (! (if space "\\LaTeX\\ " "\\LaTeX")) + "LaTeX")) + +;*---------------------------------------------------------------------*/ +;* TeX ... */ +;*---------------------------------------------------------------------*/ +(define-markup (TeX #!key (space #t)) + (if (engine-format? "latex") + (! (if space "\\TeX\\ " "\\TeX")) + "TeX")) + +;*---------------------------------------------------------------------*/ +;* latex ... */ +;*---------------------------------------------------------------------*/ +(define-markup (!latex fmt #!rest opt) + (if (engine-format? "latex") + (apply ! fmt opt) + #f)) + +;*---------------------------------------------------------------------*/ +;* latex-width ... */ +;*---------------------------------------------------------------------*/ +(define (latex-width width) + (if (and (number? width) (inexact? width)) + (string-append (number->string (/ width 100.)) "\\linewidth") + (string-append (number->string width) "pt"))) + +;*---------------------------------------------------------------------*/ +;* latex-font-size ... */ +;*---------------------------------------------------------------------*/ +(define (latex-font-size size) + (case size + ((4) "Huge") + ((3) "huge") + ((2) "Large") + ((1) "large") + ((0) "normalsize") + ((-1) "small") + ((-2) "footnotesize") + ((-3) "scriptsize") + ((-4) "tiny") + (else (if (number? size) + (if (< size 0) "tiny" "Huge") + "normalsize")))) + +;*---------------------------------------------------------------------*/ +;* *skribe-latex-color-table* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-latex-color-table* #f) + +;*---------------------------------------------------------------------*/ +;* latex-declare-color ... */ +;*---------------------------------------------------------------------*/ +(define (latex-declare-color name rgb) + (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) + +;*---------------------------------------------------------------------*/ +;* skribe-get-latex-color ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-latex-color spec) + (let ((c (and (hashtable? *skribe-latex-color-table*) + (hashtable-get *skribe-latex-color-table* spec)))) + (if (not (string? c)) + (skribe-error 'latex "Can't find color" spec) + c))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->latex-rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->latex-rgb spec) + (receive (r g b) + (skribe-color->rgb spec) + (cond + ((and (= r 0) (= g 0) (= b 0)) + "0.,0.,0.") + ((and (= r #xff) (= g #xff) (= b #xff)) + "1.,1.,1.") + (else + (let ((ff (exact->inexact #xff))) + (format "~a,~a,~a" + (number->string (/ r ff)) + (number->string (/ g ff)) + (number->string (/ b ff)))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-latex-declare-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-latex-declare-colors colors) + (set! *skribe-latex-color-table* (make-hashtable)) + (for-each (lambda (spec) + (let ((old (hashtable-get *skribe-latex-color-table* spec))) + (if (not (string? old)) + (let ((name (symbol->string (gensym 'c)))) + ;; bind the color + (hashtable-put! *skribe-latex-color-table* spec name) + ;; and emit a latex declaration + (latex-declare-color + name + (skribe-color->latex-rgb spec)))))) + colors)) + +;*---------------------------------------------------------------------*/ +;* &~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&~ + :before "~" + :action #f) + +;*---------------------------------------------------------------------*/ +;* &latex-table-start */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-start + :options '() + :action (lambda (n e) + (let ((width (markup-option n 'width))) + (if (number? width) + (printf "\\begin{tabular*}{~a}" (latex-width width)) + (display "\\begin{tabular}"))))) + +;*---------------------------------------------------------------------*/ +;* &latex-table-stop */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-stop + :options '() + :action (lambda (n e) + (let ((width (markup-option n 'width))) + (if (number? width) + (display "\\end{tabular*}\n") + (display "\\end{tabular}\n"))))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :env) + :before (lambda (n e) + ;; documentclass + (let ((dc (engine-custom e 'documentclass))) + (if dc + (begin (display dc) (newline)) + (display "\\documentclass{article}\n"))) + (if (latex-color? e) + (display (engine-custom e 'color-usepackage))) + (if (engine-custom e 'hyperref) + (display (engine-custom e 'hyperref-usepackage))) + ;; usepackage + (let ((pa (engine-custom e 'usepackage))) + (if pa (begin (display pa) (newline)))) + ;; colors + (if (latex-color? e) + (begin + (skribe-use-color! (engine-custom e 'source-comment-color)) + (skribe-use-color! (engine-custom e 'source-define-color)) + (skribe-use-color! (engine-custom e 'source-module-color)) + (skribe-use-color! (engine-custom e 'source-markup-color)) + (skribe-use-color! (engine-custom e 'source-thread-color)) + (skribe-use-color! (engine-custom e 'source-string-color)) + (skribe-use-color! (engine-custom e 'source-bracket-color)) + (skribe-use-color! (engine-custom e 'source-type-color)) + (display "\n%% colors\n") + (skribe-latex-declare-colors (skribe-get-used-colors)) + (display "\n\n"))) + ;; predocument + (let ((pd (engine-custom e 'predocument))) + (when pd (display pd) (newline))) + ;; title + (let ((t (markup-option n :title))) + (when t + (skribe-eval (new markup + (markup '&latex-title) + (body t)) + e + :env `((parent ,n))))) + ;; author + (let ((a (markup-option n :author))) + (when a + (skribe-eval (new markup + (markup '&latex-author) + (body a)) + e + :env `((parent ,n))))) + ;; document + (display "\\begin{document}\n") + ;; postdocument + (let ((pd (engine-custom e 'postdocument))) + (if pd (begin (display pd) (newline)))) + ;; maketitle + (let ((mt (engine-custom e 'maketitle))) + (if mt (begin (display mt) (newline))))) + :action (lambda (n e) + (output (markup-body n) e)) + :after (lambda (n e) + (display "\n\\end{document}\n"))) + +;*---------------------------------------------------------------------*/ +;* &latex-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-title + :before "\\title{" + :after "}\n") + +;*---------------------------------------------------------------------*/ +;* &latex-author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-author + :before "\\author{\\centerline{\n" + :action (lambda (n e) + (let ((body (markup-body n))) + (if (pair? body) + (begin + (output (new markup + (markup '&latex-table-start) + (class "&latex-author-table")) + e) + (printf "{~a}\n" (make-string (length body) #\c)) + (let loop ((as body)) + (output (car as) e) + (if (pair? (cdr as)) + (begin + (display " & ") + (loop (cdr as))))) + (display "\\\\\n") + (output (new markup + (markup '&latex-table-stop) + (class "&latex-author-table")) + e)) + (output body e)))) + :after "}}\n") + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (output (new markup + (markup '&latex-table-start) + (class "author")) + e) + (printf "{~a}\n" + (case (markup-option n :align) + ((left) "l") + ((right) "r") + (else "c")))) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (cond + ((pair? address) + (for-each row address)) + ((string? address) + (row address))) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url)))) + :after (lambda (n e) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :predicate (lambda (n e) (markup-option n :photo)) + :before (lambda (n e) + (output (new markup + (markup '&latex-table-start) + (class "author")) + e) + (printf "{cc}\n")) + :action (lambda (n e) + (let ((photo (markup-option n :photo))) + (output photo e) + (display " & ") + (markup-option-add! n :photo #f) + (output n e) + (markup-option-add! n :photo photo) + (display "\\\\\n"))) + :after (lambda (n e) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options '() + :action (lambda (n e) (display "\\tableofcontents\n"))) + +;*---------------------------------------------------------------------*/ +;* latex-block-before ... */ +;*---------------------------------------------------------------------*/ +(define (latex-block-before m) + (lambda (n e) + (let ((num (markup-option n :number))) + (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (printf "\\~a~a{" m (if (not num) "*" "")) + (output (markup-option n :title) latex-title-engine) + (display "}\n") + (when num + (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) + +;*---------------------------------------------------------------------*/ +;* section ... .. @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :before (latex-block-before 'chapter)) + +;*---------------------------------------------------------------------*/ +;* section ... . @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :number :toc :file :env) + :before (latex-block-before 'section)) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :before (latex-block-before 'subsection)) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :before (latex-block-before 'subsubsection)) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :options '(:title :number :toc :env) + :before (lambda (n e) + (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) + (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" + (ast-location n))) + (display "\\noindent ")) + :after "\\par\n") + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :before "\\footnote{" + :after "}") + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :action (lambda (n e) + (display "\\makebox[\\linewidth]{}"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '() + :before "\\hrulefill" + :action #f) + +;*---------------------------------------------------------------------*/ +;* latex-color-counter */ +;*---------------------------------------------------------------------*/ +(define latex-color-counter 1) + +;*---------------------------------------------------------------------*/ +;* latex-color ... */ +;*---------------------------------------------------------------------*/ +(define latex-color + (lambda (bg fg n e) + (if (not (latex-color? e)) + (output n e) + (begin + (if bg + (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) + (set! latex-color-counter (+ latex-color-counter 1)) + (if fg + (begin + (printf "\\textcolor{~a}{" (skribe-get-latex-color fg)) + (output n e) + (display "}")) + (output n e)) + (set! latex-color-counter (- latex-color-counter 1)) + (if bg + (printf "\\egroup\\colorbox{~a}{\\box~a}%\n" + (skribe-get-latex-color bg) latex-color-counter)))))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:bg :fg :width) + :action (lambda (n e) + (let* ((w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (m (markup-option n :margin)) + (tw (cond + ((not w) + #f) + ((and (integer? w) (exact? w)) + w) + ((real? w) + (latex-width w))))) + (when bg + (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") + (when m + (printf "\\addtolength{\\tabcolsep}{~a}" + (latex-width m))) + (output (new markup + (markup '&latex-table-start) + (class "color")) + e) + (if tw + (printf "{p{~a}}\n" tw) + (printf "{l}\n"))) + (latex-color bg fg (markup-body n) e) + (when bg + (output (new markup + (markup '&latex-table-stop) + (class "color")) + e) + (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n"))))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + :options '(:width :border :margin) + :before (lambda (n e) + (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") + (let ((m (markup-option n :margin))) + (when m + (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) + (newline)) + :action (lambda (n e) + (let* ((b (markup-option n :border)) + (w (markup-option n :width)) + (tw (cond + ((not w) + ".96\\linewidth") + ((and (integer? w) (exact? w)) + w) + ((real? w) + (latex-width w))))) + (output (new markup + (markup '&latex-table-start) + (class "frame")) + e) + (if (and (integer? b) (> b 0)) + (begin + (printf "{|p{~a}|}\\hline\n" tw) + (output (markup-body n) e) + (display "\\\\\\hline\n")) + (begin + (printf "{p{~a}}\n" tw) + (output (markup-body n) e))) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n") + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size) + :action (lambda (n e) + (let* ((size (markup-option n :size)) + (cs (let ((n (engine-custom e '%font-size))) + (if (number? n) + n + 0))) + (ns (cond + ((and (integer? size) (exact? size)) + (if (> size 0) + size + (+ cs size))) + ((and (number? size) (inexact? size)) + (+ cs (inexact->exact size))) + ((string? size) + (let ((nb (string->number size))) + (if (not (number? nb)) + (skribe-error + 'font + (format "Illegal font size ~s" size) + nb) + (+ cs nb)))))) + (ne (make-engine (gensym 'latex) + :delegate e + :filter (engine-filter e) + :symbol-table (engine-symbol-table e) + :custom `((%font-size ,ns) + ,@(engine-customs e))))) + (printf "{\\~a{" (latex-font-size ns)) + (output (markup-body n) ne) + (display "}}")))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\\begin{center}\n")) + ((left) + (display "\\begin{flushleft}")) + ((right) + (display "\\begin{flushright}")))) + :after (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\\end{center}\n")) + ((left) + (display "\\end{flushleft}\n")) + ((right) + (display "\\end{flushright}\n"))))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before "\\begin{center}\n" + :after "\\end{center}\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre + :before (lambda (n e) + (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" + latex-color-counter) + (output (new markup + (markup '&latex-table-start) + (class "pre")) + e) + (display "{l}\n") + (set! latex-color-counter (+ latex-color-counter 1))) + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after (lambda (n e) + (set! latex-color-counter (- latex-color-counter 1)) + (output (new markup + (markup '&latex-table-stop) + (class "pre")) + e) + (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before (lambda (n e) + (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{" + latex-color-counter) + (output (new markup + (markup '&latex-table-start) + (class "pre")) + e) + (display "{l}\n") + (set! latex-color-counter (+ latex-color-counter 1))) + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after (lambda (n e) + (set! latex-color-counter (- latex-color-counter 1)) + (output (new markup + (markup '&latex-table-stop) + (class "prog")) + e) + (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&prog-line + :before (lambda (n e) + (let ((n (markup-ident n))) + (if n (skribe-eval (it (list n) ": ") e)))) + :after "\\\\\n") + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'itemize + :options '(:symbol) + :before "\\begin{itemize}\n" + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{itemize} ") + +(markup-writer 'itemize + :predicate (lambda (n e) (markup-option n :symbol)) + :options '(:symbol) + :before (lambda (n e) + (display "\\begin{list}{") + (output (markup-option n :symbol) e) + (display "}{}") + (newline)) + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{list}\n") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before "\\begin{enumerate}\n" + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{enumerate}\n") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) + :before "\\begin{description}\n" + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (for-each (lambda (i) + (display " \\item[") + (output i e) + (display "]\n")) + (if (pair? k) k (list k))) + (output (markup-body item) e))) + (markup-body n))) + :after "\\end{description}\n") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (display "[") + (output k e) + (display "] ")))) + (output (markup-body n) e))) + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :before "\n\\begin{quote}\n" + :after "\n\\end{quote}") + +;*---------------------------------------------------------------------*/ +;* figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'figure + :options '(:legend :number :multicolumns) + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend)) + (mc (markup-option n :multicolumns))) + (display (if mc + "\\begin{figure*}[!th]\n" + "\\begin{figure}[ht]\n")) + (output (markup-body n) e) + (printf "\\caption{\\label{~a}" (string-canonicalize ident)) + (output legend e) + (display (if mc + "}\\end{figure*}\n" + "}\\end{figure}\n"))))) + +;*---------------------------------------------------------------------*/ +;* table-column-number ... */ +;* ------------------------------------------------------------- */ +;* Computes how many columns are contained in a table. */ +;*---------------------------------------------------------------------*/ +(define (table-column-number t) + (define (row-columns row) + (let luup ((cells (markup-body row)) + (nbcols 0)) + (cond + ((null? cells) + nbcols) + ((pair? cells) + (luup (cdr cells) + (+ nbcols (markup-option (car cells) :colspan)))) + (else + (skribe-type-error 'tr "Illegal tr body, " row "pair"))))) + (let loop ((rows (markup-body t)) + (nbcols 0)) + (if (null? rows) + nbcols + (loop (cdr rows) + (max (row-columns (car rows)) nbcols))))) + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:width :frame :rules :cellstyle) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (nbcols (table-column-number n)) + (id (markup-ident n)) + (cla (markup-class n)) + (rows (markup-body n))) + ;; the table header + (output (new markup + (markup '&latex-table-start) + (class "table") + (options `((width ,width)))) + e) + ;; store the actual number of columns + (markup-option-add! n '&nbcols nbcols) + ;; compute the table header + (let ((cols (cond + ((= nbcols 0) + (skribe-error 'table + "Illegal empty table" + n)) + ((or (not width) (= nbcols 1)) + (make-string nbcols #\c)) + (else + (let ((v (make-vector + (- nbcols 1) + "@{\\extracolsep{\\fill}}c"))) + (apply string-append + (cons "c" (vector->list v)))))))) + (case frame + ((none) + (printf "{~a}\n" cols)) + ((border box) + (printf "{|~a|}" cols) + (markup-option-add! n '&lhs #t) + (markup-option-add! n '&rhs #t) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-above" id)) + (class "table-line-above")) + e)) + ((above hsides) + (printf "{~a}" cols) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-above" id)) + (class "table-line-above")) + e)) + ((vsides) + (markup-option-add! n '&lhs #t) + (markup-option-add! n '&rhs #t) + (printf "{|~a|}\n" cols)) + ((lhs) + (markup-option-add! n '&lhs #t) + (printf "{|~a}\n" cols)) + ((rhs) + (markup-option-add! n '&rhs #t) + (printf "{~a|}\n" cols)) + (else + (printf "{~a}\n" cols))) + ;; mark each row with appropriate '&tl (top-line) + ;; and &bl (bottom-line) options + (when (pair? rows) + (if (and (memq rules '(rows all)) + (or (not (eq? cstyle 'collapse)) + (not (memq frame '(border box above hsides))))) + (let ((frow (car rows))) + (if (is-markup? frow 'tr) + (markup-option-add! frow '&tl #t)))) + (if (eq? rules 'header) + (let ((frow (car rows))) + (if (is-markup? frow 'tr) + (markup-option-add! frow '&bl #t)))) + (when (and (pair? (cdr rows)) + (memq rules '(rows all))) + (for-each (lambda (row) + (if (is-markup? row 'tr) + (markup-option-add! row '&bl #t))) + rows) + (markup-option-add! (car (last-pair rows)) '&bl #f)) + (if (and (memq rules '(rows all)) + (or (not (eq? cstyle 'collapse)) + (not (memq frame '(border box above hsides))))) + (let ((lrow (car (last-pair rows)))) + (if (is-markup? lrow 'tr) + (markup-option-add! lrow '&bl #t)))))))) + :after (lambda (n e) + (case (markup-option n :frame) + ((hsides below box border) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-below" (markup-ident n))) + (class "table-hline-below")) + e))) + (output (new markup + (markup '&latex-table-stop) + (class "table") + (options `((width ,(markup-option n :width))))) + e))) + +;*---------------------------------------------------------------------*/ +;* &latex-table-hline */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-hline + :action "\\hline\n") + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '() + :action (lambda (n e) + (let* ((parent (ast-parent n)) + (_ (if (not (is-markup? parent 'table)) + (skribe-type-error 'tr "Illegal parent, " parent + "#"))) + (nbcols (markup-option parent '&nbcols)) + (lhs (markup-option parent '&lhs)) + (rhs (markup-option parent '&rhs)) + (rules (markup-option parent :rules)) + (collapse (eq? (markup-option parent :cellstyle) + 'collapse)) + (vrules (memq rules '(cols all))) + (cells (markup-body n))) + (if (markup-option n '&tl) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (markup-ident n)) + (class (markup-class n))) + e)) + (if (> nbcols 0) + (let laap ((nbc nbcols) + (cs cells)) + (if (null? cs) + (when (> nbc 1) + (display " & ") + (laap (- nbc 1) cs)) + (let* ((c (car cs)) + (nc (- nbc (markup-option c :colspan)))) + (when (= nbcols nbc) + (cond + ((and lhs vrules (not collapse)) + (markup-option-add! c '&lhs "||")) + ((or lhs vrules) + (markup-option-add! c '&lhs #\|)))) + (when (= nc 0) + (cond + ((and rhs vrules (not collapse)) + (markup-option-add! c '&rhs "||")) + ((or rhs vrules) + (markup-option-add! c '&rhs #\|)))) + (when (and vrules (> nc 0) (< nc nbcols)) + (markup-option-add! c '&rhs #\|)) + (output c e) + (when (> nc 0) + (display " & ") + (laap nc (cdr cs))))))))) + :after (lambda (n e) + (display "\\\\") + (if (markup-option n '&bl) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (markup-ident n)) + (class (markup-class n))) + e) + (newline)))) + +;*---------------------------------------------------------------------*/ +;* tc */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(:width :align :valign :colspan) + :action (lambda (n e) + (let ((id (markup-ident n)) + (cla (markup-class n))) + (let* ((o0 (markup-body n)) + (o1 (if (eq? (markup-option n 'markup) 'th) + (new markup + (markup '&latex-th) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o0)) + o0)) + (o2 (if (markup-option n :width) + (new markup + (markup '&latex-tc-parbox) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o1)) + o1)) + (o3 (if (or (> (markup-option n :colspan) 1) + (not (eq? (markup-option n :align) + 'center)) + (markup-option n '&lhs) + (markup-option n '&rhs)) + (new markup + (markup '&latex-tc-multicolumn) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o2)) + o2))) + (output o3 e))))) + +;*---------------------------------------------------------------------*/ +;* &latex-th ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-th + :before "\\textsf{" + :after "}") + +;*---------------------------------------------------------------------*/ +;* &latex-tc-parbox ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-tc-parbox + :before (lambda (n e) + (let ((width (markup-option n :width)) + (valign (markup-option n :valign))) + (printf "\\parbox{~a}{" (latex-width width)))) + :after "}") + +;*---------------------------------------------------------------------*/ +;* &latex-tc-multicolumn ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-tc-multicolumn + :before (lambda (n e) + (let ((colspan (markup-option n :colspan)) + (lhs (or (markup-option n '&lhs) "")) + (rhs (or (markup-option n '&rhs) "")) + (align (case (markup-option n :align) + ((left) #\l) + ((center) #\c) + ((right) #\r) + (else #\c)))) + (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) + :after "}") + +;*---------------------------------------------------------------------*/ +;* image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'image + :options '(:file :url :width :height :zoom) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (zoom (markup-option n :zoom)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("eps")))))) + (if (not (string? img)) + (skribe-error 'latex "Illegal image" file) + (begin + (printf "\\epsfig{file=~a" (strip-ref-base img)) + (if width (printf ", width=~a" (latex-width width))) + (if height (printf ", height=~apt" height)) + (if zoom (printf ", zoom=\"~a\"" zoom)) + (display "}")))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'roman :before "{\\textrm{" :after "}}") +(markup-writer 'bold :before "{\\textbf{" :after "}}") +(markup-writer 'underline :before "{\\underline{" :after "}}") +(markup-writer 'emph :before "{\\em{" :after "}}") +(markup-writer 'it :before "{\\textit{" :after "}}") +(markup-writer 'code :before "{\\texttt{" :after "}}") +(markup-writer 'var :before "{\\texttt{" :after "}}") +(markup-writer 'sc :before "{\\sc{" :after "}}") +(markup-writer 'sf :before "{\\sf{" :after "}}") +(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}") +(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}") + +(markup-writer 'tt + :before "{\\texttt{" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-tt-encoding) + :custom (engine-customs e) + :symbol-table (engine-symbol-table e)))) + (output (markup-body n) ne))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "``" + :after "''") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :before "{\\texttt{" + :action (lambda (n e) + (let ((text (markup-option n :text))) + (output (or text (markup-body n)) e))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :before (lambda (n e) + (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) + :action (lambda (n e) + (let ((t (markup-option n :text))) + (if t + (begin + (output t e) + (output "~" e (markup-writer-get '&~ e)))))) + :after (lambda (n e) + (let* ((c (handle-ast (markup-body n))) + (id (markup-ident c))) + (if (markup-option n :page) + (printf "\\begin{math}{\\pageref{~a}}\\end{math}" + (string-canonicalize id)) + (printf "\\ref{~a}" + (string-canonicalize id)))))) + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (output (markup-option (handle-ast (markup-body n)) :title) e)) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (invoke (writer-action (markup-writer-get 'bib-ref e)) + (car rs) + e) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* url-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :action (lambda (n e) + (let ((text (markup-option n :text)) + (url (markup-option n :url))) + (if (not text) + (output url e) + (output text e))))) + +;*---------------------------------------------------------------------*/ +;* url-ref hyperref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :predicate (lambda (n e) + (engine-custom e 'hyperref)) + :action (lambda (n e) + (let ((body (markup-option n :text)) + (url (markup-option n :url))) + (if (and body (not (equal? body url))) + (begin + (display "\\href{") + (display url) + (display "}{") + (output body e) + (display "}")) + (begin + (display "\\href{") + (display url) + (printf "}{~a}" url)))))) + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before "{\\textit{" + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (v (string->number (markup-option n :text)))) + (cond + ((and (number? o) (number? v)) + (display (+ o v))) + (else + (display v))))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* &the-bibliography ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-bibliography + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[21]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + \\itemsep 0pt + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-label e)) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :predicate (lambda (n e) + (engine-custom e 'hyperref)) + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before "\\item[{\\char91}" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "{\\char93}] ") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let* ((en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (t (bold (markup-body url)))) + (skribe-eval (ref :url (markup-body url) :text t) e)))) + +;*---------------------------------------------------------------------*/ +;* &source-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-line-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-keyword ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (underline (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &source-error ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'error-color) cc) + (color :fg cc (underline n1)) + (underline n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-define ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-module ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-markup ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-thread ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-string ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-key ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm new file mode 100644 index 0000000..4f26d12 --- /dev/null +++ b/src/guile/skribilo/engine/xml.scm @@ -0,0 +1,113 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/xml.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 09:46:09 2003 */ +;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Generic XML Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/xmle.skb:ref@ */ +;*=====================================================================*/ + +(define-skribe-module (skribilo engine xml)) + +;*---------------------------------------------------------------------*/ +;* xml-engine ... */ +;*---------------------------------------------------------------------*/ +(define xml-engine + ;; setup the xml engine + (default-engine-set! + (make-engine 'xml + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@")))))) + +;*---------------------------------------------------------------------*/ +;* markup ... */ +;*---------------------------------------------------------------------*/ +(let ((xml-margin 0)) + (define (make-margin) + (make-string xml-margin #\space)) + (define (xml-attribute? val) + (cond + ((or (string? val) (number? val) (boolean? val)) + #t) + ((list? val) + (every? xml-attribute? val)) + (else + #f))) + (define (xml-attribute att val) + (let ((s (keyword->string att))) + (printf " ~a=\"" (substring s 1 (string-length s))) + (let loop ((val val)) + (cond + ((or (string? val) (number? val)) + (display val)) + ((boolean? val) + (display (if val "true" "false"))) + ((pair? val) + (for-each loop val)) + (else + #f))) + (display #\"))) + (define (xml-option opt val e) + (let* ((m (make-margin)) + (ks (keyword->string opt)) + (s (substring ks 1 (string-length ks)))) + (printf "~a<~a>\n" m s) + (output val e) + (printf "~a\n" m s))) + (define (xml-options n e) + ;; display the true options + (let ((opts (filter (lambda (o) + (and (keyword? (car o)) + (not (xml-attribute? (cadr o))))) + (markup-options n)))) + (if (pair? opts) + (let ((m (make-margin))) + (display m) + (display "\n") + (set! xml-margin (+ xml-margin 1)) + (for-each (lambda (o) + (xml-option (car o) (cadr o) e)) + opts) + (set! xml-margin (- xml-margin 1)) + (display m) + (display "\n"))))) + (markup-writer #t + :options 'all + :before (lambda (n e) + (printf "~a<~a" (make-margin) (markup-markup n)) + ;; display the xml attributes + (for-each (lambda (o) + (if (and (keyword? (car o)) + (xml-attribute? (cadr o))) + (xml-attribute (car o) (cadr o)))) + (markup-options n)) + (set! xml-margin (+ xml-margin 1)) + (display ">\n")) + :action (lambda (n e) + ;; options + (xml-options n e) + ;; body + (output (markup-body n) e)) + :after (lambda (n e) + (printf "~a\n" (make-margin) (markup-markup n)) + (set! xml-margin (- xml-margin 1))))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/src/guile/skribilo/eval.scm b/src/guile/skribilo/eval.scm deleted file mode 100644 index 8bae8ad..0000000 --- a/src/guile/skribilo/eval.scm +++ /dev/null @@ -1,186 +0,0 @@ -;;; -;;; eval.stk -- Skribe Evaluator -;;; -;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;; Copyright 2005 Ludovic Courtès -;;; -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program 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 General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;; USA. -;;; - - - -;; FIXME; On peut implémenter maintenant skribe-warning/node - - -(define-module (skribilo eval) - :export (skribe-eval skribe-eval-port skribe-load skribe-load-options - skribe-include - - run-time-module make-run-time-module)) - -(use-modules (skribilo debug) - (skribilo engine) - (skribilo verify) - (skribilo resolve) - (skribilo output) - (ice-9 optargs)) - - -(define *skribe-loaded* '()) ;; List of already loaded files -(define *skribe-load-options* '()) - -(define (%evaluate expr) - (eval expr (current-module))) - - -(define *skribilo-user-module* #f) - -(define *skribilo-user-imports* - '((srfi srfi-1) - (oop goops) - (skribilo module) - (skribilo config) - (skribilo vars) - (skribilo runtime) - (skribilo biblio) - (skribilo lib) - (skribilo resolve))) - - -;;; -;;; MAKE-RUN-TIME-MODULE -;;; -(define (make-run-time-module) - "Return a new module that imports all the necessary bindings required for -execution of Skribilo/Skribe code." - (let ((the-module (make-module))) - (for-each (lambda (iface) - (module-use! the-module (resolve-module iface))) - *skribilo-user-imports*) - (set-module-name! the-module '(skribilo-user)) - the-module)) - -;;; -;;; RUN-TIME-MODULE -;;; -(define (run-time-module) - "Return the default instance of a Skribilo/Skribe run-time module." - (if (not *skribilo-user-module*) - (set! *skribilo-user-module* (make-run-time-module))) - *skribilo-user-module*) - -;;; -;;; SKRIBE-EVAL -;;; -(define* (skribe-eval a e #:key (env '())) - (with-debug 2 'skribe-eval - (debug-item "a=" a " e=" (engine-ident e)) - (let ((a2 (resolve! a e env))) - (debug-item "resolved a=" a) - (let ((a3 (verify a2 e))) - (debug-item "verified a=" a3) - (output a3 e))))) - -;;; -;;; SKRIBE-EVAL-PORT -;;; -(define* (skribe-eval-port port engine #:key (env '())) - (with-debug 2 'skribe-eval-port - (debug-item "engine=" engine) - (let ((e (if (symbol? engine) (find-engine engine) engine))) - (debug-item "e=" e) - (if (not (is-a? e )) - (skribe-error 'skribe-eval-port "Cannot find engine" engine) - (let loop ((exp (read port))) - (with-debug 10 'skribe-eval-port - (debug-item "exp=" exp)) - (unless (eof-object? exp) - (skribe-eval (%evaluate exp) e :env env) - (loop (read port)))))))) - -;;; -;;; SKRIBE-LOAD -;;; -(define *skribe-load-options* '()) - -(define (skribe-load-options) - *skribe-load-options*) - -(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt) - (with-debug 4 'skribe-load - (debug-item " engine=" engine) - (debug-item " path=" path) - (debug-item " opt" opt) - - (let* ((ei (cond - ((not engine) *skribe-engine*) - ((engine? engine) engine) - ((not (symbol? engine)) (skribe-error 'skribe-load - "Illegal engine" engine)) - (else engine))) - (path (cond - ((not path) (skribe-path)) - ((string? path) (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else path))) - (filep (find-path file path))) - - (set! *skribe-load-options* opt) - - (unless (and (string? filep) (file-exists? filep)) - (skribe-error 'skribe-load - (format "Cannot find ~S in path" file) - *skribe-path*)) - - ;; Load this file if not already done - (unless (member filep *skribe-loaded*) - (cond - ((> *skribe-verbose* 1) - (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) - ((> *skribe-verbose* 0) - (format (current-error-port) " [loading file: ~S]\n" filep))) - ;; Load it - (with-input-from-file filep - (lambda () - (skribe-eval-port (current-input-port) ei))) - (set! *skribe-loaded* (cons filep *skribe-loaded*)))))) - -;;; -;;; SKRIBE-INCLUDE -;;; -(define* (skribe-include file #:optional (path (skribe-path))) - (unless (every string? path) - (skribe-error 'skribe-include "Illegal path" path)) - - (let ((path (find-path file path))) - (unless (and (string? path) (file-exists? path)) - (skribe-error 'skribe-load - (format "Cannot find ~S in path" file) - path)) - (when (> *skribe-verbose* 0) - (format (current-error-port) " [including file: ~S]\n" path)) - (with-input-from-file path - (lambda () - (let Loop ((exp (read (current-input-port))) - (res '())) - (if (eof-object? exp) - (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (Loop (read (current-input-port)) - (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm new file mode 100644 index 0000000..b7e04c1 --- /dev/null +++ b/src/guile/skribilo/evaluator.scm @@ -0,0 +1,207 @@ +;;; +;;; eval.stk -- Skribe Evaluator +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; + + + +;; FIXME; On peut implémenter maintenant skribe-warning/node + + +(define-module (skribilo evaluator) + :export (skribe-eval skribe-eval-port skribe-load skribe-load-options + skribe-include)) + +(use-modules (skribilo debug) + (skribilo reader) + (skribilo engine) + (skribilo verify) + (skribilo resolve) + (skribilo output) + (skribilo types) + (skribilo lib) + (skribilo vars) + (ice-9 optargs) + (oop goops)) + + + +;;; FIXME: The following page must eventually go to `module.scm'. + +(define *skribilo-user-module* #f) + +(define *skribilo-user-imports* + '((srfi srfi-1) + (srfi srfi-13) + (oop goops) + (skribilo module) + (skribilo config) + (skribilo vars) + (skribilo runtime) + (skribilo biblio) + (skribilo lib) + (skribilo resolve) + (skribilo engine) + (skribilo writer))) + +(define *skribe-core-modules* ;;; FIXME: From `module.scm'. + '("utils" "api" "bib" "index" "param" "sui")) + +;;; +;;; MAKE-RUN-TIME-MODULE +;;; +(define-public (make-run-time-module) + "Return a new module that imports all the necessary bindings required for +execution of Skribilo/Skribe code." + (let ((the-module (make-module))) + (for-each (lambda (iface) + (module-use! the-module (resolve-module iface))) + (append *skribilo-user-imports* + (map (lambda (mod) + `(skribilo skribe + ,(string->symbol mod))) + *skribe-core-modules*))) + (set-module-name! the-module '(skribilo-user)) + the-module)) + +;;; +;;; RUN-TIME-MODULE +;;; +(define-public (run-time-module) + "Return the default instance of a Skribilo/Skribe run-time module." + (if (not *skribilo-user-module*) + (set! *skribilo-user-module* (make-run-time-module))) + *skribilo-user-module*) + + + +(define *skribe-loaded* '()) ;; List of already loaded files +(define *skribe-load-options* '()) + +(define (%evaluate expr) + (eval expr (current-module))) + + + + +;;; +;;; SKRIBE-EVAL +;;; +(define* (skribe-eval a e #:key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;;; +;;; SKRIBE-EVAL-PORT +;;; +(define* (skribe-eval-port port engine #:key (env '()) + (reader %default-reader)) + (with-debug 2 'skribe-eval-port + (debug-item "engine=" engine) + (let ((e (if (symbol? engine) (find-engine engine) engine))) + (debug-item "e=" e) + (if (not (is-a? e )) + (skribe-error 'skribe-eval-port "cannot find engine" engine) + (let loop ((exp (reader port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (skribe-eval (%evaluate exp) e :env env) + (loop (reader port)))))))) + +;;; +;;; SKRIBE-LOAD +;;; +(define *skribe-load-options* '()) + +(define (skribe-load-options) + *skribe-load-options*) + +(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt=" opt) + + (let* ((ei (cond + ((not engine) *skribe-engine*) + ((engine? engine) engine) + ((not (symbol? engine)) + (skribe-error 'skribe-load + "Illegal engine" engine)) + (else engine))) + (path (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else path))) + (filep (search-path path file))) + + (set! *skribe-load-options* opt) + + (unless (and (string? filep) (file-exists? filep)) + (skribe-error 'skribe-load + (string-append "cannot find `" file "' in path") + (skribe-path))) + + ;; Load this file if not already done + (unless (member filep *skribe-loaded*) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + ;; Load it + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))) + (set! *skribe-loaded* (cons filep *skribe-loaded*)))))) + +;;; +;;; SKRIBE-INCLUDE +;;; +(define* (skribe-include file #:optional (path (skribe-path))) + (unless (every string? path) + (skribe-error 'skribe-include "Illegal path" path)) + + (let ((path (search-path path file))) + (unless (and (string? path) (file-exists? path)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + path)) + (when (> *skribe-verbose* 0) + (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path + (lambda () + (let Loop ((exp (read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (read (current-input-port)) + (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index 26b348a..bb41597 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -32,6 +32,13 @@ skribe-warning skribe-warning/ast skribe-message + ;; paths as lists of directories + + %skribilo-load-path + %skribilo-image-path %skribilo-bib-path %skribilo-source-path + + ;; compatibility + skribe-path skribe-path-set! skribe-image-path skribe-image-path-set! skribe-bib-path skribe-bib-path-set! @@ -45,6 +52,7 @@ printf fprintf any? every? process-input-port process-output-port process-error-port + %procedure-arity make-hashtable hashtable? hashtable-get hashtable-put! hashtable-update! @@ -58,6 +66,9 @@ ;; for compatibility unwind-protect unless when) + :use-module (skribilo config) + :use-module (skribilo types) + :use-module (srfi srfi-1) :use-module (ice-9 optargs)) @@ -79,7 +90,7 @@ (define-macro (define-markup bindings . body) ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the - ;; `#:rest' argument can only appear last which not what Skribe/DSSSL + ;; `#:rest' argument can only appear last, which is not what Skribe/DSSSL ;; expect, hence `fix-rest-arg'. (define (fix-rest-arg args) (let loop ((args args) @@ -256,44 +267,34 @@ (Loop (cdr l)))))) - + ;;; ====================================================================== ;;; ;;; A C C E S S O R S ;;; ;;; ====================================================================== -;; SKRIBE-PATH -(define (skribe-path) *skribe-path*) - -(define (skribe-path-set! path) - (if (not (and (list? path) (every string? path))) - (skribe-error 'skribe-path-set! "Illegal path" path) - (set! *skribe-path* path))) -;; SKRIBE-IMAGE-PATH -(define (skribe-image-path) *skribe-image-path*) +(define %skribilo-load-path (list (skribilo-default-path) ".")) +(define %skribilo-image-path '(".")) +(define %skribilo-bib-path '(".")) +(define %skribilo-source-path '(".")) -(define (skribe-image-path-set! path) - (if (not (and (list? path) (every string? path))) - (skribe-error 'skribe-image-path-set! "Illegal path" path) - (set! *skribe-image-path* path))) +(define-macro (define-compatibility-accessors var oldname) + (let ((newname (symbol-append '%skribilo- var)) + (setter (symbol-append oldname '-set!))) + `(begin + (define (,oldname) ,newname) + (define (,setter path) + (if (not (and (list? path) (every string? path))) + (skribe-error ',setter "illegal path" path) + (set! ,newname path)))))) -;; SKRIBE-BIB-PATH -(define (skribe-bib-path) *skribe-bib-path*) +(define-compatibility-accessors load-path skribe-path) +(define-compatibility-accessors image-path skribe-image-path) +(define-compatibility-accessors bib-path skribe-bib-path) +(define-compatibility-accessors source-path skribe-source-path) -(define (skribe-bib-path-set! path) - (if (not (and (list? path) (every string? path))) - (skribe-error 'skribe-bib-path-set! "Illegal path" path) - (set! *skribe-bib-path* path))) - -;; SKRBE-SOURCE-PATH -(define (skribe-source-path) *skribe-source-path*) - -(define (skribe-source-path-set! path) - (if (not (and (list? path) (every string? path))) - (skribe-error 'skribe-source-path-set! "Illegal path" path) - (set! *skribe-source-path* path))) ;;; ====================================================================== @@ -346,6 +347,14 @@ (define find-runtime-type (lambda (obj) obj)) + +;;; +;;; Various things. +;;; + +(define (%procedure-arity proc) + (car (procedure-property proc 'arity))) + (define-macro (unwind-protect expr1 expr2) ;; This is no completely correct. `(dynamic-wind @@ -353,8 +362,8 @@ (lambda () ,expr1) (lambda () ,expr2))) -(define-macro (unless expr body) - `(if (not ,expr) ,body)) +(define-macro (unless condition . exprs) + `(if (not ,condition) (begin ,@exprs))) -(define-macro (when expr . exprs) - `(if ,expr (begin ,@exprs))) +(define-macro (when condition . exprs) + `(if ,condition (begin ,@exprs))) diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 4d29f31..50c7b23 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -20,7 +20,8 @@ (define-module (skribilo module) :use-module (skribilo reader) - :use-module (skribilo eval) + :use-module (skribilo evaluator) + :use-module (skribilo debug) :use-module (ice-9 optargs)) ;;; Author: Ludovic Courtès @@ -43,7 +44,10 @@ ;; to actually create and read the module. (use-modules (skribilo module) (skribilo reader) - (skribilo eval) ;; `run-time-module' + (skribilo evaluator) ;; `run-time-module' + (skribilo engine) + (skribilo writer) + (skribilo types) (srfi srfi-1) (ice-9 optargs) @@ -53,26 +57,26 @@ (skribilo vars) (skribilo config)) - (use-syntax (skribilo lib)) ;; The `define' below results in a module-local definition. So the ;; definition of `read' in the `(guile-user)' module is left untouched. ;(define read ,(make-reader 'skribe)) ;; Everything is exported. - (define-macro (define . things) - (let* ((first (car things)) - (binding (cond ((symbol? first) first) - ((list? first) (car first)) - ((pair? first) (car first)) - (else - (error "define/skribe: bad formals" first))))) - `(begin - (define-public ,@things) - ;; Automatically push it to the run-time user module. -; (module-define! ,(run-time-module) -; (quote ,binding) ,binding) - ))))) +; (define-macro (define . things) +; (let* ((first (car things)) +; (binding (cond ((symbol? first) first) +; ((list? first) (car first)) +; ((pair? first) (car first)) +; (else +; (error "define/skribe: bad formals" first))))) +; `(begin +; (define-public ,@things) +; ;; Automatically push it to the run-time user module. +; ; (module-define! ,(run-time-module) +; ; (quote ,binding) ,binding) +; ))) + )) ;; Make it available to the top-level module. @@ -80,39 +84,44 @@ 'define-skribe-module define-skribe-module) +(define-public *skribe-core-modules* + '("utils" "api" "bib" "index" "param" "sui")) + + + +;; FIXME: This will eventually be replaced by the per-module reader thing in +;; Guile. (define-public (load-file-with-read file read module) - (with-input-from-file file - (lambda () + (with-debug 5 'load-file-with-read + (debug-item "loading " file) + + (with-input-from-file (search-path %load-path file) + (lambda () ; (format #t "load-file-with-read: ~a~%" read) - (let loop ((sexp (read)) - (result #f)) - (if (eof-object? sexp) - result - (begin + (let loop ((sexp (read)) + (result #f)) + (if (eof-object? sexp) + result + (begin ; (format #t "preparing to evaluate `~a'~%" sexp) - (loop (read) - (eval sexp module)))))))) + (loop (read) + (primitive-eval sexp))))))))) (define-public (load-skribilo-file file reader-name) (load-file-with-read file (make-reader reader-name) (current-module))) -(define-public *skribe-core-modules* - '("utils" "api" "bib" "index" "param" "sui")) - (define*-public (load-skribe-modules #:optional (debug? #f)) "Load the core Skribe modules, both in the @code{(skribilo skribe)} hierarchy and in @code{(run-time-module)}." (for-each (lambda (mod) - (if debug? - (format #t "loading skribe module `~a'...~%" mod)) - (load-skribilo-file (string-append "skribe/" mod ".scm") - 'skribe)) - *skribe-core-modules*) - (for-each (lambda (mod) + (format #t "~~ loading skribe module `~a'...~%" mod) + (load-skribilo-file (string-append "skribilo/skribe/" + mod ".scm") + 'skribe) (module-use! (run-time-module) - (resolve-interface (list skribilo skribe - (string->symbol - mod))))) + (resolve-module `(skribilo skribe + ,(string->symbol mod))))) *skribe-core-modules*)) + ;;; module.scm ends here diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm index cc690ec..eeff397 100644 --- a/src/guile/skribilo/output.scm +++ b/src/guile/skribilo/output.scm @@ -1,24 +1,24 @@ ;;;; ;;;; output.stk -- Skribe Output Stage -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 13-Aug-2003 18:42 (eg) ;;;; Last file update: 5-Mar-2004 10:32 (eg) @@ -29,8 +29,8 @@ (use-modules (skribilo debug) (skribilo types) -; (skribe engine) -; (skribe writer) +; (skribilo engine) + (skribilo writer) (oop goops)) @@ -47,7 +47,7 @@ (invoke (slot-ref w 'action) n e) (invoke (slot-ref w 'after) n e)))) - + (define (output node e . writer) (with-debug 3 'output @@ -135,7 +135,7 @@ (+ (- (char->integer c) (char->integer #\0)) (* 10 n)))))))) - + (let loop ((i 0)) (cond ((= i lf) diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm index a149ab1..27c740b 100644 --- a/src/guile/skribilo/reader.scm +++ b/src/guile/skribilo/reader.scm @@ -21,7 +21,8 @@ (define-module (skribilo reader) :use-module (srfi srfi-9) ;; records :use-module (srfi srfi-17) ;; generalized `set!' - :export (%make-reader lookup-reader make-reader) + :export (%make-reader lookup-reader make-reader + %default-reader) :export-syntax (define-reader define-public-reader)) ;;; Author: Ludovic Courtès @@ -65,7 +66,7 @@ (define (lookup-reader name) "Look for a reader named @var{name} (a symbol) in the @code{(skribilo -readers)} module hierarchy. If no such reader was found, an error is +reader)} module hierarchy. If no such reader was found, an error is raised." (let ((m (resolve-module `(skribilo reader ,name)))) (if (module-bound? m 'reader-specification) @@ -78,5 +79,6 @@ raised." (make (reader:make spec))) (make))) +(define %default-reader (make-reader 'skribe)) ;;; reader.scm ends here diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index 2dc5e98..e59a2f8 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -50,11 +50,13 @@ (define (resolve! ast engine env) (with-debug 3 'resolve (debug-item "ast=" ast) - (fluid-let ((*unresolved* #f)) + (let ((*unresolved* (make-fluid))) + (fluid-set! *unresolved* #f) + (let Loop ((ast ast)) - (set! *unresolved* #f) + (fluid-set! *unresolved* #f) (let ((ast (do-resolve! ast engine env))) - (if *unresolved* + (if (fluid-ref *unresolved*) (Loop ast) ast)))))) diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm index af76237..2642f7e 100644 --- a/src/guile/skribilo/runtime.scm +++ b/src/guile/skribilo/runtime.scm @@ -48,7 +48,7 @@ (skribilo verify) (skribilo resolve) (skribilo output) - (skribilo eval) + (skribilo evaluator) (oop goops)) @@ -195,7 +195,7 @@ to)))))) (define (convert-image file formats) - (let ((path (find-path file (skribe-image-path)))) + (let ((path (search-path (skribe-image-path) file))) (if (not path) (skribe-error 'convert-image (format "Can't find `~a' image file in path: " file) @@ -259,14 +259,17 @@ (display (if res (cadr res) ch) out))) (get-output-string out)))) +(define string->html + (%make-general-string-replace '((#\" """) (#\& "&") (#\< "<") + (#\> ">")))) (define (make-string-replace lst) (let ((l (sort lst (lambda (r1 r2) (char ">"))) - string->html) + string->html) (else - (%make-general-string-replace lst))))) + (%make-general-string-replace lst))))) diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index e56f350..1e88d45 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -42,7 +42,7 @@ ;* source-read-lines ... */ ;*---------------------------------------------------------------------*/ (define (source-read-lines file start stop tab) - (let ((p (find-path file (skribe-source-path)))) + (let ((p (search-path (skribe-source-path) file))) (if (or (not (string? p)) (not (file-exists? p))) (skribe-error 'source (format "Can't find `~a' source file in path" file) @@ -119,7 +119,7 @@ ;* source-read-definition ... */ ;*---------------------------------------------------------------------*/ (define (source-read-definition file definition tab lang) - (let ((p (find-path file (skribe-source-path)))) + (let ((p (search-path (skribe-source-path) file))) (cond ((not (language-extractor lang)) (skribe-error 'source diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm index 048dcfb..70ba817 100644 --- a/src/guile/skribilo/writer.scm +++ b/src/guile/skribilo/writer.scm @@ -1,24 +1,24 @@ ;;;; ;;;; writer.stk -- Skribe Writer Stuff -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 15-Sep-2003 22:21 (eg) ;;;; Last file update: 4-Mar-2004 10:48 (eg) @@ -31,8 +31,10 @@ (use-modules (skribilo debug) -; (skribilo engine) + (skribilo engine) (skribilo output) + (skribilo types) + (skribilo lib) (oop goops) (ice-9 optargs)) @@ -40,7 +42,7 @@ ;;;; ====================================================================== ;;;; -;;;; INVOKE +;;;; INVOKE ;;;; ;;;; ====================================================================== (define (invoke proc node e) @@ -56,7 +58,7 @@ ;;;; ====================================================================== ;;;; -;;;; LOOKUP-MARKUP-WRITER +;;;; LOOKUP-MARKUP-WRITER ;;;; ;;;; ====================================================================== (define (lookup-markup-writer node e) @@ -76,7 +78,7 @@ ;;;; ====================================================================== ;;;; -;;;; MAKE-WRITER-PREDICATE +;;;; MAKE-WRITER-PREDICATE ;;;; ;;;; ====================================================================== (define (make-writer-predicate markup predicate class) @@ -104,26 +106,55 @@ ;;;; ====================================================================== ;;;; -;;;; MARKUP-WRITER +;;;; MARKUP-WRITER ;;;; ;;;; ====================================================================== -(define* (markup-writer markup #:optional engine +; (define-macro (lambda** arglist . body) +; (let ((parse-arglist (module-ref (resolve-module '(ice-9 optargs)) +; 'parse-arglist))) +; (parse-arglist +; arglist +; (lambda (mandatory-args optionals keys aok? rest-arg) +; (let ((l**-rest-arg (gensym "L**-rest")) +; (l**-loop (gensym "L**-loop"))) +; `(lambda (,@mandatory-args . ,l**-rest-arg) +; `(let ,l**-loop ((,l**-rest-arg ,l**-rest-arg) +; (,rest-arg '()) +; ,@optionals +; ,@keys) +; (if (null? ,l**-rest-arg) +; (begin +; ,@body) + +(define* (markup-writer markup ;; #:optional (engine #f) #:key (predicate #f) (class #f) (options '()) - (validate #f) - (before #f) (action 'unspecified) (after #f)) - (let ((e (or engine (default-engine)))) + (validate #f) + (before #f) + (action 'unspecified) + (after #f) + #:rest engine) + ;;; FIXME: `lambda*' sucks and fails when both optional arguments and + ;;; keyword arguments are used together. In particular, if ENGINE is not + ;;; specified by the caller but other keyword arguments are specified, it + ;;; will consider the value of ENGINE to be the first keyword found. + +; (let ((e (or engine (default-engine)))) + (let ((e (or (and (list? engine) + (not (keyword? (car engine)))) + (default-engine)))) + (cond ((and (not (symbol? markup)) (not (eq? markup #t))) - (skribe-error 'markup-writer "Illegal markup" markup)) + (skribe-error 'markup-writer "illegal markup" markup)) ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) + (skribe-error 'markup-writer "illegal engine" e)) ((and (not predicate) (not class) (null? options) (not before) (eq? action 'unspecified) (not after)) - (skribe-error 'markup-writer "Illegal writer" markup)) + (skribe-error 'markup-writer "illegal writer" markup)) (else (let ((m (make-writer-predicate markup predicate class)) (ac (if (eq? action 'unspecified) @@ -135,35 +166,35 @@ ;;;; ====================================================================== ;;;; -;;;; MARKUP-WRITER-GET +;;;; MARKUP-WRITER-GET ;;;; ;;;; ====================================================================== (define* (markup-writer-get markup :optional engine :key (class #f) (pred #f)) (let ((e (or engine (default-engine)))) (cond ((not (symbol? markup)) - (skribe-error 'markup-writer-get "Illegal symbol" markup)) + (skribe-error 'markup-writer-get "Illegal symbol" markup)) ((not (engine? e)) - (skribe-error 'markup-writer-get "Illegal engine" e)) + (skribe-error 'markup-writer-get "Illegal engine" e)) (else (let liip ((e e)) (let loop ((w* (slot-ref e 'writers))) (cond ((pair? w*) - (if (and (eq? (writer-ident (car w*)) markup) + (if (and (eq? (writer-ident (car w*)) markup) (equal? (writer-class (car w*)) class) (or (unspecified? pred) (eq? (slot-ref (car w*) 'upred) pred))) (car w*) (loop (cdr w*)))) ((engine? (slot-ref e 'delegate)) - (liip (slot-ref e 'delegate))) + (liip (slot-ref e 'delegate))) (else - #f)))))))) + #f)))))))) ;;;; ====================================================================== ;;;; -;;;; MARKUP-WRITER-GET* +;;;; MARKUP-WRITER-GET* ;;;; ;;;; ====================================================================== @@ -194,16 +225,16 @@ ;;; ====================================================================== ;;;; -;;;; COPY-MARKUP-WRITER +;;;; COPY-MARKUP-WRITER ;;;; ;;;; ====================================================================== (define* (copy-markup-writer markup old-engine :optional new-engine - :key (predicate 'unspecified) - (class 'unspecified) + :key (predicate 'unspecified) + (class 'unspecified) (options 'unspecified) - (validate 'unspecified) - (before 'unspecified) - (action 'unspecified) + (validate 'unspecified) + (before 'unspecified) + (action 'unspecified) (after 'unspecified)) (let ((old (markup-writer-get markup old-engine)) (new-engine (or new-engine old-engine))) -- cgit v1.2.3 From 2d740bec3cc50480980d8aae3a06e27a5f0649e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Jul 2005 02:04:46 +0000 Subject: Started relying on the per-module reader; first doc produced ever! First document compiled by Skribilo to HTML! * src/guile/skribilo/module.scm (define-skribe-module): Use the `#:reader' option of `define-module' (not yet integrated in Guile 1.7). Plus lots of other things... git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-3 --- src/guile/README | 4 +- src/guile/skribilo.scm | 36 +++++++------ src/guile/skribilo/biblio.scm | 11 ++-- src/guile/skribilo/engine/html.scm | 7 ++- src/guile/skribilo/evaluator.scm | 47 ---------------- src/guile/skribilo/lib.scm | 10 +++- src/guile/skribilo/module.scm | 105 ++++++++++++++++++++++-------------- src/guile/skribilo/output.scm | 7 +-- src/guile/skribilo/resolve.scm | 24 ++++----- src/guile/skribilo/runtime.scm | 102 ++++++++++++++++++----------------- src/guile/skribilo/skribe/api.scm | 1 + src/guile/skribilo/skribe/bib.scm | 1 - src/guile/skribilo/skribe/utils.scm | 3 +- src/guile/skribilo/source.scm | 18 +++---- src/guile/skribilo/types.scm | 6 ++- src/guile/skribilo/vars.scm | 8 ++- src/guile/skribilo/verify.scm | 31 ++++++----- src/guile/skribilo/writer.scm | 2 +- 18 files changed, 216 insertions(+), 207 deletions(-) diff --git a/src/guile/README b/src/guile/README index 1b9a6c4..4bd7eff 100644 --- a/src/guile/README +++ b/src/guile/README @@ -1,4 +1,4 @@ -Skribilo +Skribilo -*- Outline -*- ======== Skribilo is a port of Skribe to GNU Guile. @@ -11,6 +11,8 @@ Here are a few goals. ** Better error handling, automatic back-traces, etc. +** Add an option to continuously watch a file and re-compile it + * Font-ends (readers) ** Implement a new front-end mechanism (see `(skribilo reader)') diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm index ae21fab..a43ec66 100755 --- a/src/guile/skribilo.scm +++ b/src/guile/skribilo.scm @@ -59,10 +59,6 @@ exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@" the-arg)))))))) -(set! %load-hook - (lambda (file) - (format #t "~~ loading `~a'...~%" file))) - (define-module (skribilo)) @@ -415,6 +411,11 @@ Processes a Skribilo/Skribe source file and produces its output. (set-skribe-debug! (string->number debugging-level)) + (if (> (skribe-debug) 4) + (set! %load-hook + (lambda (file) + (format #t "~~ loading `~a'...~%" file)))) + (set! %skribilo-load-path (cons load-path %skribilo-load-path)) (set! %skribilo-bib-path @@ -426,9 +427,6 @@ Processes a Skribilo/Skribe source file and produces its output. ;; Load the user rc file ;(load-rc) - ;; load the basic Skribe modules - (load-skribe-modules) - ;; Load the base file to bootstrap the system as well as the files ;; that are in the PRELOAD variable. (find-engine 'base) @@ -442,24 +440,28 @@ Processes a Skribilo/Skribe source file and produces its output. (reverse! variants)) (let ((files (option-ref options '() '()))) - (if (null? files) - (error "you must specify at least the input file" files)) + (if (> (length files) 2) (error "you can specify at most one input file and one output file" files)) - (let* ((source-file (car files)) - (dest-file (if (null? (cdr files)) #f (cadr files))) - (source-port (open-input-file source-file))) + (let* ((source-file (if (null? files) #f (car files))) + (dest-file (if (or (not source-file) + (null? (cdr files))) + #f + (cadr files))) + (do-it! (lambda () + (if (string? dest-file) + (with-output-to-file dest-file doskribe) + (doskribe))))) (if (and dest-file (file-exists? dest-file)) (delete-file dest-file)) - (with-input-from-file source-file - (lambda () - (if (string? dest-file) - (with-output-to-file dest-file doskribe) - (doskribe)))))))) + (if source-file + (with-input-from-file source-file + do-it!) + (do-it!)))))) (define main skribilo) diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index d4a644e..f3ddf97 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -27,10 +27,11 @@ (define-module (skribilo biblio) - :use-module (skribilo runtime) - :export (bib-tables? make-bib-table default-bib-table - bib-load! resolve-bib resolve-the-bib - bib-sort/authors bib-sort/idents bib-sort/dates)) + :use-module (skribilo runtime) + :use-module (skribilo lib) ;; `when', `unless' + :use-module (skribilo vars) + :export (bib-table? make-bib-table default-bib-table + bib-add!)) (define *bib-table* #f) @@ -50,7 +51,7 @@ (make-hash-table)) (define (bib-table? obj) - (hashtable? obj)) + (hash-table? obj)) (define (default-bib-table) (unless *bib-table* diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index a20ea68..c85f18f 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -16,7 +16,8 @@ ;* @ref ../../doc/user/htmle.skb:ref@ */ ;*=====================================================================*/ -(define-skribe-module (skribilo engine html)) +(define-skribe-module (skribilo engine html) + #:use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:))) ;; Keep a reference to the base engine. @@ -843,7 +844,9 @@ :url (skribilo-url)) "." (linebreak) - "Last update: " (date))))) + "Last update: " + (s19:date->string + (s19:current-date)))))) e)))) :after "\n") diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index b7e04c1..703186c 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -43,53 +43,6 @@ (oop goops)) - -;;; FIXME: The following page must eventually go to `module.scm'. - -(define *skribilo-user-module* #f) - -(define *skribilo-user-imports* - '((srfi srfi-1) - (srfi srfi-13) - (oop goops) - (skribilo module) - (skribilo config) - (skribilo vars) - (skribilo runtime) - (skribilo biblio) - (skribilo lib) - (skribilo resolve) - (skribilo engine) - (skribilo writer))) - -(define *skribe-core-modules* ;;; FIXME: From `module.scm'. - '("utils" "api" "bib" "index" "param" "sui")) - -;;; -;;; MAKE-RUN-TIME-MODULE -;;; -(define-public (make-run-time-module) - "Return a new module that imports all the necessary bindings required for -execution of Skribilo/Skribe code." - (let ((the-module (make-module))) - (for-each (lambda (iface) - (module-use! the-module (resolve-module iface))) - (append *skribilo-user-imports* - (map (lambda (mod) - `(skribilo skribe - ,(string->symbol mod))) - *skribe-core-modules*))) - (set-module-name! the-module '(skribilo-user)) - the-module)) - -;;; -;;; RUN-TIME-MODULE -;;; -(define-public (run-time-module) - "Return the default instance of a Skribilo/Skribe run-time module." - (if (not *skribilo-user-module*) - (set! *skribilo-user-module* (make-run-time-module))) - *skribilo-user-module*) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index bb41597..ef8ef8d 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -58,6 +58,7 @@ hashtable-get hashtable-put! hashtable-update! hashtable->list + skribe-read find-runtime-type) :export-syntax (new define-markup define-simple-markup @@ -68,6 +69,8 @@ :use-module (skribilo config) :use-module (skribilo types) + :use-module (skribilo reader) + :use-module (skribilo vars) :use-module (srfi srfi-1) :use-module (ice-9 optargs)) @@ -105,7 +108,7 @@ (let ((name (car bindings)) (opts (cdr bindings))) - `(define* ,(cons name (fix-rest-arg opts)) ,@body))) + `(define*-public ,(cons name (fix-rest-arg opts)) ,@body))) ;;; @@ -352,6 +355,11 @@ ;;; Various things. ;;; +(define %skribe-reader (make-reader 'skribe)) + +(define* (skribe-read #:optional (port (current-input-port))) + (%skribe-reader port)) + (define (%procedure-arity proc) (car (procedure-property proc 'arity))) diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 50c7b23..854c50d 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -22,6 +22,7 @@ :use-module (skribilo reader) :use-module (skribilo evaluator) :use-module (skribilo debug) + :use-module (srfi srfi-1) :use-module (ice-9 optargs)) ;;; Author: Ludovic Courtès @@ -36,47 +37,47 @@ ;;; ;;; Code: -(define-macro (define-skribe-module name) +(define *skribilo-user-imports* + ;; List of modules that should be imported by any good Skribilo module. + '((srfi srfi-1) ;; lists + (srfi srfi-13) ;; strings + ;(srfi srfi-19) ;; date and time + (oop goops) ;; `make' + (ice-9 optargs) ;; `define*' + + (skribilo module) + (skribilo types) ;; `', `document?', etc. + (skribilo config) + (skribilo vars) + (skribilo runtime) ;; `the-options', `the-body' + (skribilo biblio) + (skribilo lib) ;; `define-markup', `unwind-protect', etc. + (skribilo resolve) + (skribilo engine) + (skribilo writer) + (skribilo output) + (skribilo evaluator))) + +(define *skribe-core-modules* + '("utils" "api" "bib" "index" "param" "sui")) + +(define-macro (define-skribe-module name . options) `(begin - (define-module ,name) + (define-module ,name + #:reader (make-reader 'skribe) + #:use-module (skribilo reader) + ,@options) ;; Pull all the bindings that Skribe code may expect, plus those needed ;; to actually create and read the module. - (use-modules (skribilo module) - (skribilo reader) - (skribilo evaluator) ;; `run-time-module' - (skribilo engine) - (skribilo writer) - (skribilo types) - - (srfi srfi-1) - (ice-9 optargs) - - (skribilo lib) ;; `define-markup', `unwind-protect', etc. - (skribilo runtime) - (skribilo vars) - (skribilo config)) - - - ;; The `define' below results in a module-local definition. So the - ;; definition of `read' in the `(guile-user)' module is left untouched. - ;(define read ,(make-reader 'skribe)) - - ;; Everything is exported. -; (define-macro (define . things) -; (let* ((first (car things)) -; (binding (cond ((symbol? first) first) -; ((list? first) (car first)) -; ((pair? first) (car first)) -; (else -; (error "define/skribe: bad formals" first))))) -; `(begin -; (define-public ,@things) -; ;; Automatically push it to the run-time user module. -; ; (module-define! ,(run-time-module) -; ; (quote ,binding) ,binding) -; ))) - )) + ,(cons 'use-modules + (append *skribilo-user-imports* + (filter-map (lambda (mod) + (let ((m `(skribilo skribe + ,(string->symbol + mod)))) + (and (not (equal? m name)) m))) + *skribe-core-modules*))))) ;; Make it available to the top-level module. @@ -84,9 +85,35 @@ 'define-skribe-module define-skribe-module) -(define-public *skribe-core-modules* - '("utils" "api" "bib" "index" "param" "sui")) + +(define *skribilo-user-module* #f) + +;;; +;;; MAKE-RUN-TIME-MODULE +;;; +(define-public (make-run-time-module) + "Return a new module that imports all the necessary bindings required for +execution of Skribilo/Skribe code." + (let ((the-module (make-module))) + (for-each (lambda (iface) + (module-use! the-module (resolve-module iface))) + (append *skribilo-user-imports* + (map (lambda (mod) + `(skribilo skribe + ,(string->symbol mod))) + *skribe-core-modules*))) + (set-module-name! the-module '(skribilo-user)) + the-module)) + +;;; +;;; RUN-TIME-MODULE +;;; +(define-public (run-time-module) + "Return the default instance of a Skribilo/Skribe run-time module." + (if (not *skribilo-user-module*) + (set! *skribilo-user-module* (make-run-time-module))) + *skribilo-user-module*) ;; FIXME: This will eventually be replaced by the per-module reader thing in diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm index eeff397..8a63a48 100644 --- a/src/guile/skribilo/output.scm +++ b/src/guile/skribilo/output.scm @@ -31,6 +31,7 @@ (skribilo types) ; (skribilo engine) (skribilo writer) + (skribilo lib) ;; `when', `unless' (oop goops)) @@ -60,10 +61,10 @@ (%out/writer node e (car writer))) ((not (car writer)) (skribe-error 'output - (format "Illegal ~A user writer" (engine-ident e)) + (format #f "illegal ~A user writer" (engine-ident e)) (if (markup? node) (markup-markup node) node))) (else - (skribe-error 'output "Illegal user writer" (car writer))))))) + (skribe-error 'output "illegal user writer" (car writer))))))) ;;; @@ -74,7 +75,7 @@ (define-method (out (node ) e) - (let Loop ((n* node)) + (let loop ((n* node)) (cond ((pair? n*) (out (car n*) e) diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index e59a2f8..14f36b2 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -1,24 +1,24 @@ ;;;; ;;;; resolve.stk -- Skribe Resolve Stage -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 13-Aug-2003 18:39 (eg) ;;;; Last file update: 17-Feb-2004 14:43 (eg) @@ -28,6 +28,7 @@ :use-module (skribilo debug) :use-module (skribilo runtime) :use-module (skribilo types) + :use-module (skribilo lib) ;; `unless' and `when' :use-module (oop goops) @@ -62,7 +63,7 @@ ;;;; ====================================================================== ;;;; -;;;; D O - R E S O L V E ! +;;;; D O - R E S O L V E ! ;;;; ;;;; ====================================================================== @@ -195,10 +196,10 @@ (debug-item "parent=" p " " (if (is-a? p 'markup) (slot-ref p 'markup) "???")) (cond - ((pred p) p) + ((pred p) p) ((is-a? p ) p) ((not p) #f) - (else (resolve-search-parent p e pred)))))) + (else (resolve-search-parent p e pred)))))) ;;;; ====================================================================== ;;;; @@ -231,7 +232,7 @@ (else (set-car! (cdr c) (+ 1 num)) (+ 1 num))))))) - + ;;;; ====================================================================== ;;;; ;;;; RESOLVE-IDENT @@ -259,4 +260,3 @@ (car mks)) (else (loop (cdr mks))))))))))) - diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm index 2642f7e..1f411dc 100644 --- a/src/guile/skribilo/runtime.scm +++ b/src/guile/skribilo/runtime.scm @@ -27,6 +27,7 @@ (define-module (skribilo runtime) :export (;; Utilities strip-ref-base ast->file-location string-canonicalize + the-options the-body ;; Markup functions markup-option markup-option-add! markup-output @@ -49,6 +50,8 @@ (skribilo resolve) (skribilo output) (skribilo evaluator) + (skribilo vars) + (srfi srfi-13) (oop goops)) @@ -253,10 +256,10 @@ ;; The general version (lambda (str) (let ((out (open-output-string))) - (dotimes (i (string-length str)) - (let* ((ch (string-ref str i)) - (res (assq ch lst))) - (display (if res (cadr res) ch) out))) + (string-for-each (lambda (ch) + (let ((res (assq ch lst))) + (display (if res (cadr res) ch) out))) + str) (get-output-string out)))) (define string->html @@ -414,48 +417,49 @@ ;;NEW '())))))) ;;NEW -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G -;;NEW ;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (the-body opt) -;;NEW ;; Filter out the options -;;NEW (let loop ((opt* opt) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-body "Illegal body" opt)) -;;NEW ((keyword? (car opt*)) -;;NEW (if (null? (cdr opt*)) -;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) -;;NEW (loop (cddr opt*) res))) -;;NEW (else -;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) -;;NEW -;;NEW -;;NEW -;;NEW (define (the-options opt+ . out) -;;NEW ;; Returns an list made of options.The OUT argument contains -;;NEW ;; keywords that are filtered out. -;;NEW (let loop ((opt* opt+) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-options "Illegal options" opt*)) -;;NEW ((keyword? (car opt*)) -;;NEW (cond -;;NEW ((null? (cdr opt*)) -;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) -;;NEW ((memq (car opt*) out) -;;NEW (loop (cdr opt*) res)) -;;NEW (else -;;NEW (loop (cdr opt*) -;;NEW (cons (list (car opt*) (cadr opt*)) res))))) -;;NEW (else -;;NEW (loop (cdr opt*) res))))) -;;NEW + +;;;; ====================================================================== +;;;; +;;;; M A R K U P A R G U M E N T P A R S I N G +;;;; +;;;; ====================================================================== +(define (the-body opt) + ;; Filter out the options + (let loop ((opt* opt) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-body "Illegal body" opt)) + ((keyword? (car opt*)) + (if (null? (cdr opt*)) + (skribe-error 'the-body "Illegal option" (car opt*)) + (loop (cddr opt*) res))) + (else + (loop (cdr opt*) (cons (car opt*) res)))))) + + + +(define (the-options opt+ . out) + ;; Returns an list made of options.The OUT argument contains + ;; keywords that are filtered out. + (let loop ((opt* opt+) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-options "Illegal options" opt*)) + ((keyword? (car opt*)) + (cond + ((null? (cdr opt*)) + (skribe-error 'the-options "Illegal option" (car opt*))) + ((memq (car opt*) out) + (loop (cdr opt*) res)) + (else + (loop (cdr opt*) + (cons (list (car opt*) (cadr opt*)) res))))) + (else + (loop (cdr opt*) res))))) + diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm index 2828908..e7ba4a6 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/skribe/api.scm @@ -253,6 +253,7 @@ ;* paragraph ... */ ;*---------------------------------------------------------------------*/ (define-simple-markup paragraph) +(define-public p paragraph) ;*---------------------------------------------------------------------*/ ;* footnote ... */ diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm index f1a32c1..2ec5c0b 100644 --- a/src/guile/skribilo/skribe/bib.scm +++ b/src/guile/skribilo/skribe/bib.scm @@ -32,7 +32,6 @@ ;;; The contents of the file below are unchanged compared to Skribe 1.2d's ;;; `bib.scm' file found in the `common' directory. - ;*---------------------------------------------------------------------*/ ;* bib-load! ... */ ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm index f963020..b2a5cfb 100644 --- a/src/guile/skribilo/skribe/utils.scm +++ b/src/guile/skribilo/skribe/utils.scm @@ -19,7 +19,8 @@ ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -(define-skribe-module (skribilo skribe utils)) +(define-skribe-module (skribilo skribe utils) + #:export (ast-document)) ;;; Author: Manuel Serrano ;;; Commentary: diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index 1e88d45..c682687 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,24 +1,24 @@ ;;;; ;;;; source.stk -- Skibe SOURCE implementation stuff -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 3-Sep-2003 12:22 (eg) ;;;; Last file update: 27-Oct-2004 20:09 (eg) @@ -27,7 +27,8 @@ (define-module (skribilo source) - :export (source-read-lines source-read-definition source-fontify)) + :export (source-read-lines source-read-definition source-fontify) + :use-module (skribilo vars)) ;; Temporary solution @@ -187,4 +188,3 @@ (cons* 'eol (substring str j i) r)))) (else (loop (+ i 1) j r)))))) - diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index 0d51c70..0893587 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -33,10 +33,12 @@ node? node-options node-loc engine? engine-ident engine-format engine-customs engine-filter engine-symbol-table - writer? write-object + writer? write-object writer-options writer-ident + writer-before writer-action writer-after processor? processor-combinator processor-engine markup? bind-markup! markup-options is-markup? - markup-body find-markups write-object + markup-markup markup-body markup-ident markup-class + find-markups write-object container? container-options container-ident container-body document? document-ident document-body diff --git a/src/guile/skribilo/vars.scm b/src/guile/skribilo/vars.scm index 51a7ee7..7e75e0f 100644 --- a/src/guile/skribilo/vars.scm +++ b/src/guile/skribilo/vars.scm @@ -21,7 +21,8 @@ ;;; USA. -(define-module (skribilo vars)) +(define-module (skribilo vars) + #:use-module (srfi srfi-17)) ;;; ;;; Switches @@ -30,6 +31,11 @@ (define-public *skribe-warning* 5) (define-public *load-rc* #t) +(define-public skribe-debug + (let ((level 0)) + (getter-with-setter (lambda () level) + (lambda (val) (set! level val))))) + ;;; ;;; PATH variables ;;; diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm index 93a1be3..1ff0b5b 100644 --- a/src/guile/skribilo/verify.scm +++ b/src/guile/skribilo/verify.scm @@ -1,24 +1,24 @@ ;;;; ;;;; verify.stk -- Skribe Verification Stage -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program 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 General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 13-Aug-2003 11:57 (eg) ;;;; Last file update: 27-Oct-2004 16:35 (eg) @@ -29,9 +29,10 @@ (use-modules (skribilo debug) ; (skribilo engine) -; (skribilo writer) + (skribilo writer) ; (skribilo runtime) (skribilo types) + (skribilo lib) ;; `when', `unless' (oop goops)) @@ -61,16 +62,16 @@ ;;; CHECK-OPTIONS ;;; (define (check-options lopts markup engine) - + ;; Only keywords are checked, symbols are voluntary left unchecked. */ (with-debug 6 'check-options (debug-item "markup=" (markup-markup markup)) (debug-item "options=" (slot-ref markup 'options)) (debug-item "lopts=" lopts) (for-each - (lambda (o2) + (lambda (o2) (for-each - (lambda (o) + (lambda (o) (if (and (keyword? o) (not (eq? o :&skribe-eval-location)) (not (memq o lopts))) @@ -85,11 +86,11 @@ (markup-option markup o))))) o2)) (slot-ref markup 'options)))) - + ;;; ====================================================================== ;;; -;;; V E R I F Y +;;; V E R I F Y ;;; ;;; ====================================================================== @@ -124,7 +125,7 @@ (with-debug 5 'verify:: (debug-item "node=" (markup-markup node)) (debug-item "options=" (slot-ref node 'options)) - (debug-item "e=" (engine-ident e)) + (debug-item "e=" (engine-ident e)) (next-method) @@ -157,5 +158,3 @@ (slot-ref e 'customs)) node) - - diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm index 70ba817..eeefe8b 100644 --- a/src/guile/skribilo/writer.scm +++ b/src/guile/skribilo/writer.scm @@ -64,7 +64,7 @@ (define (lookup-markup-writer node e) (let ((writers (slot-ref e 'writers)) (delegate (slot-ref e 'delegate))) - (let Loop ((w* writers)) + (let loop ((w* writers)) (cond ((pair? w*) (let ((pred (slot-ref (car w*) 'pred))) -- cgit v1.2.3