diff options
22 files changed, 701 insertions, 548 deletions
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/skr/base.skr b/src/guile/skribilo/engine/base.scm index ec987ec..53d837d 100644 --- a/skr/base.skr +++ b/src/guile/skribilo/engine/base.scm @@ -9,6 +9,8 @@ ;* BASE Skribe engine */ ;*=====================================================================*/ +(define-skribe-module (skribilo engine base)) + ;*---------------------------------------------------------------------*/ ;* base-engine ... */ ;*---------------------------------------------------------------------*/ @@ -110,7 +112,7 @@ ("Downarrow" "v") ("<=>" "<=>") ("<==>" "<==>") - ;; Mathematical operators + ;; Mathematical operators ("asterisk" "*") ("angle" "<") ("and" "^;") @@ -122,13 +124,13 @@ ("mid" "|") ("langle" "<") ("rangle" ">") - ;; LaTeX + ;; LaTeX ("circ" "o") ("top" "T") ("lhd" "<") ("rhd" ">") ("parallel" "||"))))) - + ;*---------------------------------------------------------------------*/ ;* mark ... */ ;*---------------------------------------------------------------------*/ @@ -203,7 +205,7 @@ :before "[" :action (lambda (n e) (output (markup-option n :title) e)) :after "]") - + ;*---------------------------------------------------------------------*/ ;* &bib-entry-body ... */ ;*---------------------------------------------------------------------*/ @@ -220,11 +222,11 @@ (if (eq? (caar descr) 'or) (let ((o1 (cadr (car descr)))) (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending + (loop (cons o1 (cdr descr)) + pending #t) (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) + (loop (cons o2 (cdr descr)) pending armed)))) (let ((o (markup-option n (cadr (car descr))))) @@ -240,7 +242,7 @@ (loop (cdr descr) pending armed))))) ((symbol? (car descr)) (let ((o (markup-option n (car descr)))) - (if o + (if o (begin (if (and armed pending) (output pending e)) @@ -250,7 +252,7 @@ ((null? (cdr descr)) (output (car descr) e)) ((string? (car descr)) - (loop (cdr descr) + (loop (cdr descr) (if pending pending (car descr)) armed)) (else @@ -260,26 +262,26 @@ (output-fields (case (markup-option n 'kind) ((techreport) - `(author " -- " (or title url documenturl) " -- " + `(author " -- " (or title url documenturl) " -- " number ", " institution ", " - address ", " month ", " year ", " + address ", " month ", " year ", " ("pp. " pages) ".")) ((article) - `(author " -- " (or title url documenturl) " -- " + `(author " -- " (or title url documenturl) " -- " journal ", " volume "" ("(" number ")") ", " address ", " month ", " year ", " ("pp. " pages) ".")) ((inproceedings) - `(author " -- " (or title url documenturl) " -- " + `(author " -- " (or title url documenturl) " -- " booktitle ", " series ", " ("(" number ")") ", " address ", " month ", " year ", " ("pp. " pages) ".")) ((book) - '(author " -- " (or title url documenturl) " -- " + '(author " -- " (or title url documenturl) " -- " publisher ", " address ", " month ", " year ", " ("pp. " pages) ".")) ((phdthesis) - '(author " -- " (or title url documenturl) " -- " type ", " + '(author " -- " (or title url documenturl) " -- " type ", " school ", " address ", " month ", " year".")) ((misc) @@ -322,7 +324,7 @@ :action (lambda (n e) (define (make-mark-entry n fst) (let ((l (tr :class 'index-mark-entry - (td :colspan 2 :align 'left + (td :colspan 2 :align 'left (bold (it (sf n))))))) (if fst (list l) @@ -330,13 +332,13 @@ (define (make-primary-entry n p) (let* ((note (markup-option n :note)) (b (markup-body n)) - (c (if note + (c (if note (list b (it (list " (" note ")"))) b))) - (when p - (markup-option-add! b :text - (list (markup-option b :text) + (when p + (markup-option-add! b :text + (list (markup-option b :text) ", p.")) (markup-option-add! b :page #t)) (tr :class 'index-primary-entry @@ -347,7 +349,7 @@ (bb (markup-body b))) (cond ((not (or bb (is-markup? b 'url-ref))) - (skribe-error 'the-index + (skribe-error 'the-index "Illegal entry" b)) (note @@ -355,13 +357,13 @@ (it (ref :class "the-index-secondary" :handle bb :page p - :text (if p + :text (if p (list note ", p.") note))) (it (ref :class "the-index-secondary" :url (markup-option b :url) :page p - :text (if p + :text (if p (list note ", p.") note)))))) (tr :class 'index-secondary-entry @@ -370,12 +372,12 @@ (else (let ((r (if bb (ref :class "the-index-secondary" - :handle bb - :page p + :handle bb + :page p :text (if p " ..., p." " ...")) (ref :class "the-index-secondary" :url (markup-option b :url) - :page p + :page p :text (if p " ..., p." " ..."))))) (tr :class 'index-secondary-entry (td :valign 'top :align 'right :width 1.) @@ -387,11 +389,11 @@ ((null? ie) '()) ((not (pair? (car ie))) - (append (make-mark-entry (car ie) f) + (append (make-mark-entry (car ie) f) (loop (cdr ie) #f))) (else (cons (make-primary-entry (caar ie) p) - (append (map (lambda (x) + (append (map (lambda (x) (make-secondary-entry x p)) (cdar ie)) (loop (cdr ie) #f))))))) @@ -399,7 +401,7 @@ (let* ((l (length ie)) (w (/ 100. nc)) (iepc (let ((d (/ l nc))) - (if (integer? d) + (if (integer? d) (inexact->exact d) (+ 1 (inexact->exact (truncate d)))))) (split (list-split ie iepc))) @@ -417,13 +419,13 @@ ((null? ie) "") ((or (not (integer? nc)) (= nc 1)) - (table :width 100. - :&skribe-eval-location loc + (table :width 100. + :&skribe-eval-location loc :class "index-table" (make-column ie pref))) (else (table :width 100. - :&skribe-eval-location loc + :&skribe-eval-location loc :class "index-table" (make-sub-tables ie nc pref)))))) (output (skribe-eval t e) e)))) @@ -434,7 +436,7 @@ ;* The index header is only useful for targets that support */ ;* hyperlinks such as HTML. */ ;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header +(markup-writer '&the-index-header :action (lambda (n e) #f)) ;*---------------------------------------------------------------------*/ diff --git a/skr/context.skr b/src/guile/skribilo/engine/context.scm index 5bc5316..48a069e 100644 --- a/skr/context.skr +++ b/src/guile/skribilo/engine/context.scm @@ -1,31 +1,33 @@ ;;;; ;;;; 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, +;;;; 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 ... +;;;; context-customs ... ;;;; ====================================================================== (define context-customs '((source-comment-color "#ffa600") @@ -45,9 +47,9 @@ (document-style "book"))) ;;;; ====================================================================== -;;;; context-encoding ... +;;;; context-encoding ... ;;;; ====================================================================== -(define context-encoding +(define context-encoding '((#\# "\\type{#}") (#\| "\\type{|}") (#\{ "$\\{$") @@ -65,16 +67,16 @@ (#\\ "$\\backslash$"))) ;;;; ====================================================================== -;;;; context-pre-encoding ... +;;;; context-pre-encoding ... ;;;; ====================================================================== -(define context-pre-encoding +(define context-pre-encoding (append '((#\space "~") (#\~ "\\type{~}")) context-encoding)) ;;;; ====================================================================== -;;;; context-symbol-table ... +;;;; context-symbol-table ... ;;;; ====================================================================== (define (context-symbol-table math) `(("iexcl" "!`") @@ -302,23 +304,23 @@ ;;;; context-width ;;;; ====================================================================== (define (context-width width) - (cond - ((string? width) + (cond + ((string? width) width) ((and (number? width) (inexact? width)) (string-append (number->string (/ width 100.)) "\\textwidth")) - (else + (else (string-append (number->string width) "pt")))) ;;;; ====================================================================== ;;;; context-dim ;;;; ====================================================================== (define (context-dim dimension) - (cond - ((string? dimension) + (cond + ((string? dimension) dimension) ((number? dimension) - (string-append (number->string (inexact->exact (round dimension))) + (string-append (number->string (inexact->exact (round dimension))) "pt")))) ;;;; ====================================================================== @@ -354,16 +356,16 @@ ;; 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 + (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) + (for-each (lambda (x) (skribe-use-color! (engine-custom engine x))) - '(source-comment-color source-define-color source-module-color + '(source-comment-color source-define-color source-module-color source-markup-color source-thread-color source-string-color source-bracket-color source-type-color))) @@ -375,7 +377,7 @@ c))) ;;;; ====================================================================== -;;;; context-engine ... +;;;; context-engine ... ;;;; ====================================================================== (define context-engine (default-engine-set! @@ -388,7 +390,7 @@ :custom context-customs))) ;;;; ====================================================================== -;;;; document ... +;;;; document ... ;;;; ====================================================================== (markup-writer 'document :options '(:title :subtitle :author :ending :env) @@ -400,13 +402,13 @@ (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) + ;; Choose the document font + (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) (engine-custom e 'font-size)) - ;; Color + ;; Color (display "\\setupcolors[state=start]\n") ;; Load Style - (printf "\\input skribe-context-~a.tex\n" + (printf "\\input skribe-context-~a.tex\n" (engine-custom e 'document-style)) ;; Insert User customization (let ((s (engine-custom e 'user-style))) @@ -414,15 +416,15 @@ ;; 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) + (skribe-eval (new markup + (markup '&context-title) (body t) - (options + (options `((subtitle ,(markup-option n :subtitle))))) e :env `((parent ,n))))) @@ -431,7 +433,7 @@ (when a (if (list? a) ;; List of authors. Use multi-columns - (begin + (begin (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) (display "\\startAuthors\n") (let Loop ((l a)) @@ -477,17 +479,17 @@ (url (markup-option n :url)) (address (markup-option n :address)) (phone (markup-option n :phone)) - (out (lambda (n) - (output n e) + (out (lambda (n) + (output n e) (display "\\\\\n")))) (display "{\\midaligned{") - (when name (out name)) - (when title (out title)) - (when affiliation (out affiliation)) + (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)) + (when phone (out phone)) + (when email (out email)) + (when url (out url)) (display "}}\n")))) @@ -556,15 +558,15 @@ ;;;; ====================================================================== ;;;; hrule ... ;;;; ====================================================================== -(markup-writer 'hrule +(markup-writer 'hrule :options '(:width :height) :before (lambda (n e) - (printf "\\blackrule[width=~A,height=~A]\n" + (printf "\\blackrule[width=~A,height=~A]\n" (context-width (markup-option n :width)) (context-dim (markup-option n :height))))) - + ;;;; ====================================================================== -;;;; color ... +;;;; color ... ;;;; ====================================================================== (markup-writer 'color :options '(:bg :fg :width :margin :border) @@ -584,12 +586,12 @@ (when m (printf ",offset=~A" (context-width m))) (when bg - (printf ",background=color,backgroundcolor=~A" + (printf ",background=color,backgroundcolor=~A" (skribe-get-color bg))) (when fg - (printf ",foregroundcolor=~A" + (printf ",foregroundcolor=~A" (skribe-get-color fg))) - (when c + (when c (display ",framecorner=round")) (printf "]\n")) ;; Probably just a foreground was specified @@ -620,7 +622,7 @@ "fit")) (printf ",rulethickness=~A" (context-dim b)) (printf ",offset=~A" (context-width m)) - (when c + (when c (display ",framecorner=round")) (printf "]\n"))) :after "\\stopframedtext ") @@ -630,7 +632,7 @@ ;;;; ====================================================================== (markup-writer 'font :options '(:size) - :action (lambda (n e) + :action (lambda (n e) (let* ((size (markup-option n :size)) (cs (engine-custom e 'font-size)) (ns (cond @@ -643,7 +645,7 @@ ((string? size) (let ((nb (string->number size))) (if (not (number? nb)) - (skribe-error + (skribe-error 'font (format "Illegal font size ~s" size) nb) @@ -657,10 +659,10 @@ (printf "{\\switchtobodyfont[~apt]" ns) (output (markup-body n) ne) (display "}")))) - + ;;;; ====================================================================== -;;;; flush ... +;;;; flush ... ;;;; ====================================================================== (markup-writer 'flush :options '(:side) @@ -711,7 +713,7 @@ :custom (engine-customs e)))) (output (markup-body n) ne))) :after "\n\\stoplines\n}") - + ;;;; ====================================================================== ;;;; itemize, enumerate ... @@ -719,8 +721,8 @@ (define (context-itemization-action n e descr?) (let ((symbol (markup-option n :symbol))) (for-each (lambda (item) - (if symbol - (begin + (if symbol + (begin (display "\\sym{") (output symbol e) (display "}")) @@ -732,14 +734,14 @@ (markup-body n)))) (markup-writer 'itemize - :options '(:symbol) + :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) + :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") @@ -748,7 +750,7 @@ ;;;; description ... ;;;; ====================================================================== (markup-writer 'description - :options '(:symbol) + :options '(:symbol) :before "\\startnarrower[left]\n\\startitemize[serried]\n" :action (lambda (n e) (context-itemization-action n e #t)) :after "\\stopitemize\n\\stopnarrower\n") @@ -757,7 +759,7 @@ ;;;; item ... ;;;; ====================================================================== (markup-writer 'item - :options '(:key) + :options '(:key) :action (lambda (n e) (let ((k (markup-option n :key))) (when k @@ -772,7 +774,7 @@ ;; Output body (output (markup-body n) e) ;; Terminate - (when k + (when k (display "\n\\stopnarrower\n"))))) ;;;; ====================================================================== @@ -792,13 +794,13 @@ (let ((ident (markup-ident n)) (number (markup-option n :number)) (legend (markup-option n :legend))) - (unless number + (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 + (unless number (display "}\n"))))) ;;;; ====================================================================== @@ -818,7 +820,7 @@ (printf "\n{\\bTABLE\n") (printf "\\setupTABLE[") (printf "width=~A" (if width (context-width width) "fit")) - (when border + (when border (printf ",rulethickness=~A" (context-dim border))) (when cp (printf ",offset=~A" (context-width cp))) @@ -832,7 +834,7 @@ ((cols) (display vert)) ((all) (display hor) (display vert))))) - (when frame + (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") @@ -845,8 +847,8 @@ ((lhs) (display left)) ((rhs) (display right)) ((vsides) (display left) (diplay right)) - ((box border) (display top) (display bot) - (display left) (display right))))))) + ((box border) (display top) (display bot) + (display left) (display right))))))) :after (lambda (n e) (printf "\\eTABLE}\n"))) @@ -862,7 +864,7 @@ (let ((bg (markup-option n :bg))) (when bg (printf "[background=color,backgroundcolor=~A]" - (skribe-get-color bg))))) + (skribe-get-color bg))))) :after "\\eTR\n") @@ -871,7 +873,7 @@ ;;;; ====================================================================== (markup-writer 'tc :options '(:width :align :valign :colspan) - :before (lambda (n e) + :before (lambda (n e) (let ((th? (eq? 'th (markup-option n 'markup))) (width (markup-option n :width)) (align (markup-option n :align)) @@ -882,13 +884,13 @@ (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 + ;; 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 + (when align (printf ",align=~a" (case align ((left) 'right) ; !!!! ((right) 'left) ; !!!! @@ -896,10 +898,10 @@ (unless (equal? colspan 1) (printf ",nx=~a" colspan)) (display "]") - (when th? + (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 @@ -919,8 +921,8 @@ (zoom (markup-option n :zoom)) (body (markup-body n)) (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) + (img (or url (convert-image file + (if (list? efmt) efmt '("jpg")))))) (if (not (string? img)) @@ -977,7 +979,7 @@ :action (lambda (n e) (let ((text (markup-option n :text)) (url (markup-body n))) - (when (pair? url) + (when (pair? url) (context-url (format "mailto:~A" (car url)) (or text (car url)) @@ -987,24 +989,24 @@ ;;;; ====================================================================== (markup-writer 'mark :before (lambda (n e) - (printf "\\reference[~a]{}\n" + (printf "\\reference[~a]{}\n" (string-canonicalize (markup-ident n))))) ;;;; ====================================================================== ;;;; ref ... ;;;; ====================================================================== (markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection + :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 + (cond (page ;; Output the page only (this is a hack) (when text (output text e)) - (printf "\\at[~a]" + (printf "\\at[~a]" (string-canonicalize id))) ((or (markup-option n :chapter) (markup-option n :section) @@ -1041,7 +1043,7 @@ (markup-writer 'bib-ref+ :options '(:text :bib) :before (lambda (n e) (output "[" e)) - :action (lambda (n e) + :action (lambda (n e) (let loop ((rs (markup-body n))) (cond ((null? rs) @@ -1063,7 +1065,7 @@ ;;;; ====================================================================== (markup-writer 'url-ref :options '(:url :text) - :action (lambda (n e) + :action (lambda (n e) (context-url (markup-option n :url) (markup-option n :text) e))) ;;//;*---------------------------------------------------------------------*/ @@ -1138,13 +1140,13 @@ ;;;; ====================================================================== (markup-writer '&the-index :options '(:column) - :action + :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) ", ")) @@ -1192,7 +1194,7 @@ (color :fg cc n1) n1))) (skribe-eval n2 e)))) - + ;;;; ====================================================================== ;;;; &source-line-comment ... ;;;; ====================================================================== @@ -1204,7 +1206,7 @@ (color :fg cc n1) n1))) (skribe-eval n2 e)))) - + ;;;; ====================================================================== ;;;; &source-keyword ... ;;;; ====================================================================== @@ -1335,7 +1337,7 @@ ;;;; ====================================================================== -;;;; Context Only Markups +;;;; Context Only Markups ;;;; ====================================================================== ;;; @@ -1363,7 +1365,7 @@ ;;; ;;; ConTeXt and TeX -;;; +;;; (define-markup (ConTeXt #!key (space #t)) (if (engine-format? "context") (! (if space "\\CONTEXT\\ " "\\CONTEXT")) diff --git a/skr/html.skr b/src/guile/skribilo/engine/html.scm index 79186ca..a20ea68 100644 --- a/skr/html.skr +++ b/src/guile/skribilo/engine/html.scm @@ -16,61 +16,67 @@ ;* @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 (gensym))) + (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))) + (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)))))))) + (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 ... */ @@ -262,8 +268,8 @@ ("yacute" "ý") ("thorn" "þ") ("ymul" "ÿ") - ;; Greek - ("Alpha" "Α") + ;; Greek + ("Alpha" "Α") ("Beta" "Β") ("Gamma" "Γ") ("Delta" "Δ") @@ -339,7 +345,7 @@ ("Downarrow" "⇓") ("<=>" "⇔") ("<==>" "⇔") - ;; Mathematical operators + ;; Mathematical operators ("forall" "∀") ("partial" "∂") ("exists" "∃") @@ -387,13 +393,13 @@ ("langle" "〈") ("rangle" "〉") ;; Misc - ("loz" "◊") + ("loz" "◊") ("spades" "♠") ("clubs" "♣") ("hearts" "♥") ("diams" "♦") ("euro" "ℐ") - ;; LaTeX + ;; LaTeX ("dag" "dag") ("ddag" "ddag") ("circ" "o") @@ -442,17 +448,17 @@ ((string? n) n) ((number? n) - (if (procedure? proc) + (if (procedure? proc) (proc n) (number->string n))) (else ""))) (define (html-chapter-number c) - (html-number (markup-option c :number) + (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) + (s (html-number (markup-option c :number) (engine-custom e 'section-number->string)))) (cond ((is-markup? p 'chapter) @@ -461,7 +467,7 @@ (string-append s))))) (define (html-subsection-number c) (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) + (s (html-number (markup-option c :number) (engine-custom e 'subsection-number->string)))) (cond ((is-markup? p 'section) @@ -470,7 +476,7 @@ (string-append "." s))))) (define (html-subsubsection-number c) (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) + (s (html-number (markup-option c :number) (engine-custom e 'subsubsection-number->string)))) (cond ((is-markup? p 'subsection) @@ -497,7 +503,7 @@ (skribe-error 'html-container-number "Not a container" (markup-markup c)))))))) - + ;*---------------------------------------------------------------------*/ ;* html-counter ... */ ;*---------------------------------------------------------------------*/ @@ -553,10 +559,10 @@ ;* html-color-spec? ... */ ;*---------------------------------------------------------------------*/ (define (html-color-spec? v) - (and v + (and v (not (unspecified? v)) (or (not (string? v)) (> (string-length v) 0)))) - + ;*---------------------------------------------------------------------*/ ;* document ... */ ;*---------------------------------------------------------------------*/ @@ -599,7 +605,7 @@ ;*---------------------------------------------------------------------*/ ;* &html-body ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '&html-body +(markup-writer '&html-body :before (lambda (n e) (let ((bg (engine-custom e 'background))) (display "<body") @@ -680,7 +686,7 @@ (let* ((ic (engine-custom e 'favicon)) (id (markup-ident n))) (unless (string? id) - (skribe-error '&html-generic-header + (skribe-error '&html-generic-header (format "Illegal identifier `~a'" id) n)) ;; title @@ -716,7 +722,7 @@ (ident (string-append id "-css")) (body (let ((c (engine-custom e 'css))) (if (string? c) - (list c) + (list c) c)))) e) ;; javascript @@ -745,7 +751,7 @@ (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) @@ -767,7 +773,7 @@ (for-each (lambda (css) (let ((p (open-input-file css))) (if (not (input-port? p)) - (skribe-error + (skribe-error 'html-css "Can't open CSS file for input" css) @@ -780,7 +786,7 @@ (close-input-port p))))) icss)))) :after " -->\n </style>\n") - + (markup-writer '&html-header-javascript :action (lambda (n e) (when (engine-custom e 'javascript) @@ -807,8 +813,8 @@ (for-each (lambda (s) (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s)) js)))) - - + + ;*---------------------------------------------------------------------*/ ;* &html-header ... */ ;*---------------------------------------------------------------------*/ @@ -827,13 +833,18 @@ (let ((body (markup-body n))) (if body (output body #t) - (skribe-eval [ -,(hrule) -,(p :class "ending" (font :size -1 [ -This ,(sc "Html") page has been produced by -,(ref :url (skribe-url) :text "Skribe"). -,(linebreak) -Last update ,(it (date)).]))] e)))) + (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") ;*---------------------------------------------------------------------*/ @@ -894,8 +905,8 @@ Last update ,(it (date)).]))] e)))) (let loop ((fns footnotes)) (if (pair? fns) (let ((fn (car fns))) - (printf "<a name=\"footnote-~a\">" - (string-canonicalize + (printf "<a name=\"footnote-~a\">" + (string-canonicalize (container-ident fn))) (printf "<sup><small>~a</small></sup></a>: " (markup-option fn :number)) @@ -1109,12 +1120,12 @@ Last update ,(it (date)).]))] e)))) ;; blank columns (col level) ;; number - (printf "<td valign=\"top\" align=\"left\">~a</td>" + (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\">" + (printf "<a href=\"~a#~a\">" (if (string=? f *skribe-dest*) "" (strip-ref-base (or f *skribe-dest* ""))) @@ -1139,8 +1150,8 @@ Last update ,(it (date)).]))] e)))) (handle-ast b) b))) (if (not (container? bb)) - (error 'toc - "Illegal body (container expected)" + (error 'toc + "Illegal body (container expected)" (if (markup? bb) (markup-markup bb) "???")) @@ -1151,7 +1162,7 @@ Last update ,(it (date)).]))] e)))) (and ss (is-markup? x 'subsection)) (and s (is-markup? x 'section)) (and c (is-markup? x 'chapter)) - (markup-option n (symbol->keyword + (markup-option n (symbol->keyword (markup-markup x)))))) (container-body bb)))) ;; avoid to produce an empty table @@ -1159,9 +1170,9 @@ Last update ,(it (date)).]))] e)))) (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"))))))) ;*---------------------------------------------------------------------*/ @@ -1186,7 +1197,7 @@ Last update ,(it (date)).]))] e)))) (ident (string-append id "-footnote")) (class (markup-class n)) (parent n) - (body (reverse! + (body (reverse! (container-env-get n 'footnote-env))))) (page (new markup (markup '&html-page) @@ -1202,7 +1213,7 @@ Last update ,(it (date)).]))] e)))) (body (or (markup-option n :ending) (let ((p (ast-document n))) (and p (markup-option p :ending))))))) - (body (new markup + (body (new markup (markup '&html-body) (ident (string-append id "-body")) (class (markup-class n)) @@ -1231,17 +1242,17 @@ Last update ,(it (date)).]))] e)))) (ti (let* ((nb (html-container-number n e)) (tc (markup-option n :title)) (ti (if (document? p) - (list (markup-option p :title) + (list (markup-option p :title) (engine-custom e 'file-title-separator) tc) tc)) - (sep (engine-custom + (sep (engine-custom e - (symbol-append (markup-markup n) + (symbol-append (markup-markup n) '-title-number-separator))) (nti (and tc (if (and nb (not (equal? nb ""))) - (list nb + (list nb (if (unspecified? sep) ". " sep) ti) ti)))) @@ -1344,7 +1355,7 @@ Last update ,(it (date)).]))] e)))) ;; on-file section writer (markup-writer 'section :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) + :predicate (lambda (n e) (or (markup-option n :file) (engine-custom e 'section-file))) :action &html-generic-subdocument) @@ -1356,11 +1367,11 @@ Last update ,(it (date)).]))] e)))) :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) + :predicate (lambda (n e) (or (markup-option n :file) (engine-custom e 'subsection-file))) :action &html-generic-subdocument) @@ -1376,7 +1387,7 @@ Last update ,(it (date)).]))] e)))) ;; on-file subsection writer (markup-writer 'section :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) + :predicate (lambda (n e) (or (markup-option n :file) (engine-custom e 'subsubsection-file))) :action &html-generic-subdocument) @@ -1384,7 +1395,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* paragraph ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '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>" @@ -1405,7 +1416,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* linebreak ... */ ;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak +(markup-writer 'linebreak :before (lambda (n e) (display "<br") (html-class n) @@ -1414,14 +1425,14 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* hrule ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '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) + (if (< width 100) (printf " width=\"~a\"" (html-width width))) (if (> height 1) (printf " size=\"~a\"" height)) @@ -1432,7 +1443,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ (markup-writer 'color :options '(:bg :fg :width :margin) - :before (lambda (n e) + :before (lambda (n e) (let ((m (markup-option n :margin)) (w (markup-option n :width)) (bg (markup-option n :bg)) @@ -1446,7 +1457,7 @@ Last update ,(it (date)).]))] e)))) (display "<td bgcolor=\"") (output bg e) (display "\">")) - (when (html-color-spec? fg) + (when (html-color-spec? fg) (display "<font color=\"") (output fg e) (display "\">")))) @@ -1461,7 +1472,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ (markup-writer 'frame :options '(:width :margin :border) - :before (lambda (n e) + :before (lambda (n e) (let ((m (markup-option n :margin)) (b (markup-option n :border)) (w (markup-option n :width))) @@ -1478,7 +1489,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ (markup-writer 'font :options '(:size :face) - :before (lambda (n e) + :before (lambda (n e) (let ((size (markup-option n :size)) (face (markup-option n :face))) (when (and (number? size) (inexact? size)) @@ -1527,8 +1538,8 @@ Last update ,(it (date)).]))] e)))) (html-class n) (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">")) (else - (skribe-error 'flush - "Illegal side" + (skribe-error 'flush + "Illegal side" (markup-option n :side))))) :after (lambda (n e) (case (markup-option n :side) @@ -1563,7 +1574,7 @@ Last update ,(it (date)).]))] e)))) ;* itemize ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'itemize - :options '(:symbol) + :options '(:symbol) :before (html-markup-class "ul") :action (lambda (n e) (for-each (lambda (item) @@ -1584,7 +1595,7 @@ Last update ,(it (date)).]))] e)))) ;* enumerate ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'enumerate - :options '(:symbol) + :options '(:symbol) :before (html-markup-class "ol") :action (lambda (n e) (for-each (lambda (item) @@ -1604,7 +1615,7 @@ Last update ,(it (date)).]))] e)))) ;* description ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'description - :options '(:symbol) + :options '(:symbol) :before (html-markup-class "dl") :action (lambda (n e) (for-each (lambda (item) @@ -1628,7 +1639,7 @@ Last update ,(it (date)).]))] e)))) ;* item ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'item - :options '(:key) + :options '(:key) :action (lambda (n e) (let ((k (markup-option n :key))) (if k @@ -1643,9 +1654,9 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* blockquote ... */ ;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote +(markup-writer 'blockquote :options '() - :before (lambda (n e) + :before (lambda (n e) (display "<blockquote ") (html-class n) (display ">\n")) @@ -1679,17 +1690,17 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* &html-figure-legend ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '&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 + (if number (printf "<strong>Fig. ~a:</strong> " number) (printf "<strong>Fig. :</strong> ")))) :after "</center>") - + ;*---------------------------------------------------------------------*/ ;* table ... */ ;*---------------------------------------------------------------------*/ @@ -1719,7 +1730,7 @@ Last update ,(it (date)).]))] e)))) ((number? cstyle) (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) (if frame - (printf " frame=\"~a\"" + (printf " frame=\"~a\"" (if (eq? frame 'none) "void" frame))) (if (and rules (not (eq? rules 'header))) (printf " rules=\"~a\"" rules)) @@ -1738,7 +1749,7 @@ Last update ,(it (date)).]))] e)))) (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) (display ">"))) :after "</tr>\n") - + ;*---------------------------------------------------------------------*/ ;* tc ... */ ;*---------------------------------------------------------------------*/ @@ -1771,7 +1782,7 @@ Last update ,(it (date)).]))] e)))) :after (lambda (n e) (let ((markup (or (markup-option n 'markup) 'td))) (printf "</~a>" markup)))) - + ;*---------------------------------------------------------------------*/ ;* image ... @label image@ */ ;*---------------------------------------------------------------------*/ @@ -1784,7 +1795,7 @@ Last update ,(it (date)).]))] e)))) (height (markup-option n :height)) (body (markup-body n)) (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file + (img (or url (convert-image file (if (list? efmt) efmt '("gif" "jpg" "png")))))) @@ -1851,7 +1862,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ (markup-writer 'mailto :options '(:text) - :predicate (lambda (n e) + :predicate (lambda (n e) (and (engine-custom e 'javascript) (or (string? (markup-body n)) (and (pair? (markup-body n)) @@ -1926,7 +1937,7 @@ Last update ,(it (date)).]))] e)))) (markup '&html-section-ref) (body (markup-body n))) e)) - + ((not m) (output (new markup (markup '&html-unmark-ref) @@ -1939,7 +1950,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* &html-figure-ref ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-ref +(markup-writer '&html-figure-ref :action (lambda (n e) (let ((c (handle-ast (markup-body n)))) (if (or (not (markup? c)) @@ -1950,7 +1961,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* &html-section-ref ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '&html-section-ref +(markup-writer '&html-section-ref :action (lambda (n e) (let ((c (handle-ast (markup-body n)))) (if (not (markup? c)) @@ -1960,7 +1971,7 @@ Last update ,(it (date)).]))] e)))) ;*---------------------------------------------------------------------*/ ;* &html-unmark-ref ... */ ;*---------------------------------------------------------------------*/ -(markup-writer '&html-unmark-ref +(markup-writer '&html-unmark-ref :action (lambda (n e) (let ((c (handle-ast (markup-body n)))) (if (not (markup? c)) @@ -1971,8 +1982,8 @@ Last update ,(it (date)).]))] e)))) (let ((l (markup-option c :legend))) (if l (output t e) - (display - (string-canonicalize + (display + (string-canonicalize (markup-ident c))))))))))) ;*---------------------------------------------------------------------*/ @@ -1990,7 +2001,7 @@ Last update ,(it (date)).]))] e)))) (markup-writer 'bib-ref+ :options '(:text :bib) :before "[" - :action (lambda (n e) + :action (lambda (n e) (let loop ((rs (markup-body n))) (cond ((null? rs) @@ -2032,7 +2043,7 @@ Last update ,(it (date)).]))] e)))) (display "\"") (when class (printf " class=\"~a\"" class)) (display ">"))) - :action (lambda (n e) + :action (lambda (n e) (let ((v (markup-option n :text))) (output (or v (markup-option n :url)) e))) :after "</a>") @@ -2060,7 +2071,7 @@ Last update ,(it (date)).]))] e)))) :options '(:mark :handle) :action (lambda (n e) (error 'page-ref:html "Not implemented yet" n))) - + ;*---------------------------------------------------------------------*/ ;* &bib-entry-label ... */ ;*---------------------------------------------------------------------*/ @@ -2125,7 +2136,7 @@ Last update ,(it (date)).]))] e)))) (color :fg cc n1) n1))) (skribe-eval n2 e)))) - + ;*---------------------------------------------------------------------*/ ;* &source-line-comment ... */ ;*---------------------------------------------------------------------*/ @@ -2137,7 +2148,7 @@ Last update ,(it (date)).]))] e)))) (color :fg cc n1) n1))) (skribe-eval n2 e)))) - + ;*---------------------------------------------------------------------*/ ;* &source-keyword ... */ ;*---------------------------------------------------------------------*/ diff --git a/skr/html4.skr b/src/guile/skribilo/engine/html4.scm index acb7068..614ca99 100644 --- a/skr/html4.skr +++ b/src/guile/skribilo/engine/html4.scm @@ -1,38 +1,40 @@ ;;;; ;;;; 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, +;;;; 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 + (cond ((null? l) l) ((pair? l) (append (flat (car l)) (flat (cdr l)))) (else (list l)))) - - (if (markup? node) + + (if (markup? node) (flat (markup-body node)) node)) @@ -45,9 +47,9 @@ (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 ... + ;; &html-html ... ;;---------------------------------------------------------------------- (markup-writer '&html-html le :before "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> @@ -55,21 +57,21 @@ :after "</html>") ;;---------------------------------------------------------------------- - ;; &html-ending + ;; &html-ending ;;---------------------------------------------------------------------- (let* ((img (engine-custom le 'html4-logo)) (url (engine-custom le 'html4-validator)) - (bottom (list (hrule) + (bottom (list (hrule) (table :width 100. (tr (td :align 'left (font :size -1 [ - This ,(sc "Html") page has been produced by + 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 + (ref :url url :text (image :url img :width 88 :height 31)))))))) (markup-writer '&html-ending le :before "<div class=\"skribe-ending\">" @@ -79,13 +81,13 @@ (output body #t) (skribe-eval bottom e)))) :after "</div>\n")) - + ;;---------------------------------------------------------------------- ;; color ... ;;---------------------------------------------------------------------- (markup-writer 'color le :options '(:bg :fg :width :margin) - :before (lambda (n e) + :before (lambda (n e) (let ((m (markup-option n :margin)) (w (markup-option n :width)) (bg (markup-option n :bg)) @@ -106,27 +108,27 @@ :after (lambda (n e) (when (markup-option n :fg) (display "</span>")) - (when (markup-option n :bg) + (when (markup-option n :bg) (display "</td></tr>\n</tbody></table>")))) - + ;;---------------------------------------------------------------------- ;; font ... ;;---------------------------------------------------------------------- (markup-writer 'font le :options '(:size :face) - :before (lambda (n e) + :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 + (format "~a%" + (+ 100 (* 20 (inexact->exact (truncate sz)))))) ((number? sz) sz) - (else + (else (skribe-error 'font (format "Illegal font size ~s" sz) n)))))) @@ -153,8 +155,8 @@ ;;---------------------------------------------------------------------- (markup-writer 'roman le :before "<span style=\"font-family: serif\">" - :after "</span>") - + :after "</span>") + ;;---------------------------------------------------------------------- ;; table ... ;;---------------------------------------------------------------------- diff --git a/skr/latex-simple.skr b/src/guile/skribilo/engine/latex-simple.scm index dd2eccb..638c158 100644 --- a/skr/latex-simple.skr +++ b/src/guile/skribilo/engine/latex-simple.scm @@ -1,5 +1,7 @@ +(define-skribe-module (skribilo engine latex-simple)) + ;;; -;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER +;;; 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 ;;; @@ -24,7 +26,7 @@ "\\usepackage{epsfig} \\usepackage{workshop} \\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} - {September 22, 2004, Snowbird, Utah, USA.} + {September 22, 2004, Snowbird, Utah, USA.} \\CopyrightYear{2004} \\CopyrightHolder{Damien Ciabrini} \\renewcommand{\\ttdefault}{cmtt} @@ -46,28 +48,28 @@ :options '(:text :bib) :before "\\cite{" :action (lambda (n e) (display (markup-option n :bib))) - :after "}") + :after "}") (markup-writer 'bib-ref+ le :options '(:text :bib) :before "\\cite{" - :action (lambda (n e) + :action (lambda (n e) (let loop ((bibs (markup-option n :bib))) (if (pair? bibs) - (begin + (begin (display (car bibs)) (if (pair? (cdr bibs)) (display ", ")) (loop (cdr bibs)))))) :after "}") (markup-writer '&the-bibliography le - :action (lambda (n e) + :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) + (if (pair? body) (print "\\numberofauthors{" (length body) "}")) (print "\\author{"))) :after "}\n") @@ -80,9 +82,9 @@ (address (markup-option n :address)) (email (markup-option n :email))) (define (row pre n post) - (display pre) + (display pre) (output n e) - (display post) + (display post) (display "\\\\\n")) ;; name (if name (row "\\alignauthor " name "")) @@ -97,5 +99,5 @@ :after "") ) -(define (include-biblio) +(define (include-biblio) (the-bibliography)) diff --git a/skr/latex.skr b/src/guile/skribilo/engine/latex.scm index bc20493..bc20493 100644 --- a/skr/latex.skr +++ b/src/guile/skribilo/engine/latex.scm diff --git a/skr/xml.skr b/src/guile/skribilo/engine/xml.scm index 784b6f0..4f26d12 100644 --- a/skr/xml.skr +++ b/src/guile/skribilo/engine/xml.scm @@ -16,6 +16,8 @@ ;* @ref ../../doc/user/xmle.skb:ref@ */ ;*=====================================================================*/ +(define-skribe-module (skribilo engine xml)) + ;*---------------------------------------------------------------------*/ ;* xml-engine ... */ ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/eval.scm b/src/guile/skribilo/evaluator.scm index 8bae8ad..b7e04c1 100644 --- a/src/guile/skribilo/eval.scm +++ b/src/guile/skribilo/evaluator.scm @@ -26,31 +26,31 @@ ;; FIXME; On peut implémenter maintenant skribe-warning/node -(define-module (skribilo eval) +(define-module (skribilo evaluator) :export (skribe-eval skribe-eval-port skribe-load skribe-load-options - skribe-include - - run-time-module make-run-time-module)) + skribe-include)) (use-modules (skribilo debug) + (skribilo reader) (skribilo engine) (skribilo verify) (skribilo resolve) (skribilo output) - (ice-9 optargs)) + (skribilo types) + (skribilo lib) + (skribilo vars) + (ice-9 optargs) + (oop goops)) -(define *skribe-loaded* '()) ;; List of already loaded files -(define *skribe-load-options* '()) - -(define (%evaluate expr) - (eval expr (current-module))) - + +;;; 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) @@ -58,31 +58,50 @@ (skribilo runtime) (skribilo biblio) (skribilo lib) - (skribilo resolve))) + (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 (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))) - *skribilo-user-imports*) + (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 (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 ;;; @@ -98,19 +117,20 @@ execution of Skribilo/Skribe code." ;;; ;;; SKRIBE-EVAL-PORT ;;; -(define* (skribe-eval-port port engine #:key (env '())) +(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 (read port))) + (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 (read port)))))))) + (loop (reader port)))))))) ;;; ;;; SKRIBE-LOAD @@ -124,13 +144,14 @@ execution of Skribilo/Skribe code." (with-debug 4 'skribe-load (debug-item " engine=" engine) (debug-item " path=" path) - (debug-item " opt" opt) + (debug-item " opt=" opt) (let* ((ei (cond ((not engine) *skribe-engine*) ((engine? engine) engine) - ((not (symbol? engine)) (skribe-error 'skribe-load - "Illegal engine" engine)) + ((not (symbol? engine)) + (skribe-error 'skribe-load + "Illegal engine" engine)) (else engine))) (path (cond ((not path) (skribe-path)) @@ -138,14 +159,14 @@ execution of Skribilo/Skribe code." ((not (and (list? path) (every? string? path))) (skribe-error 'skribe-load "Illegal path" path)) (else path))) - (filep (find-path file path))) + (filep (search-path path file))) (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*)) + (string-append "cannot find `" file "' in path") + (skribe-path))) ;; Load this file if not already done (unless (member filep *skribe-loaded*) @@ -167,7 +188,7 @@ execution of Skribilo/Skribe code." (unless (every string? path) (skribe-error 'skribe-include "Illegal path" path)) - (let ((path (find-path file 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) 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))) |