From efea4dc93f2565555e47de0bfd027614a9c8674d Mon Sep 17 00:00:00 2001
From: Ludovic Courtes
Date: Fri, 1 Jul 2005 23:55:56 +0000
Subject: Lots of changes, again.
Lots of changes, notably the following:
* skr/*.skr: Moved engines to `src/guile/skribilo/engine'.
* src/guile/skribilo/engine.scm (lookup-engine): Rewritten. Don't use
the auto-load alist.
* src/guile/skribilo/evaluator.scm: New name of the `eval' module.
`eval' couldn't be used as the module base-name because of Guile's
recursive module name space.
git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-2
---
src/guile/README | 42 +
src/guile/skribilo.scm | 177 ++-
src/guile/skribilo/biblio.scm | 2 +-
src/guile/skribilo/config.scm.in | 1 -
src/guile/skribilo/debug.scm | 3 +-
src/guile/skribilo/engine.scm | 50 +-
src/guile/skribilo/engine/base.scm | 466 ++++++
src/guile/skribilo/engine/context.scm | 1382 +++++++++++++++++
src/guile/skribilo/engine/html.scm | 2282 ++++++++++++++++++++++++++++
src/guile/skribilo/engine/html4.scm | 167 ++
src/guile/skribilo/engine/latex-simple.scm | 103 ++
src/guile/skribilo/engine/latex.scm | 1780 ++++++++++++++++++++++
src/guile/skribilo/engine/xml.scm | 113 ++
src/guile/skribilo/eval.scm | 186 ---
src/guile/skribilo/evaluator.scm | 207 +++
src/guile/skribilo/lib.scm | 75 +-
src/guile/skribilo/module.scm | 83 +-
src/guile/skribilo/output.scm | 22 +-
src/guile/skribilo/reader.scm | 6 +-
src/guile/skribilo/resolve.scm | 8 +-
src/guile/skribilo/runtime.scm | 11 +-
src/guile/skribilo/source.scm | 4 +-
src/guile/skribilo/writer.scm | 95 +-
23 files changed, 6845 insertions(+), 420 deletions(-)
create mode 100644 src/guile/README
create mode 100644 src/guile/skribilo/engine/base.scm
create mode 100644 src/guile/skribilo/engine/context.scm
create mode 100644 src/guile/skribilo/engine/html.scm
create mode 100644 src/guile/skribilo/engine/html4.scm
create mode 100644 src/guile/skribilo/engine/latex-simple.scm
create mode 100644 src/guile/skribilo/engine/latex.scm
create mode 100644 src/guile/skribilo/engine/xml.scm
delete mode 100644 src/guile/skribilo/eval.scm
create mode 100644 src/guile/skribilo/evaluator.scm
(limited to 'src')
diff --git a/src/guile/README b/src/guile/README
new file mode 100644
index 0000000..1b9a6c4
--- /dev/null
+++ b/src/guile/README
@@ -0,0 +1,42 @@
+Skribilo
+========
+
+Skribilo is a port of Skribe to GNU Guile.
+
+Here are a few goals.
+
+* Usability
+
+** Integration with Guile's module system
+
+** Better error handling, automatic back-traces, etc.
+
+* Font-ends (readers)
+
+** Implement a new front-end mechanism (see `(skribilo reader)')
+
+** Skribe front-end (read Skribe syntax)
+
+** Texinfo front-end
+
+** Simple markup front-end (� la `txt2tags', Emacs' outline mode, or Wiki)
+
+* Back-ends (engines)
+
+** Easier to plug-in new back-ends (no need to modify the source)
+
+** Better HTML (or XHTML?) back-end
+
+** Lout back-end (including automatic `lout' invocation?)
+
+** Info back-end
+
+* Packages
+
+** Pie charts
+
+** Equations
+
+
+
+;;; arch-tag: 2d0a6235-5c09-4930-998c-56a4de2c0aca
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index c352f7f..ae21fab 100755
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -1,7 +1,7 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(skribilo)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;;;
@@ -42,17 +42,11 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;; Allow for this `:style' of keywords.
(read-set! keywords 'prefix)
-;; Allow for DSSSL-style keywords (i.e. `#!key', etc.).
-;; See http://lists.gnu.org/archive/html/guile-devel/2005-06/msg00060.html
-;; for details.
-(read-hash-extend #\! (lambda (chr port)
- (symbol->keyword (read port))))
-
(let ((gensym-orig gensym))
;; In Skribe, `gensym' expects a symbol as its (optional) argument, while
;; Guile's `gensym' expect a string. XXX
(set! gensym
- (lambda (. args)
+ (lambda args
(if (null? args)
(gensym-orig)
(let ((the-arg (car args)))
@@ -64,45 +58,29 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(skribe-error 'gensym "Invalid argument type"
the-arg))))))))
-; (use-modules (skribe eval)
-; (skribe configure)
-; (skribe runtime)
-; (skribe engine)
-; (skribe writer)
-; (skribe verify)
-; (skribe output)
-; (skribe biblio)
-; (skribe prog)
-; (skribe resolve)
-; (skribe source)
-; (skribe lisp)
-; (skribe xml)
-; (skribe c)
-; (skribe debug)
-; (skribe color))
-
-(use-modules (skribe runtime)
- (skribe configure)
- (skribe eval)
- (skribe engine)
- (skribe types) ;; because `new' is a macro and refers to classes
-
- (oop goops) ;; because `new' is a macro
- (ice-9 optargs)
- (ice-9 getopt-long))
+(set! %load-hook
+ (lambda (file)
+ (format #t "~~ loading `~a'...~%" file)))
+
+(define-module (skribilo))
-(load "skribe/lib.scm")
+(use-modules (skribilo module)
+ (skribilo runtime)
+ (skribilo evaluator)
+ (skribilo types)
+ (skribilo engine)
+ (skribilo debug)
+ (skribilo vars)
+ (skribilo lib)
-(load "../common/configure.scm")
-(load "../common/param.scm")
-(load "../common/lib.scm")
-(load "../common/sui.scm")
-(load "../common/index.scm")
+ (ice-9 optargs)
+ (ice-9 getopt-long))
-;; Markup definitions...
-(load "../common/api.scm")
+
+
+;;; FIXME: With my `#:reader' thing added to `define-module',
@@ -115,7 +93,7 @@ specifications."
,@(if alternate
`((single-char ,(string-ref alternate 0)))
'())
- (value #f)))
+ (value ,(if arg #t #f))))
(define (raw-options->getopt-long options)
"Converts @var{options} to a getopt-long-compatible representation."
@@ -130,9 +108,9 @@ specifications."
(("target" :alternate "t" :arg target
:help "sets the output format to <target>")
(set! engine (string->symbol target)))
- (("I" :arg path :help "adds <path> to Skribe path")
+ (("load-path" :alternate "I" :arg path :help "adds <path> to Skribe path")
(set! paths (cons path paths)))
- (("B" :arg path :help "adds <path> to bibliography path")
+ (("bib-path" :alternate "B" :arg path :help "adds <path> to bibliography path")
(skribe-bib-path-set! (cons path (skribe-bib-path))))
(("S" :arg path :help "adds <path> to source path")
(skribe-source-path-set! (cons path (skribe-source-path))))
@@ -247,7 +225,7 @@ Processes a Skribilo/Skribe source file and produces its output.
"))
(define (skribilo-show-version)
- (format #t "skribilo ~a~%" (skribe-release)))
+ (format #t "skribilo ~a~%" (skribilo-release)))
;;;; ======================================================================
;;;;
@@ -387,16 +365,20 @@ Processes a Skribilo/Skribe source file and produces its output.
;;;; S K R I B E
;;;;
;;;; ======================================================================
+; (define (doskribe)
+; (let ((e (find-engine *skribe-engine*)))
+; (if (and (engine? e) (pair? *skribe-precustom*))
+; (for-each (lambda (cv)
+; (engine-custom-set! e (car cv) (cdr cv)))
+; *skribe-precustom*))
+; (if (pair? *skribe-src*)
+; (for-each (lambda (f) (skribe-load f :engine *skribe-engine*))
+; *skribe-src*)
+; (skribe-eval-port (current-input-port) *skribe-engine*))))
+
(define (doskribe)
- (let ((e (find-engine *skribe-engine*)))
- (if (and (engine? e) (pair? *skribe-precustom*))
- (for-each (lambda (cv)
- (engine-custom-set! e (car cv) (cdr cv)))
- *skribe-precustom*))
- (if (pair? *skribe-src*)
- (for-each (lambda (f) (skribe-load f :engine *skribe-engine*))
- *skribe-src*)
- (skribe-eval-port (current-input-port) *skribe-engine*))))
+ (set-current-module (make-run-time-module))
+ (skribe-eval-port (current-input-port) *skribe-engine*))
;;;; ======================================================================
@@ -404,42 +386,81 @@ Processes a Skribilo/Skribe source file and produces its output.
;;;; M A I N
;;;;
;;;; ======================================================================
-(define (skribilo . args)
- (let* ((options (getopt-long (cons "skribilo" args) skribilo-options))
- (target (option-ref options 'target #f))
+(define-public (skribilo . args)
+ (let* ((options (getopt-long (cons "skribilo" args)
+ skribilo-options))
+ (engine (string->symbol
+ (option-ref options 'target "html")))
+ (debugging-level (option-ref options 'debug 0))
+ (load-path (option-ref options 'load-path "."))
+ (bib-path (option-ref options 'bib-path "."))
+ (preload '())
+ (variants '())
+
(help-wanted (option-ref options 'help #f))
(version-wanted (option-ref options 'version #f)))
+ ;; Set up the debugging infrastructure.
+ (debug-enable 'debug)
+ (debug-enable 'backtrace)
+ (debug-enable 'procnames)
+ (read-enable 'positions)
+
(cond (help-wanted (begin (skribilo-show-help) (exit 1)))
- (version-wanted (begin (skribilo-show-version) (exit 1)))
- (target (format #t "target set to `~a'~%" target)))
+ (version-wanted (begin (skribilo-show-version) (exit 1))))
+
+ ;; Parse the most important options.
+
+ (set! *skribe-engine* engine)
+
+ (set-skribe-debug! (string->number debugging-level))
+
+ (set! %skribilo-load-path
+ (cons load-path %skribilo-load-path))
+ (set! %skribilo-bib-path
+ (cons bib-path %skribilo-bib-path))
+
+ (if (option-ref options 'verbose #f)
+ (set! *skribe-verbose* #t))
;; Load the user rc file
- (load-rc)
+ ;(load-rc)
+
+ ;; load the basic Skribe modules
+ (load-skribe-modules)
;; Load the base file to bootstrap the system as well as the files
- ;; that are in the *skribe-preload* variable
- (skribe-load "base.skr" :engine 'base)
+ ;; that are in the PRELOAD variable.
+ (find-engine 'base)
(for-each (lambda (f)
(skribe-load f :engine *skribe-engine*))
- *skribe-preload*)
+ preload)
- ;; Load the specified variants
+ ;; Load the specified variants.
(for-each (lambda (x)
(skribe-load (format #f "~a.skr" x) :engine *skribe-engine*))
- (reverse! *skribe-variants*))
-
- ;; (if (string? *skribe-dest*)
- ;; (with-handler (lambda (kind loc msg)
- ;; (remove-file *skribe-dest*)
- ;; (error loc msg))
- ;; (with-output-to-file *skribe-dest* doskribe))
- ;; (doskribe))
- (if (string? *skribe-dest*)
- (with-output-to-file *skribe-dest* doskribe)
- (doskribe))))
-
-(display "skribilo loaded\n")
+ (reverse! variants))
+
+ (let ((files (option-ref options '() '())))
+ (if (null? files)
+ (error "you must specify at least the input file" files))
+ (if (> (length files) 2)
+ (error "you can specify at most one input file and one output file"
+ files))
+
+ (let* ((source-file (car files))
+ (dest-file (if (null? (cdr files)) #f (cadr files)))
+ (source-port (open-input-file source-file)))
+
+ (if (and dest-file (file-exists? dest-file))
+ (delete-file dest-file))
+
+ (with-input-from-file source-file
+ (lambda ()
+ (if (string? dest-file)
+ (with-output-to-file dest-file doskribe)
+ (doskribe))))))))
+
(define main skribilo)
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm
index 0a4fc98..d4a644e 100644
--- a/src/guile/skribilo/biblio.scm
+++ b/src/guile/skribilo/biblio.scm
@@ -143,7 +143,7 @@
;;; ======================================================================
;; FIXME: Factoriser
(define (skribe-open-bib-file file command)
- (let ((path (find-path file *skribe-bib-path*)))
+ (let ((path (search-path *skribe-bib-path* file)))
(if (string? path)
(begin
(when (> *skribe-verbose* 0)
diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in
index 6e40e7f..a5e3b7c 100644
--- a/src/guile/skribilo/config.scm.in
+++ b/src/guile/skribilo/config.scm.in
@@ -10,7 +10,6 @@
(define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@")
(define-public (skribilo-scheme) "guile")
-
;; Compatibility.
(define-public skribe-release skribilo-release)
diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm
index 1a5478e..b880a66 100644
--- a/src/guile/skribilo/debug.scm
+++ b/src/guile/skribilo/debug.scm
@@ -73,8 +73,7 @@
(define (debug-color col . o)
(with-output-to-string
(if (and *skribe-debug-color*
- (equal? (getenv "TERM") "xterm")
- (interactive-port? *debug-port*))
+ (equal? (getenv "TERM") "xterm"))
(lambda ()
(format #t "[0m[1;~Am" (+ 31 col))
(for-each display o)
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index 9584f5e..1b39ec6 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -27,9 +27,10 @@
(define-module (skribilo engine)
:use-module (skribilo debug)
-; :use-module (skribilo eval)
+; :use-module (skribilo evaluator)
:use-module (skribilo writer)
:use-module (skribilo types)
+ :use-module (skribilo lib)
:use-module (oop goops)
:use-module (ice-9 optargs)
@@ -58,11 +59,14 @@
(define (default-engine-set! e)
- (if (not (engine? e))
- (skribe-error 'default-engine-set! "bad engine ~S" e))
- (set! *default-engine* e)
- (set! *default-engines* (cons e *default-engines*))
- e)
+ (with-debug 5 'default-engine-set!
+ (debug-item "engine=" e)
+
+ (if (not (engine? e))
+ (skribe-error 'default-engine-set! "bad engine ~S" e))
+ (set! *default-engine* e)
+ (set! *default-engines* (cons e *default-engines*))
+ e))
(define (push-default-engine e)
@@ -141,32 +145,22 @@
;;;
;;; FIND-ENGINE
;;;
-(define (%find-loaded-engine id version)
- (let loop ((es *engines*))
- (cond
- ((null? es) #f)
- ((eq? (slot-ref (car es) 'ident) id)
- (cond
- ((eq? version 'unspecified) (car es))
- ((eq? version (slot-ref (car es) 'version)) (car es))
- (else (Loop (cdr es)))))
- (else (loop (cdr es))))))
-
-(define* (find-engine id #:key (version 'unspecified))
- (with-debug 5 'find-engine
+(define* (lookup-engine id #:key (version 'unspecified))
+ "Look for an engine named @var{name} (a symbol) in the @code{(skribilo
+engine)} module hierarchy. If no such engine was found, an error is raised,
+otherwise the requested engine is returned."
+ (with-debug 5 'lookup-engine
(debug-item "id=" id " version=" version)
- (or (%find-loaded-engine id version)
- (let ((c (assq id *skribe-auto-load-alist*)))
- (debug-item "c=" c)
- (if (and c (string? (cdr c)))
- (begin
- (skribe-load (cdr c) :engine 'base)
- (%find-loaded-engine id version))
- #f)))))
+ (let* ((engine (symbol-append id '-engine))
+ (m (resolve-module `(skribilo engine ,id))))
+ (if (module-bound? m engine)
+ (module-ref m engine)
+ (error "no such engine" id)))))
-(define lookup-engine find-engine)
+(define (find-engine . args)
+ (false-if-exception (apply lookup-engine args)))
;;;
diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm
new file mode 100644
index 0000000..53d837d
--- /dev/null
+++ b/src/guile/skribilo/engine/base.scm
@@ -0,0 +1,466 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/base.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sat Jul 26 12:39:30 2003 */
+;* Last change : Wed Oct 27 11:24:20 2004 (eg) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* BASE Skribe engine */
+;*=====================================================================*/
+
+(define-skribe-module (skribilo engine base))
+
+;*---------------------------------------------------------------------*/
+;* base-engine ... */
+;*---------------------------------------------------------------------*/
+(define base-engine
+ (default-engine-set!
+ (make-engine 'base
+ :version 'plain
+ :symbol-table '(("iexcl" "!")
+ ("cent" "c")
+ ("lguillemet" "\"")
+ ("not" "!")
+ ("registered" "(r)")
+ ("degree" "o")
+ ("plusminus" "+/-")
+ ("micro" "o")
+ ("paragraph" "p")
+ ("middot" ".")
+ ("rguillemet" "\"")
+ ("iquestion" "?")
+ ("Agrave" "�")
+ ("Aacute" "A")
+ ("Acircumflex" "�")
+ ("Atilde" "A")
+ ("Amul" "A")
+ ("Aring" "A")
+ ("AEligature" "AE")
+ ("Oeligature" "OE")
+ ("Ccedilla" "�")
+ ("Egrave" "�")
+ ("Eacute" "�")
+ ("Ecircumflex" "�")
+ ("Euml" "E")
+ ("Igrave" "I")
+ ("Iacute" "I")
+ ("Icircumflex" "�")
+ ("Iuml" "I")
+ ("ETH" "D")
+ ("Ntilde" "N")
+ ("Ograve" "O")
+ ("Oacute" "O")
+ ("Ocurcumflex" "O")
+ ("Otilde" "O")
+ ("Ouml" "O")
+ ("times" "x")
+ ("Oslash" "O")
+ ("Ugrave" "�")
+ ("Uacute" "U")
+ ("Ucircumflex" "�")
+ ("Uuml" "�")
+ ("Yacute" "Y")
+ ("agrave" "�")
+ ("aacute" "a")
+ ("acircumflex" "�")
+ ("atilde" "a")
+ ("amul" "a")
+ ("aring" "a")
+ ("aeligature" "�")
+ ("oeligature" "oe")
+ ("ccedilla" "�")
+ ("egrave" "�")
+ ("eacute" "�")
+ ("ecircumflex" "�")
+ ("euml" "e")
+ ("igrave" "i")
+ ("iacute" "i")
+ ("icircumflex" "�")
+ ("iuml" "i")
+ ("ntilde" "n")
+ ("ograve" "o")
+ ("oacute" "o")
+ ("ocurcumflex" "o")
+ ("otilde" "o")
+ ("ouml" "o")
+ ("divide" "/")
+ ("oslash" "o")
+ ("ugrave" "�")
+ ("uacute" "u")
+ ("ucircumflex" "�")
+ ("uuml" "�")
+ ("yacute" "y")
+ ("ymul" "y")
+ ;; punctuation
+ ("bullet" ".")
+ ("ellipsis" "...")
+ ("<-" "<-")
+ ("<--" "<--")
+ ("uparrow" "^;")
+ ("->" "->")
+ ("-->" "-->")
+ ("downarrow" "v")
+ ("<->" "<->")
+ ("<-->" "<-->")
+ ("<+" "<+")
+ ("<=" "<=;")
+ ("<==" "<==")
+ ("Uparrow" "^")
+ ("=>" "=>")
+ ("==>" "==>")
+ ("Downarrow" "v")
+ ("<=>" "<=>")
+ ("<==>" "<==>")
+ ;; Mathematical operators
+ ("asterisk" "*")
+ ("angle" "<")
+ ("and" "^;")
+ ("or" "v")
+ ("models" "|=")
+ ("vdash" "|-")
+ ("dashv" "-|")
+ ("sim" "~")
+ ("mid" "|")
+ ("langle" "<")
+ ("rangle" ">")
+ ;; LaTeX
+ ("circ" "o")
+ ("top" "T")
+ ("lhd" "<")
+ ("rhd" ">")
+ ("parallel" "||")))))
+
+;*---------------------------------------------------------------------*/
+;* mark ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'symbol
+ :action (lambda (n e)
+ (let* ((s (markup-body n))
+ (c (assoc s (engine-symbol-table e))))
+ (if (pair? c)
+ (display (cadr c))
+ (output s e)))))
+
+;*---------------------------------------------------------------------*/
+;* unref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'unref
+ :options 'all
+ :action (lambda (n e)
+ (let* ((s (markup-option n :skribe))
+ (k (markup-option n 'kind))
+ (f (cond
+ (s
+ (format "?~a@~a " k s))
+ (else
+ (format "?~a " k))))
+ (msg (list f (markup-body n)))
+ (n (list "[" (color :fg "red" (bold msg)) "]")))
+ (skribe-eval n e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ (let ((w (markup-writer-get 'table e)))
+ (and (writer? w) (invoke (writer-before w) n e))))
+ :action (lambda (n e)
+ (when (pair? (markup-body n))
+ (for-each (lambda (i) (output i e)) (markup-body n))))
+ :after (lambda (n e)
+ (let ((w (markup-writer-get 'table e)))
+ (and (writer? w) (invoke (writer-after w) n e)))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :before (lambda (n e)
+ (invoke (writer-before (markup-writer-get 'tr e)) n e))
+ :action (lambda (n e)
+ (let ((wtc (markup-writer-get 'tc e)))
+ ;; the label
+ (markup-option-add! n :valign 'top)
+ (markup-option-add! n :align 'right)
+ (invoke (writer-before wtc) n e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (invoke (writer-after wtc) n e)
+ ;; the body
+ (markup-option-add! n :valign 'top)
+ (markup-option-add! n :align 'left)
+ (invoke (writer-before wtc) n e)
+ (output n e (markup-writer-get '&bib-entry-body))
+ (invoke (writer-after wtc) n e)))
+ :after (lambda (n e)
+ (invoke (writer-after (markup-writer-get 'tr e)) n e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before "["
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-body ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-body
+ :action (lambda (n e)
+ (define (output-fields descr)
+ (let loop ((descr descr)
+ (pending #f)
+ (armed #f))
+ (cond
+ ((null? descr)
+ 'done)
+ ((pair? (car descr))
+ (if (eq? (caar descr) 'or)
+ (let ((o1 (cadr (car descr))))
+ (if (markup-option n o1)
+ (loop (cons o1 (cdr descr))
+ pending
+ #t)
+ (let ((o2 (caddr (car descr))))
+ (loop (cons o2 (cdr descr))
+ pending
+ armed))))
+ (let ((o (markup-option n (cadr (car descr)))))
+ (if o
+ (begin
+ (if (and pending armed)
+ (output pending e))
+ (output (caar descr) e)
+ (output o e)
+ (if (pair? (cddr (car descr)))
+ (output (caddr (car descr)) e))
+ (loop (cdr descr) #f #t))
+ (loop (cdr descr) pending armed)))))
+ ((symbol? (car descr))
+ (let ((o (markup-option n (car descr))))
+ (if o
+ (begin
+ (if (and armed pending)
+ (output pending e))
+ (output o e)
+ (loop (cdr descr) #f #t))
+ (loop (cdr descr) pending armed))))
+ ((null? (cdr descr))
+ (output (car descr) e))
+ ((string? (car descr))
+ (loop (cdr descr)
+ (if pending pending (car descr))
+ armed))
+ (else
+ (skribe-error 'output-bib-fields
+ "Illegal description"
+ (car descr))))))
+ (output-fields
+ (case (markup-option n 'kind)
+ ((techreport)
+ `(author " -- " (or title url documenturl) " -- "
+ number ", " institution ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((article)
+ `(author " -- " (or title url documenturl) " -- "
+ journal ", " volume "" ("(" number ")") ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((inproceedings)
+ `(author " -- " (or title url documenturl) " -- "
+ booktitle ", " series ", " ("(" number ")") ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((book)
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year ", " ("pp. " pages) "."))
+ ((phdthesis)
+ '(author " -- " (or title url documenturl) " -- " type ", "
+ school ", " address
+ ", " month ", " year"."))
+ ((misc)
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year"."))
+ (else
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year ", " ("pp. " pages) "."))))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-ident ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-ident
+ :action (lambda (n e)
+ (output (markup-option n 'number) e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-publisher ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-publisher
+ :action (lambda (n e)
+ (skribe-eval (it (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &the-index ... @label the-index@ */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index
+ :options '(:column)
+ :before (lambda (n e)
+ (output (markup-option n 'header) e))
+ :action (lambda (n e)
+ (define (make-mark-entry n fst)
+ (let ((l (tr :class 'index-mark-entry
+ (td :colspan 2 :align 'left
+ (bold (it (sf n)))))))
+ (if fst
+ (list l)
+ (list (tr (td :colspan 2)) l))))
+ (define (make-primary-entry n p)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (c (if note
+ (list b
+ (it (list " (" note ")")))
+ b)))
+ (when p
+ (markup-option-add! b :text
+ (list (markup-option b :text)
+ ", p."))
+ (markup-option-add! b :page #t))
+ (tr :class 'index-primary-entry
+ (td :colspan 2 :valign 'top :align 'left c))))
+ (define (make-secondary-entry n p)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (bb (markup-body b)))
+ (cond
+ ((not (or bb (is-markup? b 'url-ref)))
+ (skribe-error 'the-index
+ "Illegal entry"
+ b))
+ (note
+ (let ((r (if bb
+ (it (ref :class "the-index-secondary"
+ :handle bb
+ :page p
+ :text (if p
+ (list note ", p.")
+ note)))
+ (it (ref :class "the-index-secondary"
+ :url (markup-option b :url)
+ :page p
+ :text (if p
+ (list note ", p.")
+ note))))))
+ (tr :class 'index-secondary-entry
+ (td :valign 'top :align 'right :width 1. " ...")
+ (td :valign 'top :align 'left r))))
+ (else
+ (let ((r (if bb
+ (ref :class "the-index-secondary"
+ :handle bb
+ :page p
+ :text (if p " ..., p." " ..."))
+ (ref :class "the-index-secondary"
+ :url (markup-option b :url)
+ :page p
+ :text (if p " ..., p." " ...")))))
+ (tr :class 'index-secondary-entry
+ (td :valign 'top :align 'right :width 1.)
+ (td :valign 'top :align 'left r)))))))
+ (define (make-column ie p)
+ (let loop ((ie ie)
+ (f #t))
+ (cond
+ ((null? ie)
+ '())
+ ((not (pair? (car ie)))
+ (append (make-mark-entry (car ie) f)
+ (loop (cdr ie) #f)))
+ (else
+ (cons (make-primary-entry (caar ie) p)
+ (append (map (lambda (x)
+ (make-secondary-entry x p))
+ (cdar ie))
+ (loop (cdr ie) #f)))))))
+ (define (make-sub-tables ie nc p)
+ (let* ((l (length ie))
+ (w (/ 100. nc))
+ (iepc (let ((d (/ l nc)))
+ (if (integer? d)
+ (inexact->exact d)
+ (+ 1 (inexact->exact (truncate d))))))
+ (split (list-split ie iepc)))
+ (tr (map (lambda (ies)
+ (td :valign 'top :width w
+ (if (pair? ies)
+ (table :width 100. (make-column ies p))
+ "")))
+ split))))
+ (let* ((ie (markup-body n))
+ (nc (markup-option n :column))
+ (loc (ast-loc n))
+ (pref (eq? (engine-custom e 'index-page-ref) #t))
+ (t (cond
+ ((null? ie)
+ "")
+ ((or (not (integer? nc)) (= nc 1))
+ (table :width 100.
+ :&skribe-eval-location loc
+ :class "index-table"
+ (make-column ie pref)))
+ (else
+ (table :width 100.
+ :&skribe-eval-location loc
+ :class "index-table"
+ (make-sub-tables ie nc pref))))))
+ (output (skribe-eval t e) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;* ------------------------------------------------------------- */
+;* The index header is only useful for targets that support */
+;* hyperlinks such as HTML. */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e) #f))
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (n (markup-ident (handle-body (markup-body n)))))
+ (skribe-eval (it (if (integer? o) (+ o n) n)) e))))
+
+
+
+;;;; A VIRER (mais handle-body n'est pas d�fini)
+(markup-writer 'line-ref
+ :options '(:offset)
+ :action #f)
diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm
new file mode 100644
index 0000000..48a069e
--- /dev/null
+++ b/src/guile/skribilo/engine/context.scm
@@ -0,0 +1,1382 @@
+;;;;
+;;;; context.skr -- ConTeXt mode for Skribe
+;;;;
+;;;; Copyright � 2004 Erick Gallesio - I3S-CNRS/ESSI <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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 23-Sep-2004 17:21 (eg)
+;;;; Last file update: 3-Nov-2004 12:54 (eg)
+;;;;
+
+(define-skribe-module (skribilo engine context))
+
+;;;; ======================================================================
+;;;; context-customs ...
+;;;; ======================================================================
+(define context-customs
+ '((source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ (index-page-ref #t)
+ (image-format ("jpg"))
+ (font-size 11)
+ (font-type "roman")
+ (user-style #f)
+ (document-style "book")))
+
+;;;; ======================================================================
+;;;; context-encoding ...
+;;;; ======================================================================
+(define context-encoding
+ '((#\# "\\type{#}")
+ (#\| "\\type{|}")
+ (#\{ "$\\{$")
+ (#\} "$\\}$")
+ (#\~ "\\type{~}")
+ (#\& "\\type{&}")
+ (#\_ "\\type{_}")
+ (#\^ "\\type{^}")
+ (#\[ "\\type{[}")
+ (#\] "\\type{]}")
+ (#\< "\\type{<}")
+ (#\> "\\type{>}")
+ (#\$ "\\type{$}")
+ (#\% "\\%")
+ (#\\ "$\\backslash$")))
+
+;;;; ======================================================================
+;;;; context-pre-encoding ...
+;;;; ======================================================================
+(define context-pre-encoding
+ (append '((#\space "~")
+ (#\~ "\\type{~}"))
+ context-encoding))
+
+
+;;;; ======================================================================
+;;;; context-symbol-table ...
+;;;; ======================================================================
+(define (context-symbol-table math)
+ `(("iexcl" "!`")
+ ("cent" "c")
+ ("pound" "\\pounds")
+ ("yen" "Y")
+ ("section" "\\S")
+ ("mul" ,(math "^-"))
+ ("copyright" "\\copyright")
+ ("lguillemet" ,(math "\\ll"))
+ ("not" ,(math "\\neg"))
+ ("degree" ,(math "^{\\small{o}}"))
+ ("plusminus" ,(math "\\pm"))
+ ("micro" ,(math "\\mu"))
+ ("paragraph" "\\P")
+ ("middot" ,(math "\\cdot"))
+ ("rguillemet" ,(math "\\gg"))
+ ("1/4" ,(math "\\frac{1}{4}"))
+ ("1/2" ,(math "\\frac{1}{2}"))
+ ("3/4" ,(math "\\frac{3}{4}"))
+ ("iquestion" "?`")
+ ("Agrave" "\\`{A}")
+ ("Aacute" "\\'{A}")
+ ("Acircumflex" "\\^{A}")
+ ("Atilde" "\\~{A}")
+ ("Amul" "\\\"{A}")
+ ("Aring" "{\\AA}")
+ ("AEligature" "{\\AE}")
+ ("Oeligature" "{\\OE}")
+ ("Ccedilla" "{\\c{C}}")
+ ("Egrave" "{\\`{E}}")
+ ("Eacute" "{\\'{E}}")
+ ("Ecircumflex" "{\\^{E}}")
+ ("Euml" "\\\"{E}")
+ ("Igrave" "{\\`{I}}")
+ ("Iacute" "{\\'{I}}")
+ ("Icircumflex" "{\\^{I}}")
+ ("Iuml" "\\\"{I}")
+ ("ETH" "D")
+ ("Ntilde" "\\~{N}")
+ ("Ograve" "\\`{O}")
+ ("Oacute" "\\'{O}")
+ ("Ocurcumflex" "\\^{O}")
+ ("Otilde" "\\~{O}")
+ ("Ouml" "\\\"{O}")
+ ("times" ,(math "\\times"))
+ ("Oslash" "\\O")
+ ("Ugrave" "\\`{U}")
+ ("Uacute" "\\'{U}")
+ ("Ucircumflex" "\\^{U}")
+ ("Uuml" "\\\"{U}")
+ ("Yacute" "\\'{Y}")
+ ("szlig" "\\ss")
+ ("agrave" "\\`{a}")
+ ("aacute" "\\'{a}")
+ ("acircumflex" "\\^{a}")
+ ("atilde" "\\~{a}")
+ ("amul" "\\\"{a}")
+ ("aring" "\\aa")
+ ("aeligature" "\\ae")
+ ("oeligature" "{\\oe}")
+ ("ccedilla" "{\\c{c}}")
+ ("egrave" "{\\`{e}}")
+ ("eacute" "{\\'{e}}")
+ ("ecircumflex" "{\\^{e}}")
+ ("euml" "\\\"{e}")
+ ("igrave" "{\\`{\\i}}")
+ ("iacute" "{\\'{\\i}}")
+ ("icircumflex" "{\\^{\\i}}")
+ ("iuml" "\\\"{\\i}")
+ ("ntilde" "\\~{n}")
+ ("ograve" "\\`{o}")
+ ("oacute" "\\'{o}")
+ ("ocurcumflex" "\\^{o}")
+ ("otilde" "\\~{o}")
+ ("ouml" "\\\"{o}")
+ ("divide" ,(math "\\div"))
+ ("oslash" "\\o")
+ ("ugrave" "\\`{u}")
+ ("uacute" "\\'{u}")
+ ("ucircumflex" "\\^{u}")
+ ("uuml" "\\\"{u}")
+ ("yacute" "\\'{y}")
+ ("ymul" "\\\"{y}")
+ ;; Greek
+ ("Alpha" "A")
+ ("Beta" "B")
+ ("Gamma" ,(math "\\Gamma"))
+ ("Delta" ,(math "\\Delta"))
+ ("Epsilon" "E")
+ ("Zeta" "Z")
+ ("Eta" "H")
+ ("Theta" ,(math "\\Theta"))
+ ("Iota" "I")
+ ("Kappa" "K")
+ ("Lambda" ,(math "\\Lambda"))
+ ("Mu" "M")
+ ("Nu" "N")
+ ("Xi" ,(math "\\Xi"))
+ ("Omicron" "O")
+ ("Pi" ,(math "\\Pi"))
+ ("Rho" "P")
+ ("Sigma" ,(math "\\Sigma"))
+ ("Tau" "T")
+ ("Upsilon" ,(math "\\Upsilon"))
+ ("Phi" ,(math "\\Phi"))
+ ("Chi" "X")
+ ("Psi" ,(math "\\Psi"))
+ ("Omega" ,(math "\\Omega"))
+ ("alpha" ,(math "\\alpha"))
+ ("beta" ,(math "\\beta"))
+ ("gamma" ,(math "\\gamma"))
+ ("delta" ,(math "\\delta"))
+ ("epsilon" ,(math "\\varepsilon"))
+ ("zeta" ,(math "\\zeta"))
+ ("eta" ,(math "\\eta"))
+ ("theta" ,(math "\\theta"))
+ ("iota" ,(math "\\iota"))
+ ("kappa" ,(math "\\kappa"))
+ ("lambda" ,(math "\\lambda"))
+ ("mu" ,(math "\\mu"))
+ ("nu" ,(math "\\nu"))
+ ("xi" ,(math "\\xi"))
+ ("omicron" ,(math "\\o"))
+ ("pi" ,(math "\\pi"))
+ ("rho" ,(math "\\rho"))
+ ("sigmaf" ,(math "\\varsigma"))
+ ("sigma" ,(math "\\sigma"))
+ ("tau" ,(math "\\tau"))
+ ("upsilon" ,(math "\\upsilon"))
+ ("phi" ,(math "\\varphi"))
+ ("chi" ,(math "\\chi"))
+ ("psi" ,(math "\\psi"))
+ ("omega" ,(math "\\omega"))
+ ("thetasym" ,(math "\\vartheta"))
+ ("piv" ,(math "\\varpi"))
+ ;; punctuation
+ ("bullet" ,(math "\\bullet"))
+ ("ellipsis" ,(math "\\ldots"))
+ ("weierp" ,(math "\\wp"))
+ ("image" ,(math "\\Im"))
+ ("real" ,(math "\\Re"))
+ ("tm" ,(math "^{\\sc\\tiny{tm}}"))
+ ("alef" ,(math "\\aleph"))
+ ("<-" ,(math "\\leftarrow"))
+ ("<--" ,(math "\\longleftarrow"))
+ ("uparrow" ,(math "\\uparrow"))
+ ("->" ,(math "\\rightarrow"))
+ ("-->" ,(math "\\longrightarrow"))
+ ("downarrow" ,(math "\\downarrow"))
+ ("<->" ,(math "\\leftrightarrow"))
+ ("<-->" ,(math "\\longleftrightarrow"))
+ ("<+" ,(math "\\hookleftarrow"))
+ ("<=" ,(math "\\Leftarrow"))
+ ("<==" ,(math "\\Longleftarrow"))
+ ("Uparrow" ,(math "\\Uparrow"))
+ ("=>" ,(math "\\Rightarrow"))
+ ("==>" ,(math "\\Longrightarrow"))
+ ("Downarrow" ,(math "\\Downarrow"))
+ ("<=>" ,(math "\\Leftrightarrow"))
+ ("<==>" ,(math "\\Longleftrightarrow"))
+ ;; Mathematical operators
+ ("forall" ,(math "\\forall"))
+ ("partial" ,(math "\\partial"))
+ ("exists" ,(math "\\exists"))
+ ("emptyset" ,(math "\\emptyset"))
+ ("infinity" ,(math "\\infty"))
+ ("nabla" ,(math "\\nabla"))
+ ("in" ,(math "\\in"))
+ ("notin" ,(math "\\notin"))
+ ("ni" ,(math "\\ni"))
+ ("prod" ,(math "\\Pi"))
+ ("sum" ,(math "\\Sigma"))
+ ("asterisk" ,(math "\\ast"))
+ ("sqrt" ,(math "\\surd"))
+ ("propto" ,(math "\\propto"))
+ ("angle" ,(math "\\angle"))
+ ("and" ,(math "\\wedge"))
+ ("or" ,(math "\\vee"))
+ ("cap" ,(math "\\cap"))
+ ("cup" ,(math "\\cup"))
+ ("integral" ,(math "\\int"))
+ ("models" ,(math "\\models"))
+ ("vdash" ,(math "\\vdash"))
+ ("dashv" ,(math "\\dashv"))
+ ("sim" ,(math "\\sim"))
+ ("cong" ,(math "\\cong"))
+ ("approx" ,(math "\\approx"))
+ ("neq" ,(math "\\neq"))
+ ("equiv" ,(math "\\equiv"))
+ ("le" ,(math "\\leq"))
+ ("ge" ,(math "\\geq"))
+ ("subset" ,(math "\\subset"))
+ ("supset" ,(math "\\supset"))
+ ("subseteq" ,(math "\\subseteq"))
+ ("supseteq" ,(math "\\supseteq"))
+ ("oplus" ,(math "\\oplus"))
+ ("otimes" ,(math "\\otimes"))
+ ("perp" ,(math "\\perp"))
+ ("mid" ,(math "\\mid"))
+ ("lceil" ,(math "\\lceil"))
+ ("rceil" ,(math "\\rceil"))
+ ("lfloor" ,(math "\\lfloor"))
+ ("rfloor" ,(math "\\rfloor"))
+ ("langle" ,(math "\\langle"))
+ ("rangle" ,(math "\\rangle"))
+ ;; Misc
+ ("loz" ,(math "\\diamond"))
+ ("spades" ,(math "\\spadesuit"))
+ ("clubs" ,(math "\\clubsuit"))
+ ("hearts" ,(math "\\heartsuit"))
+ ("diams" ,(math "\\diamondsuit"))
+ ("euro" "\\euro{}")
+ ;; ConTeXt
+ ("dag" "\\dag")
+ ("ddag" "\\ddag")
+ ("circ" ,(math "\\circ"))
+ ("top" ,(math "\\top"))
+ ("bottom" ,(math "\\bot"))
+ ("lhd" ,(math "\\triangleleft"))
+ ("rhd" ,(math "\\triangleright"))
+ ("parallel" ,(math "\\parallel"))))
+
+;;;; ======================================================================
+;;;; context-width
+;;;; ======================================================================
+(define (context-width width)
+ (cond
+ ((string? width)
+ width)
+ ((and (number? width) (inexact? width))
+ (string-append (number->string (/ width 100.)) "\\textwidth"))
+ (else
+ (string-append (number->string width) "pt"))))
+
+;;;; ======================================================================
+;;;; context-dim
+;;;; ======================================================================
+(define (context-dim dimension)
+ (cond
+ ((string? dimension)
+ dimension)
+ ((number? dimension)
+ (string-append (number->string (inexact->exact (round dimension)))
+ "pt"))))
+
+;;;; ======================================================================
+;;;; context-url
+;;;; ======================================================================
+(define(context-url url text e)
+ (let ((name (gensym 'url))
+ (text (or text url)))
+ (printf "\\useURL[~A][~A][][" name url)
+ (output text e)
+ (printf "]\\from[~A]" name)))
+
+;;;; ======================================================================
+;;;; Color Management ...
+;;;; ======================================================================
+(define *skribe-context-color-table* (make-hashtable))
+
+(define (skribe-color->context-color spec)
+ (receive (r g b)
+ (skribe-color->rgb spec)
+ (let ((ff (exact->inexact #xff)))
+ (format "r=~a,g=~a,b=~a"
+ (number->string (/ r ff))
+ (number->string (/ g ff))
+ (number->string (/ b ff))))))
+
+
+(define (skribe-declare-used-colors)
+ (printf "\n%%Colors\n")
+ (for-each (lambda (spec)
+ (let ((c (hashtable-get *skribe-context-color-table* spec)))
+ (unless (string? c)
+ ;; Color was never used before
+ (let ((name (symbol->string (gensym 'col))))
+ (hashtable-put! *skribe-context-color-table* spec name)
+ (printf "\\definecolor[~A][~A]\n"
+ name
+ (skribe-color->context-color spec))))))
+ (skribe-get-used-colors))
+ (newline))
+
+(define (skribe-declare-standard-colors engine)
+ (for-each (lambda (x)
+ (skribe-use-color! (engine-custom engine x)))
+ '(source-comment-color source-define-color source-module-color
+ source-markup-color source-thread-color source-string-color
+ source-bracket-color source-type-color)))
+
+(define (skribe-get-color spec)
+ (let ((c (and (hashtable? *skribe-context-color-table*)
+ (hashtable-get *skribe-context-color-table* spec))))
+ (if (not (string? c))
+ (skribe-error 'context "Can't find color" spec)
+ c)))
+
+;;;; ======================================================================
+;;;; context-engine ...
+;;;; ======================================================================
+(define context-engine
+ (default-engine-set!
+ (make-engine 'context
+ :version 1.0
+ :format "context"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace context-encoding)
+ :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m)))
+ :custom context-customs)))
+
+;;;; ======================================================================
+;;;; document ...
+;;;; ======================================================================
+(markup-writer 'document
+ :options '(:title :subtitle :author :ending :env)
+ :before (lambda (n e)
+ ;; Prelude
+ (printf "% interface=en output=pdftex\n")
+ (display "%%%% -*- TeX -*-\n")
+ (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n"
+ (skribe-release) (date))
+ ;; Make URLs active
+ (printf "\\setupinteraction[state=start]\n")
+ ;; Choose the document font
+ (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type)
+ (engine-custom e 'font-size))
+ ;; Color
+ (display "\\setupcolors[state=start]\n")
+ ;; Load Style
+ (printf "\\input skribe-context-~a.tex\n"
+ (engine-custom e 'document-style))
+ ;; Insert User customization
+ (let ((s (engine-custom e 'user-style)))
+ (when s (printf "\\input ~a\n" s)))
+ ;; Output used colors
+ (skribe-declare-standard-colors e)
+ (skribe-declare-used-colors)
+
+ (display "\\starttext\n\\StartTitlePage\n")
+ ;; title
+ (let ((t (markup-option n :title)))
+ (when t
+ (skribe-eval (new markup
+ (markup '&context-title)
+ (body t)
+ (options
+ `((subtitle ,(markup-option n :subtitle)))))
+ e
+ :env `((parent ,n)))))
+ ;; author(s)
+ (let ((a (markup-option n :author)))
+ (when a
+ (if (list? a)
+ ;; List of authors. Use multi-columns
+ (begin
+ (printf "\\defineparagraphs[Authors][n=~A]\n" (length a))
+ (display "\\startAuthors\n")
+ (let Loop ((l a))
+ (unless (null? l)
+ (output (car l) e)
+ (unless (null? (cdr l))
+ (display "\\nextAuthors\n")
+ (Loop (cdr l)))))
+ (display "\\stopAuthors\n\n"))
+ ;; One author, that's easy
+ (output a e))))
+ ;; End of the title
+ (display "\\StopTitlePage\n"))
+ :after (lambda (n e)
+ (display "\n\\stoptext\n")))
+
+
+
+;;;; ======================================================================
+;;;; &context-title ...
+;;;; ======================================================================
+(markup-writer '&context-title
+ :before "{\\DocumentTitle{"
+ :action (lambda (n e)
+ (output (markup-body n) e)
+ (let ((sub (markup-option n 'subtitle)))
+ (when sub
+ (display "\\\\\n\\switchtobodyfont[16pt]\\it{")
+ (output sub e)
+ (display "}\n"))))
+ :after "}}")
+
+;;;; ======================================================================
+;;;; author ...
+;;;; ======================================================================
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (out (lambda (n)
+ (output n e)
+ (display "\\\\\n"))))
+ (display "{\\midaligned{")
+ (when name (out name))
+ (when title (out title))
+ (when affiliation (out affiliation))
+ (when (pair? address) (for-each out address))
+ (when phone (out phone))
+ (when email (out email))
+ (when url (out url))
+ (display "}}\n"))))
+
+
+;;;; ======================================================================
+;;;; toc ...
+;;;; ======================================================================
+(markup-writer 'toc
+ :options '()
+ :action (lambda (n e) (display "\\placecontent\n")))
+
+;;;; ======================================================================
+;;;; context-block-before ...
+;;;; ======================================================================
+(define (context-block-before name name-unnum)
+ (lambda (n e)
+ (let ((num (markup-option n :number)))
+ (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n)))
+ (printf "\\~a[~a]{" (if num name name-unnum)
+ (string-canonicalize (markup-ident n)))
+ (output (markup-option n :title) e)
+ (display "}\n"))))
+
+
+;;;; ======================================================================
+;;;; chapter, section, ...
+;;;; ======================================================================
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'chapter 'title))
+
+
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'section 'subject))
+
+
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'subsection 'subsubject))
+
+
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'subsubsection 'subsubsubject))
+
+;;;; ======================================================================
+;;;; paragraph ...
+;;;; ======================================================================
+(markup-writer 'paragraph
+ :options '(:title :number :toc :env)
+ :after "\\par\n")
+
+;;;; ======================================================================
+;;;; footnote ...
+;;;; ======================================================================
+(markup-writer 'footnote
+ :before "\\footnote{"
+ :after "}")
+
+;;;; ======================================================================
+;;;; linebreak ...
+;;;; ======================================================================
+(markup-writer 'linebreak
+ :action "\\crlf ")
+
+;;;; ======================================================================
+;;;; hrule ...
+;;;; ======================================================================
+(markup-writer 'hrule
+ :options '(:width :height)
+ :before (lambda (n e)
+ (printf "\\blackrule[width=~A,height=~A]\n"
+ (context-width (markup-option n :width))
+ (context-dim (markup-option n :height)))))
+
+;;;; ======================================================================
+;;;; color ...
+;;;; ======================================================================
+(markup-writer 'color
+ :options '(:bg :fg :width :margin :border)
+ :before (lambda (n e)
+ (let ((bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (w (markup-option n :width))
+ (m (markup-option n :margin))
+ (b (markup-option n :border))
+ (c (markup-option n :round-corner)))
+ (if (or bg w m b)
+ (begin
+ (printf "\\startframedtext[width=~a" (if w
+ (context-width w)
+ "fit"))
+ (printf ",rulethickness=~A" (if b (context-width b) "0pt"))
+ (when m
+ (printf ",offset=~A" (context-width m)))
+ (when bg
+ (printf ",background=color,backgroundcolor=~A"
+ (skribe-get-color bg)))
+ (when fg
+ (printf ",foregroundcolor=~A"
+ (skribe-get-color fg)))
+ (when c
+ (display ",framecorner=round"))
+ (printf "]\n"))
+ ;; Probably just a foreground was specified
+ (when fg
+ (printf "\\startcolor[~A] " (skribe-get-color fg))))))
+ :after (lambda (n e)
+ (let ((bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (w (markup-option n :width))
+ (m (markup-option n :margin))
+ (b (markup-option n :border)))
+ (if (or bg w m b)
+ (printf "\\stopframedtext ")
+ (when fg
+ (printf "\\stopcolor "))))))
+;;;; ======================================================================
+;;;; frame ...
+;;;; ======================================================================
+(markup-writer 'frame
+ :options '(:width :border :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (b (markup-option n :border))
+ (c (markup-option n :round-corner)))
+ (printf "\\startframedtext[width=~a" (if w
+ (context-width w)
+ "fit"))
+ (printf ",rulethickness=~A" (context-dim b))
+ (printf ",offset=~A" (context-width m))
+ (when c
+ (display ",framecorner=round"))
+ (printf "]\n")))
+ :after "\\stopframedtext ")
+
+;;;; ======================================================================
+;;;; font ...
+;;;; ======================================================================
+(markup-writer 'font
+ :options '(:size)
+ :action (lambda (n e)
+ (let* ((size (markup-option n :size))
+ (cs (engine-custom e 'font-size))
+ (ns (cond
+ ((and (integer? size) (exact? size))
+ (if (> size 0)
+ size
+ (+ cs size)))
+ ((and (number? size) (inexact? size))
+ (+ cs (inexact->exact size)))
+ ((string? size)
+ (let ((nb (string->number size)))
+ (if (not (number? nb))
+ (skribe-error
+ 'font
+ (format "Illegal font size ~s" size)
+ nb)
+ (+ cs nb))))))
+ (ne (make-engine (gensym 'context)
+ :delegate e
+ :filter (engine-filter e)
+ :symbol-table (engine-symbol-table e)
+ :custom `((font-size ,ns)
+ ,@(engine-customs e)))))
+ (printf "{\\switchtobodyfont[~apt]" ns)
+ (output (markup-body n) ne)
+ (display "}"))))
+
+
+;;;; ======================================================================
+;;;; flush ...
+;;;; ======================================================================
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\n\n\\midaligned{"))
+ ((left)
+ (display "\n\n\\leftaligned{"))
+ ((right)
+ (display "\n\n\\rightaligned{"))))
+ :after "}\n")
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before "\n\n\\midaligned{"
+ :after "}\n")
+
+;;;; ======================================================================
+;;;; pre ...
+;;;; ======================================================================
+(markup-writer 'pre
+ :before "{\\tt\n\\startlines\n\\fixedspaces\n"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'context)
+ :delegate e
+ :filter (make-string-replace context-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after "\n\\stoplines\n}")
+
+;;;; ======================================================================
+;;;; prog ...
+;;;; ======================================================================
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before "{\\tt\n\\startlines\n\\fixedspaces\n"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'context)
+ :delegate e
+ :filter (make-string-replace context-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after "\n\\stoplines\n}")
+
+
+;;;; ======================================================================
+;;;; itemize, enumerate ...
+;;;; ======================================================================
+(define (context-itemization-action n e descr?)
+ (let ((symbol (markup-option n :symbol)))
+ (for-each (lambda (item)
+ (if symbol
+ (begin
+ (display "\\sym{")
+ (output symbol e)
+ (display "}"))
+ ;; output a \item iff not a description
+ (unless descr?
+ (display " \\item ")))
+ (output item e)
+ (newline))
+ (markup-body n))))
+
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[serried]\n"
+ :action (lambda (n e) (context-itemization-action n e #f))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[n][standard]\n"
+ :action (lambda (n e) (context-itemization-action n e #f))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+;;;; ======================================================================
+;;;; description ...
+;;;; ======================================================================
+(markup-writer 'description
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[serried]\n"
+ :action (lambda (n e) (context-itemization-action n e #t))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+;;;; ======================================================================
+;;;; item ...
+;;;; ======================================================================
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (when k
+ ;; Output the key(s)
+ (let Loop ((l (if (pair? k) k (list k))))
+ (unless (null? l)
+ (output (bold (car l)) e)
+ (unless (null? (cdr l))
+ (display "\\crlf\n"))
+ (Loop (cdr l))))
+ (display "\\nowhitespace\\startnarrower[left]\n"))
+ ;; Output body
+ (output (markup-body n) e)
+ ;; Terminate
+ (when k
+ (display "\n\\stopnarrower\n")))))
+
+;;;; ======================================================================
+;;;; blockquote ...
+;;;; ======================================================================
+(markup-writer 'blockquote
+ :before "\n\\startnarrower[left,right]\n"
+ :after "\n\\stopnarrower\n")
+
+
+;;;; ======================================================================
+;;;; figure ...
+;;;; ======================================================================
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (unless number
+ (display "{\\setupcaptions[number=off]\n"))
+ (display "\\placefigure\n")
+ (printf " [~a]\n" (string-canonicalize ident))
+ (display " {") (output legend e) (display "}\n")
+ (display " {") (output (markup-body n) e) (display "}")
+ (unless number
+ (display "}\n")))))
+
+;;;; ======================================================================
+;;;; table ...
+;;;; ======================================================================
+ ;; width doesn't work
+(markup-writer 'table
+ :options '(:width :border :frame :rules :cellpadding)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (cp (markup-option n :cellpadding))
+ (cs (markup-option n :cellspacing)))
+ (printf "\n{\\bTABLE\n")
+ (printf "\\setupTABLE[")
+ (printf "width=~A" (if width (context-width width) "fit"))
+ (when border
+ (printf ",rulethickness=~A" (context-dim border)))
+ (when cp
+ (printf ",offset=~A" (context-width cp)))
+ (printf ",frame=off]\n")
+
+ (when rules
+ (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n")
+ (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n"))
+ (case rules
+ ((rows) (display hor))
+ ((cols) (display vert))
+ ((all) (display hor) (display vert)))))
+
+ (when frame
+ ;; hsides, vsides, lhs, rhs, box, border
+ (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n")
+ (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n")
+ (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n")
+ (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n"))
+ (case frame
+ ((above) (display top))
+ ((below) (display bot))
+ ((hsides) (display top) (display bot))
+ ((lhs) (display left))
+ ((rhs) (display right))
+ ((vsides) (display left) (diplay right))
+ ((box border) (display top) (display bot)
+ (display left) (display right)))))))
+
+ :after (lambda (n e)
+ (printf "\\eTABLE}\n")))
+
+
+;;;; ======================================================================
+;;;; tr ...
+;;;; ======================================================================
+(markup-writer 'tr
+ :options '(:bg)
+ :before (lambda (n e)
+ (display "\\bTR")
+ (let ((bg (markup-option n :bg)))
+ (when bg
+ (printf "[background=color,backgroundcolor=~A]"
+ (skribe-get-color bg)))))
+ :after "\\eTR\n")
+
+
+;;;; ======================================================================
+;;;; tc ...
+;;;; ======================================================================
+(markup-writer 'tc
+ :options '(:width :align :valign :colspan)
+ :before (lambda (n e)
+ (let ((th? (eq? 'th (markup-option n 'markup)))
+ (width (markup-option n :width))
+ (align (markup-option n :align))
+ (valign (markup-option n :valign))
+ (colspan (markup-option n :colspan))
+ (rowspan (markup-option n :rowspan))
+ (bg (markup-option n :bg)))
+ (printf "\\bTD[")
+ (printf "width=~a" (if width (context-width width) "fit"))
+ (when valign
+ ;; This is buggy. In fact valign an align can't be both
+ ;; specified in ConTeXt
+ (printf ",align=~a" (case valign
+ ((center) 'lohi)
+ ((bottom) 'low)
+ ((top) 'high))))
+ (when align
+ (printf ",align=~a" (case align
+ ((left) 'right) ; !!!!
+ ((right) 'left) ; !!!!
+ (else 'middle))))
+ (unless (equal? colspan 1)
+ (printf ",nx=~a" colspan))
+ (display "]")
+ (when th?
+ ;; This is a TH, output is bolded
+ (display "{\\bf{"))))
+
+ :after (lambda (n e)
+ (when (equal? (markup-option n 'markup) 'th)
+ ;; This is a TH, output is bolded
+ (display "}}"))
+ (display "\\eTD")))
+
+;;;; ======================================================================
+;;;; image ...
+;;;; ======================================================================
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("jpg"))))))
+ (if (not (string? img))
+ (skribe-error 'context "Illegal image" file)
+ (begin
+ (printf "\\externalfigure[~A][frame=off" (strip-ref-base img))
+ (if zoom (printf ",factor=~a" (inexact->exact zoom)))
+ (if width (printf ",width=~a" (context-width width)))
+ (if height (printf ",height=~apt" (context-dim height)))
+ (display "]"))))))
+
+
+;;;; ======================================================================
+;;;; Ornaments ...
+;;;; ======================================================================
+(markup-writer 'roman :before "{\\rm{" :after "}}")
+(markup-writer 'bold :before "{\\bf{" :after "}}")
+(markup-writer 'underline :before "{\\underbar{" :after "}}")
+(markup-writer 'emph :before "{\\em{" :after "}}")
+(markup-writer 'it :before "{\\it{" :after "}}")
+(markup-writer 'code :before "{\\tt{" :after "}}")
+(markup-writer 'var :before "{\\tt{" :after "}}")
+(markup-writer 'sc :before "{\\sc{" :after "}}")
+;;//(markup-writer 'sf :before "{\\sf{" :after "}}")
+(markup-writer 'sub :before "{\\low{" :after "}}")
+(markup-writer 'sup :before "{\\high{" :after "}}")
+
+
+;;//
+;;//(markup-writer 'tt
+;;// :before "{\\texttt{"
+;;// :action (lambda (n e)
+;;// (let ((ne (make-engine
+;;// (gensym 'latex)
+;;// :delegate e
+;;// :filter (make-string-replace latex-tt-encoding)
+;;// :custom (engine-customs e)
+;;// :symbol-table (engine-symbol-table e))))
+;;// (output (markup-body n) ne)))
+;;// :after "}}")
+
+;;;; ======================================================================
+;;;; q ...
+;;;; ======================================================================
+(markup-writer 'q
+ :before "\\quotation{"
+ :after "}")
+
+;;;; ======================================================================
+;;;; mailto ...
+;;;; ======================================================================
+(markup-writer 'mailto
+ :options '(:text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text))
+ (url (markup-body n)))
+ (when (pair? url)
+ (context-url (format "mailto:~A" (car url))
+ (or text
+ (car url))
+ e)))))
+;;;; ======================================================================
+;;;; mark ...
+;;;; ======================================================================
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "\\reference[~a]{}\n"
+ (string-canonicalize (markup-ident n)))))
+
+;;;; ======================================================================
+;;;; ref ...
+;;;; ======================================================================
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection
+ :figure :mark :handle :page)
+ :action (lambda (n e)
+ (let* ((text (markup-option n :text))
+ (page (markup-option n :page))
+ (c (handle-ast (markup-body n)))
+ (id (markup-ident c)))
+ (cond
+ (page ;; Output the page only (this is a hack)
+ (when text (output text e))
+ (printf "\\at[~a]"
+ (string-canonicalize id)))
+ ((or (markup-option n :chapter)
+ (markup-option n :section)
+ (markup-option n :subsection)
+ (markup-option n :subsubsection))
+ (if text
+ (printf "\\goto{~a}[~a]" (or text id)
+ (string-canonicalize id))
+ (printf "\\in[~a]" (string-canonicalize id))))
+ ((markup-option n :mark)
+ (printf "\\goto{~a}[~a]"
+ (or text id)
+ (string-canonicalize id)))
+ (else ;; Output a little image indicating the direction
+ (printf "\\in[~a]" (string-canonicalize id)))))))
+
+;;;; ======================================================================
+;;;; bib-ref ...
+;;;; ======================================================================
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e)
+ (let* ((obj (handle-ast (markup-body n)))
+ (title (markup-option obj :title))
+ (ref (markup-option title 'number))
+ (ident (markup-ident obj)))
+ (printf "\\goto{~a}[~a]" ref (string-canonicalize ident))))
+ :after (lambda (n e) (output "]" e)))
+
+;;;; ======================================================================
+;;;; bib-ref+ ...
+;;;; ======================================================================
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after (lambda (n e) (output "]" e)))
+
+;;;; ======================================================================
+;;;; url-ref ...
+;;;; ======================================================================
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (context-url (markup-option n :url) (markup-option n :text) e)))
+
+;;//;*---------------------------------------------------------------------*/
+;;//;* line-ref ... */
+;;//;*---------------------------------------------------------------------*/
+;;//(markup-writer 'line-ref
+;;// :options '(:offset)
+;;// :before "{\\textit{"
+;;// :action (lambda (n e)
+;;// (let ((o (markup-option n :offset))
+;;// (v (string->number (markup-option n :text))))
+;;// (cond
+;;// ((and (number? o) (number? v))
+;;// (display (+ o v)))
+;;// (else
+;;// (display v)))))
+;;// :after "}}")
+
+
+;;;; ======================================================================
+;;;; &the-bibliography ...
+;;;; ======================================================================
+(markup-writer '&the-bibliography
+ :before "\n% Bibliography\n\n")
+
+
+;;;; ======================================================================
+;;;; &bib-entry ...
+;;;; ======================================================================
+(markup-writer '&bib-entry
+ :options '(:title)
+ :action (lambda (n e)
+ (skribe-eval (mark (markup-ident n)) e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (output n e (markup-writer-get '&bib-entry-body e)))
+ :after "\n\n")
+
+;;;; ======================================================================
+;;;; &bib-entry-label ...
+;;;; ======================================================================
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after (lambda (n e) (output "] "e)))
+
+;;;; ======================================================================
+;;;; &bib-entry-title ...
+;;;; ======================================================================
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+
+;;//;*---------------------------------------------------------------------*/
+;;//;* &bib-entry-url ... */
+;;//;*---------------------------------------------------------------------*/
+;;//(markup-writer '&bib-entry-url
+;;// :action (lambda (n e)
+;;// (let* ((en (handle-ast (ast-parent n)))
+;;// (url (markup-option en 'url))
+;;// (t (bold (markup-body url))))
+;;// (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+
+;;;; ======================================================================
+;;;; &the-index ...
+;;;; ======================================================================
+(markup-writer '&the-index
+ :options '(:column)
+ :action
+ (lambda (n e)
+ (define (make-mark-entry n)
+ (display "\\blank[medium]\n{\\bf\\it\\tfc{")
+ (skribe-eval (bold n) e)
+ (display "}}\\crlf\n"))
+
+ (define (make-primary-entry n)
+ (let ((b (markup-body n)))
+ (markup-option-add! b :text (list (markup-option b :text) ", "))
+ (markup-option-add! b :page #t)
+ (output n e)))
+
+ (define (make-secondary-entry n)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (bb (markup-body b)))
+ (if note
+ (begin ;; This is another entry
+ (display "\\crlf\n ... ")
+ (markup-option-add! b :text (list note ", ")))
+ (begin ;; another line on an entry
+ (markup-option-add! b :text ", ")))
+ (markup-option-add! b :page #t)
+ (output n e)))
+
+ ;; Writer body starts here
+ (let ((col (markup-option n :column)))
+ (when col
+ (printf "\\startcolumns[n=~a]\n" col))
+ (for-each (lambda (item)
+ ;;(DEBUG "ITEM= ~S" item)
+ (if (pair? item)
+ (begin
+ (make-primary-entry (car item))
+ (for-each (lambda (x) (make-secondary-entry x))
+ (cdr item)))
+ (make-mark-entry item))
+ (display "\\crlf\n"))
+ (markup-body n))
+ (when col
+ (printf "\\stopcolumns\n")))))
+
+;;;; ======================================================================
+;;;; &source-comment ...
+;;;; ======================================================================
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-line-comment ...
+;;;; ======================================================================
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-keyword ...
+;;;; ======================================================================
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (it (markup-body n)) e)))
+
+;;;; ======================================================================
+;;;; &source-error ...
+;;;; ======================================================================
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'error-color) cc)
+ (color :fg cc (it n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-define ...
+;;;; ======================================================================
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-module ...
+;;;; ======================================================================
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-markup ...
+;;;; ======================================================================
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-thread ...
+;;;; ======================================================================
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-string ...
+;;;; ======================================================================
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-bracket ...
+;;;; ======================================================================
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-type ...
+;;;; ======================================================================
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-key ...
+;;;; ======================================================================
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-type ...
+;;;; ======================================================================
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+
+
+;;;; ======================================================================
+;;;; Context Only Markups
+;;;; ======================================================================
+
+;;;
+;;; Margin -- put text in the margin
+;;;
+(define-markup (margin #!rest opts #!key (ident #f) (class "margin")
+ (side 'right) text)
+ (new markup
+ (markup 'margin)
+ (ident (or ident (symbol->string (gensym 'ident))))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+(markup-writer 'margin
+ :options '(:text)
+ :before (lambda (n e)
+ (display
+ "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n")
+ (display "\\inright{")
+ (output (markup-option n :text) e)
+ (display "}{"))
+ :after "}")
+
+;;;
+;;; ConTeXt and TeX
+;;;
+(define-markup (ConTeXt #!key (space #t))
+ (if (engine-format? "context")
+ (! (if space "\\CONTEXT\\ " "\\CONTEXT"))
+ "ConTeXt"))
+
+(define-markup (TeX #!key (space #t))
+ (if (engine-format? "context")
+ (! (if space "\\TEX\\ " "\\TEX"))
+ "ConTeXt"))
+
+;;;; ======================================================================
+;;;; Restore the base engine
+;;;; ======================================================================
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
new file mode 100644
index 0000000..a20ea68
--- /dev/null
+++ b/src/guile/skribilo/engine/html.scm
@@ -0,0 +1,2282 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/html.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sat Jul 26 12:28:57 2003 */
+;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */
+;* Copyright : 2003-05 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* HTML Skribe engine */
+;* ------------------------------------------------------------- */
+;* Implementation: */
+;* common: @path ../src/common/api.src@ */
+;* bigloo: @path ../src/bigloo/api.bgl@ */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/htmle.skb:ref@ */
+;*=====================================================================*/
+
+(define-skribe-module (skribilo engine html))
+
+
+;; Keep a reference to the base engine.
+(define base-engine (find-engine 'base))
+
+;*---------------------------------------------------------------------*/
+;* html-file-default ... */
+;*---------------------------------------------------------------------*/
+(define html-file-default
+ ;; Default implementation of the `file-name-proc' custom.
+ (let ((table '())
+ (filename (tmpnam)))
+ (define (get-file-name base suf)
+ (let* ((c (assoc base table))
+ (n (if (pair? c)
+ (let ((n (+ 1 (cdr c))))
+ (set-cdr! c n)
+ n)
+ (begin
+ (set! table (cons (cons base 1) table))
+ 1))))
+ (format "~a-~a.~a" base n suf)))
+ (lambda (node e)
+ (let ((f (markup-option node filename))
+ (file (markup-option node :file)))
+ (cond
+ ((string? f)
+ f)
+ ((string? file)
+ file)
+ ((or file
+ (and (is-markup? node 'chapter)
+ (engine-custom e 'chapter-file))
+ (and (is-markup? node 'section)
+ (engine-custom e 'section-file))
+ (and (is-markup? node 'subsection)
+ (engine-custom e 'subsection-file))
+ (and (is-markup? node 'subsubsection)
+ (engine-custom e 'subsubsection-file)))
+ (let* ((b (or (and (string? *skribe-dest*)
+ (prefix *skribe-dest*))
+ ""))
+ (s (or (and (string? *skribe-dest*)
+ (suffix *skribe-dest*))
+ "html"))
+ (nm (get-file-name b s)))
+ (markup-option-add! node filename nm)
+ nm))
+ ((document? node)
+ *skribe-dest*)
+ (else
+ (let ((p (ast-parent node)))
+ (if (container? p)
+ (let ((file (html-file p e)))
+ (if (string? file)
+ (begin
+ (markup-option-add! node filename file)
+ file)
+ #f))
+ #f))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-engine ... */
+;*---------------------------------------------------------------------*/
+(define html-engine
+ ;; setup the html engine
+ (default-engine-set!
+ (make-engine 'html
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "<")
+ (#\> ">")
+ (#\& "&")
+ (#\" """)
+ (#\@ "@")))
+ :custom `(;; the icon associated with the URL
+ (favicon #f)
+ ;; charset used
+ (charset "ISO-8859-1")
+ ;; enable/disable Javascript
+ (javascript #f)
+ ;; user html head
+ (head #f)
+ ;; user CSS
+ (css ())
+ ;; user inlined CSS
+ (inline-css ())
+ ;; user JS
+ (js ())
+ ;; emit-sui
+ (emit-sui #f)
+ ;; the body
+ (background "#ffffff")
+ (foreground #f)
+ ;; the margins
+ (margin-padding 3)
+ (left-margin #f)
+ (chapter-left-margin #f)
+ (section-left-margin #f)
+ (left-margin-font #f)
+ (left-margin-size 17.)
+ (left-margin-background "#dedeff")
+ (left-margin-foreground #f)
+ (right-margin #f)
+ (chapter-right-margin #f)
+ (section-right-margin #f)
+ (right-margin-font #f)
+ (right-margin-size 17.)
+ (right-margin-background "#dedeff")
+ (right-margin-foreground #f)
+ ;; author configuration
+ (author-font #f)
+ ;; title configuration
+ (title-font #f)
+ (title-background "#8381de")
+ (title-foreground #f)
+ (file-title-separator " -- ")
+ ;; html file naming
+ (file-name-proc ,html-file-default)
+ ;; index configuration
+ (index-header-font-size +2.)
+ ;; chapter configuration
+ (chapter-number->string number->string)
+ (chapter-file #f)
+ ;; section configuration
+ (section-title-start "<h3>")
+ (section-title-stop "</h3>")
+ (section-title-background "#dedeff")
+ (section-title-foreground "black")
+ (section-title-number-separator " ")
+ (section-number->string number->string)
+ (section-file #f)
+ ;; subsection configuration
+ (subsection-title-start "<h3>")
+ (subsection-title-stop "</h3>")
+ (subsection-title-background "#ffffff")
+ (subsection-title-foreground "#8381de")
+ (subsection-title-number-separator " ")
+ (subsection-number->string number->string)
+ (subsection-file #f)
+ ;; subsubsection configuration
+ (subsubsection-title-start "<h4>")
+ (subsubsection-title-stop "</h4>")
+ (subsubsection-title-background #f)
+ (subsubsection-title-foreground "#8381de")
+ (subsubsection-title-number-separator " ")
+ (subsubsection-number->string number->string)
+ (subsubsection-file #f)
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ ;; image
+ (image-format ("png" "gif" "jpg" "jpeg")))
+ :symbol-table '(("iexcl" "¡")
+ ("cent" "¢")
+ ("pound" "£")
+ ("currency" "¤")
+ ("yen" "¥")
+ ("section" "§")
+ ("mul" "¨")
+ ("copyright" "©")
+ ("female" "ª")
+ ("lguillemet" "«")
+ ("not" "¬")
+ ("registered" "®")
+ ("degree" "°")
+ ("plusminus" "±")
+ ("micro" "µ")
+ ("paragraph" "¶")
+ ("middot" "·")
+ ("male" "¸")
+ ("rguillemet" "»")
+ ("1/4" "¼")
+ ("1/2" "½")
+ ("3/4" "¾")
+ ("iquestion" "¿")
+ ("Agrave" "À")
+ ("Aacute" "Á")
+ ("Acircumflex" "Â")
+ ("Atilde" "Ã")
+ ("Amul" "Ä")
+ ("Aring" "Å")
+ ("AEligature" "Æ")
+ ("Oeligature" "Œ")
+ ("Ccedilla" "Ç")
+ ("Egrave" "È")
+ ("Eacute" "É")
+ ("Ecircumflex" "Ê")
+ ("Euml" "Ë")
+ ("Igrave" "Ì")
+ ("Iacute" "Í")
+ ("Icircumflex" "Î")
+ ("Iuml" "Ï")
+ ("ETH" "Ð")
+ ("Ntilde" "Ñ")
+ ("Ograve" "Ò")
+ ("Oacute" "Ó")
+ ("Ocurcumflex" "Ô")
+ ("Otilde" "Õ")
+ ("Ouml" "Ö")
+ ("times" "×")
+ ("Oslash" "Ø")
+ ("Ugrave" "Ù")
+ ("Uacute" "Ú")
+ ("Ucircumflex" "Û")
+ ("Uuml" "Ü")
+ ("Yacute" "Ý")
+ ("THORN" "Þ")
+ ("szlig" "ß")
+ ("agrave" "à")
+ ("aacute" "á")
+ ("acircumflex" "â")
+ ("atilde" "ã")
+ ("amul" "ä")
+ ("aring" "å")
+ ("aeligature" "æ")
+ ("oeligature" "œ")
+ ("ccedilla" "ç")
+ ("egrave" "è")
+ ("eacute" "é")
+ ("ecircumflex" "ê")
+ ("euml" "ë")
+ ("igrave" "ì")
+ ("iacute" "í")
+ ("icircumflex" "î")
+ ("iuml" "ï")
+ ("eth" "ð")
+ ("ntilde" "ñ")
+ ("ograve" "ò")
+ ("oacute" "ó")
+ ("ocurcumflex" "ô")
+ ("otilde" "õ")
+ ("ouml" "ö")
+ ("divide" "÷")
+ ("oslash" "ø")
+ ("ugrave" "ù")
+ ("uacute" "ú")
+ ("ucircumflex" "û")
+ ("uuml" "ü")
+ ("yacute" "ý")
+ ("thorn" "þ")
+ ("ymul" "ÿ")
+ ;; Greek
+ ("Alpha" "Α")
+ ("Beta" "Β")
+ ("Gamma" "Γ")
+ ("Delta" "Δ")
+ ("Epsilon" "Ε")
+ ("Zeta" "Ζ")
+ ("Eta" "Η")
+ ("Theta" "Θ")
+ ("Iota" "Ι")
+ ("Kappa" "Κ")
+ ("Lambda" "Λ")
+ ("Mu" "Μ")
+ ("Nu" "Ν")
+ ("Xi" "Ξ")
+ ("Omicron" "Ο")
+ ("Pi" "Π")
+ ("Rho" "Ρ")
+ ("Sigma" "Σ")
+ ("Tau" "Τ")
+ ("Upsilon" "Υ")
+ ("Phi" "Φ")
+ ("Chi" "Χ")
+ ("Psi" "Ψ")
+ ("Omega" "Ω")
+ ("alpha" "α")
+ ("beta" "β")
+ ("gamma" "γ")
+ ("delta" "δ")
+ ("epsilon" "ε")
+ ("zeta" "ζ")
+ ("eta" "η")
+ ("theta" "θ")
+ ("iota" "ι")
+ ("kappa" "κ")
+ ("lambda" "λ")
+ ("mu" "μ")
+ ("nu" "ν")
+ ("xi" "ξ")
+ ("omicron" "ο")
+ ("pi" "π")
+ ("rho" "ρ")
+ ("sigmaf" "ς")
+ ("sigma" "σ")
+ ("tau" "τ")
+ ("upsilon" "υ")
+ ("phi" "φ")
+ ("chi" "χ")
+ ("psi" "ψ")
+ ("omega" "ω")
+ ("thetasym" "ϑ")
+ ("piv" "ϖ")
+ ;; punctuation
+ ("bullet" "•")
+ ("ellipsis" "…")
+ ("weierp" "℘")
+ ("image" "ℑ")
+ ("real" "ℜ")
+ ("tm" "™")
+ ("alef" "ℵ")
+ ("<-" "←")
+ ("<--" "←")
+ ("uparrow" "↑")
+ ("->" "→")
+ ("-->" "→")
+ ("downarrow" "↓")
+ ("<->" "↔")
+ ("<-->" "↔")
+ ("<+" "↵")
+ ("<=" "⇐")
+ ("<==" "⇐")
+ ("Uparrow" "⇑")
+ ("=>" "⇒")
+ ("==>" "⇒")
+ ("Downarrow" "⇓")
+ ("<=>" "⇔")
+ ("<==>" "⇔")
+ ;; Mathematical operators
+ ("forall" "∀")
+ ("partial" "∂")
+ ("exists" "∃")
+ ("emptyset" "∅")
+ ("infinity" "∞")
+ ("nabla" "∇")
+ ("in" "∈")
+ ("notin" "∉")
+ ("ni" "∋")
+ ("prod" "∏")
+ ("sum" "∑")
+ ("asterisk" "∗")
+ ("sqrt" "√")
+ ("propto" "∝")
+ ("angle" "∠")
+ ("and" "∧")
+ ("or" "∨")
+ ("cap" "∩")
+ ("cup" "∪")
+ ("integral" "∫")
+ ("therefore" "∴")
+ ("models" "|=")
+ ("vdash" "|-")
+ ("dashv" "-|")
+ ("sim" "∼")
+ ("cong" "≅")
+ ("approx" "≈")
+ ("neq" "≠")
+ ("equiv" "≡")
+ ("le" "≤")
+ ("ge" "≥")
+ ("subset" "⊂")
+ ("supset" "⊃")
+ ("nsupset" "⊃")
+ ("subseteq" "⊆")
+ ("supseteq" "⊇")
+ ("oplus" "⊕")
+ ("otimes" "⊗")
+ ("perp" "⊥")
+ ("mid" "|")
+ ("lceil" "⌈")
+ ("rceil" "⌉")
+ ("lfloor" "⌊")
+ ("rfloor" "⌋")
+ ("langle" "〈")
+ ("rangle" "〉")
+ ;; Misc
+ ("loz" "◊")
+ ("spades" "♠")
+ ("clubs" "♣")
+ ("hearts" "♥")
+ ("diams" "♦")
+ ("euro" "ℐ")
+ ;; LaTeX
+ ("dag" "dag")
+ ("ddag" "ddag")
+ ("circ" "o")
+ ("top" "T")
+ ("bottom" "⊥")
+ ("lhd" "<")
+ ("rhd" ">")
+ ("parallel" "||")))))
+
+;*---------------------------------------------------------------------*/
+;* html-file ... */
+;*---------------------------------------------------------------------*/
+(define (html-file n e)
+ (let ((proc (or (engine-custom e 'file-name-proc) html-file-default)))
+ (proc n e)))
+
+;*---------------------------------------------------------------------*/
+;* html-title-engine ... */
+;*---------------------------------------------------------------------*/
+(define html-title-engine
+ (copy-engine 'html-title base-engine
+ :filter (make-string-replace '((#\< "<")
+ (#\> ">")
+ (#\& "&")
+ (#\" """)))))
+
+;*---------------------------------------------------------------------*/
+;* html-browser-title ... */
+;*---------------------------------------------------------------------*/
+(define (html-browser-title n)
+ (and (markup? n)
+ (or (markup-option n :html-title)
+ (if (document? n)
+ (markup-option n :title)
+ (html-browser-title (ast-parent n))))))
+
+
+;*---------------------------------------------------------------------*/
+;* html-container-number ... */
+;* ------------------------------------------------------------- */
+;* Returns a string representing the container number */
+;*---------------------------------------------------------------------*/
+(define (html-container-number c e)
+ (define (html-number n proc)
+ (cond
+ ((string? n)
+ n)
+ ((number? n)
+ (if (procedure? proc)
+ (proc n)
+ (number->string n)))
+ (else
+ "")))
+ (define (html-chapter-number c)
+ (html-number (markup-option c :number)
+ (engine-custom e 'chapter-number->string)))
+ (define (html-section-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'section-number->string))))
+ (cond
+ ((is-markup? p 'chapter)
+ (string-append (html-chapter-number p) "." s))
+ (else
+ (string-append s)))))
+ (define (html-subsection-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'subsection-number->string))))
+ (cond
+ ((is-markup? p 'section)
+ (string-append (html-section-number p) "." s))
+ (else
+ (string-append "." s)))))
+ (define (html-subsubsection-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'subsubsection-number->string))))
+ (cond
+ ((is-markup? p 'subsection)
+ (string-append (html-subsection-number p) "." s))
+ (else
+ (string-append ".." s)))))
+ (define (inner-html-container-number c)
+ (html-number (markup-option c :number) #f))
+ (let ((n (markup-option c :number)))
+ (if (not n)
+ ""
+ (case (markup-markup c)
+ ((chapter)
+ (html-chapter-number c))
+ ((section)
+ (html-section-number c))
+ ((subsection)
+ (html-subsection-number c))
+ ((subsubsection)
+ (html-subsubsection-number c))
+ (else
+ (if (container? c)
+ (inner-html-container-number c)
+ (skribe-error 'html-container-number
+ "Not a container"
+ (markup-markup c))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-counter ... */
+;*---------------------------------------------------------------------*/
+(define (html-counter cnts)
+ (cond
+ ((not cnts)
+ "")
+ ((null? cnts)
+ "")
+ ((not (pair? cnts))
+ cnts)
+ ((null? (cdr cnts))
+ (format "~a." (car cnts)))
+ (else
+ (let loop ((cnts cnts))
+ (if (null? (cdr cnts))
+ (format "~a" (car cnts))
+ (format "~a.~a" (car cnts) (loop (cdr cnts))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-width ... */
+;*---------------------------------------------------------------------*/
+(define (html-width width)
+ (cond
+ ((and (integer? width) (exact? width))
+ (format "~A" width))
+ ((real? width)
+ (format "~A%" (inexact->exact (round width))))
+ ((string? width)
+ width)
+ (else
+ (skribe-error 'html-width "bad width" width))))
+
+;*---------------------------------------------------------------------*/
+;* html-class ... */
+;*---------------------------------------------------------------------*/
+(define (html-class m)
+ (if (markup? m)
+ (let ((c (markup-class m)))
+ (if (or (string? c) (symbol? c) (number? c))
+ (printf " class=\"~a\"" c)))))
+
+;*---------------------------------------------------------------------*/
+;* html-markup-class ... */
+;*---------------------------------------------------------------------*/
+(define (html-markup-class m)
+ (lambda (n e)
+ (printf "<~a" m)
+ (html-class n)
+ (display ">")))
+
+;*---------------------------------------------------------------------*/
+;* html-color-spec? ... */
+;*---------------------------------------------------------------------*/
+(define (html-color-spec? v)
+ (and v
+ (not (unspecified? v))
+ (or (not (string? v)) (> (string-length v) 0))))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :html-title :env)
+ :action (lambda (n e)
+ (let* ((id (markup-ident n))
+ (title (new markup
+ (markup '&html-document-title)
+ (parent n)
+ (ident (string-append id "-title"))
+ (class (markup-class n))
+ (options `((author ,(markup-option n :author))))
+ (body (markup-option n :title)))))
+ (&html-generic-document n title e)))
+ :after (lambda (n e)
+ (if (engine-custom e 'emit-sui)
+ (document-sui n e))))
+
+;*---------------------------------------------------------------------*/
+;* &html-html ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-html
+ :before "<!-- 95% W3C COMPLIANT, 95% CSS FREE, RAW HTML -->
+<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+<html>\n"
+ :after "</html>")
+
+;*---------------------------------------------------------------------*/
+;* &html-head ... */
+;*---------------------------------------------------------------------*/
+(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)
+ 'charset)))
+ :after "</head>\n\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-body ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-body
+ :before (lambda (n e)
+ (let ((bg (engine-custom e 'background)))
+ (display "<body")
+ (html-class n)
+ (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg))
+ (display ">\n")))
+ :after "</body>\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-page ... */
+;*---------------------------------------------------------------------*/
+(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)
+ (if size
+ (printf " width=\"~a\"" (html-width size)))
+ (if (html-color-spec? bg)
+ (printf " bgcolor=\"~a\">" bg)
+ (display ">"))
+ (printf "<div class=\"~a\">\n" cla)
+ (cond
+ ((and (string? fg) (string? fn))
+ (printf "<font color=\"~a\" \"~a\">" fg fn))
+ ((string? fg)
+ (printf "<font color=\"~a\">" fg))
+ ((string? fn)
+ (printf "<font \"~a\">" fn)))
+ (if (procedure? m)
+ (skribe-eval (m n e) e)
+ (output m e))
+ (if (or (string? fg) (string? fn))
+ (display "</font>"))
+ (display "</div></td>\n"))
+ (let ((body (markup-body n))
+ (lm (engine-custom e 'left-margin))
+ (lmfn (engine-custom e 'left-margin-font))
+ (lms (engine-custom e 'left-margin-size))
+ (lmbg (engine-custom e 'left-margin-background))
+ (lmfg (engine-custom e 'left-margin-foreground))
+ (rm (engine-custom e 'right-margin))
+ (rmfn (engine-custom e 'right-margin-font))
+ (rms (engine-custom e 'right-margin-size))
+ (rmbg (engine-custom e 'right-margin-background))
+ (rmfg (engine-custom e 'right-margin-foreground)))
+ (cond
+ ((and lm rm)
+ (let* ((ep (engine-custom e 'margin-padding))
+ (ac (if (number? ep) ep 0)))
+ (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac))
+ (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin")
+ (html-margin body #f #f #f #f "skribe-body")
+ (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin")
+ (display "</tr></table>"))
+ (lm
+ (let* ((ep (engine-custom e 'margin-padding))
+ (ac (if (number? ep) ep 0)))
+ (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac))
+ (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin")
+ (html-margin body #f #f #f #f "skribe-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=\"skribe-margins\"><tr>\n"))
+ (html-margin body #f #f #f #f "skribe-body")
+ (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin")
+ (display "</tr></table>"))
+ (else
+ (display "<div class=\"skribe-body\">\n")
+ (output body e)
+ (display "</div>\n"))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-header ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-header n e)
+ (let* ((ic (engine-custom e 'favicon))
+ (id (markup-ident n)))
+ (unless (string? id)
+ (skribe-error '&html-generic-header
+ (format "Illegal identifier `~a'" id)
+ n))
+ ;; title
+ (output (new markup
+ (markup '&html-header-title)
+ (parent n)
+ (ident (string-append id "-title"))
+ (class (markup-class n))
+ (body (markup-body n)))
+ e)
+ ;; favicon
+ (output (new markup
+ (markup '&html-header-favicon)
+ (parent n)
+ (ident (string-append id "-favicon"))
+ (body (cond
+ ((string? ic)
+ ic)
+ ((procedure? ic)
+ (ic d e)))))
+ e)
+ ;; style
+ (output (new markup
+ (markup '&html-header-style)
+ (parent n)
+ (ident (string-append id "-style"))
+ (class (markup-class n)))
+ e)
+ ;; css
+ (output (new markup
+ (markup '&html-header-css)
+ (parent n)
+ (ident (string-append id "-css"))
+ (body (let ((c (engine-custom e 'css)))
+ (if (string? c)
+ (list c)
+ c))))
+ e)
+ ;; javascript
+ (output (new markup
+ (markup '&html-header-javascript)
+ (parent n)
+ (ident (string-append id "-javascript")))
+ e)))
+
+(markup-writer '&html-header-title
+ :before "<title>"
+ :action (lambda (n e)
+ (output (markup-body n) html-title-engine))
+ :after "</title>\n")
+
+(markup-writer '&html-header-favicon
+ :action (lambda (n e)
+ (let ((i (markup-body n)))
+ (when i
+ (printf " <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))
+ css)))))
+
+(markup-writer '&html-header-style
+ :before " <style type=\"text/css\">\n <!--\n"
+ :action (lambda (n e)
+ (let ((hd (engine-custom e 'head))
+ (icss (let ((ic (engine-custom e 'inline-css)))
+ (if (string? ic)
+ (list ic)
+ ic))))
+ (display " pre { font-family: monospace }\n")
+ (display " tt { font-family: monospace }\n")
+ (display " code { font-family: monospace }\n")
+ (display " p.flushright { text-align: right }\n")
+ (display " p.flushleft { text-align: left }\n")
+ (display " span.sc { font-variant: small-caps }\n")
+ (display " span.sf { font-family: sans-serif }\n")
+ (display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n")
+ (when hd (display (format " ~a\n" hd)))
+ (when (pair? icss)
+ (for-each (lambda (css)
+ (let ((p (open-input-file css)))
+ (if (not (input-port? p))
+ (skribe-error
+ 'html-css
+ "Can't open CSS file for input"
+ css)
+ (begin
+ (let loop ((l (read-line p)))
+ (unless (eof-object? l)
+ (display l)
+ (newline)
+ (loop (read-line p))))
+ (close-input-port p)))))
+ icss))))
+ :after " -->\n </style>\n")
+
+(markup-writer '&html-header-javascript
+ :action (lambda (n e)
+ (when (engine-custom e 'javascript)
+ (display " <script language=\"JavaScript\" type=\"text/javascript\">\n")
+ (display " <!--\n")
+ (display " function skribenospam( n, d, f ) {\n")
+ (display " nn=n.replace( / /g , \".\" );\n" )
+ (display " dd=d.replace( / /g , \".\" );\n" )
+ (display " document.write( \"<a href=\\\"mailto:\" + nn + \"@\" + dd + \"\\\">\" );\n")
+ (display " if( f ) {\n")
+ (display " document.write( \"<tt>\" + nn + \"@\" + dd + \"</\" + \"tt><\" + \"/a>\" );\n")
+ (display " }\n")
+ (display " }\n")
+ (display " -->\n")
+ (display " </script>\n"))
+ (let* ((ejs (engine-custom e 'js))
+ (js (cond
+ ((string? ejs)
+ (list ejs))
+ ((list? ejs)
+ ejs)
+ (else
+ '()))))
+ (for-each (lambda (s)
+ (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s))
+ js))))
+
+
+;*---------------------------------------------------------------------*/
+;* &html-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-document-header :action &html-generic-header)
+(markup-writer '&html-chapter-header :action &html-generic-header)
+(markup-writer '&html-section-header :action &html-generic-header)
+(markup-writer '&html-subsection-header :action &html-generic-header)
+(markup-writer '&html-subsubsection-header :action &html-generic-header)
+
+;*---------------------------------------------------------------------*/
+;* &html-ending ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-ending
+ :before "<div class=\"skribe-ending\">"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if body
+ (output body #t)
+ (skribe-eval
+ (list (hrule)
+ (p :class "ending"
+ (font :size -1
+ (list "This HTML page was "
+ "produced by "
+ (ref :text "Skribilo"
+ :url (skribilo-url))
+ "."
+ (linebreak)
+ "Last update: " (date)))))
+ e))))
+ :after "</div>\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-title ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-title n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (tbg (engine-custom e 'title-background))
+ (tfg (engine-custom e 'title-foreground))
+ (tfont (engine-custom e 'title-font)))
+ (when title
+ (display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>")
+ (if (html-color-spec? tbg)
+ (printf "<td align=\"center\" bgcolor=\"~a\">" tbg)
+ (display "<td align=\"center\">"))
+ (if (string? tfg)
+ (printf "<font color=\"~a\">" tfg))
+ (when title
+ (if (string? tfont)
+ (begin
+ (printf "<font ~a><strong>" tfont)
+ (output title e)
+ (display "</strong></font>"))
+ (begin
+ (printf "<div class=\"skribetitle\"><strong><big><big><big>")
+ (output title e)
+ (display "</big></big></big></strong></div>"))))
+ (if (not authors)
+ (display "\n")
+ (html-title-authors authors e))
+ (if (string? tfg)
+ (display "</font>"))
+ (display "</td></tr></tbody></table>\n"))))
+
+;*---------------------------------------------------------------------*/
+;* &html-document-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-document-title :action &html-generic-title)
+(markup-writer '&html-chapter-title :action &html-generic-title)
+(markup-writer '&html-section-title :action &html-generic-title)
+(markup-writer '&html-subsection-title :action &html-generic-title)
+(markup-writer '&html-subsubsection-title :action &html-generic-title)
+
+;*---------------------------------------------------------------------*/
+;* &html-footnotes */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-footnotes
+ :before (lambda (n e)
+ (let ((footnotes (markup-body n)))
+ (when (pair? footnotes)
+ (display "<div class=\"footnote\">")
+ (display "<br><br>\n")
+ (display "<hr width='20%' size='2' align='left'>\n"))))
+ :action (lambda (n e)
+ (let ((footnotes (markup-body n)))
+ (when (pair? footnotes)
+ (let loop ((fns footnotes))
+ (if (pair? fns)
+ (let ((fn (car fns)))
+ (printf "<a name=\"footnote-~a\">"
+ (string-canonicalize
+ (container-ident fn)))
+ (printf "<sup><small>~a</small></sup></a>: "
+ (markup-option fn :number))
+ (output (markup-body fn) e)
+ (display "\n<br>\n")
+ (loop (cdr fns)))))
+ (display "<div>")))))
+
+;*---------------------------------------------------------------------*/
+;* html-title-authors ... */
+;*---------------------------------------------------------------------*/
+(define (html-title-authors authors e)
+ (define (html-authorsN authors cols first)
+ (define (make-row authors . opt)
+ (tr (map (lambda (v)
+ (apply td :align 'center :valign 'top v opt))
+ authors)))
+ (define (make-rows authors)
+ (let loop ((authors authors)
+ (rows '())
+ (row '())
+ (cnum 0))
+ (cond
+ ((null? authors)
+ (reverse! (cons (make-row (reverse! row)) rows)))
+ ((= cnum cols)
+ (loop authors
+ (cons (make-row (reverse! row)) rows)
+ '()
+ 0))
+ (else
+ (loop (cdr authors)
+ rows
+ (cons (car authors) row)
+ (+ cnum 1))))))
+ (output (table :cellpadding 10
+ (if first
+ (cons (make-row (list (car authors)) :colspan cols)
+ (make-rows (cdr authors)))
+ (make-rows authors)))
+ e))
+ (cond
+ ((pair? authors)
+ (display "<center>\n")
+ (let ((len (length authors)))
+ (case len
+ ((1)
+ (output (car authors) e))
+ ((2 3)
+ (html-authorsN authors len #f))
+ ((4)
+ (html-authorsN authors 2 #f))
+ (else
+ (html-authorsN authors 3 #t))))
+ (display "</center>\n"))
+ (else
+ (html-title-authors (list authors) e))))
+
+;*---------------------------------------------------------------------*/
+;* document-sui ... */
+;*---------------------------------------------------------------------*/
+(define (document-sui n e)
+ (define (sui)
+ (display "(sui \"")
+ (skribe-eval (markup-option n :title) html-title-engine)
+ (display "\"\n")
+ (printf " :file ~s\n" (sui-referenced-file n e))
+ (sui-marks n e)
+ (sui-blocks 'chapter n e)
+ (sui-blocks 'section n e)
+ (sui-blocks 'subsection n e)
+ (sui-blocks 'subsubsection n e)
+ (display " )\n"))
+ (if (string? *skribe-dest*)
+ (let ((f (format "~a.sui" (prefix *skribe-dest*))))
+ (with-output-to-file f sui))
+ (sui)))
+
+;*---------------------------------------------------------------------*/
+;* sui-referenced-file ... */
+;*---------------------------------------------------------------------*/
+(define (sui-referenced-file n e)
+ (let ((file (html-file n e)))
+ (if (member (suffix file) '("skb" "sui" "skr" "html"))
+ (string-append (strip-ref-base (prefix file)) ".html")
+ file)))
+
+;*---------------------------------------------------------------------*/
+;* sui-marks ... */
+;*---------------------------------------------------------------------*/
+(define (sui-marks n e)
+ (printf " (marks")
+ (for-each (lambda (m)
+ (printf "\n (~s" (markup-ident m))
+ (printf " :file ~s" (sui-referenced-file m e))
+ (printf " :mark ~s" (markup-ident m))
+ (when (markup-class m)
+ (printf " :class ~s" (markup-class m)))
+ (display ")"))
+ (search-down (lambda (n) (is-markup? n 'mark)) n))
+ (display ")\n"))
+
+;*---------------------------------------------------------------------*/
+;* sui-blocks ... */
+;*---------------------------------------------------------------------*/
+(define (sui-blocks kind n e)
+ (printf " (~as" kind)
+ (for-each (lambda (chap)
+ (display "\n (\"")
+ (skribe-eval (markup-option chap :title) html-title-engine)
+ (printf "\" :file ~s" (sui-referenced-file chap e))
+ (printf " :mark ~s" (markup-ident chap))
+ (when (markup-class chap)
+ (printf " :class ~s" (markup-class chap)))
+ (display ")"))
+ (container-search-down (lambda (n) (is-markup? n kind)) n))
+ (display ")\n"))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (display "<table")
+ (html-class n)
+ (display "><tbody>\n"))
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (nfn (engine-custom e 'author-font))
+ (align (markup-option n :align)))
+ (define (row n)
+ (printf "<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)
+ (display "<font size=\"+2\"><i>\n"))
+ (output name e)
+ (if nfn
+ (printf "</font>\n")
+ (display "</i></font>\n"))
+ (display "</td></tr>")
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (if (pair? address)
+ (for-each row address))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url))))
+ :after "</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :predicate (lambda (n e) (markup-option n :photo))
+ :before (lambda (n e)
+ (display "<table")
+ (html-class n)
+ (display "><tbody>\n<tr>"))
+ :action (lambda (n e)
+ (let ((photo (markup-option n :photo)))
+ (display "<td>")
+ (output photo e)
+ (display "</td><td>")
+ (markup-option-add! n :photo #f)
+ (output n e)
+ (markup-option-add! n :photo photo)
+ (display "</td>")))
+ :after "</tr>\n</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options 'all
+ :action (lambda (n e)
+ (define (col n)
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (display "<td></td>")
+ (loop (+ i 1))))))
+ (define (toc-entry fe level)
+ (let* ((c (car fe))
+ (ch (cdr fe))
+ (t (markup-option c :title))
+ (id (markup-ident c))
+ (f (html-file c e)))
+ (unless (string? id)
+ (skribe-error 'toc
+ (format "Illegal identifier `~a'" id)
+ c))
+ (display " <tr>")
+ ;; blank columns
+ (col level)
+ ;; number
+ (printf "<td valign=\"top\" align=\"left\">~a</td>"
+ (html-container-number c e))
+ ;; title
+ (printf "<td colspan=\"~a\" width=\"100%\">"
+ (- 4 level))
+ (printf "<a href=\"~a#~a\">"
+ (if (string=? f *skribe-dest*)
+ ""
+ (strip-ref-base (or f *skribe-dest* "")))
+ (string-canonicalize id))
+ (output (markup-option c :title) e)
+ (display "</a></td>")
+ (display "</tr>\n")
+ ;; the children
+ (for-each (lambda (n) (toc-entry n (+ 1 level))) ch)))
+ (define (symbol->keyword s)
+ (cond-expand
+ (stklos
+ (make-keyword s))
+ (bigloo
+ (string->keyword (string-append ":" (symbol->string s))))))
+ (let* ((c (markup-option n :chapter))
+ (s (markup-option n :section))
+ (ss (markup-option n :subsection))
+ (sss (markup-option n :subsubsection))
+ (b (markup-body n))
+ (bb (if (handle? b)
+ (handle-ast b)
+ b)))
+ (if (not (container? bb))
+ (error 'toc
+ "Illegal body (container expected)"
+ (if (markup? bb)
+ (markup-markup bb)
+ "???"))
+ (let ((lst (find-down (lambda (x)
+ (and (markup? x)
+ (markup-option x :toc)
+ (or (and sss (is-markup? x 'subsubsection))
+ (and ss (is-markup? x 'subsection))
+ (and s (is-markup? x 'section))
+ (and c (is-markup? x 'chapter))
+ (markup-option n (symbol->keyword
+ (markup-markup x))))))
+ (container-body bb))))
+ ;; avoid to produce an empty table
+ (unless (null? lst)
+ (display "<table cellspacing=\"1\" cellpadding=\"1\" width=\"100%\"")
+ (html-class n)
+ (display ">\n<tbody>\n")
+
+ (for-each (lambda (n) (toc-entry n 0)) lst)
+
+ (display "</tbody>\n</table>\n")))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-document ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-document n title e)
+ (let* ((id (markup-ident n))
+ (header (new markup
+ (markup '&html-chapter-header)
+ (ident (string-append id "-header"))
+ (class (markup-class n))
+ (parent n)
+ (body (html-browser-title n))))
+ (head (new markup
+ (markup '&html-head)
+ (ident (string-append id "-head"))
+ (class (markup-class n))
+ (parent n)
+ (body header)))
+ (ftnote (new markup
+ (markup '&html-footnotes)
+ (ident (string-append id "-footnote"))
+ (class (markup-class n))
+ (parent n)
+ (body (reverse!
+ (container-env-get n 'footnote-env)))))
+ (page (new markup
+ (markup '&html-page)
+ (ident (string-append id "-page"))
+ (class (markup-class n))
+ (parent n)
+ (body (list (markup-body n) ftnote))))
+ (ending (new markup
+ (markup '&html-ending)
+ (ident (string-append id "-ending"))
+ (class (markup-class n))
+ (parent n)
+ (body (or (markup-option n :ending)
+ (let ((p (ast-document n)))
+ (and p (markup-option p :ending)))))))
+ (body (new markup
+ (markup '&html-body)
+ (ident (string-append id "-body"))
+ (class (markup-class n))
+ (parent n)
+ (body (list title page ending))))
+ (html (new markup
+ (markup '&html-html)
+ (ident (string-append id "-html"))
+ (class (markup-class n))
+ (parent n)
+ (body (list head body)))))
+ ;; No file must be opened for documents. These files are
+ ;; directly opened by Skribe
+ (if (document? n)
+ (output html e)
+ (with-output-to-file (html-file n e)
+ (lambda ()
+ (output html e))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-subdocument ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-subdocument n e)
+ (let* ((p (ast-document n))
+ (id (markup-ident n))
+ (ti (let* ((nb (html-container-number n e))
+ (tc (markup-option n :title))
+ (ti (if (document? p)
+ (list (markup-option p :title)
+ (engine-custom e 'file-title-separator)
+ tc)
+ tc))
+ (sep (engine-custom
+ e
+ (symbol-append (markup-markup n)
+ '-title-number-separator)))
+ (nti (and tc
+ (if (and nb (not (equal? nb "")))
+ (list nb
+ (if (unspecified? sep) ". " sep)
+ ti)
+ ti))))
+ (new markup
+ (markup (symbol-append '&html- (markup-markup n) '-title))
+ (ident (string-append id "-title"))
+ (parent n)
+ (options '((author ())))
+ (body nti)))))
+ (case (markup-markup n)
+ ((chapter)
+ (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id))
+ ((section)
+ (skribe-message " [~s section: ~a]\n" (engine-ident e) id)))
+ (&html-generic-document n ti e)))
+
+;*---------------------------------------------------------------------*/
+;* chapter ... @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :file :toc :html-title :env)
+ :before (lambda (n e)
+ (let ((title (markup-option n :title))
+ (ident (markup-ident n)))
+ (display "<!-- ")
+ (output title html-title-engine)
+ (display " -->\n")
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (display "<center><h1")
+ (html-class n)
+ (display ">")
+ (output (html-container-number n e) e)
+ (display " ")
+ (output (markup-option n :title) e)
+ (display "</h1></center>")))
+ :after "<br>")
+
+;; This writer is invoked only for chapters rendered inside separate files!
+(markup-writer 'chapter
+ :options '(:title :number :file :toc :html-title :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'chapter-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* html-section-title ... */
+;*---------------------------------------------------------------------*/
+(define (html-section-title n e)
+ (let* ((title (markup-option n :title))
+ (number (markup-option n :number))
+ (c (markup-class n))
+ (ident (markup-ident n))
+ (kind (markup-markup n))
+ (tbg (engine-custom e (symbol-append kind '-title-background)))
+ (tfg (engine-custom e (symbol-append kind '-title-foreground)))
+ (tstart (engine-custom e (symbol-append kind '-title-start)))
+ (tstop (engine-custom e (symbol-append kind '-title-stop)))
+ (nsep (engine-custom e (symbol-append kind '-title-number-separator))))
+ ;; the section header
+ (display "<!-- ")
+ (output title html-title-engine)
+ (display " -->\n")
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (if c
+ (printf "<div class=\"~a-atitle\">" c)
+ (printf "<div class=\"skribe~atitle\">" (markup-markup n)))
+ (when (html-color-spec? tbg)
+ (display "<table width=\"100%\">")
+ (printf "<tr><td bgcolor=\"~a\">" tbg))
+ (display tstart)
+ (if tfg (printf "<font color=\"~a\">" tfg))
+ (if number
+ (begin
+ (output (html-container-number n e) e)
+ (output nsep e)))
+ (output title e)
+ (if tfg (display "</font>\n"))
+ (display tstop)
+ (when (and (string? tbg) (> (string-length tbg) 0))
+ (display "</td></tr></table>\n"))
+ (display "</div>")
+ (display "<div")
+ (html-class n)
+ (display ">"))
+ (newline))
+
+;*---------------------------------------------------------------------*/
+;* section ... @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :before html-section-title
+ :after "</div><br>\n")
+
+;; on-file section writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'section-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :html-title :number :toc :env :file)
+ :before html-section-title
+ :after "</div>\n")
+
+;; on-file subsection writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'subsection-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :html-title :number :toc :env :file)
+ :before html-section-title
+ :after "</div>\n")
+
+;; on-file subsection writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'subsubsection-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :before (lambda (n e)
+ (when (and (>= (skribe-debug) 2) (location? (ast-loc n)))
+ (printf "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>"
+ (ast-location n)))
+ ((html-markup-class "p") n e))
+ :after "</p>")
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :options '(:number)
+ :action (lambda (n e)
+ (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>"
+ (string-canonicalize (container-ident n))
+ (markup-option n :number))))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :before (lambda (n e)
+ (display "<br")
+ (html-class n)
+ (display "/>")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '(:width :height)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (height (markup-option n :height)))
+ (display "<hr")
+ (html-class n)
+ (if (< width 100)
+ (printf " width=\"~a\"" (html-width width)))
+ (if (> height 1)
+ (printf " size=\"~a\"" height))
+ (display ">"))))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:bg :fg :width :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg)))
+ (when (html-color-spec? bg)
+ (display "<table cellspacing=\"0\"")
+ (html-class n)
+ (printf " cellpadding=\"~a\"" (if m m 0))
+ (if w (printf " width=\"~a\"" (html-width w)))
+ (display "><tbody>\n<tr>")
+ (display "<td bgcolor=\"")
+ (output bg e)
+ (display "\">"))
+ (when (html-color-spec? fg)
+ (display "<font color=\"")
+ (output fg e)
+ (display "\">"))))
+ :after (lambda (n e)
+ (when (html-color-spec? (markup-option n :fg))
+ (display "</font>"))
+ (when (html-color-spec? (markup-option n :bg))
+ (display "</td></tr>\n</tbody></table>"))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ :options '(:width :margin :border)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (b (markup-option n :border))
+ (w (markup-option n :width)))
+ (display "<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)))
+ (display "><tbody>\n<tr><td>")))
+ :after "</td></tr>\n</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((size (markup-option n :size))
+ (face (markup-option n :face)))
+ (when (and (number? size) (inexact? size))
+ (let ((s (if (> size 0) "<big>" "<small>"))
+ (d (if (> size 0) 1 -1)))
+ (do ((i (inexact->exact size) (- i d)))
+ ((= i 0))
+ (display s))))
+ (when (or (and (number? size) (exact? size)) face)
+ (display "<font")
+ (html-class n)
+ (when (and (number? size) (exact? size) (not (= size 0)))
+ (printf " size=\"~a\"" size))
+ (when face (printf " face=\"~a\"" face))
+ (display ">"))))
+ :after (lambda (n e)
+ (let ((size (markup-option n :size))
+ (face (markup-option n :face)))
+ (when (or (and (number? size) (exact? size) (not (= size 0)))
+ face)
+ (display "</font>"))
+ (when (and (number? size) (inexact? size))
+ (let ((s (if (> size 0) "</big>" "</small>"))
+ (d (if (> size 0) 1 -1)))
+ (do ((i (inexact->exact size) (- i d)))
+ ((= i 0))
+ (display s)))))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "<center")
+ (html-class n)
+ (display ">\n"))
+ ((left)
+ (display "<p style=\"text-align:left;\"")
+ (html-class n)
+ (display ">\n"))
+ ((right)
+ (display "<table ")
+ (html-class n)
+ (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">"))
+ (else
+ (skribe-error 'flush
+ "Illegal side"
+ (markup-option n :side)))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "</center>\n"))
+ ((right)
+ (display "</td></tr></table>\n"))
+ ((left)
+ (display "</p>\n")))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before (html-markup-class "center")
+ :after "</center>\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre :before (html-markup-class "pre") :after "</pre>\n")
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before (html-markup-class "pre")
+ :after "</pre>\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before (html-markup-class "ul")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((ident (and (markup? item)
+ (markup-ident item))))
+ (display "<li")
+ (html-class item)
+ (display ">")
+ (if ident ;; produce an anchor
+ (printf "\n<a name=\"~a\"></a>\n"
+ (string-canonicalize ident)))
+ (output item e)
+ (display "</li>\n")))
+ (markup-body n)))
+ :after "</ul>")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before (html-markup-class "ol")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((ident (and (markup? item)
+ (markup-ident item))))
+ (display "<li")
+ (html-class item)
+ (display ">")
+ (if ident ;; produce an anchor
+ (printf "\n<a name=\"~a\"></a>\n" ident))
+ (output item e)
+ (display "</li>\n")))
+ (markup-body n)))
+ :after "</ol>")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol)
+ :before (html-markup-class "dl")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (for-each (lambda (i)
+ (display " <dt")
+ (html-class i)
+ (display ">")
+ (output i e)
+ (display "</dt>"))
+ (if (pair? k) k (list k)))
+ (display "<dd")
+ (html-class item)
+ (display ">")
+ (output (markup-body item) e)
+ (display "</dd>\n")))
+ (markup-body n)))
+ :after "</dl>")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (if k
+ (begin
+ (display "<b")
+ (html-class n)
+ (display ">")
+ (output k e)
+ (display "</b> "))))
+ (output (markup-body n) e)))
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :options '()
+ :before (lambda (n e)
+ (display "<blockquote ")
+ (html-class n)
+ (display ">\n"))
+ :after "\n</blockquote>\n")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns :legend-width)
+ :before (html-markup-class "br")
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (output (markup-body n) e)
+ (display "<br>\n")
+ (output (new markup
+ (markup '&html-figure-legend)
+ (parent n)
+ (ident (string-append ident "-legend"))
+ (class (markup-class n))
+ (options `((:number ,number)))
+ (body legend))
+ e)))
+ :after "<br>")
+
+;*---------------------------------------------------------------------*/
+;* &html-figure-legend ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-figure-legend
+ :options '(:number)
+ :before (lambda (n e)
+ (display "<center>")
+ (let ((number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (if number
+ (printf "<strong>Fig. ~a:</strong> " number)
+ (printf "<strong>Fig. :</strong> "))))
+ :after "</center>")
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (cp (markup-option n :cellpadding))
+ (cs (markup-option n :cellspacing)))
+ (display "<table")
+ (html-class n)
+ (if width (printf " width=\"~a\"" (html-width width)))
+ (if border (printf " border=\"~a\"" border))
+ (if (and (number? cp) (>= cp 0))
+ (printf " cellpadding=\"~a\"" cp))
+ (if (and (number? cs) (>= cs 0))
+ (printf " cellspacing=\"~a\"" cs))
+ (cond
+ ((symbol? cstyle)
+ (printf " style=\"border-collapse: ~a;\"" cstyle))
+ ((string? cstyle)
+ (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle))
+ ((number? cstyle)
+ (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle)))
+ (if frame
+ (printf " frame=\"~a\""
+ (if (eq? frame 'none) "void" frame)))
+ (if (and rules (not (eq? rules 'header)))
+ (printf " rules=\"~a\"" rules))
+ (display "><tbody>\n")))
+ :after "</tbody></table>\n")
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '(:bg)
+ :before (lambda (n e)
+ (let ((bg (markup-option n :bg)))
+ (display "<tr")
+ (html-class n)
+ (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg))
+ (display ">")))
+ :after "</tr>\n")
+
+;*---------------------------------------------------------------------*/
+;* tc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(markup :width :align :valign :colspan :rowspan :bg)
+ :before (lambda (n e)
+ (let ((markup (or (markup-option n 'markup) 'td))
+ (width (markup-option n :width))
+ (align (markup-option n :align))
+ (valign (let ((v (markup-option n :valign)))
+ (cond
+ ((or (eq? v 'center)
+ (equal? v "center"))
+ "middle")
+ (else
+ v))))
+ (colspan (markup-option n :colspan))
+ (rowspan (markup-option n :rowspan))
+ (bg (markup-option n :bg)))
+ (printf "<~a" markup)
+ (html-class n)
+ (if width (printf " width=\"~a\"" (html-width width)))
+ (if align (printf " align=\"~a\"" align))
+ (if valign (printf " valign=\"~a\"" valign))
+ (if colspan (printf " colspan=\"~a\"" colspan))
+ (if rowspan (printf " rowspan=\"~a\"" rowspan))
+ (when (html-color-spec? bg)
+ (printf " bgcolor=\"~a\"" bg))
+ (display ">")))
+ :after (lambda (n e)
+ (let ((markup (or (markup-option n 'markup) 'td)))
+ (printf "</~a>" markup))))
+
+;*---------------------------------------------------------------------*/
+;* image ... @label image@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("gif" "jpg" "png"))))))
+ (if (not (string? img))
+ (skribe-error 'html "Illegal image" file)
+ (begin
+ (printf "<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))
+ (display ">"))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'roman :before "")
+(markup-writer 'bold :before (html-markup-class "strong") :after "</strong>")
+(markup-writer 'underline :before (html-markup-class "u") :after "</u>")
+(markup-writer 'strike :before (html-markup-class "strike") :after "</strike>")
+(markup-writer 'emph :before (html-markup-class "em") :after "</em>")
+(markup-writer 'kbd :before (html-markup-class "kbd") :after "</kbd>")
+(markup-writer 'it :before (html-markup-class "em") :after "</em>")
+(markup-writer 'tt :before (html-markup-class "tt") :after "</tt>")
+(markup-writer 'code :before (html-markup-class "code") :after "</code>")
+(markup-writer 'var :before (html-markup-class "var") :after "</var>")
+(markup-writer 'samp :before (html-markup-class "samp") :after "</samp>")
+(markup-writer 'sc :before "<span class=\"sc\">" :after "</span>")
+(markup-writer 'sf :before "<span class=\"sf\">" :after "</span>")
+(markup-writer 'sub :before (html-markup-class "sub") :after "</sub>")
+(markup-writer 'sup :before (html-markup-class "sup") :after "</sup>")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "\""
+ :after "\"")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (display "<a href=\"mailto:")
+ (output (markup-body n) e)
+ (display #\")
+ (html-class n)
+ (display #\>)
+ (if text
+ (output text e)
+ (skribe-eval (tt (markup-body n)) e))
+ (display "</a>"))))
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :predicate (lambda (n e)
+ (and (engine-custom e 'javascript)
+ (or (string? (markup-body n))
+ (and (pair? (markup-body n))
+ (null? (cdr (markup-body n)))
+ (string? (car (markup-body n)))))))
+ :action (lambda (n e)
+ (let* ((body (markup-body n))
+ (email (if (string? body) body (car body)))
+ (split (pregexp-split "@" email))
+ (na (car split))
+ (do (if (pair? (cdr split)) (cadr split) ""))
+ (nn (pregexp-replace* "[.]" na " "))
+ (dd (pregexp-replace* "[.]" do " "))
+ (text (markup-option n :text)))
+ (display "<script language=\"JavaScript\" type=\"text/javascript\"")
+ (if (not text)
+ (printf ">skribenospam( ~s, ~s, true )" nn dd)
+ (begin
+ (printf ">skribenospam( ~s, ~s, false )" nn dd)
+ (display "</script>")
+ (output text e)
+ (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")")))
+ (display "</script>\n"))))
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n)))
+ (html-class n)
+ (display ">"))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle)
+ :before (lambda (n e)
+ (let* ((c (handle-ast (markup-body n)))
+ (id (markup-ident c))
+ (f (html-file c e))
+ (class (if (markup-class n)
+ (markup-class n)
+ "inbound")))
+ (printf "<a href=\"~a#~a\" class=\"~a\""
+ (if (string=? f *skribe-dest*)
+ ""
+ (strip-ref-base (or f *skribe-dest* "")))
+ (string-canonicalize id)
+ class)
+ (display ">")))
+ :action (lambda (n e)
+ (let ((t (markup-option n :text))
+ (m (markup-option n 'mark))
+ (f (markup-option n :figure))
+ (c (markup-option n :chapter))
+ (s (markup-option n :section))
+ (ss (markup-option n :subsection))
+ (sss (markup-option n :subsubsection)))
+ (cond
+ (t
+ (output t e))
+ (f
+ (output (new markup
+ (markup '&html-figure-ref)
+ (body (markup-body n)))
+ e))
+ ((or c s ss sss)
+ (output (new markup
+ (markup '&html-section-ref)
+ (body (markup-body n)))
+ e))
+
+ ((not m)
+ (output (new markup
+ (markup '&html-unmark-ref)
+ (body (markup-body n)))
+ e))
+ (else
+ (display m)))))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* &html-figure-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-figure-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (or (not (markup? c))
+ (not (is-markup? c 'figure)))
+ (display "???")
+ (output (markup-option c :number) e)))))
+
+;*---------------------------------------------------------------------*/
+;* &html-section-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-section-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (not (markup? c))
+ (display "???")
+ (output (markup-option c :title) e)))))
+
+;*---------------------------------------------------------------------*/
+;* &html-unmark-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-unmark-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (not (markup? c))
+ (display "???")
+ (let ((t (markup-option c :title)))
+ (if t
+ (output t e)
+ (let ((l (markup-option c :legend)))
+ (if l
+ (output t e)
+ (display
+ (string-canonicalize
+ (markup-ident c)))))))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e) (output n e (markup-writer-get 'ref e)))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (output (car rs) e (markup-writer-get 'ref e))
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :before (lambda (n e)
+ (let* ((url (markup-option n :url))
+ (class (cond
+ ((markup-class n)
+ (markup-class n))
+ ((not (string? url))
+ #f)
+ (else
+ (let ((l (string-length url)))
+ (let loop ((i 0))
+ (cond
+ ((= i l)
+ #f)
+ ((char=? (string-ref url i) #\:)
+ (substring url 0 i))
+ (else
+ (loop (+ i 1))))))))))
+ (display "<a href=\"")
+ (output url html-title-engine)
+ (display "\"")
+ (when class (printf " class=\"~a\"" class))
+ (display ">")))
+ :action (lambda (n e)
+ (let ((v (markup-option n :text)))
+ (output (or v (markup-option n :url)) e)))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before (html-markup-class "i")
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (if (and (number? o) (number? v))
+ (markup-option-add! n :text (+ o v)))
+ (output n e (markup-writer-get 'ref e))
+ (if (and (number? o) (number? v))
+ (markup-option-add! n :text v))))
+ :after "</i>")
+
+;*---------------------------------------------------------------------*/
+;* page-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'page-ref
+ :options '(:mark :handle)
+ :action (lambda (n e)
+ (error 'page-ref:html "Not implemented yet" n)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before (lambda (n e)
+ (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n)))
+ (html-class n)
+ (display ">"))
+ :action (lambda (n e)
+ (output n e (markup-writer-get '&bib-entry-label base-engine)))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (or (markup-option en 'url)
+ (markup-option en 'documenturl)))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e)
+ (display "<center")
+ (html-class n)
+ (display ">")
+ (for-each (lambda (h)
+ (let ((f (engine-custom e 'index-header-font-size)))
+ (if f
+ (skribe-eval (font :size f (bold (it h))) e)
+ (output h e))
+ (display " ")))
+ (markup-body n))
+ (display "</center>")
+ (skribe-eval (linebreak 2) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-error ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm
new file mode 100644
index 0000000..614ca99
--- /dev/null
+++ b/src/guile/skribilo/engine/html4.scm
@@ -0,0 +1,167 @@
+;;;;
+;;;; html4.skr -- HTML 4.01 Engine
+;;;;
+;;;; Copyright � 2004 Erick Gallesio - I3S-CNRS/ESSI <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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 18-Feb-2004 11:58 (eg)
+;;;; Last file update: 26-Feb-2004 21:09 (eg)
+;;;;
+
+(define-skribe-module (skribilo engine html4))
+
+(define (find-children node)
+ (define (flat l)
+ (cond
+ ((null? l) l)
+ ((pair? l) (append (flat (car l))
+ (flat (cdr l))))
+ (else (list l))))
+
+ (if (markup? node)
+ (flat (markup-body node))
+ node))
+
+;;; ======================================================================
+
+(let ((le (find-engine 'html)))
+ ;;----------------------------------------------------------------------
+ ;; Customizations
+ ;;----------------------------------------------------------------------
+ (engine-custom-set! le 'html-variant "html4")
+ (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401")
+ (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer")
+
+ ;;----------------------------------------------------------------------
+ ;; &html-html ...
+ ;;----------------------------------------------------------------------
+ (markup-writer '&html-html le
+ :before "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+<html>\n"
+ :after "</html>")
+
+ ;;----------------------------------------------------------------------
+ ;; &html-ending
+ ;;----------------------------------------------------------------------
+ (let* ((img (engine-custom le 'html4-logo))
+ (url (engine-custom le 'html4-validator))
+ (bottom (list (hrule)
+ (table :width 100.
+ (tr
+ (td :align 'left
+ (font :size -1 [
+ This ,(sc "Html") page has been produced by
+ ,(ref :url (skribe-url) :text "Skribe").
+ ,(linebreak)
+ Last update ,(it (date)).]))
+ (td :align 'right :valign 'top
+ (ref :url url
+ :text (image :url img :width 88 :height 31))))))))
+ (markup-writer '&html-ending le
+ :before "<div class=\"skribe-ending\">"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if body
+ (output body #t)
+ (skribe-eval bottom e))))
+ :after "</div>\n"))
+
+ ;;----------------------------------------------------------------------
+ ;; color ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'color le
+ :options '(:bg :fg :width :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg)))
+ (when bg
+ (display "<table cellspacing=\"0\"")
+ (html-class n)
+ (printf " cellpadding=\"~a\"" (if m m 0))
+ (if w (printf " width=\"~a\"" (html-width w)))
+ (display "><tbody>\n<tr>")
+ (display "<td bgcolor=\"")
+ (output bg e)
+ (display "\">"))
+ (when fg
+ (display "<span style=\"color:")
+ (output fg e)
+ (display ";\">"))))
+ :after (lambda (n e)
+ (when (markup-option n :fg)
+ (display "</span>"))
+ (when (markup-option n :bg)
+ (display "</td></tr>\n</tbody></table>"))))
+
+ ;;----------------------------------------------------------------------
+ ;; font ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'font le
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((face (markup-option n :face))
+ (size (let ((sz (markup-option n :size)))
+ (cond
+ ((or (unspecified? sz) (not sz))
+ #f)
+ ((and (number? sz) (or (inexact? sz) (negative? sz)))
+ (format "~a%"
+ (+ 100
+ (* 20 (inexact->exact (truncate sz))))))
+ ((number? sz)
+ sz)
+ (else
+ (skribe-error 'font
+ (format "Illegal font size ~s" sz)
+ n))))))
+ (display "<span ")
+ (html-class n)
+ (display "style=\"")
+ (if size (printf "font-size: ~a; " size))
+ (if face (printf "font-family:'~a'; " face))
+ (display "\">")))
+ :after "</span>")
+
+ ;;----------------------------------------------------------------------
+ ;; paragraph ...
+ ;;----------------------------------------------------------------------
+ (copy-markup-writer 'paragraph le
+ :validate (lambda (n e)
+ (let ((pred (lambda (x)
+ (and (container? x)
+ (not (memq (markup-markup x) '(font color)))))))
+ (not (any pred (find-children n))))))
+
+ ;;----------------------------------------------------------------------
+ ;; roman ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'roman le
+ :before "<span style=\"font-family: serif\">"
+ :after "</span>")
+
+ ;;----------------------------------------------------------------------
+ ;; table ...
+ ;;----------------------------------------------------------------------
+ (let ((old-writer (markup-writer-get 'table le)))
+ (copy-markup-writer 'table le
+ :validate (lambda (n e)
+ (not (null? (markup-body n))))))
+)
diff --git a/src/guile/skribilo/engine/latex-simple.scm b/src/guile/skribilo/engine/latex-simple.scm
new file mode 100644
index 0000000..638c158
--- /dev/null
+++ b/src/guile/skribilo/engine/latex-simple.scm
@@ -0,0 +1,103 @@
+(define-skribe-module (skribilo engine latex-simple))
+
+;;;
+;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER
+;;; CE FICHIER (sion simplifie il ne rest plus grand chose)
+;;; Erick 27-10-04
+;;;
+
+
+;*=====================================================================*/
+;* scmws04/src/latex-style.skr */
+;* ------------------------------------------------------------- */
+;* Author : Damien Ciabrini */
+;* Creation : Tue Aug 24 19:17:04 2004 */
+;* Last change : Thu Oct 28 21:45:25 2004 (eg) */
+;* Copyright : 2004 Damien Ciabrini, see LICENCE file */
+;* ------------------------------------------------------------- */
+;* Custom style for Latex... */
+;*=====================================================================*/
+
+(let* ((le (find-engine 'latex))
+ (oa (markup-writer-get 'author le)))
+ ; latex class & package for the workshop
+ (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}")
+ (engine-custom-set! le 'usepackage
+ "\\usepackage{epsfig}
+\\usepackage{workshop}
+\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.}
+ {September 22, 2004, Snowbird, Utah, USA.}
+\\CopyrightYear{2004}
+\\CopyrightHolder{Damien Ciabrini}
+\\renewcommand{\\ttdefault}{cmtt}
+")
+ (engine-custom-set! le 'image-format '("eps"))
+ (engine-custom-set! le 'source-define-color "#000080")
+ (engine-custom-set! le 'source-thread-color "#8080f0")
+ (engine-custom-set! le 'source-string-color "#000000")
+
+ ; hyperref options
+ (engine-custom-set! le 'hyperref #t)
+ (engine-custom-set! le 'hyperref-usepackage
+ "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}")
+ ; nbsp with ~ char
+ (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding))
+
+ ; let latex process citations
+ (markup-writer 'bib-ref le
+ :options '(:text :bib)
+ :before "\\cite{"
+ :action (lambda (n e) (display (markup-option n :bib)))
+ :after "}")
+ (markup-writer 'bib-ref+ le
+ :options '(:text :bib)
+ :before "\\cite{"
+ :action (lambda (n e)
+ (let loop ((bibs (markup-option n :bib)))
+ (if (pair? bibs)
+ (begin
+ (display (car bibs))
+ (if (pair? (cdr bibs)) (display ", "))
+ (loop (cdr bibs))))))
+ :after "}")
+ (markup-writer '&the-bibliography le
+ :action (lambda (n e)
+ (print "\\bibliographystyle{abbrv}")
+ (display "\\bibliography{biblio}")))
+
+ ; ACM-style for authors
+ (markup-writer '&latex-author le
+ :before (lambda (n e)
+ (let ((body (markup-body n)))
+ (if (pair? body)
+ (print "\\numberofauthors{" (length body) "}"))
+ (print "\\author{")))
+ :after "}\n")
+ (markup-writer 'author le
+ :options (writer-options oa)
+ :before ""
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (affiliation (markup-option n :affiliation))
+ (address (markup-option n :address))
+ (email (markup-option n :email)))
+ (define (row pre n post)
+ (display pre)
+ (output n e)
+ (display post)
+ (display "\\\\\n"))
+ ;; name
+ (if name (row "\\alignauthor " name ""))
+ ;; affiliation
+ (if affiliation (row "\\affaddr{" affiliation "}"))
+ ;; address
+ (if (pair? address)
+ (for-each (lambda (x)
+ (row "\\affaddr{" x "}")) address))
+ ;; email
+ (if email (row "\\email{" email "}"))))
+ :after "")
+)
+
+(define (include-biblio)
+ (the-bibliography))
diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm
new file mode 100644
index 0000000..bc20493
--- /dev/null
+++ b/src/guile/skribilo/engine/latex.scm
@@ -0,0 +1,1780 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/latex.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Tue Sep 2 09:46:09 2003 */
+;* Last change : Thu May 26 12:59:47 2005 (serrano) */
+;* Copyright : 2003-05 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* LaTeX Skribe engine */
+;* ------------------------------------------------------------- */
+;* Implementation: */
+;* common: @path ../src/common/api.src@ */
+;* bigloo: @path ../src/bigloo/api.bgl@ */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/latexe.skb:ref@ */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* latex-verbatim-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-verbatim-encoding
+ '((#\\ "{\\char92}")
+ (#\^ "{\\char94}")
+ (#\{ "\\{")
+ (#\} "\\}")
+ (#\& "\\&")
+ (#\$ "\\$")
+ (#\# "\\#")
+ (#\_ "\\_")
+ (#\% "\\%")
+ (#\~ "$_{\\mbox{\\char126}}$")
+ (#\� "\\c{c}")
+ (#\� "\\c{C}")
+ (#\� "\\^{a}")
+ (#\� "\\^{A}")
+ (#\� "\\`{a}")
+ (#\� "\\`{A}")
+ (#\� "\\'{e}")
+ (#\� "\\'{E}")
+ (#\� "\\`{e}")
+ (#\� "\\`{E}")
+ (#\� "\\^{e}")
+ (#\� "\\^{E}")
+ (#\� "\\`{u}")
+ (#\� "\\`{U}")
+ (#\� "\\^{u}")
+ (#\� "\\^{U}")
+ (#\� "{\\o}")
+ (#\� "\\^{o}")
+ (#\� "\\^{O}")
+ (#\� "\\\"{o}")
+ (#\� "\\\"{O}")
+ (#\� "\\^{\\i}")
+ (#\� "\\^{I}")
+ (#\� "\\\"{\\i}")
+ (#\� "\\\"{I}")
+ (#\] "{\\char93}")
+ (#\[ "{\\char91}")
+ (#\� "\\,{\\tiny{$^{\\gg}$}}")
+ (#\� "{\\tiny{$^{\\ll}$}}\\,")))
+
+;*---------------------------------------------------------------------*/
+;* latex-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-encoding
+ (append '((#\| "$|$")
+ (#\< "$<$")
+ (#\> "$>$")
+ (#\: "{\\char58}")
+ (#\# "{\\char35}")
+ (#\Newline " %\n"))
+ latex-verbatim-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-tt-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-tt-encoding
+ (append '((#\. ".\\-")
+ (#\/ "/\\-"))
+ latex-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-pre-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-pre-encoding
+ (append '((#\Space "\\ ")
+ (#\Newline "\\\\\n"))
+ latex-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-symbol-table ... */
+;*---------------------------------------------------------------------*/
+(define (latex-symbol-table math)
+ `(("iexcl" "!`")
+ ("cent" "c")
+ ("pound" "\\pounds")
+ ("yen" "Y")
+ ("section" "\\S")
+ ("mul" ,(math "^-"))
+ ("copyright" "\\copyright")
+ ("lguillemet" ,(math "\\ll"))
+ ("not" ,(math "\\neg"))
+ ("degree" ,(math "^{\\small{o}}"))
+ ("plusminus" ,(math "\\pm"))
+ ("micro" ,(math "\\mu"))
+ ("paragraph" "\\P")
+ ("middot" ,(math "\\cdot"))
+ ("rguillemet" ,(math "\\gg"))
+ ("1/4" ,(math "\\frac{1}{4}"))
+ ("1/2" ,(math "\\frac{1}{2}"))
+ ("3/4" ,(math "\\frac{3}{4}"))
+ ("iquestion" "?`")
+ ("Agrave" "\\`{A}")
+ ("Aacute" "\\'{A}")
+ ("Acircumflex" "\\^{A}")
+ ("Atilde" "\\~{A}")
+ ("Amul" "\\\"{A}")
+ ("Aring" "{\\AA}")
+ ("AEligature" "{\\AE}")
+ ("Oeligature" "{\\OE}")
+ ("Ccedilla" "{\\c{C}}")
+ ("Egrave" "{\\`{E}}")
+ ("Eacute" "{\\'{E}}")
+ ("Ecircumflex" "{\\^{E}}")
+ ("Euml" "\\\"{E}")
+ ("Igrave" "{\\`{I}}")
+ ("Iacute" "{\\'{I}}")
+ ("Icircumflex" "{\\^{I}}")
+ ("Iuml" "\\\"{I}")
+ ("ETH" "D")
+ ("Ntilde" "\\~{N}")
+ ("Ograve" "\\`{O}")
+ ("Oacute" "\\'{O}")
+ ("Ocurcumflex" "\\^{O}")
+ ("Otilde" "\\~{O}")
+ ("Ouml" "\\\"{O}")
+ ("times" ,(math "\\times"))
+ ("Oslash" "\\O")
+ ("Ugrave" "\\`{U}")
+ ("Uacute" "\\'{U}")
+ ("Ucircumflex" "\\^{U}")
+ ("Uuml" "\\\"{U}")
+ ("Yacute" "\\'{Y}")
+ ("szlig" "\\ss")
+ ("agrave" "\\`{a}")
+ ("aacute" "\\'{a}")
+ ("acircumflex" "\\^{a}")
+ ("atilde" "\\~{a}")
+ ("amul" "\\\"{a}")
+ ("aring" "\\aa")
+ ("aeligature" "\\ae")
+ ("oeligature" "{\\oe}")
+ ("ccedilla" "{\\c{c}}")
+ ("egrave" "{\\`{e}}")
+ ("eacute" "{\\'{e}}")
+ ("ecircumflex" "{\\^{e}}")
+ ("euml" "\\\"{e}")
+ ("igrave" "{\\`{\\i}}")
+ ("iacute" "{\\'{\\i}}")
+ ("icircumflex" "{\\^{\\i}}")
+ ("iuml" "\\\"{\\i}")
+ ("ntilde" "\\~{n}")
+ ("ograve" "\\`{o}")
+ ("oacute" "\\'{o}")
+ ("ocurcumflex" "\\^{o}")
+ ("otilde" "\\~{o}")
+ ("ouml" "\\\"{o}")
+ ("divide" ,(math "\\div"))
+ ("oslash" "\\o")
+ ("ugrave" "\\`{u}")
+ ("uacute" "\\'{u}")
+ ("ucircumflex" "\\^{u}")
+ ("uuml" "\\\"{u}")
+ ("yacute" "\\'{y}")
+ ("ymul" "\\\"{y}")
+ ;; Greek
+ ("Alpha" "A")
+ ("Beta" "B")
+ ("Gamma" ,(math "\\Gamma"))
+ ("Delta" ,(math "\\Delta"))
+ ("Epsilon" "E")
+ ("Zeta" "Z")
+ ("Eta" "H")
+ ("Theta" ,(math "\\Theta"))
+ ("Iota" "I")
+ ("Kappa" "K")
+ ("Lambda" ,(math "\\Lambda"))
+ ("Mu" "M")
+ ("Nu" "N")
+ ("Xi" ,(math "\\Xi"))
+ ("Omicron" "O")
+ ("Pi" ,(math "\\Pi"))
+ ("Rho" "P")
+ ("Sigma" ,(math "\\Sigma"))
+ ("Tau" "T")
+ ("Upsilon" ,(math "\\Upsilon"))
+ ("Phi" ,(math "\\Phi"))
+ ("Chi" "X")
+ ("Psi" ,(math "\\Psi"))
+ ("Omega" ,(math "\\Omega"))
+ ("alpha" ,(math "\\alpha"))
+ ("beta" ,(math "\\beta"))
+ ("gamma" ,(math "\\gamma"))
+ ("delta" ,(math "\\delta"))
+ ("epsilon" ,(math "\\varepsilon"))
+ ("zeta" ,(math "\\zeta"))
+ ("eta" ,(math "\\eta"))
+ ("theta" ,(math "\\theta"))
+ ("iota" ,(math "\\iota"))
+ ("kappa" ,(math "\\kappa"))
+ ("lambda" ,(math "\\lambda"))
+ ("mu" ,(math "\\mu"))
+ ("nu" ,(math "\\nu"))
+ ("xi" ,(math "\\xi"))
+ ("omicron" ,(math "\\o"))
+ ("pi" ,(math "\\pi"))
+ ("rho" ,(math "\\rho"))
+ ("sigmaf" ,(math "\\varsigma"))
+ ("sigma" ,(math "\\sigma"))
+ ("tau" ,(math "\\tau"))
+ ("upsilon" ,(math "\\upsilon"))
+ ("phi" ,(math "\\varphi"))
+ ("chi" ,(math "\\chi"))
+ ("psi" ,(math "\\psi"))
+ ("omega" ,(math "\\omega"))
+ ("thetasym" ,(math "\\vartheta"))
+ ("piv" ,(math "\\varpi"))
+ ;; punctuation
+ ("bullet" ,(math "\\bullet"))
+ ("ellipsis" ,(math "\\ldots"))
+ ("weierp" ,(math "\\wp"))
+ ("image" ,(math "\\Im"))
+ ("real" ,(math "\\Re"))
+ ("tm" ,(math "^{\\sc\\tiny{tm}}"))
+ ("alef" ,(math "\\aleph"))
+ ("<-" ,(math "\\leftarrow"))
+ ("<--" ,(math "\\longleftarrow"))
+ ("uparrow" ,(math "\\uparrow"))
+ ("->" ,(math "\\rightarrow"))
+ ("-->" ,(math "\\longrightarrow"))
+ ("downarrow" ,(math "\\downarrow"))
+ ("<->" ,(math "\\leftrightarrow"))
+ ("<-->" ,(math "\\longleftrightarrow"))
+ ("<+" ,(math "\\hookleftarrow"))
+ ("<=" ,(math "\\Leftarrow"))
+ ("<==" ,(math "\\Longleftarrow"))
+ ("Uparrow" ,(math "\\Uparrow"))
+ ("=>" ,(math "\\Rightarrow"))
+ ("==>" ,(math "\\Longrightarrow"))
+ ("Downarrow" ,(math "\\Downarrow"))
+ ("<=>" ,(math "\\Leftrightarrow"))
+ ("<==>" ,(math "\\Longleftrightarrow"))
+ ;; Mathematical operators
+ ("forall" ,(math "\\forall"))
+ ("partial" ,(math "\\partial"))
+ ("exists" ,(math "\\exists"))
+ ("emptyset" ,(math "\\emptyset"))
+ ("infinity" ,(math "\\infty"))
+ ("nabla" ,(math "\\nabla"))
+ ("in" ,(math "\\in"))
+ ("notin" ,(math "\\notin"))
+ ("ni" ,(math "\\ni"))
+ ("prod" ,(math "\\Pi"))
+ ("sum" ,(math "\\Sigma"))
+ ("asterisk" ,(math "\\ast"))
+ ("sqrt" ,(math "\\surd"))
+ ("propto" ,(math "\\propto"))
+ ("angle" ,(math "\\angle"))
+ ("and" ,(math "\\wedge"))
+ ("or" ,(math "\\vee"))
+ ("cap" ,(math "\\cap"))
+ ("cup" ,(math "\\cup"))
+ ("integral" ,(math "\\int"))
+ ("models" ,(math "\\models"))
+ ("vdash" ,(math "\\vdash"))
+ ("dashv" ,(math "\\dashv"))
+ ("sim" ,(math "\\sim"))
+ ("cong" ,(math "\\cong"))
+ ("approx" ,(math "\\approx"))
+ ("neq" ,(math "\\neq"))
+ ("equiv" ,(math "\\equiv"))
+ ("le" ,(math "\\leq"))
+ ("ge" ,(math "\\geq"))
+ ("subset" ,(math "\\subset"))
+ ("supset" ,(math "\\supset"))
+ ("subseteq" ,(math "\\subseteq"))
+ ("supseteq" ,(math "\\supseteq"))
+ ("oplus" ,(math "\\oplus"))
+ ("otimes" ,(math "\\otimes"))
+ ("perp" ,(math "\\perp"))
+ ("mid" ,(math "\\mid"))
+ ("lceil" ,(math "\\lceil"))
+ ("rceil" ,(math "\\rceil"))
+ ("lfloor" ,(math "\\lfloor"))
+ ("rfloor" ,(math "\\rfloor"))
+ ("langle" ,(math "\\langle"))
+ ("rangle" ,(math "\\rangle"))
+ ;; Misc
+ ("loz" ,(math "\\diamond"))
+ ("spades" ,(math "\\spadesuit"))
+ ("clubs" ,(math "\\clubsuit"))
+ ("hearts" ,(math "\\heartsuit"))
+ ("diams" ,(math "\\diamondsuit"))
+ ("euro" "\\euro{}")
+ ;; LaTeX
+ ("dag" "\\dag")
+ ("ddag" "\\ddag")
+ ("circ" ,(math "\\circ"))
+ ("top" ,(math "\\top"))
+ ("bottom" ,(math "\\bot"))
+ ("lhd" ,(math "\\triangleleft"))
+ ("rhd" ,(math "\\triangleright"))
+ ("parallel" ,(math "\\parallel"))))
+
+;*---------------------------------------------------------------------*/
+;* latex-engine ... */
+;*---------------------------------------------------------------------*/
+(define latex-engine
+ (default-engine-set!
+ (make-engine 'latex
+ :version 1.0
+ :format "latex"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace latex-encoding)
+ :custom '((documentclass "\\documentclass{article}")
+ (usepackage "\\usepackage{epsfig}\n")
+ (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n")
+ (postdocument #f)
+ (maketitle "\\date{}\n\\maketitle")
+ (%font-size 0)
+ ;; color
+ (color #t)
+ (color-usepackage "\\usepackage{color}\n")
+ ;; hyperref
+ (hyperref #t)
+ (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n")
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ (image-format ("eps"))
+ (index-page-ref #t))
+ :symbol-table (latex-symbol-table
+ (lambda (m)
+ (format "\\begin{math}~a\\end{math}" m))))))
+
+;*---------------------------------------------------------------------*/
+;* latex-title-engine ... */
+;*---------------------------------------------------------------------*/
+(define latex-title-engine
+ (make-engine 'latex-title
+ :version 1.0
+ :format "latex-title"
+ :delegate latex-engine
+ :filter (make-string-replace latex-encoding)
+ :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m)))))
+
+;*---------------------------------------------------------------------*/
+;* latex-color? ... */
+;*---------------------------------------------------------------------*/
+(define (latex-color? e)
+ (engine-custom e 'color))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX ... */
+;*---------------------------------------------------------------------*/
+(define-markup (LaTeX #!key (space #t))
+ (if (engine-format? "latex")
+ (! (if space "\\LaTeX\\ " "\\LaTeX"))
+ "LaTeX"))
+
+;*---------------------------------------------------------------------*/
+;* TeX ... */
+;*---------------------------------------------------------------------*/
+(define-markup (TeX #!key (space #t))
+ (if (engine-format? "latex")
+ (! (if space "\\TeX\\ " "\\TeX"))
+ "TeX"))
+
+;*---------------------------------------------------------------------*/
+;* latex ... */
+;*---------------------------------------------------------------------*/
+(define-markup (!latex fmt #!rest opt)
+ (if (engine-format? "latex")
+ (apply ! fmt opt)
+ #f))
+
+;*---------------------------------------------------------------------*/
+;* latex-width ... */
+;*---------------------------------------------------------------------*/
+(define (latex-width width)
+ (if (and (number? width) (inexact? width))
+ (string-append (number->string (/ width 100.)) "\\linewidth")
+ (string-append (number->string width) "pt")))
+
+;*---------------------------------------------------------------------*/
+;* latex-font-size ... */
+;*---------------------------------------------------------------------*/
+(define (latex-font-size size)
+ (case size
+ ((4) "Huge")
+ ((3) "huge")
+ ((2) "Large")
+ ((1) "large")
+ ((0) "normalsize")
+ ((-1) "small")
+ ((-2) "footnotesize")
+ ((-3) "scriptsize")
+ ((-4) "tiny")
+ (else (if (number? size)
+ (if (< size 0) "tiny" "Huge")
+ "normalsize"))))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-latex-color-table* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-latex-color-table* #f)
+
+;*---------------------------------------------------------------------*/
+;* latex-declare-color ... */
+;*---------------------------------------------------------------------*/
+(define (latex-declare-color name rgb)
+ (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb))
+
+;*---------------------------------------------------------------------*/
+;* skribe-get-latex-color ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-get-latex-color spec)
+ (let ((c (and (hashtable? *skribe-latex-color-table*)
+ (hashtable-get *skribe-latex-color-table* spec))))
+ (if (not (string? c))
+ (skribe-error 'latex "Can't find color" spec)
+ c)))
+
+;*---------------------------------------------------------------------*/
+;* skribe-color->latex-rgb ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-color->latex-rgb spec)
+ (receive (r g b)
+ (skribe-color->rgb spec)
+ (cond
+ ((and (= r 0) (= g 0) (= b 0))
+ "0.,0.,0.")
+ ((and (= r #xff) (= g #xff) (= b #xff))
+ "1.,1.,1.")
+ (else
+ (let ((ff (exact->inexact #xff)))
+ (format "~a,~a,~a"
+ (number->string (/ r ff))
+ (number->string (/ g ff))
+ (number->string (/ b ff))))))))
+
+;*---------------------------------------------------------------------*/
+;* skribe-latex-declare-colors ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-latex-declare-colors colors)
+ (set! *skribe-latex-color-table* (make-hashtable))
+ (for-each (lambda (spec)
+ (let ((old (hashtable-get *skribe-latex-color-table* spec)))
+ (if (not (string? old))
+ (let ((name (symbol->string (gensym 'c))))
+ ;; bind the color
+ (hashtable-put! *skribe-latex-color-table* spec name)
+ ;; and emit a latex declaration
+ (latex-declare-color
+ name
+ (skribe-color->latex-rgb spec))))))
+ colors))
+
+;*---------------------------------------------------------------------*/
+;* &~ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&~
+ :before "~"
+ :action #f)
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-start */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-start
+ :options '()
+ :action (lambda (n e)
+ (let ((width (markup-option n 'width)))
+ (if (number? width)
+ (printf "\\begin{tabular*}{~a}" (latex-width width))
+ (display "\\begin{tabular}")))))
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-stop */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-stop
+ :options '()
+ :action (lambda (n e)
+ (let ((width (markup-option n 'width)))
+ (if (number? width)
+ (display "\\end{tabular*}\n")
+ (display "\\end{tabular}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :env)
+ :before (lambda (n e)
+ ;; documentclass
+ (let ((dc (engine-custom e 'documentclass)))
+ (if dc
+ (begin (display dc) (newline))
+ (display "\\documentclass{article}\n")))
+ (if (latex-color? e)
+ (display (engine-custom e 'color-usepackage)))
+ (if (engine-custom e 'hyperref)
+ (display (engine-custom e 'hyperref-usepackage)))
+ ;; usepackage
+ (let ((pa (engine-custom e 'usepackage)))
+ (if pa (begin (display pa) (newline))))
+ ;; colors
+ (if (latex-color? e)
+ (begin
+ (skribe-use-color! (engine-custom e 'source-comment-color))
+ (skribe-use-color! (engine-custom e 'source-define-color))
+ (skribe-use-color! (engine-custom e 'source-module-color))
+ (skribe-use-color! (engine-custom e 'source-markup-color))
+ (skribe-use-color! (engine-custom e 'source-thread-color))
+ (skribe-use-color! (engine-custom e 'source-string-color))
+ (skribe-use-color! (engine-custom e 'source-bracket-color))
+ (skribe-use-color! (engine-custom e 'source-type-color))
+ (display "\n%% colors\n")
+ (skribe-latex-declare-colors (skribe-get-used-colors))
+ (display "\n\n")))
+ ;; predocument
+ (let ((pd (engine-custom e 'predocument)))
+ (when pd (display pd) (newline)))
+ ;; title
+ (let ((t (markup-option n :title)))
+ (when t
+ (skribe-eval (new markup
+ (markup '&latex-title)
+ (body t))
+ e
+ :env `((parent ,n)))))
+ ;; author
+ (let ((a (markup-option n :author)))
+ (when a
+ (skribe-eval (new markup
+ (markup '&latex-author)
+ (body a))
+ e
+ :env `((parent ,n)))))
+ ;; document
+ (display "\\begin{document}\n")
+ ;; postdocument
+ (let ((pd (engine-custom e 'postdocument)))
+ (if pd (begin (display pd) (newline))))
+ ;; maketitle
+ (let ((mt (engine-custom e 'maketitle)))
+ (if mt (begin (display mt) (newline)))))
+ :action (lambda (n e)
+ (output (markup-body n) e))
+ :after (lambda (n e)
+ (display "\n\\end{document}\n")))
+
+;*---------------------------------------------------------------------*/
+;* &latex-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-title
+ :before "\\title{"
+ :after "}\n")
+
+;*---------------------------------------------------------------------*/
+;* &latex-author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-author
+ :before "\\author{\\centerline{\n"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if (pair? body)
+ (begin
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "&latex-author-table"))
+ e)
+ (printf "{~a}\n" (make-string (length body) #\c))
+ (let loop ((as body))
+ (output (car as) e)
+ (if (pair? (cdr as))
+ (begin
+ (display " & ")
+ (loop (cdr as)))))
+ (display "\\\\\n")
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "&latex-author-table"))
+ e))
+ (output body e))))
+ :after "}}\n")
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "author"))
+ e)
+ (printf "{~a}\n"
+ (case (markup-option n :align)
+ ((left) "l")
+ ((right) "r")
+ (else "c"))))
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone)))
+ (define (row n)
+ (output n e)
+ (display "\\\\\n"))
+ ;; name
+ (if name (row name))
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (cond
+ ((pair? address)
+ (for-each row address))
+ ((string? address)
+ (row address)))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url))))
+ :after (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :predicate (lambda (n e) (markup-option n :photo))
+ :before (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "author"))
+ e)
+ (printf "{cc}\n"))
+ :action (lambda (n e)
+ (let ((photo (markup-option n :photo)))
+ (output photo e)
+ (display " & ")
+ (markup-option-add! n :photo #f)
+ (output n e)
+ (markup-option-add! n :photo photo)
+ (display "\\\\\n")))
+ :after (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options '()
+ :action (lambda (n e) (display "\\tableofcontents\n")))
+
+;*---------------------------------------------------------------------*/
+;* latex-block-before ... */
+;*---------------------------------------------------------------------*/
+(define (latex-block-before m)
+ (lambda (n e)
+ (let ((num (markup-option n :number)))
+ (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n)))
+ (printf "\\~a~a{" m (if (not num) "*" ""))
+ (output (markup-option n :title) latex-title-engine)
+ (display "}\n")
+ (when num
+ (printf "\\label{~a}\n" (string-canonicalize (markup-ident n)))))))
+
+;*---------------------------------------------------------------------*/
+;* section ... .. @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'chapter))
+
+;*---------------------------------------------------------------------*/
+;* section ... . @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'section))
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'subsection))
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'subsubsection))
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :options '(:title :number :toc :env)
+ :before (lambda (n e)
+ (when (and (>= (skribe-debug) 2) (location? (ast-loc n)))
+ (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n"
+ (ast-location n)))
+ (display "\\noindent "))
+ :after "\\par\n")
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :before "\\footnote{"
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :action (lambda (n e)
+ (display "\\makebox[\\linewidth]{}")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '()
+ :before "\\hrulefill"
+ :action #f)
+
+;*---------------------------------------------------------------------*/
+;* latex-color-counter */
+;*---------------------------------------------------------------------*/
+(define latex-color-counter 1)
+
+;*---------------------------------------------------------------------*/
+;* latex-color ... */
+;*---------------------------------------------------------------------*/
+(define latex-color
+ (lambda (bg fg n e)
+ (if (not (latex-color? e))
+ (output n e)
+ (begin
+ (if bg
+ (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter))
+ (set! latex-color-counter (+ latex-color-counter 1))
+ (if fg
+ (begin
+ (printf "\\textcolor{~a}{" (skribe-get-latex-color fg))
+ (output n e)
+ (display "}"))
+ (output n e))
+ (set! latex-color-counter (- latex-color-counter 1))
+ (if bg
+ (printf "\\egroup\\colorbox{~a}{\\box~a}%\n"
+ (skribe-get-latex-color bg) latex-color-counter))))))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:bg :fg :width)
+ :action (lambda (n e)
+ (let* ((w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (m (markup-option n :margin))
+ (tw (cond
+ ((not w)
+ #f)
+ ((and (integer? w) (exact? w))
+ w)
+ ((real? w)
+ (latex-width w)))))
+ (when bg
+ (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n")
+ (when m
+ (printf "\\addtolength{\\tabcolsep}{~a}"
+ (latex-width m)))
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "color"))
+ e)
+ (if tw
+ (printf "{p{~a}}\n" tw)
+ (printf "{l}\n")))
+ (latex-color bg fg (markup-body n) e)
+ (when bg
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "color"))
+ e)
+ (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ :options '(:width :border :margin)
+ :before (lambda (n e)
+ (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}")
+ (let ((m (markup-option n :margin)))
+ (when m
+ (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m))))
+ (newline))
+ :action (lambda (n e)
+ (let* ((b (markup-option n :border))
+ (w (markup-option n :width))
+ (tw (cond
+ ((not w)
+ ".96\\linewidth")
+ ((and (integer? w) (exact? w))
+ w)
+ ((real? w)
+ (latex-width w)))))
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "frame"))
+ e)
+ (if (and (integer? b) (> b 0))
+ (begin
+ (printf "{|p{~a}|}\\hline\n" tw)
+ (output (markup-body n) e)
+ (display "\\\\\\hline\n"))
+ (begin
+ (printf "{p{~a}}\n" tw)
+ (output (markup-body n) e)))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+ :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n")
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size)
+ :action (lambda (n e)
+ (let* ((size (markup-option n :size))
+ (cs (let ((n (engine-custom e '%font-size)))
+ (if (number? n)
+ n
+ 0)))
+ (ns (cond
+ ((and (integer? size) (exact? size))
+ (if (> size 0)
+ size
+ (+ cs size)))
+ ((and (number? size) (inexact? size))
+ (+ cs (inexact->exact size)))
+ ((string? size)
+ (let ((nb (string->number size)))
+ (if (not (number? nb))
+ (skribe-error
+ 'font
+ (format "Illegal font size ~s" size)
+ nb)
+ (+ cs nb))))))
+ (ne (make-engine (gensym 'latex)
+ :delegate e
+ :filter (engine-filter e)
+ :symbol-table (engine-symbol-table e)
+ :custom `((%font-size ,ns)
+ ,@(engine-customs e)))))
+ (printf "{\\~a{" (latex-font-size ns))
+ (output (markup-body n) ne)
+ (display "}}"))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\\begin{center}\n"))
+ ((left)
+ (display "\\begin{flushleft}"))
+ ((right)
+ (display "\\begin{flushright}"))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\\end{center}\n"))
+ ((left)
+ (display "\\end{flushleft}\n"))
+ ((right)
+ (display "\\end{flushright}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before "\\begin{center}\n"
+ :after "\\end{center}\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre
+ :before (lambda (n e)
+ (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{"
+ latex-color-counter)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "pre"))
+ e)
+ (display "{l}\n")
+ (set! latex-color-counter (+ latex-color-counter 1)))
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after (lambda (n e)
+ (set! latex-color-counter (- latex-color-counter 1))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "pre"))
+ e)
+ (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter)))
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before (lambda (n e)
+ (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{"
+ latex-color-counter)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "pre"))
+ e)
+ (display "{l}\n")
+ (set! latex-color-counter (+ latex-color-counter 1)))
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after (lambda (n e)
+ (set! latex-color-counter (- latex-color-counter 1))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "prog"))
+ e)
+ (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter)))
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\\\\\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before "\\begin{itemize}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{itemize} ")
+
+(markup-writer 'itemize
+ :predicate (lambda (n e) (markup-option n :symbol))
+ :options '(:symbol)
+ :before (lambda (n e)
+ (display "\\begin{list}{")
+ (output (markup-option n :symbol) e)
+ (display "}{}")
+ (newline))
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{list}\n")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before "\\begin{enumerate}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{enumerate}\n")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol)
+ :before "\\begin{description}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (for-each (lambda (i)
+ (display " \\item[")
+ (output i e)
+ (display "]\n"))
+ (if (pair? k) k (list k)))
+ (output (markup-body item) e)))
+ (markup-body n)))
+ :after "\\end{description}\n")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (if k
+ (begin
+ (display "[")
+ (output k e)
+ (display "] "))))
+ (output (markup-body n) e)))
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :before "\n\\begin{quote}\n"
+ :after "\n\\end{quote}")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend))
+ (mc (markup-option n :multicolumns)))
+ (display (if mc
+ "\\begin{figure*}[!th]\n"
+ "\\begin{figure}[ht]\n"))
+ (output (markup-body n) e)
+ (printf "\\caption{\\label{~a}" (string-canonicalize ident))
+ (output legend e)
+ (display (if mc
+ "}\\end{figure*}\n"
+ "}\\end{figure}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* table-column-number ... */
+;* ------------------------------------------------------------- */
+;* Computes how many columns are contained in a table. */
+;*---------------------------------------------------------------------*/
+(define (table-column-number t)
+ (define (row-columns row)
+ (let luup ((cells (markup-body row))
+ (nbcols 0))
+ (cond
+ ((null? cells)
+ nbcols)
+ ((pair? cells)
+ (luup (cdr cells)
+ (+ nbcols (markup-option (car cells) :colspan))))
+ (else
+ (skribe-type-error 'tr "Illegal tr body, " row "pair")))))
+ (let loop ((rows (markup-body t))
+ (nbcols 0))
+ (if (null? rows)
+ nbcols
+ (loop (cdr rows)
+ (max (row-columns (car rows)) nbcols)))))
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:width :frame :rules :cellstyle)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (nbcols (table-column-number n))
+ (id (markup-ident n))
+ (cla (markup-class n))
+ (rows (markup-body n)))
+ ;; the table header
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "table")
+ (options `((width ,width))))
+ e)
+ ;; store the actual number of columns
+ (markup-option-add! n '&nbcols nbcols)
+ ;; compute the table header
+ (let ((cols (cond
+ ((= nbcols 0)
+ (skribe-error 'table
+ "Illegal empty table"
+ n))
+ ((or (not width) (= nbcols 1))
+ (make-string nbcols #\c))
+ (else
+ (let ((v (make-vector
+ (- nbcols 1)
+ "@{\\extracolsep{\\fill}}c")))
+ (apply string-append
+ (cons "c" (vector->list v))))))))
+ (case frame
+ ((none)
+ (printf "{~a}\n" cols))
+ ((border box)
+ (printf "{|~a|}" cols)
+ (markup-option-add! n '&lhs #t)
+ (markup-option-add! n '&rhs #t)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format "~a-above" id))
+ (class "table-line-above"))
+ e))
+ ((above hsides)
+ (printf "{~a}" cols)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format "~a-above" id))
+ (class "table-line-above"))
+ e))
+ ((vsides)
+ (markup-option-add! n '&lhs #t)
+ (markup-option-add! n '&rhs #t)
+ (printf "{|~a|}\n" cols))
+ ((lhs)
+ (markup-option-add! n '&lhs #t)
+ (printf "{|~a}\n" cols))
+ ((rhs)
+ (markup-option-add! n '&rhs #t)
+ (printf "{~a|}\n" cols))
+ (else
+ (printf "{~a}\n" cols)))
+ ;; mark each row with appropriate '&tl (top-line)
+ ;; and &bl (bottom-line) options
+ (when (pair? rows)
+ (if (and (memq rules '(rows all))
+ (or (not (eq? cstyle 'collapse))
+ (not (memq frame '(border box above hsides)))))
+ (let ((frow (car rows)))
+ (if (is-markup? frow 'tr)
+ (markup-option-add! frow '&tl #t))))
+ (if (eq? rules 'header)
+ (let ((frow (car rows)))
+ (if (is-markup? frow 'tr)
+ (markup-option-add! frow '&bl #t))))
+ (when (and (pair? (cdr rows))
+ (memq rules '(rows all)))
+ (for-each (lambda (row)
+ (if (is-markup? row 'tr)
+ (markup-option-add! row '&bl #t)))
+ rows)
+ (markup-option-add! (car (last-pair rows)) '&bl #f))
+ (if (and (memq rules '(rows all))
+ (or (not (eq? cstyle 'collapse))
+ (not (memq frame '(border box above hsides)))))
+ (let ((lrow (car (last-pair rows))))
+ (if (is-markup? lrow 'tr)
+ (markup-option-add! lrow '&bl #t))))))))
+ :after (lambda (n e)
+ (case (markup-option n :frame)
+ ((hsides below box border)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format "~a-below" (markup-ident n)))
+ (class "table-hline-below"))
+ e)))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "table")
+ (options `((width ,(markup-option n :width)))))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-hline */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-hline
+ :action "\\hline\n")
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '()
+ :action (lambda (n e)
+ (let* ((parent (ast-parent n))
+ (_ (if (not (is-markup? parent 'table))
+ (skribe-type-error 'tr "Illegal parent, " parent
+ "#<table>")))
+ (nbcols (markup-option parent '&nbcols))
+ (lhs (markup-option parent '&lhs))
+ (rhs (markup-option parent '&rhs))
+ (rules (markup-option parent :rules))
+ (collapse (eq? (markup-option parent :cellstyle)
+ 'collapse))
+ (vrules (memq rules '(cols all)))
+ (cells (markup-body n)))
+ (if (markup-option n '&tl)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (markup-ident n))
+ (class (markup-class n)))
+ e))
+ (if (> nbcols 0)
+ (let laap ((nbc nbcols)
+ (cs cells))
+ (if (null? cs)
+ (when (> nbc 1)
+ (display " & ")
+ (laap (- nbc 1) cs))
+ (let* ((c (car cs))
+ (nc (- nbc (markup-option c :colspan))))
+ (when (= nbcols nbc)
+ (cond
+ ((and lhs vrules (not collapse))
+ (markup-option-add! c '&lhs "||"))
+ ((or lhs vrules)
+ (markup-option-add! c '&lhs #\|))))
+ (when (= nc 0)
+ (cond
+ ((and rhs vrules (not collapse))
+ (markup-option-add! c '&rhs "||"))
+ ((or rhs vrules)
+ (markup-option-add! c '&rhs #\|))))
+ (when (and vrules (> nc 0) (< nc nbcols))
+ (markup-option-add! c '&rhs #\|))
+ (output c e)
+ (when (> nc 0)
+ (display " & ")
+ (laap nc (cdr cs)))))))))
+ :after (lambda (n e)
+ (display "\\\\")
+ (if (markup-option n '&bl)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (markup-ident n))
+ (class (markup-class n)))
+ e)
+ (newline))))
+
+;*---------------------------------------------------------------------*/
+;* tc */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(:width :align :valign :colspan)
+ :action (lambda (n e)
+ (let ((id (markup-ident n))
+ (cla (markup-class n)))
+ (let* ((o0 (markup-body n))
+ (o1 (if (eq? (markup-option n 'markup) 'th)
+ (new markup
+ (markup '&latex-th)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o0))
+ o0))
+ (o2 (if (markup-option n :width)
+ (new markup
+ (markup '&latex-tc-parbox)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o1))
+ o1))
+ (o3 (if (or (> (markup-option n :colspan) 1)
+ (not (eq? (markup-option n :align)
+ 'center))
+ (markup-option n '&lhs)
+ (markup-option n '&rhs))
+ (new markup
+ (markup '&latex-tc-multicolumn)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o2))
+ o2)))
+ (output o3 e)))))
+
+;*---------------------------------------------------------------------*/
+;* &latex-th ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-th
+ :before "\\textsf{"
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* &latex-tc-parbox ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-tc-parbox
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (valign (markup-option n :valign)))
+ (printf "\\parbox{~a}{" (latex-width width))))
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* &latex-tc-multicolumn ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-tc-multicolumn
+ :before (lambda (n e)
+ (let ((colspan (markup-option n :colspan))
+ (lhs (or (markup-option n '&lhs) ""))
+ (rhs (or (markup-option n '&rhs) ""))
+ (align (case (markup-option n :align)
+ ((left) #\l)
+ ((center) #\c)
+ ((right) #\r)
+ (else #\c))))
+ (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs)))
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* image ... @label image@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("eps"))))))
+ (if (not (string? img))
+ (skribe-error 'latex "Illegal image" file)
+ (begin
+ (printf "\\epsfig{file=~a" (strip-ref-base img))
+ (if width (printf ", width=~a" (latex-width width)))
+ (if height (printf ", height=~apt" height))
+ (if zoom (printf ", zoom=\"~a\"" zoom))
+ (display "}"))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'roman :before "{\\textrm{" :after "}}")
+(markup-writer 'bold :before "{\\textbf{" :after "}}")
+(markup-writer 'underline :before "{\\underline{" :after "}}")
+(markup-writer 'emph :before "{\\em{" :after "}}")
+(markup-writer 'it :before "{\\textit{" :after "}}")
+(markup-writer 'code :before "{\\texttt{" :after "}}")
+(markup-writer 'var :before "{\\texttt{" :after "}}")
+(markup-writer 'sc :before "{\\sc{" :after "}}")
+(markup-writer 'sf :before "{\\sf{" :after "}}")
+(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}")
+(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}")
+
+(markup-writer 'tt
+ :before "{\\texttt{"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-tt-encoding)
+ :custom (engine-customs e)
+ :symbol-table (engine-symbol-table e))))
+ (output (markup-body n) ne)))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "``"
+ :after "''")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :before "{\\texttt{"
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (output (or text (markup-body n)) e)))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "\\label{~a}" (string-canonicalize (markup-ident n)))))
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page)
+ :action (lambda (n e)
+ (let ((t (markup-option n :text)))
+ (if t
+ (begin
+ (output t e)
+ (output "~" e (markup-writer-get '&~ e))))))
+ :after (lambda (n e)
+ (let* ((c (handle-ast (markup-body n)))
+ (id (markup-ident c)))
+ (if (markup-option n :page)
+ (printf "\\begin{math}{\\pageref{~a}}\\end{math}"
+ (string-canonicalize id))
+ (printf "\\ref{~a}"
+ (string-canonicalize id))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (output (markup-option (handle-ast (markup-body n)) :title) e))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text))
+ (url (markup-option n :url)))
+ (if (not text)
+ (output url e)
+ (output text e)))))
+
+;*---------------------------------------------------------------------*/
+;* url-ref hyperref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :predicate (lambda (n e)
+ (engine-custom e 'hyperref))
+ :action (lambda (n e)
+ (let ((body (markup-option n :text))
+ (url (markup-option n :url)))
+ (if (and body (not (equal? body url)))
+ (begin
+ (display "\\href{")
+ (display url)
+ (display "}{")
+ (output body e)
+ (display "}"))
+ (begin
+ (display "\\href{")
+ (display url)
+ (printf "}{~a}" url))))))
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before "{\\textit{"
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (cond
+ ((and (number? o) (number? v))
+ (display (+ o v)))
+ (else
+ (display v)))))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ (display "{%
+\\sloppy
+\\sfcode`\\.=1000\\relax
+\\newdimen\\bibindent
+\\bibindent=0em
+\\begin{list}{}{%
+ \\settowidth\\labelwidth{[21]}%
+ \\leftmargin\\labelwidth
+ \\advance\\leftmargin\\labelsep
+ \\advance\\leftmargin\\bibindent
+ \\itemindent -\\bibindent
+ \\listparindent \\itemindent
+ \\itemsep 0pt
+ }%\n"))
+ :after (lambda (n e)
+ (display "\n\\end{list}}\n")))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :action (lambda (n e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (output n e (markup-writer-get '&bib-entry-body e)))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :predicate (lambda (n e)
+ (engine-custom e 'hyperref))
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before "\\item[{\\char91}"
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "{\\char93}] ")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (underline (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-error ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'error-color) cc)
+ (color :fg cc (underline n1))
+ (underline n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm
new file mode 100644
index 0000000..4f26d12
--- /dev/null
+++ b/src/guile/skribilo/engine/xml.scm
@@ -0,0 +1,113 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/xml.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Tue Sep 2 09:46:09 2003 */
+;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Generic XML Skribe engine */
+;* ------------------------------------------------------------- */
+;* Implementation: */
+;* common: @path ../src/common/api.src@ */
+;* bigloo: @path ../src/bigloo/api.bgl@ */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/xmle.skb:ref@ */
+;*=====================================================================*/
+
+(define-skribe-module (skribilo engine xml))
+
+;*---------------------------------------------------------------------*/
+;* xml-engine ... */
+;*---------------------------------------------------------------------*/
+(define xml-engine
+ ;; setup the xml engine
+ (default-engine-set!
+ (make-engine 'xml
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "<")
+ (#\> ">")
+ (#\& "&")
+ (#\" """)
+ (#\@ "@"))))))
+
+;*---------------------------------------------------------------------*/
+;* markup ... */
+;*---------------------------------------------------------------------*/
+(let ((xml-margin 0))
+ (define (make-margin)
+ (make-string xml-margin #\space))
+ (define (xml-attribute? val)
+ (cond
+ ((or (string? val) (number? val) (boolean? val))
+ #t)
+ ((list? val)
+ (every? xml-attribute? val))
+ (else
+ #f)))
+ (define (xml-attribute att val)
+ (let ((s (keyword->string att)))
+ (printf " ~a=\"" (substring s 1 (string-length s)))
+ (let loop ((val val))
+ (cond
+ ((or (string? val) (number? val))
+ (display val))
+ ((boolean? val)
+ (display (if val "true" "false")))
+ ((pair? val)
+ (for-each loop val))
+ (else
+ #f)))
+ (display #\")))
+ (define (xml-option opt val e)
+ (let* ((m (make-margin))
+ (ks (keyword->string opt))
+ (s (substring ks 1 (string-length ks))))
+ (printf "~a<~a>\n" m s)
+ (output val e)
+ (printf "~a</~a>\n" m s)))
+ (define (xml-options n e)
+ ;; display the true options
+ (let ((opts (filter (lambda (o)
+ (and (keyword? (car o))
+ (not (xml-attribute? (cadr o)))))
+ (markup-options n))))
+ (if (pair? opts)
+ (let ((m (make-margin)))
+ (display m)
+ (display "<options>\n")
+ (set! xml-margin (+ xml-margin 1))
+ (for-each (lambda (o)
+ (xml-option (car o) (cadr o) e))
+ opts)
+ (set! xml-margin (- xml-margin 1))
+ (display m)
+ (display "</options>\n")))))
+ (markup-writer #t
+ :options 'all
+ :before (lambda (n e)
+ (printf "~a<~a" (make-margin) (markup-markup n))
+ ;; display the xml attributes
+ (for-each (lambda (o)
+ (if (and (keyword? (car o))
+ (xml-attribute? (cadr o)))
+ (xml-attribute (car o) (cadr o))))
+ (markup-options n))
+ (set! xml-margin (+ xml-margin 1))
+ (display ">\n"))
+ :action (lambda (n e)
+ ;; options
+ (xml-options n e)
+ ;; body
+ (output (markup-body n) e))
+ :after (lambda (n e)
+ (printf "~a</~a>\n" (make-margin) (markup-markup n))
+ (set! xml-margin (- xml-margin 1)))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/eval.scm b/src/guile/skribilo/eval.scm
deleted file mode 100644
index 8bae8ad..0000000
--- a/src/guile/skribilo/eval.scm
+++ /dev/null
@@ -1,186 +0,0 @@
-;;;
-;;; eval.stk -- Skribe Evaluator
-;;;
-;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;; Copyright 2005 Ludovic Court�s <ludovic.courtes@laas.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;; USA.
-;;;
-
-
-
-;; FIXME; On peut impl�menter maintenant skribe-warning/node
-
-
-(define-module (skribilo eval)
- :export (skribe-eval skribe-eval-port skribe-load skribe-load-options
- skribe-include
-
- run-time-module make-run-time-module))
-
-(use-modules (skribilo debug)
- (skribilo engine)
- (skribilo verify)
- (skribilo resolve)
- (skribilo output)
- (ice-9 optargs))
-
-
-(define *skribe-loaded* '()) ;; List of already loaded files
-(define *skribe-load-options* '())
-
-(define (%evaluate expr)
- (eval expr (current-module)))
-
-
-(define *skribilo-user-module* #f)
-
-(define *skribilo-user-imports*
- '((srfi srfi-1)
- (oop goops)
- (skribilo module)
- (skribilo config)
- (skribilo vars)
- (skribilo runtime)
- (skribilo biblio)
- (skribilo lib)
- (skribilo resolve)))
-
-
-;;;
-;;; MAKE-RUN-TIME-MODULE
-;;;
-(define (make-run-time-module)
- "Return a new module that imports all the necessary bindings required for
-execution of Skribilo/Skribe code."
- (let ((the-module (make-module)))
- (for-each (lambda (iface)
- (module-use! the-module (resolve-module iface)))
- *skribilo-user-imports*)
- (set-module-name! the-module '(skribilo-user))
- the-module))
-
-;;;
-;;; RUN-TIME-MODULE
-;;;
-(define (run-time-module)
- "Return the default instance of a Skribilo/Skribe run-time module."
- (if (not *skribilo-user-module*)
- (set! *skribilo-user-module* (make-run-time-module)))
- *skribilo-user-module*)
-
-;;;
-;;; SKRIBE-EVAL
-;;;
-(define* (skribe-eval a e #:key (env '()))
- (with-debug 2 'skribe-eval
- (debug-item "a=" a " e=" (engine-ident e))
- (let ((a2 (resolve! a e env)))
- (debug-item "resolved a=" a)
- (let ((a3 (verify a2 e)))
- (debug-item "verified a=" a3)
- (output a3 e)))))
-
-;;;
-;;; SKRIBE-EVAL-PORT
-;;;
-(define* (skribe-eval-port port engine #:key (env '()))
- (with-debug 2 'skribe-eval-port
- (debug-item "engine=" engine)
- (let ((e (if (symbol? engine) (find-engine engine) engine)))
- (debug-item "e=" e)
- (if (not (is-a? e <engine>))
- (skribe-error 'skribe-eval-port "Cannot find engine" engine)
- (let loop ((exp (read port)))
- (with-debug 10 'skribe-eval-port
- (debug-item "exp=" exp))
- (unless (eof-object? exp)
- (skribe-eval (%evaluate exp) e :env env)
- (loop (read port))))))))
-
-;;;
-;;; SKRIBE-LOAD
-;;;
-(define *skribe-load-options* '())
-
-(define (skribe-load-options)
- *skribe-load-options*)
-
-(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt)
- (with-debug 4 'skribe-load
- (debug-item " engine=" engine)
- (debug-item " path=" path)
- (debug-item " opt" opt)
-
- (let* ((ei (cond
- ((not engine) *skribe-engine*)
- ((engine? engine) engine)
- ((not (symbol? engine)) (skribe-error 'skribe-load
- "Illegal engine" engine))
- (else engine)))
- (path (cond
- ((not path) (skribe-path))
- ((string? path) (list path))
- ((not (and (list? path) (every? string? path)))
- (skribe-error 'skribe-load "Illegal path" path))
- (else path)))
- (filep (find-path file path)))
-
- (set! *skribe-load-options* opt)
-
- (unless (and (string? filep) (file-exists? filep))
- (skribe-error 'skribe-load
- (format "Cannot find ~S in path" file)
- *skribe-path*))
-
- ;; Load this file if not already done
- (unless (member filep *skribe-loaded*)
- (cond
- ((> *skribe-verbose* 1)
- (format (current-error-port) " [loading file: ~S ~S]\n" filep opt))
- ((> *skribe-verbose* 0)
- (format (current-error-port) " [loading file: ~S]\n" filep)))
- ;; Load it
- (with-input-from-file filep
- (lambda ()
- (skribe-eval-port (current-input-port) ei)))
- (set! *skribe-loaded* (cons filep *skribe-loaded*))))))
-
-;;;
-;;; SKRIBE-INCLUDE
-;;;
-(define* (skribe-include file #:optional (path (skribe-path)))
- (unless (every string? path)
- (skribe-error 'skribe-include "Illegal path" path))
-
- (let ((path (find-path file path)))
- (unless (and (string? path) (file-exists? path))
- (skribe-error 'skribe-load
- (format "Cannot find ~S in path" file)
- path))
- (when (> *skribe-verbose* 0)
- (format (current-error-port) " [including file: ~S]\n" path))
- (with-input-from-file path
- (lambda ()
- (let Loop ((exp (read (current-input-port)))
- (res '()))
- (if (eof-object? exp)
- (if (and (pair? res) (null? (cdr res)))
- (car res)
- (reverse! res))
- (Loop (read (current-input-port))
- (cons (%evaluate exp) res))))))))
diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm
new file mode 100644
index 0000000..b7e04c1
--- /dev/null
+++ b/src/guile/skribilo/evaluator.scm
@@ -0,0 +1,207 @@
+;;;
+;;; eval.stk -- Skribe Evaluator
+;;;
+;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2005 Ludovic Court�s <ludovic.courtes@laas.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+;;;
+
+
+
+;; FIXME; On peut impl�menter maintenant skribe-warning/node
+
+
+(define-module (skribilo evaluator)
+ :export (skribe-eval skribe-eval-port skribe-load skribe-load-options
+ skribe-include))
+
+(use-modules (skribilo debug)
+ (skribilo reader)
+ (skribilo engine)
+ (skribilo verify)
+ (skribilo resolve)
+ (skribilo output)
+ (skribilo types)
+ (skribilo lib)
+ (skribilo vars)
+ (ice-9 optargs)
+ (oop goops))
+
+
+
+;;; FIXME: The following page must eventually go to `module.scm'.
+
+(define *skribilo-user-module* #f)
+
+(define *skribilo-user-imports*
+ '((srfi srfi-1)
+ (srfi srfi-13)
+ (oop goops)
+ (skribilo module)
+ (skribilo config)
+ (skribilo vars)
+ (skribilo runtime)
+ (skribilo biblio)
+ (skribilo lib)
+ (skribilo resolve)
+ (skribilo engine)
+ (skribilo writer)))
+
+(define *skribe-core-modules* ;;; FIXME: From `module.scm'.
+ '("utils" "api" "bib" "index" "param" "sui"))
+
+;;;
+;;; MAKE-RUN-TIME-MODULE
+;;;
+(define-public (make-run-time-module)
+ "Return a new module that imports all the necessary bindings required for
+execution of Skribilo/Skribe code."
+ (let ((the-module (make-module)))
+ (for-each (lambda (iface)
+ (module-use! the-module (resolve-module iface)))
+ (append *skribilo-user-imports*
+ (map (lambda (mod)
+ `(skribilo skribe
+ ,(string->symbol mod)))
+ *skribe-core-modules*)))
+ (set-module-name! the-module '(skribilo-user))
+ the-module))
+
+;;;
+;;; RUN-TIME-MODULE
+;;;
+(define-public (run-time-module)
+ "Return the default instance of a Skribilo/Skribe run-time module."
+ (if (not *skribilo-user-module*)
+ (set! *skribilo-user-module* (make-run-time-module)))
+ *skribilo-user-module*)
+
+
+
+(define *skribe-loaded* '()) ;; List of already loaded files
+(define *skribe-load-options* '())
+
+(define (%evaluate expr)
+ (eval expr (current-module)))
+
+
+
+
+;;;
+;;; SKRIBE-EVAL
+;;;
+(define* (skribe-eval a e #:key (env '()))
+ (with-debug 2 'skribe-eval
+ (debug-item "a=" a " e=" (engine-ident e))
+ (let ((a2 (resolve! a e env)))
+ (debug-item "resolved a=" a)
+ (let ((a3 (verify a2 e)))
+ (debug-item "verified a=" a3)
+ (output a3 e)))))
+
+;;;
+;;; SKRIBE-EVAL-PORT
+;;;
+(define* (skribe-eval-port port engine #:key (env '())
+ (reader %default-reader))
+ (with-debug 2 'skribe-eval-port
+ (debug-item "engine=" engine)
+ (let ((e (if (symbol? engine) (find-engine engine) engine)))
+ (debug-item "e=" e)
+ (if (not (is-a? e <engine>))
+ (skribe-error 'skribe-eval-port "cannot find engine" engine)
+ (let loop ((exp (reader port)))
+ (with-debug 10 'skribe-eval-port
+ (debug-item "exp=" exp))
+ (unless (eof-object? exp)
+ (skribe-eval (%evaluate exp) e :env env)
+ (loop (reader port))))))))
+
+;;;
+;;; SKRIBE-LOAD
+;;;
+(define *skribe-load-options* '())
+
+(define (skribe-load-options)
+ *skribe-load-options*)
+
+(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt)
+ (with-debug 4 'skribe-load
+ (debug-item " engine=" engine)
+ (debug-item " path=" path)
+ (debug-item " opt=" opt)
+
+ (let* ((ei (cond
+ ((not engine) *skribe-engine*)
+ ((engine? engine) engine)
+ ((not (symbol? engine))
+ (skribe-error 'skribe-load
+ "Illegal engine" engine))
+ (else engine)))
+ (path (cond
+ ((not path) (skribe-path))
+ ((string? path) (list path))
+ ((not (and (list? path) (every? string? path)))
+ (skribe-error 'skribe-load "Illegal path" path))
+ (else path)))
+ (filep (search-path path file)))
+
+ (set! *skribe-load-options* opt)
+
+ (unless (and (string? filep) (file-exists? filep))
+ (skribe-error 'skribe-load
+ (string-append "cannot find `" file "' in path")
+ (skribe-path)))
+
+ ;; Load this file if not already done
+ (unless (member filep *skribe-loaded*)
+ (cond
+ ((> *skribe-verbose* 1)
+ (format (current-error-port) " [loading file: ~S ~S]\n" filep opt))
+ ((> *skribe-verbose* 0)
+ (format (current-error-port) " [loading file: ~S]\n" filep)))
+ ;; Load it
+ (with-input-from-file filep
+ (lambda ()
+ (skribe-eval-port (current-input-port) ei)))
+ (set! *skribe-loaded* (cons filep *skribe-loaded*))))))
+
+;;;
+;;; SKRIBE-INCLUDE
+;;;
+(define* (skribe-include file #:optional (path (skribe-path)))
+ (unless (every string? path)
+ (skribe-error 'skribe-include "Illegal path" path))
+
+ (let ((path (search-path path file)))
+ (unless (and (string? path) (file-exists? path))
+ (skribe-error 'skribe-load
+ (format "Cannot find ~S in path" file)
+ path))
+ (when (> *skribe-verbose* 0)
+ (format (current-error-port) " [including file: ~S]\n" path))
+ (with-input-from-file path
+ (lambda ()
+ (let Loop ((exp (read (current-input-port)))
+ (res '()))
+ (if (eof-object? exp)
+ (if (and (pair? res) (null? (cdr res)))
+ (car res)
+ (reverse! res))
+ (Loop (read (current-input-port))
+ (cons (%evaluate exp) res))))))))
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index 26b348a..bb41597 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -32,6 +32,13 @@
skribe-warning skribe-warning/ast
skribe-message
+ ;; paths as lists of directories
+
+ %skribilo-load-path
+ %skribilo-image-path %skribilo-bib-path %skribilo-source-path
+
+ ;; compatibility
+
skribe-path skribe-path-set!
skribe-image-path skribe-image-path-set!
skribe-bib-path skribe-bib-path-set!
@@ -45,6 +52,7 @@
printf fprintf
any? every?
process-input-port process-output-port process-error-port
+ %procedure-arity
make-hashtable hashtable?
hashtable-get hashtable-put! hashtable-update!
@@ -58,6 +66,9 @@
;; for compatibility
unwind-protect unless when)
+ :use-module (skribilo config)
+ :use-module (skribilo types)
+
:use-module (srfi srfi-1)
:use-module (ice-9 optargs))
@@ -79,7 +90,7 @@
(define-macro (define-markup bindings . body)
;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the
- ;; `#:rest' argument can only appear last which not what Skribe/DSSSL
+ ;; `#:rest' argument can only appear last, which is not what Skribe/DSSSL
;; expect, hence `fix-rest-arg'.
(define (fix-rest-arg args)
(let loop ((args args)
@@ -256,44 +267,34 @@
(Loop (cdr l))))))
-
+
;;; ======================================================================
;;;
;;; A C C E S S O R S
;;;
;;; ======================================================================
-;; SKRIBE-PATH
-(define (skribe-path) *skribe-path*)
-
-(define (skribe-path-set! path)
- (if (not (and (list? path) (every string? path)))
- (skribe-error 'skribe-path-set! "Illegal path" path)
- (set! *skribe-path* path)))
-;; SKRIBE-IMAGE-PATH
-(define (skribe-image-path) *skribe-image-path*)
+(define %skribilo-load-path (list (skribilo-default-path) "."))
+(define %skribilo-image-path '("."))
+(define %skribilo-bib-path '("."))
+(define %skribilo-source-path '("."))
-(define (skribe-image-path-set! path)
- (if (not (and (list? path) (every string? path)))
- (skribe-error 'skribe-image-path-set! "Illegal path" path)
- (set! *skribe-image-path* path)))
+(define-macro (define-compatibility-accessors var oldname)
+ (let ((newname (symbol-append '%skribilo- var))
+ (setter (symbol-append oldname '-set!)))
+ `(begin
+ (define (,oldname) ,newname)
+ (define (,setter path)
+ (if (not (and (list? path) (every string? path)))
+ (skribe-error ',setter "illegal path" path)
+ (set! ,newname path))))))
-;; SKRIBE-BIB-PATH
-(define (skribe-bib-path) *skribe-bib-path*)
+(define-compatibility-accessors load-path skribe-path)
+(define-compatibility-accessors image-path skribe-image-path)
+(define-compatibility-accessors bib-path skribe-bib-path)
+(define-compatibility-accessors source-path skribe-source-path)
-(define (skribe-bib-path-set! path)
- (if (not (and (list? path) (every string? path)))
- (skribe-error 'skribe-bib-path-set! "Illegal path" path)
- (set! *skribe-bib-path* path)))
-
-;; SKRBE-SOURCE-PATH
-(define (skribe-source-path) *skribe-source-path*)
-
-(define (skribe-source-path-set! path)
- (if (not (and (list? path) (every string? path)))
- (skribe-error 'skribe-source-path-set! "Illegal path" path)
- (set! *skribe-source-path* path)))
;;; ======================================================================
@@ -346,6 +347,14 @@
(define find-runtime-type (lambda (obj) obj))
+
+;;;
+;;; Various things.
+;;;
+
+(define (%procedure-arity proc)
+ (car (procedure-property proc 'arity)))
+
(define-macro (unwind-protect expr1 expr2)
;; This is no completely correct.
`(dynamic-wind
@@ -353,8 +362,8 @@
(lambda () ,expr1)
(lambda () ,expr2)))
-(define-macro (unless expr body)
- `(if (not ,expr) ,body))
+(define-macro (unless condition . exprs)
+ `(if (not ,condition) (begin ,@exprs)))
-(define-macro (when expr . exprs)
- `(if ,expr (begin ,@exprs)))
+(define-macro (when condition . exprs)
+ `(if ,condition (begin ,@exprs)))
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 4d29f31..50c7b23 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -20,7 +20,8 @@
(define-module (skribilo module)
:use-module (skribilo reader)
- :use-module (skribilo eval)
+ :use-module (skribilo evaluator)
+ :use-module (skribilo debug)
:use-module (ice-9 optargs))
;;; Author: Ludovic Court�s
@@ -43,7 +44,10 @@
;; to actually create and read the module.
(use-modules (skribilo module)
(skribilo reader)
- (skribilo eval) ;; `run-time-module'
+ (skribilo evaluator) ;; `run-time-module'
+ (skribilo engine)
+ (skribilo writer)
+ (skribilo types)
(srfi srfi-1)
(ice-9 optargs)
@@ -53,26 +57,26 @@
(skribilo vars)
(skribilo config))
- (use-syntax (skribilo lib))
;; The `define' below results in a module-local definition. So the
;; definition of `read' in the `(guile-user)' module is left untouched.
;(define read ,(make-reader 'skribe))
;; Everything is exported.
- (define-macro (define . things)
- (let* ((first (car things))
- (binding (cond ((symbol? first) first)
- ((list? first) (car first))
- ((pair? first) (car first))
- (else
- (error "define/skribe: bad formals" first)))))
- `(begin
- (define-public ,@things)
- ;; Automatically push it to the run-time user module.
-; (module-define! ,(run-time-module)
-; (quote ,binding) ,binding)
- )))))
+; (define-macro (define . things)
+; (let* ((first (car things))
+; (binding (cond ((symbol? first) first)
+; ((list? first) (car first))
+; ((pair? first) (car first))
+; (else
+; (error "define/skribe: bad formals" first)))))
+; `(begin
+; (define-public ,@things)
+; ;; Automatically push it to the run-time user module.
+; ; (module-define! ,(run-time-module)
+; ; (quote ,binding) ,binding)
+; )))
+ ))
;; Make it available to the top-level module.
@@ -80,39 +84,44 @@
'define-skribe-module define-skribe-module)
+(define-public *skribe-core-modules*
+ '("utils" "api" "bib" "index" "param" "sui"))
+
+
+
+;; FIXME: This will eventually be replaced by the per-module reader thing in
+;; Guile.
(define-public (load-file-with-read file read module)
- (with-input-from-file file
- (lambda ()
+ (with-debug 5 'load-file-with-read
+ (debug-item "loading " file)
+
+ (with-input-from-file (search-path %load-path file)
+ (lambda ()
; (format #t "load-file-with-read: ~a~%" read)
- (let loop ((sexp (read))
- (result #f))
- (if (eof-object? sexp)
- result
- (begin
+ (let loop ((sexp (read))
+ (result #f))
+ (if (eof-object? sexp)
+ result
+ (begin
; (format #t "preparing to evaluate `~a'~%" sexp)
- (loop (read)
- (eval sexp module))))))))
+ (loop (read)
+ (primitive-eval sexp)))))))))
(define-public (load-skribilo-file file reader-name)
(load-file-with-read file (make-reader reader-name) (current-module)))
-(define-public *skribe-core-modules*
- '("utils" "api" "bib" "index" "param" "sui"))
-
(define*-public (load-skribe-modules #:optional (debug? #f))
"Load the core Skribe modules, both in the @code{(skribilo skribe)}
hierarchy and in @code{(run-time-module)}."
(for-each (lambda (mod)
- (if debug?
- (format #t "loading skribe module `~a'...~%" mod))
- (load-skribilo-file (string-append "skribe/" mod ".scm")
- 'skribe))
- *skribe-core-modules*)
- (for-each (lambda (mod)
+ (format #t "~~ loading skribe module `~a'...~%" mod)
+ (load-skribilo-file (string-append "skribilo/skribe/"
+ mod ".scm")
+ 'skribe)
(module-use! (run-time-module)
- (resolve-interface (list skribilo skribe
- (string->symbol
- mod)))))
+ (resolve-module `(skribilo skribe
+ ,(string->symbol mod)))))
*skribe-core-modules*))
+
;;; module.scm ends here
diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm
index cc690ec..eeff397 100644
--- a/src/guile/skribilo/output.scm
+++ b/src/guile/skribilo/output.scm
@@ -1,24 +1,24 @@
;;;;
;;;; output.stk -- Skribe Output Stage
-;;;;
+;;;;
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 13-Aug-2003 18:42 (eg)
;;;; Last file update: 5-Mar-2004 10:32 (eg)
@@ -29,8 +29,8 @@
(use-modules (skribilo debug)
(skribilo types)
-; (skribe engine)
-; (skribe writer)
+; (skribilo engine)
+ (skribilo writer)
(oop goops))
@@ -47,7 +47,7 @@
(invoke (slot-ref w 'action) n e)
(invoke (slot-ref w 'after) n e))))
-
+
(define (output node e . writer)
(with-debug 3 'output
@@ -135,7 +135,7 @@
(+ (- (char->integer c)
(char->integer #\0))
(* 10 n))))))))
-
+
(let loop ((i 0))
(cond
((= i lf)
diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm
index a149ab1..27c740b 100644
--- a/src/guile/skribilo/reader.scm
+++ b/src/guile/skribilo/reader.scm
@@ -21,7 +21,8 @@
(define-module (skribilo reader)
:use-module (srfi srfi-9) ;; records
:use-module (srfi srfi-17) ;; generalized `set!'
- :export (%make-reader lookup-reader make-reader)
+ :export (%make-reader lookup-reader make-reader
+ %default-reader)
:export-syntax (define-reader define-public-reader))
;;; Author: Ludovic Court�s
@@ -65,7 +66,7 @@
(define (lookup-reader name)
"Look for a reader named @var{name} (a symbol) in the @code{(skribilo
-readers)} module hierarchy. If no such reader was found, an error is
+reader)} module hierarchy. If no such reader was found, an error is
raised."
(let ((m (resolve-module `(skribilo reader ,name))))
(if (module-bound? m 'reader-specification)
@@ -78,5 +79,6 @@ raised."
(make (reader:make spec)))
(make)))
+(define %default-reader (make-reader 'skribe))
;;; reader.scm ends here
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 2dc5e98..e59a2f8 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -50,11 +50,13 @@
(define (resolve! ast engine env)
(with-debug 3 'resolve
(debug-item "ast=" ast)
- (fluid-let ((*unresolved* #f))
+ (let ((*unresolved* (make-fluid)))
+ (fluid-set! *unresolved* #f)
+
(let Loop ((ast ast))
- (set! *unresolved* #f)
+ (fluid-set! *unresolved* #f)
(let ((ast (do-resolve! ast engine env)))
- (if *unresolved*
+ (if (fluid-ref *unresolved*)
(Loop ast)
ast))))))
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm
index af76237..2642f7e 100644
--- a/src/guile/skribilo/runtime.scm
+++ b/src/guile/skribilo/runtime.scm
@@ -48,7 +48,7 @@
(skribilo verify)
(skribilo resolve)
(skribilo output)
- (skribilo eval)
+ (skribilo evaluator)
(oop goops))
@@ -195,7 +195,7 @@
to))))))
(define (convert-image file formats)
- (let ((path (find-path file (skribe-image-path))))
+ (let ((path (search-path (skribe-image-path) file)))
(if (not path)
(skribe-error 'convert-image
(format "Can't find `~a' image file in path: " file)
@@ -259,14 +259,17 @@
(display (if res (cadr res) ch) out)))
(get-output-string out))))
+(define string->html
+ (%make-general-string-replace '((#\" """) (#\& "&") (#\< "<")
+ (#\> ">"))))
(define (make-string-replace lst)
(let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
(cond
((equal? l '((#\" """) (#\& "&") (#\< "<") (#\> ">")))
- string->html)
+ string->html)
(else
- (%make-general-string-replace lst)))))
+ (%make-general-string-replace lst)))))
diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm
index e56f350..1e88d45 100644
--- a/src/guile/skribilo/source.scm
+++ b/src/guile/skribilo/source.scm
@@ -42,7 +42,7 @@
;* source-read-lines ... */
;*---------------------------------------------------------------------*/
(define (source-read-lines file start stop tab)
- (let ((p (find-path file (skribe-source-path))))
+ (let ((p (search-path (skribe-source-path) file)))
(if (or (not (string? p)) (not (file-exists? p)))
(skribe-error 'source
(format "Can't find `~a' source file in path" file)
@@ -119,7 +119,7 @@
;* source-read-definition ... */
;*---------------------------------------------------------------------*/
(define (source-read-definition file definition tab lang)
- (let ((p (find-path file (skribe-source-path))))
+ (let ((p (search-path (skribe-source-path) file)))
(cond
((not (language-extractor lang))
(skribe-error 'source
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
index 048dcfb..70ba817 100644
--- a/src/guile/skribilo/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -1,24 +1,24 @@
;;;;
;;;; writer.stk -- Skribe Writer Stuff
-;;;;
+;;;;
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Sep-2003 22:21 (eg)
;;;; Last file update: 4-Mar-2004 10:48 (eg)
@@ -31,8 +31,10 @@
(use-modules (skribilo debug)
-; (skribilo engine)
+ (skribilo engine)
(skribilo output)
+ (skribilo types)
+ (skribilo lib)
(oop goops)
(ice-9 optargs))
@@ -40,7 +42,7 @@
;;;; ======================================================================
;;;;
-;;;; INVOKE
+;;;; INVOKE
;;;;
;;;; ======================================================================
(define (invoke proc node e)
@@ -56,7 +58,7 @@
;;;; ======================================================================
;;;;
-;;;; LOOKUP-MARKUP-WRITER
+;;;; LOOKUP-MARKUP-WRITER
;;;;
;;;; ======================================================================
(define (lookup-markup-writer node e)
@@ -76,7 +78,7 @@
;;;; ======================================================================
;;;;
-;;;; MAKE-WRITER-PREDICATE
+;;;; MAKE-WRITER-PREDICATE
;;;;
;;;; ======================================================================
(define (make-writer-predicate markup predicate class)
@@ -104,26 +106,55 @@
;;;; ======================================================================
;;;;
-;;;; MARKUP-WRITER
+;;;; MARKUP-WRITER
;;;;
;;;; ======================================================================
-(define* (markup-writer markup #:optional engine
+; (define-macro (lambda** arglist . body)
+; (let ((parse-arglist (module-ref (resolve-module '(ice-9 optargs))
+; 'parse-arglist)))
+; (parse-arglist
+; arglist
+; (lambda (mandatory-args optionals keys aok? rest-arg)
+; (let ((l**-rest-arg (gensym "L**-rest"))
+; (l**-loop (gensym "L**-loop")))
+; `(lambda (,@mandatory-args . ,l**-rest-arg)
+; `(let ,l**-loop ((,l**-rest-arg ,l**-rest-arg)
+; (,rest-arg '())
+; ,@optionals
+; ,@keys)
+; (if (null? ,l**-rest-arg)
+; (begin
+; ,@body)
+
+(define* (markup-writer markup ;; #:optional (engine #f)
#:key (predicate #f) (class #f) (options '())
- (validate #f)
- (before #f) (action 'unspecified) (after #f))
- (let ((e (or engine (default-engine))))
+ (validate #f)
+ (before #f)
+ (action 'unspecified)
+ (after #f)
+ #:rest engine)
+ ;;; FIXME: `lambda*' sucks and fails when both optional arguments and
+ ;;; keyword arguments are used together. In particular, if ENGINE is not
+ ;;; specified by the caller but other keyword arguments are specified, it
+ ;;; will consider the value of ENGINE to be the first keyword found.
+
+; (let ((e (or engine (default-engine))))
+ (let ((e (or (and (list? engine)
+ (not (keyword? (car engine))))
+ (default-engine))))
+
(cond
((and (not (symbol? markup)) (not (eq? markup #t)))
- (skribe-error 'markup-writer "Illegal markup" markup))
+ (skribe-error 'markup-writer "illegal markup" markup))
((not (engine? e))
- (skribe-error 'markup-writer "Illegal engine" e))
+ (skribe-error 'markup-writer "illegal engine" e))
((and (not predicate)
(not class)
(null? options)
(not before)
(eq? action 'unspecified)
(not after))
- (skribe-error 'markup-writer "Illegal writer" markup))
+ (skribe-error 'markup-writer "illegal writer" markup))
(else
(let ((m (make-writer-predicate markup predicate class))
(ac (if (eq? action 'unspecified)
@@ -135,35 +166,35 @@
;;;; ======================================================================
;;;;
-;;;; MARKUP-WRITER-GET
+;;;; MARKUP-WRITER-GET
;;;;
;;;; ======================================================================
(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f))
(let ((e (or engine (default-engine))))
(cond
((not (symbol? markup))
- (skribe-error 'markup-writer-get "Illegal symbol" markup))
+ (skribe-error 'markup-writer-get "Illegal symbol" markup))
((not (engine? e))
- (skribe-error 'markup-writer-get "Illegal engine" e))
+ (skribe-error 'markup-writer-get "Illegal engine" e))
(else
(let liip ((e e))
(let loop ((w* (slot-ref e 'writers)))
(cond
((pair? w*)
- (if (and (eq? (writer-ident (car w*)) markup)
+ (if (and (eq? (writer-ident (car w*)) markup)
(equal? (writer-class (car w*)) class)
(or (unspecified? pred)
(eq? (slot-ref (car w*) 'upred) pred)))
(car w*)
(loop (cdr w*))))
((engine? (slot-ref e 'delegate))
- (liip (slot-ref e 'delegate)))
+ (liip (slot-ref e 'delegate)))
(else
- #f))))))))
+ #f))))))))
;;;; ======================================================================
;;;;
-;;;; MARKUP-WRITER-GET*
+;;;; MARKUP-WRITER-GET*
;;;;
;;;; ======================================================================
@@ -194,16 +225,16 @@
;;; ======================================================================
;;;;
-;;;; COPY-MARKUP-WRITER
+;;;; COPY-MARKUP-WRITER
;;;;
;;;; ======================================================================
(define* (copy-markup-writer markup old-engine :optional new-engine
- :key (predicate 'unspecified)
- (class 'unspecified)
+ :key (predicate 'unspecified)
+ (class 'unspecified)
(options 'unspecified)
- (validate 'unspecified)
- (before 'unspecified)
- (action 'unspecified)
+ (validate 'unspecified)
+ (before 'unspecified)
+ (action 'unspecified)
(after 'unspecified))
(let ((old (markup-writer-get markup old-engine))
(new-engine (or new-engine old-engine)))
--
cgit v1.2.3
From 2d740bec3cc50480980d8aae3a06e27a5f0649e5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtes
Date: Sat, 2 Jul 2005 02:04:46 +0000
Subject: Started relying on the per-module reader; first doc produced ever!
First document compiled by Skribilo to HTML!
* src/guile/skribilo/module.scm (define-skribe-module): Use the
`#:reader' option of `define-module' (not yet integrated in Guile 1.7).
Plus lots of other things...
git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-3
---
src/guile/README | 4 +-
src/guile/skribilo.scm | 36 +++++++------
src/guile/skribilo/biblio.scm | 11 ++--
src/guile/skribilo/engine/html.scm | 7 ++-
src/guile/skribilo/evaluator.scm | 47 ----------------
src/guile/skribilo/lib.scm | 10 +++-
src/guile/skribilo/module.scm | 105 ++++++++++++++++++++++--------------
src/guile/skribilo/output.scm | 7 +--
src/guile/skribilo/resolve.scm | 24 ++++-----
src/guile/skribilo/runtime.scm | 102 ++++++++++++++++++-----------------
src/guile/skribilo/skribe/api.scm | 1 +
src/guile/skribilo/skribe/bib.scm | 1 -
src/guile/skribilo/skribe/utils.scm | 3 +-
src/guile/skribilo/source.scm | 18 +++----
src/guile/skribilo/types.scm | 6 ++-
src/guile/skribilo/vars.scm | 8 ++-
src/guile/skribilo/verify.scm | 31 ++++++-----
src/guile/skribilo/writer.scm | 2 +-
18 files changed, 216 insertions(+), 207 deletions(-)
(limited to 'src')
diff --git a/src/guile/README b/src/guile/README
index 1b9a6c4..4bd7eff 100644
--- a/src/guile/README
+++ b/src/guile/README
@@ -1,4 +1,4 @@
-Skribilo
+Skribilo -*- Outline -*-
========
Skribilo is a port of Skribe to GNU Guile.
@@ -11,6 +11,8 @@ Here are a few goals.
** Better error handling, automatic back-traces, etc.
+** Add an option to continuously watch a file and re-compile it
+
* Font-ends (readers)
** Implement a new front-end mechanism (see `(skribilo reader)')
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index ae21fab..a43ec66 100755
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -59,10 +59,6 @@ exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@"
the-arg))))))))
-(set! %load-hook
- (lambda (file)
- (format #t "~~ loading `~a'...~%" file)))
-
(define-module (skribilo))
@@ -415,6 +411,11 @@ Processes a Skribilo/Skribe source file and produces its output.
(set-skribe-debug! (string->number debugging-level))
+ (if (> (skribe-debug) 4)
+ (set! %load-hook
+ (lambda (file)
+ (format #t "~~ loading `~a'...~%" file))))
+
(set! %skribilo-load-path
(cons load-path %skribilo-load-path))
(set! %skribilo-bib-path
@@ -426,9 +427,6 @@ Processes a Skribilo/Skribe source file and produces its output.
;; Load the user rc file
;(load-rc)
- ;; load the basic Skribe modules
- (load-skribe-modules)
-
;; Load the base file to bootstrap the system as well as the files
;; that are in the PRELOAD variable.
(find-engine 'base)
@@ -442,24 +440,28 @@ Processes a Skribilo/Skribe source file and produces its output.
(reverse! variants))
(let ((files (option-ref options '() '())))
- (if (null? files)
- (error "you must specify at least the input file" files))
+
(if (> (length files) 2)
(error "you can specify at most one input file and one output file"
files))
- (let* ((source-file (car files))
- (dest-file (if (null? (cdr files)) #f (cadr files)))
- (source-port (open-input-file source-file)))
+ (let* ((source-file (if (null? files) #f (car files)))
+ (dest-file (if (or (not source-file)
+ (null? (cdr files)))
+ #f
+ (cadr files)))
+ (do-it! (lambda ()
+ (if (string? dest-file)
+ (with-output-to-file dest-file doskribe)
+ (doskribe)))))
(if (and dest-file (file-exists? dest-file))
(delete-file dest-file))
- (with-input-from-file source-file
- (lambda ()
- (if (string? dest-file)
- (with-output-to-file dest-file doskribe)
- (doskribe))))))))
+ (if source-file
+ (with-input-from-file source-file
+ do-it!)
+ (do-it!))))))
(define main skribilo)
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm
index d4a644e..f3ddf97 100644
--- a/src/guile/skribilo/biblio.scm
+++ b/src/guile/skribilo/biblio.scm
@@ -27,10 +27,11 @@
(define-module (skribilo biblio)
- :use-module (skribilo runtime)
- :export (bib-tables? make-bib-table default-bib-table
- bib-load! resolve-bib resolve-the-bib
- bib-sort/authors bib-sort/idents bib-sort/dates))
+ :use-module (skribilo runtime)
+ :use-module (skribilo lib) ;; `when', `unless'
+ :use-module (skribilo vars)
+ :export (bib-table? make-bib-table default-bib-table
+ bib-add!))
(define *bib-table* #f)
@@ -50,7 +51,7 @@
(make-hash-table))
(define (bib-table? obj)
- (hashtable? obj))
+ (hash-table? obj))
(define (default-bib-table)
(unless *bib-table*
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
index a20ea68..c85f18f 100644
--- a/src/guile/skribilo/engine/html.scm
+++ b/src/guile/skribilo/engine/html.scm
@@ -16,7 +16,8 @@
;* @ref ../../doc/user/htmle.skb:ref@ */
;*=====================================================================*/
-(define-skribe-module (skribilo engine html))
+(define-skribe-module (skribilo engine html)
+ #:use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)))
;; Keep a reference to the base engine.
@@ -843,7 +844,9 @@
:url (skribilo-url))
"."
(linebreak)
- "Last update: " (date)))))
+ "Last update: "
+ (s19:date->string
+ (s19:current-date))))))
e))))
:after "</div>\n")
diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm
index b7e04c1..703186c 100644
--- a/src/guile/skribilo/evaluator.scm
+++ b/src/guile/skribilo/evaluator.scm
@@ -43,53 +43,6 @@
(oop goops))
-
-;;; FIXME: The following page must eventually go to `module.scm'.
-
-(define *skribilo-user-module* #f)
-
-(define *skribilo-user-imports*
- '((srfi srfi-1)
- (srfi srfi-13)
- (oop goops)
- (skribilo module)
- (skribilo config)
- (skribilo vars)
- (skribilo runtime)
- (skribilo biblio)
- (skribilo lib)
- (skribilo resolve)
- (skribilo engine)
- (skribilo writer)))
-
-(define *skribe-core-modules* ;;; FIXME: From `module.scm'.
- '("utils" "api" "bib" "index" "param" "sui"))
-
-;;;
-;;; MAKE-RUN-TIME-MODULE
-;;;
-(define-public (make-run-time-module)
- "Return a new module that imports all the necessary bindings required for
-execution of Skribilo/Skribe code."
- (let ((the-module (make-module)))
- (for-each (lambda (iface)
- (module-use! the-module (resolve-module iface)))
- (append *skribilo-user-imports*
- (map (lambda (mod)
- `(skribilo skribe
- ,(string->symbol mod)))
- *skribe-core-modules*)))
- (set-module-name! the-module '(skribilo-user))
- the-module))
-
-;;;
-;;; RUN-TIME-MODULE
-;;;
-(define-public (run-time-module)
- "Return the default instance of a Skribilo/Skribe run-time module."
- (if (not *skribilo-user-module*)
- (set! *skribilo-user-module* (make-run-time-module)))
- *skribilo-user-module*)
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index bb41597..ef8ef8d 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -58,6 +58,7 @@
hashtable-get hashtable-put! hashtable-update!
hashtable->list
+ skribe-read
find-runtime-type)
:export-syntax (new define-markup define-simple-markup
@@ -68,6 +69,8 @@
:use-module (skribilo config)
:use-module (skribilo types)
+ :use-module (skribilo reader)
+ :use-module (skribilo vars)
:use-module (srfi srfi-1)
:use-module (ice-9 optargs))
@@ -105,7 +108,7 @@
(let ((name (car bindings))
(opts (cdr bindings)))
- `(define* ,(cons name (fix-rest-arg opts)) ,@body)))
+ `(define*-public ,(cons name (fix-rest-arg opts)) ,@body)))
;;;
@@ -352,6 +355,11 @@
;;; Various things.
;;;
+(define %skribe-reader (make-reader 'skribe))
+
+(define* (skribe-read #:optional (port (current-input-port)))
+ (%skribe-reader port))
+
(define (%procedure-arity proc)
(car (procedure-property proc 'arity)))
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 50c7b23..854c50d 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -22,6 +22,7 @@
:use-module (skribilo reader)
:use-module (skribilo evaluator)
:use-module (skribilo debug)
+ :use-module (srfi srfi-1)
:use-module (ice-9 optargs))
;;; Author: Ludovic Court�s
@@ -36,47 +37,47 @@
;;;
;;; Code:
-(define-macro (define-skribe-module name)
+(define *skribilo-user-imports*
+ ;; List of modules that should be imported by any good Skribilo module.
+ '((srfi srfi-1) ;; lists
+ (srfi srfi-13) ;; strings
+ ;(srfi srfi-19) ;; date and time
+ (oop goops) ;; `make'
+ (ice-9 optargs) ;; `define*'
+
+ (skribilo module)
+ (skribilo types) ;; `<document>', `document?', etc.
+ (skribilo config)
+ (skribilo vars)
+ (skribilo runtime) ;; `the-options', `the-body'
+ (skribilo biblio)
+ (skribilo lib) ;; `define-markup', `unwind-protect', etc.
+ (skribilo resolve)
+ (skribilo engine)
+ (skribilo writer)
+ (skribilo output)
+ (skribilo evaluator)))
+
+(define *skribe-core-modules*
+ '("utils" "api" "bib" "index" "param" "sui"))
+
+(define-macro (define-skribe-module name . options)
`(begin
- (define-module ,name)
+ (define-module ,name
+ #:reader (make-reader 'skribe)
+ #:use-module (skribilo reader)
+ ,@options)
;; Pull all the bindings that Skribe code may expect, plus those needed
;; to actually create and read the module.
- (use-modules (skribilo module)
- (skribilo reader)
- (skribilo evaluator) ;; `run-time-module'
- (skribilo engine)
- (skribilo writer)
- (skribilo types)
-
- (srfi srfi-1)
- (ice-9 optargs)
-
- (skribilo lib) ;; `define-markup', `unwind-protect', etc.
- (skribilo runtime)
- (skribilo vars)
- (skribilo config))
-
-
- ;; The `define' below results in a module-local definition. So the
- ;; definition of `read' in the `(guile-user)' module is left untouched.
- ;(define read ,(make-reader 'skribe))
-
- ;; Everything is exported.
-; (define-macro (define . things)
-; (let* ((first (car things))
-; (binding (cond ((symbol? first) first)
-; ((list? first) (car first))
-; ((pair? first) (car first))
-; (else
-; (error "define/skribe: bad formals" first)))))
-; `(begin
-; (define-public ,@things)
-; ;; Automatically push it to the run-time user module.
-; ; (module-define! ,(run-time-module)
-; ; (quote ,binding) ,binding)
-; )))
- ))
+ ,(cons 'use-modules
+ (append *skribilo-user-imports*
+ (filter-map (lambda (mod)
+ (let ((m `(skribilo skribe
+ ,(string->symbol
+ mod))))
+ (and (not (equal? m name)) m)))
+ *skribe-core-modules*)))))
;; Make it available to the top-level module.
@@ -84,9 +85,35 @@
'define-skribe-module define-skribe-module)
-(define-public *skribe-core-modules*
- '("utils" "api" "bib" "index" "param" "sui"))
+
+(define *skribilo-user-module* #f)
+
+;;;
+;;; MAKE-RUN-TIME-MODULE
+;;;
+(define-public (make-run-time-module)
+ "Return a new module that imports all the necessary bindings required for
+execution of Skribilo/Skribe code."
+ (let ((the-module (make-module)))
+ (for-each (lambda (iface)
+ (module-use! the-module (resolve-module iface)))
+ (append *skribilo-user-imports*
+ (map (lambda (mod)
+ `(skribilo skribe
+ ,(string->symbol mod)))
+ *skribe-core-modules*)))
+ (set-module-name! the-module '(skribilo-user))
+ the-module))
+
+;;;
+;;; RUN-TIME-MODULE
+;;;
+(define-public (run-time-module)
+ "Return the default instance of a Skribilo/Skribe run-time module."
+ (if (not *skribilo-user-module*)
+ (set! *skribilo-user-module* (make-run-time-module)))
+ *skribilo-user-module*)
;; FIXME: This will eventually be replaced by the per-module reader thing in
diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm
index eeff397..8a63a48 100644
--- a/src/guile/skribilo/output.scm
+++ b/src/guile/skribilo/output.scm
@@ -31,6 +31,7 @@
(skribilo types)
; (skribilo engine)
(skribilo writer)
+ (skribilo lib) ;; `when', `unless'
(oop goops))
@@ -60,10 +61,10 @@
(%out/writer node e (car writer)))
((not (car writer))
(skribe-error 'output
- (format "Illegal ~A user writer" (engine-ident e))
+ (format #f "illegal ~A user writer" (engine-ident e))
(if (markup? node) (markup-markup node) node)))
(else
- (skribe-error 'output "Illegal user writer" (car writer)))))))
+ (skribe-error 'output "illegal user writer" (car writer)))))))
;;;
@@ -74,7 +75,7 @@
(define-method (out (node <pair>) e)
- (let Loop ((n* node))
+ (let loop ((n* node))
(cond
((pair? n*)
(out (car n*) e)
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index e59a2f8..14f36b2 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -1,24 +1,24 @@
;;;;
;;;; resolve.stk -- Skribe Resolve Stage
-;;;;
+;;;;
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 13-Aug-2003 18:39 (eg)
;;;; Last file update: 17-Feb-2004 14:43 (eg)
@@ -28,6 +28,7 @@
:use-module (skribilo debug)
:use-module (skribilo runtime)
:use-module (skribilo types)
+ :use-module (skribilo lib) ;; `unless' and `when'
:use-module (oop goops)
@@ -62,7 +63,7 @@
;;;; ======================================================================
;;;;
-;;;; D O - R E S O L V E !
+;;;; D O - R E S O L V E !
;;;;
;;;; ======================================================================
@@ -195,10 +196,10 @@
(debug-item "parent=" p " "
(if (is-a? p 'markup) (slot-ref p 'markup) "???"))
(cond
- ((pred p) p)
+ ((pred p) p)
((is-a? p <unresolved>) p)
((not p) #f)
- (else (resolve-search-parent p e pred))))))
+ (else (resolve-search-parent p e pred))))))
;;;; ======================================================================
;;;;
@@ -231,7 +232,7 @@
(else
(set-car! (cdr c) (+ 1 num))
(+ 1 num)))))))
-
+
;;;; ======================================================================
;;;;
;;;; RESOLVE-IDENT
@@ -259,4 +260,3 @@
(car mks))
(else
(loop (cdr mks)))))))))))
-
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm
index 2642f7e..1f411dc 100644
--- a/src/guile/skribilo/runtime.scm
+++ b/src/guile/skribilo/runtime.scm
@@ -27,6 +27,7 @@
(define-module (skribilo runtime)
:export (;; Utilities
strip-ref-base ast->file-location string-canonicalize
+ the-options the-body
;; Markup functions
markup-option markup-option-add! markup-output
@@ -49,6 +50,8 @@
(skribilo resolve)
(skribilo output)
(skribilo evaluator)
+ (skribilo vars)
+ (srfi srfi-13)
(oop goops))
@@ -253,10 +256,10 @@
;; The general version
(lambda (str)
(let ((out (open-output-string)))
- (dotimes (i (string-length str))
- (let* ((ch (string-ref str i))
- (res (assq ch lst)))
- (display (if res (cadr res) ch) out)))
+ (string-for-each (lambda (ch)
+ (let ((res (assq ch lst)))
+ (display (if res (cadr res) ch) out)))
+ str)
(get-output-string out))))
(define string->html
@@ -414,48 +417,49 @@
;;NEW '()))))))
;;NEW
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G
-;;NEW ;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (the-body opt)
-;;NEW ;; Filter out the options
-;;NEW (let loop ((opt* opt)
-;;NEW (res '()))
-;;NEW (cond
-;;NEW ((null? opt*)
-;;NEW (reverse! res))
-;;NEW ((not (pair? opt*))
-;;NEW (skribe-error 'the-body "Illegal body" opt))
-;;NEW ((keyword? (car opt*))
-;;NEW (if (null? (cdr opt*))
-;;NEW (skribe-error 'the-body "Illegal option" (car opt*))
-;;NEW (loop (cddr opt*) res)))
-;;NEW (else
-;;NEW (loop (cdr opt*) (cons (car opt*) res))))))
-;;NEW
-;;NEW
-;;NEW
-;;NEW (define (the-options opt+ . out)
-;;NEW ;; Returns an list made of options.The OUT argument contains
-;;NEW ;; keywords that are filtered out.
-;;NEW (let loop ((opt* opt+)
-;;NEW (res '()))
-;;NEW (cond
-;;NEW ((null? opt*)
-;;NEW (reverse! res))
-;;NEW ((not (pair? opt*))
-;;NEW (skribe-error 'the-options "Illegal options" opt*))
-;;NEW ((keyword? (car opt*))
-;;NEW (cond
-;;NEW ((null? (cdr opt*))
-;;NEW (skribe-error 'the-options "Illegal option" (car opt*)))
-;;NEW ((memq (car opt*) out)
-;;NEW (loop (cdr opt*) res))
-;;NEW (else
-;;NEW (loop (cdr opt*)
-;;NEW (cons (list (car opt*) (cadr opt*)) res)))))
-;;NEW (else
-;;NEW (loop (cdr opt*) res)))))
-;;NEW
+
+;;;; ======================================================================
+;;;;
+;;;; M A R K U P A R G U M E N T P A R S I N G
+;;;;
+;;;; ======================================================================
+(define (the-body opt)
+ ;; Filter out the options
+ (let loop ((opt* opt)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-body "Illegal body" opt))
+ ((keyword? (car opt*))
+ (if (null? (cdr opt*))
+ (skribe-error 'the-body "Illegal option" (car opt*))
+ (loop (cddr opt*) res)))
+ (else
+ (loop (cdr opt*) (cons (car opt*) res))))))
+
+
+
+(define (the-options opt+ . out)
+ ;; Returns an list made of options.The OUT argument contains
+ ;; keywords that are filtered out.
+ (let loop ((opt* opt+)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-options "Illegal options" opt*))
+ ((keyword? (car opt*))
+ (cond
+ ((null? (cdr opt*))
+ (skribe-error 'the-options "Illegal option" (car opt*)))
+ ((memq (car opt*) out)
+ (loop (cdr opt*) res))
+ (else
+ (loop (cdr opt*)
+ (cons (list (car opt*) (cadr opt*)) res)))))
+ (else
+ (loop (cdr opt*) res)))))
+
diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm
index 2828908..e7ba4a6 100644
--- a/src/guile/skribilo/skribe/api.scm
+++ b/src/guile/skribilo/skribe/api.scm
@@ -253,6 +253,7 @@
;* paragraph ... */
;*---------------------------------------------------------------------*/
(define-simple-markup paragraph)
+(define-public p paragraph)
;*---------------------------------------------------------------------*/
;* footnote ... */
diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm
index f1a32c1..2ec5c0b 100644
--- a/src/guile/skribilo/skribe/bib.scm
+++ b/src/guile/skribilo/skribe/bib.scm
@@ -32,7 +32,6 @@
;;; The contents of the file below are unchanged compared to Skribe 1.2d's
;;; `bib.scm' file found in the `common' directory.
-
;*---------------------------------------------------------------------*/
;* bib-load! ... */
;*---------------------------------------------------------------------*/
diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm
index f963020..b2a5cfb 100644
--- a/src/guile/skribilo/skribe/utils.scm
+++ b/src/guile/skribilo/skribe/utils.scm
@@ -19,7 +19,8 @@
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
-(define-skribe-module (skribilo skribe utils))
+(define-skribe-module (skribilo skribe utils)
+ #:export (ast-document))
;;; Author: Manuel Serrano
;;; Commentary:
diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm
index 1e88d45..c682687 100644
--- a/src/guile/skribilo/source.scm
+++ b/src/guile/skribilo/source.scm
@@ -1,24 +1,24 @@
;;;;
;;;; source.stk -- Skibe SOURCE implementation stuff
-;;;;
+;;;;
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 3-Sep-2003 12:22 (eg)
;;;; Last file update: 27-Oct-2004 20:09 (eg)
@@ -27,7 +27,8 @@
(define-module (skribilo source)
- :export (source-read-lines source-read-definition source-fontify))
+ :export (source-read-lines source-read-definition source-fontify)
+ :use-module (skribilo vars))
;; Temporary solution
@@ -187,4 +188,3 @@
(cons* 'eol (substring str j i) r))))
(else
(loop (+ i 1) j r))))))
-
diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm
index 0d51c70..0893587 100644
--- a/src/guile/skribilo/types.scm
+++ b/src/guile/skribilo/types.scm
@@ -33,10 +33,12 @@
<node> node? node-options node-loc
<engine> engine? engine-ident engine-format engine-customs
engine-filter engine-symbol-table
- <writer> writer? write-object
+ <writer> writer? write-object writer-options writer-ident
+ writer-before writer-action writer-after
<processor> processor? processor-combinator processor-engine
<markup> markup? bind-markup! markup-options is-markup?
- markup-body find-markups write-object
+ markup-markup markup-body markup-ident markup-class
+ find-markups write-object
<container> container? container-options
container-ident container-body
<document> document? document-ident document-body
diff --git a/src/guile/skribilo/vars.scm b/src/guile/skribilo/vars.scm
index 51a7ee7..7e75e0f 100644
--- a/src/guile/skribilo/vars.scm
+++ b/src/guile/skribilo/vars.scm
@@ -21,7 +21,8 @@
;;; USA.
-(define-module (skribilo vars))
+(define-module (skribilo vars)
+ #:use-module (srfi srfi-17))
;;;
;;; Switches
@@ -30,6 +31,11 @@
(define-public *skribe-warning* 5)
(define-public *load-rc* #t)
+(define-public skribe-debug
+ (let ((level 0))
+ (getter-with-setter (lambda () level)
+ (lambda (val) (set! level val)))))
+
;;;
;;; PATH variables
;;;
diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm
index 93a1be3..1ff0b5b 100644
--- a/src/guile/skribilo/verify.scm
+++ b/src/guile/skribilo/verify.scm
@@ -1,24 +1,24 @@
;;;;
;;;; verify.stk -- Skribe Verification Stage
-;;;;
+;;;;
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 13-Aug-2003 11:57 (eg)
;;;; Last file update: 27-Oct-2004 16:35 (eg)
@@ -29,9 +29,10 @@
(use-modules (skribilo debug)
; (skribilo engine)
-; (skribilo writer)
+ (skribilo writer)
; (skribilo runtime)
(skribilo types)
+ (skribilo lib) ;; `when', `unless'
(oop goops))
@@ -61,16 +62,16 @@
;;; CHECK-OPTIONS
;;;
(define (check-options lopts markup engine)
-
+
;; Only keywords are checked, symbols are voluntary left unchecked. */
(with-debug 6 'check-options
(debug-item "markup=" (markup-markup markup))
(debug-item "options=" (slot-ref markup 'options))
(debug-item "lopts=" lopts)
(for-each
- (lambda (o2)
+ (lambda (o2)
(for-each
- (lambda (o)
+ (lambda (o)
(if (and (keyword? o)
(not (eq? o :&skribe-eval-location))
(not (memq o lopts)))
@@ -85,11 +86,11 @@
(markup-option markup o)))))
o2))
(slot-ref markup 'options))))
-
+
;;; ======================================================================
;;;
-;;; V E R I F Y
+;;; V E R I F Y
;;;
;;; ======================================================================
@@ -124,7 +125,7 @@
(with-debug 5 'verify::<markup>
(debug-item "node=" (markup-markup node))
(debug-item "options=" (slot-ref node 'options))
- (debug-item "e=" (engine-ident e))
+ (debug-item "e=" (engine-ident e))
(next-method)
@@ -157,5 +158,3 @@
(slot-ref e 'customs))
node)
-
-
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
index 70ba817..eeefe8b 100644
--- a/src/guile/skribilo/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -64,7 +64,7 @@
(define (lookup-markup-writer node e)
(let ((writers (slot-ref e 'writers))
(delegate (slot-ref e 'delegate)))
- (let Loop ((w* writers))
+ (let loop ((w* writers))
(cond
((pair? w*)
(let ((pred (slot-ref (car w*) 'pred)))
--
cgit v1.2.3