From 3f0d8774b2920e2922a963d5f96b533ca865acae Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 11 Jun 2007 13:35:20 +0000 Subject: Switched all engines to a native Guile module. git-archimport-id: lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-70 --- src/guile/skribilo/engine/Makefile.am | 9 +- src/guile/skribilo/engine/base.scm | 13 +- src/guile/skribilo/engine/context.scm | 655 +++++++++++++++-------------- src/guile/skribilo/engine/html.scm | 323 +++++++------- src/guile/skribilo/engine/html4.scm | 95 +++-- src/guile/skribilo/engine/latex-simple.scm | 103 ----- src/guile/skribilo/engine/latex.scm | 220 +++++----- src/guile/skribilo/engine/lout.scm | 351 +++++++--------- src/guile/skribilo/engine/xml.scm | 59 +-- 9 files changed, 879 insertions(+), 949 deletions(-) delete mode 100644 src/guile/skribilo/engine/latex-simple.scm diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am index 784b718..260cd3a 100644 --- a/src/guile/skribilo/engine/Makefile.am +++ b/src/guile/skribilo/engine/Makefile.am @@ -1,10 +1,5 @@ guilemoduledir = $(GUILE_SITE)/skribilo/engine dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \ - latex-simple.scm latex.scm \ - lout.scm \ - xml.scm + latex.scm lout.scm xml.scm -# FIXME: Guile-Lint can't be used here because of `define-skribe-module' -# and because of the custom reader syntax that's used. - -#include $(top_srcdir)/guile-lint.am +include $(top_srcdir)/guile-lint.am diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm index 2085ed6..9941ff1 100644 --- a/src/guile/skribilo/engine/base.scm +++ b/src/guile/skribilo/engine/base.scm @@ -23,15 +23,18 @@ :use-module (skribilo ast) :use-module (skribilo engine) :use-module (skribilo writer) - :autoload (skribilo output) (output) :use-module (skribilo evaluator) + :autoload (skribilo output) (output) + :autoload (skribilo lib) (skribe-error) :autoload (skribilo package base) (color it bold ref) :autoload (skribilo utils keywords) (list-split) :autoload (skribilo biblio template) (make-bib-entry-template/default output-bib-entry-template) ;; syntactic sugar :use-module (skribilo reader) - :use-module (skribilo utils syntax)) + :use-module (skribilo utils syntax) + + :export (base-engine)) (fluid-set! current-reader (make-reader 'skribe)) @@ -405,13 +408,9 @@ (t (cond ((null? ie) "") - ;; FIXME: Since we don't support - ;; `:&skribe-eval-location', we could set up a - ;; `parameterize' thing around `skribe-eval' to - ;; provide it with the right location information. ((or (not (integer? nc)) (= nc 1)) (table :width 100. - ;;:&skribe-eval-location loc + :&location loc :class "index-table" (make-column ie pref))) (else diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm index c9e0986..87d36df 100644 --- a/src/guile/skribilo/engine/context.scm +++ b/src/guile/skribilo/engine/context.scm @@ -1,34 +1,52 @@ -;;;; -;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;;;; 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 ... -;;;; ====================================================================== +;;; context.scm -- ConTeXt engine. +;;; +;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2007 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo engine context) + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo utils keywords) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) + :use-module (skribilo package base) + :autoload (skribilo utils images) (convert-image) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo output) (output) + :autoload (skribilo color) (skribe-color->rgb + skribe-get-used-colors + skribe-use-color!) + :autoload (skribilo config) (skribilo-release) + :use-module (ice-9 optargs) + :use-module (ice-9 receive) + :export (context-engine + ConTeXt TeX)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; ====================================================================== +;;; context-customs ... +;;; ====================================================================== (define context-customs '((source-comment-color "#ffa600") (source-error-color "red") @@ -46,9 +64,9 @@ (user-style #f) (document-style "book"))) -;;;; ====================================================================== -;;;; context-encoding ... -;;;; ====================================================================== +;;; ====================================================================== +;;; context-encoding ... +;;; ====================================================================== (define context-encoding '((#\# "\\type{#}") (#\| "\\type{|}") @@ -66,18 +84,18 @@ (#\% "\\%") (#\\ "$\\backslash$"))) -;;;; ====================================================================== -;;;; context-pre-encoding ... -;;;; ====================================================================== +;;; ====================================================================== +;;; context-pre-encoding ... +;;; ====================================================================== (define context-pre-encoding (append '((#\space "~") (#\~ "\\type{~}")) context-encoding)) -;;;; ====================================================================== -;;;; context-symbol-table ... -;;;; ====================================================================== +;;; ====================================================================== +;;; context-symbol-table ... +;;; ====================================================================== (define (context-symbol-table math) `(("iexcl" "!`") ("cent" "c") @@ -300,9 +318,9 @@ ("rhd" ,(math "\\triangleright")) ("parallel" ,(math "\\parallel")))) -;;;; ====================================================================== -;;;; context-width -;;;; ====================================================================== +;;; ====================================================================== +;;; context-width +;;; ====================================================================== (define (context-width width) (cond ((string? width) @@ -312,9 +330,9 @@ (else (string-append (number->string width) "pt")))) -;;;; ====================================================================== -;;;; context-dim -;;;; ====================================================================== +;;; ====================================================================== +;;; context-dim +;;; ====================================================================== (define (context-dim dimension) (cond ((string? dimension) @@ -323,40 +341,40 @@ (string-append (number->string (inexact->exact (round dimension))) "pt")))) -;;;; ====================================================================== -;;;; context-url -;;;; ====================================================================== +;;; ====================================================================== +;;; context-url +;;; ====================================================================== (define(context-url url text e) - (let ((name (gensym 'url)) + (let ((name (gensym "url")) (text (or text url))) - (printf "\\useURL[~A][~A][][" name url) + (format #t "\\useURL[~A][~A][][" name url) (output text e) - (printf "]\\from[~A]" name))) + (format #t "]\\from[~A]" name))) -;;;; ====================================================================== -;;;; Color Management ... -;;;; ====================================================================== -(define *skribe-context-color-table* (make-hashtable)) +;;; ====================================================================== +;;; Color Management ... +;;; ====================================================================== +(define *skribe-context-color-table* (make-hash-table)) (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" + (format #f "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") + (display "\n%%Colors\n") (for-each (lambda (spec) - (let ((c (hashtable-get *skribe-context-color-table* spec))) + (let ((c (hash-ref *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" + (let ((name (symbol->string (gensym "col")))) + (hash-set! *skribe-context-color-table* spec name) + (format #t "\\definecolor[~A][~A]\n" name (skribe-color->context-color spec)))))) (skribe-get-used-colors)) @@ -370,15 +388,15 @@ 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)))) + (let ((c (and (hash-table? *skribe-context-color-table*) + (hash-ref *skribe-context-color-table* spec)))) (if (not (string? c)) (skribe-error 'context "Can't find color" spec) c))) -;;;; ====================================================================== -;;;; context-engine ... -;;;; ====================================================================== +;;; ====================================================================== +;;; context-engine ... +;;; ====================================================================== (define context-engine (default-engine-set! (make-engine 'context @@ -389,30 +407,30 @@ :symbol-table (context-symbol-table (lambda (m) (format #f "$~a$" m))) :custom context-customs))) -;;;; ====================================================================== -;;;; document ... -;;;; ====================================================================== +;;; ====================================================================== +;;; document ... +;;; ====================================================================== (markup-writer 'document :options '(:title :subtitle :author :ending :env) :before (lambda (n e) ;; Prelude - (printf "% interface=en output=pdftex\n") + (display "% interface=en output=pdftex\n") (display "%%%% -*- TeX -*-\n") - (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" - (skribe-release) (date)) + (format #t "%%%% File automatically generated by Skribilo ~A\n\n" + (skribilo-release)) ;; Make URLs active - (printf "\\setupinteraction[state=start]\n") + (display "\\setupinteraction[state=start]\n") ;; Choose the document font - (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) + (format #t "\\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" + (format #t "\\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))) + (when s (format #t "\\input ~a\n" s))) ;; Output used colors (skribe-declare-standard-colors e) (skribe-declare-used-colors) @@ -421,20 +439,21 @@ ;; 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))))) + (evaluate-document + (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)) + (format #t "\\defineparagraphs[Authors][n=~A]\n" (length a)) (display "\\startAuthors\n") (let Loop ((l a)) (unless (null? l) @@ -452,9 +471,9 @@ -;;;; ====================================================================== -;;;; &context-title ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &context-title ... +;;; ====================================================================== (markup-writer '&context-title :before "{\\DocumentTitle{" :action (lambda (n e) @@ -466,9 +485,9 @@ (display "}\n")))) :after "}}") -;;;; ====================================================================== -;;;; author ... -;;;; ====================================================================== +;;; ====================================================================== +;;; author ... +;;; ====================================================================== (markup-writer 'author :options '(:name :title :affiliation :email :url :address :phone :photo :align) :action (lambda (n e) @@ -493,29 +512,29 @@ (display "}}\n")))) -;;;; ====================================================================== -;;;; toc ... -;;;; ====================================================================== +;;; ====================================================================== +;;; toc ... +;;; ====================================================================== (markup-writer 'toc :options '() :action (lambda (n e) (display "\\placecontent\n"))) -;;;; ====================================================================== -;;;; context-block-before ... -;;;; ====================================================================== +;;; ====================================================================== +;;; 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) + (format #t "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (format #t "\\~a[~a]{" (if num name name-unnum) (string-canonicalize (markup-ident n))) (output (markup-option n :title) e) (display "}\n")))) -;;;; ====================================================================== -;;;; chapter, section, ... -;;;; ====================================================================== +;;; ====================================================================== +;;; chapter, section, ... +;;; ====================================================================== (markup-writer 'chapter :options '(:title :number :toc :file :env) :before (context-block-before 'chapter 'title)) @@ -535,39 +554,39 @@ :options '(:title :number :toc :file :env) :before (context-block-before 'subsubsection 'subsubsubject)) -;;;; ====================================================================== -;;;; paragraph ... -;;;; ====================================================================== +;;; ====================================================================== +;;; paragraph ... +;;; ====================================================================== (markup-writer 'paragraph :options '(:title :number :toc :env) :after "\\par\n") -;;;; ====================================================================== -;;;; footnote ... -;;;; ====================================================================== +;;; ====================================================================== +;;; footnote ... +;;; ====================================================================== (markup-writer 'footnote :before "\\footnote{" :after "}") -;;;; ====================================================================== -;;;; linebreak ... -;;;; ====================================================================== +;;; ====================================================================== +;;; linebreak ... +;;; ====================================================================== (markup-writer 'linebreak :action "\\crlf ") -;;;; ====================================================================== -;;;; hrule ... -;;;; ====================================================================== +;;; ====================================================================== +;;; hrule ... +;;; ====================================================================== (markup-writer 'hrule :options '(:width :height) :before (lambda (n e) - (printf "\\blackrule[width=~A,height=~A]\n" + (format #t "\\blackrule[width=~A,height=~A]\n" (context-width (markup-option n :width)) (context-dim (markup-option n :height))))) -;;;; ====================================================================== -;;;; color ... -;;;; ====================================================================== +;;; ====================================================================== +;;; color ... +;;; ====================================================================== (markup-writer 'color :options '(:bg :fg :width :margin :border) :before (lambda (n e) @@ -579,24 +598,24 @@ (c (markup-option n :round-corner))) (if (or bg w m b) (begin - (printf "\\startframedtext[width=~a" (if w + (format #t "\\startframedtext[width=~a" (if w (context-width w) "fit")) - (printf ",rulethickness=~A" (if b (context-width b) "0pt")) + (format #t ",rulethickness=~A" (if b (context-width b) "0pt")) (when m - (printf ",offset=~A" (context-width m))) + (format #t ",offset=~A" (context-width m))) (when bg - (printf ",background=color,backgroundcolor=~A" + (format #t ",background=color,backgroundcolor=~A" (skribe-get-color bg))) (when fg - (printf ",foregroundcolor=~A" + (format #t ",foregroundcolor=~A" (skribe-get-color fg))) (when c (display ",framecorner=round")) - (printf "]\n")) + (display "]\n")) ;; Probably just a foreground was specified (when fg - (printf "\\startcolor[~A] " (skribe-get-color fg)))))) + (format #t "\\startcolor[~A] " (skribe-get-color fg)))))) :after (lambda (n e) (let ((bg (markup-option n :bg)) (fg (markup-option n :fg)) @@ -604,12 +623,12 @@ (m (markup-option n :margin)) (b (markup-option n :border))) (if (or bg w m b) - (printf "\\stopframedtext ") + (display "\\stopframedtext ") (when fg - (printf "\\stopcolor ")))))) -;;;; ====================================================================== -;;;; frame ... -;;;; ====================================================================== + (display "\\stopcolor ")))))) +;;; ====================================================================== +;;; frame ... +;;; ====================================================================== (markup-writer 'frame :options '(:width :border :margin) :before (lambda (n e) @@ -617,19 +636,19 @@ (w (markup-option n :width)) (b (markup-option n :border)) (c (markup-option n :round-corner))) - (printf "\\startframedtext[width=~a" (if w + (format #t "\\startframedtext[width=~a" (if w (context-width w) "fit")) - (printf ",rulethickness=~A" (context-dim b)) - (printf ",offset=~A" (context-width m)) + (format #t ",rulethickness=~A" (context-dim b)) + (format #t ",offset=~A" (context-width m)) (when c (display ",framecorner=round")) - (printf "]\n"))) + (display "]\n"))) :after "\\stopframedtext ") -;;;; ====================================================================== -;;;; font ... -;;;; ====================================================================== +;;; ====================================================================== +;;; font ... +;;; ====================================================================== (markup-writer 'font :options '(:size) :action (lambda (n e) @@ -650,20 +669,20 @@ (format #f "Illegal font size ~s" size) nb) (+ cs nb)))))) - (ne (make-engine (gensym 'context) + (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) + (format #t "{\\switchtobodyfont[~apt]" ns) (output (markup-body n) ne) (display "}")))) -;;;; ====================================================================== -;;;; flush ... -;;;; ====================================================================== +;;; ====================================================================== +;;; flush ... +;;; ====================================================================== (markup-writer 'flush :options '(:side) :before (lambda (n e) @@ -683,14 +702,14 @@ :before "\n\n\\midaligned{" :after "}\n") -;;;; ====================================================================== -;;;; pre ... -;;;; ====================================================================== +;;; ====================================================================== +;;; pre ... +;;; ====================================================================== (markup-writer 'pre :before "{\\tt\n\\startlines\n\\fixedspaces\n" :action (lambda (n e) (let ((ne (make-engine - (gensym 'context) + (gensym "context") :delegate e :filter (make-string-replace context-pre-encoding) :symbol-table (engine-symbol-table e) @@ -698,15 +717,15 @@ (output (markup-body n) ne))) :after "\n\\stoplines\n}") -;;;; ====================================================================== -;;;; prog ... -;;;; ====================================================================== +;;; ====================================================================== +;;; prog ... +;;; ====================================================================== (markup-writer 'prog :options '(:line :mark) :before "{\\tt\n\\startlines\n\\fixedspaces\n" :action (lambda (n e) (let ((ne (make-engine - (gensym 'context) + (gensym "context") :delegate e :filter (make-string-replace context-pre-encoding) :symbol-table (engine-symbol-table e) @@ -715,9 +734,9 @@ :after "\n\\stoplines\n}") -;;;; ====================================================================== -;;;; itemize, enumerate ... -;;;; ====================================================================== +;;; ====================================================================== +;;; itemize, enumerate ... +;;; ====================================================================== (define (context-itemization-action n e descr?) (let ((symbol (markup-option n :symbol))) (for-each (lambda (item) @@ -746,18 +765,18 @@ :action (lambda (n e) (context-itemization-action n e #f)) :after "\\stopitemize\n\\stopnarrower\n") -;;;; ====================================================================== -;;;; description ... -;;;; ====================================================================== +;;; ====================================================================== +;;; 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 ... -;;;; ====================================================================== +;;; ====================================================================== +;;; item ... +;;; ====================================================================== (markup-writer 'item :options '(:key) :action (lambda (n e) @@ -777,17 +796,17 @@ (when k (display "\n\\stopnarrower\n"))))) -;;;; ====================================================================== -;;;; blockquote ... -;;;; ====================================================================== +;;; ====================================================================== +;;; blockquote ... +;;; ====================================================================== (markup-writer 'blockquote :before "\n\\startnarrower[left,right]\n" :after "\n\\stopnarrower\n") -;;;; ====================================================================== -;;;; figure ... -;;;; ====================================================================== +;;; ====================================================================== +;;; figure ... +;;; ====================================================================== (markup-writer 'figure :options '(:legend :number :multicolumns) :action (lambda (n e) @@ -797,15 +816,15 @@ (unless number (display "{\\setupcaptions[number=off]\n")) (display "\\placefigure\n") - (printf " [~a]\n" (string-canonicalize ident)) + (format #t " [~a]\n" (string-canonicalize ident)) (display " {") (output legend e) (display "}\n") (display " {") (output (markup-body n) e) (display "}") (unless number (display "}\n"))))) -;;;; ====================================================================== -;;;; table ... -;;;; ====================================================================== +;;; ====================================================================== +;;; table ... +;;; ====================================================================== ;; width doesn't work (markup-writer 'table :options '(:width :border :frame :rules :cellpadding) @@ -814,17 +833,15 @@ (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")) + (cp (markup-option n :cellpadding))) + (display "\n{\\bTABLE\n") + (display "\\setupTABLE[") + (format #t "width=~A" (if width (context-width width) "fit")) (when border - (printf ",rulethickness=~A" (context-dim border))) + (format #t ",rulethickness=~A" (context-dim border))) (when cp - (printf ",offset=~A" (context-width cp))) - (printf ",frame=off]\n") + (format #t ",offset=~A" (context-width cp))) + (display ",frame=off]\n") (when rules (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") @@ -846,31 +863,31 @@ ((hsides) (display top) (display bot)) ((lhs) (display left)) ((rhs) (display right)) - ((vsides) (display left) (diplay right)) + ((vsides) (display left) (display right)) ((box border) (display top) (display bot) (display left) (display right))))))) :after (lambda (n e) - (printf "\\eTABLE}\n"))) + (display "\\eTABLE}\n"))) -;;;; ====================================================================== -;;;; tr ... -;;;; ====================================================================== +;;; ====================================================================== +;;; 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]" + (format #t "[background=color,backgroundcolor=~A]" (skribe-get-color bg))))) :after "\\eTR\n") -;;;; ====================================================================== -;;;; tc ... -;;;; ====================================================================== +;;; ====================================================================== +;;; tc ... +;;; ====================================================================== (markup-writer 'tc :options '(:width :align :valign :colspan) :before (lambda (n e) @@ -878,25 +895,23 @@ (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")) + (colspan (markup-option n :colspan))) + (display "\\bTD[") + (format #t "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 + (format #t ",align=~a" (case valign ((center) 'lohi) ((bottom) 'low) ((top) 'high)))) (when align - (printf ",align=~a" (case align + (format #t ",align=~a" (case align ((left) 'right) ; !!!! ((right) 'left) ; !!!! (else 'middle)))) (unless (equal? colspan 1) - (printf ",nx=~a" colspan)) + (format #t ",nx=~a" colspan)) (display "]") (when th? ;; This is a TH, output is bolded @@ -908,9 +923,9 @@ (display "}}")) (display "\\eTD"))) -;;;; ====================================================================== -;;;; image ... -;;;; ====================================================================== +;;; ====================================================================== +;;; image ... +;;; ====================================================================== (markup-writer 'image :options '(:file :url :width :height :zoom) :action (lambda (n e) @@ -919,7 +934,6 @@ (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) @@ -928,16 +942,16 @@ (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))) + (format #t "\\externalfigure[~A][frame=off" (strip-ref-base img)) + (if zoom (format #t ",factor=~a" (inexact->exact zoom))) + (if width (format #t ",width=~a" (context-width width))) + (if height (format #t ",height=~apt" (context-dim height))) (display "]")))))) -;;;; ====================================================================== -;;;; Ornaments ... -;;;; ====================================================================== +;;; ====================================================================== +;;; Ornaments ... +;;; ====================================================================== (markup-writer 'roman :before "{\\rm{" :after "}}") (markup-writer 'bold :before "{\\bf{" :after "}}") (markup-writer 'underline :before "{\\underbar{" :after "}}") @@ -964,16 +978,16 @@ ;;// (output (markup-body n) ne))) ;;// :after "}}") -;;;; ====================================================================== -;;;; q ... -;;;; ====================================================================== +;;; ====================================================================== +;;; q ... +;;; ====================================================================== (markup-writer 'q :before "\\quotation{" :after "}") -;;;; ====================================================================== -;;;; mailto ... -;;;; ====================================================================== +;;; ====================================================================== +;;; mailto ... +;;; ====================================================================== (markup-writer 'mailto :options '(:text) :action (lambda (n e) @@ -984,17 +998,17 @@ (or text (car url)) e))))) -;;;; ====================================================================== -;;;; mark ... -;;;; ====================================================================== +;;; ====================================================================== +;;; mark ... +;;; ====================================================================== (markup-writer 'mark :before (lambda (n e) - (printf "\\reference[~a]{}\n" + (format #t "\\reference[~a]{}\n" (string-canonicalize (markup-ident n))))) -;;;; ====================================================================== -;;;; ref ... -;;;; ====================================================================== +;;; ====================================================================== +;;; ref ... +;;; ====================================================================== (markup-writer 'ref :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) @@ -1006,26 +1020,26 @@ (cond (page ;; Output the page only (this is a hack) (when text (output text e)) - (printf "\\at[~a]" + (format #t "\\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) + (format #t "\\goto{~a}[~a]" (or text id) (string-canonicalize id)) - (printf "\\in[~a]" (string-canonicalize id)))) + (format #t "\\in[~a]" (string-canonicalize id)))) ((markup-option n :mark) - (printf "\\goto{~a}[~a]" + (format #t "\\goto{~a}[~a]" (or text id) (string-canonicalize id))) (else ;; Output a little image indicating the direction - (printf "\\in[~a]" (string-canonicalize id))))))) + (format #t "\\in[~a]" (string-canonicalize id))))))) -;;;; ====================================================================== -;;;; bib-ref ... -;;;; ====================================================================== +;;; ====================================================================== +;;; bib-ref ... +;;; ====================================================================== (markup-writer 'bib-ref :options '(:text :bib) :before (lambda (n e) (output "[" e)) @@ -1034,12 +1048,12 @@ (title (markup-option obj :title)) (ref (markup-option title 'number)) (ident (markup-ident obj))) - (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) + (format #t "\\goto{~a}[~a]" ref (string-canonicalize ident)))) :after (lambda (n e) (output "]" e))) -;;;; ====================================================================== -;;;; bib-ref+ ... -;;;; ====================================================================== +;;; ====================================================================== +;;; bib-ref+ ... +;;; ====================================================================== (markup-writer 'bib-ref+ :options '(:text :bib) :before (lambda (n e) (output "[" e)) @@ -1060,9 +1074,9 @@ (loop (cdr rs)))))))) :after (lambda (n e) (output "]" e))) -;;;; ====================================================================== -;;;; url-ref ... -;;;; ====================================================================== +;;; ====================================================================== +;;; url-ref ... +;;; ====================================================================== (markup-writer 'url-ref :options '(:url :text) :action (lambda (n e) @@ -1085,43 +1099,42 @@ ;;// :after "}}") -;;;; ====================================================================== -;;;; &the-bibliography ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &the-bibliography ... +;;; ====================================================================== (markup-writer '&the-bibliography :before "\n% Bibliography\n\n") -;;;; ====================================================================== -;;;; &bib-entry ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &bib-entry ... +;;; ====================================================================== (markup-writer '&bib-entry :options '(:title) :action (lambda (n e) - (skribe-eval (mark (markup-ident n)) e) + (evaluate-document (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 ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &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 ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &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)))) + (evaluate-document ht e)))) ;;//;*---------------------------------------------------------------------*/ @@ -1132,19 +1145,19 @@ ;;// (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)))) +;;// (evaluate-document (ref :url (markup-body url) :text t) e)))) -;;;; ====================================================================== -;;;; &the-index ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &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) + (evaluate-document (bold n) e) (display "}}\\crlf\n")) (define (make-primary-entry n) @@ -1155,8 +1168,7 @@ (define (make-secondary-entry n) (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) + (b (markup-body n))) (if note (begin ;; This is another entry (display "\\crlf\n ... ") @@ -1169,7 +1181,7 @@ ;; Writer body starts here (let ((col (markup-option n :column))) (when col - (printf "\\startcolumns[n=~a]\n" col)) + (format #t "\\startcolumns[n=~a]\n" col)) (for-each (lambda (item) ;;(DEBUG "ITEM= ~S" item) (if (pair? item) @@ -1181,11 +1193,11 @@ (display "\\crlf\n")) (markup-body n)) (when col - (printf "\\stopcolumns\n"))))) + (display "\\stopcolumns\n"))))) -;;;; ====================================================================== -;;;; &source-comment ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-comment ... +;;; ====================================================================== (markup-writer '&source-comment :action (lambda (n e) (let* ((cc (engine-custom e 'source-comment-color)) @@ -1193,11 +1205,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-line-comment ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-line-comment ... +;;; ====================================================================== (markup-writer '&source-line-comment :action (lambda (n e) (let* ((cc (engine-custom e 'source-comment-color)) @@ -1205,18 +1217,18 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-keyword ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-keyword ... +;;; ====================================================================== (markup-writer '&source-keyword :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) + (evaluate-document (it (markup-body n)) e))) -;;;; ====================================================================== -;;;; &source-error ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-error ... +;;; ====================================================================== (markup-writer '&source-error :action (lambda (n e) (let* ((cc (engine-custom e 'source-error-color)) @@ -1224,11 +1236,11 @@ (n2 (if (and (engine-custom e 'error-color) cc) (color :fg cc (it n1)) (it n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-define ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-define ... +;;; ====================================================================== (markup-writer '&source-define :action (lambda (n e) (let* ((cc (engine-custom e 'source-define-color)) @@ -1236,11 +1248,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-module ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-module ... +;;; ====================================================================== (markup-writer '&source-module :action (lambda (n e) (let* ((cc (engine-custom e 'source-module-color)) @@ -1248,11 +1260,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-markup ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-markup ... +;;; ====================================================================== (markup-writer '&source-markup :action (lambda (n e) (let* ((cc (engine-custom e 'source-markup-color)) @@ -1260,11 +1272,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-thread ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-thread ... +;;; ====================================================================== (markup-writer '&source-thread :action (lambda (n e) (let* ((cc (engine-custom e 'source-thread-color)) @@ -1272,11 +1284,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-string ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-string ... +;;; ====================================================================== (markup-writer '&source-string :action (lambda (n e) (let* ((cc (engine-custom e 'source-string-color)) @@ -1284,11 +1296,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-bracket ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-bracket ... +;;; ====================================================================== (markup-writer '&source-bracket :action (lambda (n e) (let* ((cc (engine-custom e 'source-bracket-color)) @@ -1296,11 +1308,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc (bold n1)) (it n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-type ... +;;; ====================================================================== (markup-writer '&source-type :action (lambda (n e) (let* ((cc (engine-custom e 'source-type-color)) @@ -1308,11 +1320,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) (it n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-key ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-key ... +;;; ====================================================================== (markup-writer '&source-key :action (lambda (n e) (let* ((cc (engine-custom e 'source-type-color)) @@ -1320,11 +1332,11 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc (bold n1)) (it n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== +;;; ====================================================================== +;;; &source-type ... +;;; ====================================================================== (markup-writer '&source-type :action (lambda (n e) (let* ((cc (engine-custom e 'source-type-color)) @@ -1332,23 +1344,25 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg "red" (bold n1)) (bold n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) -;;;; ====================================================================== -;;;; Context Only Markups -;;;; ====================================================================== + +;;; ====================================================================== +;;; Context Only Markups +;;; ====================================================================== ;;; ;;; Margin -- put text in the margin ;;; -(define-markup (margin #!rest opts #!key (ident #f) (class "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)))) + (ident (or ident (symbol->string (gensym "ident")))) (class class) + (loc &invocation-location) (required-options '(:text)) (options (the-options opts :ident :class)) (body (the-body opts)))) @@ -1366,17 +1380,18 @@ ;;; ;;; ConTeXt and TeX ;;; -(define-markup (ConTeXt #!key (space #t)) +(define* (ConTeXt :key (space #t)) (if (engine-format? "context") (! (if space "\\CONTEXT\\ " "\\CONTEXT")) "ConTeXt")) -(define-markup (TeX #!key (space #t)) +(define* (TeX :key (space #t)) (if (engine-format? "context") (! (if space "\\TEX\\ " "\\TEX")) "ConTeXt")) -;;;; ====================================================================== -;;;; Restore the base engine -;;;; ====================================================================== + +;;; ====================================================================== +;;; 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 index 6232b96..86af489 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -1,7 +1,7 @@ ;;; html.scm -- HTML engine. ;;; ;;; Copyright 2003, 2004 Manuel Serrano -;;; Copyright 2005, 2006 Ludovic Courtès +;;; Copyright 2005, 2006, 2007 Ludovic Courtès ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -19,11 +19,36 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine html) - :autoload (skribilo parameters) (*destination-file*) - :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:))) - - +(define-module (skribilo engine html) + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (skribilo config) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo location) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) + :use-module (skribilo package base) + :autoload (skribilo utils images) (convert-image) + :autoload (skribilo utils files) (file-prefix file-suffix) + :autoload (skribilo parameters) (*destination-file*) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo output) (output) + :autoload (skribilo debug) (*debug*) + :autoload (ice-9 rdelim) (read-line) + :autoload (ice-9 regex) (regexp-substitute/global) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) + + :export (html-engine + html-width html-class html-markup-class + html-title-authors)) + +(fluid-set! current-reader %skribilo-module-reader) + + + ;; Keep a reference to the base engine. (define base-engine (find-engine 'base)) @@ -65,10 +90,10 @@ (and (is-markup? node 'subsubsection) (engine-custom e 'subsubsection-file))) (let* ((b (or (and (string? (*destination-file*)) - (prefix (*destination-file*))) + (file-prefix (*destination-file*))) "")) (s (or (and (string? (*destination-file*)) - (suffix (*destination-file*))) + (file-suffix (*destination-file*))) "html")) (nm (get-file-name b s))) (markup-option-add! node filename nm) @@ -89,7 +114,7 @@ ;*---------------------------------------------------------------------*/ ;* html-engine ... */ ;*---------------------------------------------------------------------*/ -(define-public html-engine +(define html-engine ;; setup the html engine (default-engine-set! (make-engine 'html @@ -472,7 +497,7 @@ ((is-markup? p 'chapter) (string-append (html-chapter-number p) "." s)) (else - (string-append s))))) + s)))) (define (html-subsection-number c) (let ((p (ast-parent c)) (s (html-number (markup-option c :number) @@ -512,29 +537,11 @@ "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 #f "~a." (car cnts))) - (else - (let loop ((cnts cnts)) - (if (null? (cdr cnts)) - (format #f "~a" (car cnts)) - (format #f "~a.~a" (car cnts) (loop (cdr cnts)))))))) ;*---------------------------------------------------------------------*/ ;* html-width ... */ ;*---------------------------------------------------------------------*/ -(define-public (html-width width) +(define (html-width width) (cond ((and (integer? width) (exact? width)) (format #f "~A" width)) @@ -548,18 +555,18 @@ ;*---------------------------------------------------------------------*/ ;* html-class ... */ ;*---------------------------------------------------------------------*/ -(define-public (html-class m) +(define (html-class m) (if (markup? m) (let ((c (markup-class m))) (if (or (string? c) (symbol? c) (number? c)) - (printf " class=\"~a\"" c))))) + (format #t " class=\"~a\"" c))))) ;*---------------------------------------------------------------------*/ ;* html-markup-class ... */ ;*---------------------------------------------------------------------*/ -(define-public (html-markup-class m) +(define (html-markup-class m) (lambda (n e) - (printf "<~a" m) + (format #t "<~a" m) (html-class n) (display ">"))) @@ -604,9 +611,9 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&html-head :before (lambda (n e) - (printf "\n") - (printf "\n" (engine-custom (find-engine 'html) + (display "\n") + (display "\n" (engine-custom (find-engine 'html) 'charset))) :after "\n\n") @@ -628,7 +635,7 @@ (let ((bg (engine-custom e 'background))) (display "\n"))) :after "\n") @@ -638,22 +645,22 @@ (markup-writer '&html-page :action (lambda (n e) (define (html-margin m fn size bg fg cla) - (printf "" bg) + (format #t " bgcolor=\"~a\">" bg) (display ">")) - (printf "
\n" cla) + (format #t "
\n" cla) (cond ((and (string? fg) (string? fn)) - (printf "" fg fn)) + (format #t "" fg fn)) ((string? fg) - (printf "" fg)) + (format #t "" fg)) ((string? fn) - (printf "" fn))) + (format #t "" fn))) (if (procedure? m) - (skribe-eval (m n e) e) + (evaluate-document (m n e) e) (output m e)) (if (or (string? fg) (string? fn)) (display "")) @@ -673,7 +680,7 @@ ((and lm rm) (let* ((ep (engine-custom e 'margin-padding)) (ac (if (number? ep) ep 0))) - (printf "\n" ac)) + (format #t "
\n" ac)) (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin") (html-margin body #f #f #f #f "skribilo-body") (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin") @@ -681,14 +688,12 @@ (lm (let* ((ep (engine-custom e 'margin-padding)) (ac (if (number? ep) ep 0))) - (printf "
\n" ac)) + (format #t "
\n" ac)) (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin") (html-margin body #f #f #f #f "skribilo-body") (display "
")) (rm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n")) + (display "
\n") (html-margin body #f #f #f #f "skribilo-body") (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin") (display "
")) @@ -724,7 +729,7 @@ ((string? ic) ic) ((procedure? ic) - (ic d e)) + (ic id e)) (else #f)))) e) ;; style @@ -761,14 +766,14 @@ :action (lambda (n e) (let ((i (markup-body n))) (when i - (printf " \n" i))))) + (format #t " \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)) + (format #t " \n" css)) css))))) (markup-writer '&html-header-style @@ -830,7 +835,7 @@ (else '())))) (for-each (lambda (s) - (printf "" s)) + (format #t "" s)) js)))) @@ -852,7 +857,7 @@ (let ((body (markup-body n))) (if body (output body #t) - (skribe-eval + (evaluate-document (list (hrule) (p :class "ending" (font :size -1 @@ -880,21 +885,21 @@ (when title (display "\n") (if (html-color-spec? tbg) - (printf "")) ;; name - (printf "") ;; title (if title (row title)) @@ -1129,7 +1134,6 @@ (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) @@ -1140,12 +1144,12 @@ ;; blank columns (col level) ;; number - (printf "" + (format #t "" (html-container-number c e)) ;; title - (printf "\n") @@ -1799,19 +1802,19 @@ (colspan (markup-option n :colspan)) (rowspan (markup-option n :rowspan)) (bg (markup-option n :bg))) - (printf "<~a" markup) + (format #t "<~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)) + (if width (format #t " width=\"~a\"" (html-width width))) + (if align (format #t " align=\"~a\"" align)) + (if valign (format #t " valign=\"~a\"" valign)) + (if colspan (format #t " colspan=\"~a\"" colspan)) + (if rowspan (format #t " rowspan=\"~a\"" rowspan)) (when (html-color-spec? bg) - (printf " bgcolor=\"~a\"" bg)) + (format #t " bgcolor=\"~a\"" bg)) (display ">"))) :after (lambda (n e) (let ((markup (or (markup-option n 'markup) 'td))) - (printf "" markup)))) + (format #t "" markup)))) ;*---------------------------------------------------------------------*/ ;* image ... @label image@ */ @@ -1832,16 +1835,16 @@ (if (not (string? img)) (skribe-error 'html "Illegal image" file) (begin - (printf "\"")")))))) ;*---------------------------------------------------------------------*/ @@ -1884,12 +1887,16 @@ (display #\>) (if text (output text e) - (skribe-eval (tt (markup-body n)) e)) + (evaluate-document (tt (markup-body n)) e)) (display "")))) ;*---------------------------------------------------------------------*/ ;* mailto ... @label mailto@ */ ;*---------------------------------------------------------------------*/ +(define %non-at + ;; Char-set not containing the `@' character. + (char-set-complement (char-set #\@))) + (markup-writer 'mailto :options '(:text) :predicate (lambda (n e) @@ -1901,17 +1908,19 @@ :action (lambda (n e) (let* ((body (markup-body n)) (email (if (string? body) body (car body))) - (split (pregexp-split "@" email)) + (split (string-tokenize email %non-at)) (na (car split)) (do (if (pair? (cdr split)) (cadr split) "")) - (nn (pregexp-replace* "[.]" na " ")) - (dd (pregexp-replace* "[.]" do " ")) + (nn (regexp-substitute/global #f "\\." na + 'pre " " 'post)) + (dd (regexp-substitute/global #f "\\." do + 'pre " " 'post)) (text (markup-option n :text))) (display "") (output text e) (display "
" + (format #t "" (if (html-color-spec? tbg) (string-append "bgcolor=\"" tbg "\"") "")) (display "")) (if (string? tfg) - (printf "" tfg)) + (format #t "" tfg)) (when title (if (string? tfont) (begin - (printf "" tfont) + (format #t "" tfont) (output title e) (display "")) (begin - (printf "
") + (display "
") (output title e) (display "
")))) (if (not authors) @@ -929,10 +934,10 @@ (let loop ((fns footnotes)) (if (pair? fns) (let ((fn (car fns))) - (printf "" + (format #t "" (string-canonicalize (container-ident fn))) - (printf "~a: " + (format #t "~a: " (markup-option fn :number)) (output (markup-body fn) e) (display "\n
\n") @@ -942,7 +947,7 @@ ;*---------------------------------------------------------------------*/ ;* html-title-authors ... */ ;*---------------------------------------------------------------------*/ -(define-public (html-title-authors authors e) +(define (html-title-authors authors e) (define (html-authorsN authors cols first) (define (make-row authors . opt) (tr (map (lambda (v) @@ -995,9 +1000,9 @@ (define (document-sui n e) (define (sui) (display "(sui \"") - (skribe-eval (markup-option n :title) html-title-engine) + (evaluate-document (markup-option n :title) html-title-engine) (display "\"\n") - (printf " :file ~s\n" (sui-referenced-file n e)) + (format #t " :file ~s\n" (sui-referenced-file n e)) (sui-marks n e) (sui-blocks 'chapter n e) (sui-blocks 'section n e) @@ -1005,7 +1010,7 @@ (sui-blocks 'subsubsection n e) (display " )\n")) (if (string? (*destination-file*)) - (let ((f (format #f "~a.sui" (prefix (*destination-file*))))) + (let ((f (format #f "~a.sui" (file-prefix (*destination-file*))))) (with-output-to-file f sui)) (sui))) @@ -1014,21 +1019,21 @@ ;*---------------------------------------------------------------------*/ (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") + (if (member (file-suffix file) '("skb" "sui" "skr" "html")) + (string-append (strip-ref-base (file-prefix file)) ".html") file))) ;*---------------------------------------------------------------------*/ ;* sui-marks ... */ ;*---------------------------------------------------------------------*/ (define (sui-marks n e) - (printf " (marks") + (display " (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)) + (format #t "\n (~s" (markup-ident m)) + (format #t " :file ~s" (sui-referenced-file m e)) + (format #t " :mark ~s" (markup-ident m)) (when (markup-class m) - (printf " :class ~s" (markup-class m))) + (format #t " :class ~s" (markup-class m))) (display ")")) (search-down (lambda (n) (is-markup? n 'mark)) n)) (display ")\n")) @@ -1037,14 +1042,14 @@ ;* sui-blocks ... */ ;*---------------------------------------------------------------------*/ (define (sui-blocks kind n e) - (printf " (~as" kind) + (format #t " (~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)) + (evaluate-document (markup-option chap :title) html-title-engine) + (format #t "\" :file ~s" (sui-referenced-file chap e)) + (format #t " :mark ~s" (markup-ident chap)) (when (markup-class chap) - (printf " :class ~s" (markup-class chap))) + (format #t " :class ~s" (markup-class chap))) (display ")")) (container-search-down (lambda (n) (is-markup? n kind)) n)) (display ")\n")) @@ -1069,14 +1074,14 @@ (nfn (engine-custom e 'author-font)) (align (markup-option n :align))) (define (row n) - (printf "
" align) + (format #t "
" align) (output n e) (display "
" align) - (if nfn (printf "\n" nfn)) + (format #t "
" align) + (if nfn (format #t "\n" nfn)) (output name e) - (if nfn (printf "\n")) + (if nfn (display "\n")) (display "
~a~a" + (format #t "" (- 4 level)) - (printf "" + (format #t "" (if (and (*destination-file*) (string=? f (*destination-file*))) "" @@ -1344,13 +1348,13 @@ (display (string-canonicalize ident)) (display "\">\n") (if c - (printf "
" c) - (printf "
" (markup-markup n))) + (format #t "
" c) + (format #t "
" (markup-markup n))) (when (html-color-spec? tbg) (display "") - (printf "\n"))) :after "
" tbg)) + (format #t "
" tbg)) (display tstart) - (if tfg (printf "" tfg)) + (if tfg (format #t "" tfg)) (if number (begin (output (html-container-number n e) e) @@ -1419,9 +1423,9 @@ ;*---------------------------------------------------------------------*/ (markup-writer 'paragraph :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "~a" - (ast-location n))) + (when (and (>= (*debug*) 2) (location? (ast-loc n))) + (format #t "~a" + (ast-loc n))) ((html-markup-class "p") n e)) :after "

") @@ -1439,7 +1443,7 @@ (markup-writer 'footnote :options '(:label) :action (lambda (n e) - (printf "~a" + (format #t "~a" (string-canonicalize (container-ident n)) (markup-option n :label)))) @@ -1463,9 +1467,9 @@ (display " height 1) - (printf " size=\"~a\"" height)) + (format #t " size=\"~a\"" height)) (display ">")))) ;*---------------------------------------------------------------------*/ @@ -1481,8 +1485,8 @@ (when (html-color-spec? bg) (display "\n") (display "\n\n
"))) :after "
") @@ -1532,8 +1536,8 @@ (display "")))) :after (lambda (n e) (let ((size (markup-option n :size)) @@ -1614,7 +1618,7 @@ (html-class item) (display ">") (if ident ;; produce an anchor - (printf "\n\n" + (format #t "\n\n" (string-canonicalize ident))) (output item e) (display "\n"))) @@ -1635,7 +1639,7 @@ (html-class item) (display ">") (if ident ;; produce an anchor - (printf "\n\n" ident)) + (format #t "\n\n" ident)) (output item e) (display "\n"))) (markup-body n))) @@ -1724,11 +1728,10 @@ :options '(:number) :before (lambda (n e) (display "
") - (let ((number (markup-option n :number)) - (legend (markup-option n :legend))) + (let ((number (markup-option n :number))) (if number - (printf "Fig. ~a: " number) - (printf "Fig. : ")))) + (format #t "Fig. ~a: " number) + (display "Fig. : ")))) :after "
") ;*---------------------------------------------------------------------*/ @@ -1746,24 +1749,24 @@ (cs (markup-option n :cellspacing))) (display "= cp 0)) - (printf " cellpadding=\"~a\"" cp)) + (format #t " cellpadding=\"~a\"" cp)) (if (and (number? cs) (>= cs 0)) - (printf " cellspacing=\"~a\"" cs)) + (format #t " cellspacing=\"~a\"" cs)) (cond ((symbol? cstyle) - (printf " style=\"border-collapse: ~a;\"" cstyle)) + (format #t " style=\"border-collapse: ~a;\"" cstyle)) ((string? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) + (format #t " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) ((number? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) + (format #t " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) (if frame - (printf " frame=\"~a\"" + (format #t " frame=\"~a\"" (if (eq? frame 'none) "void" frame))) (if (and rules (not (eq? rules 'header))) - (printf " rules=\"~a\"" rules)) + (format #t " rules=\"~a\"" rules)) (display ">
\n") @@ -1776,7 +1779,7 @@ (let ((bg (markup-option n :bg))) (display ""))) :after "