aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/engine/Makefile.am9
-rw-r--r--src/guile/skribilo/engine/base.scm13
-rw-r--r--src/guile/skribilo/engine/context.scm655
-rw-r--r--src/guile/skribilo/engine/html.scm323
-rw-r--r--src/guile/skribilo/engine/html4.scm95
-rw-r--r--src/guile/skribilo/engine/latex-simple.scm103
-rw-r--r--src/guile/skribilo/engine/latex.scm220
-rw-r--r--src/guile/skribilo/engine/lout.scm351
-rw-r--r--src/guile/skribilo/engine/xml.scm59
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 '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")
- (#\@ "&#x40;"))))))
+ (make-engine 'xml
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")
+ (#\@ "&#x40;")))))
;*---------------------------------------------------------------------*/
;* 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))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-10 23:33:12 +0000