diff options
| author | Ludovic Court`es | 2006-10-11 07:43:47 +0000 |
|---|---|---|
| committer | Ludovic Court`es | 2006-10-11 07:43:47 +0000 |
| commit | d4360259d60722eaa175a483f792fce7b8c66d97 (patch) | |
| tree | 622cc21b820e3dd4616890bc9ccba74de6637d8a /src/guile | |
| parent | fc42fe56a57eace2dbdb31574c2e161f0eacf839 (diff) | |
| download | skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.gz skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.lz skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.zip | |
slide: Propagate the `outline?' parameter in `slide-(sub)?topic'.
* src/guile/skribilo/package/slide.scm (slide-topic): Propagate the
`outline?' parameter as an option.
(slide-subtopic): Likewise.
git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1
Diffstat (limited to 'src/guile')
83 files changed, 26258 insertions, 0 deletions
diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..e410a87 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,5 @@ +SUBDIRS = skribilo + +guilemoduledir = $(GUILE_SITE) +dist_guilemodule_DATA = skribilo.scm +EXTRA_DIST = README diff --git a/src/guile/README b/src/guile/README new file mode 100644 index 0000000..6c5128f --- /dev/null +++ b/src/guile/README @@ -0,0 +1,63 @@ +Skribilo -*- Outline -*- +======== + +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. + +** Add useful markups + +- `document': add `:keywords' and `:language', maybe `:date' + +- numbered references + +- improved footnotes + +** Add an option to continuously watch a file and re-compile it + +* Font-ends (readers) + +** Implement a new front-end mechanism (see `(skribilo reader)') + +** Skribe front-end (read Skribe syntax) + +Done. + +** Texinfo front-end + +Use guile-library's `stexi'. + +** Simple markup front-end (à la `txt2tags', Emacs' outline mode, or Wiki) + +Almost done (Emacs `outline-mode'). + +* 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?) + +Done, except automatic invocation. + +** Info back-end + +* Packages + +** Pie charts + +** Equations + +* Toys + +** Document browser with guile-gnome + + +;;; arch-tag: 2d0a6235-5c09-4930-998c-56a4de2c0aca diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm new file mode 100644 index 0000000..531b0fb --- /dev/null +++ b/src/guile/skribilo.scm @@ -0,0 +1,480 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(skribilo)) '\'main')' +exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@" +!# + +;;;; skribilo.scm +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. + +;;;; Commentary: +;;;; +;;;; Usage: skribilo [ARGS] +;;;; +;;;; Process a skribilo document. +;;;; +;;;; Code: + + + +(define-module (skribilo) + :autoload (skribilo module) (make-run-time-module *skribilo-user-module*) + :autoload (skribilo engine) (*current-engine*) + :autoload (skribilo reader) (*document-reader*) + :use-module (skribilo utils syntax)) + +(use-modules (skribilo evaluator) + (skribilo debug) + (skribilo parameters) + (skribilo lib) + + (srfi srfi-39) + (ice-9 optargs) + (ice-9 getopt-long)) + + +;; Install the Skribilo module syntax reader. +(fluid-set! current-reader %skribilo-module-reader) + +(if (not (keyword? :kw)) + (error "guile-reader sucks")) + + + + +(define* (process-option-specs longname + :key (alternate #f) (arg #f) (help #f) + :rest thunk) + "Process STkLos-like option specifications and return getopt-long option +specifications." + `(,(string->symbol longname) + ,@(if alternate + `((single-char ,(string-ref alternate 0))) + '()) + (value ,(if arg #t #f)))) + +(define (raw-options->getopt-long options) + "Converts @var{options} to a getopt-long-compatible representation." + (map (lambda (option-specs) + (apply process-option-specs (car option-specs))) + options)) + +(define-macro (define-options binding . options) + `(define ,binding (quote ,(raw-options->getopt-long options)))) + +(define-options skribilo-options + (("reader" :alternate "R" :arg reader + (nothing))) + (("target" :alternate "t" :arg target + :help "sets the output format to <target>") + (set! engine (string->symbol target))) + (("load-path" :alternate "I" :arg path :help "adds <path> to Skribe path") + (set! paths (cons path paths))) + (("bib-path" :alternate "B" :arg path :help "adds <path> to bibliography path") + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("source-path" :alternate "S" :arg path :help "adds <path> to source path") + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("image-path" :alternate "P" :arg path :help "adds <path> to image path") + (skribe-image-path-set! (cons path (skribe-image-path)))) + (("split-chapters" :alternate "C" :arg chapter + :help "emit chapter's sections in separate files") + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("preload" :arg file :help "preload <file>") + (set! *skribe-preload* (cons file *skribe-preload*))) + (("use-variant" :alternate "u" :arg variant + :help "use <variant> output format") + (set! *skribe-variants* (cons variant *skribe-variants*))) + (("base" :alternate "b" :arg base + :help "base prefix to remove from hyperlinks") + (set! *skribe-ref-base* base)) + (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>") + (set! *skribe-rc-directory* dir)) + + ;;"File options:" + (("no-init-file" :help "Dont load rc Skribe file") + (set! *load-rc* #f)) + (("output" :alternate "o" :arg file :help "set the output to <file>") + (set! *skribe-dest* file) + (let* ((s (file-suffix file)) + (c (assoc s *skribe-auto-mode-alist*))) + (if (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + + ;;"Misc:" + (("help" :alternate "h" :help "provides help for the command") + (arg-usage (current-error-port)) + (exit 0)) + (("options" :help "display the skribe options and exit") + (arg-usage (current-output-port) #t) + (exit 0)) + (("version" :alternate "V" :help "displays the version of Skribe") + (version) + (exit 0)) + (("query" :alternate "q" + :help "displays informations about Skribe conf.") + (query) + (exit 0)) + (("verbose" :alternate "v" :arg level + :help "sets the verbosity to <level>. Use -v0 for crystal silence") + (let ((val (string->number level))) + (if (integer? val) + (set! *skribe-verbose* val)))) + (("warning" :alternate "w" :arg level + :help "sets the verbosity to <level>. Use -w0 for crystal silence") + (let ((val (string->number level))) + (if (integer? val) + (set! *skribe-warning* val)))) + (("debug" :alternate "g" :arg level :help "sets the debug <level>") + (let ((val (string->number level))) + (if (integer? val) + (set-skribe-debug! val) + (begin + ;; Use the symbol for debug + (set-skribe-debug! 1) + (add-skribe-debug-symbol (string->symbol level)))))) + (("no-color" :help "disable coloring for output") + (no-debug-color)) + (("custom" :alternate "c" :arg key=val :help "Preset custom value") + (let ((args (string-split key=val "="))) + (if (and (list args) (= (length args) 2)) + (let ((key (car args)) + (val (cadr args))) + (set! *skribe-precustom* (cons (cons (string->symbol key) val) + *skribe-precustom*))) + (error 'parse-arguments "Bad custom ~S" key=val)))) + (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>") + (with-input-from-string expr + (lambda () (eval (read)))))) + + +; (define skribilo-options +; ;; Skribilo options in getopt-long's format, as computed by +; ;; `raw-options->getopt-long'. +; `((target (single-char #\t) (value #f)) +; (I (value #f)) +; (B (value #f)) +; (S (value #f)) +; (P (value #f)) +; (split-chapters (single-char #\C) (value #f)) +; (preload (value #f)) +; (use-variant (single-char #\u) (value #f)) +; (base (single-char #\b) (value #f)) +; (rc-dir (single-char #\d) (value #f)) +; (no-init-file (value #f)) +; (output (single-char #\o) (value #f)) +; (help (single-char #\h) (value #f)) +; (options (value #f)) +; (version (single-char #\V) (value #f)) +; (query (single-char #\q) (value #f)) +; (verbose (single-char #\v) (value #f)) +; (warning (single-char #\w) (value #f)) +; (debug (single-char #\g) (value #f)) +; (no-color (value #f)) +; (custom (single-char #\c) (value #f)) +; (eval (single-char #\e) (value #f)))) + + +(define (skribilo-show-help) + (format #t "Usage: skribilo [OPTIONS] [INPUT] + +Processes a Skribilo/Skribe source file and produces its output. + + --reader=READER Use READER to parse the input file (by default, + the `skribe' reader is used) + --target=ENGINE Use ENGINE as the underlying engine + + --help Give this help list + --version Print program version +~%")) + +(define (skribilo-show-version) + (format #t "skribilo ~a~%" (skribilo-release))) + +;;;; ====================================================================== +;;;; +;;;; P A R S E - A R G S +;;;; +;;;; ====================================================================== +(define (parse-args args) + + (define (version) + (format #t "skribe v~A\n" (skribe-release))) + + (define (query) + (version) + (for-each (lambda (x) + (let ((s (keyword->string (car x)))) + (printf " ~a: ~a\n" s (cadr x)))) + (skribe-configure))) + + ;; + ;; parse-args starts here + ;; + (let ((paths '()) + (engine #f)) + (parse-arguments args + "Usage: skribe [options] [input]" + "General options:" + (("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") + (set! paths (cons path paths))) + (("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)))) + (("P" :arg path :help "adds <path> to image path") + (skribe-image-path-set! (cons path (skribe-image-path)))) + (("split-chapters" :alternate "C" :arg chapter + :help "emit chapter's sections in separate files") + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("preload" :arg file :help "preload <file>") + (set! *skribe-preload* (cons file *skribe-preload*))) + (("use-variant" :alternate "u" :arg variant + :help "use <variant> output format") + (set! *skribe-variants* (cons variant *skribe-variants*))) + (("base" :alternate "b" :arg base + :help "base prefix to remove from hyperlinks") + (set! *skribe-ref-base* base)) + (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>") + (set! *skribe-rc-directory* dir)) + + "File options:" + (("no-init-file" :help "Dont load rc Skribe file") + (set! *load-rc* #f)) + (("output" :alternate "o" :arg file :help "set the output to <file>") + (set! *skribe-dest* file) + (let* ((s (file-suffix file)) + (c (assoc s *skribe-auto-mode-alist*))) + (if (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + + "Misc:" + (("help" :alternate "h" :help "provides help for the command") + (arg-usage (current-error-port)) + (exit 0)) + (("options" :help "display the skribe options and exit") + (arg-usage (current-output-port) #t) + (exit 0)) + (("version" :alternate "V" :help "displays the version of Skribe") + (version) + (exit 0)) + (("query" :alternate "q" + :help "displays informations about Skribe conf.") + (query) + (exit 0)) + (("verbose" :alternate "v" :arg level + :help "sets the verbosity to <level>. Use -v0 for crystal silence") + (let ((val (string->number level))) + (if (integer? val) + (set! *skribe-verbose* val)))) + (("warning" :alternate "w" :arg level + :help "sets the verbosity to <level>. Use -w0 for crystal silence") + (let ((val (string->number level))) + (if (integer? val) + (set! *skribe-warning* val)))) + (("debug" :alternate "g" :arg level :help "sets the debug <level>") + (let ((val (string->number level))) + (if (integer? val) + (set-skribe-debug! val) + (begin + ;; Use the symbol for debug + (set-skribe-debug! 1) + (add-skribe-debug-symbol (string->symbol level)))))) + (("no-color" :help "disable coloring for output") + (no-debug-color)) + (("custom" :alternate "c" :arg key=val :help "Preset custom value") + (let ((args (string-split key=val "="))) + (if (and (list args) (= (length args) 2)) + (let ((key (car args)) + (val (cadr args))) + (set! *skribe-precustom* (cons (cons (string->symbol key) val) + *skribe-precustom*))) + (error 'parse-arguments "Bad custom ~S" key=val)))) + (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>") + (with-input-from-string expr + (lambda () (eval (read))))) + (else + (set! *skribe-src* other-arguments))) + + ;; we have to configure Skribe path according to the environment variable + (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH"))) + (if path + (string-split path ":") + '())) + (reverse! paths) + (skribe-default-path))) + ;; Final initializations + (if engine + (set! *skribe-engine* engine)))) + +;;;; ====================================================================== +;;;; +;;;; L O A D - R C +;;;; +;;;; ====================================================================== +(define *load-rc* #f) ;; FIXME: This should go somewhere else. + +(define (load-rc) + (if *load-rc* + (let ((file (make-path (*rc-directory*) (*rc-file*)))) + (if (and file (file-exists? file)) + (load file))))) + + +;;;; ====================================================================== +;;;; +;;;; 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 *skribilo-output-port* (make-parameter (current-output-port))) + +(define (doskribe) + (let ((output-port (current-output-port)) + (user-module (current-module))) + (dynamic-wind + (lambda () + ;; FIXME: Using this technique, anything written to `stderr' will + ;; also end up in the output file (e.g. Guile warnings). + (set-current-output-port (*skribilo-output-port*)) + (let ((user (make-run-time-module))) + (set-current-module user) + (*skribilo-user-module* user))) + (lambda () + ;;(format #t "engine is ~a~%" (*current-engine*)) + (evaluate-document-from-port (current-input-port) + (*current-engine*))) + (lambda () + (set-current-output-port output-port) + (set-current-module user-module) + (*skribilo-user-module* #f))))) + + + +;;;; ====================================================================== +;;;; +;;;; M A I N +;;;; +;;;; ====================================================================== +(define-public (skribilo . args) + (let* ((options (getopt-long (cons "skribilo" args) + skribilo-options)) + (reader-name (string->symbol + (option-ref options 'reader "skribe"))) + (engine (string->symbol + (option-ref options 'target "html"))) + (output-file (option-ref options 'output #f)) + (debugging-level (option-ref options 'debug "0")) + (warning-level (option-ref options 'warning "2")) + (load-path (option-ref options 'load-path ".")) + (bib-path (option-ref options 'bib-path ".")) + (source-path (option-ref options 'source-path ".")) + (image-path (option-ref options 'image-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) + + (cond (help-wanted (begin (skribilo-show-help) (exit 1))) + (version-wanted (begin (skribilo-show-version) (exit 1)))) + + ;; Parse the most important options. + + (if (> (*debug*) 4) + (set! %load-hook + (lambda (file) + (format #t "~~ loading `~a'...~%" file)))) + + (parameterize ((*document-reader* (make-reader reader-name)) + (*current-engine* engine) + (*document-path* (cons load-path (*document-path*))) + (*bib-path* (cons bib-path (*bib-path*))) + (*source-path* (cons source-path + (append %load-path + (*source-path*)))) + (*image-path* (cons image-path (*image-path*))) + (*debug* (string->number debugging-level)) + (*warning* (string->number warning-level)) + (*verbose* (let ((v (option-ref options + 'verbose 0))) + (if (number? v) v + (if v 1 0))))) + + ;; Load the user rc file + ;;(load-rc) + + (for-each (lambda (f) + (skribe-load f :engine (*current-engine*))) + preload) + + ;; Load the specified variants. + (for-each (lambda (x) + (skribe-load (format #f "~a.skr" x) + :engine (*current-engine*))) + (reverse! variants)) + + (let ((files (option-ref options '() '()))) + + (if (> (length files) 2) + (error "you can specify at most one input file and one output file" + files)) + + (let* ((source-file (if (null? files) #f (car files)))) + + (if (and output-file (file-exists? output-file)) + (delete-file output-file)) + + (parameterize ((*destination-file* output-file) + (*source-file* source-file) + (*skribilo-output-port* + (if (string? output-file) + (open-output-file output-file) + (current-output-port)))) + + (setvbuf (*skribilo-output-port*) _IOFBF 16384) + + ;; (start-stack 7 + (if source-file + (with-input-from-file source-file doskribe) + (doskribe)))))))) + + +(define main skribilo) + +;;; skribilo ends here. diff --git a/src/guile/skribilo/.arch-inventory b/src/guile/skribilo/.arch-inventory new file mode 100644 index 0000000..d9ada5e --- /dev/null +++ b/src/guile/skribilo/.arch-inventory @@ -0,0 +1,5 @@ +# Object files generated by Guile-VM's compiler + configuration file +# generated at `configure'-time. +precious ^(.*\.go|config.scm)$ + +# arch-tag: c25ac71e-94bc-4246-8486-49e4179987b8 diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am new file mode 100644 index 0000000..48fa5ca --- /dev/null +++ b/src/guile/skribilo/Makefile.am @@ -0,0 +1,10 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm \ + source.scm parameters.scm verify.scm \ + writer.scm ast.scm location.scm \ + condition.scm + +SUBDIRS = utils reader engine package coloring biblio diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm new file mode 100644 index 0000000..542f629 --- /dev/null +++ b/src/guile/skribilo/ast.scm @@ -0,0 +1,602 @@ +;;; ast.scm -- Skribilo abstract syntax trees. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo ast) + :use-module (oop goops) + + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + :use-module (skribilo condition) + :use-module (skribilo utils syntax) + + :autoload (skribilo location) (location?) + :autoload (srfi srfi-1) (fold) + :export (<ast> ast? ast-loc ast-loc-set! + ast-parent ast->string ast->file-location + ast-resolved? + + <command> command? command-fmt command-body + <unresolved> unresolved? unresolved-proc + <handle> handle? handle-ast handle-body + <node> node? node-options node-loc node-body + <processor> processor? processor-combinator processor-engine + + <markup> markup? markup-options is-markup? + markup-markup markup-body markup-body-set! + markup-ident markup-class + markup-option markup-option-set! + markup-option-add! markup-output + markup-parent markup-document markup-chapter + + <container> container? container-options + container-ident container-body + container-env-get + + <document> document? document-ident document-body + document-options document-end + document-lookup-node document-bind-node! + document-bind-nodes! + + ;; traversal + ast-fold + container-search-down search-down find-down find1-down + find-up find1-up + ast-document ast-chapter ast-section + + ;; error conditions + &ast-error &ast-orphan-error &ast-cycle-error + &markup-unknown-option-error &markup-already-bound-error + ast-orphan-error? ast-orphan-error:ast + ast-cycle-error? ast-cycle-error:object + markup-unknown-option-error? + markup-unknown-option-error:markup + markup-unknown-option-error:option + markup-already-bound-error? + markup-already-bound-error:markup + markup-already-bound-error:ident)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; The abstract syntax tree (AST) and its sub-types. These class form the +;;; core of a document: each part of a document is an instance of `<ast>' or +;;; one of its sub-classes. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Error conditions. +;;; + +(define-condition-type &ast-error &skribilo-error + ast-error?) + +(define-condition-type &ast-orphan-error &ast-error + ast-orphan-error? + (ast ast-orphan-error:ast)) + +(define-condition-type &ast-cycle-error &ast-error + ast-cycle-error? + (object ast-cycle-error:object)) + +(define-condition-type &markup-unknown-option-error &ast-error + markup-unknown-option-error? + (markup markup-unknown-option-error:markup) + (option markup-unknown-option-error:option)) + +(define-condition-type &markup-already-bound-error &ast-error + markup-already-bound-error? + (markup markup-already-bound-error:markup) + (ident markup-already-bound-error:ident)) + + +(define (handle-ast-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((ast-orphan-error? c) + (let* ((node (ast-orphan-error:ast c)) + (location (and (ast? node) (ast-loc node)))) + (format (current-error-port) "orphan node: ~a~a~%" + node + (if (location? location) + (string-append " " + (location-file location) ":" + (location-line location)) + "")))) + + ((ast-cycle-error? c) + (let ((object (ast-cycle-error:object c))) + (format (current-error-port) + "cycle found in AST: ~a~%" object))) + + ((markup-unknown-option-error? c) + (let ((markup (markup-unknown-option-error:markup c)) + (option (markup-unknown-option-error:option c))) + (format (current-error-port) + "~a: unknown markup option for `~a'~%" + option markup))) + + ((markup-already-bound-error? c) + (let ((markup (markup-already-bound-error:markup c)) + (ident (markup-already-bound-error:ident c))) + (format (current-error-port) + "`~a' (~a): markup identifier already bound~%" + ident + (if (markup? markup) + (markup-markup markup) + markup)))) + + (else + (format (current-error-port) "undefined resolution error: ~a~%" + c)))) + +(register-error-condition-handler! ast-error? handle-ast-error) + + + +;;; +;;; Abstract syntax tree (AST). +;;; + +;;FIXME: set! location in <ast> +(define-class <ast> () + ;; Parent of this guy. + (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) + + ;; Its source location. + (loc :init-value #f) + + ;; This slot is used as an optimization when resolving an AST: sub-parts of + ;; the tree are marked as resolved as soon as they are and don't need to be + ;; traversed again. + (resolved? :accessor ast-resolved? :init-value #f)) + + +(define (ast? obj) (is-a? obj <ast>)) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) +(define (ast-parent n) + (slot-ref n 'parent)) + + +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format #f "~a:~a:" (location-file l) (location-line l)) + ""))) + +(define-generic ast->string) + +(define-method (ast->string (ast <top>)) "") +(define-method (ast->string (ast <string>)) ast) +(define-method (ast->string (ast <number>)) (number->string ast)) + +(define-method (ast->string (ast <pair>)) + (let ((out (open-output-string))) + (let Loop ((lst ast)) + (cond + ((null? lst) + (get-output-string out)) + (else + (display (ast->string (car lst)) out) + (unless (null? (cdr lst)) + (display #\space out)) + (Loop (cdr lst))))))) + + + +;;; ====================================================================== +;;; +;;; <COMMAND> +;;; +;;; ====================================================================== +(define-class <command> (<ast>) + (fmt :init-keyword :fmt) + (body :init-keyword :body)) + +(define (command? obj) (is-a? obj <command>)) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;; ====================================================================== +;;; +;;; <UNRESOLVED> +;;; +;;; ====================================================================== +(define-class <unresolved> (<ast>) + (proc :init-keyword :proc)) + +(define (unresolved? obj) (is-a? obj <unresolved>)) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;; ====================================================================== +;;; +;;; <HANDLE> +;;; +;;; ====================================================================== +(define-class <handle> (<ast>) + (ast :init-keyword :ast :init-value #f :getter handle-ast)) + +(define (handle? obj) (is-a? obj <handle>)) +(define (handle-ast obj) (slot-ref obj 'ast)) +(define (handle-body h) (slot-ref h 'body)) + +;;; ====================================================================== +;;; +;;; <NODE> +;;; +;;; ====================================================================== +(define-class <node> (<ast>) + (required-options :init-keyword :required-options :init-value '()) + (options :init-keyword :options :init-value '()) + (body :init-keyword :body :init-value #f + :getter node-body)) + +(define (node? obj) (is-a? obj <node>)) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + +(define-method (ast->string (ast <node>)) + (ast->string (slot-ref ast 'body))) + + +;;; ====================================================================== +;;; +;;; <PROCESSOR> +;;; +;;; ====================================================================== +(define-class <processor> (<node>) + (combinator :init-keyword :combinator :init-value (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-value 'unspecified) + (procedure :init-keyword :procedure :init-value (lambda (n e) n))) + +(define (processor? obj) (is-a? obj <processor>)) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + + + +;;; +;;; Markup. +;;; + +(define-class <markup> (<node>) + (ident :init-keyword :ident :getter markup-ident :init-value #f) + (class :init-keyword :class :getter markup-class :init-value #f) + (markup :init-keyword :markup :getter markup-markup)) + + +(define (markup? obj) (is-a? obj <markup>)) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) +(define (markup-body-set! m body) + (slot-set! m 'resolved? #f) + (slot-set! m 'body body)) + +(define (markup-option m opt) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (and (pair? c) (pair? (cdr c)) + (cadr c))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option") + (argument m)))))) + +(define (markup-option-set! m opt val) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (if (and (pair? c) (pair? (cdr c))) + (set-cdr! c (list val)) + (raise (condition (&markup-unknown-option-error + (markup m) + (option opt)))))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-set!") + (argument m)))))) + +(define (markup-option-add! m opt val) + (if (markup? m) + (slot-set! m 'options (cons (list opt val) + (slot-ref m 'options))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-add!") + (argument m)))))) + + +(define (is-markup? obj markup) + (and (is-a? obj <markup>) + (eq? (slot-ref obj 'markup) markup))) + + +(define (markup-parent m) + (let ((p (slot-ref m 'parent))) + (if (eq? p 'unspecified) + (raise (condition (&ast-orphan-error (ast m)))) + p))) + +(define (markup-document m) + (let Loop ((p m) + (l #f)) + (cond + ((is-markup? p 'document) p) + ((or (eq? p 'unspecified) (not p)) l) + (else (Loop (slot-ref p 'parent) p))))) + +(define (markup-chapter m) + (let loop ((p m) + (l #f)) + (cond + ((is-markup? p 'chapter) p) + ((or (eq? p 'unspecified) (not p)) l) + (else (loop (slot-ref p 'parent) p))))) + + + + +(define-method (write (obj <markup>) port) + (format port "#<~A (~A/~A) ~A>" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (object-address obj))) + +(define-method (write (node <unresolved>) port) + (let ((proc (slot-ref node 'proc))) + (format port "#<<unresolved> (~A~A) ~A>" + proc + (let* ((name (or (procedure-name proc) "")) + (source (procedure-source proc)) + (file (and source (source-property source 'filename))) + (line (and source (source-property source 'line)))) + ;;(format (current-error-port) "src=~a~%" source) + (string-append name + (if file + (string-append " " file + (if line + (number->string line) + "")) + ""))) + (object-address node)))) + + + +;;; XXX: This was already commented out in the original Skribe source. +;;; +;; (define (markup-output markup +;; :optional (engine #f) +;; :key (predicate #f) +;; (options '()) +;; (before #f) +;; (action #f) +;; (after #f)) +;; (let ((e (or engine (use-engine)))) +;; (cond +;; ((not (is-a? e <engine>)) +;; (skribe-error 'markup-writer "illegal engine" e)) +;; ((and (not before) +;; (not action) +;; (not after)) +;; (%find-markup-output e markup)) +;; (else +;; (let ((mp (if (procedure? predicate) +;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) +;; (lambda (n e) (is-markup? n markup))))) +;; (engine-output e markup mp options +;; (or before (slot-ref e 'default-before)) +;; (or action (slot-ref e 'default-action)) +;; (or after (slot-ref e 'default-after)))))))) + + + +;;; ====================================================================== +;;; +;;; <CONTAINER> +;;; +;;; ====================================================================== +(define-class <container> (<markup>) + (env :init-keyword :env :init-value '())) + +(define (container? obj) (is-a? obj <container>)) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + +(define (container-env-get m key) + (let ((c (assq key (slot-ref m 'env)))) + (and (pair? c) (cadr c)))) + + + +;;; +;;; Document. +;;; + +(define-class <document> (<container>) + (node-table :init-thunk make-hash-table :getter document-node-table) + (nodes-bound? :init-value #f :getter document-nodes-bound?)) + + +(define (document? obj) (is-a? obj <document>)) +(define (document-ident obj) (slot-ref obj 'ident)) +(define (document-body obj) (slot-ref obj 'body)) +(define document-options markup-options) +(define document-env container-env) + +(define (document-lookup-node doc ident) + ;; Lookup the node with identifier IDENT (a string) in document DOC. + (hash-ref (document-node-table doc) ident)) + +(define (document-bind-node! doc node . ident) + ;; Bind NODE (a markup object) to DOC (a document object). + (let ((ident (if (null? ident) (markup-ident node) (car ident)))) + (if ident + (let ((handle (hash-get-handle (document-node-table doc) ident))) + ;;(format (current-error-port) "binding `~a' in `~a'~%" ident node) + (if (and (pair? handle) (not (eq? (cdr handle) node))) + (raise (condition (&markup-already-bound-error + (ident ident) + (markup node)))) + (hash-set! (document-node-table doc) ident node)))))) + +(define (document-bind-nodes! doc) + ;; Bind all the nodes contained in DOC if they are not already bound. + ;; Once, this is done, `document-lookup-node' can be used to search a node + ;; by its identifier. + + ;; We assume that unresolved nodes do not introduce any new identifier, + ;; hence this optimization. + (if (document-nodes-bound? doc) + #t + (begin + (ast-fold (lambda (node result) + (if (markup? node) (document-bind-node! doc node)) + #t) + #t ;; unused + doc) + (slot-set! doc 'nodes-bound? #t)))) + + +;;; +;;; AST traversal utilities. +;;; + +(define (ast-fold proc init ast) + ;; Apply PROC to each node in AST (per `node?'), in a way similar to `fold' + ;; (in SRFI-1). + (let loop ((ast ast) + (result init)) + (cond ((pair? ast) + (fold loop result ast)) + ((node? ast) + (loop (node-body ast) (proc ast result))) + (else result)))) + + +;; The procedures below are almost unchanged compared to Skribe 1.2d's +;; `lib.scm' file found in the `common' directory, written by Manuel Serrano +;; (I removed uses of `with-debug' et al., though). + + +(define (container-search-down pred obj) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((container? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '())))) + +(define (search-down pred obj) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '())))) + +(define (find-down pred obj) + (let loop ((obj obj)) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (if (pred obj) + (list (cons obj (loop (markup-body obj)))) + '())) + (else + (if (pred obj) + (list obj) + '()))))) + +(define (find1-down pred obj) + (let loop ((obj obj) + (stack '())) + (cond + ((memq obj stack) + (raise (condition (&ast-cycle-error (object obj))))) + ((pair? obj) + (let liip ((obj obj)) + (cond + ((null? obj) + #f) + (else + (or (loop (car obj) (cons obj stack)) + (liip (cdr obj))))))) + ((pred obj) + obj) + ((markup? obj) + (loop (markup-body obj) (cons obj stack))) + (else + #f)))) + +(define (find-up pred obj) + (let loop ((obj obj) + (res '())) + (cond + ((not (ast? obj)) + res) + ((pred obj) + (loop (ast-parent obj) (cons obj res))) + (else + (loop (ast-parent obj) (cons obj res)))))) + +(define (find1-up pred obj) + (let loop ((obj obj)) + (cond + ((not (ast? obj)) + #f) + ((pred obj) + obj) + (else + (loop (ast-parent obj)))))) + +(define (ast-document m) + (find1-up document? m)) + +(define (ast-chapter m) + (find1-up (lambda (n) (is-markup? n 'chapter)) m)) + +(define (ast-section m) + (find1-up (lambda (n) (is-markup? n 'section)) m)) + + +;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7 + +;;; ast.scm ends here diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm new file mode 100644 index 0000000..1fb4b78 --- /dev/null +++ b/src/guile/skribilo/biblio.scm @@ -0,0 +1,382 @@ +;;; biblio.scm -- Bibliography functions. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA.main.st + + + +(define-module (skribilo biblio) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) ;; `when', `unless' + + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :use-module (srfi srfi-1) + :autoload (skribilo condition) (&file-search-error) + + :autoload (skribilo reader) (%default-reader) + :autoload (skribilo parameters) (*bib-path*) + :autoload (skribilo ast) (<markup> <handle> is-markup?) + + :use-module (ice-9 optargs) + :use-module (oop goops) + + :export (bib-table? make-bib-table default-bib-table + bib-add! bib-duplicate bib-for-each bib-map + skribe-open-bib-file parse-bib + + bib-load! resolve-bib resolve-the-bib make-bib-entry + + ;; sorting entries + bib-sort/authors bib-sort/idents bib-sort/dates)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Provides the bibliography data type and basic bibliography handling, +;;; including simple procedures to sort bibliography entries. +;;; +;;; FIXME: This module need cleanup! +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;; FIXME: Should be a fluid? +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + + + +;;; ====================================================================== +;;; +;;; Utilities +;;; +;;; ====================================================================== + +(define (make-bib-table ident) + (make-hash-table)) + +(define (bib-table? obj) + (hash-table? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +(define (%bib-error who entry) + (let ((msg "bibliography syntax error on entry")) + (if (%epair? entry) + (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) + (skribe-error who msg entry)))) + +(define* (bib-for-each proc :optional (table (default-bib-table))) + (hash-for-each (lambda (ident entry) + (proc ident entry)) + table)) + +(define* (bib-map proc :optional (table (default-bib-table))) + (hash-map->list (lambda (ident entry) + (proc ident entry)) + table)) + + +;;; ====================================================================== +;;; +;;; BIB-DUPLICATE +;;; +;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format #f "duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format #f " using version of `~a'.\n" ofrom) + "") + (if from + (format #f " ignoring version of `~a'." from) + " ignoring redefinition.")))) + + +;;; ====================================================================== +;;; +;;; PARSE-BIB +;;; +;;; ====================================================================== +(define (parse-bib table port) + (let ((read %default-reader)) ;; FIXME: We should use a fluid + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-filename port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate ident from old) + (hash-set! table key + (make-bib-entry kind key fields from))) + (Loop (read port)))) + (else + (%bib-error 'bib-parse entry))))))))) + + +;;; ====================================================================== +;;; +;;; BIB-ADD! +;;; +;;; ====================================================================== +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate key #f old) + (hash-set! table key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + + +;;; ====================================================================== +;;; +;;; SKRIBE-OPEN-BIB-FILE +;;; +;;; ====================================================================== +;; FIXME: Factoriser +(define (skribe-open-bib-file file command) + (let ((path (search-path (*bib-path*) file))) + (if (string? path) + (begin + (when (> (*verbose*) 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format #f command path)) + path))) + (raise (condition (&file-search-error (file-name file) + (path (*bib-path*)))))))) + + +;;; +;;; High-level API. +;;; +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `bib.scm' file found in the `common' directory. The copyright notice for +;;; this file was: +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; + + +;*---------------------------------------------------------------------*/ +;* bib-load! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-load! table filename command) + (if (not (bib-table? table)) + (skribe-error 'bib-load "Illegal bibliography table" table) + ;; read the file + (let ((p (skribe-open-bib-file filename command))) + (if (not (input-port? p)) + (skribe-error 'bib-load "Can't open data base" filename) + (unwind-protect + (parse-bib table p) + (close-input-port p)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-bib table ident) + (if (not (bib-table? table)) + (skribe-error 'resolve-bib "Illegal bibliography table" table) + (let* ((i (cond + ((string? ident) ident) + ((symbol? ident) (symbol->string ident)) + (else (skribe-error 'resolve-bib "Illegal ident" ident)))) + (en (hash-ref table i))) + (if (is-markup? en '&bib-entry) + en + #f)))) + +;*---------------------------------------------------------------------*/ +;* make-bib-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-entry kind ident fields from) + (let* ((m (make <markup> + :markup '&bib-entry + :ident ident + :options `((kind ,kind) (from ,from)))) + (h (make <handle> :ast m))) + (for-each (lambda (f) + (if (and (pair? f) + (pair? (cdr f)) + (null? (cddr f)) + (symbol? (car f))) + (markup-option-add! m + (car f) + (make <markup> + :markup (symbol-append + '&bib-entry- + (car f)) + :parent h + :body (cadr f))) + (bib-parse-error f))) + fields) + m)) + +;*---------------------------------------------------------------------*/ +;* bib-sort/authors ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/authors l) + (define (cmp i1 i2 def) + (cond + ((and (markup? i1) (markup? i2)) + (cmp (markup-body i1) (markup-body i2) def)) + ((markup? i1) + (cmp (markup-body i1) i2 def)) + ((markup? i2) + (cmp i1 (markup-body i2) def)) + ((and (string? i1) (string? i2)) + (if (string=? i1 i2) + (def) + (string<? i1 i2))) + ((string? i1) + #f) + ((string? i2) + #t) + (else + (def)))) + (sort l (lambda (e1 e2) + (cmp (markup-option e1 'author) + (markup-option e2 'author) + (lambda () + (cmp (markup-option e1 'year) + (markup-option e2 'year) + (lambda () + (cmp (markup-option e1 'title) + (markup-option e2 'title) + (lambda () + (cmp (markup-ident e1) + (markup-ident e2) + (lambda () + #t))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/idents ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/idents l) + (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/dates ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/dates l) + (sort l (lambda (p1 p2) + (define (month-num m) + (let ((body (markup-body m))) + (if (not (string? body)) + 13 + (let* ((s (if (> (string-length body) 3) + (substring body 0 3) + body)) + (sy (string->symbol (string-downcase body))) + (c (assq sy '((jan . 1) + (feb . 2) + (mar . 3) + (apr . 4) + (may . 5) + (jun . 6) + (jul . 7) + (aug . 8) + (sep . 9) + (oct . 10) + (nov . 11) + (dec . 12))))) + (if (pair? c) (cdr c) 13))))) + (let ((d1 (markup-option p1 'year)) + (d2 (markup-option p2 'year))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((y1 (markup-body d1)) + (y2 (markup-body d2))) + (cond + ((string>? y1 y2) #t) + ((string<? y1 y2) #f) + (else + (let ((d1 (markup-option p1 'month)) + (d2 (markup-option p2 'month))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((m1 (month-num d1)) + (m2 (month-num d2))) + (> m1 m2)))))))))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-the-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-bib table n sort pred count opts) + (define (count! entries) + (let loop ((es entries) + (i 1)) + (if (pair? es) + (begin + (markup-option-add! (car es) + :title + (make <markup> + :markup '&bib-entry-ident + :parent (car es) + :options `((number ,i)) + :body (make <handle> :ast (car es)))) + (loop (cdr es) (+ i 1)))))) + (if (not (bib-table? table)) + (skribe-error 'resolve-the-bib "Illegal bibliography table" table) + (let* ((es (sort (hash-map->list (lambda (key val) val) table))) + (fes (filter (if (procedure? pred) + (lambda (m) (pred m n)) + (lambda (m) (pair? (markup-option m 'used)))) + es))) + (count! (if (eq? count 'full) es fes)) + (make <markup> + :markup '&the-bibliography + :options opts + :body fes)))) + + +;;; biblio.scm ends here diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am new file mode 100644 index 0000000..9442562 --- /dev/null +++ b/src/guile/skribilo/biblio/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/biblio +dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm + +## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657 diff --git a/src/guile/skribilo/biblio/abbrev.scm b/src/guile/skribilo/biblio/abbrev.scm new file mode 100644 index 0000000..9c88b6a --- /dev/null +++ b/src/guile/skribilo/biblio/abbrev.scm @@ -0,0 +1,170 @@ +;;; abbrev.scm -- Determining abbreviations. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo biblio abbrev) + :use-module (srfi srfi-13) + :autoload (skribilo ast) (markup? markup-body-set!) + :autoload (skribilo utils strings) (make-string-replace) + :autoload (ice-9 regex) (regexp-substitute/global) + :export (is-abbreviation? is-acronym? abbreviate-word + abbreviate-string abbreviate-markup + + %cs-conference-abbreviations + %ordinal-number-abbreviations + %common-booktitle-abbreviations)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Heuristics to identify or generate abbreviations. This module +;;; particularly targets booktitle abbreviations (in bibliography entries). +;;; +;;; Code: + +(define (is-abbreviation? str) + ;; Return #t if STR denotes an abbreviation or name initial. + (and (>= (string-length str) 2) + (char=? (string-ref str 1) #\.))) + +(define (is-acronym? str) + (string=? str (string-upcase str))) + +(define (abbreviate-word word) + (if (or (string=? "" word) + (and (>= (string-length word) 3) + (string=? "and" (substring word 0 3))) + (is-acronym? word)) + word + (let ((dash (string-index word #\-)) + (abbr (string (string-ref word 0) #\.))) + (if (not dash) + abbr + (string-append (string (string-ref word 0)) "-" + (abbreviate-word + (substring word (+ 1 dash) + (string-length word)))))))) + +(define (abbreviate-string subst title) + ;; Abbreviate common conference names within TITLE based on the SUBST list + ;; of regexp-substitution pairs (see examples below). This function also + ;; removes the abbreviation if it appears in parentheses right after the + ;; substitution regexp. Example: + ;; + ;; "Symposium on Operating Systems Principles (SOSP 2004)" + ;; + ;; yields + ;; + ;; "SOSP" + ;; + (let loop ((title title) + (subst subst)) + (if (null? subst) + title + (let* ((abbr (cdar subst)) + (abbr-rexp (string-append "( \\(" abbr "[^\\)]*\\))?")) + (to-replace (string-append (caar subst) abbr-rexp))) + (loop (regexp-substitute/global #f to-replace title + 'pre abbr 'post) + (cdr subst)))))) + +(define (abbreviate-markup subst markup) + ;; A version of `abbreviate-string' generalized to arbitrary markup + ;; objects. + (let loop ((markup markup)) + (cond ((string? markup) + (let ((purify (make-string-replace '((#\newline " ") + (#\tab " "))))) + (abbreviate-string subst (purify markup)))) + ((list? markup) + (map loop markup)) + ((markup? markup) + (markup-body-set! markup (loop (markup-body title))) + markup) + (else markup)))) + + +;;; +;;; Common English abbreviations. +;;; + +;; The following abbreviation alists may be passed to `abbreviate-string' +;; and `abbreviate-markup'. + +(define %cs-conference-abbreviations + ;; Common computer science conferences and their acronym. + '(("(Symposium [oO]n )?Operating Systems? Design and [iI]mplementation" + . "OSDI") + ("(Symposium [oO]n )?Operating Systems? Principles" + . "SOSP") + ("([wW]orkshop [oO]n )?Hot Topics [iI]n Operating Systems" + . "HotOS") + ("([cC]onference [oO]n )?[fF]ile [aA]nd [sS]torage [tT]echnologies" + . "FAST") + ("([tT]he )?([iI]nternational )?[cC]onference [oO]n [aA]rchitectural Support [fF]or Programming Languages [aA]nd Operating Systems" + . "ASPLOS") + ("([tT]he )?([iI]nternational )?[cC]onference [oO]n Peer-[tT]o-[pP]eer Computing" + . "P2P") + ("([iI]nternational )?[cC]onference [oO]n [dD]ata [eE]ngineering" + . "ICDE") + ("([cC]onference [oO]n )?[mM]ass [sS]torage [sS]ystems( [aA]nd [tT]echnologies)?" + . "MSS") + ("([sS]ymposium [oO]n )?[nN]etworked [sS]ystems [dD]esign [aA]nd [Ii]mplementation" + . "NSDI"))) + + +(define %ordinal-number-abbreviations + ;; The poor man's abbreviation system. + + ;; FIXME: Given the current `abbreviate-string', there is no clean way to + ;; make it ignore things like "twenty-first" (instead of yielding an awful + ;; "twenty-1st"). + '(("[Ff]irst" . "1st") + ("[sS]econd" . "2nd") + ("[Tt]hird" . "3rd") + ("[Ff]ourth" . "4th") + ("[Ff]ifth" . "5th") + ("[Ss]ixth" . "6th") + ("[Ss]eventh" . "7th") + ("[eE]ighth" . "8th") + ("[Nn]inth" . "9th") + ("[Tt]enth" . "10th") + ("[Ee]leventh" . "11th") + ("[Tt]welfth" . "12th") + ("[Tt]hirteenth" . "13th") + ("[Ff]ourteenth" . "14th") + ("[Ff]ifteenth" . "15th") + ("[Ss]ixteenth" . "16th") + ("[Ss]eventeenth" . "17th") + ("[Ee]ighteenth" . "18th") + ("[Nn]ineteenth" . "19th"))) + +(define %common-booktitle-abbreviations + ;; Common book title abbreviations. This is used by + ;; `abbreviate-booktitle'. + '(("[pP]roceedings?" . "Proc.") + ("[iI]nternational" . "Int.") + ("[sS]ymposium" . "Symp.") + ("[cC]onference" . "Conf."))) + + +;;; arch-tag: 34e0c5bb-592f-467b-b59a-d6f7d130ae4e + +;;; abbrev.scm ends here diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm new file mode 100644 index 0000000..ea15f4c --- /dev/null +++ b/src/guile/skribilo/biblio/author.scm @@ -0,0 +1,136 @@ +;;; author.scm -- Handling author names. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo biblio author) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) + :use-module (skribilo biblio abbrev) + :autoload (skribilo ast) (markup-option markup-body markup-ident) + :autoload (skribilo lib) (skribe-error) + :autoload (skribilo utils strings) (make-string-replace) + :export (comma-separated->author-list + comma-separated->and-separated-authors + + extract-first-author-name + abbreviate-author-first-names + abbreviate-first-names + first-author-last-name + + bib-sort/first-author-last-name)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Heuristics to manipulate author names as strings. +;;; +;;; Code: + +(define (comma-separated->author-list authors) + ;; Return a list of strings where each individual string is an author + ;; name. AUTHORS is a string representing a list of author names separated + ;; by a comma. + + ;; XXX: I should use SRFI-13 instead. + (string-split authors #\,)) + +(define (comma-separated->and-separated-authors authors) + ;; Take AUTHORS, a string containing comma-separated author names, and + ;; return a string where author names are separated by " and " (suitable + ;; for BibTeX). + (string-join (comma-separated->author-list authors) + " and " 'infix)) + + +(define (extract-first-author-name names) + ;; Extract the name of the first author from string + ;; NAMES that is a comma-separated list of authors. + (let ((author-name-end (or (string-index names #\,) + (string-length names)))) + (substring names 0 author-name-end))) + +(define (abbreviate-author-first-names name) + ;; Abbreviate author first names + (let* ((components (string-split name #\space)) + (component-number (length components))) + (apply string-append + (append + (map (lambda (c) + (string-append (abbreviate-word c) " ")) + (list-head components + (- component-number 1))) + (list-tail components (- component-number 1)))))) + +(define (abbreviate-first-names names) + ;; Abbreviate first names in NAMES. NAMES is supposed to be + ;; something like "Ludovic Courtès, Marc-Olivier Killijian". + (let loop ((names ((make-string-replace '((#\newline " ") + (#\tab " "))) + names)) + (result "")) + (if (string=? names "") + result + (let* ((len (string-length names)) + (first-author-names-end (or (string-index names #\,) + len)) + (first-author-names (substring names 0 + first-author-names-end)) + (next (substring names + (min (+ 1 first-author-names-end) len) + len))) + (loop next + (string-append result + (if (string=? "" result) "" ", ") + (abbreviate-author-first-names + first-author-names))))))) + + +(define (first-author-last-name authors) + ;; Return a string containing exactly the last name of the first author. + ;; Author names in AUTHORS are assumed to be comma separated. + (let loop ((first-author (extract-first-author-name authors))) + (let ((space (string-index first-author #\space))) + (if (not space) + first-author + (loop (substring first-author (+ space 1) + (string-length first-author))))))) + +(define (bib-sort/first-author-last-name entries) + ;; May be passed as the `:sort' argument of `the-bibliography'. + (let ((check-author (lambda (e) + (if (not (markup-option e 'author)) + (skribe-error 'web + "No author for this bib entry" + (markup-ident e)) + #t)))) + (sort entries + (lambda (e1 e2) + (let* ((x1 (check-author e1)) + (x2 (check-author e2)) + (a1 (first-author-last-name + (markup-body (markup-option e1 'author)))) + (a2 (first-author-last-name + (markup-body (markup-option e2 'author))))) + (string-ci<=? a1 a2)))))) + + +;;; arch-tag: c9a1ef10-a2cd-4a06-bd35-fbdee1abf09a + +;;; author.scm ends here diff --git a/src/guile/skribilo/biblio/bibtex.scm b/src/guile/skribilo/biblio/bibtex.scm new file mode 100644 index 0000000..319df1d --- /dev/null +++ b/src/guile/skribilo/biblio/bibtex.scm @@ -0,0 +1,83 @@ +;;; bibtex.scm -- Handling BibTeX references. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo biblio bibtex) + :autoload (skribilo utils strings) (make-string-replace) + :autoload (skribilo ast) (markup-option ast->string) + :autoload (skribilo engine) (engine-filter find-engine) + :use-module (skribilo biblio author) + :use-module (srfi srfi-39) + :export (print-as-bibtex-entry)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A set of BibTeX tools, e.g., issuing a BibTeX entry from a `&bib-entry' +;;; markup object. +;;; +;;; Code: + +(define *bibtex-author-filter* + ;; Defines how the `author' field is to be filtered. + (make-parameter comma-separated->and-separated-authors)) + +(define (print-as-bibtex-entry entry) + "Display @code{&bib-entry} object @var{entry} as a BibTeX entry." + (let ((show-option (lambda (opt) + (let* ((o (markup-option entry opt)) + (f (make-string-replace '((#\newline " ")))) + (g (if (eq? opt 'author) + (lambda (a) + ((*bibtex-author-filter*) (f a))) + f))) + (if (not o) + #f + `(,(symbol->string opt) + " = \"" + ,(g (ast->string (markup-body o))) + "\",")))))) + (format #t "@~a{~a,~%" + (markup-option entry 'kind) + (markup-ident entry)) + (for-each (lambda (opt) + (let* ((o (show-option opt)) + (tex-filter (engine-filter + (find-engine 'latex))) + (filter (lambda (n) + (tex-filter (ast->string n)))) + (id (lambda (a) a))) + (if o + (display + (apply string-append + `(,@(map (if (eq? 'url opt) + id filter) + (cons " " o)) + "\n")))))) + '(author institution title + booktitle journal number + year month url pages address publisher)) + (display "}\n"))) + + +;;; arch-tag: 8b5913cc-9077-4e92-839e-c4c633b7bd46 + +;;; bibtex.scm ends here diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm new file mode 100644 index 0000000..8b6205f --- /dev/null +++ b/src/guile/skribilo/color.scm @@ -0,0 +1,621 @@ +;;; color.scm -- Color management. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo color) + :autoload (srfi srfi-60) (bitwise-and arithmetic-shift) + :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + +;; FIXME: This module should be generalized and the `skribe-' procedures +;; moved to `compat.scm'. + +;; FIXME: Use a fluid? Or remove it? +(define *used-colors* '()) + +(define *skribe-rgb-alist* '( + ("snow" . "255 250 250") + ("ghostwhite" . "248 248 255") + ("whitesmoke" . "245 245 245") + ("gainsboro" . "220 220 220") + ("floralwhite" . "255 250 240") + ("oldlace" . "253 245 230") + ("linen" . "250 240 230") + ("antiquewhite" . "250 235 215") + ("papayawhip" . "255 239 213") + ("blanchedalmond" . "255 235 205") + ("bisque" . "255 228 196") + ("peachpuff" . "255 218 185") + ("navajowhite" . "255 222 173") + ("moccasin" . "255 228 181") + ("cornsilk" . "255 248 220") + ("ivory" . "255 255 240") + ("lemonchiffon" . "255 250 205") + ("seashell" . "255 245 238") + ("honeydew" . "240 255 240") + ("mintcream" . "245 255 250") + ("azure" . "240 255 255") + ("aliceblue" . "240 248 255") + ("lavender" . "230 230 250") + ("lavenderblush" . "255 240 245") + ("mistyrose" . "255 228 225") + ("white" . "255 255 255") + ("black" . "0 0 0") + ("darkslategrey" . "47 79 79") + ("dimgrey" . "105 105 105") + ("slategrey" . "112 128 144") + ("lightslategrey" . "119 136 153") + ("grey" . "190 190 190") + ("lightgrey" . "211 211 211") + ("midnightblue" . "25 25 112") + ("navy" . "0 0 128") + ("navyblue" . "0 0 128") + ("cornflowerblue" . "100 149 237") + ("darkslateblue" . "72 61 139") + ("slateblue" . "106 90 205") + ("mediumslateblue" . "123 104 238") + ("lightslateblue" . "132 112 255") + ("mediumblue" . "0 0 205") + ("royalblue" . "65 105 225") + ("blue" . "0 0 255") + ("dodgerblue" . "30 144 255") + ("deepskyblue" . "0 191 255") + ("skyblue" . "135 206 235") + ("lightskyblue" . "135 206 250") + ("steelblue" . "70 130 180") + ("lightsteelblue" . "176 196 222") + ("lightblue" . "173 216 230") + ("powderblue" . "176 224 230") + ("paleturquoise" . "175 238 238") + ("darkturquoise" . "0 206 209") + ("mediumturquoise" . "72 209 204") + ("turquoise" . "64 224 208") + ("cyan" . "0 255 255") + ("lightcyan" . "224 255 255") + ("cadetblue" . "95 158 160") + ("mediumaquamarine" . "102 205 170") + ("aquamarine" . "127 255 212") + ("darkgreen" . "0 100 0") + ("darkolivegreen" . "85 107 47") + ("darkseagreen" . "143 188 143") + ("seagreen" . "46 139 87") + ("mediumseagreen" . "60 179 113") + ("lightseagreen" . "32 178 170") + ("palegreen" . "152 251 152") + ("springgreen" . "0 255 127") + ("lawngreen" . "124 252 0") + ("green" . "0 255 0") + ("chartreuse" . "127 255 0") + ("mediumspringgreen" . "0 250 154") + ("greenyellow" . "173 255 47") + ("limegreen" . "50 205 50") + ("yellowgreen" . "154 205 50") + ("forestgreen" . "34 139 34") + ("olivedrab" . "107 142 35") + ("darkkhaki" . "189 183 107") + ("khaki" . "240 230 140") + ("palegoldenrod" . "238 232 170") + ("lightgoldenrodyellow" . "250 250 210") + ("lightyellow" . "255 255 224") + ("yellow" . "255 255 0") + ("gold" . "255 215 0") + ("lightgoldenrod" . "238 221 130") + ("goldenrod" . "218 165 32") + ("darkgoldenrod" . "184 134 11") + ("rosybrown" . "188 143 143") + ("indianred" . "205 92 92") + ("saddlebrown" . "139 69 19") + ("sienna" . "160 82 45") + ("peru" . "205 133 63") + ("burlywood" . "222 184 135") + ("beige" . "245 245 220") + ("wheat" . "245 222 179") + ("sandybrown" . "244 164 96") + ("tan" . "210 180 140") + ("chocolate" . "210 105 30") + ("firebrick" . "178 34 34") + ("brown" . "165 42 42") + ("darksalmon" . "233 150 122") + ("salmon" . "250 128 114") + ("lightsalmon" . "255 160 122") + ("orange" . "255 165 0") + ("darkorange" . "255 140 0") + ("coral" . "255 127 80") + ("lightcoral" . "240 128 128") + ("tomato" . "255 99 71") + ("orangered" . "255 69 0") + ("red" . "255 0 0") + ("hotpink" . "255 105 180") + ("deeppink" . "255 20 147") + ("pink" . "255 192 203") + ("lightpink" . "255 182 193") + ("palevioletred" . "219 112 147") + ("maroon" . "176 48 96") + ("mediumvioletred" . "199 21 133") + ("violetred" . "208 32 144") + ("magenta" . "255 0 255") + ("violet" . "238 130 238") + ("plum" . "221 160 221") + ("orchid" . "218 112 214") + ("mediumorchid" . "186 85 211") + ("darkorchid" . "153 50 204") + ("darkviolet" . "148 0 211") + ("blueviolet" . "138 43 226") + ("purple" . "160 32 240") + ("mediumpurple" . "147 112 219") + ("thistle" . "216 191 216") + ("snow1" . "255 250 250") + ("snow2" . "238 233 233") + ("snow3" . "205 201 201") + ("snow4" . "139 137 137") + ("seashell1" . "255 245 238") + ("seashell2" . "238 229 222") + ("seashell3" . "205 197 191") + ("seashell4" . "139 134 130") + ("antiquewhite1" . "255 239 219") + ("antiquewhite2" . "238 223 204") + ("antiquewhite3" . "205 192 176") + ("antiquewhite4" . "139 131 120") + ("bisque1" . "255 228 196") + ("bisque2" . "238 213 183") + ("bisque3" . "205 183 158") + ("bisque4" . "139 125 107") + ("peachpuff1" . "255 218 185") + ("peachpuff2" . "238 203 173") + ("peachpuff3" . "205 175 149") + ("peachpuff4" . "139 119 101") + ("navajowhite1" . "255 222 173") + ("navajowhite2" . "238 207 161") + ("navajowhite3" . "205 179 139") + ("navajowhite4" . "139 121 94") + ("lemonchiffon1" . "255 250 205") + ("lemonchiffon2" . "238 233 191") + ("lemonchiffon3" . "205 201 165") + ("lemonchiffon4" . "139 137 112") + ("cornsilk1" . "255 248 220") + ("cornsilk2" . "238 232 205") + ("cornsilk3" . "205 200 177") + ("cornsilk4" . "139 136 120") + ("ivory1" . "255 255 240") + ("ivory2" . "238 238 224") + ("ivory3" . "205 205 193") + ("ivory4" . "139 139 131") + ("honeydew1" . "240 255 240") + ("honeydew2" . "224 238 224") + ("honeydew3" . "193 205 193") + ("honeydew4" . "131 139 131") + ("lavenderblush1" . "255 240 245") + ("lavenderblush2" . "238 224 229") + ("lavenderblush3" . "205 193 197") + ("lavenderblush4" . "139 131 134") + ("mistyrose1" . "255 228 225") + ("mistyrose2" . "238 213 210") + ("mistyrose3" . "205 183 181") + ("mistyrose4" . "139 125 123") + ("azure1" . "240 255 255") + ("azure2" . "224 238 238") + ("azure3" . "193 205 205") + ("azure4" . "131 139 139") + ("slateblue1" . "131 111 255") + ("slateblue2" . "122 103 238") + ("slateblue3" . "105 89 205") + ("slateblue4" . "71 60 139") + ("royalblue1" . "72 118 255") + ("royalblue2" . "67 110 238") + ("royalblue3" . "58 95 205") + ("royalblue4" . "39 64 139") + ("blue1" . "0 0 255") + ("blue2" . "0 0 238") + ("blue3" . "0 0 205") + ("blue4" . "0 0 139") + ("dodgerblue1" . "30 144 255") + ("dodgerblue2" . "28 134 238") + ("dodgerblue3" . "24 116 205") + ("dodgerblue4" . "16 78 139") + ("steelblue1" . "99 184 255") + ("steelblue2" . "92 172 238") + ("steelblue3" . "79 148 205") + ("steelblue4" . "54 100 139") + ("deepskyblue1" . "0 191 255") + ("deepskyblue2" . "0 178 238") + ("deepskyblue3" . "0 154 205") + ("deepskyblue4" . "0 104 139") + ("skyblue1" . "135 206 255") + ("skyblue2" . "126 192 238") + ("skyblue3" . "108 166 205") + ("skyblue4" . "74 112 139") + ("lightskyblue1" . "176 226 255") + ("lightskyblue2" . "164 211 238") + ("lightskyblue3" . "141 182 205") + ("lightskyblue4" . "96 123 139") + ("lightsteelblue1" . "202 225 255") + ("lightsteelblue2" . "188 210 238") + ("lightsteelblue3" . "162 181 205") + ("lightsteelblue4" . "110 123 139") + ("lightblue1" . "191 239 255") + ("lightblue2" . "178 223 238") + ("lightblue3" . "154 192 205") + ("lightblue4" . "104 131 139") + ("lightcyan1" . "224 255 255") + ("lightcyan2" . "209 238 238") + ("lightcyan3" . "180 205 205") + ("lightcyan4" . "122 139 139") + ("paleturquoise1" . "187 255 255") + ("paleturquoise2" . "174 238 238") + ("paleturquoise3" . "150 205 205") + ("paleturquoise4" . "102 139 139") + ("cadetblue1" . "152 245 255") + ("cadetblue2" . "142 229 238") + ("cadetblue3" . "122 197 205") + ("cadetblue4" . "83 134 139") + ("turquoise1" . "0 245 255") + ("turquoise2" . "0 229 238") + ("turquoise3" . "0 197 205") + ("turquoise4" . "0 134 139") + ("cyan1" . "0 255 255") + ("cyan2" . "0 238 238") + ("cyan3" . "0 205 205") + ("cyan4" . "0 139 139") + ("aquamarine1" . "127 255 212") + ("aquamarine2" . "118 238 198") + ("aquamarine3" . "102 205 170") + ("aquamarine4" . "69 139 116") + ("darkseagreen1" . "193 255 193") + ("darkseagreen2" . "180 238 180") + ("darkseagreen3" . "155 205 155") + ("darkseagreen4" . "105 139 105") + ("seagreen1" . "84 255 159") + ("seagreen2" . "78 238 148") + ("seagreen3" . "67 205 128") + ("seagreen4" . "46 139 87") + ("palegreen1" . "154 255 154") + ("palegreen2" . "144 238 144") + ("palegreen3" . "124 205 124") + ("palegreen4" . "84 139 84") + ("springgreen1" . "0 255 127") + ("springgreen2" . "0 238 118") + ("springgreen3" . "0 205 102") + ("springgreen4" . "0 139 69") + ("green1" . "0 255 0") + ("green2" . "0 238 0") + ("green3" . "0 205 0") + ("green4" . "0 139 0") + ("chartreuse1" . "127 255 0") + ("chartreuse2" . "118 238 0") + ("chartreuse3" . "102 205 0") + ("chartreuse4" . "69 139 0") + ("olivedrab1" . "192 255 62") + ("olivedrab2" . "179 238 58") + ("olivedrab3" . "154 205 50") + ("olivedrab4" . "105 139 34") + ("darkolivegreen1" . "202 255 112") + ("darkolivegreen2" . "188 238 104") + ("darkolivegreen3" . "162 205 90") + ("darkolivegreen4" . "110 139 61") + ("khaki1" . "255 246 143") + ("khaki2" . "238 230 133") + ("khaki3" . "205 198 115") + ("khaki4" . "139 134 78") + ("lightgoldenrod1" . "255 236 139") + ("lightgoldenrod2" . "238 220 130") + ("lightgoldenrod3" . "205 190 112") + ("lightgoldenrod4" . "139 129 76") + ("lightyellow1" . "255 255 224") + ("lightyellow2" . "238 238 209") + ("lightyellow3" . "205 205 180") + ("lightyellow4" . "139 139 122") + ("yellow1" . "255 255 0") + ("yellow2" . "238 238 0") + ("yellow3" . "205 205 0") + ("yellow4" . "139 139 0") + ("gold1" . "255 215 0") + ("gold2" . "238 201 0") + ("gold3" . "205 173 0") + ("gold4" . "139 117 0") + ("goldenrod1" . "255 193 37") + ("goldenrod2" . "238 180 34") + ("goldenrod3" . "205 155 29") + ("goldenrod4" . "139 105 20") + ("darkgoldenrod1" . "255 185 15") + ("darkgoldenrod2" . "238 173 14") + ("darkgoldenrod3" . "205 149 12") + ("darkgoldenrod4" . "139 101 8") + ("rosybrown1" . "255 193 193") + ("rosybrown2" . "238 180 180") + ("rosybrown3" . "205 155 155") + ("rosybrown4" . "139 105 105") + ("indianred1" . "255 106 106") + ("indianred2" . "238 99 99") + ("indianred3" . "205 85 85") + ("indianred4" . "139 58 58") + ("sienna1" . "255 130 71") + ("sienna2" . "238 121 66") + ("sienna3" . "205 104 57") + ("sienna4" . "139 71 38") + ("burlywood1" . "255 211 155") + ("burlywood2" . "238 197 145") + ("burlywood3" . "205 170 125") + ("burlywood4" . "139 115 85") + ("wheat1" . "255 231 186") + ("wheat2" . "238 216 174") + ("wheat3" . "205 186 150") + ("wheat4" . "139 126 102") + ("tan1" . "255 165 79") + ("tan2" . "238 154 73") + ("tan3" . "205 133 63") + ("tan4" . "139 90 43") + ("chocolate1" . "255 127 36") + ("chocolate2" . "238 118 33") + ("chocolate3" . "205 102 29") + ("chocolate4" . "139 69 19") + ("firebrick1" . "255 48 48") + ("firebrick2" . "238 44 44") + ("firebrick3" . "205 38 38") + ("firebrick4" . "139 26 26") + ("brown1" . "255 64 64") + ("brown2" . "238 59 59") + ("brown3" . "205 51 51") + ("brown4" . "139 35 35") + ("salmon1" . "255 140 105") + ("salmon2" . "238 130 98") + ("salmon3" . "205 112 84") + ("salmon4" . "139 76 57") + ("lightsalmon1" . "255 160 122") + ("lightsalmon2" . "238 149 114") + ("lightsalmon3" . "205 129 98") + ("lightsalmon4" . "139 87 66") + ("orange1" . "255 165 0") + ("orange2" . "238 154 0") + ("orange3" . "205 133 0") + ("orange4" . "139 90 0") + ("darkorange1" . "255 127 0") + ("darkorange2" . "238 118 0") + ("darkorange3" . "205 102 0") + ("darkorange4" . "139 69 0") + ("coral1" . "255 114 86") + ("coral2" . "238 106 80") + ("coral3" . "205 91 69") + ("coral4" . "139 62 47") + ("tomato1" . "255 99 71") + ("tomato2" . "238 92 66") + ("tomato3" . "205 79 57") + ("tomato4" . "139 54 38") + ("orangered1" . "255 69 0") + ("orangered2" . "238 64 0") + ("orangered3" . "205 55 0") + ("orangered4" . "139 37 0") + ("red1" . "255 0 0") + ("red2" . "238 0 0") + ("red3" . "205 0 0") + ("red4" . "139 0 0") + ("deeppink1" . "255 20 147") + ("deeppink2" . "238 18 137") + ("deeppink3" . "205 16 118") + ("deeppink4" . "139 10 80") + ("hotpink1" . "255 110 180") + ("hotpink2" . "238 106 167") + ("hotpink3" . "205 96 144") + ("hotpink4" . "139 58 98") + ("pink1" . "255 181 197") + ("pink2" . "238 169 184") + ("pink3" . "205 145 158") + ("pink4" . "139 99 108") + ("lightpink1" . "255 174 185") + ("lightpink2" . "238 162 173") + ("lightpink3" . "205 140 149") + ("lightpink4" . "139 95 101") + ("palevioletred1" . "255 130 171") + ("palevioletred2" . "238 121 159") + ("palevioletred3" . "205 104 137") + ("palevioletred4" . "139 71 93") + ("maroon1" . "255 52 179") + ("maroon2" . "238 48 167") + ("maroon3" . "205 41 144") + ("maroon4" . "139 28 98") + ("violetred1" . "255 62 150") + ("violetred2" . "238 58 140") + ("violetred3" . "205 50 120") + ("violetred4" . "139 34 82") + ("magenta1" . "255 0 255") + ("magenta2" . "238 0 238") + ("magenta3" . "205 0 205") + ("magenta4" . "139 0 139") + ("orchid1" . "255 131 250") + ("orchid2" . "238 122 233") + ("orchid3" . "205 105 201") + ("orchid4" . "139 71 137") + ("plum1" . "255 187 255") + ("plum2" . "238 174 238") + ("plum3" . "205 150 205") + ("plum4" . "139 102 139") + ("mediumorchid1" . "224 102 255") + ("mediumorchid2" . "209 95 238") + ("mediumorchid3" . "180 82 205") + ("mediumorchid4" . "122 55 139") + ("darkorchid1" . "191 62 255") + ("darkorchid2" . "178 58 238") + ("darkorchid3" . "154 50 205") + ("darkorchid4" . "104 34 139") + ("purple1" . "155 48 255") + ("purple2" . "145 44 238") + ("purple3" . "125 38 205") + ("purple4" . "85 26 139") + ("mediumpurple1" . "171 130 255") + ("mediumpurple2" . "159 121 238") + ("mediumpurple3" . "137 104 205") + ("mediumpurple4" . "93 71 139") + ("thistle1" . "255 225 255") + ("thistle2" . "238 210 238") + ("thistle3" . "205 181 205") + ("thistle4" . "139 123 139") + ("grey0" . "0 0 0") + ("grey1" . "3 3 3") + ("grey2" . "5 5 5") + ("grey3" . "8 8 8") + ("grey4" . "10 10 10") + ("grey5" . "13 13 13") + ("grey6" . "15 15 15") + ("grey7" . "18 18 18") + ("grey8" . "20 20 20") + ("grey9" . "23 23 23") + ("grey10" . "26 26 26") + ("grey11" . "28 28 28") + ("grey12" . "31 31 31") + ("grey13" . "33 33 33") + ("grey14" . "36 36 36") + ("grey15" . "38 38 38") + ("grey16" . "41 41 41") + ("grey17" . "43 43 43") + ("grey18" . "46 46 46") + ("grey19" . "48 48 48") + ("grey20" . "51 51 51") + ("grey21" . "54 54 54") + ("grey22" . "56 56 56") + ("grey23" . "59 59 59") + ("grey24" . "61 61 61") + ("grey25" . "64 64 64") + ("grey26" . "66 66 66") + ("grey27" . "69 69 69") + ("grey28" . "71 71 71") + ("grey29" . "74 74 74") + ("grey30" . "77 77 77") + ("grey31" . "79 79 79") + ("grey32" . "82 82 82") + ("grey33" . "84 84 84") + ("grey34" . "87 87 87") + ("grey35" . "89 89 89") + ("grey36" . "92 92 92") + ("grey37" . "94 94 94") + ("grey38" . "97 97 97") + ("grey39" . "99 99 99") + ("grey40" . "102 102 102") + ("grey41" . "105 105 105") + ("grey42" . "107 107 107") + ("grey43" . "110 110 110") + ("grey44" . "112 112 112") + ("grey45" . "115 115 115") + ("grey46" . "117 117 117") + ("grey47" . "120 120 120") + ("grey48" . "122 122 122") + ("grey49" . "125 125 125") + ("grey50" . "127 127 127") + ("grey51" . "130 130 130") + ("grey52" . "133 133 133") + ("grey53" . "135 135 135") + ("grey54" . "138 138 138") + ("grey55" . "140 140 140") + ("grey56" . "143 143 143") + ("grey57" . "145 145 145") + ("grey58" . "148 148 148") + ("grey59" . "150 150 150") + ("grey60" . "153 153 153") + ("grey61" . "156 156 156") + ("grey62" . "158 158 158") + ("grey63" . "161 161 161") + ("grey64" . "163 163 163") + ("grey65" . "166 166 166") + ("grey66" . "168 168 168") + ("grey67" . "171 171 171") + ("grey68" . "173 173 173") + ("grey69" . "176 176 176") + ("grey70" . "179 179 179") + ("grey71" . "181 181 181") + ("grey72" . "184 184 184") + ("grey73" . "186 186 186") + ("grey74" . "189 189 189") + ("grey75" . "191 191 191") + ("grey76" . "194 194 194") + ("grey77" . "196 196 196") + ("grey78" . "199 199 199") + ("grey79" . "201 201 201") + ("grey80" . "204 204 204") + ("grey81" . "207 207 207") + ("grey82" . "209 209 209") + ("grey83" . "212 212 212") + ("grey84" . "214 214 214") + ("grey85" . "217 217 217") + ("grey86" . "219 219 219") + ("grey87" . "222 222 222") + ("grey88" . "224 224 224") + ("grey89" . "227 227 227") + ("grey90" . "229 229 229") + ("grey91" . "232 232 232") + ("grey92" . "235 235 235") + ("grey93" . "237 237 237") + ("grey94" . "240 240 240") + ("grey95" . "242 242 242") + ("grey96" . "245 245 245") + ("grey97" . "247 247 247") + ("grey98" . "250 250 250") + ("grey99" . "252 252 252") + ("grey100" . "255 255 255") + ("darkgrey" . "169 169 169") + ("darkblue" . "0 0 139") + ("darkcyan" . "0 139 139") + ("darkmagenta" . "139 0 139") + ("darkred" . "139 0 0") + ("lightgreen" . "144 238 144"))) + + +(define (%convert-color str) + (let ((col (assoc str *skribe-rgb-alist*))) + (cond + (col + (let* ((p (open-input-string (cdr col))) + (r (read p)) + (g (read p)) + (b (read p))) + (values r g b))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7)) + (values (string->number (substring str 1 3) 16) + (string->number (substring str 3 5) 16) + (string->number (substring str 5 7) 16))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13)) + (values (string->number (substring str 1 5) 16) + (string->number (substring str 5 9) 16) + (string->number (substring str 9 13) 16))) + (else + (values 0 0 0))))) + +;;; +;;; SKRIBE-COLOR->RGB +;;; +(define (skribe-color->rgb spec) + (cond + ((string? spec) (%convert-color spec)) + ((integer? spec) + (values (bitwise-and #xff (arithmetic-shift spec -16)) + (bitwise-and #xff (arithmetic-shift spec -8)) + (bitwise-and #xff spec))) + (else + (values 0 0 0)))) + +;;; +;;; SKRIBE-GET-USED-COLORS +;;; +(define (skribe-get-used-colors) + *used-colors*) + +;;; +;;; SKRIBE-USE-COLOR! +;;; +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am new file mode 100644 index 0000000..b952237 --- /dev/null +++ b/src/guile/skribilo/coloring/Makefile.am @@ -0,0 +1,16 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/coloring +dist_guilemodule_DATA = c.scm lisp.scm xml.scm \ + lisp-lex.l.scm xml-lex.l.scm c-lex.l.scm + + +EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l + +# Building the lexers with SILex. You must previously run +# `tla build-config ./arch-config' for this to run. +# +# Note: Those files should normally be part of the distribution, making +# this rule useless to the user. +%.l.scm: %.l + $(GUILE) -L $(top_srcdir)/src/guile/silex \ + -c '(load-from-path "lex.scm") (lex "$^" "$@")' + diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l new file mode 100644 index 0000000..7d7b1ce --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l @@ -0,0 +1,67 @@ +;;;; +;;;; c-lex.l -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:10 (eg) +;;;; + +space [ \n\9] +letter [_a-zA-Z] +alphanum [_a-zA-Z0-9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +;;Comments +/\*.*\*/ (new markup + (markup '&source-line-comment) + (body yytext)) +//.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) +[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text +[^\"a-zA-Z]+ (begin yytext) + + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext) + + + + + + +
\ No newline at end of file diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm new file mode 100644 index 0000000..d78e09e --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l.scm @@ -0,0 +1,1225 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; This program is free software; you can redistribute it and/or +; modify it under the terms of the GNU General Public License +; as published by the Free Software Foundation; either version 2 +; of the License, or (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<<EOF>>-action #f) + (<<ERROR>>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <<EOF>>-action + <<ERROR>>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file c-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'lisp-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) +;;Comments + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((65 (35 (34 1 5) (= 47 4 1)) (96 (91 3 (95 1 2)) (97 1 (123 3 1)))) + (65 (= 34 err 1) (97 (91 err 1) (123 err 1))) (91 (35 (34 1 err) (65 1 + 3)) (96 (95 1 2) (97 1 (123 3 1)))) (95 (65 err (91 3 err)) (97 (96 3 + err) (123 3 err))) (47 (35 (34 1 err) (= 42 7 1)) (91 (48 6 (65 1 err)) + (97 1 (123 err 1)))) (= 34 8 5) (35 (11 (10 6 1) (34 6 9)) (91 (65 6 9) + (97 6 (123 9 6)))) (42 (11 (10 7 1) (= 34 10 7)) (91 (43 11 (65 7 10)) + (97 7 (123 10 7)))) err (= 10 err 9) (11 (10 10 err) (= 42 12 10)) (43 + (34 (= 10 1 7) (35 10 (42 7 11))) (65 (= 47 13 7) (97 (91 10 7) (123 10 + 7)))) (42 (= 10 err 10) (47 (43 12 10) (48 14 10))) (42 (11 (10 7 1) (= + 34 10 7)) (91 (43 11 (65 7 10)) (97 7 (123 10 7)))) (11 (10 10 err) (= + 42 12 10))) + '#((#f . #f) (4 . 4) (3 . 3) (3 . 3) (4 . 4) (#f . #f) (2 . 2) (4 . 4) + (0 . 0) (2 . 2) (#f . #f) (4 . 4) (#f . #f) (1 . 1) (1 . 1)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm new file mode 100644 index 0000000..d2a2b9f --- /dev/null +++ b/src/guile/skribilo/coloring/c.scm @@ -0,0 +1,93 @@ +;;;; +;;;; c.stk -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:12 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module (skribilo c) + :export (c java) + :import (skribe runtime)) + +(include "c-lex.stk") ;; SILex generated + + +(define *the-keys* #f) + +(define *c-keys* #f) +(define *java-keys* #f) + + +(define (fontifier s) + (let ((lex (c-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; C +;;;; +;;;; ====================================================================== +(define (init-c-keys) + (unless *c-keys* + (set! *c-keys* '(for while return break continue void + do if else typedef struct union goto switch case + static extern default))) + *c-keys*) + +(define (c-fontifier s) + (fluid-let ((*the-keys* (init-c-keys))) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;;;; ====================================================================== +;;;; +;;;; JAVA +;;;; +;;;; ====================================================================== +(define (init-java-keys) + (unless *java-keys* + (set! *java-keys* (append (init-c-keys) + '(public final class throw catch)))) + *java-keys*) + +(define (java-fontifier s) + (fluid-let ((*the-keys* (init-java-keys))) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) + diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l new file mode 100644 index 0000000..30b6a44 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l @@ -0,0 +1,86 @@ +;;; lisp-lex.l -- SILex input for the Lisp Languages +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +space [ \n\9] +letter [#?!_:a-zA-Z\-] +digit [0-9] + + +%% +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +\;.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) +\[|\] (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis +[ \n\9\(\)]+ (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) +[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if (*class-highlight*) + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + (*the-keys*)))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm new file mode 100644 index 0000000..6ae7fe6 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l.scm @@ -0,0 +1,1249 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; This program is free software; you can redistribute it and/or +; modify it under the terms of the GNU General Public License +; as published by the Free Software Foundation; either version 2 +; of the License, or (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<<EOF>>-action #f) + (<<ERROR>>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <<EOF>>-action + <<ERROR>>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file lisp-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if (*class-highlight*) + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + (*the-keys*)))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + ))) + 'decision-trees + 0 + 0 + '#((40 (32 (9 1 (11 2 1)) (34 (33 2 1) (35 5 1))) (91 (59 (42 2 1) (60 4 + 1)) (93 (92 3 1) (94 3 1)))) (40 (32 (9 1 (11 err 1)) (34 (33 err 1) + (35 err 1))) (91 (59 (42 err 1) (60 err 1)) (93 (92 err 1) (94 err + 1)))) (32 (9 err (11 2 err)) (40 (33 2 err) (42 2 err))) err (= 10 err + 4) (= 34 6 5) err) + '#((#f . #f) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (#f . #f) (0 . 0)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm new file mode 100644 index 0000000..13bb6db --- /dev/null +++ b/src/guile/skribilo/coloring/lisp.scm @@ -0,0 +1,302 @@ +;;;; lisp.scm -- Lisp Family Fontification +;;;; +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. + + +(define-module (skribilo coloring lisp) + :use-module (skribilo utils syntax) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo utils strings) + :use-module (srfi srfi-39) + :use-module (ice-9 match) + :autoload (ice-9 regex) (make-regexp) + :autoload (skribilo reader) (make-reader) + :export (skribe scheme stklos bigloo lisp)) + + +(define *bracket-highlight* (make-parameter #t)) +(define *class-highlight* (make-parameter #t)) +(define *the-keys* (make-parameter '())) + +(define %lisp-keys #f) +(define %scheme-keys #f) +(define %skribe-keys #f) +(define %stklos-keys #f) +(define %lisp-keys #f) + + +;;; +;;; DEFINITION-SEARCH +;;; +(define (definition-search inp read tab def?) + (let Loop ((exp (read inp))) + (unless (eof-object? exp) + (if (def? exp) + (let ((start (and (pair? exp) (source-property exp 'line))) + (stop (port-line inp))) + (source-read-lines (port-filename inp) start stop tab)) + (Loop (read inp)))))) + +;; Load the SILex-generated lexer. +(load-from-path "skribilo/coloring/lisp-lex.l.scm") + +(define (lisp-family-fontifier s) + (lexer-init 'port (open-input-string s)) + (let loop ((token (lexer)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (loop (lexer) + (cons token res))))) + + +;;;; ====================================================================== +;;;; +;;;; LISP +;;;; +;;;; ====================================================================== +(define (lisp-extractor iport def tab) + (definition-search + iport + read + tab + (lambda (exp) + (match exp + (((or 'defun 'defmacro) fun _ . _) + (and (eq? def fun) exp)) + (('defvar var . _) + (and (eq? var def) exp)) + (else #f))))) + +(define (init-lisp-keys) + (unless %lisp-keys + (set! %lisp-keys + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(setq if let let* letrec cond case else progn lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(defun defclass defmacro))))) + %lisp-keys) + +(define (lisp-fontifier s) + (parameterize ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + + +;;;; ====================================================================== +;;;; +;;;; SCHEME +;;;; +;;;; ====================================================================== +(define (scheme-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro) (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? symbol? var) . _) + (and (eq? var def) exp)) + (else #f))))) + + +(define (init-scheme-keys) + (unless %scheme-keys + (set! %scheme-keys + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(set! if let let* letrec quote cond case else begin do lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(define define-syntax))))) + %scheme-keys) + + +(define (scheme-fontifier s) + (parameterize ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + + +;;;; ====================================================================== +;;;; +;;;; STKLOS +;;;; +;;;; ====================================================================== +(define (stklos-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-generic 'define-method 'define-macro) + (fun . _) . _) + (and (eq? def fun) exp)) + (((or 'define 'define-module) (? symbol? var) . _) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-stklos-keys) + (unless %stklos-keys + (init-scheme-keys) + (set! %stklos-keys (append %scheme-keys + ;; Markups + (map (lambda (x) (cons x '&source-key)) + '(select-module import export)) + ;; Key + (map (lambda (x) (cons x '&source-keyword)) + '(case-lambda dotimes match-case match-lambda)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-generic define-class + define-macro define-method define-module)) + ;; error + (map (lambda (x) (cons x '&source-error)) + '(error call/cc))))) + %stklos-keys) + + +(define (stklos-fontifier s) + (parameterize ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define stklos + (new language + (name "stklos") + (fontifier stklos-fontifier) + (extractor stklos-extractor))) + + +;;;; ====================================================================== +;;;; +;;;; SKRIBE +;;;; +;;;; ====================================================================== +(define (skribe-extractor iport def tab) + (definition-search + iport + (make-reader 'skribe) + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro 'define-markup 'define-public) + (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? symbol? var) . _) + (and (eq? var def) exp)) + (('markup-output (quote mk) . _) + (and (eq? mk def) exp)) + (else #f))))) + + +(define (init-skribe-keys) + (unless %skribe-keys + (init-stklos-keys) + (set! %skribe-keys (append %stklos-keys + ;; Markups + (map (lambda (x) (cons x '&source-markup)) + '(bold it emph tt color ref index underline + roman figure center pre flush hrule + linebreak image kbd code var samp + sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font + document chapter section subsection + subsubsection paragraph p handle resolve + processor abstract margin toc + table-of-contents current-document + current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-markup))))) + %skribe-keys) + + +(define (skribe-fontifier s) + (parameterize ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + + +;;;; ====================================================================== +;;;; +;;;; BIGLOO +;;;; +;;;; ====================================================================== +(define (bigloo-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-inline 'define-generic + 'define-method 'define-macro 'define-expander) + (fun . _) . _) + (and (eq? def fun) exp)) + (((or 'define 'define-struct 'define-library) + (? symbol? var) . _) + (and (eq? var def) exp)) + (else #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l new file mode 100644 index 0000000..aa7d312 --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 21-Dec-2003 22:38 (eg) +;;;; + +space [ \n\9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +'[^']*' (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +<!--(.|\n)*--> (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + +
\ No newline at end of file diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm new file mode 100644 index 0000000..d58e42b --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l.scm @@ -0,0 +1,1221 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; This program is free software; you can redistribute it and/or +; modify it under the terms of the GNU General Public License +; as published by the Free Software Foundation; either version 2 +; of the License, or (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<<EOF>>-action #f) + (<<ERROR>>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <<EOF>>-action + <<ERROR>>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file xml-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'xml-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((40 (35 (34 1 5) (39 1 4)) (61 (60 1 3) (= 62 2 1))) (40 (35 (34 1 + err) (39 1 err)) (61 (60 1 err) (= 62 err 1))) err (33 (11 (10 6 err) + (32 6 err)) (62 (34 7 6) (63 err 6))) (= 39 8 4) (= 34 9 5) (32 (= 10 + err 6) (62 (33 err 6) (63 err 6))) (33 (11 (10 6 err) (32 6 err)) (46 + (45 6 10) (= 62 err 6))) err err (33 (11 (10 6 err) (32 6 err)) (46 (45 + 6 11) (= 62 err 6))) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 13) (= + 62 12 11))) (= 45 14 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 15) + (= 62 12 11))) (= 45 16 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 + 15) (= 62 17 11))) (46 (45 12 16) (= 62 17 12)) (= 45 14 12)) + '#((#f . #f) (4 . 4) (3 . 3) (#f . #f) (#f . #f) (#f . #f) (3 . 3) (3 . + 3) (1 . 1) (0 . 0) (3 . 3) (3 . 3) (#f . #f) (3 . 3) (#f . #f) (3 . 3) + (#f . #f) (2 . 2)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm new file mode 100644 index 0000000..e3db36f --- /dev/null +++ b/src/guile/skribilo/coloring/xml.scm @@ -0,0 +1,82 @@ +;;; xml.scm -- XML syntax highlighting. +;;; +;;; 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (skribilo coloring xml) + :export (xml) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (ice-9 rdelim) + :use-module (ice-9 regex)) + + +(define %comment-rx (make-regexp "<!--(.|\\n)*-->" regexp/extended)) + +(define (xml-fontifier str) + (let loop ((start 0) + (result '())) + (if (>= start (string-length str)) + (reverse! result) + (case (string-ref str start) + ((#\") + (let ((end (string-index str start #\"))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML string" + (string-drop str start)) + (loop end + (cons (new markup + (markup '&source-string) + (body (substring str start end))) + result))))) + ((#\<) + (let ((end (string-index str #\> start))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML tag" + (string-drop str start)) + (let ((comment? (regexp-exec %comment-rx + (substring str start end)))) + (loop end + (cons (if comment? + (new markup + (markup '&source-comment) + (body (substring str start end))) + (new markup + (markup '&source-module) + (body (substring str start end)))) + result)))))) + + (else + (loop (+ 1 start) + (if (or (null? result) + (not (string? (car result)))) + (cons (string (string-ref str start)) result) + (cons (string-append (car result) + (string (string-ref str start))) + (cdr result))))))))) + + +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) + +;;; xml.scm ends here diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm new file mode 100644 index 0000000..4d61efb --- /dev/null +++ b/src/guile/skribilo/condition.scm @@ -0,0 +1,171 @@ +;;; condition.scm -- Skribilo SRFI-35 error condition hierarchy. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo condition) + :autoload (srfi srfi-1) (find) + :autoload (srfi srfi-34) (guard) + :use-module (srfi srfi-35) + :use-module (srfi srfi-39) + :export (&skribilo-error skribilo-error? + &invalid-argument-error invalid-argument-error? + &too-few-arguments-error too-few-arguments-error? + + &file-error file-error? + &file-search-error file-search-error? + &file-open-error file-open-error? + &file-write-error file-write-error? + + register-error-condition-handler! + lookup-error-condition-handler + + %call-with-skribilo-error-catch + call-with-skribilo-error-catch)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Top-level of Skribilo's SRFI-35 error conditions. +;;; +;;; Code: + + +;;; +;;; Standard error conditions. +;;; + +(define-condition-type &skribilo-error &error + skribilo-error?) + + +;;; +;;; Generic errors. +;;; + +(define-condition-type &invalid-argument-error &skribilo-error + invalid-argument-error? + (proc-name invalid-argument-error:proc-name) + (argument invalid-argument-error:argument)) + +(define-condition-type &too-few-arguments-error &skribilo-error + too-few-arguments-error? + (proc-name too-few-arguments-error:proc-name) + (arguments too-few-arguments-error:arguments)) + + +;;; +;;; File errors. +;;; + +(define-condition-type &file-error &skribilo-error + file-error? + (file-name file-error:file-name)) + +(define-condition-type &file-search-error &file-error + file-search-error? + (path file-search-error:path)) + +(define-condition-type &file-open-error &file-error + file-open-error?) + +(define-condition-type &file-write-error &file-error + file-write-error?) + + + +;;; +;;; Adding new error conditions from other modules. +;;; + +(define %external-error-condition-alist '()) + +(define (register-error-condition-handler! pred handler) + (set! %external-error-condition-alist + (cons (cons pred handler) + %external-error-condition-alist))) + +(define (lookup-error-condition-handler c) + (let ((pair (find (lambda (pair) + (let ((pred (car pair))) + (pred c))) + %external-error-condition-alist))) + (if (pair? pair) + (cdr pair) + #f))) + + + +;;; +;;; Convenience functions. +;;; + +(define (%call-with-skribilo-error-catch thunk exit exit-val) + (guard (c ((invalid-argument-error? c) + (format (current-error-port) "in `~a': invalid argument: ~S~%" + (invalid-argument-error:proc-name c) + (invalid-argument-error:argument c)) + (exit exit-val)) + + ((too-few-arguments-error? c) + (format (current-error-port) "in `~a': too few arguments: ~S~%" + (too-few-arguments-error:proc-name c) + (too-few-arguments-error:arguments c))) + + ((file-search-error? c) + (format (current-error-port) "~a: not found in path `~S'~%" + (file-error:file-name c) + (file-search-error:path c)) + (exit exit-val)) + + ((file-open-error? c) + (format (current-error-port) "~a: cannot open file~%" + (file-error:file-name c)) + (exit exit-val)) + + ((file-write-error? c) + (format (current-error-port) "~a: cannot write to file~%" + (file-error:file-name c)) + (exit exit-val)) + + ((file-error? c) + (format (current-error-port) "file error: ~a~%" + (file-error:file-name c)) + (exit exit-val)) + + (;;(skribilo-error? c) + #t ;; XXX: The SRFI-35 currently in `guile-lib' doesn't work + ;; properly with non-direct super-types. + (let ((handler (lookup-error-condition-handler c))) + (if (procedure? handler) + (handler c) + (format (current-error-port) + "undefined skribilo error: ~S~%" + c))) + (exit exit-val))) + + (thunk))) + +(define-macro (call-with-skribilo-error-catch thunk) + `(call/cc (lambda (cont) + (%call-with-skribilo-error-catch ,thunk cont #f)))) + +;;; arch-tag: 285010f9-06ea-4c39-82c2-6c3604f668b3 + +;;; conditions.scm ends here diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in new file mode 100644 index 0000000..545612c --- /dev/null +++ b/src/guile/skribilo/config.scm.in @@ -0,0 +1,20 @@ +;;; -*- Scheme -*- +;;; + +(define-module (skribilo config)) + +(define-public (skribilo-release) "1.2") +(define-public (skribilo-url) "http://www.nongnu.org/skribilo/") +(define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") +(define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") +(define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@") +(define-public (skribilo-scheme) "guile") + +;; Compatibility. + +(define-public skribe-release skribilo-release) +(define-public skribe-url skribilo-url) +(define-public skribe-doc-dir skribilo-doc-directory) +(define-public skribe-ext-dir skribilo-extension-directory) +(define-public skribe-default-path skribilo-default-path) +(define-public skribe-scheme skribilo-scheme) diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm new file mode 100644 index 0000000..f7709a0 --- /dev/null +++ b/src/guile/skribilo/debug.scm @@ -0,0 +1,168 @@ +;;; debug.scm -- Debugging facilities. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (srfi srfi-17) + :use-module (srfi srfi-39) + :export-syntax (debug-item with-debug)) + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Parameters. +;;; + +;; Current debugging level. +(define-public *debug* + (make-parameter 0 (lambda (val) + (cond ((number? val) val) + ((string? val) + (string->number val)) + (else + (error "*debug*: wrong argument type" + val)))))) + +;; Whether to use colors. +(define-public *debug-use-colors?* (make-parameter #t)) + +;; Where to spit debugging output. +(define-public *debug-port* (make-parameter (current-output-port))) + +;; Whether to debug individual items. +(define-public *debug-item?* (make-parameter #f)) + +;; Watched (debugged) symbols (procedure names). +(define-public *watched-symbols* (make-parameter '())) + + + +;;; +;;; Implementation. +;;; + +(define *debug-depth* (make-parameter 0)) +(define *debug-margin* (make-parameter "")) +(define *margin-level* (make-parameter 0)) + + + +;; +;; debug-port +;; +; (define (debug-port . o) +; (cond +; ((null? o) +; *debug-port*) +; ((output-port? (car o)) +; (set! *debug-port* o) +; o) +; (else +; (error 'debug-port "Illegal debug port" (car o))))) +; + +;;; +;;; debug-color +;;; +(define (debug-color col . o) + (with-output-to-string + (if (and (*debug-use-colors?*) + (equal? (getenv "TERM") "xterm")) + (lambda () + (format #t "[0m[1;~Am" (+ 31 col)) + (for-each display o) + (display "[0m")) + (lambda () + (for-each display o))))) + +;;; +;;; debug-bold +;;; +(define (debug-bold . o) + (apply debug-color -30 o)) + +;;; +;;; debug-item +;;; +(define-macro (debug-item . args) + `(if (*debug-item?*) (%do-debug-item ,@args))) + +(define-public (%do-debug-item . args) + (begin + (display (*debug-margin*) (*debug-port*)) + (display (debug-color (- (*debug-depth*) 1) "- ") (*debug-port*)) + (for-each (lambda (a) (display a (*debug-port*))) args) + (newline (*debug-port*)))) + +;;(define-macro (debug-item . args) +;; `()) + + +;;; +;;; %with-debug-margin +;;; +(define (%with-debug-margin margin thunk) + (parameterize ((*debug-depth* (+ (*debug-depth*) 1)) + (*debug-margin* (string-append (*debug-margin*) margin))) + (thunk))) + +;;; +;;; %with-debug +;;; +(define-public (%do-with-debug lvl lbl thunk) + (parameterize ((*margin-level* lvl) + (*debug-item?* #t)) + (display (*debug-margin*) (*debug-port*)) + (display (if (= (*debug-depth*) 0) + (debug-color (*debug-depth*) "+ " lbl) + (debug-color (*debug-depth*) "--+ " lbl)) + (*debug-port*)) + (newline (*debug-port*)) + (%with-debug-margin (debug-color (*debug-depth*) " |") + thunk))) + +(define-macro (with-debug level label . body) + ;; We have this as a macro in order to avoid procedure calls in the + ;; non-debugging case. Unfortunately, the macro below duplicates BODY, + ;; which has a negative impact on memory usage and startup time (XXX). + (if (number? level) + `(if (or (>= (*debug*) ,level) + (memq ,label (*watched-symbols*))) + (%do-with-debug ,level ,label (lambda () ,@body)) + (begin ,@body)) + (error "with-debug: syntax error"))) + + +; Example: + +; (with-debug 0 'foo1.1 +; (debug-item 'foo2.1) +; (debug-item 'foo2.2) +; (with-debug 0 'foo2.3 +; (debug-item 'foo3.1) +; (with-debug 0 'foo3.2 +; (debug-item 'foo4.1) +; (debug-item 'foo4.2)) +; (debug-item 'foo3.3)) +; (debug-item 'foo2.4)) + +;;; debug.scm ends here diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm new file mode 100644 index 0000000..06667ad --- /dev/null +++ b/src/guile/skribilo/engine.scm @@ -0,0 +1,390 @@ +;;; engine.scm -- Skribilo engines. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo engine) + :use-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (skribilo lib) + + ;; `(skribilo writer)' depends on this module so it needs to be loaded + ;; after we defined `<engine>' and the likes. + :autoload (skribilo writer) (<writer>) + + :use-module (oop goops) + :use-module (ice-9 optargs) + :autoload (srfi srfi-39) (make-parameter) + + :export (<engine> engine? engine-ident engine-format + engine-customs engine-filter engine-symbol-table + + *current-engine* + default-engine default-engine-set! + make-engine copy-engine find-engine lookup-engine + engine-custom engine-custom-set! engine-custom-add! + engine-format? engine-add-writer! + processor-get-engine + push-default-engine pop-default-engine + + engine-loaded? when-engine-is-loaded)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +;; Note on writers +;; --------------- +;; +;; `writers' here is an `eq?' hash table where keys are markup names +;; (symbols) and values are lists of markup writers (most of the time, the +;; list will only contain one writer). Each of these writer may define a +;; predicate or class that may further restrict its applicability. +;; +;; `free-writers' is a list of writers that may apply to *any* kind of +;; markup. These are typically define by passing `#t' to `markup-writer' +;; instead of a symbol: +;; +;; (markup-writer #f (find-engine 'xml) +;; :before ... +;; ...) +;; +;; The XML engine contains an example of such free writers. Again, these +;; writers may define a predicate or a class restricting their applicability. +;; +;; The distinction between these two kinds of writers is mostly performance: +;; "free writers" are rarely used and markup-specific are the most common +;; case which we want to be fast. Therefore, for the latter case, we can't +;; afford traversing a list of markups, evaluating each and every markup +;; predicate. +;; +;; For more details, see `markup-writer-get' and `lookup-markup-writer' in +;; `(skribilo writer)'. + +(define-class <engine> () + (ident :init-keyword :ident :init-value '???) + (format :init-keyword :format :init-value "raw") + (info :init-keyword :info :init-value '()) + (version :init-keyword :version + :init-value 'unspecified) + (delegate :init-keyword :delegate :init-value #f) + (writers :init-thunk make-hash-table) + (free-writers :init-value '()) + (filter :init-keyword :filter :init-value #f) + (customs :init-keyword :custom :init-value '()) + (symbol-table :init-keyword :symbol-table :init-value '())) + + +(define (engine? obj) + (is-a? obj <engine>)) + +(define (engine-ident obj) + (slot-ref obj 'ident)) + +(define (engine-format obj) + (slot-ref obj 'format)) + +(define (engine-customs obj) + (slot-ref obj 'customs)) + +(define (engine-filter obj) + (slot-ref obj 'filter)) + +(define (engine-symbol-table obj) + (slot-ref obj 'symbol-table)) + + + +;;; +;;; Default engines. +;;; + +(define *default-engine* #f) +(define *default-engines* '()) + + +(define (default-engine) + *default-engine*) + + +(define (default-engine-set! 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) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + + +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + + +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + (else (*current-engine*))))) + (if (not (engine? e)) + (skribe-error 'engine-format? "no engine" e) + (string=? fmt (engine-format e))))) + +;;; +;;; MAKE-ENGINE +;;; +(define* (make-engine ident :key (version 'unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (make <engine> :ident ident :version version :format format + :filter filter :delegate delegate + :symbol-table symbol-table + :custom custom :info info))) + e)) + + +;;; +;;; COPY-ENGINE +;;; +(define* (copy-engine ident e :key (version 'unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((new (shallow-clone e))) + (slot-set! new 'ident ident) + (slot-set! new 'version version) + (slot-set! new 'filter (or filter (slot-ref e 'filter))) + (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) + (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) + (slot-set! new 'customs (or custom (slot-ref e 'customs))) + + ;; XXX: We don't use `list-copy' here because writer lists are only + ;; consed, never mutated. + + ;(slot-set! new 'free-writers (list-copy (slot-ref e 'free-writers))) + + (let ((new-writers (make-hash-table))) + (hash-for-each (lambda (m w*) + (hashq-set! new-writers m w*)) + (slot-ref e 'writers)) + (slot-set! new 'writers new-writers)) + + new)) + + + +;;; +;;; Engine loading. +;;; + +;; Each engine is to be stored in its own module with the `(skribilo engine)' +;; hierarchy. The `engine-id->module-name' procedure returns this module +;; name based on the engine name. + +(define (engine-id->module-name id) + `(skribilo engine ,id)) + +(define (engine-loaded? id) + "Check whether engine @var{id} is already loaded." + ;; Trick taken from `resolve-module' in `boot-9.scm'. + (nested-ref the-root-module + `(%app modules ,@(engine-id->module-name id)))) + +;; A mapping of engine names to hooks. +(define %engine-load-hook (make-hash-table)) + +(define (consume-load-hook! id) + (with-debug 5 'consume-load-hook! + (let ((hook (hashq-ref %engine-load-hook id))) + (if hook + (begin + (debug-item "running hook " hook " for engine " id) + (hashq-remove! %engine-load-hook id) + (run-hook hook)))))) + +(define (when-engine-is-loaded id thunk) + "Run @var{thunk} only when engine with identifier @var{id} is loaded." + (if (engine-loaded? id) + (begin + ;; Maybe the engine had already been loaded via `use-modules'. + (consume-load-hook! id) + (thunk)) + (let ((hook (or (hashq-ref %engine-load-hook id) + (let ((hook (make-hook))) + (hashq-set! %engine-load-hook id hook) + hook)))) + (add-hook! hook thunk)))) + + +(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) + + (let* ((engine (symbol-append id '-engine)) + (m (resolve-module (engine-id->module-name id)))) + (if (module-bound? m engine) + (let ((e (module-ref m engine))) + (if e (consume-load-hook! id)) + e) + (error "no such engine" id))))) + +(define* (find-engine id :key (version 'unspecified)) + (false-if-exception (apply lookup-engine (list id version)))) + + + + + +;;; +;;; Engine methods. +;;; + +(define (engine-custom e id) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (cadr c) + 'unspecified))) + + +(define (engine-custom-set! e id val) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (slot-set! e 'customs (cons (list id val) customs))))) + +(define (engine-custom-add! e id val) + (let ((old (engine-custom e id))) + (if (unspecified? old) + (engine-custom-set! e id (list val)) + (engine-custom-set! e id (cons val old))))) + +(define (engine-add-writer! e ident pred upred opt before action + after class valid) + ;; Add a writer to engine E. If IDENT is a symbol, then it should denote + ;; a markup name and the writer being added is specific to that markup. If + ;; IDENT is `#t' (for instance), then it is assumed to be a ``free writer'' + ;; that may apply to any kind of markup for which PRED returns true. + + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (if (not (is-a? e <engine>)) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (if pred + (check-procedure "predicate" pred 2)) + + ;; check the correctness of the validation proc + (if valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make <writer> + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (if (symbol? ident) + (let ((writers (slot-ref e 'writers))) + (hashq-set! writers ident + (cons n (hashq-ref writers ident '())))) + (slot-set! e 'free-writers + (cons n (slot-ref e 'free-writers)))) + n)) + + + +;;; +;;; Current engine. +;;; + +;;; `(skribilo module)' must be loaded before the first `find-engine' call. +(use-modules (skribilo module)) + +;; At this point, we're almost done with the bootstrap process. +;(format #t "base engine: ~a~%" (lookup-engine 'base)) + +(define *current-engine* + ;; By default, use the HTML engine. + (make-parameter (lookup-engine 'html) + (lambda (val) + (cond ((symbol? val) (lookup-engine val)) + ((engine? val) val) + (else + (error "invalid value for `*current-engine*'" + val)))))) + + +;;; engine.scm ends here diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am new file mode 100644 index 0000000..7b6ec2c --- /dev/null +++ b/src/guile/skribilo/engine/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/engine +dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \ + latex-simple.scm latex.scm \ + lout.scm \ + xml.scm diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm new file mode 100644 index 0000000..8418e8b --- /dev/null +++ b/src/guile/skribilo/engine/base.scm @@ -0,0 +1,479 @@ +;;; base.scm -- BASE Skribe engine +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine 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 #f "?~a@~a " k s)) + (else + (format #f "?~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) + "") + ;; FIXME: Since we don't support + ;; `:&skribe-eval-location', we could set up a + ;; `parameterize' thing around `skribe-eval' to + ;; provide it with the right location information. + ((or (not (integer? nc)) (= nc 1)) + (table :width 100. + ;;:&skribe-eval-location loc + :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..c9e0986 --- /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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 23-Sep-2004 17:21 (eg) +;;;; Last file update: 3-Nov-2004 12:54 (eg) +;;;; + +(define-skribe-module (skribilo engine context)) + +;;;; ====================================================================== +;;;; context-customs ... +;;;; ====================================================================== +(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 #f "$~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 #f "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 #f "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..6232b96 --- /dev/null +++ b/src/guile/skribilo/engine/html.scm @@ -0,0 +1,2313 @@ +;;; html.scm -- HTML engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine html) + :autoload (skribilo parameters) (*destination-file*) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:))) + + +;; Keep a reference to the base engine. +(define base-engine (find-engine 'base)) + +(if (not (engine? base-engine)) + (error "bootstrap problem: base engine broken" base-engine)) + +;*---------------------------------------------------------------------*/ +;* 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 #f "~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? (*destination-file*)) + (prefix (*destination-file*))) + "")) + (s (or (and (string? (*destination-file*)) + (suffix (*destination-file*))) + "html")) + (nm (get-file-name b s))) + (markup-option-add! node filename nm) + nm)) + ((document? node) + (*destination-file*)) + (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-public 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 #f) + (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 #f) + (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 #f) + (right-margin-foreground #f) + ;; author configuration + (author-font #f) + ;; title configuration + (title-font #f) + (title-background #f) + (title-foreground #f) + (file-title-separator " -- ") + ;; html file naming + (file-name-proc ,html-file-default) + ;; index configuration + (index-header-font-size #f) ;; +2. + ;; chapter configuration + (chapter-number->string number->string) + (chapter-file #f) + ;; section configuration + (section-title-start "<h3>") + (section-title-stop "</h3>") + (section-title-background #f) + (section-title-foreground #f) + (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 #f) + (subsection-title-foreground #f) + (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 #f) + (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 #f "~a." (car cnts))) + (else + (let loop ((cnts cnts)) + (if (null? (cdr cnts)) + (format #f "~a" (car cnts)) + (format #f "~a.~a" (car cnts) (loop (cdr cnts)))))))) + +;*---------------------------------------------------------------------*/ +;* html-width ... */ +;*---------------------------------------------------------------------*/ +(define-public (html-width width) + (cond + ((and (integer? width) (exact? width)) + (format #f "~A" width)) + ((real? width) + (format #f "~A%" (inexact->exact (round width)))) + ((string? width) + width) + (else + (skribe-error 'html-width "bad width" width)))) + +;*---------------------------------------------------------------------*/ +;* html-class ... */ +;*---------------------------------------------------------------------*/ +(define-public (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-public (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 :keywords) + :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-meta ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-meta + :before "<meta name=\"keywords\" content=\"" + :action (lambda (n e) + (let ((kw* (map ast->string (or (markup-body n) '())))) + (output (keyword-list->comma-separated kw*) e))) + :after "\">\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=\"skribilo-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin") + (html-margin body #f #f #f #f "skribilo-body") + (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin") + (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=\"skribilo-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin") + (html-margin body #f #f #f #f "skribilo-body") + (display "</tr></table>")) + (rm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n")) + (html-margin body #f #f #f #f "skribilo-body") + (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin") + (display "</tr></table>")) + (else + (display "<div class=\"skribilo-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 #f "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)) + (else #f)))) + 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 #f " ~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=\"skribilo-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: " + (s19:date->string + (s19:current-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=\"skribilo-title\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") + (if (html-color-spec? tbg) + (printf "<td align=\"center\"~A>" + (if (html-color-spec? tbg) + (string-append "bgcolor=\"" tbg "\"") + "")) + (display "<td align=\"center\">")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (when title + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribilo-title\"><strong><big>") + (output title e) + (display "</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=\"skribilo-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-public (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? (*destination-file*)) + (let ((f (format #f "~a.sui" (prefix (*destination-file*))))) + (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)) + (output name e) + (if nfn (printf "</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 #f "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 (and (*destination-file*) + (string=? f (*destination-file*))) + "" + (strip-ref-base (or f (*destination-file*) ""))) + (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))) + + (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)))) + (meta (new markup + (markup '&html-meta) + (ident (string-append id "-meta")) + (class (markup-class n)) + (parent n) + (body (markup-option (ast-document n) :keywords)))) + (head (new markup + (markup '&html-head) + (ident (string-append id "-head")) + (class (markup-class n)) + (parent n) + (body (list header meta)))) + (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-title\">" c) + (printf "<div class=\"skribilo-~a-title\">" (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>") + +;*---------------------------------------------------------------------*/ +;* ~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '~ + :before " " + :after #f + :action #f) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:label) + :action (lambda (n e) + (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" + (string-canonicalize (container-ident n)) + (markup-option n :label)))) + +;*---------------------------------------------------------------------*/ +;* 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) + "skribilo-ref"))) + (printf "<a href=\"~a#~a\" class=\"~a\"" + (if (and (*destination-file*) + (string=? f (*destination-file*))) + "" + (strip-ref-base (or f (*destination-file*) ""))) + (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..48550ef --- /dev/null +++ b/src/guile/skribilo/engine/html4.scm @@ -0,0 +1,168 @@ +;;;; +;;;; html4.skr -- HTML 4.01 Engine +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 18-Feb-2004 11:58 (eg) +;;;; Last file update: 26-Feb-2004 21:09 (eg) +;;;; + +(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 #f "~a%" + (+ 100 + (* 20 (inexact->exact (truncate sz)))))) + ((number? sz) + sz) + (else + (skribe-error 'font + (format #f + "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..8d5b88f --- /dev/null +++ b/src/guile/skribilo/engine/latex.scm @@ -0,0 +1,1784 @@ +;;; latex.scm -- LaTeX engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine latex)) + +;*---------------------------------------------------------------------*/ +;* 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 #f "\\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 #f "$~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 #f "~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 #f "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 #f "~a-above" id)) + (class "table-line-above")) + e)) + ((above hsides) + (printf "{~a}" cols) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format #f "~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 #f "~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/lout.scm b/src/guile/skribilo/engine/lout.scm new file mode 100644 index 0000000..893ab2e --- /dev/null +++ b/src/guile/skribilo/engine/lout.scm @@ -0,0 +1,2891 @@ +;;; lout.scm -- A Lout engine. +;;; +;;; Copyright 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;;; Taken from `lcourtes@laas.fr--2004-libre', +;;; `skribe-lout--main--0.2--patch-15'. +;;; Based on `latex.skr', copyright 2003, 2004 Manuel Serrano. + + +(define-skribe-module (skribilo engine lout) + :autoload (ice-9 popen) (open-output-pipe) + :autoload (ice-9 rdelim) (read-line)) + + + +;*---------------------------------------------------------------------*/ +;* lout-verbatim-encoding ... */ +;*---------------------------------------------------------------------*/ +(define-public lout-verbatim-encoding + '((#\/ "\"/\"") + (#\\ "\"\\\\\"") + (#\| "\"|\"") + (#\& "\"&\"") + (#\@ "\"@\"") + (#\" "\"\\\"\"") + (#\{ "\"{\"") + (#\} "\"}\"") + (#\$ "\"$\"") + (#\# "\"#\"") + (#\_ "\"_\"") + (#\~ "\"~\""))) + +;*---------------------------------------------------------------------*/ +;* lout-encoding ... */ +;*---------------------------------------------------------------------*/ +(define-public lout-encoding + `(,@lout-verbatim-encoding + (#\ç "{ @Char ccedilla }") + (#\Ç "{ @Char Ccdeilla }") + (#\â "{ @Char acircumflex }") + (#\ "{ @Char Acircumflex }") + (#\à "{ @Char agrave }") + (#\À "{ @Char Agrave }") + (#\é "{ @Char eacute }") + (#\É "{ @Char Eacute }") + (#\è "{ @Char egrave }") + (#\È "{ @Char Egrave }") + (#\ê "{ @Char ecircumflex }") + (#\Ê "{ @Char Ecircumflex }") + (#\ù "{ @Char ugrave }") + (#\Ù "{ @Char Ugrave }") + (#\û "{ @Char ucircumflex }") + (#\Û "{ @Char Ucircumflex }") + (#\ø "{ @Char oslash }") + (#\ô "{ @Char ocircumflex }") + (#\Ô "{ @Char Ocircumflex }") + (#\ö "{ @Char odieresis }") + (#\Ö "{ @Char Odieresis }") + (#\î "{ @Char icircumflex }") + (#\Î "{ @Char Icircumflex }") + (#\ï "{ @Char idieresis }") + (#\Ï "{ @Char Idieresis }") + (#\] "\"]\"") + (#\[ "\"[\"") + (#\» "{ @Char guillemotright }") + (#\« "{ @Char guillemotleft }"))) + + +;; XXX: This is just here for experimental purposes. +(define lout-french-punctuation-encoding + (let ((space (lambda (before after thing) + (string-append "{ " + (if before + (string-append "{ " before " @Wide {} }") + "") + "\"" thing "\"" + (if after + (string-append "{ " after " @Wide {} }") + "") + " }")))) + `((#\; ,(space "0.5s" #f ";")) + (#\? ,(space "0.5s" #f ";")) + (#\! ,(space "0.5s" #f ";"))))) + +(define lout-french-encoding + (let ((punctuation (map car lout-french-punctuation-encoding))) + (append (let loop ((ch lout-encoding) + (purified '())) + (if (null? ch) + purified + (loop (cdr ch) + (if (member (car ch) punctuation) + purified + (cons (car ch) purified))))) + lout-french-punctuation-encoding))) + +;*---------------------------------------------------------------------*/ +;* lout-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define (lout-symbol-table sym math) + `(("iexcl" "{ @Char exclamdown }") + ("cent" "{ @Char cent }") + ("pound" "{ @Char sterling }") + ("yen" "{ @Char yen }") + ("section" "{ @Char section }") + ("mul" "{ @Char multiply }") + ("copyright" "{ @Char copyright }") + ("lguillemet" "{ @Char guillemotleft }") + ("not" "{ @Char logicalnot }") + ("degree" "{ @Char degree }") + ("plusminus" "{ @Char plusminus }") + ("micro" "{ @Char mu }") + ("paragraph" "{ @Char paragraph }") + ("middot" "{ @Char periodcentered }") + ("rguillemet" "{ @Char guillemotright }") + ("1/4" "{ @Char onequarter }") + ("1/2" "{ @Char onehalf }") + ("3/4" "{ @Char threequarters }") + ("iquestion" "{ @Char questiondown }") + ("Agrave" "{ @Char Agrave }") + ("Aacute" "{ @Char Aacute }") + ("Acircumflex" "{ @Char Acircumflex }") + ("Atilde" "{ @Char Atilde }") + ("Amul" "{ @Char Adieresis }") ;;; FIXME: Why `mul' and not `uml'?! + ("Aring" "{ @Char Aring }") + ("AEligature" "{ @Char oe }") + ("Oeligature" "{ @Char OE }") ;;; FIXME: Should be `OEligature'?! + ("Ccedilla" "{ @Char Ccedilla }") + ("Egrave" "{ @Char Egrave }") + ("Eacute" "{ @Char Eacute }") + ("Ecircumflex" "{ @Char Ecircumflex }") + ("Euml" "{ @Char Edieresis }") + ("Igrave" "{ @Char Igrave }") + ("Iacute" "{ @Char Iacute }") + ("Icircumflex" "{ @Char Icircumflex }") + ("Iuml" "{ @Char Idieresis }") + ("ETH" "{ @Char Eth }") + ("Ntilde" "{ @Char Ntilde }") + ("Ograve" "{ @Char Ograve }") + ("Oacute" "{ @Char Oacute }") + ("Ocircumflex" "{ @Char Ocircumflex }") + ("Otilde" "{ @Char Otilde }") + ("Ouml" "{ @Char Odieresis }") + ("times" ,(sym "multiply")) + ("Oslash" "{ @Char oslash }") + ("Ugrave" "{ @Char Ugrave }") + ("Uacute" "{ @Char Uacute }") + ("Ucircumflex" "{ @Char Ucircumflex }") + ("Uuml" "{ @Char Udieresis }") + ("Yacute" "{ @Char Yacute }") + ("szlig" "{ @Char germandbls }") + ("agrave" "{ @Char agrave }") + ("aacute" "{ @Char aacute }") + ("acircumflex" "{ @Char acircumflex }") + ("atilde" "{ @Char atilde }") + ("amul" "{ @Char adieresis }") + ("aring" "{ @Char aring }") + ("aeligature" "{ @Char ae }") + ("oeligature" "{ @Char oe }") + ("ccedilla" "{ @Char ccedilla }") + ("egrave" "{ @Char egrave }") + ("eacute" "{ @Char eacute }") + ("ecircumflex" "{ @Char ecircumflex }") + ("euml" "{ @Char edieresis }") + ("igrave" "{ @Char igrave }") + ("iacute" "{ @Char iacute }") + ("icircumflex" "{ @Char icircumflex }") + ("iuml" "{ @Char idieresis }") + ("ntilde" "{ @Char ntilde }") + ("ograve" "{ @Char ograve }") + ("oacute" "{ @Char oacute }") + ("ocurcumflex" "{ @Char ocircumflex }") ;; FIXME: `ocIrcumflex' + ("otilde" "{ @Char otilde }") + ("ouml" "{ @Char odieresis }") + ("divide" "{ @Char divide }") + ("oslash" "{ @Char oslash }") + ("ugrave" "{ @Char ugrave }") + ("uacute" "{ @Char uacute }") + ("ucircumflex" "{ @Char ucircumflex }") + ("uuml" "{ @Char udieresis }") + ("yacute" "{ @Char yacute }") + ("ymul" "{ @Char ydieresis }") ;; FIXME: `yUMl' + ;; Greek + ("Alpha" ,(sym "Alpha")) + ("Beta" ,(sym "Beta")) + ("Gamma" ,(sym "Gamma")) + ("Delta" ,(sym "Delta")) + ("Epsilon" ,(sym "Epsilon")) + ("Zeta" ,(sym "Zeta")) + ("Eta" ,(sym "Eta")) + ("Theta" ,(sym "Theta")) + ("Iota" ,(sym "Iota")) + ("Kappa" ,(sym "Kappa")) + ("Lambda" ,(sym "Lambda")) + ("Mu" ,(sym "Mu")) + ("Nu" ,(sym "Nu")) + ("Xi" ,(sym "Xi")) + ("Omicron" ,(sym "Omicron")) + ("Pi" ,(sym "Pi")) + ("Rho" ,(sym "Rho")) + ("Sigma" ,(sym "Sigma")) + ("Tau" ,(sym "Tau")) + ("Upsilon" ,(sym "Upsilon")) + ("Phi" ,(sym "Phi")) + ("Chi" ,(sym "Chi")) + ("Psi" ,(sym "Psi")) + ("Omega" ,(sym "Omega")) + ("alpha" ,(sym "alpha")) + ("beta" ,(sym "beta")) + ("gamma" ,(sym "gamma")) + ("delta" ,(sym "delta")) + ("epsilon" ,(sym "epsilon")) + ("zeta" ,(sym "zeta")) + ("eta" ,(sym "eta")) + ("theta" ,(sym "theta")) + ("iota" ,(sym "iota")) + ("kappa" ,(sym "kappa")) + ("lambda" ,(sym "lambda")) + ("mu" ,(sym "mu")) + ("nu" ,(sym "nu")) + ("xi" ,(sym "xi")) + ("omicron" ,(sym "omicron")) + ("pi" ,(sym "pi")) + ("rho" ,(sym "rho")) + ("sigmaf" ,(sym "sigmaf")) ;; FIXME! + ("sigma" ,(sym "sigma")) + ("tau" ,(sym "tau")) + ("upsilon" ,(sym "upsilon")) + ("phi" ,(sym "phi")) + ("chi" ,(sym "chi")) + ("psi" ,(sym "psi")) + ("omega" ,(sym "omega")) + ("thetasym" ,(sym "thetasym")) + ("piv" ,(sym "piv")) ;; FIXME! + ;; punctuation + ("bullet" ,(sym "bullet")) + ("ellipsis" ,(sym "ellipsis")) + ("weierp" "{ @Sym weierstrass }") + ("image" ,(sym "Ifraktur")) + ("real" ,(sym "Rfraktur")) + ("tm" ,(sym "trademarksans")) ;; alt: @Sym trademarkserif + ("alef" ,(sym "aleph")) + ("<-" ,(sym "arrowleft")) + ("<--" "{ { 1.6 1 } @Scale { @Sym arrowleft } }") ;; copied from `eqf' + ("uparrow" ,(sym "arrowup")) + ("->" ,(sym "arrowright")) + ("-->" "{ { 1.6 1 } @Scale { @Sym arrowright } }") + ("downarrow" ,(sym "arrowdown")) + ("<->" ,(sym "arrowboth")) + ("<-->" "{ { 1.6 1 } @Scale { @Sym arrowboth } }") + ("<+" ,(sym "carriagereturn")) + ("<=" ,(sym "arrowdblleft")) + ("<==" "{ { 1.6 1 } @Scale { @Sym arrowdblleft } }") + ("Uparrow" ,(sym "arrowdblup")) + ("=>" ,(sym "arrowdblright")) + ("==>" "{ { 1.6 1 } @Scale { @Sym arrowdblright } }") + ("Downarrow" ,(sym "arrowdbldown")) + ("<=>" ,(sym "arrowdblboth")) + ("<==>" "{ { 1.6 1 } @Scale { @Sym arrowdblboth } }") + ;; Mathematical operators (we try to avoid `@Eq' since it + ;; requires to `@SysInclude { eq }' -- one solution consists in copying + ;; the symbol definition from `eqf') + ("forall" "{ { Symbol Base } @Font \"\\042\" }") + ("partial" ,(sym "partialdiff")) + ("exists" "{ { Symbol Base } @Font \"\\044\" }") + ("emptyset" "{ { Symbol Base } @Font \"\\306\" }") + ("infinity" ,(sym "infinity")) + ("nabla" "{ { Symbol Base } @Font \"\\321\" }") + ("in" ,(sym "element")) + ("notin" ,(sym "notelement")) + ("ni" "{ 180d @Rotate @Sym element }") + ("prod" ,(sym "product")) + ("sum" ,(sym "summation")) + ("asterisk" ,(sym "asteriskmath")) + ("sqrt" ,(sym "radical")) + ("propto" ,(math "propto")) + ("angle" ,(sym "angle")) + ("and" ,(math "bwedge")) + ("or" ,(math "bvee")) + ("cap" ,(math "bcap")) + ("cup" ,(math "bcup")) + ("integral" ,(math "int")) + ("models" ,(math "models")) + ("vdash" ,(math "vdash")) + ("dashv" ,(math "dashv")) + ("sim" ,(sym "similar")) + ("cong" ,(sym "congruent")) + ("approx" ,(sym "approxequal")) + ("neq" ,(sym "notequal")) + ("equiv" ,(sym "equivalence")) + ("le" ,(sym "lessequal")) + ("ge" ,(sym "greaterequal")) + ("subset" ,(sym "propersubset")) + ("supset" ,(sym "propersuperset")) + ("subseteq" ,(sym "reflexsubset")) + ("supseteq" ,(sym "reflexsuperset")) + ("oplus" ,(sym "circleplus")) + ("otimes" ,(sym "circlemultiply")) + ("perp" ,(sym "perpendicular")) + ("mid" ,(sym "bar")) + ("lceil" ,(sym "bracketlefttp")) + ("rceil" ,(sym "bracketrighttp")) + ("lfloor" ,(sym "bracketleftbt")) + ("rfloor" ,(sym "bracketrightbt")) + ("langle" ,(sym "angleleft")) + ("rangle" ,(sym "angleright")) + ;; Misc + ("loz" "{ @Lozenge }") + ("spades" ,(sym "spade")) + ("clubs" ,(sym "club")) + ("hearts" ,(sym "heart")) + ("diams" ,(sym "diamond")) + ("euro" "{ @Euro }") + ;; Lout + ("dag" "{ @Dagger }") + ("ddag" "{ @DaggerDbl }") + ("circ" ,(math "circle")) + ("top" ,(math "top")) + ("bottom" ,(math "bot")) + ("lhd" ,(math "triangleleft")) + ("rhd" ,(math "triangleright")) + ("parallel" ,(math "dbar")))) + + +;;; Debugging support + +(define *lout-debug?* #f) + +(define-macro (lout-debug fmt . args) + `(if *lout-debug?* + (with-output-to-port (current-error-port) + (lambda () + (printf (string-append ,fmt "~%") ,@args + (current-error-port)))) + #t)) + +(define-public (lout-tagify ident) + ;; Return an "clean" identifier (a string) based on `ident' (a string), + ;; suitable for Lout as an `@Tag' value. + (let ((tag-encoding '((#\, "-") + (#\( "-") + (#\) "-") + (#\[ "-") + (#\] "-") + (#\/ "-") + (#\| "-") + (#\& "-") + (#\@ "-") + (#\! "-") + (#\? "-") + (#\: "-") + (#\; "-"))) + (tag (string-canonicalize ident))) + ((make-string-replace tag-encoding) tag))) + + +;; Default values of various customs (procedures) + +(define (lout-definitions engine) + ;; Return a string containing a set of useful Lout definitions that should + ;; be inserted at the beginning of the output document. + (let ((leader (engine-custom engine 'toc-leader)) + (leader-space (engine-custom engine 'toc-leader-space))) + (apply string-append + `("# @SkribeMark implements Skribe's marks " + "(i.e. cross-references)\n" + "def @SkribeMark\n" + " right @Tag\n" + "{\n" + " @PageMark @Tag\n" + "}\n\n" + + "# @SkribiloLeaders is used in `toc'\n" + "# (this is mostly copied from the expert's guide)\n" + "def @SkribiloLeaders { " + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) + +(define (lout-make-doc-cover-sheet doc engine) + ;; Create a cover sheet for node `doc' which is a doc-style Lout document. + ;; This is the default implementation, i.e. the default value of the + ;; `doc-cover-sheet-proc' custom. + (let ((title (markup-option doc :title)) + (author (markup-option doc :author)) + (date-line (engine-custom engine 'date-line)) + (cover-sheet? (engine-custom engine 'cover-sheet?)) + (multi-column? (> (engine-custom engine 'column-number) 1))) + + (if multi-column? + ;; In single-column document, `@FullWidth' yields a blank page. + (display "\n@FullWidth {")) + (display "\n//3.0fx\n") + (display "\n@Center 1.4f @Font @B { cragged nohyphen 1.4fx } @Break { ") + (if title + (output title engine) + (display "The Lout Document")) + (display " }\n") + (display "//1.7fx\n") + (if date-line + (begin + (display "@Center { ") + (output date-line engine) + (display " }\n//1.4fx\n"))) + (if author + (begin + (display "@Center { ") + (output author engine) + (display " }\n") + (display "//4fx\n"))) + (if multi-column? + (display "\n} # @FullWidth\n")))) + +(define (lout-split-external-link markup) + ;; Shorten `markup', an URL `url-ref' markup, by splitting it into an URL + ;; `ref' followed by plain text. This is useful because Lout's + ;; @ExternalLink symbols are unbreakable to the embodied text should _not_ + ;; be too large (otherwise it is scaled down). + (let* ((url (markup-option markup :url)) + (text (or (markup-option markup :text) url))) + (lout-debug "lout-split-external-link: text=~a" text) + (cond ((pair? text) + ;; no need to go recursive here: we'll get called again later + `(,(ref :url url :text (car text)) ,@(cdr text))) + + ((string? text) + (let ((len (string-length text))) + (if (> (- len 8) 2) + ;; don't split on a whitespace or it will vanish + (let ((split (let loop ((where 10)) + (if (= 0 where) + 10 + (if (char=? (string-ref text + (- where 1)) + #\space) + (loop (- where 1)) + where))))) + `(,(ref :url url :text (substring text 0 split)) + ,(substring text split len))) + (list markup)))) + + ((markup? text) + (let ((kind (markup-markup text))) + (lout-debug "lout-split-external-link: kind=~a" kind) + (if (member kind '(bold it underline)) + ;; get the ornament markup out of the `:text' argument + (list (apply (eval kind (interaction-environment)) + (list (ref :url url + :text (markup-body text))))) + ;; otherwise, leave it as is + (list markup)))) + + (else (list markup))))) + +(define (lout-make-toc-entry node engine) + ;; Default implementation of the `toc-entry-proc' custom that produces the + ;; number and title of `node' for use in the table of contents. + (let ((num (markup-option node :number)) + (title (markup-option node :title)) + (lang (engine-custom engine 'initial-language))) + (if num + (begin + (if (is-markup? node 'chapter) (display "@B { ")) + (printf "~a. |2s " (lout-structure-number-string node)) + (output title engine) + (if (is-markup? node 'chapter) (display " }"))) + (if (is-markup? node 'chapter) + (output (bold title) engine) + (output title engine))))) + +(define (lout-bib-refs-sort/number entry1 entry2) + ;; Default implementation of the `bib-refs-sort-proc' custom. Compare + ;; bibliography entries `entry1' and `entry2' (of type `&bib-entry') for + ;; use by `sort' in `bib-ref+'. + (let ((ident1 (markup-option entry1 :title)) + (ident2 (markup-option entry2 :title))) + (if (and (markup? ident1) (markup? ident2)) + (< (markup-option ident1 'number) + (markup-option ident2 'number)) + (begin + (fprint (current-error-port) "i1: " ident1 ", " entry1) + (fprint (current-error-port) "i2: " ident2 ", " entry2))))) + +(define (lout-pdf-bookmark-title node engine) + ;; Default implementation of the `pdf-bookmark-title-proc' custom that + ;; returns a title (a string) for the PDF bookmark of `node'. + (let ((number (lout-structure-number-string node))) + (string-append (if (string=? number "") "" (string-append number ". ")) + (ast->string (markup-option node :title))))) + +(define (lout-pdf-bookmark-node? node engine) + ;; Default implementation of the `pdf-bookmark-node-pred' custom that + ;; returns a boolean. + (or (is-markup? node 'chapter) + (is-markup? node 'section) + (is-markup? node 'subsection) + (is-markup? node 'slide))) + + + + +;*---------------------------------------------------------------------*/ +;* lout-engine ... */ +;*---------------------------------------------------------------------*/ +(define lout-engine + (make-engine 'lout + :version 0.2 + :format "lout" + :delegate (find-engine 'base) + :filter (make-string-replace lout-encoding) + :custom `(;; The underlying Lout document type, i.e. one + ;; of `doc', `report', `book' or `slides'. + (document-type doc) + + ;; Document style file include line (a string + ;; such as `@Include { doc-style.lout }') or + ;; `auto' (symbol) in which case the include + ;; file is deduced from `document-type'. + (document-include auto) + + (includes "@SysInclude { tbl }\n") + (initial-font "Palatino Base 10p") + (initial-break + ,(string-append "unbreakablefirst " + "unbreakablelast " + "hyphen adjust 1.2fx")) + + ;; The document's language, used for hyphenation + ;; and other things. + (initial-language "English") + + ;; Number of columns. + (column-number 1) + + ;; First page number. + (first-page-number 1) + + ;; Page orientation, `portrait', `landscape', + ;; `reverse-portrait' or `reverse-landscape'. + (page-orientation portrait) + + ;; For reports, whether to produce a cover + ;; sheet. The `doc-cover-sheet-proc' custom may + ;; also honor this custom for `doc' documents. + (cover-sheet? #t) + + ;; For reports, the date line. + (date-line #t) + + ;; For reports, an abstract. + (abstract #f) + + ;; For reports, title/name of the abstract. If + ;; `#f', the no abstract title will be + ;; produced. If `#t', a default name in the + ;; current language is chosen. + (abstract-title #t) + + ;; Whether to optimize pages. + (optimize-pages? #f) + + ;; For docs, the procedure that produces the + ;; Lout code for the cover sheet or title. + (doc-cover-sheet-proc + ,lout-make-doc-cover-sheet) + + ;; Procedure used to sort bibliography + ;; references when several are referred to at + ;; the same time, as in: + ;; (ref :bib '("smith03" "jones98")) . + ;; By default they are sorted by number. If + ;; `#f' is given, they are left as is. + (bib-refs-sort-proc + ,lout-bib-refs-sort/number) + + ;; Lout code for paragraph gaps (similar to + ;; `@PP' with `@ParaGap' equal to `1.0vx' by + ;; default) + (paragraph-gap + "\n//1.0vx @ParaIndent @Wide &{0i}\n") + + ;; For multi-page tables, it may be + ;; useful to set this to `#t'. However, + ;; this looks kind of buggy. + (use-header-rows? #f) + + ;; Tells whether to use Skribe's footnote + ;; numbers or Lout's numbering scheme (the + ;; latter may be better, typography-wise). + (use-skribe-footnote-numbers? #t) + + ;; A procedure that is passed the engine + ;; and produces Lout definitions. + (inline-definitions-proc ,lout-definitions) + + ;; A procedure that takes a URL `ref' markup and + ;; returns a list containing (maybe) one such + ;; `ref' markup. This custom can be used to + ;; modified the way URLs are rendered. The + ;; default value is a procedure that limits the + ;; size of Lout's @ExternalLink symbols since + ;; they are unbreakable. In order to completely + ;; disable use of @ExternalLinks, just set it to + ;; `markup-body'. + (transform-url-ref-proc + ,lout-split-external-link) + + ;; Leader used in the table of contents entries. + (toc-leader ".") + + ;; Inter-leader spacing in the TOC entries. + (toc-leader-space "2.5s") + + ;; Procedure that takes a large-scale structure + ;; (chapter, section, etc.) and the engine and + ;; produces the number and possibly title of + ;; this structure for use the TOC. + (toc-entry-proc ,lout-make-toc-entry) + + ;; The Lout program name, only useful when using + ;; `lout-illustration' on other back-ends. + (lout-program-name "lout") + + ;; Title and author information in the PDF + ;; document information. If `#t', the + ;; document's `:title' and `:author' are used. + (pdf-title #t) + (pdf-author #t) + + ;; Keywords (a list of string) in the PDF + ;; document information. This custom is deprecated, + ;; use the `:keywords' option of `document' instead. + (pdf-keywords #f) + + ;; Extra PDF information, an alist of key-value + ;; pairs (string pairs). + (pdf-extra-info (("SkribeVersion" + ,(skribe-release)))) + + ;; Tells whether to produce PDF "docinfo" + ;; (meta-information with title, author, + ;; keywords, etc.). + (make-pdf-docinfo? #t) + + ;; Tells whether a PDF outline + ;; (aka. "bookmarks") should be produced. + (make-pdf-outline? #t) + + ;; Procedure that takes a node and an engine and + ;; return a string representing the title of + ;; that node's PDF bookmark. + (pdf-bookmark-title-proc ,lout-pdf-bookmark-title) + + ;; Procedure that takes a node and an engine and + ;; returns true if that node should have a PDF + ;; outline entry. + (pdf-bookmark-node-pred ,lout-pdf-bookmark-node?) + + ;; Procedure that takes a node and an engine and + ;; returns true if the bookmark for that node + ;; should be closed ("folded") when the user + ;; opens the PDF document. + (pdf-bookmark-closed-pred + ,(lambda (n e) + (not (is-markup? n 'chapter)))) + + ;; color + (color? #t) + + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (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")) + + :symbol-table (lout-symbol-table + (lambda (m) + ;; We don't use `@Sym' because it doesn't + ;; work within `@Eq'. + (string-append "{ { Symbol Base } @Font " + "@Char \"" m "\" }")) + (lambda (m) + (format #f "{ @Eq { ~a } }" m))))) + + +;; So that calls to `markup-writer' automatically use `lout-engine'... +(push-default-engine lout-engine) + + + +;; User-level implementation of PDF bookmarks. +;; +;; Basically, Lout code is produced that produces (via `@Graphic') PostScript +;; code. That PostScript code is a `pdfmark' command (see Adobe's "pdfmark +;; Reference Manual") which, when converted to PDF (e.g. with `ps2pdf'), +;; produces a PDF outline, aka. "bookmarks" (see "PDF Reference, Fifth +;; Edition", section 8.2.2). + +(define (lout-internal-dest-name ident) + ;; Return the Lout-generated `pdfmark' named destination for `ident'. This + ;; function mimics Lout's `ConvertToPDFName ()', in `z49.c' (Lout's + ;; PostScript back-end). In Lout, `ConvertToPDFName ()' produces + ;; destination names for the `/Dest' function of the `pdfmark' operator. + ;; This implementation is valid as of Lout 3.31 and hopefully it won't + ;; change in the future. + (string-append "LOUT" + (list->string (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + c + #\_)) + (string->list ident))))) + +(define (lout-pdf-bookmark node children closed? engine) + ;; Return the PostScript `pdfmark' operation (a string) that creates a PDF + ;; bookmark for node `node'. `children' is the number of children of + ;; `node' in the PDF outline. If `closed?' is true, then the bookmark will + ;; be close (i.e. its children are hidden). + ;; + ;; Note: Here, we use a `GoTo' action, while we could instead simply + ;; produce a `/Page' attribute without having to use the + ;; `lout-internal-dest-name' hack. The point for doing this is that Lout's + ;; `@PageOf' operator doesn't return an "actual" page number within the + ;; document, but rather a "typographically correct" page number (e.g. `i' + ;; for the cover sheet, `1' for the second page, etc.). See + ;; http://lists.planix.com/pipermail/lout-users/2005q1/003925.html for + ;; details. + (let* ((filter-title (make-string-replace `(,@lout-verbatim-encoding + (#\newline " ")))) + (make-bookmark-title (lambda (n e) + (filter-title + ((engine-custom + engine 'pdf-bookmark-title-proc) + n e)))) + (ident (markup-ident node))) + (string-append "[" + (if (= 0 children) + "" + (string-append "\"/\"Count " + (if closed? "-" "") + (number->string children) " ")) + "\"/\"Title \"(\"" (make-bookmark-title node engine) + "\")\" " + (if (not ident) "" + (string-append "\"/\"Action \"/\"GoTo \"/\"Dest \"/\"" + (lout-internal-dest-name ident) " ")) + "\"/\"OUT pdfmark\n"))) + +(define (lout-pdf-outline node engine . children) + ;; Return the PDF outline string (in the form of a PostScript `pdfmark' + ;; command) for `node' whose child nodes are assumed to be `children', + ;; unless `node' is a document. + (let* ((choose-node? (lambda (n) + ((engine-custom engine 'pdf-bookmark-node-pred) + n engine))) + (nodes (if (document? node) + (filter choose-node? (markup-body node)) + children))) + (apply string-append + (map (lambda (node) + (let* ((children (filter choose-node? (markup-body node))) + (closed? ((engine-custom engine + 'pdf-bookmark-closed-pred) + node engine)) + (bm (lout-pdf-bookmark node (length children) + closed? engine))) + (string-append bm (apply lout-pdf-outline + `(,node ,engine ,@children))))) + nodes)))) + +(define-public (lout-embedded-postscript-code postscript) + ;; Return a string embedding PostScript code `postscript' into Lout code. + (string-append "\n" + "{ @BackEnd @Case {\n" + " PostScript @Yield {\n" + postscript + " }\n" + "} } @Graphic { }\n")) + +(define-public (lout-pdf-docinfo doc engine) + ;; Produce PostScript code that will produce PDF document information once + ;; converted to PDF. + (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding + (#\newline " ")))) + (docinfo-field (lambda (key value) + (string-append "\"/\"" key " \"(\"" + (filter-string value) + "\")\"\n"))) + (author (let ((a (engine-custom engine 'pdf-author))) + (if (or (string? a) (ast? a)) + a + (markup-option doc :author)))) + (title (let ((t (engine-custom engine 'pdf-title))) + (if (or (string? t) (ast? t)) + t + (markup-option doc :title)))) + (keywords (or (engine-custom engine 'pdf-keywords) + (map ast->string + (or (markup-option doc :keywords) '())))) + (extra-fields (engine-custom engine 'pdf-extra-info))) + + (string-append "[ " + (if title + (docinfo-field "Title" (ast->string title)) + "") + (if author + (docinfo-field "Author" + (or (cond ((markup? author) + (ast->string + (or (markup-option + author :name) + (markup-option + author :affiliation)))) + ((string? author) author) + (else (ast->string author))) + "")) + "") + (if (pair? keywords) + (docinfo-field "Keywords" + (apply string-append + (keyword-list->comma-separated + keywords))) + "") + ;; arbitrary key-value pairs, see sect. 4.7, "Info + ;; dictionary" of the `pdfmark' reference. + (if (or (not extra-fields) (null? extra-fields)) + "" + (apply string-append + (map (lambda (p) + (docinfo-field (car p) (cadr p))) + extra-fields))) + "\"/\"DOCINFO pdfmark\n"))) + +(define-public (lout-output-pdf-meta-info doc engine) + ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as + ;; document meta-information (or "docinfo"). This function makes sure that + ;; both are only produced once, and only if the relevant customs ask for + ;; them. + (if (and doc (engine-custom engine 'make-pdf-outline?) + (not (markup-option doc '&pdf-outline-produced?))) + (begin + (display + (lout-embedded-postscript-code (lout-pdf-outline doc engine))) + (markup-option-add! doc '&pdf-outline-produced? #t))) + (if (and doc (engine-custom engine 'make-pdf-docinfo?) + (not (markup-option doc '&pdf-docinfo-produced?))) + (begin + (display + (lout-embedded-postscript-code (lout-pdf-docinfo doc engine))) + (markup-option-add! doc '&pdf-docinfo-produced? #t)))) + + + +;*---------------------------------------------------------------------*/ +;* lout ... */ +;*---------------------------------------------------------------------*/ +(define-markup (!lout fmt #!rest opt) + (if (engine-format? "lout") + (apply ! fmt opt) + #f)) + +;*---------------------------------------------------------------------*/ +;* lout-width ... */ +;*---------------------------------------------------------------------*/ +(define (lout-width width) + (cond ((inexact? width) ;; a relative size (XXX: was `flonum?') + ;; FIXME: Hack ahead: assuming A4 with a 2.5cm margin + ;; on both sides + (let* ((orientation (let ((lout (find-engine 'lout))) + (or (and lout + (engine-custom lout + 'page-orientation)) + 'portrait))) + (margins 5) + (paper-width (case orientation + ((portrait reverse-portrait) + (- 21 margins)) + (else (- 29.7 margins))))) + (string-append (number->string (* paper-width + (/ (abs width) 100.))) + "c"))) + ((string? width) ;; an engine-dependent width + width) + (else ;; an absolute "pixel" size + (string-append (number->string width) "p")))) + +;*---------------------------------------------------------------------*/ +;* lout-font-size ... */ +;*---------------------------------------------------------------------*/ +(define (lout-font-size size) + (case size + ((4) "3.5f") + ((3) "2.0f") + ((2) "1.5f") + ((1) "1.2f") + ((0) "1.0f") + ((-1) "0.8f") + ((-2) "0.5f") + ((-3) "0.3f") + ((-4) "0.2f") + (else (if (number? size) + (if (< size 0) "0.3f" "1.5f") + "1.0f")))) + +(define-public (lout-color-specification skribe-color) + ;; Return a Lout color name, ie. a string which is either an English color + ;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string + ;; representing a Skribe color such as "black" or "#ffffff". + (let ((b&w? (let ((lout (find-engine 'lout))) + (and lout (not (engine-custom lout 'color?))))) + (actual-color + (if (and (string? skribe-color) + (char=? (string-ref skribe-color 0) #\#)) + (string->number (substring skribe-color 1 + (string-length skribe-color)) + 16) + skribe-color))) + (receive (r g b) + (skribe-color->rgb actual-color) + (apply format #f + (cons "rgb ~a ~a ~a" + (map (if b&w? + (let ((avg (exact->inexact (/ (+ r g b) + (* 256 3))))) + (lambda (x) avg)) + (lambda (x) + (exact->inexact (/ x 256)))) + (list r g b))))))) + +;*---------------------------------------------------------------------*/ +;* ~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '~ :before "~" :action #f) + +(define (lout-page-orientation orientation) + ;; Return a string representing the Lout page orientation name for symbol + ;; `orientation'. + (let* ((alist '((portrait . "Portrait") + (landscape . "Landscape") + (reverse-portrait . "ReversePortrait") + (reverse-landscape . "ReverseLandscape"))) + (which (assoc orientation alist))) + (if (not which) + (skribe-error 'lout + "`page-orientation' should be either `portrait' or `landscape'" + orientation) + (cdr which)))) + + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :keywords :env) + :before (lambda (n e) ;; `e' is the engine + (let* ((doc-type (let ((d (engine-custom e 'document-type))) + (if (string? d) + (begin + (engine-custom-set! e 'document-type + (string->symbol d)) + (string->symbol d)) + d))) + (doc-style? (eq? doc-type 'doc)) + (slides? (eq? doc-type 'slides)) + (doc-include (engine-custom e 'document-include)) + (includes (engine-custom e 'includes)) + (font (engine-custom e 'initial-font)) + (lang (engine-custom e 'initial-language)) + (break (engine-custom e 'initial-break)) + (column-number (engine-custom e 'column-number)) + (first-page-number (engine-custom e 'first-page-number)) + (page-orientation (engine-custom e 'page-orientation)) + (title (markup-option n :title))) + + ;; Add this markup option, used by + ;; `lout-start-large-scale-structure' et al. + (markup-option-add! n '&substructs-started? #f) + + (if (eq? doc-include 'auto) + (case doc-type + ((report) (display "@SysInclude { report }\n")) + ((book) (display "@SysInclude { book }\n")) + ((doc) (display "@SysInclude { doc }\n")) + ((slides) (display "@SysInclude { slides }\n")) + (else (skribe-error + 'lout + "`document-type' should be one of `book', `report', `doc' or `slides'" + doc-type))) + (printf "# Custom document includes\n~a\n" doc-include)) + + (if includes + (printf "# Additional user includes\n~a\n" includes) + (display "@SysInclude { tbl }\n")) + + ;; Write additional Lout definitions + (display (lout-definitions e)) + + (case doc-type + ((report) (display "@Report\n")) + ((book) (display "@Book\n")) + ((doc) (display "@Document\n")) + ((slides) (display "@OverheadTransparencies\n"))) + + (display (string-append " @InitialSpace { tex } " + "# avoid having too many spaces\n")) + + ;; The `doc' style doesn't have @Title, @Author and the likes + (if (not doc-style?) + (begin + (display " @Title { ") + (if title + (output title e) + (display "The Lout-Skribe Book")) + (display " }\n") + + ;; The author + (let* ((author (markup-option n :author))) + + (display " @Author { ") + (output author e) + (display " }\n") + + ;; Lout reports support `@Institution' while books + ;; don't. + (if (and (eq? doc-type 'report) + (is-markup? author 'author)) + (let ((institution (markup-option author + :affiliation))) + (if institution + (begin + (printf " @Institution { ") + (output institution e) + (printf " }\n")))))))) + + ;; Lout reports make it possible to choose whether to prepend + ;; a cover sheet (books and docs don't). Same for a date + ;; line. + (if (eq? doc-type 'report) + (let ((cover-sheet? (engine-custom e 'cover-sheet?)) + (date-line (engine-custom e 'date-line)) + (abstract (engine-custom e 'abstract)) + (abstract-title (engine-custom e 'abstract-title))) + (display (string-append " @CoverSheet { " + (if cover-sheet? + "Yes" "No") + " }\n")) + (display " @DateLine { ") + (if (string? date-line) + (output date-line e) + (display (if date-line "Yes" "No"))) + (display " }\n") + + (if abstract + (begin + (if (not (eq? abstract-title #t)) + (begin + (display " @AbstractTitle { ") + (cond + ((not abstract-title) #t) + (else (output abstract-title e))) + (display " }\n"))) + + (display " @Abstract {\n") + (output abstract e) + (display "\n}\n"))))) + + (printf " @OptimizePages { ~a }\n" + (if (engine-custom e 'optimize-pages?) + "Yes" "No")) + + (printf " @InitialFont { ~a }\n" + (cond ((string? font) font) + ((symbol? font) + (string-append (symbol->string font) + " Base 10p")) + ((number? font) + (string-append "Palatino Base " + (number->string font) + "p")) + (#t + (skribe-error + 'lout 'initial-font + "Should be a Lout font name, a symbol, or a number")))) + (printf " @InitialBreak { ~a }\n" + (if break break "adjust 1.2fx hyphen")) + (if (not slides?) + (printf " @ColumnNumber { ~a }\n" + (if (number? column-number) + column-number 1))) + (printf " @FirstPageNumber { ~a }\n" + (if (number? first-page-number) + first-page-number 1)) + (printf " @PageOrientation { ~a }\n" + (lout-page-orientation page-orientation)) + (printf " @InitialLanguage { ~a }\n" + (if lang lang "English")) + + ;; FIXME: Insert a preface for text preceding the first ch. + ;; FIXME: Create an @Introduction for the first chapter + ;; if its title is "Introduction" (for books). + + (display "//\n\n") + + (if doc-style? + ;; `doc' documents don't have @Title and the likes so + ;; we need to implement them "by hand" + (let ((make-cover-sheet + (engine-custom e 'doc-cover-sheet-proc))) + (display "@Text @Begin\n") + (if make-cover-sheet + (make-cover-sheet n e) + (lout-make-doc-cover-sheet n e)))) + + (if doc-style? + ;; Putting it here will only work with `doc' documents. + (lout-output-pdf-meta-info n e)))) + + :after (lambda (n e) + (let ((doc-type (engine-custom e 'document-type))) + (if (eq? doc-type 'doc) + (begin + (if (markup-option n '&substructs-started?) + (display "\n@EndSections\n")) + (display "\n@End @Text\n"))) + (display "\n\n# Lout document ends here.\n")))) + + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address + :phone :photo :align) + + :action (lambda (n e) + (let ((doc-type (engine-custom e 'document-type)) + (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)) + (photo (markup-option n :photo))) + + (define (row x) + (display "\n//1.5fx\n@Center { ") + (output x e) + (display " }\n")) + + (if email + (row (list (if name name "") + (! " <@I{") + (cond ((string? email) email) + ((markup? email) + (markup-body email)) + (#t "")) + (! "}> "))) + (if name (row name))) + + (if title (row title)) + + ;; In reports, the affiliation is passed to `@Institution'. + ;; However, books do not have an `@Institution' parameter. + (if (and affiliation (not (eq? doc-type 'report))) + (row affiliation)) + + (if address (row address)) + (if phone (row phone)) + (if url (row (it url))) + (if photo (row photo))))) + + +(define (lout-toc-entry node depth engine) + ;; Produce a TOC entry of depth `depth' (a integer greater than or equal to + ;; zero) for `node' using engine `engine'. The Lout code here is mostly + ;; copied from Lout's `dsf' (see definition of `@Item'). + (let ((ident (markup-ident node)) + (entry-proc (engine-custom engine 'toc-entry-proc))) + (if (markup-option node :toc) + (begin + (display "@LP\n") + (if ident + ;; create an internal for PDF navigation + (printf "{ ~a } @LinkSource { " (lout-tagify ident))) + + (if (> depth 0) + (printf "|~as " (number->string (* 6 depth)))) + (display " @HExpand { ") + + ;; output the number and title of this node + (entry-proc node engine) + + (display " &1rt @OneCol { ") + (printf " @SkribiloLeaders & @PageOf { ~a }" + (lout-tagify (markup-ident node))) + (display " &0io } }") + + (if ident (display " }")) + (display "\n"))))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options '(:class :chapter :section :subsection) + :action (lambda (n e) + (display "\n# toc\n") + (if (markup-option n :chapter) + (let ((chapters (filter (lambda (n) + (or (is-markup? n 'chapter) + (is-markup? n 'slide))) + (markup-body (ast-document n))))) + (for-each (lambda (c) + (let ((sections + (search-down (lambda (n) + (is-markup? n 'section)) + c))) + (lout-toc-entry c 0 e) + (if (markup-option n :section) + (for-each + (lambda (s) + (lout-toc-entry s 1 e) + (if (markup-option n :subsection) + (let ((subs + (search-down + (lambda (n) + (is-markup? + n 'subsection)) + s))) + (for-each + (lambda (s) + (lout-toc-entry s 2 e)) + subs)))) + sections)))) + chapters))))) + +(define lout-book-markup-alist + '((chapter . "Chapter") + (section . "Section") + (subsection . "SubSection") + (subsubsection . "SubSubSection"))) + +(define lout-report-markup-alist + '((chapter . "Section") + (section . "SubSection") + (subsection . "SubSubSection") + (subsubsection . #f))) + +(define lout-slides-markup-alist + '((slide . "Overhead"))) + +(define lout-doc-markup-alist lout-report-markup-alist) + +(define (lout-structure-markup skribe-markup engine) + ;; Return the Lout structure name for `skribe-markup' (eg. "Chapter" for + ;; `chapter' markups when `engine''s document type is `book'). + (let ((doc-type (engine-custom engine 'document-type)) + (assoc-ref (lambda (alist key) + (and-let* ((as (assoc key alist))) (cdr as))))) + (case doc-type + ((book) (assoc-ref lout-book-markup-alist skribe-markup)) + ((report) (assoc-ref lout-report-markup-alist skribe-markup)) + ((doc) (assoc-ref lout-doc-markup-alist skribe-markup)) + ((slides) (assoc-ref lout-slides-markup-alist skribe-markup)) + (else + (skribe-error 'lout + "`document-type' should be one of `book', `report', `doc' or `slides'" + doc-type))))) + +(define-public (lout-structure-number-string markup) + ;; Return a structure number string such as "1.2". + ;; FIXME: External code has started to rely on this. This should be + ;; generalized and moved elsewhere. + (let loop ((struct markup)) + (if (document? struct) + "" + (let ((parent-num (loop (ast-parent struct))) + (num (markup-option struct :number))) + (string-append parent-num + (if (string=? "" parent-num) "" ".") + (if (number? num) (number->string num) "")))))) + +;*---------------------------------------------------------------------*/ +;* lout-block-before ... */ +;*---------------------------------------------------------------------*/ +(define (lout-block-before n e) + ;; Produce the Lout code that introduces node `n', a large-scale + ;; structure (chapter, section, etc.). + (let ((lout-markup (lout-structure-markup (markup-markup n) e)) + (title (markup-option n :title)) + (number (markup-option n :number)) + (ident (markup-ident n))) + + (if (not lout-markup) + (begin + ;; the fallback method (i.e. when there exists no equivalent + ;; Lout markup) + (display "\n//1.8vx\n@B { ") + (output title e) + (display " }\n@SkribeMark { ") + (display (lout-tagify ident)) + (display " }\n//0.8vx\n\n")) + (begin + (printf "\n@~a\n @Title { " lout-markup) + (output title e) + (printf " }\n") + + (if (number? number) + (printf " @BypassNumber { ~a }\n" + (lout-structure-number-string n)) + (if (not number) + ;; this trick hides the section number + (printf " @BypassNumber { } # unnumbered\n"))) + + (cond ((string? ident) + (begin + (display " @Tag { ") + (display (lout-tagify ident)) + (display " }\n"))) + ((symbol? ident) + (begin + (display " @Tag { ") + (display (lout-tagify (symbol->string ident))) + (display " }\n"))) + (#t + (skribe-error 'lout + "Node identifiers should be strings" + ident))) + + (display "\n@Begin\n"))))) + +(define (lout-block-after n e) + ;; Produce the Lout code that terminates node `n', a large-scale + ;; structure (chapter, section, etc.). + (let ((lout-markup (lout-structure-markup (markup-markup n) e))) + (if (not lout-markup) + (printf "\n\n//0.3vx\n\n") ;; fallback method + (printf "\n\n@End @~a\n\n" lout-markup)))) + + +(define (lout-markup-child-type skribe-markup) + ;; Return the child markup type of `skribe-markup' (e.g. for `chapter', + ;; return `section'). + (let loop ((structs '(document chapter section subsection subsubsection))) + (if (null? structs) + #f + (if (eq? (car structs) skribe-markup) + (cadr structs) + (loop (cdr structs)))))) + +(define (lout-start-large-scale-structure markup engine) + ;; Perform the necessary step and produce output as a result of starting + ;; large-scale structure `markup' (ie. a chapter, section, subsection, + ;; etc.). + (let* ((doc-type (engine-custom engine 'document-type)) + (doc-style? (eq? doc-type 'doc)) + (parent (ast-parent markup)) + (markup-type (markup-markup markup)) + (lout-markup-name (lout-structure-markup markup-type + engine))) + (lout-debug "start-struct: markup=~a parent=~a" + markup parent) + + ;; add an `&substructs-started?' option to the markup + (markup-option-add! markup '&substructs-started? #f) + + (if (and lout-markup-name + parent (or doc-style? (not (document? parent)))) + (begin + (if (not (markup-option parent '&substructs-started?)) + ;; produce an `@BeginSubSections' or equivalent; `doc'-style + ;; documents need to preprend an `@BeginSections' before the + ;; first section while other styles don't. + (printf "\n@Begin~as\n" lout-markup-name)) + + ;; FIXME: We need to make sure that PARENT is a large-scale + ;; structure, otherwise it won't have the `&substructs-started?' + ;; option (e.g., if PARENT is a `color' markup). I need to clarify + ;; this. + (if (memq (markup-markup parent) + '(document chapter section subsection subsubsection)) + ;; update the `&substructs-started?' option of the parent + (markup-option-set! parent '&substructs-started? #t)) + + (lout-debug "start-struct: updated parent: ~a" + (markup-option parent '&substructs-started?)))) + + ;; output the `@Section @Title { ... } @Begin' thing + (lout-block-before markup engine))) + +(define (lout-end-large-scale-structure markup engine) + ;; Produce Lout code for ending structure `markup' (a chapter, section, + ;; subsection, etc.). + (let* ((doc-type (engine-custom engine 'document-type)) + (doc-style? (eq? doc-type 'doc)) + (markup-type (markup-markup markup)) + (lout-markup-name (lout-structure-markup markup-type + engine))) + + (if (and lout-markup-name + (markup-option markup '&substructs-started?) + (or doc-style? (not (document? markup)))) + (begin + ;; produce an `@EndSubSections' or equivalent; `doc'-style + ;; documents need to issue an `@EndSections' after the last section + ;; while other types of documents don't. + (lout-debug "end-struct: closing substructs for ~a" markup) + (printf "\n@End~as\n" + (lout-structure-markup (lout-markup-child-type markup-type) + engine)) + (markup-option-set! markup '&substructs-started? #f))) + + (lout-block-after markup engine))) + + +;*---------------------------------------------------------------------*/ +;* section ... .. @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (document? (ast-parent n))) + + :before (lambda (n e) + (lout-start-large-scale-structure n e) + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* section ... . @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'chapter)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'section)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'subsection)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :options '() + :validate (lambda (n e) + (or (eq? 'doc (engine-custom e 'document-type)) + (memq (and (markup? (ast-parent n)) + (markup-markup (ast-parent n))) + '(chapter section subsection subsubsection slide)))) + :before (lambda (n e) + (let ((gap (engine-custom e 'paragraph-gap))) + (display (if (string? gap) gap "\n@PP\n"))))) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:label) + :before (lambda (n e) + (let ((label (markup-option n :label)) + (use-number? + (engine-custom e 'use-skribe-footnote-numbers?))) + (if (or (and (number? label) use-number?) label) + (printf "{ @FootNote @Label { ~a } { " + (if label label "")) + (printf "{ @FootNote ~a{ " + (if (not number) "@Label { } " ""))))) + :after (lambda (n e) + (display " } }"))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :action (lambda (n e) + (display "\n@LP\n"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '() + :action "\n@LP\n@FullWidthRule\n@LP\n") + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:fg :bg :width) + ;; FIXME: `:bg' not supported + ;; FIXME: `:width' is not supported either. Rather use `frame' for that + ;; kind of options. + :before (lambda (n e) + (let* ((w (markup-option n :width)) + (fg (markup-option n :fg))) + (printf "{ ~a } @Color { " (lout-color-specification fg)))) + + :after (lambda (n e) + (display " }"))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + ;; @Box won't span over several pages so this may cause + ;; problems if large frames are used. The workaround here consists + ;; in using an @Tbl with one single cell. + :options '(:width :border :margin :bg) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (margin (markup-option n :margin)) + (border (markup-option n :border)) + (bg (markup-option n :bg))) + + ;; The user manual seems to expect `frame' to imply a + ;; linebreak. However, the LaTeX engine doesn't seem to + ;; agree. + ;(display "\n@LP") + (printf (string-append "\n@Tbl # frame\n" + " rule { yes }\n")) + (if border (printf " rulewidth { ~a }\n" + (lout-width border))) + (if width (printf " width { ~a }\n" + (lout-width width))) + (if margin (printf " margin { ~a }\n" + (lout-width margin))) + (if bg (printf " paint { ~a }\n" + (lout-color-specification bg))) + (display "{ @Row format { @Cell A } A { ")) + +; (printf "\n@Box linewidth { ~a } margin { ~a } { " +; (lout-width (markup-option n :width)) +; (lout-width (markup-option n :margin))) + ) + :after (lambda (n e) + (display " } }\n"))) + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size :face) + :before (lambda (n e) + (let ((face (markup-option n :face)) + (size (lout-font-size (markup-option n :size)))) + (printf "\n~a @Font { " size))) + :after (lambda (n e) + (display " }\n"))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (display "\n@LP") + (case (markup-option n :side) + ((center) + (display "\n@Center { # flush-center\n")) + ((left) + (display "\n# flush-left\n")) + ((right) + (display (string-append "\n@Right " + "{ rragged hyphen } @Break " + "{ # flush-right\n"))))) + :after (lambda (n e) + (case (markup-option n :side) + ((left) + (display "")) + (else + (display "\n}"))) + (display " # flush\n"))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + ;; Note: We prepend and append a newline in order to make sure + ;; things work as expected. + :before "\n@LP\n@Center {" + :after "}\n@LP\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre + :before "\n@LP lines @Break lout @Space { # pre\n" + :after "\n} # pre\n") + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before "\nlines @Break lout @Space {\n" + :after "\n} # @Break\n") + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +;; Program lines appear within a `lines @Break' block. +(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 (lambda (n e) + (let ((symbol (markup-option n :symbol))) + (if symbol + (begin + (display "\n@List style { ") + (output symbol e) + (display " } # itemize\n")) + (display "\n@BulletList # itemize\n")))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before (lambda (n e) + (let ((symbol (markup-option n :symbol))) + (if symbol + (printf "\n@List style { ~a } # enumerate\n" + symbol) + (display "\n@NumberedList # enumerate\n")))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) ;; `symbol' doesn't make sense here + :before "\n@TaggedList # description\n" + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (display "@DropTagItem { ") + (for-each (lambda (i) + (output i e) + (display " ")) + (if (pair? k) k (list k))) + (display " } { ") + (output (markup-body item) e) + (display " }\n"))) + (markup-body n))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :before "\n@LI { " + :after " }") + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :before "\n@ID {" + :after "\n} # @ID\n") + +;*---------------------------------------------------------------------*/ +;* 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 "\n@Figure\n") + (display " @Tag { ") + (display (lout-tagify ident)) + (display " }\n") + (printf " @BypassNumber { ~a }\n" + (cond ((number? number) number) + ((not number) "") + (else number))) + (display " @InitialLanguage { ") + (display (engine-custom e 'initial-language)) + (display " }\n") + + (if legend + (begin + (lout-debug "figure: ~a, \"~a\"" ident legend) + (printf " @Caption { ") + (output legend e) + (printf " }\n"))) + (printf " @Location { ~a }\n" + (if mc? "PageTop" "ColTop")) + (printf "{\n") + (output (markup-body n) e))) + :after (lambda (n e) + (display "}\n"))) + + +;*---------------------------------------------------------------------*/ +;* lout-table-column-number ... */ +;* ------------------------------------------------------------- */ +;* This function computes how columns are contained by the table. */ +;*---------------------------------------------------------------------*/ +(define (lout-table-column-number t) + (define (row-columns row) + (let loop ((cells (markup-body row)) + (nbcols 0)) + (if (null? cells) + nbcols + (loop (cdr cells) + (+ nbcols (markup-option (car cells) :colspan)))))) + (let loop ((rows (markup-body t)) + (nbcols 0)) + (if (null? rows) + nbcols + (loop (cdr rows) + (max (row-columns (car rows)) nbcols))))) + +(define (lout-table-cell-indent align) + ;; Return the Lout name (a string) for cell alignment `align' (a symbol). + (case align + ((center #f #t) "ctr") + ((right) "right") + ((left) "left") + (else (skribe-error 'td align + "Unknown alignment type")))) + +(define (lout-table-cell-vindent align) + ;; Return the Lout name (a string) for cell alignment `align' (a symbol). + (case align + ((center #f #t) "ctr") + ((top) "top") + ((bottom) "foot") + (else (skribe-error 'td align + "Unknown alignment type")))) + +(define (lout-table-cell-vspan cell-letter row-vspan) + ;; Return the vspan information (an alist) for the cell whose + ;; letter is `cell-letter', within the row whose vspan information + ;; is given by `row-vspan'. If the given cell doesn't span over + ;; rows, then #f is returned. + (and-let* ((as (assoc cell-letter row-vspan))) + (cdr as))) + +(define (lout-table-cell-vspan-start? vspan-alist) + ;; For the cell whose vspan information is given by `vspan-alist', + ;; return #t if that cell starts spanning vertically. + (and vspan-alist + (cdr (assoc 'start? vspan-alist)))) + +(define-macro (char+int c i) + `(integer->char (+ ,i (char->integer ,c)))) + +(define-macro (-- i) + `(- ,i 1)) + + +(define (lout-table-cell-option-string cell) + ;; Return the Lout cell option string for `cell'. + (let ((align (markup-option cell :align)) + (valign (markup-option cell :valign)) + (width (markup-option cell :width)) + (bg (markup-option cell :bg))) + (string-append (lout-table-cell-rules cell) " " + (string-append + "indent { " + (lout-table-cell-indent align) + " } ") + (string-append + "indentvertical { " + (lout-table-cell-vindent valign) + " } ") + (if (not width) "" + (string-append "width { " + (lout-width width) + " } ")) + (if (not bg) "" + (string-append "paint { " + (lout-color-specification bg) + " } "))))) + +(define (lout-table-cell-format-string cell vspan-alist) + ;; Return a Lout cell format string for `cell'. It uses the `&cell-name' + ;; markup option of its cell as its Lout cell name and `vspan-alist' as the + ;; source of information regarding its vertical spanning (#f means that + ;; `cell' is not vertically spanned). + (let ((cell-letter (markup-option cell '&cell-name)) + (cell-options (lout-table-cell-option-string cell)) + (colspan (if vspan-alist + (cdr (assoc 'hspan vspan-alist)) + (markup-option cell :colspan))) + (vspan-start? (and vspan-alist + (cdr (assoc 'start? vspan-alist))))) + (if (and (not vspan-start?) vspan-alist) + "@VSpan" + (let* ((cell-fmt (string-append "@Cell " cell-options + (string cell-letter)))) + (string-append + (if (> colspan 1) + (string-append (if (and vspan-start? vspan-alist) + "@StartHVSpan " "@StartHSpan ") + cell-fmt + (let pool ((cnt (- colspan 1)) + (span-cells "")) + (if (= cnt 0) + span-cells + (pool (- cnt 1) + (string-append span-cells + " | @HSpan"))))) + (string-append (if (and vspan-alist vspan-start?) + "@StartVSpan " "") + cell-fmt))))))) + + +(define (lout-table-row-format-string row) + ;; Return a Lout row format string for row `row'. It uses the `&cell-name' + ;; markup option of its cell as its Lout cell name. + + ;; FIXME: This function has become quite ugly + (let ((cells (markup-body row)) + (row-vspan (markup-option row '&vspan-alist))) + + (let loop ((cells cells) + (cell-letter #\A) + (delim "") + (fmt "")) + (lout-debug "looping on cell ~a" cell-letter) + + (if (null? cells) + + ;; The final `|' prevents the rightmost column to be + ;; expanded to full page width (see sect. 6.11, p. 133). + (if row-vspan + ;; In the end, there can be vspan columns left so we need to + ;; mark them + (let final-loop ((cell-letter cell-letter) + (fmt fmt)) + (let* ((cell-vspan (lout-table-cell-vspan cell-letter + row-vspan)) + (hspan (if cell-vspan + (cdr (assoc 'hspan cell-vspan)) + 1))) + (lout-debug "final-loop: ~a ~a" cell-letter cell-vspan) + (if (not cell-vspan) + (string-append fmt " |") + (final-loop (integer->char + (+ hspan (char->integer cell-letter))) + (string-append fmt " | @VSpan |"))))) + + (string-append fmt " |")) + + (let* ((cell (car cells)) + (vspan-alist (lout-table-cell-vspan cell-letter row-vspan)) + (vspan-start? (lout-table-cell-vspan-start? vspan-alist)) + (colspan (if vspan-alist + (cdr (assoc 'hspan vspan-alist)) + (markup-option cell :colspan))) + (cell-format + (lout-table-cell-format-string cell vspan-alist))) + + (loop (if (or (not vspan-alist) vspan-start?) + (cdr cells) + cells) ;; don't skip pure vspan cells + + ;; next cell name + (char+int cell-letter colspan) + + " | " ;; the cell delimiter + (string-append fmt delim cell-format))))))) + + + +;; A row vspan alist describes the cells of a row that span vertically +;; and it looks like this: +;; +;; ((#\A . ((start? . #t) (hspan . 1) (vspan . 3))) +;; (#\C . ((start? . #f) (hspan . 2) (vspan . 1)))) +;; +;; which means that cell `A' start spanning vertically over three rows +;; including this one, while cell `C' is an "empty" cell that continues +;; the vertical spanning of a cell appearing on some previous row. +;; +;; The running "global" (or "table-wide") vspan alist looks the same +;; except that it doesn't have the `start?' tags. + +(define (lout-table-compute-row-vspan-alist row global-vspan-alist) + ;; Compute the vspan alist of row `row' based on the current table vspan + ;; alist `global-vspan-alist'. As a side effect, this function stores the + ;; Lout cell name (a character between #\A and #\Z) as the value of markup + ;; option `&cell-name' of each cell. + (if (pair? (markup-body row)) + ;; Mark the first cell as such. + (markup-option-add! (car (markup-body row)) '&first-cell? #t)) + + (let cell-loop ((cells (markup-body row)) + (cell-letter #\A) + (row-vspan-alist '())) + (lout-debug "cell: ~a ~a" cell-letter + (if (null? cells) '() (car cells))) + + (if (null? cells) + + ;; In the end, we must retain any vspan cell that occurs after the + ;; current cell name (note: we must add a `start?' tag at this point + ;; since the global table vspan alist doesn't have that). + (let ((additional-cells (filter (lambda (c) + (char>=? (car c) cell-letter)) + global-vspan-alist))) + (lout-debug "compute-row-vspan-alist returning: ~a + ~a (~a)" + row-vspan-alist additional-cells + (length global-vspan-alist)) + (append row-vspan-alist + (map (lambda (c) + `(,(car c) . ,(cons '(start? . #f) (cdr c)))) + additional-cells))) + + (let* ((current-cell-vspan (assoc cell-letter global-vspan-alist)) + (hspan (if current-cell-vspan + (cdr (assoc 'hspan (cdr current-cell-vspan))) + (markup-option (car cells) :colspan)))) + + (if (null? (cdr cells)) + ;; Mark the last cell as such + (markup-option-add! (car cells) '&last-cell? #t)) + + (cell-loop (if current-cell-vspan + cells ;; this cell is vspanned, so don't skip it + (cdr cells)) + + ;; next cell name + (char+int cell-letter (or hspan 1)) + + (begin ;; updating the row vspan alist + (lout-debug "cells: ~a" (length cells)) + (lout-debug "current-cell-vspan for ~a: ~a" + cell-letter current-cell-vspan) + + (if current-cell-vspan + + ;; this cell is currently vspanned, ie. a previous + ;; row defined a vspan for it and that it is still + ;; spanning on this row + (cons `(,cell-letter + . ((start? . #f) + (hspan . ,(cdr + (assoc + 'hspan + (cdr current-cell-vspan)))))) + row-vspan-alist) + + ;; this cell is not currently vspanned + (let ((vspan (markup-option (car cells) :rowspan))) + (lout-debug "vspan-option for ~a: ~a" + cell-letter vspan) + + (markup-option-add! (car cells) + '&cell-name cell-letter) + (if (and vspan (> vspan 1)) + (cons `(,cell-letter . ((start? . #t) + (hspan . ,hspan) + (vspan . ,vspan))) + row-vspan-alist) + row-vspan-alist))))))))) + +(define (lout-table-update-table-vspan-alist table-vspan-alist + row-vspan-alist) + ;; Update `table-vspan-alist' based on `row-vspan-alist', the alist + ;; representing vspan cells for the last row that has been read." + (lout-debug "update-table-vspan: ~a and ~a" + table-vspan-alist row-vspan-alist) + + (let ((new-vspan-cells (filter (lambda (cell) + (cdr (assoc 'start? (cdr cell)))) + row-vspan-alist))) + + ;; Append the list of new vspan cells described in `row-vspan-alist' + (let loop ((cells (append table-vspan-alist new-vspan-cells)) + (result '())) + (if (null? cells) + (begin + (lout-debug "update-table-vspan returning: ~a" result) + result) + (let* ((cell (car cells)) + (cell-letter (car cell)) + (cell-hspan (cdr (assoc 'hspan (cdr cell)))) + (cell-vspan (-- (cdr (assoc 'vspan (cdr cell)))))) + (loop (cdr cells) + (if (> cell-vspan 0) + + ;; Keep information about this vspanned cell + (cons `(,cell-letter . ((hspan . ,cell-hspan) + (vspan . ,cell-vspan))) + result) + + ;; Vspan for this cell has been done so we can remove + ;; it from the running table vspan alist + result))))))) + +(define (lout-table-mark-vspan! tab) + ;; Traverse the rows of table `tab' and add them an `&vspan-alist' option + ;; that describes which of its cells are to be vertically spanned. + (let loop ((rows (markup-body tab)) + (global-vspan-alist '())) + (if (null? rows) + + ;; At this point, each row holds its own vspan information alist (the + ;; `&vspan-alist' option) so we don't care anymore about the running + ;; table vspan alist + #t + + (let* ((row (car rows)) + (row-vspan-alist (lout-table-compute-row-vspan-alist + row global-vspan-alist))) + + ;; Bind the row-specific vspan information to the row object + (markup-option-add! row '&vspan-alist row-vspan-alist) + + (if (null? (cdr rows)) + ;; Mark the last row as such + (markup-option-add! row '&last-row? #t)) + + (loop (cdr rows) + (lout-table-update-table-vspan-alist global-vspan-alist + row-vspan-alist)))))) + +(define (lout-table-first-row? row) + (markup-option row '&first-row?)) + +(define (lout-table-last-row? row) + (markup-option row '&last-row?)) + +(define (lout-table-first-cell? cell) + (markup-option cell '&first-cell?)) + +(define (lout-table-last-cell? cell) + (markup-option cell '&last-cell?)) + +(define (lout-table-row-rules row) + ;; Return a string representing the Lout option string for + ;; displaying rules of `row'. + (let* ((table (ast-parent row)) + (frames (markup-option table :frame)) + (rules (markup-option table :rules)) + (first? (lout-table-first-row? row)) + (last? (lout-table-last-row? row))) + (string-append (if (and first? + (member frames '(above hsides box border))) + "ruleabove { yes } " "") + (if (and last? + (member frames '(below hsides box border))) + "rulebelow { yes } " "") + ;; rules + (case rules + ((header) + ;; We consider the first row to be a header row. + (if first? "rulebelow { yes }" "")) + ((rows all) + ;; We use redundant rules because coloring + ;; might make them disappear otherwise. + (string-append (if first? "" "ruleabove { yes } ") + (if last? "" "rulebelow { yes }"))) + (else ""))))) + +(define (lout-table-cell-rules cell) + ;; Return a string representing the Lout option string for + ;; displaying rules of `cell'. + (let* ((row (ast-parent cell)) + (table (ast-parent row)) + (frames (markup-option table :frame)) + (rules (markup-option table :rules)) + (first? (lout-table-first-cell? cell)) + (last? (lout-table-last-cell? cell))) + (string-append (if (and first? + (member frames '(vsides lhs box border))) + "ruleleft { yes } " "") + (if (and last? + (member frames '(vsides rhs box border))) + "ruleright { yes } " "") + ;; rules + (case rules + ((cols all) + ;; We use redundant rules because coloring + ;; might make them disappear otherwise. + (string-append (if last? "" "ruleright { yes } ") + (if first? "" "ruleleft { yes }"))) + (else ""))))) + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:frame :rules :border :width :cellpadding) + ;; XXX: `:cellstyle' `separate' and `:cellspacing' not supported + ;; by Lout's @Tbl. + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (cp (markup-option n :cellpadding)) + (rows (markup-body n))) + + (define (cell-width row col) + (let ((cells (markup-body row)) + (bg (markup-option row :bg))) + (let loop ((cells cells) + (c 0)) + (if (pair? cells) + (let* ((ce (car cells)) + (width (markup-option ce :width)) + (colspan (markup-option ce :colspan))) + (if (= col c) + (if (number? width) width 0) + (loop (cdr cells) (+ c colspan)))) + 0)))) + + (define (col-width col) + (let loop ((rows rows) + (width 0)) + (if (null? rows) + (if (= width 0) + 0 + width) + (loop (cdr rows) + (max width (cell-width (car rows) col)))))) + + (if (pair? (markup-body n)) + ;; Mark the first row as such + (markup-option-add! (car (markup-body n)) + '&first-row? #t)) + + ;; Mark each row with vertical spanning information + (lout-table-mark-vspan! n) + + (display "\n@Tbl # table\n") + + (if (number? border) + (printf " rulewidth { ~a }\n" + (lout-width (markup-option n :border)))) + (if (number? cp) + (printf " margin { ~ap }\n" + (number->string cp))) + + (display "{\n"))) + + :after (lambda (n e) + (let ((header-rows (or (markup-option n '&header-rows) 0))) + ;; Issue an `@EndHeaderRow' symbol for each `@HeaderRow' symbol + ;; previously produced. + (let ((cnt header-rows)) + (if (> cnt 0) + (display "\n@EndHeaderRow")))) + + (display "\n} # @Tbl\n"))) + +;*---------------------------------------------------------------------*/ +;* 'tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '(:bg) + :action (lambda (row e) + (let* ((bg (markup-option row :bg)) + (bg-color (if (not bg) "" + (string-append + "paint { " + (lout-color-specification bg) " } "))) + (first-row? (markup-option row '&first-row?)) + (header-row? (any (lambda (n) + (eq? (markup-option n 'markup) + 'th)) + (markup-body row))) + (fmt (lout-table-row-format-string row)) + (rules (lout-table-row-rules row))) + + ;; Use `@FirstRow' and `@HeaderFirstRow' for the first + ;; row. `@HeaderFirstRow' seems to be buggy though. + ;; (see section 6.1, p.119 of the User's Guide). + + (printf "\n@~aRow ~aformat { ~a }" + (if first-row? "First" "") + bg-color fmt) + (display (string-append " " rules)) + (output (markup-body row) e) + + (if (and header-row? (engine-custom e 'use-header-rows?)) + ;; `@HeaderRow' symbols are not actually printed + ;; (see section 6.11, p. 134 of the User's Guide) + ;; FIXME: This all seems buggy on the Lout side. + (let* ((tab (ast-parent row)) + (hrows (and (markup? tab) + (or (markup-option tab '&header-rows) + 0)))) + (if (not (is-markup? tab 'table)) + (skribe-error 'lout + "tr's parent not a table!" tab)) + (markup-option-add! tab '&header-rows (+ hrows 1)) + (printf "\n@Header~aRow ~aformat { ~a }" + "" ; (if first-row? "First" "") + bg-color fmt) + (display (string-append " " rules)) + + ;; the cells must be produced once here + (output (markup-body row) e)))))) + +;*---------------------------------------------------------------------*/ +;* tc */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(markup :width :align :valign :colspan :rowspan :bg) + :before (lambda (cell e) + (printf "\n ~a { " (markup-option cell '&cell-name))) + :after (lambda (cell e) + (display " }"))) + + +;*---------------------------------------------------------------------*/ +;* 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 url ;; maybe we should run `wget' then? :-) + (skribe-error 'lout "Image URLs not supported" url)) + (if (not (string? img)) + (skribe-error 'lout "Illegal image" file) + (begin + (if width + (printf "\n~a @Wide" (lout-width width))) + (if height + (printf "\n~a @High" (lout-width height))) + (if zoom + (printf "\n~a @Scale" zoom)) + (printf "\n@IncludeGraphic { \"~a\" }\n" img)))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +;; Each ornament is enclosed in braces to allow such things as +;; "he,(bold "ll")o" to work without adding an extra space. +(markup-writer 'roman :before "{ @R { " :after " } }") +(markup-writer 'underline :before "{ @Underline { " :after " } }") +(markup-writer 'code :before "{ @F { " :after " } }") +(markup-writer 'var :before "{ @F { " :after " } }") +(markup-writer 'sc :before "{ @S {" :after " } }") +(markup-writer 'sf :before "{ { Helvetica Base } @Font { " :after " } }") +(markup-writer 'sub :before "{ @Sub { " :after " } }") +(markup-writer 'sup :before "{ @Sup { " :after " } }") +(markup-writer 'tt :before "{ @F { " :after " } }") + + +;; `(bold (it ...))' and `(it (bold ...))' should both lead to `@BI { ... }' +;; instead of `@B { @I { ... } }' (which is different). +;; Unfortunately, it is not possible to use `ast-parent' and +;; `find1-up' to check whether `it' (resp. `bold') was invoked within +;; a `bold' (resp. `it') markup, hence the `&italics' and `&bold' +;; option trick. FIXME: This would be much more efficient if +;; `ast-parent' would work as expected. + +;; FIXME: See whether `@II' can be useful. Use SRFI-39 parameters. + +(markup-writer 'it + :before (lambda (node engine) + (let ((bold-children (search-down (lambda (n) + (is-markup? n 'bold)) + node))) + (map (lambda (b) + (markup-option-add! b '&italics #t)) + bold-children) + (printf "{ ~a { " + (if (markup-option node '&bold) + "@BI" "@I")))) + :after " } }") + +(markup-writer 'emph + :before (lambda (n e) + (invoke (writer-before (markup-writer-get 'it e)) + n e)) + :after (lambda (n e) + (invoke (writer-after (markup-writer-get 'it e)) + n e))) + +(markup-writer 'bold + :before (lambda (node engine) + (let ((it-children (search-down (lambda (n) + (or (is-markup? n 'it) + (is-markup? n 'emph))) + node))) + (map (lambda (i) + (markup-option-add! i '&bold #t)) + it-children) + (printf "{ ~a { " + (if (markup-option node '&italics) + "@BI" "@B")))) + :after " } }") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "{ @Char guillemotleft }\" \"" + :after "\" \"{ @Char guillemotright }") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :before " @I { " + :action (lambda (n e) + (let ((text (markup-option n :text))) + (output (or text (markup-body n)) e))) + :after " }") + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :action (lambda (n e) + (if (markup-ident n) + (begin + (display "{ @SkribeMark { ") + (display (lout-tagify (markup-ident n))) + (display " } }")) + (skribe-error 'lout "mark: Node has no identifier" n)))) + +(define (lout-page-of ident) + ;; Return a string for the `@PageOf' statement for `ident'. + (let ((tag (lout-tagify ident))) + (string-append ", { " tag " } @CrossLink { " + "p. @PageOf { " tag " } }"))) + + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection + :figure :mark :handle :ident :page) + :action (lambda (n e) + (let ((url (markup-option n :url)) + (text (markup-option n :text)) + (mark (markup-option n :mark)) + (handle (markup-option n :handle)) + (chapter (markup-option n :chapter)) + (section (markup-option n :section)) + (subsection (markup-option n :subsection)) + (subsubsection (markup-option n :subsubsection)) + (show-page-num? (markup-option n :page))) + + ;; A handle to the target is automagically passed + ;; as the body of each `ref' instance (see `api.scm'). + (let* ((target (handle-ast (markup-body n))) + (ident (markup-ident target)) + (title (markup-option target :title)) + (number (markup-option target :number))) + (lout-debug "ref: target=~a ident=~a" target ident) + (if text (output text e)) + + ;; Marks don't have a number + (if (eq? (markup-markup target) 'mark) + (printf (lout-page-of ident)) + (begin + ;; Don't output a section/whatever number + ;; when text is provided in order to be + ;; consistent with the HTML back-end. + ;; Sometimes (eg. for user-defined markups), + ;; we don't even know how to reference them + ;; anyway. + (if (not text) + (printf " @NumberOf { ~a }" + (lout-tagify ident))) + (if show-page-num? + (printf (lout-page-of ident))))))))) + + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let ((entry (handle-ast (markup-body n)))) + (output (markup-option entry :title) e))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + ;; When several references are passed. Strangely enough, the list of + ;; entries passed to this writer (as its body) contains both `bib-ref' and + ;; `bib-entry' objects, hence the `canonicalize-entry' function below. + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let* ((entries (markup-body n)) + (canonicalize-entry (lambda (x) + (cond + ((is-markup? x 'bib-entry) x) + ((is-markup? x 'bib-ref) + (handle-ast (markup-body x))) + (else + (skribe-error + 'lout + "bib-ref+: invalid entry type" + x))))) + (help-proc (lambda (proc) + (lambda (e1 e2) + (proc (canonicalize-entry e1) + (canonicalize-entry e2))))) + (sort-proc (engine-custom e 'bib-refs-sort-proc))) + (let loop ((rs (if sort-proc + (sort entries (help-proc sort-proc)) + entries))) + (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 ((url (markup-option n :url)) + (text (markup-option n :text)) + (transform (engine-custom e 'transform-url-ref-proc))) + (if (or (not transform) + (markup-option n '&transformed)) + (begin + (printf "{ \"~a\" @ExternalLink { " url) + (if text ;; FIXME: Should be (not (string-index text #\space)) + (output text e) + (let ((filter-url (make-string-replace + `((#\/ "\"/\"&-") + (#\. ".&-") + (#\- "&-") + (#\_ "_&-") + ,@lout-verbatim-encoding + (#\newline ""))))) + ;; Filter the URL in a way to give Lout hints on + ;; where hyphenation should take place. + (fprint (current-error-port) "Here!!!" filter-url) + (display (filter-url url) e))) + (printf " } }")) + (begin + (markup-option-add! n '&transformed #t) + (output (transform n) e)))))) + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before "{ @I {" ;; FIXME: Not tested + :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) + ;; Compute the length (in characters) of the longest entry label + ;; so that the label width of the list is adjusted. + (let loop ((entries (markup-body n)) + (label-width 0)) + (if (null? entries) + (begin + (display "\n# the-bibliography\n@LP\n") + ;; usually, the tag with be something like "[7]", hence + ;; the `+ 1' below (`[]' is narrower than 2f) + (printf "@TaggedList labelwidth { ~af }\n" + (+ 1 label-width))) + (loop (cdr entries) + (let ((entry-length + (let liip ((e (car entries))) + (cond + ((markup? e) + (cond ((is-markup? e '&bib-entry) + (liip (markup-option e :title))) + ((is-markup? e '&bib-entry-ident) + (liip (markup-option e 'number))) + (else + (liip (markup-body e))))) + ((string? e) + (string-length e)) + ((number? e) + (liip (number->string e))) + ((list? e) + (apply + (map liip e))) + (else 0))))) +; (fprint (current-error-port) +; "node=" (car entries) +; " body=" (markup-body (car entries)) +; " title=" (markup-option (car entries) +; :title) +; " len=" entry-length) + (if (> label-width entry-length) + label-width + entry-length)))))) + :after (lambda (n e) + (display "\n@EndList # the-bibliography (end)\n"))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :before "@TagItem " + :action (lambda (n e) + (display " { ") + (output n e (markup-writer-get '&bib-entry-label e)) + (display " } { ") + (output n e (markup-writer-get '&bib-entry-body e)) + (display " }")) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* &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 (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 " \"[\"" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "\"]\" ") + +;*---------------------------------------------------------------------*/ +;* &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 { ") ;; FIXME: Needs to be rewritten. + (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 " }") + (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-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-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :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)))) + + +;*---------------------------------------------------------------------*/ +;* Illustrations */ +;*---------------------------------------------------------------------*/ +(define-public (lout-illustration . args) + ;; FIXME: This should be a markup. + + ;; Introduce a Lout illustration (such as a diagram) whose code is either + ;; the body of `lout-illustration' or the contents of `file'. For engines + ;; other than Lout, an EPS file is produced and then converted if needed. + ;; The `:alt' option is equivalent to HTML's `alt' attribute for the `img' + ;; markup, i.e. it is passed as the body of the `image' markup for + ;; non-Lout back-ends. + + (define (file-contents file) + ;; Return the contents (a string) of file `file'. + (with-input-from-file file + (lambda () + (let loop ((contents "") + (line (read-line))) + (if (eof-object? line) + contents + (loop (string-append contents line "\n") + (read-line))))))) + + (define (illustration-header) + ;; Return a string denoting the header of a Lout illustration. + (let ((lout (find-engine 'lout))) + (string-append "@SysInclude { picture }\n" + (engine-custom lout 'includes) + "\n\n@Illustration\n" + " @InitialFont { " + (engine-custom lout 'initial-font) + " }\n" + " @InitialBreak { " + (engine-custom lout 'initial-break) + " }\n" + " @InitialLanguage { " + (engine-custom lout 'initial-language) + " }\n" + " @InitialSpace { tex }\n" + "{\n"))) + + (define (illustration-ending) + ;; Return a string denoting the end of a Lout illustration. + "\n}\n") + + (let* ((opts (the-options args '(file ident alt))) + (file* (assoc ':file opts)) + (ident* (assoc ':ident opts)) + (alt* (assoc ':alt opts)) + (file (and file* (cadr file*))) + (ident (and ident* (cadr ident*))) + (alt (or (and alt* (cadr alt*)) "An illustration"))) + + (let ((contents (if (not file) + (car (the-body args)) + (file-contents file)))) + (if (engine-format? "lout") + (! contents) ;; simply inline the illustration + (let* ((lout (find-engine 'lout)) + (output (string-append (or ident + (symbol->string + (gensym 'lout-illustration))) + ".eps")) + (port (open-output-pipe + (string-append (or (engine-custom lout + 'lout-program-name) + "lout") + " -o " output + " -EPS")))) + + ;; send the illustration to Lout's standard input + (display (illustration-header) port) + (display contents port) + (display (illustration-ending) port) + + (let ((exit-val (status:exit-val (close-pipe port)))) + (if (not (eqv? 0 exit-val)) + (skribe-error 'lout-illustration + "lout exited with error code" exit-val))) + + (if (not (file-exists? output)) + (skribe-error 'lout-illustration "file not created" + output)) + + (let ((file-info (false-if-exception (stat output)))) + (if (or (not file-info) + (= 0 (stat:size file-info))) + (skribe-error 'lout-illustration + "empty output file" output))) + + ;; the image (FIXME: Should set its location) + (image :file output alt)))))) + + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(pop-default-engine) + + +;; Local Variables: -- +;; mode: Scheme -- +;; coding: latin-1 -- +;; scheme-program-name: "guile" -- +;; End: -- diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm new file mode 100644 index 0000000..81e9f27 --- /dev/null +++ b/src/guile/skribilo/engine/xml.scm @@ -0,0 +1,115 @@ +;;; xml.scm -- Generic XML engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine 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/evaluator.scm b/src/guile/skribilo/evaluator.scm new file mode 100644 index 0000000..8502d51 --- /dev/null +++ b/src/guile/skribilo/evaluator.scm @@ -0,0 +1,203 @@ +;;; eval.scm -- Skribilo evaluator. +;;; +;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2005,2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo evaluator) + :export (evaluate-document evaluate-document-from-port + load-document include-document *load-options*) + :autoload (skribilo parameters) (*verbose* *document-path*) + :autoload (skribilo location) (<location>) + :autoload (skribilo ast) (ast? markup?) + :autoload (skribilo engine) (*current-engine* + engine? find-engine engine-ident) + :autoload (skribilo reader) (*document-reader*) + + :autoload (skribilo verify) (verify) + :autoload (skribilo resolve) (resolve!) + + :autoload (skribilo module) (*skribilo-user-module*)) + + +(use-modules (skribilo utils syntax) + (skribilo condition) + (skribilo debug) + (skribilo output) + (skribilo lib) + + (ice-9 optargs) + (oop goops) + (srfi srfi-1) + (srfi srfi-13) + (srfi srfi-34) + (srfi srfi-35) + (srfi srfi-39)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; %EVALUATE +;;; +(define (%evaluate expr) + ;; Evaluate EXPR, an arbitrary S-expression that may contain calls to the + ;; markup functions defined in a markup package such as + ;; `(skribilo package base)', e.g., `(bold "hello")'. + (let ((result (eval expr (*skribilo-user-module*)))) + + (if (ast? result) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (slot-set! result 'loc + (make <location> + :file file :line line :pos column)))) + + result)) + + + +;;; +;;; EVALUATE-DOCUMENT +;;; +(define* (evaluate-document a e :key (env '())) + ;; Argument A must denote an AST of something like that, not just an + ;; S-exp. + (with-debug 2 'evaluate-document + (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))))) + +;;; +;;; EVALUATE-DOCUMENT-FROM-PORT +;;; +(define* (evaluate-document-from-port port engine + :key (env '()) + (reader (*document-reader*))) + (with-debug 2 'evaluate-document-from-port + (debug-item "engine=" engine) + (debug-item "reader=" reader) + + (let ((e (if (symbol? engine) (find-engine engine) engine))) + (debug-item "e=" e) + (if (not (engine? e)) + (skribe-error 'evaluate-document-from-port "cannot find engine" engine) + (let loop ((exp (reader port))) + (with-debug 10 'evaluate-document-from-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (evaluate-document (%evaluate exp) e :env env) + (loop (reader port)))))))) + + +;;; +;;; LOAD-DOCUMENT +;;; + +;; Options that may make sense to a specific back-end or package. +(define-public *load-options* (make-parameter '())) + +;; List of the names of files already loaded. +(define *loaded-files* (make-parameter '())) + +(define* (load-document file :key (engine #f) (path #f) :allow-other-keys + :rest opt) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt=" opt) + + (let* ((ei (*current-engine*)) + (path (append (cond + ((not path) (*document-path*)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (raise (condition (&invalid-argument-error + (proc-name 'load-document) + (argument path))))) + (else path)) + %load-path)) + (filep (or (search-path path file) + (search-path (append path %load-path) file) + (search-path (append path %load-path) + (let ((dot (string-rindex file #\.))) + (if dot + (string-append + (string-take file dot) + ".scm") + file)))))) + + (unless (and (string? filep) (file-exists? filep)) + (raise (condition (&file-search-error + (file-name file) + (path path))))) + + ;; Pass the additional options to the back-end and/or packages being + ;; used. + (parameterize ((*load-options* opt)) + + ;; Load this file if not already done + ;; FIXME: Shouldn't we remove this logic? -- Ludo'. + (unless (member filep (*loaded-files*)) + (cond + ((> (*verbose*) 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> (*verbose*) 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + + ;; Load it + (with-input-from-file filep + (lambda () + (evaluate-document-from-port (current-input-port) ei))) + + (*loaded-files* (cons filep (*loaded-files*)))))))) + +;;; +;;; INCLUDE-DOCUMENT +;;; +(define* (include-document file :key (path (*document-path*)) + (reader (*document-reader*))) + (unless (every string? path) + (raise (condition (&invalid-argument-error (proc-name 'include-document) + (argument path))))) + + (let ((full-path (search-path path file))) + (unless (and (string? full-path) (file-exists? full-path)) + (raise (condition (&file-search-error + (file-name file) + (path path))))) + + (when (> (*verbose*) 0) + (format (current-error-port) " [including file: ~S]\n" full-path)) + + (with-input-from-file full-path + (lambda () + (let Loop ((exp (reader (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (reader (current-input-port)) + (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/index.scm b/src/guile/skribilo/index.scm new file mode 100644 index 0000000..33f8d15 --- /dev/null +++ b/src/guile/skribilo/index.scm @@ -0,0 +1,170 @@ +;;; index.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo index) + :use-syntax (skribilo utils syntax) + :use-syntax (skribilo lib) + + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (srfi srfi-39) + + ;; XXX: The use of `mark' here introduces a cross-dependency between + ;; `index' and `package base'. Thus, we require that each of these two + ;; modules autoloads the other one. + :autoload (skribilo package base) (mark) + + :export (index? make-index-table *index-table* + default-index resolve-the-index)) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of functions dealing with the creation of indices in +;;; documents. +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `index.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* index? ... */ +;*---------------------------------------------------------------------*/ +(define (index? obj) + (hash-table? obj)) + +;*---------------------------------------------------------------------*/ +;* *index-table* ... */ +;*---------------------------------------------------------------------*/ +(define *index-table* (make-parameter #f)) + +;*---------------------------------------------------------------------*/ +;* make-index-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-index-table ident) + (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* default-index ... */ +;*---------------------------------------------------------------------*/ +(define (default-index) + (if (not (*index-table*)) + (*index-table* (make-index-table "default-index"))) + (*index-table*)) + +;*---------------------------------------------------------------------*/ +;* resolve-the-index ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-index loc i c indexes split char-offset header-limit col) + ;; fetch the descriminating index name letter + (define (index-ref n) + (let ((name (markup-option n 'name))) + (if (>= char-offset (string-length name)) + (skribe-error 'the-index "char-offset out of bound" char-offset) + (string-ref name char-offset)))) + ;; sort a bucket of entries (the entries in a bucket share there name) + (define (sort-entries-bucket ie) + (sort ie + (lambda (i1 i2) + (or (not (markup-option i1 :note)) + (markup-option i2 :note))))) + ;; accumulate all the entries starting with the same letter + (define (letter-references refs) + (let ((letter (index-ref (car (car refs))))) + (let loop ((refs refs) + (acc '())) + (if (or (null? refs) + (not (char-ci=? letter (index-ref (car (car refs)))))) + (values (char-upcase letter) acc refs) + (loop (cdr refs) (cons (car refs) acc)))))) + ;; merge the buckets that comes from different index tables + (define (merge-buckets buckets) + (if (null? buckets) + '() + (let loop ((buckets buckets) + (res '())) + (cond + ((null? (cdr buckets)) + (reverse! (cons (car buckets) res))) + ((string=? (markup-option (car (car buckets)) 'name) + (markup-option (car (cadr buckets)) 'name)) + ;; we merge + (loop (cons (append (car buckets) (cadr buckets)) + (cddr buckets)) + res)) + (else + (loop (cdr buckets) + (cons (car buckets) res))))))) + (let* ((entries (apply append (map (lambda (t) + (hash-map->list + (lambda (key val) val) t)) + indexes))) + (sorted (map sort-entries-bucket + (merge-buckets + (sort entries + (lambda (e1 e2) + (string-ci<? + (markup-option (car e1) 'name) + (markup-option (car e2) 'name)))))))) + (if (and (not split) (< (apply + (map length sorted)) header-limit)) + (new markup + (markup '&the-index) + (loc loc) + (ident i) + (class c) + (options `((:column ,col))) + (body sorted)) + (let loop ((refs sorted) + (lrefs '()) + (body '())) + (if (null? refs) + (new markup + (markup '&the-index) + (loc loc) + (ident i) + (class c) + (options `((:column ,col) + (header ,(new markup + (markup '&the-index-header) + (loc loc) + (body (reverse! lrefs)))))) + (body (reverse! body))) + (call-with-values + (lambda () (letter-references refs)) + (lambda (l lr next-refs) + (let* ((s (string l)) + (m (mark (symbol->string (gensym s)) :text s)) + (h (new handle (loc loc) (ast m))) + (r (ref :handle h :text s))) + (ast-loc-set! m loc) + (ast-loc-set! r loc) + (loop next-refs + (cons r lrefs) + (append lr (cons m body))))))))))) + + +;;; index.scm ends here diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm new file mode 100644 index 0000000..21b2a4d --- /dev/null +++ b/src/guile/skribilo/lib.scm @@ -0,0 +1,239 @@ +;;; +;;; lib.scm -- Utilities +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo lib) + :use-module (skribilo utils syntax) + :export (skribe-eval-location skribe-ast-error skribe-error + skribe-type-error + skribe-warning skribe-warning/ast + skribe-message + + type-name %procedure-arity) + + :export-syntax (new define-markup define-simple-markup + define-simple-container define-processor-markup) + + :use-module (skribilo config) + :use-module (skribilo ast) + + ;; useful for `new' to work well with <language> + :autoload (skribilo source) (<language>) + + :use-module (skribilo reader) + :use-module (skribilo parameters) + :use-module (skribilo location) + + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (ice-9 optargs)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; NEW +;;; + +(define %types-module (current-module)) + +(define-macro (new class . parameters) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo ast)' in order to make use of `new'. + (let* ((class-name (symbol-append '< class '>)) + (actual-class (module-ref %types-module class-name))) + `(let ((make ,make) + (,class-name ,actual-class)) + (make ,class-name + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))))) + +;;; +;;; DEFINE-MARKUP +;;; +(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 is not what Skribe/DSSSL + ;; expect, hence `fix-rest-arg'. + (define (fix-rest-arg args) + (let loop ((args args) + (result '()) + (rest-arg #f)) + (cond ((null? args) + (if rest-arg + (append (reverse result) rest-arg) + (reverse result))) + + ((list? args) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? + (list (car args) (cadr args)) + rest-arg)))) + + ((pair? args) + (loop '() + (cons (car args) result) + (list #:rest (cdr args))))))) + + (let ((name (car bindings)) + (opts (cdr bindings))) + `(define*-public ,(cons name (fix-rest-arg opts)) ,@body))) + + +;;; +;;; DEFINE-SIMPLE-MARKUP +;;; +(define-macro (define-simple-markup markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string + (gensym ',(symbol->string markup))))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-SIMPLE-CONTAINER +;;; +(define-macro (define-simple-container markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string + (gensym ',(symbol->string markup))))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-PROCESSOR-MARKUP +;;; +(define-macro (define-processor-markup proc) + `(define-markup (,proc #:rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + + + +;;; +;;; TYPE-NAME +;;; +(define (type-name obj) + (cond ((string? obj) "string") + ((ast? obj) "ast") + ((list? obj) "list") + ((pair? obj) "pair") + ((number? obj) "number") + ((char? obj) "character") + ((keyword? obj) "keyword") + (else (with-output-to-string + (lambda () (write obj)))))) + +;;; +;;; SKRIBE-EVAL-LOCATION ... +;;; +(define (skribe-eval-location) + (format (current-error-port) + "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n") + #f) + +;;; +;;; SKRIBE-ERROR +;;; +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (markup? obj) (markup-markup obj) obj))) + (if (location? l) + (error (format #f "~a:~a: ~a: ~a ~s" (location-file l) + (location-line l) proc msg shape)) + (error (format #f "~a: ~a ~s " proc msg shape))))) + +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error (format #f "~a: ~a ~s" proc msg obj)))) + + +;;; +;;; SKRIBE-TYPE-ERROR +;;; +(define (skribe-type-error proc msg obj etype) + (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f)) + + +;;; +;;; SKRIBE-WARNING & SKRIBE-WARNING/AST +;;; +(define (%skribe-warn level file line lst) + (let ((port (current-error-port))) + (if (or (not file) (not line)) + (begin + ;; XXX: This is a bit hackish, but it proves to be quite useful. + (set! file (port-filename (current-input-port))) + (set! line (port-line (current-input-port))))) + (when (and file line) + (format port "~a:~a: " file line)) + (format port "warning: ") + (for-each (lambda (x) (format port "~a " x)) lst) + (newline port))) + + +(define (skribe-warning level . obj) + (if (>= (*warning*) level) + (%skribe-warn level #f #f obj))) + + +(define (skribe-warning/ast level ast . obj) + (if (>= (*warning*) level) + (let ((l (ast-loc ast))) + (if (location? l) + (%skribe-warn level (location-file l) (location-line l) obj) + (%skribe-warn level #f #f obj))))) + +;;; +;;; SKRIBE-MESSAGE +;;; +(define (skribe-message fmt . obj) + (when (> (*verbose*) 0) + (apply format (current-error-port) fmt obj))) + + +;;; +;;; %PROCEDURE-ARITY +;;; +(define (%procedure-arity proc) + (car (procedure-property proc 'arity))) + +;;; lib.scm ends here diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm new file mode 100644 index 0000000..7c870fa --- /dev/null +++ b/src/guile/skribilo/location.scm @@ -0,0 +1,69 @@ +;;; location.scm -- Skribilo source location. +;;; +;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo location) + :use-module (oop goops) + :use-module ((skribilo utils syntax) :select (%skribilo-module-reader)) + :export (<location> location? ast-location + location-file location-line location-pos)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; An abstract data type to keep track of source locations. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +(define-class <location> () + (file :init-keyword :file :getter location-file) + (pos :init-keyword :pos :getter location-pos) + (line :init-keyword :line :getter location-line)) + +(define (location? obj) + (is-a? obj <location>)) + +(define (ast-location obj) + (let ((loc (slot-ref obj 'loc))) + (if (location? loc) + (let* ((fname (location-file loc)) + (line (location-line loc)) + (pwd (getcwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (> lenf len)) + (substring fname len (+ 1 (string-length fname))) + fname))) + (format #f "~a, line ~a" file line)) + "no source location"))) + + +;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83 + +;;; location.scm ends here. diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm new file mode 100644 index 0000000..ac8eee0 --- /dev/null +++ b/src/guile/skribilo/module.scm @@ -0,0 +1,153 @@ +;;; module.scm -- Integration of Skribe code as Guile modules. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo module) + :autoload (skribilo reader) (make-reader) + :use-module (skribilo debug) + :use-module (srfi srfi-1) + :use-module (ice-9 optargs) + :use-module (srfi srfi-39) + :use-module (skribilo utils syntax) + :export (make-run-time-module *skribilo-user-module*)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This (fake) module defines a macro called `define-skribe-module' which +;;; allows to package Skribe code (which uses Skribe built-ins and most +;;; importantly a Skribe syntax) as a Guile module. This module +;;; automatically exports the macro as a core binding so that future +;;; `use-modules' referring to Skribe modules will work as expected. +;;; +;;; Code: + +(define %skribilo-user-imports + ;; List of modules that should be imported by any good Skribilo module. + '((srfi srfi-1) ;; lists + (srfi srfi-13) ;; strings + (ice-9 optargs) ;; `define*' + + (skribilo package base) ;; the core markups + (skribilo utils syntax) ;; `unless', `when', etc. + (skribilo utils compat) ;; `skribe-load-path', etc. + (skribilo utils keywords) ;; `the-body', `the-options' + (skribilo utils strings) ;; `make-string-replace', etc. + (skribilo module) + (skribilo ast) ;; `<document>', `document?', etc. + (skribilo config) + (skribilo biblio) + (skribilo lib) ;; `define-markup', `unwind-protect', etc. + (skribilo resolve) + (skribilo engine) + (skribilo writer) + (skribilo output) + (skribilo evaluator) + (skribilo debug) + (skribilo location) + )) + +(define %skribilo-user-autoloads + ;; List of auxiliary modules that may be lazily autoloaded. + '(((skribilo engine lout) . (!lout + lout-illustration + ;; FIXME: The following should eventually be + ;; removed from here. + lout-structure-number-string)) + ((skribilo engine latex) . (!latex LaTeX TeX)) + ((skribilo engine html) . (html-markup-class html-class + html-width)) + ((skribilo utils images) . (convert-image)) + ((skribilo index) . (index? make-index-table default-index + resolve-the-index)) + ((skribilo source) . (source-read-lines source-fontify + language? language-extractor + language-fontifier source-fontify)) + ((skribilo coloring lisp) . (skribe scheme lisp)) + ((skribilo coloring xml) . (xml)) + ((skribilo prog) . (make-prog-body resolve-line)) + ((skribilo color) . + (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + ((skribilo sui) . (load-sui)) + + ((ice-9 and-let-star) . (and-let*)) + ((ice-9 receive) . (receive)))) + + + +;; The very macro to turn a legacy Skribe file (which uses Skribe's syntax) +;; into a Guile module. + +(define-macro (define-skribe-module name . options) + `(begin + (define-module ,name + :use-module ((skribilo reader) :select (%default-reader)) + :use-module (srfi srfi-1) + ,@(append-map (lambda (mod) + (list :autoload (car mod) (cdr mod))) + %skribilo-user-autoloads) + ,@options) + + ;; Pull all the bindings that Skribe code may expect, plus those needed + ;; to actually create and read the module. + ;; TODO: These should be auto-loaded. + ,(cons 'use-modules %skribilo-user-imports) + + ;; Change the current reader to a Skribe-compatible reader. If this + ;; primitive is not provided by Guile (i.e., version <= 1.7.2), then it + ;; should be provided by `guile-reader' (version >= 0.3) as a core + ;; binding and installed by `(skribilo utils syntax)'. + (fluid-set! current-reader %default-reader))) + + +;; Make it available to the top-level module. +(module-define! the-root-module + 'define-skribe-module define-skribe-module) + + + + +;;; +;;; 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)) + (autoloads (map (lambda (name+bindings) + (make-autoload-interface the-module + (car name+bindings) + (cdr name+bindings))) + %skribilo-user-autoloads))) + (set-module-name! the-module '(skribilo-user)) + (module-use-interfaces! the-module + (cons the-root-module + (append (map resolve-interface + %skribilo-user-imports) + autoloads))) + the-module)) + +;; The current module in which the document is evaluated. +(define *skribilo-user-module* (make-parameter (make-run-time-module))) + + +;;; module.scm ends here diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm new file mode 100644 index 0000000..a33c040 --- /dev/null +++ b/src/guile/skribilo/output.scm @@ -0,0 +1,228 @@ +;;; output.scm -- Skribilo output stage. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo output) + :autoload (skribilo engine) (engine-ident processor-get-engine) + :autoload (skribilo writer) (writer? writer-ident lookup-markup-writer) + :autoload (skribilo location) (location?) + :use-module (skribilo ast) + :use-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (oop goops) + + :use-module (skribilo condition) + :use-module (srfi srfi-35) + :use-module (srfi srfi-34) + :use-module (srfi srfi-39) + + :export (output + *document-being-output* + &output-error &output-unresolved-error &output-writer-error + output-error? output-unresolved-error? output-writer-error?)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Error conditions. +;;; + +(define-condition-type &output-error &skribilo-error + output-error?) + +(define-condition-type &output-unresolved-error &output-error + output-unresolved-error? + (ast output-unresolved-error:ast)) + +(define-condition-type &output-writer-error &output-error + output-writer-error? + (writer output-writer-error:writer)) + + +(define (handle-output-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((output-unresolved-error? c) + (let* ((node (output-unresolved-error:ast c)) + (location (and (ast? node) (ast-loc node)))) + (format (current-error-port) "unresolved node: ~a~a~%" + node + (if (location? location) + (string-append " " + (location-file location) ":" + (location-line location)) + "")))) + ((output-writer-error? c) + (format (current-error-port) "invalid writer: ~a~%" + (output-writer-error:writer c))) + (else + (format (current-error-port) "undefined output error: ~a~%" + c)))) + +(register-error-condition-handler! output-error? + handle-output-error) + + + +;;; +;;; Output method. +;;; + +;; The document being output. Note: This is only meant to be used by the +;; compatibility layer in order to implement things like `find-markups'! +(define *document-being-output* (make-parameter #f)) + +(define-generic out) + +(define (%out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" n " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (engine-ident e)) + (debug-item "w=" (writer-ident w)) + + (when (writer? w) + (invoke (slot-ref w 'before) n e) + (invoke (slot-ref w 'action) n e) + (invoke (slot-ref w 'after) n e)))) + + + +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (null? writer) + (out node e) + (cond + ((is-a? (car writer) <writer>) + (%out/writer node e (car writer))) + ((not (car writer)) + (raise (condition (&output-writer-error (writer writer))))) + (else + (raise (condition (&output-writer-error (writer writer))))))))) + + + +;;; +;;; OUT implementations +;;; +(define-method (out node e) + #f) + +(define-method (out (node <document>) e) + ;; Only needed by the compatibility layer. + (parameterize ((*document-being-output* node)) + (next-method))) + +(define-method (out (node <pair>) e) + (let loop ((n* node)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (raise (condition (&invalid-argument-error + (proc-name output) + (argument n*)))))))) + + +(define-method (out (node <string>) e) + (let ((f (slot-ref e 'filter))) + (if (procedure? f) + (display (f node)) + (display node)))) + + +(define-method (out (node <number>) e) + (out (number->string node) e)) + + +(define-method (out (n <processor>) e) + (let ((combinator (slot-ref n 'combinator)) + (engine (slot-ref n 'engine)) + (body (slot-ref n 'body)) + (procedure (slot-ref n 'procedure))) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + + +(define-method (out (n <command>) e) + (let* ((fmt (slot-ref n 'fmt)) + (body (slot-ref n 'body)) + (lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (raise (condition (&too-few-arguments-error + (proc-name "output<command>") + (arguments n)))))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (raise (condition (&too-few-arguments-error + (proc-name "output<command>") + (arguments n))))))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0))))))) + + +(define-method (out (n <handle>) e) + 'unspecified) + + +(define-method (out (n <unresolved>) e) + (raise (condition (&output-unresolved-error (ast n))))) + + +(define-method (out (node <markup>) e) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (%out/writer node e w) + (output (slot-ref node 'body) e)))) diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am new file mode 100644 index 0000000..693f088 --- /dev/null +++ b/src/guile/skribilo/package/Makefile.am @@ -0,0 +1,7 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package +dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ + lncs.scm scribe.scm sigplan.scm skribe.scm \ + slide.scm web-article.scm web-book.scm \ + eq.scm pie.scm base.scm + +SUBDIRS = slide eq pie diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm new file mode 100644 index 0000000..61eafd5 --- /dev/null +++ b/src/guile/skribilo/package/acmproc.scm @@ -0,0 +1,164 @@ +;;; acmproc.scm -- The Skribe style for ACMPROC articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[letterpaper]{acmproc}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\numberofauthors{~a}\n\\author{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "\\alignauthor\n") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\CopyrightYear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\crdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key (class "abstract") postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :class class :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm new file mode 100644 index 0000000..bbb2a62 --- /dev/null +++ b/src/guile/skribilo/package/base.scm @@ -0,0 +1,1410 @@ +;;; base.scm -- The base markup package of Skribe/Skribilo. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package base) + :use-syntax (skribilo lib) + :use-syntax (skribilo reader) + :use-syntax (skribilo utils syntax) + :use-syntax (ice-9 optargs) + + :use-module (skribilo ast) + :use-module (skribilo resolve) + :use-module (skribilo utils keywords) + :autoload (srfi srfi-1) (every any filter) + :autoload (skribilo evaluator) (include-document) + :autoload (skribilo engine) (engine?) + + ;; optional ``sub-packages'' + :autoload (skribilo biblio) (default-bib-table resolve-bib + bib-load! bib-add!) + :autoload (skribilo color) (skribe-use-color!) + :autoload (skribilo source) (language? source-read-lines source-fontify) + :autoload (skribilo prog) (make-prog-body resolve-line) + :autoload (skribilo index) (make-index-table) + + :replace (symbol)) + +(fluid-set! current-reader (make-reader 'skribe)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; This module contains all the core markups of Skribe/Skribilo. +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `api.scm' file found in the `common' directory. + + + +;*---------------------------------------------------------------------*/ +;* include ... */ +;*---------------------------------------------------------------------*/ +(define-markup (include file) + (if (not (string? file)) + (skribe-error 'include "Illegal file (string expected)" file) + (include-document file))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(define-markup (document #!rest + opts + #!key + (ident #f) (class "document") + (title #f) (html-title #f) (author #f) + (ending #f) (keywords '()) (env '())) + (new document + (markup 'document) + (ident (or ident + (ast->string title) + (symbol->string (gensym "document")))) + (class class) + (required-options '(:title :author :ending)) + (options (the-options opts :ident :class :env)) + (body (the-body opts)) + (env (append env + (list (list 'chapter-counter 0) (list 'chapter-env '()) + (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()) + (list 'figure-counter 0) (list 'figure-env '())))))) + +;*---------------------------------------------------------------------*/ +;* keyword-list->comma-separated ... */ +;*---------------------------------------------------------------------*/ +(define-public (keyword-list->comma-separated kw*) + ;; Turn the the list of keywords (which may be strings or other markups) + ;; KW* into a markup where the elements of KW* are comma-separated. This + ;; may commonly be used in handling the `:keywords' option of `document'. + (let loop ((kw* kw*) (result '())) + (if (null? kw*) + (reverse! result) + (loop (cdr kw*) + (cons* (if (pair? (cdr kw*)) ", " "") + (car kw*) result))))) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(define-markup (author #!rest + opts + #!key + (ident #f) (class "author") + name + (title #f) + (affiliation #f) + (email #f) + (url #f) + (address #f) + (phone #f) + (photo #f) + (align 'center)) + (if (not (memq align '(center left right))) + (skribe-error 'author "Illegal align value" align) + (new container + (markup 'author) + (ident (or ident (symbol->string (gensym "author")))) + (class class) + (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) + (options `((:name ,name) + (:align ,align) + ,@(the-options opts :ident :class))) + (body #f)))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(define-markup (toc #!rest + opts + #!key + (ident #f) (class "toc") + (chapter #t) (section #t) (subsection #f) + (subsubsection #f)) + (let ((body (the-body opts))) + (new container + (markup 'toc) + (ident (or ident (symbol->string (gensym "toc")))) + (class class) + (required-options '()) + (options `((:chapter ,chapter) + (:section ,section) + (:subsection ,subsection) + (:subsubsection ,subsubsection) + ,@(the-options opts :ident :class))) + (body (cond + ((null? body) + (new unresolved + (proc (lambda (n e env) + (handle + (resolve-search-parent n env document?)))))) + ((null? (cdr body)) + (if (handle? (car body)) + (car body) + (skribe-error 'toc + "Illegal argument (handle expected)" + (if (markup? (car body)) + (markup-markup (car body)) + "???")))) + (else + (skribe-error 'toc "Illegal argument" body))))))) + +;*---------------------------------------------------------------------*/ +;* chapter ... ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:chapter@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:chapter@ */ +;*---------------------------------------------------------------------*/ +(define-markup (chapter #!rest + opts + #!key + (ident #f) (class "chapter") + title (html-title #f) (file #f) (toc #t) (number #t)) + (new container + (markup 'chapter) + (ident (or ident (symbol->string (gensym "chapter")))) + (class class) + (required-options '(:title :file :toc :number)) + (options `((:toc ,toc) + (:number ,(and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n + env + 'chapter + number)))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()))))) + +;*---------------------------------------------------------------------*/ +;* section-number ... */ +;*---------------------------------------------------------------------*/ +(define (section-number number markup) + (and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n env markup number)))))) + +;*---------------------------------------------------------------------*/ +;* section ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:section@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:sectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (section #!rest + opts + #!key + (ident #f) (class "section") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'section) + (ident (or ident (symbol->string (gensym "section")))) + (class class) + (required-options '(:title :toc :file :toc :number)) + (options `((:number ,(section-number number 'section)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (if file + (list (list 'subsection-counter 0) (list 'subsection-env '()) + (list 'footnote-counter 0) (list 'footnote-env '())) + (list (list 'subsection-counter 0) (list 'subsection-env '())))))) + +;*---------------------------------------------------------------------*/ +;* subsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsection #!rest + opts + #!key + (ident #f) (class "subsection") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'subsection) + (ident (or ident (symbol->string (gensym "subsection")))) + (class class) + (required-options '(:title :toc :file :number)) + (options `((:number ,(section-number number 'subsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsubsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsubsection #!rest + opts + #!key + (ident #f) (class "subsubsection") + title (file #f) (toc #f) (number #t)) + (new container + (markup 'subsubsection) + (ident (or ident (symbol->string (gensym "subsubsection")))) + (class class) + (required-options '(:title :toc :number :file)) + (options `((:number ,(section-number number 'subsubsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup paragraph) + + +;*---------------------------------------------------------------------*/ +;* ~ (unbreakable space) ... */ +;*---------------------------------------------------------------------*/ +(define-markup (~ #!rest opts #!key (class #f)) + (new markup + (markup '~) + (ident (symbol->string (gensym "~"))) + (class class) + (required-options '()) + (options (the-options opts :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(define-markup (footnote #!rest opts + #!key (ident #f) (class "footnote") (label #t)) + ;; The `:label' option used to be called `:number'. + (new container + (markup 'footnote) + (ident (symbol->string (gensym "footnote"))) + (class class) + (required-options '()) + (options `((:label + ,(cond ((string? label) label) + ((number? label) label) + ((not label) label) + (else + (new unresolved + (proc (lambda (n e env) + (resolve-counter n env + 'footnote #t)))))) + ,@(the-options opts :ident :class)))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) + (let ((ln (new markup + (ident (or ident (symbol->string (gensym "linebreak")))) + (class class) + (markup 'linebreak))) + (num (the-body opts))) + (cond + ((null? num) + ln) + ((not (null? (cdr num))) + (skribe-error 'linebreak "Illegal arguments" num)) + ((not (and (integer? (car num)) (positive? (car num)))) + (skribe-error 'linebreak "Illegal argument" (car num))) + (else + (vector->list (make-vector (car num) ln)))))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(define-markup (hrule #!rest + opts + #!key + (ident #f) (class #f) + (width 100.) (height 1)) + (new markup + (markup 'hrule) + (ident (or ident (symbol->string (gensym "hrule")))) + (class class) + (required-options '()) + (options `((:width ,width) + (:height ,height) + ,@(the-options opts :ident :class))) + (body #f))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(define-markup (color #!rest + opts + #!key + (ident #f) (class "color") + (bg #f) (fg #f) (width #f) (margin #f)) + (new container + (markup 'color) + (ident (or ident (symbol->string (gensym "color")))) + (class class) + (required-options '(:bg :fg :width)) + (options `((:bg ,(if bg (skribe-use-color! bg) bg)) + (:fg ,(if fg (skribe-use-color! fg) fg)) + ,@(the-options opts :ident :class :bg :fg))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define-markup (frame #!rest + opts + #!key + (ident #f) (class "frame") + (width #f) (margin 2) (border 1)) + (new container + (markup 'frame) + (ident (or ident (symbol->string (gensym "frame")))) + (class class) + (required-options '(:width :border :margin)) + (options `((:margin ,margin) + (:border ,(cond + ((integer? border) border) + (border 1) + (else #f))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(define-markup (font #!rest + opts + #!key + (ident #f) (class #f) + (size #f) (face #f)) + (new container + (markup 'font) + (ident (or ident (symbol->string (gensym "font")))) + (class class) + (required-options '(:size)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(define-markup (flush #!rest + opts + #!key + (ident #f) (class #f) + side) + (case side + ((center left right) + (new container + (markup 'flush) + (ident (or ident (symbol->string (gensym "flush")))) + (class class) + (required-options '(:side)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + (else + (skribe-error 'flush "Illegal side" side)))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container center) + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container pre) + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:prog@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:prog@ */ +;*---------------------------------------------------------------------*/ +(define-markup (prog #!rest + opts + #!key + (ident #f) (class "prog") + (line 1) (linedigit #f) (mark ";!")) + (if (not (or (string? mark) (eq? mark #f))) + (skribe-error 'prog "Illegal mark" mark) + (new container + (markup 'prog) + (ident (or ident (symbol->string (gensym "prog")))) + (class class) + (required-options '(:line :mark)) + (options (the-options opts :ident :class :linedigit)) + (body (make-prog-body (the-body opts) line linedigit mark))))) + +;*---------------------------------------------------------------------*/ +;* source ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:source@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:source@ */ +;*---------------------------------------------------------------------*/ +(define-markup (source #!rest + opts + #!key + language + (file #f) (start #f) (stop #f) + (definition #f) (tab 8)) + (let ((body (the-body opts))) + (cond + ((and (not (null? body)) (or file start stop definition)) + (skribe-error 'source + "file, start/stop, and definition are exclusive with body" + body)) + ((and start stop definition) + (skribe-error 'source + "start/stop are exclusive with a definition" + body)) + ((and (or start stop definition) (not file)) + (skribe-error 'source + "start/stop and definition require a file specification" + file)) + ((and definition (not language)) + (skribe-error 'source + "definition requires a language specification" + definition)) + ((and file (not (string? file))) + (skribe-error 'source "Illegal file" file)) + ((and start (not (or (integer? start) (string? start)))) + (skribe-error 'source "Illegal start" start)) + ((and stop (not (or (integer? stop) (string? stop)))) + (skribe-error 'source "Illegal start" stop)) + ((and (integer? start) (integer? stop) (> start stop)) + (skribe-error 'source + "start line > stop line" + (format #f "~a/~a" start stop))) + ((and language (not (language? language))) + (skribe-error 'source "illegal language" language)) + ((and tab (not (integer? tab))) + (skribe-error 'source "illegal tab" tab)) + (file + (let ((s (if (not definition) + (source-read-lines file start stop tab) + (source-read-definition file definition tab language)))) + (if language + (source-fontify s language) + s))) + (language + (source-fontify body language)) + (else + body)))) + +;*---------------------------------------------------------------------*/ +;* language ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:language@ */ +;*---------------------------------------------------------------------*/ +(define-markup (language #!key name (fontifier #f) (extractor #f)) + (if (not (string? name)) + (skribe-type-error 'language "illegal name" name "string") + (new language + (name name) + (fontifier fontifier) + (extractor extractor)))) + +;*---------------------------------------------------------------------*/ +;* figure ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/figure.skb:figure@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:figure@ */ +;*---------------------------------------------------------------------*/ +(define-markup (figure #!rest + opts + #!key + (ident #f) (class "figure") + (legend #f) (number #t) (multicolumns #f)) + (new container + (markup 'figure) + (ident (or ident + (let ((s (ast->string legend))) + (if (not (string=? s "")) + s + (symbol->string (gensym "figure")))))) + (class class) + (required-options '(:legend :number :multicolumns)) + (options `((:number + ,(new unresolved + (proc (lambda (n e env) + (resolve-counter n env 'figure number))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* parse-list-of ... */ +;* ------------------------------------------------------------- */ +;* The function table accepts two different prototypes. It */ +;* may receive its N elements in a list of N elements or in */ +;* a list of one element which is a list of N elements. This */ +;* gets rid of APPLY when calling container markup such as ITEMIZE */ +;* or TABLE. */ +;*---------------------------------------------------------------------*/ +(define (parse-list-of for markup lst) + (cond + ((null? lst) + '()) + ((and (pair? lst) + (or (pair? (car lst)) (null? (car lst))) + (null? (cdr lst))) + (parse-list-of for markup (car lst))) + (else + (let loop ((lst lst) + (result '())) + (cond + ((null? lst) + (reverse! result)) + ((pair? (car lst)) + (loop (car lst) result)) + (else + (let ((r (car lst))) + (if (not (is-markup? r markup)) + (skribe-warning 2 + for + (format #f "illegal `~a' element, `~a' expected" + (if (markup? r) + (markup-markup r) + (type-name r)) + markup))) + (loop (cdr lst) (cons r result))))))))) + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) + (new container + (markup 'itemize) + (ident (or ident (symbol->string (gensym "itemize")))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'itemize 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) + (new container + (markup 'enumerate) + (ident (or ident (symbol->string (gensym "enumerate")))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'enumerate 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) + (new container + (markup 'description) + (ident (or ident (symbol->string (gensym "description")))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'description 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(define-markup (item #!rest opts #!key (ident #f) (class #f) key) + (if (and key (not (or (string? key) + (number? key) + (markup? key) + (pair? key)))) + (skribe-type-error 'item "Illegal key:" key "node") + (new container + (markup 'item) + (ident (or ident (symbol->string (gensym "item")))) + (class class) + (required-options '(:key)) + (options `((:key ,key) ,@(the-options opts :ident :class :key))) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* table */ +;*---------------------------------------------------------------------*/ +(define-markup (table #!rest + opts + #!key + (ident #f) (class #f) + (border #f) (width #f) + (frame 'none) (rules 'none) + (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) + (let ((frame (cond + ((string? frame) + (string->symbol frame)) + ((not frame) + #f) + (else + frame))) + (rules (cond + ((string? rules) + (string->symbol rules)) + ((not rules) + #f) + (else + rules))) + (frame-vals '(none above below hsides vsides lhs rhs box border)) + (rules-vals '(none rows cols all header)) + (cells-vals '(collapse separate))) + (cond + ((and frame (not (memq frame frame-vals))) + (skribe-error 'table + (format #f "frame should be one of \"~a\"" frame-vals) + frame)) + ((and rules (not (memq rules rules-vals))) + (skribe-error 'table + (format #f "rules should be one of \"~a\"" rules-vals) + rules)) + ((not (or (memq cellstyle cells-vals) + (string? cellstyle) + (number? cellstyle))) + (skribe-error 'table + (format #f "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) + cellstyle)) + (else + (new container + (markup 'table) + (ident (or ident (symbol->string (gensym "table")))) + (class class) + (required-options '(:width :frame :rules)) + (options `((:frame ,frame) + (:rules ,rules) + (:cellstyle ,cellstyle) + ,@(the-options opts :ident :class))) + (body (parse-list-of 'table 'tr (the-body opts)))))))) + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) + (new container + (markup 'tr) + (ident (or ident (symbol->string (gensym "tr")))) + (class class) + (required-options '()) + (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) + ,@(the-options opts :ident :class :bg))) + (body (parse-list-of 'tr 'tc (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* tc... */ +;*---------------------------------------------------------------------*/ +(define-markup (tc m + #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (rowspan 1) (bg #f)) + (let ((align (if (string? align) + (string->symbol align) + align)) + (valign (if (string? valign) + (string->symbol valign) + valign))) + (cond + ((not (integer? colspan)) + (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) + ((not (symbol? align)) + (skribe-type-error 'tc "Illegal align, " align "align")) + ((not (memq align '(#f center left right))) + (skribe-error + 'tc + "align should be one of 'left', `center', or `right'" + align)) + ((not (memq valign '(#f top middle center bottom))) + (skribe-error + 'tc + "valign should be one of 'top', `middle', `center', or `bottom'" + valign)) + (else + (new container + (markup 'tc) + (ident (or ident (symbol->string (gensym "tc")))) + (class class) + (required-options '(:width :align :valign :colspan)) + (options `((markup ,m) + (:align ,align) + (:valign ,valign) + (:colspan ,colspan) + ,@(if bg + `((:bg ,(if bg (skribe-use-color! bg) bg))) + '()) + ,@(the-options opts :ident :class :bg :align :valign))) + (body (the-body opts))))))) + +;*---------------------------------------------------------------------*/ +;* th ... */ +;*---------------------------------------------------------------------*/ +(define-markup (th #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (rowspan 1) (bg #f)) + (apply tc 'th opts)) + +;*---------------------------------------------------------------------*/ +;* td ... */ +;*---------------------------------------------------------------------*/ +(define-markup (td #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (rowspan 1) (bg #f)) + (apply tc 'td opts)) + +;*---------------------------------------------------------------------*/ +;* image ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/image.skb:image@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:image@ */ +;* latex: @ref ../../skr/latex.skr:image@ */ +;*---------------------------------------------------------------------*/ +(define-markup (image #!rest + opts + #!key + (ident #f) (class #f) + file (url #f) (width #f) (height #f) (zoom #f)) + (cond + ((not (or (string? file) (string? url))) + (skribe-error 'image "No file or url provided" file)) + ((and (string? file) (string? url)) + (skribe-error 'image "Both file and url provided" (list file url))) + (else + (new markup + (markup 'image) + (ident (or ident (symbol->string (gensym "image")))) + (class class) + (required-options '(:file :url :width :height)) + (options (the-options opts :ident :class)) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* blockquote */ +;*---------------------------------------------------------------------*/ +(define-simple-markup blockquote) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup roman) +(define-simple-markup bold) +(define-simple-markup underline) +(define-simple-markup strike) +(define-simple-markup emph) +(define-simple-markup kbd) +(define-simple-markup it) +(define-simple-markup tt) +(define-simple-markup code) +(define-simple-markup var) +(define-simple-markup samp) +(define-simple-markup sf) +(define-simple-markup sc) +(define-simple-markup sub) +(define-simple-markup sup) + +;*---------------------------------------------------------------------*/ +;* char ... */ +;*---------------------------------------------------------------------*/ +(define-markup (char char) + (cond + ((char? char) + (string char)) + ((integer? char) + (string (integer->char char))) + ((and (string? char) (= (string-length char) 1)) + char) + (else + (skribe-error 'char "Illegal char" char)))) + +;*---------------------------------------------------------------------*/ +;* symbol ... */ +;*---------------------------------------------------------------------*/ +(define-markup (symbol symbol) + (let ((v (cond + ((symbol? symbol) + (symbol->string symbol)) + ((string? symbol) + symbol) + (else + (skribe-error 'symbol + "Illegal argument (symbol expected)" + symbol))))) + (new markup + (markup 'symbol) + (body v)))) + +;*---------------------------------------------------------------------*/ +;* ! ... */ +;*---------------------------------------------------------------------*/ +(define-markup (! format #!rest node) + (if (not (string? format)) + (skribe-type-error '! "Illegal format:" format "string") + (new command + (fmt format) + (body node)))) + +;*---------------------------------------------------------------------*/ +;* processor ... */ +;*---------------------------------------------------------------------*/ +(define-markup (processor #!rest opts + #!key (combinator #f) (engine #f) (procedure #f)) + (cond + ((and combinator (not (procedure? combinator))) + (skribe-error 'processor "Combinator not a procedure" combinator)) + ((and engine (not (engine? engine))) + (skribe-error 'processor "Illegal engine" engine)) + ((and procedure + (or (not (procedure? procedure)) + (not (let ((a (procedure-property procedure 'arity))) + (and (pair? a) + (let ((compulsory (car a)) + (optional (cadr a)) + (rest? (caddr a))) + (or rest? + (>= (+ compulsory optional) 2)))))))) + (skribe-error 'processor "Illegal procedure" procedure)) + (else + (new processor + (combinator combinator) + (engine engine) + (procedure (or procedure (lambda (n e) n))) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* Processors ... */ +;*---------------------------------------------------------------------*/ +(define-processor-markup html-processor) +(define-processor-markup tex-processor) + +;*---------------------------------------------------------------------*/ +;* handle ... */ +;*---------------------------------------------------------------------*/ +(define-markup (handle #!rest opts + #!key (ident #f) (class "handle") value section) + (let ((body (the-body opts))) + (cond + (section + (error 'handle "Illegal handle `section' option" section) + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident section 'section n env))) + (new handle + (ast s))))))) + ((and (pair? body) + (null? (cdr body)) + (markup? (car body))) + (new handle + (ast (car body)))) + (else + (skribe-error 'handle "Illegal handle" opts))))) + +;*---------------------------------------------------------------------*/ +;* mailto ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mailto@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mailto@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) + (new markup + (markup 'mailto) + (ident (or ident (symbol->string (gensym "ident")))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* *mark-table* ... */ +;*---------------------------------------------------------------------*/ +(define *mark-table* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mark@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mark@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) + (let ((bd (the-body opts))) + (cond + ((and (pair? bd) (not (null? (cdr bd)))) + (skribe-error 'mark "Too many argument provided" bd)) + ((null? bd) + (skribe-error 'mark "Missing argument" '())) + ((not (string? (car bd))) + (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) + (ident + (skribe-error 'mark "Illegal `ident:' option" ident)) + (else + (let* ((bs (ast->string bd)) + (n (new markup + (markup 'mark) + (ident (symbol->string (gensym bs))) + (class class) + (options (the-options opts :ident :class :text)) + (body text)))) + (hash-set! *mark-table* bs n) + n))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:ref@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:ref@ */ +;* latex: @ref ../../skr/latex.skr:ref@ */ +;*---------------------------------------------------------------------*/ +(define-markup (ref #!rest + opts + #!key + (class #f) + (ident #f) + (text #f) + (chapter #f) + (section #f) + (subsection #f) + (subsubsection #f) + (bib #f) + (bib-table (default-bib-table)) + (url #f) + (figure #f) + (mark #f) + (handle #f) + (line #f) + (skribe #f) + (page #f)) + (define (unref ast text kind) + (let ((msg (format #f "can't find `~a': " kind))) + (if (ast? ast) + (begin + (skribe-warning/ast 1 ast 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string (gensym "unref"))) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body (list text ": " (ast->file-location ast))))) + (begin + (skribe-warning 1 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string (gensym "unref"))) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body text)))))) + (define (skribe-ref skribe) + (let ((path (find-file/path skribe (skribe-path)))) + (if (not path) + (unref #f skribe 'sui-file) + (let* ((sui (load-sui path)) + (os (the-options opts :skribe :class :text)) + (u (sui-ref->url (dirname path) sui ident os))) + (if (not u) + (unref #f os 'sui-ref) + (ref :url u :text text :ident ident :class class)))))) + (define (handle-ref text) + (new markup + (markup 'ref) + (ident (symbol->string (gensym "handle-ref"))) + (class class) + (required-options '(:text)) + (options `((kind handle) ,@(the-options opts :ident :class))) + (body text))) + (define (do-title-ref title kind) + (if (not (string? title)) + (skribe-type-error 'ref "illegal reference" title "string") + (new unresolved + (proc (lambda (n e env) + (let* ((doc (ast-document n)) + (s (find1-down + (lambda (n) + (and (is-markup? n kind) + (equal? (markup-option n :title) + title))) + doc))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "title-ref"))) + (class class) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,title) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n title (or kind 'title))))))))) + (define (do-ident-ref text kind) + (if (not (string? text)) + (skribe-type-error 'ref "Illegal reference" text "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident text kind n env))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "ident-ref"))) + (class class) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,text) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n text (or kind 'ident))))))))) + (define (mark-ref mark) + (if (not (string? mark)) + (skribe-type-error 'mark "Illegal mark, " mark "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (hash-ref *mark-table* mark))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "mark-ref"))) + (class class) + (required-options '(:text)) + (options `((kind mark) + (mark ,mark) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n mark 'mark)))))))) + (define (make-bib-ref v) + (let ((s (resolve-bib bib-table v))) + (if s + (let* ((n (new markup + (markup 'bib-ref) + (ident (symbol->string (gensym "bib-ref"))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (new handle + (ast s))))) + (h (new handle (ast n))) + (o (markup-option s 'used))) + (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) + n) + (unref #f v 'bib)))) ; FIXME: This prevents source location + ; info to be provided in the warning msg + (define (bib-ref text) + (if (pair? text) + (new markup + (markup 'bib-ref+) + (ident (symbol->string (gensym "bib-ref+"))) + (class class) + (options (the-options opts :ident :class)) + (body (map make-bib-ref text))) + (make-bib-ref text))) + (define (url-ref) + (new markup + (markup 'url-ref) + (ident (symbol->string (gensym "url-ref"))) + (class class) + (required-options '(:url :text)) + (options (the-options opts :ident :class)))) + (define (line-ref line) + (new unresolved + (proc (lambda (n e env) + (let ((l (resolve-line line))) + (if (pair? l) + (new markup + (markup 'line-ref) + (ident (symbol->string (gensym "line-ref"))) + (class class) + (options `((:text ,(markup-ident (car l))) + ,@(the-options opts :ident :class))) + (body (new handle + (ast (car l))))) + (unref n line 'line))))))) + (let ((b (the-body opts))) + (if (not (null? b)) + (skribe-warning 1 'ref "Arguments ignored " b)) + (cond + (skribe (skribe-ref skribe)) + (handle (handle-ref handle)) + (ident (do-ident-ref ident #f)) + (chapter (do-title-ref chapter 'chapter)) + (section (do-title-ref section 'section)) + (subsection (do-title-ref subsection 'subsection)) + (subsubsection (do-title-ref subsubsection 'subsubsection)) + (figure (do-ident-ref figure 'figure)) + (mark (mark-ref mark)) + (bib (bib-ref bib)) + (url (url-ref)) + (line (line-ref line)) + (else (skribe-error 'ref "illegal reference" opts))))) + +;*---------------------------------------------------------------------*/ +;* resolve ... */ +;*---------------------------------------------------------------------*/ +(define-markup (resolve fun) + (new unresolved + (proc fun))) + +;*---------------------------------------------------------------------*/ +;* bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (bibliography #!rest files + #!key + (command #f) (bib-table (default-bib-table))) + (for-each (lambda (f) + (cond + ((string? f) + (bib-load! bib-table f command)) + ((pair? f) + (bib-add! bib-table f)) + (else + (skribe-error "bibliography" "Illegal entry" f)))) + (the-body files))) + +;*---------------------------------------------------------------------*/ +;* the-bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:the-bibliography@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-bibliography #!rest opts + #!key + pred + (bib-table (default-bib-table)) + (sort bib-sort/authors) + (count 'partial)) + (if (not (memq count '(partial full))) + (skribe-error 'the-bibliography + "Cound must be either `partial' or `full'" + count) + (new unresolved + (proc (lambda (n e env) + (resolve-the-bib bib-table + (new handle (ast n)) + sort + pred + count + (the-options opts))))))) + +;*---------------------------------------------------------------------*/ +;* make-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:make-index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (make-index ident) + (make-index-table ident)) + +;*---------------------------------------------------------------------*/ +;* index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (index #!rest + opts + #!key + (ident #f) (class "index") + (note #f) (index #f) (shape #f) + (url #f)) + (let* ((entry-name (the-body opts)) + (ename (cond + ((string? entry-name) + entry-name) + ((and (pair? entry-name) (every string? entry-name)) + (apply string-append entry-name)) + (else + (skribe-error + 'index + "entry-name must be either a string or a list of strings" + entry-name)))) + (table (cond + ((not index) (default-index)) + ((index? index) index) + (else (skribe-type-error 'index + "Illegal index table, " + index + "index")))) + (m (mark (symbol->string (gensym "mark")))) + (h (new handle (ast m))) + (new (new markup + (markup '&index-entry) + (ident (or ident (symbol->string (gensym "index")))) + (class class) + (options `((name ,ename) ,@(the-options opts :ident :class))) + (body (if url + (ref :url url :text (or shape ename)) + (ref :handle h :text (or shape ename))))))) + ;; New is bound to a dummy option of the mark in order + ;; to make new options verified. + (markup-option-add! m 'to-verify new) + + (let ((handle (hash-get-handle table ename))) + (if (not handle) + (hash-set! table ename (list new)) + (set-cdr! handle (cons new (cdr handle))))) + + m)) + +;*---------------------------------------------------------------------*/ +;* the-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:the-index@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-index@ */ +;* html: @ref ../../skr/html.skr:the-index-header@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-index #!rest + opts + #!key + (ident #f) + (class "the-index") + (split #f) + (char-offset 0) + (header-limit 50) + (column 1)) + (let ((bd (the-body opts))) + (cond + ((not (and (integer? char-offset) (>= char-offset 0))) + (skribe-error 'the-index "Illegal char offset" char-offset)) + ((not (integer? column)) + (skribe-error 'the-index "Illegal column number" column)) + ((not (every index? bd)) + (skribe-error 'the-index + "Illegal indexes" + (filter (lambda (o) (not (index? o))) bd))) + (else + (new unresolved + (proc (lambda (n e env) + (resolve-the-index (ast-loc n) + ident class + bd + split + char-offset + header-limit + column)))))))) + + +;;; This part comes from the file `skribe.skr' in the original Skribe +;;; distribution. + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define-public (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define-public (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman #(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm new file mode 100644 index 0000000..4f5020e --- /dev/null +++ b/src/guile/skribilo/package/eq.scm @@ -0,0 +1,439 @@ +;;; eq.scm -- An equation formatting package. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package eq) + :autoload (skribilo ast) (markup?) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo module) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :autoload (skribilo package base) (it symbol sub sup) + :autoload (skribilo engine lout) (lout-illustration) + :use-module (ice-9 optargs)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This package defines a set of markups for formatting equations. The user +;;; may either use the standard Scheme prefix notation to represent +;;; equations, or directly use the specific markups (which looks more +;;; verbose). +;;; +;;; FIXME: This is incomplete. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Utilities. +;;; + +(define %operators + '(/ * + - = != ~= < > <= >= sqrt expt sum product script + in notin apply)) + +(define %symbols + ;; A set of symbols that are automatically recognized within an `eq' quoted + ;; list. + '(;; lower-case Greek + alpha beta gamma delta epsilon zeta eta theta iota kappa + lambda mu nu xi omicron pi rho sigma tau upsilon phi chi omega + + ;; upper-case Greek + Alpha Beta Gamma Delta Epsilon Zeta Eta Theta Iota Kappa + Lambda Mu Nu Xi Omicron Pi Rho Sigma Tau Upsilon Phi Chi Omega + + ;; Hebrew + alef + + ;; mathematics + ellipsis weierp image real forall partial exists + emptyset infinity in notin nabla nipropto angle and or cap cup + sim cong approx neq equiv le ge subset supset subseteq supseteq + oplus otimes perp mid lceil rceil lfloor rfloor langle rangle)) + + +(define (make-fast-member-predicate lst) + (let ((h (make-hash-table))) + ;; initialize a hash table equivalent to LST + (for-each (lambda (s) (hashq-set! h s #t)) lst) + + ;; the run-time, fast, definition + (lambda (sym) + (hashq-ref h sym #f)))) + +(define-public known-operator? (make-fast-member-predicate %operators)) +(define-public known-symbol? (make-fast-member-predicate %symbols)) + +(define-public equation-markup-name? + (make-fast-member-predicate (map (lambda (s) + (symbol-append 'eq: s)) + %operators))) + +(define-public (equation-markup? m) + "Return true if @var{m} is an instance of one of the equation sub-markups." + (and (markup? m) + (equation-markup-name? (markup-markup m)))) + +(define-public (equation-markup-name->operator m) + "Given symbol @var{m} (an equation markup name, e.g., @code{eq:+}), return +a symbol representing the mathematical operator denoted by @var{m} (e.g., +@code{+})." + (if (equation-markup-name? m) + (string->symbol (let ((str (symbol->string m))) + (substring str + (+ 1 (string-index str #\:)) + (string-length str)))) + #f)) + + +;;; +;;; Operator precedence. +;;; + +(define %operator-precedence + ;; FIXME: This needs to be augmented. + '((+ . 1) + (- . 1) + (* . 2) + (/ . 2) + (sum . 3) + (product . 3) + (= . 0) + (< . 0) + (> . 0) + (<= . 0) + (>= . 0))) + +(define-public (operator-precedence op) + (let ((p (assq op %operator-precedence))) + (if (pair? p) (cdr p) 0))) + + + +;;; +;;; Turning an S-exp into an `eq' markup. +;;; + +(define %rebindings + (map (lambda (sym) + (list sym (symbol-append 'eq: sym))) + %operators)) + +(define (eq:symbols->strings equation) + "Turn symbols located in non-@code{car} positions into strings." + (cond ((list? equation) + (if (or (null? equation) (null? (cdr equation))) + equation + (cons (car equation) ;; XXX: not tail-recursive + (map eq:symbols->strings (cdr equation))))) + ((symbol? equation) + (if (known-symbol? equation) + `(symbol ,(symbol->string equation)) + (symbol->string equation))) + (else equation))) + +(define-public (eq-evaluate equation) + "Evaluate @var{equation}, an sexp (list) representing an equation, e.g. +@code{'(+ a (/ b 3))}." + (eval `(let ,%rebindings ,(eq:symbols->strings equation)) + (current-module))) + + + +;;; +;;; Markup. +;;; + +(define-markup (eq :rest opts :key (ident #f) (inline? #f) + (renderer #f) (class "eq")) + (new markup + (markup 'eq) + (ident (or ident (symbol->string (gensym "eq")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + result + (loop (cdr body) + (if (markup? (car body)) + (car body) ;; the `eq:*' markups were used + ;; directly + (eq-evaluate (car body))) ;; a quoted list was + ;; passed + )))))) + +(define-simple-markup eq:/) +(define-simple-markup eq:*) +(define-simple-markup eq:+) +(define-simple-markup eq:-) + +(define-simple-markup eq:=) +(define-simple-markup eq:!=) +(define-simple-markup eq:~=) +(define-simple-markup eq:<) +(define-simple-markup eq:>) +(define-simple-markup eq:>=) +(define-simple-markup eq:<=) + +(define-simple-markup eq:sqrt) +(define-simple-markup eq:expt) + +(define-markup (eq:sum :rest opts :key (ident #f) (class "eq:sum") + (from #f) (to #f)) + (new markup + (markup 'eq:sum) + (ident (or ident (symbol->string (gensym "eq:sum")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:product :rest opts :key (ident #f) (class "eq:product") + (from #f) (to #f)) + (new markup + (markup 'eq:product) + (ident (or ident (symbol->string (gensym "eq:product")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:script :rest opts :key (ident #f) (class "eq:script") + (sub #f) (sup #f)) + (new markup + (markup 'eq:script) + (ident (or ident (symbol->string (gensym "eq:script")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-simple-markup eq:in) +(define-simple-markup eq:notin) + +(define-markup (eq:apply :rest opts :key (ident #f) (class "eq:apply")) + ;; This markup may receive either a list of arguments or arguments + ;; compatible with the real `apply'. Note: the real `apply' can take N + ;; non-list arguments but the last one has to be a list. + (new markup + (markup 'eq:apply) + (ident (or ident (symbol->string (gensym "eq:apply")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + (reverse! result) + (let ((first (car body))) + (if (list? first) + (if (null? (cdr body)) + (append (reverse! result) first) + (skribe-error 'eq:apply + "wrong argument type" + body)) + (loop (cdr body) (cons first result))))))))) + + + +;;; +;;; Text-based rendering. +;;; + + +(markup-writer 'eq (find-engine 'base) + :action (lambda (node engine) + ;; The `:renderer' option should be a symbol (naming an engine + ;; class) or an engine or engine class. This allows the use of + ;; another engine to render equations. For instance, equations + ;; may be rendered using the Lout engine within an HTML + ;; document. + (let ((renderer (markup-option node :renderer))) + (cond ((not renderer) ;; default: use the current engine + (output (it (markup-body node)) engine)) + ((symbol? renderer) + (case renderer + ;; FIXME: We should have an `embed' slot for each + ;; engine class similar to `lout-illustration'. + ((lout) + (let ((lout-code + (with-output-to-string + (lambda () + (output node (find-engine 'lout)))))) + (output (lout-illustration + :ident (markup-ident node) + lout-code) + engine))) + (else + (skribe-error 'eq "invalid renderer" renderer)))) + ;; FIXME: `engine?' and `engine-class?' + (else + (skribe-error 'eq "`:renderer' -- wrong argument type" + renderer)))))) + +(define-macro (simple-markup-writer op . obj) + ;; Note: The text-only rendering is less ambiguous if we parenthesize + ;; without taking operator precedence into account. + (let ((precedence (operator-precedence op))) + `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((o (car operands)) + (nested-eq? (equation-markup? o)) + (need-paren? + (and nested-eq? +; (< (operator-precedence +; (equation-markup-name->operator +; (markup-markup o))) +; ,precedence) + ) + )) + + (display (if need-paren? "(" "")) + (output o engine) + (display (if need-paren? ")" "")) + (if (pair? (cdr operands)) + (begin + (display " ") + (output ,(if (null? obj) + (symbol->string op) + (car obj)) + engine) + (display " "))) + (loop (cdr operands))))))))) + +(simple-markup-writer +) +(simple-markup-writer -) +(simple-markup-writer /) +(simple-markup-writer * (symbol "times")) + +(simple-markup-writer =) +(simple-markup-writer != (symbol "neq")) +(simple-markup-writer ~= (symbol "approx")) +(simple-markup-writer <) +(simple-markup-writer >) +(simple-markup-writer >= (symbol "ge")) +(simple-markup-writer <= (symbol "le")) + +(markup-writer 'eq:sqrt (find-engine 'base) + :action (lambda (node engine) + (display "sqrt(") + (output (markup-body node) engine) + (display ")"))) + +(define-macro (simple-binary-markup-writer op obj) + `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let ((first (car body)) + (second (cadr body))) + (display (if (equation-markup? first) "(" " ")) + (output first engine) + (display (if (equation-markup? first) ")" " ")) + (output ,obj engine) + (display (if (equation-markup? second) "(" "")) + (output second engine) + (display (if (equation-markup? second) ")" ""))) + (skribe-error ',(symbol-append 'eq: op) + "wrong argument type" + body)))))) + +(markup-writer 'eq:expt (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let ((first (car body)) + (second (cadr body))) + (display (if (equation-markup? first) "(" "")) + (output first engine) + (display (if (equation-markup? first) ")" "")) + (output (sup second) engine)))))) + +(simple-binary-markup-writer in (symbol "in")) +(simple-binary-markup-writer notin (symbol "notin")) + +(markup-writer 'eq:apply (find-engine 'base) + :action (lambda (node engine) + (let ((func (car (markup-body node)))) + (output func engine) + (display "(") + (let loop ((operands (cdr (markup-body node)))) + (if (null? operands) + #t + (begin + (output (car operands) engine) + (if (not (null? (cdr operands))) + (display ", ")) + (loop (cdr operands))))) + (display ")")))) + +(markup-writer 'eq:sum (find-engine 'base) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to))) + (output (symbol "Sigma") engine) + (display "(") + (output from engine) + (display ", ") + (output to engine) + (display ", ") + (output (markup-body node) engine) + (display ")")))) + +(markup-writer 'eq:prod (find-engine 'base) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to))) + (output (symbol "Pi") engine) + (display "(") + (output from engine) + (display ", ") + (output to engine) + (display ", ") + (output (markup-body node) engine) + (display ")")))) + +(markup-writer 'eq:script (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node)) + (sup* (markup-option node :sup)) + (sub* (markup-option node :sub))) + (output body engine) + (output (sup sup*) engine) + (output (sub sub*) engine)))) + + + + +;;; +;;; Initialization. +;;; + +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package eq lout)))) + + +;;; arch-tag: 58764650-2684-47a6-8cc7-6288f2b474da + +;;; eq.scm ends here diff --git a/src/guile/skribilo/package/eq/Makefile.am b/src/guile/skribilo/package/eq/Makefile.am new file mode 100644 index 0000000..c7b4f93 --- /dev/null +++ b/src/guile/skribilo/package/eq/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/eq +dist_guilemodule_DATA = lout.scm + +## arch-tag: 3e816c9a-7989-4baa-b38b-a095a5428ba1 diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm new file mode 100644 index 0000000..c487b85 --- /dev/null +++ b/src/guile/skribilo/package/eq/lout.scm @@ -0,0 +1,217 @@ +;;; lout.scm -- Lout implementation of the `eq' package. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package eq lout) + :use-module (skribilo package eq) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :use-module (ice-9 optargs)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Initialization. +;;; + +(let ((lout (find-engine 'lout))) + (if (not lout) + (skribe-error 'eq "Lout engine not found" lout) + (let ((includes (engine-custom lout 'includes))) + ;; Append the `eq' include file + (engine-custom-set! lout 'includes + (string-append includes "\n" + "@SysInclude { eq }\n"))))) + + +;;; +;;; Simple markup writers. +;;; + + +(markup-writer 'eq (find-engine 'lout) + :options '(:inline?) + :before "{ " + :action (lambda (node engine) + (display (if (markup-option node :inline?) + "@E { " + "@Eq { ")) + (let ((eq (markup-body node))) + ;;(fprint (current-error-port) "eq=" eq) + (output eq engine))) + :after " } }") + + + +(define-macro (simple-lout-markup-writer sym . args) + (let* ((lout-name (if (null? args) + (symbol->string sym) + (car args))) + (parentheses? (if (or (null? args) (null? (cdr args))) + #t + (cadr args))) + (precedence (operator-precedence sym)) + + ;; Note: We could use `pmatrix' here but it precludes line-breaking + ;; within equations. + (open-par `(if need-paren? "{ @VScale ( }" "")) + (close-par `(if need-paren? "{ @VScale ) }" ""))) + + `(markup-writer ',(symbol-append 'eq: sym) + (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (< (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column + (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " + ,(if parentheses? + open-par + ""))) + (output op engine) + (display (string-append ,(if parentheses? + close-par + "") + " }")) + (if (pair? (cdr operands)) + (display ,(string-append " " + lout-name + " "))) + (loop (cdr operands))))))))) + + +;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their +;; operands do not need to be enclosed in parentheses. OTOH, since we use a +;; horizontal bar of `/', we don't need to parenthesize its arguments. + + +(simple-lout-markup-writer +) +(simple-lout-markup-writer * "times") +(simple-lout-markup-writer - "-") +(simple-lout-markup-writer / "over" #f) +(simple-lout-markup-writer =) +(simple-lout-markup-writer <) +(simple-lout-markup-writer >) +(simple-lout-markup-writer <=) +(simple-lout-markup-writer >=) + +(define-macro (binary-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let* ((first (car body)) + (second (cadr body)) + (parentheses? (equation-markup? first))) + (display " { { ") + (if parentheses? (display "(")) + (output first engine) + (if parentheses? (display ")")) + (display ,(string-append " } " lout-name " { ")) + (output second engine) + (display " } } ")) + (skribe-error ,(symbol-append 'eq: sym) + "wrong number of arguments" + body)))))) + +(binary-lout-markup-writer expt "sup") +(binary-lout-markup-writer in "element") +(binary-lout-markup-writer notin "notelement") + +(markup-writer 'eq:apply (find-engine 'lout) + :action (lambda (node engine) + (let ((func (car (markup-body node)))) + (output func engine) + (display "(") + (let loop ((operands (cdr (markup-body node)))) + (if (null? operands) + #t + (begin + (output (car operands) engine) + (if (not (null? (cdr operands))) + (display ", ")) + (loop (cdr operands))))) + (display ")")))) + + + +;;; +;;; Sums, products, integrals, etc. +;;; + +(define-macro (range-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to)) + (body (markup-body node))) + (display ,(string-append " { big " lout-name + " from { ")) + (output from engine) + (display " } to { ") + (output to engine) + (display " } { ") + (output body engine) + (display " } } "))))) + +(range-lout-markup-writer sum "sum") +(range-lout-markup-writer product "prod") + +(markup-writer 'eq:script (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node)) + (sup (markup-option node :sup)) + (sub (markup-option node :sub))) + (display " { { ") + (output body engine) + (display " } ") + (if sup + (begin + (display (if sub " supp { " " sup { ")) + (output sup engine) + (display " } "))) + (if sub + (begin + (display " on { ") + (output sub engine) + (display " } "))) + (display " } ")))) + + +;;; arch-tag: 2a1410e5-977e-4600-b781-3d57f4409b35 diff --git a/src/guile/skribilo/package/french.scm b/src/guile/skribilo/package/french.scm new file mode 100644 index 0000000..a23d1da --- /dev/null +++ b/src/guile/skribilo/package/french.scm @@ -0,0 +1,30 @@ +;;; french.scm -- French Skribe style +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package french)) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/src/guile/skribilo/package/jfp.scm b/src/guile/skribilo/package/jfp.scm new file mode 100644 index 0000000..913b3e3 --- /dev/null +++ b/src/guile/skribilo/package/jfp.scm @@ -0,0 +1,328 @@ +;;; jfp.scm -- The Skribe style for JFP articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package jfp)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (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 + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (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 #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/src/guile/skribilo/package/letter.scm b/src/guile/skribilo/package/letter.scm new file mode 100644 index 0000000..91d45be --- /dev/null +++ b/src/guile/skribilo/package/letter.scm @@ -0,0 +1,157 @@ +;;; letter.scm -- Skribe style for letters +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package letter)) + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :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) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; 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))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "<table width=\"100%\">\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :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) + (display "<tr><td align='left'>") + (output n e) + (when hd + (display "</td><td align='right'>") + (output hd e) + (set! hd #f)) + (display "</td></tr>\n")) + ;; name + (if name (row name)) + ;; 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))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "</table>\n<hr>\n\n")) + + diff --git a/src/guile/skribilo/package/lncs.scm b/src/guile/skribilo/package/lncs.scm new file mode 100644 index 0000000..8ffa7da --- /dev/null +++ b/src/guile/skribilo/package/lncs.scm @@ -0,0 +1,158 @@ +;;; lncs.scm -- The Skribe style for LNCS articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package lncs)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/pie.scm b/src/guile/skribilo/package/pie.scm new file mode 100644 index 0000000..8ccf858 --- /dev/null +++ b/src/guile/skribilo/package/pie.scm @@ -0,0 +1,314 @@ +;;; pie.scm -- An pie-chart formatting package. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package pie) + :autoload (skribilo ast) (markup? markup-ident ast-parent) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) ;; `skribe-error' et al. + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :use-module (skribilo utils strings) ;; `make-string-replace' + :use-module (skribilo module) + :autoload (skribilo color) (skribe-color->rgb) + :autoload (skribilo package base) (bold) + :autoload (skribilo engine lout) (lout-illustration) + :autoload (ice-9 popen) (open-output-pipe) + :use-module (ice-9 optargs) + :export (%ploticus-program %ploticus-debug? + pie-sliceweight-value pie-remove-markup)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Markup. +;;; + +(define-markup (pie :rest opts + :key (ident #f) (title "Pie Chart") + (initial-angle 0) (total #f) (radius 3) + (fingers? #t) (labels 'outside) + (class "pie")) + (new container + (markup 'pie) + (ident (or ident (symbol->string (gensym "pie")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (slice :rest opts + :key (ident #f) (weight 1) (color "white") (detach? #f)) + (new container + (markup 'slice) + (ident (or ident (symbol->string (gensym "slice")))) + (weight weight) + (color color) + (detach? detach?) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (sliceweight :rest opts + :key (ident #f) (percentage? #f)) + (new markup + (markup 'sliceweight) + (ident (or ident (symbol->string (gensym "sliceweight")))) + (percentage? percentage?) + (options (the-options opts)) + (body '()))) + + + +;;; +;;; Helper functions. +;;; + +(define (make-rounder pow10) + ;; Return a procedure that round to 10 to the -POW10. + (let ((times (expt 10.0 pow10))) + (lambda (x) + (/ (round (* x times)) times)))) + +(define (pie-sliceweight-value sw-node pct?) + "Return the value that should be displayed by `sw-node', a + `sliceweight' markup node. If `pct?' is true, then this value + should be a percentage." + (let* ((the-slice (ast-parent sw-node)) + (weight (and the-slice (markup-option the-slice :weight)))) + (if (not the-slice) + (skribe-error 'lout + "`sliceweight' node not within a `slice' body" + sw-node) + (if pct? + (let* ((the-pie (ast-parent the-slice)) + (total (and the-pie + (markup-option the-pie + '&total-weight)))) + (if (not the-pie) + (skribe-error 'lout + "`slice' not within a `pie' body" + the-slice) + (* 100.0 (/ weight total)))) ;; flonum (FIXME: precision) + + weight)))) + +(define (pie-remove-markup node) + "Remove markup from `node', ie. turn something like `(it \"hello\")' into +the string \"hello\". Implement `sliceweight' markups too." + (define percentage-round (make-rounder 2)) + + (if (markup? node) + (if (and node (is-markup? node 'sliceweight)) + (let* ((pct? (markup-option node :percentage?)) + (value (pie-sliceweight-value node pct?))) + (number->string (percentage-round value))) + (pie-remove-markup (markup-body node))) + (if (list? node) + (apply string-append (map pie-remove-markup node)) + node))) + +(define strip-newlines (make-string-replace '((#\newline " ")))) + +(define (select-output-format engine) + ;; Choose an ouptut format suitable for ENGINE. + (define %supported-formats '("png" "ps" "eps" "svg" "svgz")) + (define %default-format "png") + + (let ((fmt (engine-custom engine 'image-format))) + (cond ((string? fmt) fmt) + ((and (list? fmt) (not (null? fmt))) + (let ((f (car fmt))) + (if (member f %supported-formats) + f + %default-format))) + (else %default-format)))) + + +;;; +;;; Default implementation (`base' engine). +;;; + +;; Ploticus-based implementation of pie charts, suitable for most engines. +;; See http://ploticus.sf.net for info about Ploticus. + +(define %ploticus-program "ploticus") +(define %ploticus-debug? #f) + +(define (color-spec->ploticus color-spec) + (define round (make-rounder 2)) + + (call-with-values (lambda () (skribe-color->rgb color-spec)) + (lambda (r g b) + (format #f "rgb(~a,~a,~a)" + (round (/ r 255.0)) + (round (/ g 255.0)) + (round (/ b 255.0)))))) + +(define (ploticus-script pie) + (let* ((weights (map (lambda (slice) + (markup-option slice :weight)) + (markup-body pie))) + (colors (map (lambda (slice) + (let ((c (markup-option slice :color))) + (string-append (color-spec->ploticus c) + " "))) + (markup-body pie))) + (total-weight (or (if (number? (markup-option pie + :total)) + (markup-option pie :total) + #f) + (apply + weights))) + + ;; Attach useful information to the pie and its slices + (-/- (markup-option-add! pie '&total-weight total-weight)) + + ;; One slice label per line -- so we need to remove + ;; newlines from labels. + (labels (map (lambda (b) + (strip-newlines (pie-remove-markup b))) + (markup-body pie))) + +; (flat-title (map pie-remove-markup +; (markup-option pie :title))) + (detached (map (lambda (slice) + (let ((d (markup-option slice + :detach?))) + (cond ((number? d) d) + (d 0.5) ;; default + (#t 0)))) + (markup-body pie))) + + (initial-angle (or (markup-option pie :initial-angle) + 0)) + (radius (or ;;FIXME + (markup-option pie :radius) 3)) + (max-radius (+ radius (apply max detached))) + + ;; center coordinates must take into account (i) the + ;; maxium radius when detached slices are considered and + ;; (ii) the fact that labels may get displayed to the + ;; left of the pie. + ;; FIXME: labels to the left (ii) end up being truncated + ;; when the radius is e.g. < 2. + (center `(,(+ max-radius + (* max-radius max-radius)) . + ,(* max-radius max-radius)))) + + (apply string-append + (append (list "#proc getdata\n" "data: ") + (map (lambda (weight) + (string-append (number->string weight) + "\n")) + weights) + `("\n" +; "#proc page\n" +; "title " ,@flat-title +; "\n" + "#proc pie\n" + "total: " + ,(number->string total-weight) + "\n" + "datafield: " "1" "\n") + `("firstslice: " ,(number->string initial-angle) "\n") + `("radius: " ,(number->string radius) "\n") + `("center: " ,(number->string (car center)) + " " ,(number->string (cdr center)) "\n") + `("labelmode: " + ,(case (markup-option + pie :labels) + ((outside) "line+label") + ((inside) "labelonly") + ((legend) "legend") + (else "legend")) + "\n" + "labels: " ,@(map (lambda (label) + (string-append label "\n")) + labels) + "\n") + `("explode: " + ,@(map (lambda (number) + (string-append (number->string number) + " ")) + detached) + "\n") + `("colors: " ,@colors "\n"))))) + +(markup-writer 'pie (find-engine 'base) + :action (lambda (node engine) + (let* ((fmt (select-output-format engine)) + (pie-file (string-append (markup-ident node) "." + fmt)) + (port (open-output-pipe + (string-append %ploticus-program + " -o " pie-file + " -cm -" fmt " -stdin"))) + (script (ploticus-script node))) + + + (if %ploticus-debug? + (format (current-error-port) "** Ploticus script: ~a" + script)) + + (display script port) + + (let ((exit-val (status:exit-val (close-pipe port)))) + (if (not (eqv? 0 exit-val)) + (skribe-error 'pie/ploticus + "ploticus exited with error code" + exit-val))) + + (if (not (file-exists? pie-file)) + (skribe-error 'ploticus + "Ploticus did not create the image file" + script)) + + (if (markup-option node :title) + (output (list (bold (markup-option node :title)) + (linebreak)) + engine)) + + (output (image :file pie-file + :class (markup-option node :class) + (or (markup-option node :title) + "A Pie Chart")) + engine)))) + +(markup-writer 'slice (find-engine 'base) + :action (lambda (node engine) + ;; Nothing to do here + (error "slice: this writer should never be invoked"))) + +(markup-writer 'sliceweight (find-engine 'base) + :action (lambda (node engine) + ;; Nothing to do here. + (error "sliceweight: this writer should never be invoked"))) + + +;;; +;;; Initialization. +;;; + +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package pie lout)))) + + +;;; arch-tag: 8095d8f6-b810-4619-9fdb-23fb94a77ee3 diff --git a/src/guile/skribilo/package/pie/Makefile.am b/src/guile/skribilo/package/pie/Makefile.am new file mode 100644 index 0000000..3b4fafd --- /dev/null +++ b/src/guile/skribilo/package/pie/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/pie +dist_guilemodule_DATA = lout.scm + +## arch-tag: e6a03451-14c9-4331-8b96-71bde92ac142 diff --git a/src/guile/skribilo/package/pie/lout.scm b/src/guile/skribilo/package/pie/lout.scm new file mode 100644 index 0000000..61dbcb7 --- /dev/null +++ b/src/guile/skribilo/package/pie/lout.scm @@ -0,0 +1,132 @@ +;;; lout.scm -- Lout implementation of the `pie' package. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package pie lout) + :use-module (skribilo package pie) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :autoload (skribilo engine lout) (lout-color-specification) + :use-module (ice-9 optargs)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Helper functions. +;;; + +(let ((lout (find-engine 'lout))) + (if lout + (engine-custom-set! lout 'includes + (string-append (engine-custom lout 'includes) + "\n@SysInclude { pie } # Pie Charts\n")))) + + + +;;; +;;; Writers. +;;; + +(markup-writer 'pie (find-engine 'lout) + :before (lambda (node engine) + (let* ((weights (map (lambda (slice) + (markup-option slice :weight)) + (markup-body node))) + (total-weight (or (if (number? (markup-option node + :total)) + (markup-option node :total) + #f) + (apply + weights)))) + + (if (= 0 total-weight) + (skribe-error 'lout + "Slices weight sum should not be zero" + total-weight)) + + ;; Attach useful information to the pie and its slices + (markup-option-add! node '&total-weight total-weight) + + (display "\n@Pie\n") + (display " abovecaption { ") + (if (markup-option node :title) + (output (markup-option node :title) engine)) + (display " }\n") + (format #t " totalweight { ~a }\n" total-weight) + (format #t " initialangle { ~a }\n" + (or (markup-option node :initial-angle) 0)) + (format #t " finger { ~a }\n" + (case (markup-option node :labels) + ((outside) (if (markup-option node :fingers?) + "yes" "no")) + (else "no"))) + + ;; We assume `:radius' to be centimeters + (if (markup-option node :radius) + (format #t " radius { ~ac }\n" + (markup-option node :radius))) + + (format #t " labelradius { ~a }\n" + (case (markup-option node :labels) + ((outside #f) "external") ; FIXME: options are + ; not availble within + ; :before? (hence the #f) + + ((inside) "internal") + (else + (skribe-error 'lout + "`:labels' should be one of 'inside or 'outside." + (markup-option node :labels))))) + (display "{\n"))) + :after "\n} # @Pie\n") + +(markup-writer 'slice (find-engine 'lout) + :options '(:weight :detach? :color) + :action (lambda (node engine) + (display " @Slice\n") + (format #t " detach { ~a }\n" + (if (markup-option node :detach?) + "yes" + "no")) + (format #t " paint { ~a }\n" + (lout-color-specification (markup-option node + :color))) + (format #t " weight { ~a }\n" + (markup-option node :weight)) + + (display " label { ") + (output (markup-body node) engine) + (display " }\n"))) + +(markup-writer 'sliceweight (find-engine 'base) + ;; This writer should work for every engine, provided the `pie' markup has + ;; a proper `&total-weight' option. + :action (lambda (node engine) + (let ((pct? (markup-option node :percentage?))) + (output (number->string + (pie-sliceweight-value node pct?)) + engine)))) + +;;; arch-tag: b5221e30-f80e-4b72-a281-83ce19ddb755 diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm new file mode 100644 index 0000000..902cdb5 --- /dev/null +++ b/src/guile/skribilo/package/scribe.scm @@ -0,0 +1,240 @@ +;;; scribe.scm -- Scribe Compatibility kit +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package scribe)) + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/package/sigplan.scm b/src/guile/skribilo/package/sigplan.scm new file mode 100644 index 0000000..28d4e83 --- /dev/null +++ b/src/guile/skribilo/package/sigplan.scm @@ -0,0 +1,166 @@ +;;; sigplan.scm -- The Skribe style for ACMPROC articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package sigplan)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/skribe.scm b/src/guile/skribilo/package/skribe.scm new file mode 100644 index 0000000..86969aa --- /dev/null +++ b/src/guile/skribilo/package/skribe.scm @@ -0,0 +1,85 @@ +;;; skribe.scm -- The standard Skribe style (always loaded). +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm new file mode 100644 index 0000000..7f731e3 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,274 @@ +;;; slide.scm -- Overhead transparencies. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-skribe-module (skribilo package slide)) + + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define-public &slide-load-options (skribe-load-options)) + + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +;; Extend the definition of `ref'. +;; FIXME: This technique breaks `ref' for some reason. +; (set! ref +; (lambda args +; ;; Filter out ARGS and look for a `:slide' keyword argument. +; (let loop ((slide #f) +; (opt '()) +; (args args)) +; (if (null? args) +; (set! opt (reverse! opt)) +; (let ((s? (eq? (car args) :slide))) +; (loop (if s? (cadr args) #f) +; (if s? opt (cons (car args) opt)) +; (if s? (cddr args) (cdr args))))) + +; (format (current-error-port) +; "slide.scm:ref: slide=~a opt=~a~%" slide opt) + +; (if (not slide) +; (apply %slide-old-ref opt) +; (new unresolved +; (proc (lambda (n e env) +; (cond +; ((eq? slide 'next) +; (let ((c (assq n %slide-the-slides))) +; (if (pair? c) +; (handle (cadr c)) +; #f))) +; ((eq? slide 'prev) +; (let ((c (assq n (reverse %slide-the-slides)))) +; (if (pair? c) +; (handle (cadr c)) +; #f))) +; ((number? slide) +; (let loop ((s %slide-the-slides)) +; (cond +; ((null? s) +; #f) +; ((= slide (markup-option +; (car s) :number)) +; (handle (car s))) +; (else +; (loop (cdr s)))))) +; (else +; #f))))))))) + + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + + + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define-public (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* slide-topic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-topic #!rest opt + #!key title (outline? #t) + (ident #f) (class "slide-topic")) + (new container + (markup 'slide-topic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-topic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-subtopic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-subtopic #!rest opt + #!key title (outline? #f) + (ident #f) (class "slide-subtopic")) + (new container + (markup 'slide-subtopic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + + + +;;; +;;; Initialization. +;;; + +(format (current-error-port) "Slides initializing...~%") + +;; Register specific implementations for lazy loading. +(when-engine-is-loaded 'base + (lambda () + (resolve-module '(skribilo package slide base)))) +(when-engine-is-loaded 'latex + (lambda () + (resolve-module '(skribilo package slide latex)))) +(when-engine-is-loaded 'html + (lambda () + (resolve-module '(skribilo package slide html)))) +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package slide lout)))) + diff --git a/src/guile/skribilo/package/slide/Makefile.am b/src/guile/skribilo/package/slide/Makefile.am new file mode 100644 index 0000000..53320fa --- /dev/null +++ b/src/guile/skribilo/package/slide/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/slide +dist_guilemodule_DATA = base.scm latex.scm html.scm lout.scm + +## arch-tag: 56b5fa5c-bb6a-4692-b929-74bdd032431c diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm new file mode 100644 index 0000000..c8e652c --- /dev/null +++ b/src/guile/skribilo/package/slide/base.scm @@ -0,0 +1,185 @@ +;;; base.scm -- Overhead transparencies, `base' engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package slide base) + :use-module (skribilo utils syntax) + + :use-module (skribilo package slide) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :autoload (skribilo package base) (symbol color itemize item) + + :use-module (srfi srfi-1) + + :export (%slide-outline-title %slide-outline-itemize-symbols)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Simple markups. +;;; +(let ((be (find-engine 'base))) + + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + + +;;; +;;; Helper functions for the default topic/subtopic handling. +;;; + +(define (make-subtopic-list node recurse?-proc make-entry-proc + itemize-symbols) + ;; Make a list of the subtopic of `node'. Go recursive if `recurse?-proc' + ;; returns true. `make-entry-proc' is passed a node and returns an entry + ;; (a markup) for this node. `itemize-symbols' is a (circular) list + ;; containing the symbols to be passed to `itemize'. + (let* ((subtopic? (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide)))) + (subtopic-types (if (is-markup? node 'slide-topic) + '(slide-subtopic slide) + '(slide-topic)))) + (if (subtopic? node) + '() + (apply itemize + `(,@(if (is-markup? (car itemize-symbols) 'symbol) + `(:symbol ,(car itemize-symbols)) + '()) + ,@(map (lambda (t) + (item + (make-entry-proc t) + (if (recurse?-proc t) + (make-subtopic-list t recurse?-proc + make-entry-proc + (cdr itemize-symbols)) + '()))) + (filter (lambda (n) + (and (markup? n) + (member (markup-markup n) + subtopic-types))) + (markup-body node)))))))) + +(define (make-topic-list current-topic recurse? make-entry-proc) + ;; Make a full topic list of the document which contains + ;; `current-topic'. Here, `make-entry-proc' takes a topic node and + ;; the current topic node as its arguments. + (let ((doc (ast-document current-topic))) + (make-subtopic-list doc + (lambda (t) + (and recurse? (eq? t current-topic))) + (lambda (t) + (make-entry-proc t current-topic)) + %slide-outline-itemize-symbols))) + +(define (make-topic-entry topic current-topic) + ;; Produce an entry for `topic'. Colorize it based on the fact + ;; that the current topic is `current-topic' (it may need to be + ;; hightlighted). + (let ((title (markup-option topic :title)) + (current? (eq? topic current-topic))) + (color :fg (if current? "#000000" "#666666") + (apply (if current? bold (lambda (x) x)) + (list (markup-option topic :title)))))) + + +;;; +;;; Default topic/subtopic handling. +;;; + +;; Title for the automatically-generated outline slide. +(define %slide-outline-title "") + +;; Circular list of symbols to be passed to `itemize' in outlines. +(define %slide-outline-itemize-symbols + (let loop ((names '(#t "-" "bullet" "->" "middot"))) + (if (null? names) + '() + (cons (if (string? (car names)) + (symbol (car names)) + (car names)) + (loop (cdr names)))))) + + +(define (make-outline-slide topic engine) + (let ((parent-topic (if (is-markup? topic 'slide-topic) + topic + (find1-up (lambda (n) + (is-markup? n 'slide-topic)) + topic)))) + (output (slide :title %slide-outline-title :toc #f + :class (markup-option topic :class) + ;; The mark below is needed for cross-referencing by PDF + ;; bookmarks. + (if (markup-ident topic) (mark (markup-ident topic)) "") + (p (make-topic-list parent-topic #t + make-topic-entry))) + engine))) + + +(markup-writer 'slide-topic (find-engine 'base) + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (if (markup-option n :outline?) + (make-outline-slide n e)) + + (output (markup-body n) e))) + +(markup-writer 'slide-subtopic (find-engine 'base) + ;; FIXME: Largely untested. + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (if (markup-option n :outline?) + (make-outline-slide n e)) + + (output (markup-body n) e))) + + +;;; arch-tag: 1187ce0c-3ffc-4248-b68b-a7c77d6598b9 diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm new file mode 100644 index 0000000..d47ef82 --- /dev/null +++ b/src/guile/skribilo/package/slide/html.scm @@ -0,0 +1,144 @@ +;;; html.scm -- HTML implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide html) + :use-module (skribilo package slide)) + + +(define-public (%slide-html-initialize!) + (let ((he (find-engine 'html))) + (skribe-message "HTML slides setup...\n") + ;; &html-page-title + (markup-writer '&html-document-title he + ;;:predicate (lambda (n e) %slide-initialized) + :action html-slide-title) + ;; slide + (markup-writer 'slide he + :options '(:title :number :transition :toc :bg) + :before (lambda (n e) + (printf "<a name=\"~a\">" (markup-ident n)) + (display "<br>\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format #f "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "<br>") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "<br>"))))) + + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-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))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (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>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + + + +;;; +;;; Slide topics/subtopics. +;;; + +(markup-writer 'slide-topic (find-engine 'html) + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (let ((title (markup-option n :title)) + (body (markup-body n))) + (display "\n<h2 class=\"slide-topic:title\">") + (if (markup-ident n) + (printf "<a name=\"~a\"></a>" (markup-ident n))) + (output title e) + (display "</h2> <br>\n") + (display "\n<div class=\"slide-topic:slide-list\">") + (for-each (lambda (s) + (output (markup-option s :title) e) + (display " -- ")) + (filter (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide))) + (markup-body n))) + (display "\n</div> <!-- slide-topic:slide-list -->") + (display "\n<hr><br>\n") + + ;; the slides + (output (markup-body n) e)))) + + +;;; +;;; Initialization. +;;; + +(%slide-html-initialize!) + + +;;; arch-tag: 8be0cdf2-b755-4baa-baf6-739cdd00e193 diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm new file mode 100644 index 0000000..e187d3c --- /dev/null +++ b/src/guile/skribilo/package/slide/latex.scm @@ -0,0 +1,394 @@ +;;; latex.scm -- LaTeX implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide latex) + :use-module (skribilo package slide)) + + +(define-public %slide-latex-mode 'seminar) + +(define-public (%slide-latex-initialize!) + (skribe-message "LaTeX slides setup...\n") + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode)))) + + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +;;; FIXME: We shouldn't load `latex.scm' from here. Instead, we should +;;; register a hook on its load. +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format #f "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) + + + +;;; +;;; Initialization. +;;; + +(%slide-latex-initialize!) + +;;; arch-tag: b99e2c65-55f7-462c-8482-f47c7e223538 diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm new file mode 100644 index 0000000..d53cff1 --- /dev/null +++ b/src/guile/skribilo/package/slide/lout.scm @@ -0,0 +1,151 @@ +;;; lout.scm -- Lout implementation of the `slide' package. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide lout) + :use-module (skribilo utils syntax) + + ;; XXX: If changing the following `autoload' to `use-module' doesn't work, + ;; then you need to fix your Guile. See this thread about + ;; `make-autoload-interface': + ;; + ;; http://article.gmane.org/gmane.lisp.guile.devel/5748 + ;; http://lists.gnu.org/archive/html/guile-devel/2006-03/msg00004.html . + + :autoload (skribilo engine lout) (lout-tagify lout-output-pdf-meta-info + lout-verbatim-encoding)) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; TODO: +;;; +;;; Make some more PS/PDF trickery. + +(format (current-error-port) "Lout slides setup...~%") + +(let ((le (find-engine 'lout))) + + ;; FIXME: Automatically switching to `slides' is problematic, e.g., for the + ;; user manual which embeds slides. +; ;; Automatically switch to the `slides' document type. +; (engine-custom-set! le 'document-type 'slides)) + + (markup-writer 'slide le + :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) + + :validate (lambda (n e) + (eq? (engine-custom e 'document-type) 'slides)) + + :before (lambda (n e) + (display "\n@Overhead\n") + (display " @Title { ") + (output (markup-option n :title) e) + (display " }\n") + (if (markup-ident n) + (begin + (display " @Tag { ") + (display (lout-tagify (markup-ident n))) + (display " }\n"))) + (if (markup-option n :number) + (begin + (display " @BypassNumber { ") + (output (markup-option n :number) e) + (display " }\n"))) + (display "@Begin\n") + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after "@End @Overhead\n") + + (markup-writer 'slide-vspace le + :options '(:unit) + :validate (lambda (n e) + (and (pair? (markup-body n)) + (number? (car (markup-body n))))) + :action (lambda (n e) + (printf "\n//~a~a # slide-vspace\n" + (car (markup-body n)) + (case (markup-option n :unit) + ((cm) "c") + ((point points pt) "p") + ((inch inches) "i") + (else + (skribe-error 'lout + "Unknown vspace unit" + (markup-option n :unit))))))) + + (markup-writer 'slide-pause le + ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. + ;; << /Type /Action + ;; << /S /Trans + ;; entry in the trans dict + ;; << /Type /Trans /S /Dissolve >> + :action (lambda (n e) + (let ((filter (make-string-replace lout-verbatim-encoding)) + (pdfmark " +[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) + (display (lout-embedded-postscript-code + (filter pdfmark)))))) + + ;; For movies, see + ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . + (markup-writer 'slide-embed le + :options '(:alt :geometry :rgeometry :geometry-opt :command) + ;; FIXME: `pdfmark'. + ;; << /Type /Action /S /Launch + :action (lambda (n e) + (let ((command (markup-option n :command)) + (filter (make-string-replace lout-verbatim-encoding)) + (pdfmark "[ /Rect [ 0 ysize xsize 0 ] +/Name /Comment +/Contents (This is an embedded application) +/ANN pdfmark + +[ /Type /Action +/S /Launch +/F (~a) +/OBJ pdfmark")) + (display (string-append + "4c @Wide 3c @High " + (lout-embedded-postscript-code + (filter (format #f pdfmark command))))))))) + + + +;;; +;;; Customs for a nice handling of topics/subtopics. +;;; + +(let ((lout (find-engine 'lout))) + (if lout + (begin + (engine-custom-set! lout 'pdf-bookmark-node-pred + (lambda (n e) + (or (is-markup? n 'slide) + (is-markup? n 'slide-topic) + (is-markup? n 'slide-subtopic)))) + (engine-custom-set! lout 'pdf-bookmark-closed-pred + (lambda (n e) #f))))) + + +;;; arch-tag: 0c717553-5cbb-46ed-937a-f844b6aeb145 diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm new file mode 100644 index 0000000..6d1b7a5 --- /dev/null +++ b/src/guile/skribilo/package/web-article.scm @@ -0,0 +1,241 @@ +;;; web-article.scm -- A Skribe style for producing web articles +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package web-article)) + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web 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))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><b>" tfont) + (output title e) + (display "</b></font>")) + (begin + (printf "<h1>") + (output title e) + (display "</h1>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-document-title ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-document-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (id (markup-ident n))) + ;; the title + (printf "<div id=\"~a\" class=\"document-title-title\">\n" + (string-canonicalize id)) + (output title e) + (display "</div>\n") + ;; the authors + (printf "<div id=\"~a\" class=\"document-title-authors\">\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "</div>\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-author ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-author 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))) + (when name + (printf "<span class=\"document-author-name\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output name e) + (display "</span>\n")) + (when title + (printf "<span class=\"document-author-title\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output title e) + (display "</span>\n")) + (when affiliation + (printf "<span class=\"document-author-affiliation\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "</span>\n")) + (when (pair? address) + (printf "<span class=\"document-author-address\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "</span>\n")) + (when phone + (printf "<span class=\"document-author-phone\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "</span>\n")) + (when email + (printf "<span class=\"document-author-email\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output email e) + (display "</span>\n")) + (when url + (printf "<span class=\"document-author-url\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output url e) + (display "</span>\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML settings */ +;*---------------------------------------------------------------------*/ +(define (web-article-modern-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :action html-document-title-web) + ;; section + (markup-writer 'section he + :options 'all + :before "<br>" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background))) + (markup-writer 'section e1 + :options 'all + :action (lambda (n e2) (output n e sec))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg n)) + e1)))) + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before "<br>" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background)) + (fg (engine-custom he 'subsection-title-foreground))) + (markup-writer '&html-footnotes e1 + :options 'all + :action (lambda (n e2) + (invoke (writer-action ft) n e))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg :fg fg n)) + e1)))))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-setup ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :before (lambda (n e) + (printf "<div id=\"~a\" class=\"document-title\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "</div>\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "<span id=\"~a\" class=\"document-author\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "</span\n") + ;; section + (markup-writer 'section he + :options 'all + :before (lambda (n e) + (printf "<div class=\"section\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "</div>\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "<div class=\"footnotes\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "</div>\n"))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &web-article-load-options) + (p (memq :style opt)) + (css (memq :css opt)) + (he (find-engine 'html))) + (cond + ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) + (web-article-css-setup he)) + ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) + (engine-custom-set! he 'css (cadr css)) + (web-article-css-setup he)) + (else + (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm new file mode 100644 index 0000000..49197f1 --- /dev/null +++ b/src/guile/skribilo/package/web-book.scm @@ -0,0 +1,121 @@ +;;; web-book.scm -- The Skribe web book style. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package web-book)) + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (let ((text (bold "main page")) + (bg (engine-custom e 'background))) + (if bg (color :fg bg text) text)))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (let ((title (bold (markup-option n :title))) + (bg (engine-custom e 'background))) + (if bg (color :fg title) title)))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (let ((text (bold (if chap "Chapters" "Sections"))) + (bg (engine-custom e 'background))) + (if bg (color :fg bg text) text)))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/src/guile/skribilo/parameters.scm b/src/guile/skribilo/parameters.scm new file mode 100644 index 0000000..5893851 --- /dev/null +++ b/src/guile/skribilo/parameters.scm @@ -0,0 +1,88 @@ +;;; parameters.scm -- Skribilo settings as parameter objects. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo parameters) + :use-module (srfi srfi-39)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines parameter objects that may be used to specify +;;; run-time parameters of a Skribilo process. +;;; +;;; Code: + + +;;; +;;; Switches. +;;; + +(define (make-expect pred pred-name parameter) + (let ((msg (string-append parameter ": " pred-name " expected"))) + (lambda (val) + (if (pred val) + val + (error msg val))))) + +(define-macro (define-number-parameter name) + `(define-public ,name + (make-parameter 0 + (make-expect number? "number" ,(symbol->string name))))) + +(define-number-parameter *verbose*) +(define-number-parameter *warning*) + +(define-public *load-rc-file?* (make-parameter #f)) + +;;; +;;; Paths. +;;; + + +(define-macro (define-path-parameter name) + `(define-public ,name + (make-parameter (list ".") + (make-expect list? "list" ,(symbol->string name))))) + + +(define-path-parameter *document-path*) +(define-path-parameter *bib-path*) +(define-path-parameter *source-path*) +(define-path-parameter *image-path*) + + +;;; +;;; Files. +;;; + +(define-public *destination-file* (make-parameter "output.html")) +(define-public *source-file* (make-parameter "default-input-file.skb")) + +;; Base prefix to remove from hyperlinks. +(define-public *ref-base* (make-parameter "")) + +;;; TODO: Skribe used to have other parameters as global variables. See +;;; which ones need to be kept. + + +;;; arch-tag: 3c0d2e18-b997-4615-8a3d-b6622ae28874 + +;;; parameters.scm ends here diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm new file mode 100644 index 0000000..266d607 --- /dev/null +++ b/src/guile/skribilo/prog.scm @@ -0,0 +1,220 @@ +;;; prog.scm -- All the stuff for the prog markup +;;; +;;; Copyright 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo prog) + :use-module (ice-9 regex) + :autoload (ice-9 receive) (receive) + :use-module (skribilo lib) ;; `new' + :autoload (skribilo ast) (node? node-body) + :export (make-prog-body resolve-line)) + +;;; ====================================================================== +;;; +;;; COMPATIBILITY +;;; +;;; ====================================================================== +(define pregexp-match string-match) +(define pregexp-replace (lambda (rx str what) + (regexp-substitute/global #f rx str + 'pre what 'post))) +(define pregexp-quote regexp-quote) + + +(define (node-body-set! b v) + (slot-set! b 'body v)) + +;;; +;;; FIXME: Tout le module peut se factoriser +;;; définir en bigloo node-body-set + + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +;; FIXME: Removed that global. Rework the thing. +(define *lines* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m line-ident b) + (let* ((n (list (mark line-ident) b))) + (hash-set! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hash-ref *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((list? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (receive (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((node? line) + (receive (m l) + (extract-mark (node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((= r2 l) + (if (= r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+ r2 1) + (+ r2 1) + (if (= r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+ r2 1) + res)))))) + ((list? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (number->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + + (let* ((regexp (and mark + (format #f "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (number->string (+ (if (integer? ldigit) + (max lnum (expt 10 (- ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (receive (m l) + (extract-mark (car lines) mark regexp) + (let* ((line-ident (symbol->string (gensym "&prog-line"))) + (n (new markup + (markup '&prog-line) + (ident line-ident) + (body (if m (make-line-mark m line-ident l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) + diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm new file mode 100644 index 0000000..871d92c --- /dev/null +++ b/src/guile/skribilo/reader.scm @@ -0,0 +1,106 @@ +;;; reader.scm -- Skribilo's front-end (aka. reader) interface. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader) + :use-module (srfi srfi-9) ;; records + :use-module (srfi srfi-17) ;; generalized `set!' + :use-module (srfi srfi-39) ;; parameter objects + :use-module (skribilo condition) + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :export (%make-reader lookup-reader make-reader + %default-reader *document-reader* + + &reader-search-error reader-search-error? + reader-search-error:reader) + :export-syntax (define-reader define-public-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module contains Skribilo's front-end (aka. ``reader'') interface. +;;; Skribilo's default reader is `(skribilo reader skribe)' which provides a +;;; reader for the Skribe syntax. +;;; +;;; Code: + +(define-record-type <reader> + (%make-reader name version make) + reader? + (name reader:name reader:set-name!) ;; a symbol + (version reader:version reader:set-version!) ;; a string + (make reader:make reader:set-make!)) ;; a one-argument proc + ;; that returns a reader + ;; proc + +(define-public reader:name + (getter-with-setter reader:name reader:set-name!)) + +(define-public reader:version + (getter-with-setter reader:version reader:set-version!)) + +(define-public reader:make + (getter-with-setter reader:make reader:set-make!)) + +(define-macro (define-reader name version make-proc) + `(define reader-specification + (%make-reader (quote ,name) ,version ,make-proc))) + +(define-macro (define-public-reader name version make-proc) + `(define-reader ,name ,version ,make-proc)) + + +;;; Error condition. + +(define-condition-type &reader-search-error &skribilo-error + reader-search-error? + (reader reader-search-error:reader)) + + + +;;; The mechanism below is inspired by Guile-VM code written by K. Nishida. + +(define (lookup-reader name) + "Look for a reader named @var{name} (a symbol) in the @code{(skribilo +reader)} module hierarchy. If no such reader was found, an error is +raised." + (let ((m (false-if-exception + (resolve-module `(skribilo reader ,name))))) + (if (and (module? m) + (module-bound? m 'reader-specification)) + (module-ref m 'reader-specification) + (raise (condition (&reader-search-error (reader name))))))) + +(define (make-reader name) + "Look for reader @var{name} and instantiate it." + (let* ((spec (lookup-reader name)) + (make (reader:make spec))) + (make))) + +(define %default-reader (make-reader 'skribe)) + + +;;; Current document reader. + +(define *document-reader* (make-parameter %default-reader)) + + +;;; reader.scm ends here diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..807e4a7 --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm outline.scm diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm new file mode 100644 index 0000000..09792f5 --- /dev/null +++ b/src/guile/skribilo/reader/outline.scm @@ -0,0 +1,426 @@ +;;; outline.scm -- A reader for Emacs' outline syntax. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader outline) + :use-module (skribilo utils syntax) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-11) + + :autoload (ice-9 rdelim) (read-line) + :autoload (ice-9 regex) (make-regexp) + + :export (reader-specification + make-outline-reader)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for Emacs' outline-mode syntax. +;;; +;;; Code: + +;;; TODO: +;;; +;;; - add source position information; +;;; - handle `blockquote' (indented paragraph); +;;; - handle sublists (indented lists) --- optional; +;;; - handle inline Skribe code: `\n{skribe\n(table (tr ... ))\n}\n' + + + + +;;; +;;; Tools. +;;; + +(define (apply-any procs args) + "Apply the procedure listed in @var{procs} to @var{args} until one of these +procedure returns true." + (let loop ((procs procs)) + (if (null? procs) + #f + (let ((result (apply (car procs) args))) + (if result result (loop (cdr procs))))))) + +(define (make-markup name body) + "Return a clean markup form, i.e., an s-exp whose @code{car} is a symbol +equal to @var{name}, a markup name." + (cond ((list? body) + (cond ((null? body) `(,name)) + ((symbol? (car body)) `(,name ,body)) + (else `(,name ,@body)))) + (else + (list name body)))) + + +(define (append-trees . trees) + "Append markup trees @var{trees}. Trees whose car is a symbol (e.g., +@code{(bold \"paf\")} will be considered as sub-trees of the resulting tree." + (let loop ((trees trees) + (result '())) + (if (null? trees) + result + (let ((tree (car trees))) + (loop (cdr trees) + (append result + (if (list? tree) + (cond ((null? tree) '()) + ((symbol? (car tree)) (list tree)) + (else tree)) + (list tree)))))))) + +(define (null-string? s) + (and (string? s) (string=? s ""))) + + +(define empty-line-rx (make-regexp "^([[:space:]]*|;.*)$")) +(define (empty-line? s) + "Return true if string @var{s} denotes an ``empty'' line, i.e., a blank +line or a line comment." + (regexp-exec empty-line-rx s)) + + + +;;; +;;; In-line markup, i.e., markup that doesn't span over multiple lines. +;;; + +(define %inline-markup + ;; Note: the order matters because, for instance, URLs must be searched for + ;; _before_ italics (`/italic/'). + `(("_([^_]+)_" . + ,(lambda (m) + (values (match:prefix m) ;; before + (match:substring m 1) ;; body + (match:suffix m) ;; after + (lambda (body) `(emph ,body))))) ;; process-body + ("(f|ht)tp://[a-zA-Z0-9\\._~%/-]+" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m) + (match:suffix m) + (lambda (url) `(ref :url ,url))))) + ("\\/([^\\/]+)\\/" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(it ,body))))) + ("\\*([^\\*]+)\\*" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(bold ,body))))) + ("``(([^`^'])+)''" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(q ,body))))) + ("`(([^`^'])+)'" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(tt ,body))))))) + +(define (make-markup-processor rx proc) + (lambda (line) + (let ((match (regexp-exec rx line))) + (if match + (proc match) + #f)))) + +(define (make-line-processor markup-alist) + "Returns a @dfn{line processor}. A line processor is a procedure that +takes a string and returns a list." + (let* ((markups (map (lambda (rx+proc) + (cons (make-regexp (car rx+proc) regexp/extended) + (cdr rx+proc))) + markup-alist)) + (procs (map (lambda (rx+proc) + (make-markup-processor (car rx+proc) (cdr rx+proc))) + markups))) + (lambda (line) + (let self ((line line)) + ;;(format #t "self: ~a~%" line) + (cond ((string? line) + (let ((result (apply-any procs (list line)))) + (if result + (let-values (((before body after proc-body) + result)) + (let ((body+ + (if (string=? (string-append before body after) + line) + body (self body)))) + (if (and (null-string? before) + (null-string? after)) + (proc-body body+) + (append-trees (self before) + (proc-body body+) + (self after))))) + line))) + (else + (error "line-processor: internal error" line))))))) + +(define %line-processor + (make-line-processor %inline-markup)) + + + +;;; +;;; Large-scale structures: paragraphs, chapters, sections, etc. +;;; + +(define (process-paragraph line line-proc port) + (let loop ((line line) + (result '())) + (if (or (eof-object? line) (empty-line? line)) + (cons 'p result) + (loop (read-line port) + (let ((line (line-proc line))) + (append-trees result line "\n")))))) + +(define (make-list-processor rx node-type extract-line-proc line-proc + end-of-node?) + "Return a procedure (a @dfn{list processor}) that takes a line and a port +and returns an AST node of type @var{node-type} (a symbol, typically +@code{itemize} or @code{enumerate}) along with a line. If the processor is +not triggered, i.e., it is passed a line that does not match @var{rx}, then +it returns @code{#f}." + (lambda (line port) + (let ((match (regexp-exec rx line))) + (if (not match) + #f + (let loop ((line line) + (contiguous-empty-lines 0) + (item '()) + (body '())) + (if (eof-object? line) + (let ((body (if (null? item) + body + (cons `(item ,@(reverse! item)) body)))) + (values line `(,node-type ,@(reverse! body)))) + (let ((match (regexp-exec rx line))) + (cond (match + ;; reading the first line of an item + (loop (read-line port) 0 + (append-trees + (line-proc (extract-line-proc match))) + body)) + + ((and (procedure? end-of-node?) + (end-of-node? line)) + (values line + `(,node-type ,@(reverse! body)))) + + ((empty-line? line) + (cond ((>= contiguous-empty-lines 1) + ;; end of list + (values line + `(,node-type ,@(reverse! body)))) + + ((= contiguous-empty-lines 0) + ;; end of item: add ITEM to BODY + (loop (read-line port) 1 '() + (cons (make-markup 'item item) + body))) + + (else + ;; skipping empty line + (loop (read-line port) + (+ 1 contiguous-empty-lines) + item body)))) + + (else + ;; reading an item: add LINE to ITEM + (loop (read-line port) 0 + (append-trees item (line-proc line)) + body)))))))))) + +(define (make-node-processor rx node-type title-proc line-proc + subnode-procs end-of-node?) + "Return a procedure that reads the given string and return an AST node of +type @var{node-type} or @code{#f}. When the original string matches the node +header, then the rest of the node is read from @var{port}. +@var{subnode-procs} is a list of node processors for node types subordinate +to @var{node-type}." + (lambda (line port) + (let ((match (regexp-exec rx line))) + (if (not match) + #f + (let ((title (line-proc (title-proc match)))) + (let loop ((line (read-line port)) + (body '())) + + (let ((subnode (and (not (eof-object? line)) + (apply-any subnode-procs + (list line port))))) + (cond (subnode + (let-values (((line node) subnode)) + (loop line (cons node body)))) + + ((or (eof-object? line) + (regexp-exec rx line) + (and (procedure? end-of-node?) + (end-of-node? line))) + (values line + `(,node-type :title ,title ,@(reverse! body)))) + + ((empty-line? line) + (loop (read-line port) body)) + + (else + (let ((par (process-paragraph line line-proc port))) + (loop (read-line port) + (cons par body)))))))))))) + + +(define (node-markup-line? line) + (define node-rx (make-regexp "^\\*+ (.+)$" regexp/extended)) + (regexp-exec node-rx line)) + +(define %list-processors + (list (make-list-processor (make-regexp "^[-~o] (.+)$" regexp/extended) + 'itemize + (lambda (m) (match:substring m 1)) + %line-processor + node-markup-line?) + (make-list-processor (make-regexp "^([0-9]+)\\.? (.+)$" + regexp/extended) + 'enumerate + (lambda (m) (match:substring m 2)) + %line-processor + node-markup-line?))) + +(define %node-processors + (let* ((subsubsection-proc + (make-node-processor (make-regexp "^\\*\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + %list-processors ;; no further subnodes + node-markup-line?)) + (subsection-proc + (make-node-processor (make-regexp "^\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsubsection-proc)) + node-markup-line?)) + (section-proc + (make-node-processor (make-regexp "^\\*\\* (.+)$" regexp/extended) + 'section + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsection-proc)) + node-markup-line?))) + (list (make-node-processor (make-regexp "^\\* (.+)$" regexp/extended) + 'chapter + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list section-proc)) + #f)))) + + + + +;;; +;;; The top-level parser. +;;; + +(define (make-document-processor node-procs line-proc) + (lambda (line port) + (let self ((line line) + (doc '())) + ;;(format #t "doc-proc: ~a~%" line) + (if (eof-object? line) + (if (null? doc) + line + (reverse! doc)) + (if (empty-line? line) + (self (read-line port) doc) + (let ((result (apply-any node-procs (list line port)))) + (if result + (let-values (((line node) result)) + (self line (cons node doc))) + (let ((par (process-paragraph line line-proc port))) + (self (read-line port) + (cons par doc)))))))))) + + +(define* (outline-reader :optional (port (current-input-port))) + (define modeline-rx + (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$")) + (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended)) + (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended)) + + (let ((doc-proc (make-document-processor %node-processors %line-processor))) + + (let loop ((title #f) + (author #f) + (line (read-line port))) + + (if (eof-object? line) + (if (or title author) + `(document :title ,title :author (author :name ,author) '()) + line) + (if (or (empty-line? line) + (regexp-exec modeline-rx line)) + (loop title author (read-line port)) + (let ((title-match (regexp-exec title-rx line))) + (if title-match + (loop (match:substring title-match 1) + author (read-line port)) + (let ((author-match (regexp-exec author-rx line))) + (if author-match + (loop title (match:substring author-match 1) + (read-line port)) + + ;; Let's go. + `(document :title ,title + :author (author :name ,author) + ,@(doc-proc line port))))))))))) + + +(define* (make-outline-reader :optional (version "0.1")) + outline-reader) + + + +;;; The reader specification. + +(define-reader outline "0.1" make-outline-reader) + + +;;; arch-tag: 53473e73-c811-4eed-a0b4-22ada4d6ef08 + +;;; outline.scm ends here + diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm new file mode 100644 index 0000000..d3dbb5f --- /dev/null +++ b/src/guile/skribilo/reader/skribe.scm @@ -0,0 +1,113 @@ +;;; skribe.scm -- A reader for the Skribe syntax. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader skribe) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-1) + + ;; the Scheme reader composition framework + :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) + + :export (reader-specification + make-skribe-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for the Skribe syntax, i.e. roughly R5RS Scheme plus DSSSL-style +;;; keywords and sk-exps (expressions introduced using a square bracket). +;;; +;;; Code: + +;;; Note: We need guile-reader 0.2 at least. + +(define* (make-skribe-reader #:optional (version "1.2d")) + "Return a Skribe reader (a procedure) suitable for version @var{version} of +the Skribe syntax." + (if (string> version "1.2d") + (error "make-skribe-reader: unsupported version" version) + %skribe-reader)) + +(define (make-colon-free-token-reader tr) + ;; Stolen from `guile-reader' 0.3. + "If token reader @var{tr} handles the @code{:} (colon) character, remove it +from its specification and return the new token reader." + (let* ((spec (r:token-reader-specification tr)) + (proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (char=? chr #\:))) + spec) + proc))) + +(define &sharp-reader + ;; The reader for what comes after a `#' character. + (let* ((dsssl-keyword-reader ;; keywords à la `#!key' + (r:make-token-reader #\! + (r:token-reader-procedure + (r:standard-token-reader 'keyword))))) + (r:make-reader (cons dsssl-keyword-reader + (map r:standard-token-reader + '(character srfi-4 vector + number+radix boolean + srfi30-block-comment + srfi62-sexp-comment))) + #f ;; use default fault handler + 'reader/record-positions))) + +(define (%make-skribe-reader) + (let ((colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (symbol-misc-chars-tr + ;; Make sure `:' is handled only by the keyword token reader. + (make-colon-free-token-reader + (r:standard-token-reader 'r6rs-symbol-misc-chars)))) + + + ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since + ;; they consider square brackets as delimiters. + (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader) + colon-keywords + symbol-misc-chars-tr + (map r:standard-token-reader + `(whitespace + sexp string r6rs-number + r6rs-symbol-lower-case + r6rs-symbol-upper-case + quote-quasiquote-unquote + semicolon-comment + skribe-exp))) + #f ;; use the default fault handler + 'reader/record-positions + ))) + +;; We actually cache an instance here. +(define %skribe-reader (%make-skribe-reader)) + + + +;;; The reader specification. + +(define-reader skribe "1.2d" make-skribe-reader) + +;;; skribe.scm ends here diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm new file mode 100644 index 0000000..ba5af6a --- /dev/null +++ b/src/guile/skribilo/resolve.scm @@ -0,0 +1,296 @@ +;;; resolve.scm -- Skribilo reference resolution. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo resolve) + :use-module (skribilo debug) + :use-module (skribilo ast) + :use-module (skribilo utils syntax) + + :use-module (oop goops) + :use-module (srfi srfi-39) + + :use-module (skribilo condition) + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + + :export (resolve! resolve-search-parent resolve-children resolve-children* + find1 resolve-counter resolve-parent resolve-ident + *document-being-resolved*)) + +(fluid-set! current-reader %skribilo-module-reader) + + + + +;;; +;;; Resolving nodes. +;;; + +;; The document being resolved. Note: This is only meant to be used by the +;; compatibility layer in order to implement things like `find-markups'! +(define *document-being-resolved* (make-parameter #f)) + +(define *unresolved* (make-parameter #f)) +(define-generic do-resolve!) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE! +;;;; +;;;; This function iterates over an ast until all unresolved references +;;;; are resolved. +;;;; +;;;; ====================================================================== +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + + (if (document? ast) + ;; Bind nodes prior to resolution so that unresolved nodes can + ;; lookup nodes by identifier using `document-lookup-node' or + ;; `resolve-ident'. + (document-bind-nodes! ast)) + + (parameterize ((*unresolved* #f)) + (let Loop ((ast ast)) + (*unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if (*unresolved*) + (begin + (debug-item "iterating over ast " ast) + (Loop ast)) + ast)))))) + +;;;; ====================================================================== +;;;; +;;;; D O - R E S O L V E ! +;;;; +;;;; ====================================================================== + +(define-method (do-resolve! ast engine env) + ast) + + +(define-method (do-resolve! (ast <pair>) engine env) + (let Loop ((n* ast)) + (cond + ((null? n*) + ast) + ((list? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (Loop (cdr n*))) + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (set-cdr! n* (do-resolve! (cdr n*) engine env))) + (else + (raise (condition (&invalid-argument-error + (proc-name "do-resolve!<pair>") + (argument n*)))))))) + + +(define-method (do-resolve! (node <node>) engine env) + (if (ast-resolved? node) + node + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent)) + (unresolved? (*unresolved*))) + (with-debug 5 'do-resolve<body> + (debug-item "body=" body) + (parameterize ((*unresolved* #f)) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env))) + (slot-set! node 'parent + (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options)))) + (slot-set! node 'body (do-resolve! body engine env)) + (slot-set! node 'resolved? (not (*unresolved*)))) + + (*unresolved* (or unresolved? (not (ast-resolved? node)))) + node)))) + + +(define-method (do-resolve! (node <container>) engine env0) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (env (slot-ref node 'env)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve<container> + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" body) + (debug-item "env0=" env0) + (debug-item "env=" env) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env0))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))))) + (let ((e `((parent ,node) ,@env ,@env0))) + (slot-set! node 'body (do-resolve! body engine e))) + node))) + + +(define-method (do-resolve! (node <document>) engine env0) + (parameterize ((*document-being-resolved* node)) + (next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (slot-ref engine 'customs))) + node)) + + +(define-method (do-resolve! (node <unresolved>) engine env) + (with-debug 5 'do-resolve<unresolved> + (debug-item "node=" node) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + + (let* ((proc (slot-ref node 'proc)) + (res (proc node engine env)) + (loc (ast-loc node))) + (when (ast? res) + (ast-loc-set! res loc) + (slot-set! res 'parent (assq 'parent env))) + (debug-item "res=" res) + (*unresolved* #t) + res))) + + +(define-method (do-resolve! (node <handle>) engine env) + node) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (is-a? n <ast>)) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (slot-ref n 'parent) 'unspecified) + (raise (condition (&ast-orphan-error (ast n))))) + (else + (slot-ref n 'parent))))) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-SEARCH-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" n) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" p " " + (if (is-a? p 'markup) (slot-ref p 'markup) "???")) + (cond + ((pred p) p) + ((is-a? p <unresolved>) p) + ((not p) #f) + (else (resolve-search-parent p e pred)))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-COUNTER +;;;; +;;;; ====================================================================== +;;FIXME: factoriser +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (raise (condition (&ast-orphan-error (ast n)))) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + + +;;; +;;; `resolve-ident'. +;;; +;;; This function kind of sucks because the document where IDENT is to be +;;; searched is not explictly passed. Thus, using `document-lookup-node' is +;;; recommended instead of using this function. +;;; + +(define (resolve-ident ident markup n e) + ;; Search for a node with identifier IDENT and markup type MARKUP. N is + ;; typically an `<unresolved>' node and the node lookup should be performed + ;; in its parent document. E is the "environment" (an alist). + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (raise (condition (&invalid-argument-error ;; type error + (proc-name "resolve-ident") + (argument ident)))) + (let* ((doc (ast-document n)) + (result (and doc (document-lookup-node doc ident)))) + (if (or (not markup) + (and (markup? result) (eq? (markup-markup result) markup))) + result + #f))))) + diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm new file mode 100644 index 0000000..a61de4f --- /dev/null +++ b/src/guile/skribilo/source.scm @@ -0,0 +1,208 @@ +;;;; source.scm -- Highlighting source files. +;;;; +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; + +(define-module (skribilo source) + :export (<language> language? language-extractor language-fontifier + source-read-lines source-read-definition source-fontify) + + :use-module (srfi srfi-35) + :autoload (srfi srfi-34) (raise) + :autoload (srfi srfi-13) (string-prefix-length) + :autoload (skribilo condition) (&file-search-error &file-open-error) + + :use-module (skribilo utils syntax) + :use-module (skribilo parameters) + :use-module (skribilo lib) + :use-module (oop goops) + :use-module (ice-9 rdelim)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +(define-class <language> () + (name :init-keyword :name :init-value #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-value #f + :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f + :getter language-extractor)) + +(define (language? obj) + (is-a? obj <language>)) + + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (search-path (*source-path*) file))) + (if (or (not (string? p)) (not (file-exists? p))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*))))) + (with-input-from-file p + (lambda () + (if (> (*verbose*) 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 0) ;; In Guile, line nums are 0-origined. + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) + (= (string-prefix-length stop s) stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) + (= (string-prefix-length start s) startl)) + (loop (+ l 1) #t (read-line) r)) + (else + (loop (+ l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((= i len) + (let ((nlen (- col 1))) + (if (= len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((= i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (* (/ (+ col tabl) + tabl) + tabl))) + (liip (+ i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+ i 1) (+ j 1) (+ col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+ i 1) + (* (/ (+ col tabl) tabl) tabl))) + (else + (loop (+ i 1) (+ col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (search-path (*source-path*) file))) + (cond + ((not (language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + (slot-ref lang 'name))) + + ((or (not p) (not (file-exists? p))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*)))))) + + (else + (let ((ip (open-input-file p))) + (if (> (*verbose*) 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (raise (condition (&file-open-error (file-name p)))) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) diff --git a/src/guile/skribilo/sui.scm b/src/guile/skribilo/sui.scm new file mode 100644 index 0000000..e0a9b19 --- /dev/null +++ b/src/guile/skribilo/sui.scm @@ -0,0 +1,199 @@ +;;; sui.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo sui) + :use-module (skribilo utils syntax) + :use-module (skribilo lib) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :autoload (skribilo parameters) (*verbose*) + :autoload (skribilo reader) (make-reader) + + :export (load-sui sui-ref->url sui-title sui-file sui-key + sui-find-ref sui-search-ref sui-filter)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; Library dealing with Skribe URL Indexes (SUI). +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `sui.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* *sui-table* ... */ +;*---------------------------------------------------------------------*/ +(define *sui-table* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* load-sui ... */ +;* ------------------------------------------------------------- */ +;* Returns a SUI sexp if already loaded. Load it otherwise. */ +;* Raise an error if the file cannot be open. */ +;*---------------------------------------------------------------------*/ +(define (load-sui path) + (let ((sexp (hash-ref *sui-table* path))) + (or sexp + (begin + (when (> (*verbose*) 0) + (format (current-error-port) " [loading sui: ~a]\n" path)) + (let ((p (open-input-file path)) + (read (make-reader 'skribe))) + (if (not (input-port? p)) + (skribe-error 'load-sui + "Can't find `Skribe Url Index' file" + path) + (unwind-protect + (let ((sexp (read p))) + (match sexp + (('sui (? string?) . _) + (hash-set! *sui-table* path sexp)) + (else + (skribe-error 'load-sui + "Illegal `Skribe Url Index' file" + path))) + sexp) + (close-input-port p)))))))) + +;*---------------------------------------------------------------------*/ +;* sui-ref->url ... */ +;*---------------------------------------------------------------------*/ +(define (sui-ref->url dir sui ident opts) + (let ((refs (sui-find-ref sui ident opts))) + (and (pair? refs) + (let ((base (sui-file sui)) + (file (car (car refs))) + (mark (cdr (car refs)))) + (format #f "~a/~a#~a" dir (or file base) mark))))) + +;*---------------------------------------------------------------------*/ +;* sui-title ... */ +;*---------------------------------------------------------------------*/ +(define (sui-title sexp) + (match sexp + (('sui (and title (? string?)) . _) + title) + (else + (skribe-error 'sui-title "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-file sexp) + (sui-key sexp :file)) + +;*---------------------------------------------------------------------*/ +;* sui-key ... */ +;*---------------------------------------------------------------------*/ +(define (sui-key sexp key) + (match sexp + (('sui _ . rest) + (let loop ((rest rest)) + (and (pair? rest) + (if (eq? (car rest) key) + (and (pair? (cdr rest)) + (cadr rest)) + (loop (cdr rest)))))) + (else + (skribe-error 'sui-key "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-find-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-find-ref sui ident opts) + (let ((ident (assq :ident opts)) + (mark (assq :mark opts)) + (class (let ((c (assq :class opts))) + (and (pair? c) (cadr c)))) + (chapter (assq :chapter opts)) + (section (assq :section opts)) + (subsection (assq :subsection opts)) + (subsubsection (assq :subsubsection opts))) + (match sui + (('sui (? string?) . refs) + (cond + (mark (sui-search-ref 'marks refs (cadr mark) class)) + (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) + (section (sui-search-ref 'sections refs (cadr section) class)) + (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) + (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) + (ident (sui-search-all-refs sui ident class)) + (else '()))) + (else + (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) + +;*---------------------------------------------------------------------*/ +;* sui-search-all-refs ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-all-refs sui id refs) + '()) + +;*---------------------------------------------------------------------*/ +;* sui-search-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-ref kind refs val class) + (define (find-ref refs val class) + (map (lambda (r) + (let ((f (memq :file r)) + (c (memq :mark r))) + (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) + (filter (if class + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val) + (let ((c (memq :class m))) + (and (pair? c) + (eq? (cadr c) class))))) + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val)))) + refs))) + (let loop ((refs refs)) + (if (pair? refs) + (if (and (pair? (car refs)) (eq? (caar refs) kind)) + (find-ref (cdar refs) val class) + (loop (cdr refs))) + '()))) + +;*---------------------------------------------------------------------*/ +;* sui-filter ... */ +;*---------------------------------------------------------------------*/ +(define (sui-filter sui pred1 pred2) + (match sui + (('sui (? string?) . refs) + (let loop ((refs refs) + (res '())) + (if (pair? refs) + (if (and (pred1 (car refs))) + (loop (cdr refs) + (cons (filter pred2 (cdar refs)) res)) + (loop (cdr refs) res)) + (reverse! res)))) + (else + (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am new file mode 100644 index 0000000..9d9df6f --- /dev/null +++ b/src/guile/skribilo/utils/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/utils +dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm \ + keywords.scm strings.scm + +## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm new file mode 100644 index 0000000..118f294 --- /dev/null +++ b/src/guile/skribilo/utils/compat.scm @@ -0,0 +1,309 @@ +;;; compat.scm -- Skribe compatibility module. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo utils compat) + :use-module (skribilo utils syntax) + :use-module (skribilo utils files) + :use-module (skribilo parameters) + :use-module (skribilo evaluator) + :use-module (srfi srfi-1) + :autoload (srfi srfi-13) (string-rindex) + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + :use-module (ice-9 optargs) + :autoload (skribilo ast) (ast? document? document-lookup-node) + :autoload (skribilo condition) (file-search-error? &file-search-error) + :autoload (skribilo reader) (make-reader) + :autoload (skribilo lib) (type-name) + :autoload (skribilo resolve) (*document-being-resolved*) + :autoload (skribilo output) (*document-being-output*) + :use-module (skribilo debug) + + :re-export (file-size) ;; re-exported from `(skribilo utils files)' + :replace (gensym)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines symbols for compatibility with Skribe 1.2. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; gensym +;;; + +(define %gensym-orig (module-ref the-root-module 'gensym)) + +(define gensym + ;; In Skribe, `gensym' accepts a symbol. Guile's `gensym' accepts only + ;; strings (or no argument). + (lambda obj + (apply %gensym-orig + (cond ((null? obj) '()) + ((symbol? (car obj)) (list (symbol->string (car obj)))) + ((string? (car obj)) (list (car obj))) + (else (skribe-error 'gensym "invalid argument" obj)))))) + + +;;; +;;; Global variables that have been replaced by parameter objects +;;; in `(skribilo parameters)'. +;;; +;;; FIXME: There's not much we can do about these variables (as opposed to +;;; the _accessors_ below). Perhaps we should just not define them? +;;; + +;;; Switches +(define-public *skribe-verbose* 0) +(define-public *skribe-warning* 5) +(define-public *load-rc* #t) + + +;;; Path variables +(define-public *skribe-path* #f) +(define-public *skribe-bib-path* '(".")) +(define-public *skribe-source-path* '(".")) +(define-public *skribe-image-path* '(".")) + + +(define-public *skribe-rc-directory* + (string-append (getenv "HOME") "/" ".skribilo")) + + +;;; In and out ports +(define-public *skribe-src* '()) +(define-public *skribe-dest* #f) + +;;; Engine +(define-public *skribe-engine* 'html) ;; Use HTML by default + +;;; Misc +(define-public *skribe-chapter-split* '()) +(define-public *skribe-ref-base* #f) +(define-public *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter +(define-public *skribe-variants* '()) + + + +;;; +;;; Accessors mapped to parameter objects. +;;; + +(define-public skribe-path *document-path*) +(define-public skribe-image-path *image-path*) +(define-public skribe-source-path *source-path*) +(define-public skribe-bib-path *bib-path*) + +(define-public (skribe-path-set! path) (*document-path* path)) +(define-public (skribe-image-path-set! path) (*image-path* path)) +(define-public (skribe-source-path-set! path) (*source-path* path)) +(define-public (skribe-bib-path-set! path) (*bib-path* path)) + + + +;;; +;;; Evaluator. +;;; + +(define %skribe-known-files + ;; Like of Skribe package files and their equivalent Skribilo module. + '(("web-book.skr" . (skribilo package web-book)) + ("web-article.skr" . (skribilo package web-article)) + ("slide.skr" . (skribilo package slide)) + ("sigplan.skr" . (skribilo package sigplan)) + ("scribe.skr" . (skribilo package scribe)) + ("lncs.skr" . (skribilo package lncs)) + ("letter.skr" . (skribilo package letter)) + ("jfp.skr" . (skribilo package jfp)) + ("french.skr" . (skribilo package french)) + ("acmproc.skr" . (skribilo package acmproc)))) + +(define*-public (skribe-load file :rest args) + (guard (c ((file-search-error? c) + ;; Regular file loading failed. Try built-ins. + (let ((mod-name (assoc-ref %skribe-known-files file))) + (if mod-name + (begin + (if (> (*verbose*) 1) + (format (current-error-port) + " skribe-load: `~a' -> `~a'~%" + file mod-name)) + (let ((mod (false-if-exception + (resolve-module mod-name)))) + (if (not mod) + (raise c) + (begin + (set-module-uses! + (current-module) + (cons mod (module-uses (current-module)))) + #t)))) + (raise c))))) + + ;; Try a regular `load-document'. + (apply load-document file args))) + + +(define-public skribe-include include-document) +(define-public skribe-load-options *load-options*) + +(define-public skribe-eval evaluate-document) +(define-public skribe-eval-port evaluate-document-from-port) + +(set! %skribe-reader #f) +(define*-public (skribe-read #:optional (port (current-input-port))) + (if (not %skribe-reader) + (set! %skribe-reader (make-reader 'skribe))) + (%skribe-reader port)) + + + +;;; +;;; Node lookup (formerly provided by `ast.scm'). +;;; + +(define-public (bind-markup! node) + (let ((doc (or (*document-being-resolved*) + (*document-being-output*)))) + (if (document? doc) + (document-bind-node! doc node) + (error "Sorry, unable to achieve `bind-markup!'. Use `document-bind-node!' instead." + node)))) + +(define-public (find-markups ident) + (let ((doc (or (*document-being-resolved*) + (*document-being-output*)))) + (if (document? doc) + (let ((result (document-lookup-node doc ident))) + (if result + (list result) + #f)) + (error "Sorry, unable to achieve `find-markups'. Use `document-lookup-node' instead." + ident)))) + +(define-public (find-markup-ident ident) + (or (find-markups ident) '())) + + + +;;; +;;; Debugging facilities. +;;; + +(define-public (set-skribe-debug! val) + (*debug* val)) + +(define-public (no-debug-color) + (*debug-use-colors?* #f)) + +(define-public skribe-debug *debug*) + +(define-public (add-skribe-debug-symbol s) + (*watched-symbols* (cons s *watched-symbols*))) + + + +;;; +;;; Compatibility with Bigloo. +;;; + +(define-public (substring=? s1 s2 len) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (let Loop ((i 0)) + (cond + ((= i len) #t) + ((= i l1) #f) + ((= i l2) #f) + ((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1))) + (else #f))))) + +(define-public (directory->list str) + (map basename (glob (string-append str "/*") (string-append "/.*")))) + +(define-macro (printf . args) `(format #t ,@args)) +(export-syntax printf) +(define-public fprintf format) + +(define-public (fprint port . args) + (if port + (with-output-to-port port + (lambda () + (for-each display args) + (display "\n"))))) + + + +(define-public prefix file-prefix) +(define-public suffix file-suffix) +(define-public system->string system) ;; FIXME +(define-public any? any) +(define-public every? every) +(define-public (find-file/path file path) + (search-path path file)) + +(define-public process-input-port #f) ;process-input) +(define-public process-output-port #f) ;process-output) +(define-public process-error-port #f) ;process-error) + +;;; hash tables +(define-public make-hashtable make-hash-table) +(define-public hashtable? hash-table?) +(define-public hashtable-get (lambda (h k) (hash-ref h k #f))) +(define-public hashtable-put! hash-set!) +(define-public (hashtable-update! table key update-proc init-value) + ;; This is a Bigloo-specific API. + (let ((handle (hash-get-handle table key))) + (if (not handle) + (hash-set! table key init-value) + (set-cdr! handle (update-proc (cdr handle)))))) + +(define-public (hashtable->list h) + (hash-map->list (lambda (key val) val) h)) + +(define-public (find-runtime-type obj) + (type-name obj)) + + +;;; +;;; Miscellaneous. +;;; + +(use-modules ((srfi srfi-19) #:renamer (symbol-prefix-proc 's19:))) + +(define-public (date) + (s19:date->string (s19:current-date) "~c")) + +(define-public (correct-arity? proc argcount) + (let ((a (procedure-property proc 'arity))) + (and (pair? a) + (let ((compulsory (car a)) + (optional (cadr a)) + (rest? (caddr a))) + (or rest? + (>= (+ compulsory optional) argcount)))))) + + +;;; compat.scm ends here diff --git a/src/guile/skribilo/utils/files.scm b/src/guile/skribilo/utils/files.scm new file mode 100644 index 0000000..6d89d4d --- /dev/null +++ b/src/guile/skribilo/utils/files.scm @@ -0,0 +1,55 @@ +;;; files.scm -- File-related utilities. +;;; +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils files) + :export (file-prefix file-suffix file-size)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines filesystem-related utility functions. +;;; +;;; Code: + +(define (file-size file) + (let ((file-info (false-if-exception (stat file)))) + (if file-info + (stat:size file-info) + #f))) + +(define (file-prefix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot (substring fn 0 dot) fn)) + "./SKRIBILO-OUTPUT")) + +(define (file-suffix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot + (substring fn (+ dot 1) (string-length fn)) + "")) + #f)) + + +;;; arch-tag: b63d2a9f-a254-4e2d-8d85-df773bbc4a9b + +;;; files.scm ends here diff --git a/src/guile/skribilo/utils/images.scm b/src/guile/skribilo/utils/images.scm new file mode 100644 index 0000000..24405d6 --- /dev/null +++ b/src/guile/skribilo/utils/images.scm @@ -0,0 +1,99 @@ +;;; images.scm -- Images handling utilities. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils images) + :export (convert-image + *fig-convert-program* *bitmap-convert-program*) + + :autoload (skribilo utils files) (file-suffix file-prefix) + :autoload (skribilo parameters) (*image-path* *verbose*) + :autoload (skribilo condition) (&file-search-error) + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :use-module (srfi srfi-39)) + +;;; Author: Erick Gallesio, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides convenience functions to handle image files, notably +;;; for format conversion via ImageMagick's `convert'. +;;; +;;; Code: + +(define *fig-convert-program* (make-parameter "fig2dev -L")) +(define *generic-convert-program* (make-parameter "convert")) + +(define (builtin-convert-image from fmt dir) + (let* ((s (file-suffix from)) + (f (string-append (file-prefix (basename from)) "." fmt)) + (to (string-append dir "/" f))) ;; FIXME: + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append (*fig-convert-program*) " " + fmt " " from " > " to) + (string-append (*generic-convert-program*) " " + from " " to)))) + (cond + ((> (*verbose*) 1) + (format (current-error-port) " [converting image: ~S (~S)]" from c)) + ((> (*verbose*) 0) + (format (current-error-port) " [converting image: ~S]" from))) + (and (zero? (system c)) + to)))))) + +(define (convert-image file formats) + (let ((path (search-path (*image-path*) file))) + (if (not path) + (raise (condition (&file-search-error (file-name file) + (path (*image-path*))))) + (let ((suf (file-suffix file))) + (if (member suf formats) + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) + #f))) + (if dir + (let* ((dest (basename path)) + (dest-path (string-append dir "/" dest))) + (if (not (string=? path dest-path)) + (copy-file path dest-path)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + + +;;; arch-tag: a1992fa8-6073-4cd7-a018-80e2cc8d537c + +;;; images.scm ends here diff --git a/src/guile/skribilo/utils/keywords.scm b/src/guile/skribilo/utils/keywords.scm new file mode 100644 index 0000000..1bcd5dc --- /dev/null +++ b/src/guile/skribilo/utils/keywords.scm @@ -0,0 +1,99 @@ +;;; keywords.scm -- Convenience procedures for keyword-argument handling. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils keywords) + :export (the-body the-options list-split)) + +;;; Author: Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides convenience functions to handle keyword arguments. +;;; These are typically used by markup functions. +;;; +;;; Code: + +(define (the-body opt+) + ;; Filter out the keyword arguments from OPT+. + (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) + ;; Return a list made of keyword arguments (i.e., each time, a keyword + ;; followed by its associated value). The OUT argument should be a list + ;; containing keyword argument names to be filtered out (e.g., + ;; `(#:ident)'). + (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))))) + +(define (list-split l num . fill) + (let loop ((l l) + (i 0) + (acc '()) + (res '())) + (cond + ((null? l) + (reverse! (cons (if (or (null? fill) (= i num)) + (reverse! acc) + (append! (reverse! acc) + (make-list (- num i) (car fill)))) + res))) + ((= i num) + (loop l + 0 + '() + (cons (reverse! acc) res))) + (else + (loop (cdr l) + (+ i 1) + (cons (car l) acc) + res))))) + +;;; arch-tag: 3e9066d5-6d7d-4da5-922b-cc3d4ba8476e + +;;; keywords.scm ends here diff --git a/src/guile/skribilo/utils/strings.scm b/src/guile/skribilo/utils/strings.scm new file mode 100644 index 0000000..e8e8f8f --- /dev/null +++ b/src/guile/skribilo/utils/strings.scm @@ -0,0 +1,145 @@ +;;; strings.scm -- Convenience functions to manipulate strings. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils strings) + :export (strip-ref-base string-canonicalize + make-string-replace) + :autoload (skribilo parameters) (*ref-base*) + :use-module (skribilo lib) + :use-module (srfi srfi-13)) + + +;;; +;;; Utilities. +;;; + +(define (strip-ref-base file) + ;; Given FILE, a file path (a string), remove `(*ref-base*)' from it. + ;; This is useful, e.g., for hyperlinks. + (if (not (string? (*ref-base*))) + file + (let ((l (string-length (*ref-base*)))) + (cond + ((not (> (string-length file) (+ l 2))) + file) + ((not (string-contains file (*ref-base*) 0 l)) + file) + ((not (char=? (string-ref file l) #\/)) + file) + (else + (substring file (+ l 1) (string-length file))))))) + + +(define (string-canonicalize old) + ;; Return a string that is a canonical summarized representation of string + ;; OLD. This is a one-way function. + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((= r l) + (cond + ((= w 0) + "") + ((char-whitespace? (string-ref new (- w 1))) + (substring new 0 (- w 1))) + ((= w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+ r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+ r 1) (+ w 1) #f)))))) + + + + +;;; +;;; String writing. +;;; + +;; +;; (define (%make-html-replace) +;; ;; Ad-hoc version for HTML, a little bit faster than the +;; ;; make-general-string-replace define later (particularily if there +;; ;; is nothing to replace since, it does not allocate a new string +;; (let ((specials (string->regexp "&|\"|<|>"))) +;; (lambda (str) +;; (if (regexp-match specials str) +;; (begin +;; (let ((out (open-output-string))) +;; (dotimes (i (string-length str)) +;; (let ((ch (string-ref str i))) +;; (case ch +;; ((#\") (display """ out)) +;; ((#\&) (display "&" out)) +;; ((#\<) (display "<" out)) +;; ((#\>) (display ">" out)) +;; (else (write-char ch out))))) +;; (get-output-string out))) +;; str)))) + + +(define (%make-general-string-replace lst) + ;; The general version + (let ((chars (make-hash-table))) + + ;; Setup a hash table equivalent to LST. + (for-each (lambda (chr) + (hashq-set! chars (car chr) (cadr chr))) + lst) + + ;; Help the GC. + (set! lst #f) + + (lambda (str) + (let ((out (open-output-string))) + (string-for-each (lambda (ch) + (let ((res (hashq-ref chars ch #f))) + (display (if res res ch) out))) + str) + (get-output-string out))))) + +(define %html-replacements + '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) + +(define %string->html + (%make-general-string-replace %html-replacements)) + +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2)))))) + (cond + ((equal? l %html-replacements) + %string->html) + (else + (%make-general-string-replace lst))))) + diff --git a/src/guile/skribilo/utils/syntax.scm b/src/guile/skribilo/utils/syntax.scm new file mode 100644 index 0000000..44bff09 --- /dev/null +++ b/src/guile/skribilo/utils/syntax.scm @@ -0,0 +1,81 @@ +;;; syntax.scm -- Syntactic candy for Skribilo modules. +;;; +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils syntax) + :use-module (skribilo reader) + :use-module (system reader library) + :use-module (system reader compat) ;; make sure `current-reader' exists + :use-module (system reader confinement) + :export (%skribe-reader %skribilo-module-reader) + :export-syntax (unwind-protect unless when)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides syntactic candy for Skribilo modules, i.e., a syntax +;;; similar to Guile's default syntax with a few extensions, plus various +;;; convenience macros. +;;; +;;; Code: + +(define %skribilo-module-reader + ;; The syntax used to read Skribilo modules. + (apply make-alternate-guile-reader + '(colon-keywords no-scsh-block-comments + srfi30-block-comments srfi62-sexp-comments) + (lambda (chr port read) + (let ((file (port-filename port)) + (line (port-line port)) + (column (port-column port))) + (error (string-append + (if (string? file) + (format #f "~a:~a:~a: " file line column) + "") + "unexpected character in Skribilo module") + chr))) + + ;; By default, don't record positions: this yields a nice read + ;; performance improvement. + (if (memq 'debug (debug-options)) + (list 'reader/record-positions) + '()))) + +(define %skribe-reader + ;; The Skribe syntax reader. + (make-reader 'skribe)) + + +(define-macro (unwind-protect expr1 expr2) + ;; This is no completely correct. + `(dynamic-wind + (lambda () #f) + (lambda () ,expr1) + (lambda () ,expr2))) + +(define-macro (unless condition . exprs) + `(if (not ,condition) (begin ,@exprs))) + +(define-macro (when condition . exprs) + `(if ,condition (begin ,@exprs))) + +;;; arch-tag: 9a0e0638-64f0-480a-ab19-49e8bfcbcd9b + +;;; syntax.scm ends here diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm new file mode 100644 index 0000000..052b5cc --- /dev/null +++ b/src/guile/skribilo/verify.scm @@ -0,0 +1,160 @@ +;;; verify.scm -- Skribe AST verification. +;;; +;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo verify) + :autoload (skribilo engine) (engine-ident processor-get-engine) + :autoload (skribilo writer) (writer? writer-options lookup-markup-writer) + :autoload (skribilo lib) (skribe-warning/ast skribe-warning + skribe-error) + :export (verify)) + +(use-modules (skribilo debug) + (skribilo ast) + (skribilo utils syntax) + (oop goops)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +(define-generic verify) + +;;; +;;; CHECK-REQUIRED-OPTIONS +;;; +(define (check-required-options markup writer engine) + (let ((required-options (slot-ref markup 'required-options)) + (ident (slot-ref writer 'ident)) + (options (slot-ref writer 'options)) + (verified? (slot-ref writer 'verified?))) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (engine-ident engine) + (format #f "option unsupported: ~a, supported options: ~a" o options) + markup))) + required-options) + (slot-set! writer 'verified? #t))))) + +;;; +;;; 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) + (for-each + (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o lopts))) + (skribe-warning/ast + 3 + markup + 'verify + (format #f "engine ~a does not support markup ~a option `~a' -- ~a" + (engine-ident engine) + (markup-markup markup) + o + (markup-option markup o))))) + o2)) + (slot-ref markup 'options)))) + + +;;; ====================================================================== +;;; +;;; V E R I F Y +;;; +;;; ====================================================================== + +;;; TOP +(define-method (verify (obj <top>) e) + obj) + +;;; PAIR +(define-method (verify (obj <pair>) e) + (for-each (lambda (x) (verify x e)) obj) + obj) + +;;; PROCESSOR +(define-method (verify (obj <processor>) e) + (let ((combinator (slot-ref obj 'combinator)) + (engine (slot-ref obj 'engine)) + (body (slot-ref obj 'body))) + (verify body (processor-get-engine combinator engine e)) + obj)) + +;;; NODE +(define-method (verify (node <node>) e) + ;; Verify body + (verify (slot-ref node 'body) e) + ;; Verify options + (for-each (lambda (o) (verify (cadr o) e)) + (slot-ref node 'options)) + node) + +;;; MARKUP +(define-method (verify (node <markup>) e) + (with-debug 5 'verify::<markup> + (debug-item "node=" (markup-markup node)) + (debug-item "options=" (slot-ref node 'options)) + (debug-item "e=" (engine-ident e)) + + (next-method) + + (let ((w (lookup-markup-writer node e))) + (when (writer? w) + (check-required-options node w e) + (when (pair? (writer-options w)) + (check-options (slot-ref w 'options) node e)) + (let ((validate (slot-ref w 'validate))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format #f "node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)))))))) + node)) + + +;;; DOCUMENT +(define-method (verify (node <document>) e) + (next-method) + + ;; verify the engine customs + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (slot-ref e 'customs)) + + node) + +;;; verify.scm ends here
\ No newline at end of file diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm new file mode 100644 index 0000000..b16819d --- /dev/null +++ b/src/guile/skribilo/writer.scm @@ -0,0 +1,261 @@ +;;; writer.scm -- Markup writers. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2005, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo writer) + :export (<writer> writer? write-object writer-options writer-ident + writer-before writer-action writer-after writer-class + + invoke markup-writer markup-writer-get markup-writer-get* + lookup-markup-writer copy-markup-writer) + + :use-module (skribilo utils syntax) + :autoload (srfi srfi-1) (find filter) + :autoload (skribilo engine) (engine? engine-ident? default-engine)) + + +(use-modules (skribilo debug) + (skribilo output) + (skribilo ast) + (skribilo lib) + + (oop goops) + (ice-9 optargs)) + + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Class definition. +;;; + +(define-class <writer> () + (ident :init-keyword :ident :init-value '??? :getter writer-ident) + (class :init-keyword :class :init-value 'unspecified + :getter writer-class) + (pred :init-keyword :pred :init-value 'unspecified) + (upred :init-keyword :upred :init-value 'unspecified) + (options :init-keyword :options :init-value '() :getter writer-options) + (verified? :init-keyword :verified? :init-value #f) + (validate :init-keyword :validate :init-value #f) + (before :init-keyword :before :init-value #f :getter writer-before) + (action :init-keyword :action :init-value #f :getter writer-action) + (after :init-keyword :after :init-value #f :getter writer-after)) + +(define (writer? obj) + (is-a? obj <writer>)) + +(define-method (write (obj <writer>) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (object-address obj))) + + + +;;; +;;; Writer methods. +;;; + +(define (invoke proc node e) + (with-debug 5 'invoke + (debug-item "e=" (engine-ident e)) + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))) + + + +(define (make-writer-predicate markup predicate class) + (define (%always-true n e) #t) + + (let* ((t2 (if class + (lambda (n e) + (and (equal? (markup-class n) class))) + #f))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (eq? (%procedure-arity predicate) 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (if (procedure? t2) + (lambda (n e) + (and (t2 n e) (predicate n e))) + predicate))) + t2))) + + +;;; +;;; `markup-writer' +;;; + +(define* (markup-writer markup ;; #:optional (engine #f) + #:key (predicate #f) (class #f) (options '()) + (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 (if (and (list? engine) (not (keyword? (car engine)))) + (car engine) + #f) + (default-engine)))) + + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "illegal markup" markup)) + ((not (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)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action 'unspecified) + (lambda (n e) (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + + + +;;; +;;; Finding a markup writer. +;;; + +(define (lookup-markup-writer node e) + ;; Find the writer that applies best to NODE. See also `markup-writer-get' + ;; and `markup-writer-get*'. + + (define (matching-writer writers) + (find (lambda (w) + (let ((pred (slot-ref w 'pred))) + (if (procedure? pred) + (pred node e) + #t))) + writers)) + + (let* ((writers (slot-ref e 'writers)) + (node-writers (hashq-ref writers (markup-markup node) '())) + (delegate (slot-ref e 'delegate))) + + (or (matching-writer node-writers) + (matching-writer (slot-ref e 'free-writers)) + (and (engine? delegate) + (lookup-markup-writer node delegate))))) + + +(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f)) + ;; Get a markup writer for MARKUP (a symbol) in ENGINE, with class CLASS + ;; and user predicate PRED. [FIXME: Useless since PRED is a procedure and + ;; therefore not comparable?] + + (define (matching-writer writers) + (find (lambda (w) + (and (if class (equal? (writer-class w) class) #t) + (or (unspecified? pred) + (eq? (slot-ref w 'upred) pred)))) + writers)) + + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer-get "illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer-get "illegal engine" e)) + (else + (let* ((writers (slot-ref e 'writers)) + (markup-writers (hashq-ref writers markup '())) + (delegate (slot-ref e 'delegate))) + + (or (matching-writer markup-writers) + (and (engine? delegate) + (markup-writer-get markup delegate + :class class :pred pred)))))))) + + +(define* (markup-writer-get* markup #:optional engine #:key (class #f)) + ;; Finds all writers, recursively going through the engine hierarchy, that + ;; match MARKUP with optional CLASS attribute. + + (define (matching-writers writers) + (filter (lambda (w) + (or (not class) + (equal? (writer-class w) class))) + writers)) + + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "illegal engine" e)) + (else + (let* ((writers (slot-ref e 'writers)) + (markup-writers (hashq-ref writers markup '())) + (delegate (slot-ref e 'delegate))) + + (append (matching-writers writers) + (if (engine? delegate) + (markup-writer-get* markup delegate :class class) + '()))))))) + + +(define* (copy-markup-writer markup old-engine :optional new-engine + :key (predicate 'unspecified) + (class 'unspecified) + (options 'unspecified) + (validate 'unspecified) + (before 'unspecified) + (action 'unspecified) + (after 'unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate) + :class (if (unspecified? class) (slot-ref old 'class) class) + :options (if (unspecified? options) (slot-ref old 'options) options) + :validate (if (unspecified? validate) (slot-ref old 'validate) validate) + :before (if (unspecified? before) (slot-ref old 'before) before) + :action (if (unspecified? action) (slot-ref old 'action) action) + :after (if (unspecified? after) (slot-ref old 'after) after)))) + +;;; writer.scm ends here |