diff options
| -rw-r--r-- | src/guile/skribilo/engine/Makefile.am | 9 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/base.scm | 13 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/context.scm | 655 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/html.scm | 323 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/html4.scm | 95 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/latex-simple.scm | 103 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/latex.scm | 220 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/lout.scm | 351 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/xml.scm | 59 |
9 files changed, 879 insertions, 949 deletions
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 <eg@essi.fr> -;;;; -;;;; -;;;; 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 <eg@essi.fr> +;;; Copyright 2007 Ludovic Courtès <ludo@chbouib.org> +;;; +;;; +;;; 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 <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006, 2007 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; 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 "<head>\n") - (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;") - (printf "charset=~A\">\n" (engine-custom (find-engine 'html) + (display "<head>\n") + (display "<meta http-equiv=\"Content-Type\" content=\"text/html;") + (format #t "charset=~A\">\n" (engine-custom (find-engine 'html) 'charset))) :after "</head>\n\n") @@ -628,7 +635,7 @@ (let ((bg (engine-custom e 'background))) (display "<body") (html-class n) - (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (when (html-color-spec? bg) (format #t " bgcolor=\"~a\"" bg)) (display ">\n"))) :after "</body>\n") @@ -638,22 +645,22 @@ (markup-writer '&html-page :action (lambda (n e) (define (html-margin m fn size bg fg cla) - (printf "<td align=\"left\" valign=\"top\" class=\"~a\"" cla) + (format #t "<td align=\"left\" valign=\"top\" class=\"~a\"" cla) (if size - (printf " width=\"~a\"" (html-width size))) + (format #t " width=\"~a\"" (html-width size))) (if (html-color-spec? bg) - (printf " bgcolor=\"~a\">" bg) + (format #t " bgcolor=\"~a\">" bg) (display ">")) - (printf "<div class=\"~a\">\n" cla) + (format #t "<div class=\"~a\">\n" cla) (cond ((and (string? fg) (string? fn)) - (printf "<font color=\"~a\" \"~a\">" fg fn)) + (format #t "<font color=\"~a\" \"~a\">" fg fn)) ((string? fg) - (printf "<font color=\"~a\">" fg)) + (format #t "<font color=\"~a\">" fg)) ((string? fn) - (printf "<font \"~a\">" fn))) + (format #t "<font \"~a\">" 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 "</font>")) @@ -673,7 +680,7 @@ ((and lm rm) (let* ((ep (engine-custom e 'margin-padding)) (ac (if (number? ep) ep 0))) - (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n" ac)) + (format #t "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\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 "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n" ac)) + (format #t "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n" ac)) (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin") (html-margin body #f #f #f #f "skribilo-body") (display "</tr></table>")) (rm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n")) + (display "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n") (html-margin body #f #f #f #f "skribilo-body") (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin") (display "</tr></table>")) @@ -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 " <link rel=\"shortcut icon\" href=~s>\n" i))))) + (format #t " <link rel=\"shortcut icon\" href=~s>\n" i))))) (markup-writer '&html-header-css :action (lambda (n e) (let ((css (markup-body n))) (when (pair? css) (for-each (lambda (css) - (printf " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css)) + (format #t " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css)) css))))) (markup-writer '&html-header-style @@ -830,7 +835,7 @@ (else '())))) (for-each (lambda (s) - (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s)) + (format #t "<script type=\"text/javascript\" src=\"~a\"></script>" 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 "<table width=\"100%\" class=\"skribilo-title\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") (if (html-color-spec? tbg) - (printf "<td align=\"center\"~A>" + (format #t "<td align=\"center\"~A>" (if (html-color-spec? tbg) (string-append "bgcolor=\"" tbg "\"") "")) (display "<td align=\"center\">")) (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) + (format #t "<font color=\"~a\">" tfg)) (when title (if (string? tfont) (begin - (printf "<font ~a><strong>" tfont) + (format #t "<font ~a><strong>" tfont) (output title e) (display "</strong></font>")) (begin - (printf "<div class=\"skribilo-title\"><strong><big>") + (display "<div class=\"skribilo-title\"><strong><big>") (output title e) (display "</big></strong></div>")))) (if (not authors) @@ -929,10 +934,10 @@ (let loop ((fns footnotes)) (if (pair? fns) (let ((fn (car fns))) - (printf "<a name=\"footnote-~a\">" + (format #t "<a name=\"footnote-~a\">" (string-canonicalize (container-ident fn))) - (printf "<sup><small>~a</small></sup></a>: " + (format #t "<sup><small>~a</small></sup></a>: " (markup-option fn :number)) (output (markup-body fn) e) (display "\n<br>\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 "<tr><td align=\"~a\">" align) + (format #t "<tr><td align=\"~a\">" align) (output n e) (display "</td></tr>")) ;; name - (printf "<tr><td align=\"~a\">" align) - (if nfn (printf "<font ~a>\n" nfn)) + (format #t "<tr><td align=\"~a\">" align) + (if nfn (format #t "<font ~a>\n" nfn)) (output name e) - (if nfn (printf "</font>\n")) + (if nfn (display "</font>\n")) (display "</td></tr>") ;; 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 "<td valign=\"top\" align=\"left\">~a</td>" + (format #t "<td valign=\"top\" align=\"left\">~a</td>" (html-container-number c e)) ;; title - (printf "<td colspan=\"~a\" width=\"100%\">" + (format #t "<td colspan=\"~a\" width=\"100%\">" (- 4 level)) - (printf "<a href=\"~a#~a\">" + (format #t "<a href=\"~a#~a\">" (if (and (*destination-file*) (string=? f (*destination-file*))) "" @@ -1344,13 +1348,13 @@ (display (string-canonicalize ident)) (display "\"></a>\n") (if c - (printf "<div class=\"~a-title\">" c) - (printf "<div class=\"skribilo-~a-title\">" (markup-markup n))) + (format #t "<div class=\"~a-title\">" c) + (format #t "<div class=\"skribilo-~a-title\">" (markup-markup n))) (when (html-color-spec? tbg) (display "<table width=\"100%\">") - (printf "<tr><td bgcolor=\"~a\">" tbg)) + (format #t "<tr><td bgcolor=\"~a\">" tbg)) (display tstart) - (if tfg (printf "<font color=\"~a\">" tfg)) + (if tfg (format #t "<font color=\"~a\">" 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 "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>" - (ast-location n))) + (when (and (>= (*debug*) 2) (location? (ast-loc n))) + (format #t "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>" + (ast-loc n))) ((html-markup-class "p") n e)) :after "</p>") @@ -1439,7 +1443,7 @@ (markup-writer 'footnote :options '(:label) :action (lambda (n e) - (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" + (format #t "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" (string-canonicalize (container-ident n)) (markup-option n :label)))) @@ -1463,9 +1467,9 @@ (display "<hr") (html-class n) (if (< width 100) - (printf " width=\"~a\"" (html-width width))) + (format #t " width=\"~a\"" (html-width width))) (if (> height 1) - (printf " size=\"~a\"" height)) + (format #t " size=\"~a\"" height)) (display ">")))) ;*---------------------------------------------------------------------*/ @@ -1481,8 +1485,8 @@ (when (html-color-spec? bg) (display "<table cellspacing=\"0\"") (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (if w (printf " width=\"~a\"" (html-width w))) + (format #t " cellpadding=\"~a\"" (if m m 0)) + (if w (format #t " width=\"~a\"" (html-width w))) (display "><tbody>\n<tr>") (display "<td bgcolor=\"") (output bg e) @@ -1508,9 +1512,9 @@ (w (markup-option n :width))) (display "<table cellspacing=\"0\"") (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (printf " border=\"~a\"" (if b b 0)) - (if w (printf " width=\"~a\"" (html-width w))) + (format #t " cellpadding=\"~a\"" (if m m 0)) + (format #t " border=\"~a\"" (if b b 0)) + (if w (format #t " width=\"~a\"" (html-width w))) (display "><tbody>\n<tr><td>"))) :after "</td></tr>\n</tbody></table>") @@ -1532,8 +1536,8 @@ (display "<font") (html-class n) (when (and (number? size) (exact? size) (not (= size 0))) - (printf " size=\"~a\"" size)) - (when face (printf " face=\"~a\"" face)) + (format #t " size=\"~a\"" size)) + (when face (format #t " face=\"~a\"" face)) (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<a name=\"~a\"></a>\n" + (format #t "\n<a name=\"~a\"></a>\n" (string-canonicalize ident))) (output item e) (display "</li>\n"))) @@ -1635,7 +1639,7 @@ (html-class item) (display ">") (if ident ;; produce an anchor - (printf "\n<a name=\"~a\"></a>\n" ident)) + (format #t "\n<a name=\"~a\"></a>\n" ident)) (output item e) (display "</li>\n"))) (markup-body n))) @@ -1724,11 +1728,10 @@ :options '(:number) :before (lambda (n e) (display "<center>") - (let ((number (markup-option n :number)) - (legend (markup-option n :legend))) + (let ((number (markup-option n :number))) (if number - (printf "<strong>Fig. ~a:</strong> " number) - (printf "<strong>Fig. :</strong> ")))) + (format #t "<strong>Fig. ~a:</strong> " number) + (display "<strong>Fig. :</strong> ")))) :after "</center>") ;*---------------------------------------------------------------------*/ @@ -1746,24 +1749,24 @@ (cs (markup-option n :cellspacing))) (display "<table") (html-class n) - (if width (printf " width=\"~a\"" (html-width width))) - (if border (printf " border=\"~a\"" border)) + (if width (format #t " width=\"~a\"" (html-width width))) + (if border (format #t " border=\"~a\"" border)) (if (and (number? cp) (>= 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 "><tbody>\n"))) :after "</tbody></table>\n") @@ -1776,7 +1779,7 @@ (let ((bg (markup-option n :bg))) (display "<tr") (html-class n) - (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (when (html-color-spec? bg) (format #t " bgcolor=\"~a\"" bg)) (display ">"))) :after "</tr>\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 "</~a>" markup)))) + (format #t "</~a>" markup)))) ;*---------------------------------------------------------------------*/ ;* image ... @label image@ */ @@ -1832,16 +1835,16 @@ (if (not (string? img)) (skribe-error 'html "Illegal image" file) (begin - (printf "<img src=\"~a\" border=\"0\"" img) + (format #t "<img src=\"~a\" border=\"0\"" img) (html-class n) (if body (begin (display " alt=\"") (output body e) (display "\"")) - (printf " alt=\"~a\"" file)) - (if width (printf " width=\"~a\"" (html-width width))) - (if height (printf " height=\"~a\"" height)) + (format #t " alt=\"~a\"" file)) + (if width (format #t " width=\"~a\"" (html-width width))) + (if height (format #t " height=\"~a\"" height)) (display ">")))))) ;*---------------------------------------------------------------------*/ @@ -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 "</a>")))) ;*---------------------------------------------------------------------*/ ;* 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 "<script language=\"JavaScript\" type=\"text/javascript\"") (if (not text) - (printf ">skribenospam( ~s, ~s, true )" nn dd) + (format #t ">skribenospam( ~s, ~s, true )" nn dd) (begin - (printf ">skribenospam( ~s, ~s, false )" nn dd) + (format #t ">skribenospam( ~s, ~s, false )" nn dd) (display "</script>") (output text e) (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")"))) @@ -1922,7 +1931,7 @@ ;*---------------------------------------------------------------------*/ (markup-writer 'mark :before (lambda (n e) - (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (format #t "<a name=\"~a\"" (string-canonicalize (markup-ident n))) (html-class n) (display ">")) :after "</a>") @@ -1939,7 +1948,7 @@ (class (if (markup-class n) (markup-class n) "skribilo-ref"))) - (printf "<a href=\"~a#~a\" class=\"~a\"" + (format #t "<a href=\"~a#~a\" class=\"~a\"" (if (and (*destination-file*) (string=? f (*destination-file*))) "" @@ -2072,7 +2081,7 @@ (display "<a href=\"") (output url html-title-engine) (display "\"") - (when class (printf " class=\"~a\"" class)) + (when class (format #t " class=\"~a\"" class)) (display ">"))) :action (lambda (n e) (let ((v (markup-option n :text))) @@ -2109,7 +2118,7 @@ (markup-writer '&bib-entry-label :options '(:title) :before (lambda (n e) - (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (format #t "<a name=\"~a\"" (string-canonicalize (markup-ident n))) (html-class n) (display ">")) :action (lambda (n e) @@ -2126,7 +2135,7 @@ (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)))) + (evaluate-document ht e)))) ;*---------------------------------------------------------------------*/ ;* &bib-entry-url ... */ @@ -2136,7 +2145,7 @@ (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-header ... */ @@ -2149,12 +2158,12 @@ (for-each (lambda (h) (let ((f (engine-custom e 'index-header-font-size))) (if f - (skribe-eval (font :size f (bold (it h))) e) + (evaluate-document (font :size f (bold (it h))) e) (output h e)) (display " "))) (markup-body n)) (display "</center>") - (skribe-eval (linebreak 2) e))) + (evaluate-document (linebreak 2) e))) ;*---------------------------------------------------------------------*/ ;* &source-comment ... */ @@ -2166,7 +2175,7 @@ (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 ... */ @@ -2178,14 +2187,14 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-keyword ... */ ;*---------------------------------------------------------------------*/ (markup-writer '&source-keyword :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) + (evaluate-document (bold (markup-body n)) e))) ;*---------------------------------------------------------------------*/ ;* &source-error ... */ @@ -2197,7 +2206,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-define ... */ @@ -2209,7 +2218,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-module ... */ @@ -2221,7 +2230,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-markup ... */ @@ -2233,7 +2242,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-thread ... */ @@ -2245,7 +2254,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-string ... */ @@ -2257,7 +2266,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-bracket ... */ @@ -2269,7 +2278,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc (bold n1)) (bold n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-type ... */ @@ -2281,7 +2290,7 @@ (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 ... */ @@ -2293,7 +2302,7 @@ (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 ... */ @@ -2305,7 +2314,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg "red" (bold n1)) (bold n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm index 48550ef..9141469 100644 --- a/src/guile/skribilo/engine/html4.scm +++ b/src/guile/skribilo/engine/html4.scm @@ -1,31 +1,41 @@ -;;;; -;;;; html4.skr -- HTML 4.01 Engine -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; 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: 18-Feb-2004 11:58 (eg) -;;;; Last file update: 26-Feb-2004 21:09 (eg) -;;;; +;;; html4.scm -- HTML 4.01 engine. +;;; +;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2007 Ludovic Courtès <ludo@chbouib.org> +;;; +;;; +;;; 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-skribe-module (skribilo engine html4)) +(define-module (skribilo engine html4) + :use-module (skribilo ast) + :use-module (skribilo config) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo utils syntax) + :use-module (skribilo package base) + :use-module (skribilo engine html) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo output) (output) + :autoload (skribilo lib) (skribe-error) + :use-module (srfi srfi-1) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:))) +(fluid-set! current-reader %skribilo-module-reader) + + (define (find-children node) (define (flat l) (cond @@ -65,21 +75,25 @@ (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)).])) + (font :size -1 + "This HTML page was produced by " + (ref :url (skribilo-url) + :text "Skribilo") ". " + (linebreak) + "Last update: " + (s19:date->string + (s19:current-date)))) (td :align 'right :valign 'top (ref :url url - :text (image :url img :width 88 :height 31)))))))) + :text (image :url img :width 88 + :height 31)))))))) (markup-writer '&html-ending le :before "<div class=\"skribe-ending\">" :action (lambda (n e) (let ((body (markup-body n))) (if body (output body #t) - (skribe-eval bottom e)))) + (evaluate-document bottom e)))) :after "</div>\n")) ;;---------------------------------------------------------------------- @@ -95,8 +109,8 @@ (when bg (display "<table cellspacing=\"0\"") (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (if w (printf " width=\"~a\"" (html-width w))) + (format #t " cellpadding=\"~a\"" (if m m 0)) + (if w (format #t " width=\"~a\"" (html-width w))) (display "><tbody>\n<tr>") (display "<td bgcolor=\"") (output bg e) @@ -136,8 +150,8 @@ (display "<span ") (html-class n) (display "style=\"") - (if size (printf "font-size: ~a; " size)) - (if face (printf "font-family:'~a'; " face)) + (if size (format #t "font-size: ~a; " size)) + (if face (format #t "font-family:'~a'; " face)) (display "\">"))) :after "</span>") @@ -161,8 +175,7 @@ ;;---------------------------------------------------------------------- ;; table ... ;;---------------------------------------------------------------------- - (let ((old-writer (markup-writer-get 'table le))) - (copy-markup-writer 'table le - :validate (lambda (n e) - (not (null? (markup-body n)))))) + (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 deleted file mode 100644 index 638c158..0000000 --- a/src/guile/skribilo/engine/latex-simple.scm +++ /dev/null @@ -1,103 +0,0 @@ -(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 index e69769b..50b59d6 100644 --- a/src/guile/skribilo/engine/latex.scm +++ b/src/guile/skribilo/engine/latex.scm @@ -19,9 +19,33 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine latex) - :use-module (srfi srfi-13)) - +(define-module (skribilo engine latex) + :use-module (skribilo lib) + :use-module (skribilo ast) + :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 evaluator) (evaluate-document) + :autoload (skribilo output) (output) + :autoload (skribilo debug) (*debug*) + :autoload (skribilo color) (skribe-color->rgb + skribe-use-color!) + :use-module (srfi srfi-13) + :use-module (ice-9 optargs) + :use-module (ice-9 receive) + + :export (latex-engine + LaTeX TeX !latex + skribe-get-latex-color)) + +(fluid-set! current-reader %skribilo-module-reader) + + + ;*---------------------------------------------------------------------*/ ;* latex-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ @@ -381,7 +405,7 @@ ;*---------------------------------------------------------------------*/ ;* LaTeX ... */ ;*---------------------------------------------------------------------*/ -(define-markup (LaTeX #!key (space #t)) +(define* (LaTeX :key (space #t)) (if (engine-format? "latex") (! (if space "\\LaTeX\\ " "\\LaTeX")) "LaTeX")) @@ -389,7 +413,7 @@ ;*---------------------------------------------------------------------*/ ;* TeX ... */ ;*---------------------------------------------------------------------*/ -(define-markup (TeX #!key (space #t)) +(define* (TeX :key (space #t)) (if (engine-format? "latex") (! (if space "\\TeX\\ " "\\TeX")) "TeX")) @@ -397,11 +421,11 @@ ;*---------------------------------------------------------------------*/ ;* latex ... */ ;*---------------------------------------------------------------------*/ -(define-markup (!latex fmt #!rest opt) +(define* (!latex fmt :rest opt) (if (engine-format? "latex") (apply ! fmt opt) #f)) - + ;*---------------------------------------------------------------------*/ ;* latex-width ... */ ;*---------------------------------------------------------------------*/ @@ -437,14 +461,14 @@ ;* latex-declare-color ... */ ;*---------------------------------------------------------------------*/ (define (latex-declare-color name rgb) - (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) + (format #t "\\definecolor{~a}{rgb}{~a}\n" name rgb)) ;*---------------------------------------------------------------------*/ ;* skribe-get-latex-color ... */ ;*---------------------------------------------------------------------*/ -(define-public (skribe-get-latex-color spec) - (let ((c (and (hashtable? *skribe-latex-color-table*) - (hashtable-get *skribe-latex-color-table* spec)))) +(define (skribe-get-latex-color spec) + (let ((c (and (hash-table? *skribe-latex-color-table*) + (hash-ref *skribe-latex-color-table* spec)))) (if (not (string? c)) (skribe-error 'latex "Can't find color" spec) c))) @@ -471,13 +495,13 @@ ;* skribe-latex-declare-colors ... */ ;*---------------------------------------------------------------------*/ (define (skribe-latex-declare-colors colors) - (set! *skribe-latex-color-table* (make-hashtable)) + (set! *skribe-latex-color-table* (make-hash-table)) (for-each (lambda (spec) - (let ((old (hashtable-get *skribe-latex-color-table* spec))) + (let ((old (hash-ref *skribe-latex-color-table* spec))) (if (not (string? old)) - (let ((name (symbol->string (gensym 'c)))) + (let ((name (symbol->string (gensym "c")))) ;; bind the color - (hashtable-put! *skribe-latex-color-table* spec name) + (hash-set! *skribe-latex-color-table* spec name) ;; and emit a latex declaration (latex-declare-color name @@ -506,7 +530,7 @@ :action (lambda (n e) (let ((width (markup-option n 'width))) (if (number? width) - (printf "\\begin{tabular*}{~a}" (latex-width width)) + (format #t "\\begin{tabular*}{~a}" (latex-width width)) (display "\\begin{tabular}"))))) ;*---------------------------------------------------------------------*/ @@ -558,19 +582,21 @@ ;; title (let ((t (markup-option n :title))) (when t - (skribe-eval (new markup - (markup '&latex-title) - (body t)) - e - :env `((parent ,n))))) + (evaluate-document + (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))))) + (evaluate-document + (new markup + (markup '&latex-author) + (body a)) + e + :env `((parent ,n))))) ;; document (display "\\begin{document}\n") ;; postdocument @@ -604,7 +630,7 @@ (markup '&latex-table-start) (class "&latex-author-table")) e) - (printf "{~a}\n" (make-string (length body) #\c)) + (format #t "{~a}\n" (make-string (length body) #\c)) (let loop ((as body)) (output (car as) e) (if (pair? (cdr as)) @@ -629,7 +655,7 @@ (markup '&latex-table-start) (class "author")) e) - (printf "{~a}\n" + (format #t "{~a}\n" (case (markup-option n :align) ((left) "l") ((right) "r") @@ -680,7 +706,7 @@ (markup '&latex-table-start) (class "author")) e) - (printf "{cc}\n")) + (display "{cc}\n")) :action (lambda (n e) (let ((photo (markup-option n :photo))) (output photo e) @@ -725,12 +751,12 @@ %chapter-mapping %chapterless-mapping)) (latex-markup (cdr (assq m markup-mapping)))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a~a{" latex-markup (if (not num) "*" "")) + (format #t "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (format #t "\\~a~a{" latex-markup (if (not num) "*" "")) (output (markup-option n :title) latex-title-engine) (display "}\n") (when num - (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) + (format #t "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) ;*---------------------------------------------------------------------*/ ;* section ... .. @label chapter@ */ @@ -766,8 +792,8 @@ (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" + (when (and (>= (*debug*) 2) (location? (ast-loc n))) + (format #t "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" (ast-location n))) (display "\\noindent ")) :after "\\par\n") @@ -808,17 +834,17 @@ (output n e) (begin (if bg - (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) + (format #t "\\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)) + (format #t "\\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" + (format #t "\\egroup\\colorbox{~a}{\\box~a}%\n" (skribe-get-latex-color bg) latex-color-counter)))))) ;*---------------------------------------------------------------------*/ @@ -841,15 +867,15 @@ (when bg (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") (when m - (printf "\\addtolength{\\tabcolsep}{~a}" + (format #t "\\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"))) + (format #t "{p{~a}}\n" tw) + (display "{l}\n"))) (latex-color bg fg (markup-body n) e) (when bg (output (new markup @@ -867,7 +893,7 @@ (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") (let ((m (markup-option n :margin))) (when m - (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) + (format #t "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) (newline)) :action (lambda (n e) (let* ((b (markup-option n :border)) @@ -885,11 +911,11 @@ e) (if (and (integer? b) (> b 0)) (begin - (printf "{|p{~a}|}\\hline\n" tw) + (format #t "{|p{~a}|}\\hline\n" tw) (output (markup-body n) e) (display "\\\\\\hline\n")) (begin - (printf "{p{~a}}\n" tw) + (format #t "{p{~a}}\n" tw) (output (markup-body n) e))) (output (new markup (markup '&latex-table-stop) @@ -923,13 +949,13 @@ (format #f "Illegal font size ~s" size) nb) (+ cs nb)))))) - (ne (make-engine (gensym 'latex) + (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)) + (format #t "{\\~a{" (latex-font-size ns)) (output (markup-body n) ne) (display "}}")))) @@ -967,7 +993,7 @@ ;*---------------------------------------------------------------------*/ (markup-writer 'pre :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" + (format #t "\\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) @@ -977,7 +1003,7 @@ (set! latex-color-counter (+ latex-color-counter 1))) :action (lambda (n e) (let ((ne (make-engine - (gensym 'latex) + (gensym "latex") :delegate e :filter (make-string-replace latex-pre-encoding) :symbol-table (engine-symbol-table e) @@ -989,7 +1015,7 @@ (markup '&latex-table-stop) (class "pre")) e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + (format #t "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) ;*---------------------------------------------------------------------*/ ;* prog ... */ @@ -997,7 +1023,7 @@ (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{" + (format #t "\\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) @@ -1007,7 +1033,7 @@ (set! latex-color-counter (+ latex-color-counter 1))) :action (lambda (n e) (let ((ne (make-engine - (gensym 'latex) + (gensym "latex") :delegate e :filter (make-string-replace latex-pre-encoding) :symbol-table (engine-symbol-table e) @@ -1019,7 +1045,7 @@ (markup '&latex-table-stop) (class "prog")) e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + (format #t "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) ;*---------------------------------------------------------------------*/ ;* &prog-line ... */ @@ -1028,7 +1054,7 @@ :before (lambda (n e) (let ((num (markup-option n :number))) (if (number? num) - (skribe-eval + (evaluate-document (it (string-append (string-pad (number->string num) 3) ": ")) e)))) @@ -1124,14 +1150,13 @@ :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)) + (format #t "\\caption{\\label{~a}" (string-canonicalize ident)) (output legend e) (display (if mc "}\\end{figure*}\n" @@ -1173,7 +1198,6 @@ (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 @@ -1195,13 +1219,13 @@ (let ((v (make-vector (- nbcols 1) "@{\\extracolsep{\\fill}}c"))) - (apply string-append + (string-concatenate (cons "c" (vector->list v)))))))) (case frame ((none) - (printf "{~a}\n" cols)) + (format #t "{~a}\n" cols)) ((border box) - (printf "{|~a|}" cols) + (format #t "{|~a|}" cols) (markup-option-add! n '&lhs #t) (markup-option-add! n '&rhs #t) (output (new markup @@ -1211,7 +1235,7 @@ (class "table-line-above")) e)) ((above hsides) - (printf "{~a}" cols) + (format #t "{~a}" cols) (output (new markup (markup '&latex-table-hline) (parent n) @@ -1221,15 +1245,15 @@ ((vsides) (markup-option-add! n '&lhs #t) (markup-option-add! n '&rhs #t) - (printf "{|~a|}\n" cols)) + (format #t "{|~a|}\n" cols)) ((lhs) (markup-option-add! n '&lhs #t) - (printf "{|~a}\n" cols)) + (format #t "{|~a}\n" cols)) ((rhs) (markup-option-add! n '&rhs #t) - (printf "{~a|}\n" cols)) + (format #t "{~a|}\n" cols)) (else - (printf "{~a}\n" cols))) + (format #t "{~a}\n" cols))) ;; mark each row with appropriate '&tl (top-line) ;; and &bl (bottom-line) options (when (pair? rows) @@ -1283,10 +1307,11 @@ (markup-writer 'tr :options '() :action (lambda (n e) + (if (not (is-markup? (ast-parent n) 'table)) + (skribe-type-error 'tr "Illegal parent, " (ast-parent n) + "#<table>")) + (let* ((parent (ast-parent n)) - (_ (if (not (is-markup? parent 'table)) - (skribe-type-error 'tr "Illegal parent, " parent - "#<table>"))) (nbcols (markup-option parent '&nbcols)) (lhs (markup-option parent '&lhs)) (rhs (markup-option parent '&rhs)) @@ -1394,9 +1419,8 @@ ;*---------------------------------------------------------------------*/ (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)))) + (let ((width (markup-option n :width))) + (format #t "\\parbox{~a}{" (latex-width width)))) :after "}") ;*---------------------------------------------------------------------*/ @@ -1412,7 +1436,7 @@ ((center) #\c) ((right) #\r) (else #\c)))) - (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) + (format #t "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) :after "}") ;*---------------------------------------------------------------------*/ @@ -1426,7 +1450,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) @@ -1435,10 +1458,10 @@ (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)) + (format #t "\\epsfig{file=~a" (strip-ref-base img)) + (if width (format #t ", width=~a" (latex-width width))) + (if height (format #t ", height=~apt" height)) + (if zoom (format #t ", zoom=\"~a\"" zoom)) (display "}")))))) ;*---------------------------------------------------------------------*/ @@ -1460,7 +1483,7 @@ :before "{\\texttt{" :action (lambda (n e) (let ((ne (make-engine - (gensym 'latex) + (gensym "latex") :delegate e :filter (make-string-replace latex-tt-encoding) :custom (engine-customs e) @@ -1491,7 +1514,7 @@ ;*---------------------------------------------------------------------*/ (markup-writer 'mark :before (lambda (n e) - (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) + (format #t "\\label{~a}" (string-canonicalize (markup-ident n))))) ;*---------------------------------------------------------------------*/ ;* ref ... @label ref@ */ @@ -1505,21 +1528,20 @@ (i (markup-ident c)) (hyper? (engine-custom e 'hyperref))) (if (and hyper? i) - (printf "\\hyperref[~a]{" i)) + (format #t "\\hyperref[~a]{" i)) (output t e) (if (and hyper? i) - (printf "}")))))) + (display "}")))))) :after (lambda (n e) (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c)) - (t (markup-option n :text))) + (id (markup-ident c))) (cond ((markup-option n :page) - (printf "~\\begin{math}{\\pageref{~a}}\\end{math}" + (format #t "~~\\begin{math}{\\pageref{~a}}\\end{math}" (string-canonicalize id))) ((markup-option n :text) #t) (else - (printf "\\ref{~a}" + (format #t "\\ref{~a}" (string-canonicalize id))))))) ;*---------------------------------------------------------------------*/ @@ -1587,7 +1609,7 @@ (begin (display "\\href{") (display url) - (printf "}{~a}" url)))))) + (format #t "}{~a}" url)))))) ;*---------------------------------------------------------------------*/ ;* line-ref ... */ @@ -1648,7 +1670,7 @@ (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)))) + (evaluate-document ht e)))) ;*---------------------------------------------------------------------*/ ;* &bib-entry-label ... */ @@ -1667,7 +1689,7 @@ (let* ((en (handle-ast (ast-parent n))) (url (markup-option en 'url)) (t (it (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) + (evaluate-document (ref :url (markup-body url) :text t) e)))) ;*---------------------------------------------------------------------*/ ;* &source-comment ... */ @@ -1679,7 +1701,7 @@ (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 ... */ @@ -1691,14 +1713,14 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-keyword ... */ ;*---------------------------------------------------------------------*/ (markup-writer '&source-keyword :action (lambda (n e) - (skribe-eval (underline (markup-body n)) e))) + (evaluate-document (underline (markup-body n)) e))) ;*---------------------------------------------------------------------*/ ;* &source-error ... */ @@ -1710,7 +1732,7 @@ (n2 (if (and (engine-custom e 'error-color) cc) (color :fg cc (underline n1)) (underline n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-define ... */ @@ -1722,7 +1744,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-module ... */ @@ -1734,7 +1756,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-markup ... */ @@ -1746,7 +1768,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-thread ... */ @@ -1758,7 +1780,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-string ... */ @@ -1770,7 +1792,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-bracket ... */ @@ -1782,7 +1804,7 @@ (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 ... */ @@ -1794,7 +1816,7 @@ (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 ... */ @@ -1806,7 +1828,7 @@ (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 ... */ @@ -1818,7 +1840,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg "red" (bold n1)) (bold n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index aebde57..664e046 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -19,25 +19,50 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. +(define-module (skribilo engine lout) + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (skribilo config) + :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) + :use-module (srfi srfi-1) + :use-module (srfi srfi-2) + :use-module (srfi srfi-11) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) + :autoload (ice-9 popen) (open-output-pipe) + :autoload (ice-9 rdelim) (read-line) + + :export (lout-engine + lout-illustration !lout + + lout-verbatim-encoding lout-encoding + lout-french-encoding + lout-tagify lout-embedded-postscript-code + lout-color-specification lout-make-url-breakable)) + ;;; Taken from `lcourtes@laas.fr--2004-libre', ;;; `skribe-lout--main--0.2--patch-15'. ;;; Based on `latex.skr', copyright 2003, 2004 Manuel Serrano. ;;; ;;; For more information on Lout, see http://lout.sf.net/ . - -(define-skribe-module (skribilo engine lout) - :use-module (srfi srfi-13) - :use-module (srfi srfi-14) - :autoload (ice-9 popen) (open-output-pipe) - :autoload (ice-9 rdelim) (read-line)) - +(fluid-set! current-reader %skribilo-module-reader) + ;*---------------------------------------------------------------------*/ ;* lout-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ -(define-public lout-verbatim-encoding +(define lout-verbatim-encoding '((#\/ "\"/\"") (#\\ "\"\\\\\"") (#\| "\"|\"") @@ -54,7 +79,7 @@ ;*---------------------------------------------------------------------*/ ;* lout-encoding ... */ ;*---------------------------------------------------------------------*/ -(define-public lout-encoding +(define lout-encoding `(,@lout-verbatim-encoding (#\ç "{ @Char ccedilla }") (#\Ç "{ @Char Ccdeilla }") @@ -351,11 +376,11 @@ `(if *lout-debug?* (with-output-to-port (current-error-port) (lambda () - (printf (string-append ,fmt "~%") ,@args + (format #t (string-append ,fmt "~%") ,@args (current-error-port)))) #t)) -(define-public (lout-tagify ident) +(define (lout-tagify ident) ;; Return an "clean" identifier (a string) based on `ident' (a string), ;; suitable for Lout as an `@Tag' value. (let ((tag-encoding '((#\, "-") @@ -382,7 +407,7 @@ ;; be inserted at the beginning of the output document. (let ((leader (engine-custom engine 'toc-leader)) (leader-space (engine-custom engine 'toc-leader-space))) - (apply string-append + (string-concatenate `("# @SkribiloMark implements Skribe's marks " "(i.e. cross-references)\n" "def @SkribiloMark\n" @@ -425,7 +450,6 @@ (let ((title (markup-option doc :title)) (author (markup-option doc :author)) (date-line (engine-custom engine 'date-line)) - (cover-sheet? (engine-custom engine 'cover-sheet?)) (multi-column? (> (engine-custom engine 'column-number) 1))) (if multi-column? @@ -502,12 +526,11 @@ ;; Default implementation of the `toc-entry-proc' custom that produces the ;; number and title of `node' for use in the table of contents. (let ((num (markup-option node :number)) - (title (markup-option node :title)) - (lang (engine-custom engine 'initial-language))) + (title (markup-option node :title))) (if num (begin (if (is-markup? node 'chapter) (display "@B { ")) - (printf "~a. |2s " (markup-number-string node)) + (format #t "~a. |2s " (markup-number-string node)) (output title engine) (if (is-markup? node 'chapter) (display " }"))) (if (is-markup? node 'chapter) @@ -526,8 +549,8 @@ (and (number? n1) (number? n2) (< n1 n2))) (begin - (fprint (current-error-port) "i1: " ident1 ", " entry1) - (fprint (current-error-port) "i2: " ident2 ", " entry2))))) + (format (current-error-port) "i1: ~a, ~a" ident1 entry1) + (format (current-error-port) "i2: ~a, ~a" ident2 entry2))))) (define (lout-pdf-bookmark-title node engine) ;; Default implementation of the `pdf-bookmark-title-proc' custom that @@ -687,7 +710,7 @@ ;; Extra PDF information, an alist of key-value ;; pairs (string pairs). (pdf-extra-info (("SkribeVersion" - ,(skribe-release)))) + ,(skribilo-release)))) ;; Tells whether to produce PDF "docinfo" ;; (meta-information with title, author, @@ -813,7 +836,7 @@ (nodes (if (document? node) (filter choose-node? (markup-body node)) children))) - (apply string-append + (string-concatenate (map (lambda (node) (let* ((children (filter choose-node? (markup-body node))) (closed? ((engine-custom engine @@ -825,7 +848,7 @@ `(,node ,engine ,@children))))) nodes)))) -(define-public (lout-embedded-postscript-code postscript) +(define (lout-embedded-postscript-code postscript) ;; Return a string embedding PostScript code `postscript' into Lout code. (string-append "\n" "{ @BackEnd @Case {\n" @@ -834,7 +857,7 @@ " }\n" "} } @Graphic { }\n")) -(define-public (lout-pdf-docinfo doc engine) +(define (lout-pdf-docinfo doc engine) ;; Produce PostScript code that will produce PDF document information once ;; converted to PDF. (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding @@ -874,7 +897,7 @@ "") (if (pair? keywords) (docinfo-field "Keywords" - (apply string-append + (string-concatenate (keyword-list->comma-separated keywords))) "") @@ -882,13 +905,13 @@ ;; dictionary" of the `pdfmark' reference. (if (or (not extra-fields) (null? extra-fields)) "" - (apply string-append + (string-concatenate (map (lambda (p) (docinfo-field (car p) (cadr p))) extra-fields))) "\"/\"DOCINFO pdfmark\n"))) -(define-public (lout-output-pdf-meta-info doc engine) +(define (lout-output-pdf-meta-info doc engine) ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as ;; document meta-information (or "docinfo"). This function makes sure that ;; both are only produced once, and only if the relevant customs ask for @@ -911,7 +934,7 @@ ;*---------------------------------------------------------------------*/ ;* lout ... */ ;*---------------------------------------------------------------------*/ -(define-markup (!lout fmt #!rest opt) +(define (!lout fmt . opt) (if (engine-format? "lout") (apply ! fmt opt) #f)) @@ -959,7 +982,7 @@ (if (< size 0) "0.3f" "1.5f") "1.0f")))) -(define-public (lout-color-specification skribe-color) +(define (lout-color-specification skribe-color) ;; Return a Lout color name, ie. a string which is either an English color ;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string ;; representing a Skribe color such as "black" or "#ffffff". @@ -972,17 +995,17 @@ (string-length skribe-color)) 16) skribe-color))) - (receive (r g b) - (skribe-color->rgb actual-color) - (apply format #f - (cons "rgb ~a ~a ~a" - (map (if b&w? - (let ((avg (exact->inexact (/ (+ r g b) - (* 256 3))))) - (lambda (x) avg)) - (lambda (x) - (exact->inexact (/ x 256)))) - (list r g b))))))) + (let-values (((r g b) + (skribe-color->rgb actual-color))) + (apply format #f + (cons "rgb ~a ~a ~a" + (map (if b&w? + (let ((avg (exact->inexact (/ (+ r g b) + (* 256 3))))) + (lambda (x) avg)) + (lambda (x) + (exact->inexact (/ x 256)))) + (list r g b))))))) ;*---------------------------------------------------------------------*/ ;* ~ ... */ @@ -1049,10 +1072,10 @@ 'lout "`document-type' should be one of `book', `report', `doc' or `slides'" doc-type))) - (printf "# Custom document includes\n~a\n" doc-include)) + (format #t "# Custom document includes\n~a\n" doc-include)) (if includes - (printf "# Additional user includes\n~a\n" includes) + (format #t "# Additional user includes\n~a\n" includes) (display "@SysInclude { tbl }\n")) ;; Write additional Lout definitions @@ -1091,9 +1114,9 @@ :affiliation))) (if institution (begin - (printf " @Institution { ") + (display " @Institution { ") (output institution e) - (printf " }\n")))))))) + (display " }\n")))))))) (if (memq doc-type '(report slides)) (let ((date-line (engine-custom e 'date-line))) @@ -1129,11 +1152,11 @@ (output abstract e) (display "\n}\n"))))) - (printf " @OptimizePages { ~a }\n" + (format #t " @OptimizePages { ~a }\n" (if (engine-custom e 'optimize-pages?) "Yes" "No")) - (printf " @InitialFont { ~a }\n" + (format #t " @InitialFont { ~a }\n" (cond ((string? font) font) ((symbol? font) (string-append (symbol->string font) @@ -1146,18 +1169,18 @@ (skribe-error 'lout 'initial-font "Should be a Lout font name, a symbol, or a number")))) - (printf " @InitialBreak { ~a }\n" + (format #t " @InitialBreak { ~a }\n" (if break break "adjust 1.2fx hyphen")) (if (not slides?) - (printf " @ColumnNumber { ~a }\n" + (format #t " @ColumnNumber { ~a }\n" (if (number? column-number) column-number 1))) - (printf " @FirstPageNumber { ~a }\n" + (format #t " @FirstPageNumber { ~a }\n" (if (number? first-page-number) first-page-number 1)) - (printf " @PageOrientation { ~a }\n" + (format #t " @PageOrientation { ~a }\n" (lout-page-orientation page-orientation)) - (printf " @InitialLanguage { ~a }\n" + (format #t " @InitialLanguage { ~a }\n" (if lang lang "English")) ;; FIXME: Insert a preface for text preceding the first ch. @@ -1247,17 +1270,17 @@ (display "@LP\n") (if ident ;; create an internal for PDF navigation - (printf "{ ~a } @LinkSource { " (lout-tagify ident))) + (format #t "{ ~a } @LinkSource { " (lout-tagify ident))) (if (> depth 0) - (printf "|~as " (number->string (* 6 depth)))) + (format #t "|~as " (number->string (* 6 depth)))) (display " @HExpand { ") ;; output the number and title of this node (entry-proc node engine) (display " &1rt @OneCol { ") - (printf " @SkribiloLeaders & @PageOf { ~a }" + (format #t " @SkribiloLeaders & @PageOf { ~a }" (lout-tagify (markup-ident node))) (display " &0io } }") @@ -1333,12 +1356,6 @@ "`document-type' should be one of `book', `report', `doc' or `slides'" doc-type))))) -(define-public (lout-structure-number-string markup) - ;; FIXME: External code has started to rely on this before this was moved - ;; to the `ast' module as `markup-number-string'. Thus, we'll have to keep it - ;; here for some time. - (markup-number-string markup ".")) - ;*---------------------------------------------------------------------*/ ;* lout-block-before ... */ @@ -1361,16 +1378,16 @@ (display (lout-tagify ident)) (display " }\n//0.8vx\n\n")) (begin - (printf "\n@~a\n @Title { " lout-markup) + (format #t "\n@~a\n @Title { " lout-markup) (output title e) - (printf " }\n") + (display " }\n") (if (number? number) - (printf " @BypassNumber { ~a }\n" + (format #t " @BypassNumber { ~a }\n" (markup-number-string n)) (if (not number) ;; this trick hides the section number - (printf " @BypassNumber { } # unnumbered\n"))) + (display " @BypassNumber { } # unnumbered\n"))) (cond ((string? ident) (begin @@ -1394,8 +1411,8 @@ ;; structure (chapter, section, etc.). (let ((lout-markup (lout-structure-markup (markup-markup n) e))) (if (not lout-markup) - (printf "\n\n//0.3vx\n\n") ;; fallback method - (printf "\n\n@End @~a\n\n" lout-markup)))) + (display "\n\n//0.3vx\n\n") ;; fallback method + (format #t "\n\n@End @~a\n\n" lout-markup)))) (define (lout-markup-child-type skribe-markup) @@ -1431,7 +1448,7 @@ ;; produce an `@BeginSubSections' or equivalent; `doc'-style ;; documents need to preprend an `@BeginSections' before the ;; first section while other styles don't. - (printf "\n@Begin~as\n" lout-markup-name)) + (format #t "\n@Begin~as\n" lout-markup-name)) ;; FIXME: We need to make sure that PARENT is a large-scale ;; structure, otherwise it won't have the `&substructs-started?' @@ -1465,7 +1482,7 @@ ;; documents need to issue an `@EndSections' after the last section ;; while other types of documents don't. (lout-debug "end-struct: closing substructs for ~a" markup) - (printf "\n@End~as\n" + (format #t "\n@End~as\n" (lout-structure-markup (lout-markup-child-type markup-type) engine)) (markup-option-set! markup '&substructs-started? #f))) @@ -1546,10 +1563,10 @@ (use-number? (engine-custom e 'use-skribe-footnote-numbers?))) (if (or (and (number? label) use-number?) label) - (printf "{ @FootNote @Label { ~a } { " + (format #t "{ @FootNote @Label { ~a } { " (if label label "")) - (printf "{ @FootNote ~a{ " - (if (not number) "@Label { } " ""))))) + (format #t "{ @FootNote ~a{ " + (if (not label) "@Label { } " ""))))) :after (lambda (n e) (display " } }"))) @@ -1576,10 +1593,9 @@ ;; FIXME: `:width' is not supported either. Rather use `frame' for that ;; kind of options. :before (lambda (n e) - (let* ((w (markup-option n :width)) - (fg (markup-option n :fg))) + (let ((fg (markup-option n :fg))) ;; Skip a line to avoid hitting Basser Lout's length limit. - (printf "{ { ~a }\n@Color { " (lout-color-specification fg)))) + (format #t "{ { ~a }\n@Color { " (lout-color-specification fg)))) :after (lambda (n e) (display " } }"))) @@ -1602,19 +1618,19 @@ ;; linebreak. However, the LaTeX engine doesn't seem to ;; agree. ;(display "\n@LP") - (printf (string-append "\n@Tbl # frame\n" + (format #t (string-append "\n@Tbl # frame\n" " rule { yes }\n")) - (if border (printf " rulewidth { ~a }\n" + (if border (format #t " rulewidth { ~a }\n" (lout-width border))) - (if width (printf " width { ~a }\n" + (if width (format #t " width { ~a }\n" (lout-width width))) - (if margin (printf " margin { ~a }\n" + (if margin (format #t " margin { ~a }\n" (lout-width margin))) - (if bg (printf " paint { ~a }\n" + (if bg (format #t " paint { ~a }\n" (lout-color-specification bg))) (display "{ @Row format { @Cell A } A { ")) -; (printf "\n@Box linewidth { ~a } margin { ~a } { " +; (format #t "\n@Box linewidth { ~a } margin { ~a } { " ; (lout-width (markup-option n :width)) ; (lout-width (markup-option n :margin))) ) @@ -1627,9 +1643,8 @@ (markup-writer 'font :options '(:size :face) :before (lambda (n e) - (let ((face (markup-option n :face)) - (size (lout-font-size (markup-option n :size)))) - (printf "\n~a @Font { " size))) + (let ((size (lout-font-size (markup-option n :size)))) + (format #t "\n~a @Font { " size))) :after (lambda (n e) (display " }\n"))) @@ -1689,7 +1704,7 @@ :before (lambda (n e) (let ((num (markup-option n :number))) (if (number? num) - (skribe-eval + (evaluate-document (it (string-append (string-pad (number->string num) 3) ": ")) e)))) @@ -1718,7 +1733,7 @@ :before (lambda (n e) (let ((symbol (markup-option n :symbol))) (if symbol - (printf "\n@List style { ~a } # enumerate\n" + (format #t "\n@List style { ~a } # enumerate\n" symbol) (display "\n@NumberedList # enumerate\n")))) :after "\n@EndList\n") @@ -1772,7 +1787,7 @@ (display " @Tag { ") (display (lout-tagify ident)) (display " }\n") - (printf " @BypassNumber { ~a }\n" + (format #t " @BypassNumber { ~a }\n" (cond ((number? number) number) ((not number) "") (else number))) @@ -1783,36 +1798,20 @@ (if legend (begin (lout-debug "figure: ~a, \"~a\"" ident legend) - (printf " @Caption { ") + (display " @Caption { ") (output legend e) - (printf " }\n"))) - (printf " @Location { ~a }\n" + (display " }\n"))) + (format #t " @Location { ~a }\n" (if mc? "PageTop" "ColTop")) - (printf "{\n") + (display "{\n") (output (markup-body n) e))) :after (lambda (n e) (display "}\n"))) -;*---------------------------------------------------------------------*/ -;* lout-table-column-number ... */ -;* ------------------------------------------------------------- */ -;* This function computes how columns are contained by the table. */ -;*---------------------------------------------------------------------*/ -(define (lout-table-column-number t) - (define (row-columns row) - (let loop ((cells (markup-body row)) - (nbcols 0)) - (if (null? cells) - nbcols - (loop (cdr cells) - (+ nbcols (markup-option (car cells) :colspan)))))) - (let loop ((rows (markup-body t)) - (nbcols 0)) - (if (null? rows) - nbcols - (loop (cdr rows) - (max (row-columns (car rows)) nbcols))))) +;;; +;;; Table layout. +;;; (define (lout-table-cell-indent align) ;; Return the Lout name (a string) for cell alignment `align' (a symbol). @@ -1893,21 +1892,20 @@ "@VSpan" (let* ((cell-fmt (string-append "@Cell " cell-options (string cell-letter)))) - (string-append - (if (> colspan 1) - (string-append (if (and vspan-start? vspan-alist) - "@StartHVSpan " "@StartHSpan ") - cell-fmt - (let pool ((cnt (- colspan 1)) - (span-cells "")) - (if (= cnt 0) - span-cells - (pool (- cnt 1) - (string-append span-cells - " | @HSpan"))))) - (string-append (if (and vspan-alist vspan-start?) - "@StartVSpan " "") - cell-fmt))))))) + (if (> colspan 1) + (string-append (if (and vspan-start? vspan-alist) + "@StartHVSpan " "@StartHSpan ") + cell-fmt + (let pool ((cnt (- colspan 1)) + (span-cells "")) + (if (= cnt 0) + span-cells + (pool (- cnt 1) + (string-append span-cells + " | @HSpan"))))) + (string-append (if (and vspan-alist vspan-start?) + "@StartVSpan " "") + cell-fmt)))))) (define (lout-table-row-format-string row) @@ -2191,34 +2189,8 @@ ;; XXX: `:cellstyle' `separate' and `:cellspacing' not supported ;; by Lout's @Tbl. :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (cp (markup-option n :cellpadding)) - (rows (markup-body n))) - - (define (cell-width row col) - (let ((cells (markup-body row)) - (bg (markup-option row :bg))) - (let loop ((cells cells) - (c 0)) - (if (pair? cells) - (let* ((ce (car cells)) - (width (markup-option ce :width)) - (colspan (markup-option ce :colspan))) - (if (= col c) - (if (number? width) width 0) - (loop (cdr cells) (+ c colspan)))) - 0)))) - - (define (col-width col) - (let loop ((rows rows) - (width 0)) - (if (null? rows) - (if (= width 0) - 0 - width) - (loop (cdr rows) - (max width (cell-width (car rows) col)))))) + (let ((border (markup-option n :border)) + (cp (markup-option n :cellpadding))) (if (pair? (markup-body n)) ;; Mark the first row as such @@ -2231,10 +2203,10 @@ (display "\n@Tbl # table\n") (if (number? border) - (printf " rulewidth { ~a }\n" + (format #t " rulewidth { ~a }\n" (lout-width (markup-option n :border)))) (if (number? cp) - (printf " margin { ~ap }\n" + (format #t " margin { ~ap }\n" (number->string cp))) (display "{\n"))) @@ -2272,7 +2244,7 @@ ;; row. `@HeaderFirstRow' seems to be buggy though. ;; (see section 6.1, p.119 of the User's Guide). - (printf "\n@~aRow ~aformat { ~a }" + (format #t "\n@~aRow ~aformat { ~a }" (if first-row? "First" "") bg-color fmt) (display (string-append " " rules)) @@ -2290,7 +2262,7 @@ (skribe-error 'lout "tr's parent not a table!" tab)) (markup-option-add! tab '&header-rows (+ hrows 1)) - (printf "\n@Header~aRow ~aformat { ~a }" + (format #t "\n@Header~aRow ~aformat { ~a }" "" ; (if first-row? "First" "") bg-color fmt) (display (string-append " " rules)) @@ -2304,10 +2276,11 @@ (markup-writer 'tc :options '(markup :width :align :valign :colspan :rowspan :bg) :before (lambda (cell e) - (printf "\n ~a { " (markup-option cell '&cell-name))) + (format #t "\n ~a { " (markup-option cell '&cell-name))) :after (lambda (cell e) (display " }"))) + ;*---------------------------------------------------------------------*/ ;* image ... */ @@ -2320,7 +2293,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) @@ -2332,12 +2304,12 @@ (skribe-error 'lout "Illegal image" file) (begin (if width - (printf "\n~a @Wide" (lout-width width))) + (format #t "\n~a @Wide" (lout-width width))) (if height - (printf "\n~a @High" (lout-width height))) + (format #t "\n~a @High" (lout-width height))) (if zoom - (printf "\n~a @Scale" zoom)) - (printf "\n@IncludeGraphic { \"~a\" }\n" img)))))) + (format #t "\n~a @Scale" zoom)) + (format #t "\n@IncludeGraphic { \"~a\" }\n" img)))))) ;*---------------------------------------------------------------------*/ ;* Ornaments ... */ @@ -2373,7 +2345,7 @@ (map (lambda (b) (markup-option-add! b '&italics #t)) bold-children) - (printf "{ ~a { " + (format #t "{ ~a { " (if (markup-option node '&bold) "@BI" "@I")))) :after " } }") @@ -2395,7 +2367,7 @@ (map (lambda (i) (markup-option-add! i '&bold #t)) it-children) - (printf "{ ~a { " + (format #t "{ ~a { " (if (markup-option node '&italics) "@BI" "@B")))) :after " } }") @@ -2451,16 +2423,15 @@ (text (markup-option n :text)) (show-page-num? (markup-option n :page))) - ;; A handle to the target is passed as the body of each - ;; `ref' instance (see `package/base.scm'). - (let* ((target (handle-ast (markup-body n))) - (title (markup-option target :title))) + ;; A handle to the target is passed as the body of each `ref' + ;; instance (see `package/base.scm'). + (let ((target (handle-ast (markup-body n)))) (lout-debug "ref: target=~a ident=~a" target ident) (if text (output text e)) ;; Marks don't have a number (if (eq? kind 'mark) - (printf (lout-page-of ident)) + (format #t (lout-page-of ident)) (begin ;; Don't output a section/whatever number ;; when text is provided in order to be @@ -2476,7 +2447,7 @@ (display " ") (display number)) (if show-page-num? - (printf (lout-page-of ident)))))))))) + (format #t (lout-page-of ident)))))))))) ;*---------------------------------------------------------------------*/ @@ -2543,7 +2514,7 @@ ;*---------------------------------------------------------------------*/ ;* lout-make-url-breakable ... */ ;*---------------------------------------------------------------------*/ -(define-public lout-make-url-breakable +(define lout-make-url-breakable ;; Make the given string (which is assumed to be a URL) breakable. (make-string-replace `((#\/ "\"/\"&0ik{}") (#\. ".&0ik{}") @@ -2565,11 +2536,11 @@ (if (or (not transform) (markup-option n '&transformed)) (begin - (printf "{ \"~a\" @ExternalLink { " url) + (format #t "{ \"~a\" @ExternalLink { " url) (if text (output text e) (display (lout-make-url-breakable url) e)) - (printf " } }")) + (display " } }")) (begin (markup-option-add! n '&transformed #t) (output (transform n) e)))))) @@ -2606,7 +2577,7 @@ (if (null? entries) ;; usually, the tag with be something like "[7]", hence ;; the `+ 1' below (`[]' is narrower than 2f) - (printf "@TaggedList labelwidth { ~af }\n" + (format #t "@TaggedList labelwidth { ~af }\n" (+ 1 label-width)) (loop (cdr entries) (let ((entry-length @@ -2672,7 +2643,7 @@ (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)))) + (evaluate-document ht e)))) ;*---------------------------------------------------------------------*/ ;* &bib-entry-label ... */ @@ -2691,7 +2662,7 @@ (let* ((en (handle-ast (ast-parent n))) (url (markup-option en 'url)) (t (it (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-header ... */ @@ -2702,12 +2673,12 @@ (for-each (lambda (h) (let ((f (engine-custom e 'index-header-font-size))) (if f - (skribe-eval (font :size f (bold (it h))) e) + (evaluate-document (font :size f (bold (it h))) e) (output h e)) (display " "))) (markup-body n)) (display " }") - (skribe-eval (linebreak 2) e))) + (evaluate-document (linebreak 2) e))) ;*---------------------------------------------------------------------*/ ;* &source-comment ... */ @@ -2719,7 +2690,7 @@ (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 ... */ @@ -2731,14 +2702,14 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-keyword ... */ ;*---------------------------------------------------------------------*/ (markup-writer '&source-keyword :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) + (evaluate-document (bold (markup-body n)) e))) ;*---------------------------------------------------------------------*/ ;* &source-define ... */ @@ -2750,7 +2721,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-module ... */ @@ -2762,7 +2733,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-markup ... */ @@ -2774,7 +2745,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-thread ... */ @@ -2786,7 +2757,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-string ... */ @@ -2798,7 +2769,7 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg cc n1) n1))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* &source-bracket ... */ @@ -2810,7 +2781,7 @@ (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 ... */ @@ -2822,7 +2793,7 @@ (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 ... */ @@ -2834,7 +2805,7 @@ (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-bracket ... */ @@ -2846,13 +2817,13 @@ (n2 (if (and (engine-custom e 'source-color) cc) (color :fg "red" (bold n1)) (bold n1)))) - (skribe-eval n2 e)))) + (evaluate-document n2 e)))) ;*---------------------------------------------------------------------*/ ;* Illustrations */ ;*---------------------------------------------------------------------*/ -(define-public (lout-illustration . args) +(define (lout-illustration . args) ;; FIXME: This should be a markup. ;; Introduce a Lout illustration (such as a diagram) whose code is either @@ -2911,7 +2882,7 @@ (let* ((lout (find-engine 'lout)) (output (string-append (or ident (symbol->string - (gensym 'lout-illustration))) + (gensym "lout-illustration"))) ".eps")) (port (open-output-pipe (apply string-append diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm index 81e9f27..b99a814 100644 --- a/src/guile/skribilo/engine/xml.scm +++ b/src/guile/skribilo/engine/xml.scm @@ -1,6 +1,7 @@ ;;; xml.scm -- Generic XML engine. ;;; ;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2007 Ludovic Courtès <ludo@chbouib.org> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -18,28 +19,41 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine xml)) +(define-module (skribilo engine xml) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) + :autoload (skribilo output) (output) + :use-module (srfi srfi-1) + :export (xml-engine)) +(fluid-set! current-reader %skribilo-module-reader) + + + ;*---------------------------------------------------------------------*/ ;* 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 '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@")))))) + (make-engine 'xml + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@"))))) ;*---------------------------------------------------------------------*/ ;* markup ... */ ;*---------------------------------------------------------------------*/ (let ((xml-margin 0)) + (define (keyword->string kw) + (symbol->string (keyword->symbol kw))) (define (make-margin) (make-string xml-margin #\space)) (define (xml-attribute? val) @@ -47,12 +61,12 @@ ((or (string? val) (number? val) (boolean? val)) #t) ((list? val) - (every? xml-attribute? 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))) + (format #t " ~a=\"" s) (let loop ((val val)) (cond ((or (string? val) (number? val)) @@ -65,12 +79,11 @@ #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) + (let ((m (make-margin)) + (s (keyword->string opt))) + (format #t "~a<~a>\n" m s) (output val e) - (printf "~a</~a>\n" m s))) + (format #t "~a</~a>\n" m s))) (define (xml-options n e) ;; display the true options (let ((opts (filter (lambda (o) @@ -88,10 +101,10 @@ (set! xml-margin (- xml-margin 1)) (display m) (display "</options>\n"))))) - (markup-writer #t + (markup-writer #t xml-engine :options 'all :before (lambda (n e) - (printf "~a<~a" (make-margin) (markup-markup n)) + (format #t "~a<~a" (make-margin) (markup-markup n)) ;; display the xml attributes (for-each (lambda (o) (if (and (keyword? (car o)) @@ -106,10 +119,6 @@ ;; body (output (markup-body n) e)) :after (lambda (n e) - (printf "~a</~a>\n" (make-margin) (markup-markup n)) + (format #t "~a</~a>\n" (make-margin) (markup-markup n)) (set! xml-margin (- xml-margin 1))))) -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) |