diff options
Diffstat (limited to 'src/guile')
63 files changed, 2108 insertions, 934 deletions
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm index dbaa368..53afa89 100644 --- a/src/guile/skribilo.scm +++ b/src/guile/skribilo.scm @@ -22,7 +22,7 @@ exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@" ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; Commentary: @@ -464,6 +464,8 @@ Processes a Skribilo/Skribe source file and produces its output. (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) diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am index 6689d15..8de8774 100644 --- a/src/guile/skribilo/Makefile.am +++ b/src/guile/skribilo/Makefile.am @@ -2,9 +2,9 @@ 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 runtime.scm \ + reader.scm resolve.scm \ source.scm parameters.scm verify.scm \ writer.scm ast.scm location.scm \ condition.scm -SUBDIRS = utils reader engine package skribe coloring +SUBDIRS = utils reader engine package skribe coloring biblio diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm index 3968b18..f8ee519 100644 --- a/src/guile/skribilo/ast.scm +++ b/src/guile/skribilo/ast.scm @@ -1,7 +1,8 @@ ;;; ast.scm -- Skribilo abstract syntax trees. ;;; -;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; 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 @@ -16,12 +17,13 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo ast) :use-module (oop goops) :autoload (skribilo location) (location?) + :autoload (skribilo lib) (skribe-type-error skribe-error) :use-module (skribilo utils syntax) :export (<ast> ast? ast-loc ast-loc-set! ast-parent ast->string ast->file-location @@ -34,9 +36,11 @@ <processor> processor? processor-combinator processor-engine <markup> markup? bind-markup! markup-options is-markup? - markup-markup markup-body markup-ident markup-class + markup-markup markup-body markup-body-set! + markup-ident markup-class find-markups - markup-option markup-option-add! markup-output + markup-option markup-option-set! + markup-option-add! markup-output markup-parent markup-document markup-chapter <container> container? container-options @@ -44,9 +48,15 @@ container-env-get <document> document? document-ident document-body - document-options document-end)) + document-options document-end -;;; Author: Ludovic Courtès + ;; traversal + find-markup-ident + container-search-down search-down find-down find1-down + find-up find1-up + ast-document ast-chapter ast-section)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès ;;; ;;; Commentary: ;;; @@ -214,6 +224,9 @@ (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) @@ -222,6 +235,14 @@ (cadr c))) (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) +(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)) + (skribe-error 'markup-option-set! "unknown option: " + m))) + (skribe-type-error 'markup-option-set! "Illegal markup: " m "markup"))) (define (markup-option-add! m opt val) (if (markup? m) @@ -263,12 +284,31 @@ (hash-ref *node-table* ident #f)) -(define-method (write-object (obj <markup>) port) - (format port "#[~A (~A/~A) ~A]" +(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) - (address-of obj))) + (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. @@ -332,6 +372,119 @@ (define document-env container-env) + +;;; +;;; AST traversal utilities. +;;; + + +;; 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 (find-markup-ident ident) + (let ((r (find-markups ident))) + (if (or (pair? r) (null? r)) + r + '()))) + +(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) + (skribe-error 'find1-down "Illegal cyclic 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 index 082fb99..e5ab6e3 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -1,7 +1,7 @@ ;;; biblio.scm -- Bibliography functions. ;;; -;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; 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 @@ -15,27 +15,46 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA.main.st (define-module (skribilo biblio) - :use-module (skribilo runtime) + :use-module (skribilo utils strings) :use-module (skribilo utils syntax) ;; `when', `unless' - :use-module (skribilo module) - :use-module (skribilo skribe bib) ;; `make-bib-entry' - :autoload (srfi srfi-34) (raise) + :autoload (srfi srfi-34) (raise) :use-module (srfi srfi-35) - :autoload (skribilo condition) (&file-search-error) + :use-module (srfi srfi-1) + :autoload (skribilo condition) (&file-search-error) :autoload (skribilo reader) (%default-reader) :autoload (skribilo parameters) (*bib-path*) - :autoload (ice-9 format) (format) + :autoload (skribilo ast) (<markup> <handle>) + + :use-module (ice-9 optargs) + :use-module (oop goops) + :export (bib-table? make-bib-table default-bib-table - bib-add! bib-duplicate - skribe-open-bib-file parse-bib)) + 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) @@ -66,15 +85,23 @@ (set! *bib-table* (make-bib-table "default-bib-table"))) *bib-table*) -;; -;; Utilities -;; (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 @@ -162,3 +189,194 @@ 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 index d2ba1d4..8b6205f 100644 --- a/src/guile/skribilo/color.scm +++ b/src/guile/skribilo/color.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l index a5b337e..7d7b1ce 100644 --- a/src/guile/skribilo/coloring/c-lex.l +++ b/src/guile/skribilo/coloring/c-lex.l @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm index c9129cf..d78e09e 100644 --- a/src/guile/skribilo/coloring/c-lex.l.scm +++ b/src/guile/skribilo/coloring/c-lex.l.scm @@ -14,7 +14,7 @@ ; ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software -; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ; ; Gestion des Input Systems diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm index baa3e53..d2a2b9f 100644 --- a/src/guile/skribilo/coloring/c.scm +++ b/src/guile/skribilo/coloring/c.scm @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l index c4db526..30b6a44 100644 --- a/src/guile/skribilo/coloring/lisp-lex.l +++ b/src/guile/skribilo/coloring/lisp-lex.l @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm index b5db4e8..6ae7fe6 100644 --- a/src/guile/skribilo/coloring/lisp-lex.l.scm +++ b/src/guile/skribilo/coloring/lisp-lex.l.scm @@ -14,7 +14,7 @@ ; ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software -; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ; ; Gestion des Input Systems diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm index e3458b1..13bb6db 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. @@ -24,7 +24,7 @@ :use-module (skribilo utils syntax) :use-module (skribilo source) :use-module (skribilo lib) - :use-module (skribilo runtime) + :use-module (skribilo utils strings) :use-module (srfi srfi-39) :use-module (ice-9 match) :autoload (ice-9 regex) (make-regexp) diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l index 5d9a8d9..aa7d312 100644 --- a/src/guile/skribilo/coloring/xml-lex.l +++ b/src/guile/skribilo/coloring/xml-lex.l @@ -17,7 +17,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm index 0e3fe05..d58e42b 100644 --- a/src/guile/skribilo/coloring/xml-lex.l.scm +++ b/src/guile/skribilo/coloring/xml-lex.l.scm @@ -14,7 +14,7 @@ ; ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software -; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ; ; Gestion des Input Systems diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm index 820dcc5..4d61efb 100644 --- a/src/guile/skribilo/condition.scm +++ b/src/guile/skribilo/condition.scm @@ -15,20 +15,26 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 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)) @@ -58,6 +64,11 @@ (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. @@ -80,6 +91,28 @@ ;;; +;;; 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. ;;; @@ -90,6 +123,11 @@ (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) @@ -111,9 +149,15 @@ (file-error:file-name c)) (exit exit-val)) - ((skribilo-error? c) - (format (current-error-port) "undefined skribilo error: ~S~%" - c) + (;;(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))) diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm index 1481a56..f7709a0 100644 --- a/src/guile/skribilo/debug.scm +++ b/src/guile/skribilo/debug.scm @@ -15,14 +15,15 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 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)) + :use-module (srfi srfi-39) + :export-syntax (debug-item with-debug)) (fluid-set! current-reader %skribilo-module-reader) @@ -102,14 +103,15 @@ ;;; ;;; debug-item ;;; -(define-public (debug-item . args) - (if (or (>= (*debug*) (*margin-level*)) - (*debug-item?*)) - (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) + `(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) ;; `()) @@ -125,30 +127,29 @@ ;;; ;;; %with-debug -;; -(define-public (%with-debug lvl lbl thunk) - (parameterize ((*margin-level* lvl)) - (if (or (and (number? lvl) (>= (*debug*) lvl)) - (and (symbol? lbl) - (memq lbl (*watched-symbols*)))) - (parameterize ((*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)) - (thunk)))) - -(define-macro (with-debug level label . body) - `(%with-debug ,level ,label (lambda () ,@body))) - -;;(define-macro (with-debug level label . body) -;; `(begin ,@body)) - -(export 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: diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm index 3e05571..06667ad 100644 --- a/src/guile/skribilo/engine.scm +++ b/src/guile/skribilo/engine.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo engine) @@ -38,7 +38,7 @@ *current-engine* default-engine default-engine-set! make-engine copy-engine find-engine lookup-engine - engine-custom engine-custom-set! + engine-custom engine-custom-set! engine-custom-add! engine-format? engine-add-writer! processor-get-engine push-default-engine pop-default-engine @@ -302,6 +302,11 @@ otherwise the requested engine is returned." (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) @@ -369,7 +374,7 @@ otherwise the requested engine is returned." (use-modules (skribilo module)) ;; At this point, we're almost done with the bootstrap process. -(format #t "base engine: ~a~%" (lookup-engine 'base)) +;(format #t "base engine: ~a~%" (lookup-engine 'base)) (define *current-engine* ;; By default, use the HTML engine. diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm index a79e88a..c9e0986 100644 --- a/src/guile/skribilo/engine/context.scm +++ b/src/guile/skribilo/engine/context.scm @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index 4ba058a..c290189 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -115,7 +115,7 @@ ;; emit-sui (emit-sui #f) ;; the body - (background "#ffffff") + (background #f) (foreground #f) ;; the margins (margin-padding 3) @@ -124,42 +124,42 @@ (section-left-margin #f) (left-margin-font #f) (left-margin-size 17.) - (left-margin-background "#dedeff") + (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 "#dedeff") + (right-margin-background #f) (right-margin-foreground #f) ;; author configuration (author-font #f) ;; title configuration (title-font #f) - (title-background "#8381de") + (title-background #f) (title-foreground #f) (file-title-separator " -- ") ;; html file naming (file-name-proc ,html-file-default) ;; index configuration - (index-header-font-size +2.) + (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 "#dedeff") - (section-title-foreground "black") + (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 "#ffffff") - (subsection-title-foreground "#8381de") + (subsection-title-background #f) + (subsection-title-foreground #f) (subsection-title-number-separator " ") (subsection-number->string number->string) (subsection-file #f) @@ -167,7 +167,7 @@ (subsubsection-title-start "<h4>") (subsubsection-title-stop "</h4>") (subsubsection-title-background #f) - (subsubsection-title-foreground "#8381de") + (subsubsection-title-foreground #f) (subsubsection-title-number-separator " ") (subsubsection-number->string number->string) (subsubsection-file #f) @@ -572,7 +572,7 @@ ;* document ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'document - :options '(:title :author :ending :html-title :env) + :options '(:title :author :ending :html-title :env :keywords) :action (lambda (n e) (let* ((id (markup-ident n)) (title (new markup @@ -601,13 +601,23 @@ ;*---------------------------------------------------------------------*/ (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))) + (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 @@ -867,7 +877,10 @@ (when title (display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") (if (html-color-spec? tbg) - (printf "<td align=\"center\" bgcolor=\"~a\">" tbg) + (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)) @@ -1058,13 +1071,9 @@ (display "</td></tr>")) ;; name (printf "<tr><td align=\"~a\">" align) - (if nfn - (printf "<font ~a>\n" nfn) - (display "<font size=\"+2\"><i>\n")) + (if nfn (printf "<font ~a>\n" nfn)) (output name e) - (if nfn - (printf "</font>\n") - (display "</i></font>\n")) + (if nfn (printf "</font>\n")) (display "</td></tr>") ;; title (if title (row title)) @@ -1190,12 +1199,18 @@ (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 n :keywords)))) (head (new markup (markup '&html-head) (ident (string-append id "-head")) (class (markup-class n)) (parent n) - (body header))) + (body (list header meta)))) (ftnote (new markup (markup '&html-footnotes) (ident (string-append id "-footnote")) diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm index ddc7c73..48550ef 100644 --- a/src/guile/skribilo/engine/html4.scm +++ b/src/guile/skribilo/engine/html4.scm @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 8727df8..893ab2e 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. ;;; Taken from `lcourtes@laas.fr--2004-libre', @@ -642,7 +642,8 @@ (pdf-author #t) ;; Keywords (a list of string) in the PDF - ;; document information. + ;; document information. This custom is deprecated, + ;; use the `:keywords' option of `document' instead. (pdf-keywords #f) ;; Extra PDF information, an alist of key-value @@ -812,15 +813,11 @@ (if (or (string? t) (ast? t)) t (markup-option doc :title)))) - (keywords (engine-custom engine 'pdf-keywords)) - (extra-fields (engine-custom engine 'pdf-extra-info)) - (stringify-kw (lambda (kws) - (let loop ((kws kws) (s "")) - (if (null? kws) s - (loop (cdr kws) - (string-append s (car kws) - (if (pair? (cdr kws)) - ", " "")))))))) + (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)) @@ -837,13 +834,11 @@ (else (ast->string author))) "")) "") - (if keywords + (if (pair? keywords) (docinfo-field "Keywords" - (cond ((string? keywords) - keywords) - ((pair? keywords) - (stringify-kw keywords)) - (else ""))) + (apply string-append + (keyword-list->comma-separated + keywords))) "") ;; arbitrary key-value pairs, see sect. 4.7, "Info ;; dictionary" of the `pdfmark' reference. @@ -926,7 +921,7 @@ (if (< size 0) "0.3f" "1.5f") "1.0f")))) -(define (lout-color-specification skribe-color) +(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". @@ -975,7 +970,7 @@ ;* document ... */ ;*---------------------------------------------------------------------*/ (markup-writer 'document - :options '(:title :author :ending :env) + :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) @@ -1136,7 +1131,7 @@ (lout-make-doc-cover-sheet n e)))) (if doc-style? - ;; Putting it here will only works with `doc' documents. + ;; Putting it here will only work with `doc' documents. (lout-output-pdf-meta-info n e)))) :after (lambda (n e) @@ -1363,21 +1358,6 @@ (printf "\n\n@End @~a\n\n" lout-markup)))) -(define (markup-option-set! m opt val) - ;; Sets the value of markup option `opt' of markup `m' to `val'. - (let ((o (assoc opt (markup-options m)))) - (if o - (begin -; (set-cdr! o val) - (markup-option-add! m opt val) ;; FIXME: the above method fails - (if (not (eq? (markup-option m opt) val)) - (skribe-error 'markup-option-set! - "Doesn't work!" (markup-option m opt)))) - (begin - (lout-debug "markup-option-set!: markup ~a doesn't have option ~a" - m opt) - #f)))) - (define (lout-markup-child-type skribe-markup) ;; Return the child markup type of `skribe-markup' (e.g. for `chapter', ;; return `section'). @@ -1413,8 +1393,15 @@ ;; first section while other styles don't. (printf "\n@Begin~as\n" lout-markup-name)) - ;; update the `&substructs-started?' option of the parent - (markup-option-set! parent '&substructs-started? #t) + ;; 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?)))) diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index b47f821..abee2fd 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. @@ -26,7 +26,8 @@ :autoload (skribilo parameters) (*verbose* *document-path*) :autoload (skribilo location) (<location>) :autoload (skribilo ast) (ast? markup?) - :autoload (skribilo engine) (engine? find-engine engine-ident) + :autoload (skribilo engine) (*current-engine* + engine? find-engine engine-ident) :autoload (skribilo reader) (*document-reader*) :autoload (skribilo verify) (verify) @@ -56,8 +57,8 @@ ;;; (define (%evaluate expr) ;; Evaluate EXPR, an arbitrary S-expression that may contain calls to the - ;; markup functions defined in `(skribilo skribe api)', e.g., `(bold - ;; "hello")'. + ;; markup functions defined in a markup package such as + ;; `(skribilo package base)', e.g., `(bold "hello")'. (let ((result (eval expr (current-module)))) (if (ast? result) diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/index.scm index 415cadf..33f8d15 100644 --- a/src/guile/skribilo/skribe/index.scm +++ b/src/guile/skribilo/index.scm @@ -1,7 +1,7 @@ ;;; index.scm ;;; ;;; Copyright 2003, 2004 Manuel Serrano -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -16,52 +16,70 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo skribe index)) +(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 index-related functions. +;;; A library of functions dealing with the creation of indices in +;;; documents. ;;; ;;; Code: -;;; The contents of the file below are unchanged compared to Skribe 1.2d's -;;; `index.scm' file found in the `common' directory. +;;; 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-public (index? obj) - (hashtable? obj)) +(define (index? obj) + (hash-table? obj)) ;*---------------------------------------------------------------------*/ ;* *index-table* ... */ ;*---------------------------------------------------------------------*/ -(define-public *index-table* #f) +(define *index-table* (make-parameter #f)) ;*---------------------------------------------------------------------*/ ;* make-index-table ... */ ;*---------------------------------------------------------------------*/ -(define-public (make-index-table ident) - (make-hashtable)) +(define (make-index-table ident) + (make-hash-table)) ;*---------------------------------------------------------------------*/ ;* default-index ... */ ;*---------------------------------------------------------------------*/ -(define-public (default-index) - (if (not *index-table*) - (set! *index-table* (make-index-table "default-index"))) - *index-table*) +(define (default-index) + (if (not (*index-table*)) + (*index-table* (make-index-table "default-index"))) + (*index-table*)) ;*---------------------------------------------------------------------*/ ;* resolve-the-index ... */ ;*---------------------------------------------------------------------*/ -(define-public (resolve-the-index loc i c indexes split char-offset header-limit col) +(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))) @@ -101,7 +119,10 @@ (else (loop (cdr buckets) (cons (car buckets) res))))))) - (let* ((entries (apply append (map hashtable->list indexes))) + (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 diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index f08a36e..21b2a4d 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -17,7 +17,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo lib) @@ -27,7 +27,7 @@ skribe-warning skribe-warning/ast skribe-message - %procedure-arity) + type-name %procedure-arity) :export-syntax (new define-markup define-simple-markup define-simple-container define-processor-markup) @@ -146,6 +146,21 @@ (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 ... ;;; @@ -215,38 +230,9 @@ (apply format (current-error-port) fmt obj))) - ;;; -;;; KEY-GET -;;; -;;; We need to redefine the standard key-get to be more permissive. In -;;; STklos key-get accepts a list which is formed only of keywords. In -;;; Skribe, parameter lists are of the form -;;; (:title "..." :option "...." body1 body2 body3) -;;; So is we find an element which is not a keyword, we skip it (unless it -;;; follows a keyword of course). Since the compiler of extended lambda -;;; uses the function key-get, it will now accept Skribe markups -(define* (key-get lst key #:optional (default #f) default?) - (define (not-found) - (if default? - default - (error 'key-get "value ~S not found in list ~S" key lst))) - (let Loop ((l lst)) - (cond - ((null? l) - (not-found)) - ((not (pair? l)) - (error 'key-get "bad list ~S" lst)) - ((keyword? (car l)) - (if (null? (cdr l)) - (error 'key-get "bad keyword list ~S" lst) - (if (eq? (car l) key) - (cadr l) - (Loop (cddr l))))) - (else - (Loop (cdr l)))))) - - +;;; %PROCEDURE-ARITY +;;; (define (%procedure-arity proc) (car (procedure-property proc 'arity))) diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm index c663605..7c870fa 100644 --- a/src/guile/skribilo/location.scm +++ b/src/guile/skribilo/location.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo location) diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 753aca8..54989fb 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -1,6 +1,6 @@ ;;; module.scm -- Integration of Skribe code as Guile modules. ;;; -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo module) @@ -45,12 +45,14 @@ (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 runtime) ;; `the-options', `the-body', `make-string-replace' (skribilo biblio) (skribilo lib) ;; `define-markup', `unwind-protect', etc. (skribilo resolve) @@ -73,6 +75,8 @@ ((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)) @@ -86,7 +90,7 @@ ((ice-9 receive) . (receive)))) (define %skribe-core-modules - '("utils" "api" "bib" "index" "param" "sui")) + '("param" "sui")) diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm index 02633f1..7a49fd1 100644 --- a/src/guile/skribilo/output.scm +++ b/src/guile/skribilo/output.scm @@ -1,7 +1,7 @@ ;;; output.scm -- Skribilo output stage. ;;; ;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -16,23 +16,75 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo output) - :export (output) :autoload (skribilo engine) (engine-ident processor-get-engine) :autoload (skribilo writer) (writer? writer-ident lookup-markup-writer) - :use-module (skribilo lib) + :autoload (skribilo location) (location?) :use-module (skribilo ast) :use-module (skribilo debug) :use-module (skribilo utils syntax) - :use-module (oop goops)) + :use-module (oop goops) + + :use-module (skribilo condition) + :use-module (srfi srfi-35) + :use-module (srfi srfi-34) + + :export (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. +;;; + (define-generic out) (define (%out/writer n e w) @@ -58,11 +110,10 @@ ((is-a? (car writer) <writer>) (%out/writer node e (car writer))) ((not (car writer)) - (skribe-error 'output - (format #f "illegal ~A user writer" (engine-ident e)) - (if (markup? node) (markup-markup node) node))) + (raise (condition (&output-writer-error (writer writer))))) (else - (skribe-error 'output "illegal user writer" (car writer))))))) + (raise (condition (&output-writer-error (writer writer))))))))) + ;;; @@ -79,7 +130,9 @@ (out (car n*) e) (loop (cdr n*))) ((not (null? n*)) - (skribe-error 'out "Illegal argument" n*))))) + (raise (condition (&invalid-argument-error + (proc-name output) + (argument n*)))))))) (define-method (out (node <string>) e) @@ -113,7 +166,9 @@ (if (> n 0) (if (<= n lb) (output (list-ref body (- n 1)) e) - (skribe-error '! "Too few arguments provided" n))) + (raise (condition (&too-few-arguments-error + (proc-name "output<command>") + (arguments n)))))) lf) (let ((c (string-ref fmt i))) (cond @@ -128,7 +183,9 @@ (output (list-ref body (- n 1)) e) i) (else - (skribe-error '! "Too few arguments provided" n)))) + (raise (condition (&too-few-arguments-error + (proc-name "output<command>") + (arguments n))))))) (else (loops (+ i 1) (+ (- (char->integer c) @@ -151,7 +208,7 @@ (define-method (out (n <unresolved>) e) - (skribe-error 'output "orphan unresolved" n)) + (raise (condition (&output-unresolved-error (ast n))))) (define-method (out (node <markup>) e) diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am index 6cb30b9..693f088 100644 --- a/src/guile/skribilo/package/Makefile.am +++ b/src/guile/skribilo/package/Makefile.am @@ -2,6 +2,6 @@ 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 + eq.scm pie.scm base.scm -SUBDIRS = slide eq +SUBDIRS = slide eq pie diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/package/base.scm index 2cd8b2e..8f484a0 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/package/base.scm @@ -1,4 +1,4 @@ -;;; api.scm -- The markup API of Skribe/Skribilo. +;;; base.scm -- The base markup package of Skribe/Skribilo. ;;; ;;; Copyright 2003, 2004 Manuel Serrano ;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> @@ -16,13 +16,34 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo skribe api) +(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) + :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)) -;;; Author: Manuel Serrano +(fluid-set! current-reader (make-reader 'skribe)) + +;;; Author: Manuel Serrano ;;; Commentary: ;;; ;;; This module contains all the core markups of Skribe/Skribilo. @@ -30,8 +51,8 @@ ;;; Code: -;;; The contents of the file below are unchanged compared to Skribe 1.2d's -;;; `api.scm' file found in the `common' directory. +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `api.scm' file found in the `common' directory. @@ -41,7 +62,7 @@ (define-markup (include file) (if (not (string? file)) (skribe-error 'include "Illegal file (string expected)" file) - (skribe-include file))) + (include-document file))) ;*---------------------------------------------------------------------*/ ;* document ... */ @@ -51,12 +72,12 @@ #!key (ident #f) (class "document") (title #f) (html-title #f) (author #f) - (ending #f) (env '())) + (ending #f) (keywords '()) (env '())) (new document (markup 'document) (ident (or ident (ast->string title) - (symbol->string (gensym 'document)))) + (symbol->string (gensym "document")))) (class class) (required-options '(:title :author :ending)) (options (the-options opts :ident :class :env)) @@ -68,6 +89,20 @@ (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 @@ -87,7 +122,7 @@ (skribe-error 'author "Illegal align value" align) (new container (markup 'author) - (ident (or ident (symbol->string (gensym 'author)))) + (ident (or ident (symbol->string (gensym "author")))) (class class) (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) (options `((:name ,name) @@ -107,7 +142,7 @@ (let ((body (the-body opts))) (new container (markup 'toc) - (ident (or ident (symbol->string (gensym 'toc)))) + (ident (or ident (symbol->string (gensym "toc")))) (class class) (required-options '()) (options `((:chapter ,chapter) @@ -147,7 +182,7 @@ title (html-title #f) (file #f) (toc #t) (number #t)) (new container (markup 'chapter) - (ident (or ident (symbol->string (gensym 'chapter)))) + (ident (or ident (symbol->string (gensym "chapter")))) (class class) (required-options '(:title :file :toc :number)) (options `((:toc ,toc) @@ -187,7 +222,7 @@ title (file #f) (toc #t) (number #t)) (new container (markup 'section) - (ident (or ident (symbol->string (gensym 'section)))) + (ident (or ident (symbol->string (gensym "section")))) (class class) (required-options '(:title :toc :file :toc :number)) (options `((:number ,(section-number number 'section)) @@ -214,7 +249,7 @@ title (file #f) (toc #t) (number #t)) (new container (markup 'subsection) - (ident (or ident (symbol->string (gensym 'subsection)))) + (ident (or ident (symbol->string (gensym "subsection")))) (class class) (required-options '(:title :toc :file :number)) (options `((:number ,(section-number number 'subsection)) @@ -238,7 +273,7 @@ title (file #f) (toc #f) (number #t)) (new container (markup 'subsubsection) - (ident (or ident (symbol->string (gensym 'subsubsection)))) + (ident (or ident (symbol->string (gensym "subsubsection")))) (class class) (required-options '(:title :toc :number :file)) (options `((:number ,(section-number number 'subsubsection)) @@ -258,7 +293,7 @@ (define-markup (~ #!rest opts #!key (class #f)) (new markup (markup '~) - (ident (gensym '~)) + (ident (gensym "~")) (class class) (required-options '()) (options (the-options opts :class)) @@ -272,7 +307,7 @@ ;; The `:label' option used to be called `:number'. (new container (markup 'footnote) - (ident (symbol->string (gensym 'footnote))) + (ident (symbol->string (gensym "footnote"))) (class class) (required-options '()) (options `((:label @@ -292,7 +327,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) (let ((ln (new markup - (ident (or ident (symbol->string (gensym 'linebreak)))) + (ident (or ident (symbol->string (gensym "linebreak")))) (class class) (markup 'linebreak))) (num (the-body opts))) @@ -316,7 +351,7 @@ (width 100.) (height 1)) (new markup (markup 'hrule) - (ident (or ident (symbol->string (gensym 'hrule)))) + (ident (or ident (symbol->string (gensym "hrule")))) (class class) (required-options '()) (options `((:width ,width) @@ -334,7 +369,7 @@ (bg #f) (fg #f) (width #f) (margin #f)) (new container (markup 'color) - (ident (or ident (symbol->string (gensym 'color)))) + (ident (or ident (symbol->string (gensym "color")))) (class class) (required-options '(:bg :fg :width)) (options `((:bg ,(if bg (skribe-use-color! bg) bg)) @@ -352,7 +387,7 @@ (width #f) (margin 2) (border 1)) (new container (markup 'frame) - (ident (or ident (symbol->string (gensym 'frame)))) + (ident (or ident (symbol->string (gensym "frame")))) (class class) (required-options '(:width :border :margin)) (options `((:margin ,margin) @@ -373,7 +408,7 @@ (size #f) (face #f)) (new container (markup 'font) - (ident (or ident (symbol->string (gensym 'font)))) + (ident (or ident (symbol->string (gensym "font")))) (class class) (required-options '(:size)) (options (the-options opts :ident :class)) @@ -391,7 +426,7 @@ ((center left right) (new container (markup 'flush) - (ident (or ident (symbol->string (gensym 'flush)))) + (ident (or ident (symbol->string (gensym "flush")))) (class class) (required-options '(:side)) (options (the-options opts :ident :class)) @@ -426,7 +461,7 @@ (skribe-error 'prog "Illegal mark" mark) (new container (markup 'prog) - (ident (or ident (symbol->string (gensym 'prog)))) + (ident (or ident (symbol->string (gensym "prog")))) (class class) (required-options '(:line :mark)) (options (the-options opts :ident :class :linedigit)) @@ -523,7 +558,7 @@ (let ((s (ast->string legend))) (if (not (string=? s "")) s - (symbol->string (gensym 'figure)))))) + (symbol->string (gensym "figure")))))) (class class) (required-options '(:legend :number :multicolumns)) (options `((:number @@ -551,12 +586,13 @@ (null? (cdr lst))) (parse-list-of for markup (car lst))) (else - (let loop ((lst lst)) + (let loop ((lst lst) + (result '())) (cond ((null? lst) - '()) + (reverse! result)) ((pair? (car lst)) - (loop (car lst))) + (loop (car lst) result)) (else (let ((r (car lst))) (if (not (is-markup? r markup)) @@ -567,7 +603,7 @@ (markup-markup r) (find-runtime-type r)) markup))) - (cons r (loop (cdr lst)))))))))) + (loop (cdr lst) (cons r result))))))))) ;*---------------------------------------------------------------------*/ ;* itemize ... */ @@ -575,7 +611,7 @@ (define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) (new container (markup 'itemize) - (ident (or ident (symbol->string (gensym 'itemize)))) + (ident (or ident (symbol->string (gensym "itemize")))) (class class) (required-options '(:symbol)) (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) @@ -587,7 +623,7 @@ (define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) (new container (markup 'enumerate) - (ident (or ident (symbol->string (gensym 'enumerate)))) + (ident (or ident (symbol->string (gensym "enumerate")))) (class class) (required-options '(:symbol)) (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) @@ -599,7 +635,7 @@ (define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) (new container (markup 'description) - (ident (or ident (symbol->string (gensym 'description)))) + (ident (or ident (symbol->string (gensym "description")))) (class class) (required-options '(:symbol)) (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) @@ -616,7 +652,7 @@ (skribe-type-error 'item "Illegal key:" key "node") (new container (markup 'item) - (ident (or ident (symbol->string (gensym 'item)))) + (ident (or ident (symbol->string (gensym "item")))) (class class) (required-options '(:key)) (options `((:key ,key) ,@(the-options opts :ident :class :key))) @@ -667,7 +703,7 @@ (else (new container (markup 'table) - (ident (or ident (symbol->string (gensym 'table)))) + (ident (or ident (symbol->string (gensym "table")))) (class class) (required-options '(:width :frame :rules)) (options `((:frame ,frame) @@ -682,7 +718,7 @@ (define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) (new container (markup 'tr) - (ident (or ident (symbol->string (gensym 'tr)))) + (ident (or ident (symbol->string (gensym "tr")))) (class class) (required-options '()) (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) @@ -723,7 +759,7 @@ (else (new container (markup 'tc) - (ident (or ident (symbol->string (gensym 'tc)))) + (ident (or ident (symbol->string (gensym "tc")))) (class class) (required-options '(:width :align :valign :colspan)) (options `((markup ,m) @@ -780,7 +816,7 @@ (else (new markup (markup 'image) - (ident (or ident (symbol->string (gensym 'image)))) + (ident (or ident (symbol->string (gensym "image")))) (class class) (required-options '(:file :url :width :height)) (options (the-options opts :ident :class)) @@ -863,7 +899,13 @@ (skribe-error 'processor "Illegal engine" engine)) ((and procedure (or (not (procedure? procedure)) - (not (correct-arity? procedure 2)))) + (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 @@ -911,7 +953,7 @@ (define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) (new markup (markup 'mailto) - (ident (or ident (symbol->string (gensym 'ident)))) + (ident (or ident (symbol->string (gensym "ident")))) (class class) (required-options '(:text)) (options (the-options opts :ident :class)) @@ -920,7 +962,7 @@ ;*---------------------------------------------------------------------*/ ;* *mark-table* ... */ ;*---------------------------------------------------------------------*/ -(define *mark-table* (make-hashtable)) +(define *mark-table* (make-hash-table)) ;*---------------------------------------------------------------------*/ ;* mark ... */ @@ -949,7 +991,7 @@ (class class) (options (the-options opts :ident :class :text)) (body text)))) - (hashtable-put! *mark-table* bs n) + (hash-set! *mark-table* bs n) n))))) ;*---------------------------------------------------------------------*/ @@ -1019,7 +1061,31 @@ (required-options '(:text)) (options `((kind handle) ,@(the-options opts :ident :class))) (body text))) - (define (doref text kind) + (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 '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 @@ -1028,7 +1094,7 @@ (if s (new markup (markup 'ref) - (ident (symbol->string 'ref)) + (ident (symbol->string 'indent-ref)) (class class) (required-options '(:text)) (options `((kind ,kind) @@ -1042,7 +1108,7 @@ (skribe-type-error 'mark "Illegal mark, " mark "string") (new unresolved (proc (lambda (n e env) - (let ((s (hashtable-get *mark-table* mark))) + (let ((s (hash-ref *mark-table* mark))) (if s (new markup (markup 'ref) @@ -1108,17 +1174,17 @@ (cond (skribe (skribe-ref skribe)) (handle (handle-ref handle)) - (ident (doref ident #f)) - (chapter (doref chapter 'chapter)) - (section (doref section 'section)) - (subsection (doref subsection 'subsection)) - (subsubsection (doref subsubsection 'subsubsection)) - (figure (doref figure 'figure)) + (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))))) + (else (skribe-error 'ref "illegal reference" opts))))) ;*---------------------------------------------------------------------*/ ;* resolve ... */ @@ -1212,11 +1278,11 @@ "Illegal index table, " index "index")))) - (m (mark (symbol->string (gensym)))) + (m (mark (symbol->string (gensym "mark")))) (h (new handle (ast m))) (new (new markup (markup '&index-entry) - (ident (or ident (symbol->string (gensym 'index)))) + (ident (or ident (symbol->string (gensym "index")))) (class class) (options `((name ,ename) ,@(the-options opts :ident :class))) (body (if url @@ -1225,10 +1291,12 @@ ;; New is bound to a dummy option of the mark in order ;; to make new options verified. (markup-option-add! m 'to-verify new) - (hashtable-update! table - ename - (lambda (cur) (cons new cur)) - (list 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)) ;*---------------------------------------------------------------------*/ @@ -1255,7 +1323,7 @@ (skribe-error 'the-index "Illegal char offset" char-offset)) ((not (integer? column)) (skribe-error 'the-index "Illegal column number" column)) - ((not (every? index? bd)) + ((not (every index? bd)) (skribe-error 'the-index "Illegal indexes" (filter (lambda (o) (not (index? o))) bd))) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 45a863f..4f5020e 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo package eq) @@ -26,8 +26,8 @@ :use-module (skribilo lib) :use-module (skribilo utils syntax) :use-module (skribilo module) - :use-module (skribilo skribe utils) ;; `the-options', etc. - :autoload (skribilo skribe api) (it symbol sub sup) + :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)) @@ -76,10 +76,6 @@ sim cong approx neq equiv le ge subset supset subseteq supseteq oplus otimes perp mid lceil rceil lfloor rfloor langle rangle)) -(define %rebindings - (map (lambda (sym) - (list sym (symbol-append 'eq: sym))) - %operators)) (define (make-fast-member-predicate lst) (let ((h (make-hash-table))) @@ -93,15 +89,60 @@ (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." - (define eq-sym? - (make-fast-member-predicate (map (lambda (s) - (symbol-append 'eq: s)) - %operators))) (and (markup? m) - (eq-sym? (markup-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." @@ -122,12 +163,14 @@ (eval `(let ,%rebindings ,(eq:symbols->strings equation)) (current-module))) + ;;; ;;; Markup. ;;; -(define-markup (eq :rest opts :key (ident #f) (renderer #f) (class "eq")) +(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")))) @@ -208,13 +251,13 @@ body)) (loop (cdr body) (cons first result))))))))) + ;;; -;;; Base and text-only implementation. +;;; Text-based rendering. ;;; - (markup-writer 'eq (find-engine 'base) :action (lambda (node engine) ;; The `:renderer' option should be a symbol (naming an engine @@ -246,24 +289,37 @@ renderer)))))) (define-macro (simple-markup-writer op . obj) - `(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))) - (display (if (equation-markup? o) "(" "")) - (output o engine) - (display (if (equation-markup? o) ")" "")) - (if (pair? (cdr operands)) - (begin - (display " ") - (output ,(if (null? obj) - (symbol->string op) - (car obj)) - engine) - (display " "))) - (loop (cdr operands)))))))) + ;; 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 -) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 561e4cb..c487b85 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo package eq lout) @@ -26,7 +26,7 @@ :use-module (skribilo engine) :use-module (skribilo lib) :use-module (skribilo utils syntax) - :use-module (skribilo skribe utils) ;; `the-options', etc. + :use-module (skribilo utils keywords) ;; `the-options', etc. :use-module (ice-9 optargs)) (fluid-set! current-reader %skribilo-module-reader) @@ -53,64 +53,78 @@ (markup-writer 'eq (find-engine 'lout) - :before "{ @Eq { " + :options '(:inline?) + :before "{ " :action (lambda (node engine) - (let ((eq (markup-body node))) - ;(fprint (current-error-port) "eq=" eq) - (output eq engine))) + (display (if (markup-option node :inline?) + "@E { " + "@Eq { ")) + (let ((eq (markup-body node))) + ;;(fprint (current-error-port) "eq=" eq) + (output eq engine))) :after " } }") -;; -;; `+' and `-' have lower precedence than `*', `/', `=', etc., so their -;; operands do not need to be enclosed in braces. -;; - -(markup-writer 'eq:+ (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - ;; no braces - (output (car operands) engine) - (if (pair? (cdr operands)) - (display " + ")) - (loop (cdr operands))))))) - -(markup-writer 'eq:- (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - ;; no braces - (output (car operands) engine) - (if (pair? (cdr operands)) - (display " - ")) - (loop (cdr operands))))))) - -(define-macro (simple-lout-markup-writer sym . lout-name) - `(markup-writer ',(symbol-append 'eq: sym) - (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - (display " { ") - (output (car operands) engine) - (display " }") - (if (pair? (cdr operands)) - (display ,(string-append " " - (if (null? lout-name) - (symbol->string sym) - (car lout-name)) - " "))) - (loop (cdr operands)))))))) +(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 / "over") +(simple-lout-markup-writer - "-") +(simple-lout-markup-writer / "over" #f) (simple-lout-markup-writer =) (simple-lout-markup-writer <) (simple-lout-markup-writer >) 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/slide.scm b/src/guile/skribilo/package/slide.scm index 629abdf..8c4582c 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index 128b7e3..58348df 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-skribe-module (skribilo package slide html) diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm index 4105e74..e187d3c 100644 --- a/src/guile/skribilo/package/slide/latex.scm +++ b/src/guile/skribilo/package/slide/latex.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-skribe-module (skribilo package slide latex) diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm index c36c793..817d0ed 100644 --- a/src/guile/skribilo/package/slide/lout.scm +++ b/src/guile/skribilo/package/slide/lout.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-skribe-module (skribilo package slide lout) diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm index a954c7a..e52bdc3 100644 --- a/src/guile/skribilo/package/web-book.scm +++ b/src/guile/skribilo/package/web-book.scm @@ -35,10 +35,11 @@ (center (table :width 97. :border 1 :frame 'box :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold "main page")))) - (tr :bg (engine-custom e 'background) + (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 @@ -60,12 +61,13 @@ (define chapter-browsing (lambda (n e) (center - (table :width 97. :border 1 :frame 'box + (table :width 97. :border 1 :frame 'box :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (markup-option n :title))))) - (tr :bg (engine-custom e 'background) + (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))))))) ;*---------------------------------------------------------------------*/ @@ -79,10 +81,11 @@ (center (table :width 97. :border 1 :frame 'box :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (if chap "Chapters" "Sections"))))) - (tr :bg (engine-custom e 'background) + (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))))))))) diff --git a/src/guile/skribilo/parameters.scm b/src/guile/skribilo/parameters.scm index 04517e7..5893851 100644 --- a/src/guile/skribilo/parameters.scm +++ b/src/guile/skribilo/parameters.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo parameters) diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm index 87b964b..6ef41ee 100644 --- a/src/guile/skribilo/prog.scm +++ b/src/guile/skribilo/prog.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo prog) diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm index 95e545b..871d92c 100644 --- a/src/guile/skribilo/reader.scm +++ b/src/guile/skribilo/reader.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo reader) diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm index 4b7d00d..09792f5 100644 --- a/src/guile/skribilo/reader/outline.scm +++ b/src/guile/skribilo/reader/outline.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo reader outline) @@ -133,13 +133,13 @@ line or a line comment." (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) diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index f92f13b..d3dbb5f 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -1,6 +1,6 @@ ;;; skribe.scm -- A reader for the Skribe syntax. ;;; -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -15,12 +15,13 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 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:)) @@ -46,6 +47,17 @@ the Skribe syntax." (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' @@ -65,18 +77,23 @@ the Skribe syntax." (let ((colon-keywords ;; keywords à la `:key' fashion (r:make-token-reader #\: (r:token-reader-procedure - (r:standard-token-reader 'keyword))))) + (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 - r6rs-symbol-misc-chars quote-quasiquote-unquote semicolon-comment skribe-exp))) diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index 34d6bde..224bc06 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -16,24 +16,70 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo resolve) :use-module (skribilo debug) - :use-module (skribilo runtime) :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)) + find1 resolve-counter resolve-parent resolve-ident + + &resolution-error resolution-error? + &resolution-orphan-error resolution-orphan-error? + resolution-orphan-error:ast)) (fluid-set! current-reader %skribilo-module-reader) + +;;; +;;; Error conditions. +;;; + +(define-condition-type &resolution-error &skribilo-error + resolution-error?) + +(define-condition-type &resolution-orphan-error &resolution-error + resolution-orphan-error? + (ast resolution-orphan-error:ast)) + + +(define (handle-resolution-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((resolution-orphan-error? c) + (let* ((node (resolution-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)) + "")))) + + (else + (format (current-error-port) "undefined resolution error: ~a~%" + c)))) + +(register-error-condition-handler! resolution-error? + handle-resolution-error) + + + +;;; +;;; Resolving nodes. +;;; + (define *unresolved* (make-parameter #f)) (define-generic do-resolve!) @@ -81,7 +127,9 @@ (set-car! n* (do-resolve! (car n*) engine env)) (set-cdr! n* (do-resolve! (cdr n*) engine env))) (else - (error 'do-resolve "illegal argument" n*))))) + (raise (condition (&invalid-argument-error + (proc-name "do-resolve!<pair>") + (argument n*)))))))) (define-method (do-resolve! (node <node>) engine env) @@ -186,7 +234,7 @@ (cadr c) n))) ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "orphan node" n)) + (raise (condition (&resolution-orphan-error (ast n))))) (else (slot-ref n 'parent))))) @@ -219,7 +267,7 @@ (let ((c (assq (symbol-append cnt '-counter) e))) (if (not (pair? c)) (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "orphan node" n) + (raise (condition (&resolution-orphan-error (ast n)))) (begin (set-cdr! (last-pair e) (list (list (symbol-append cnt '-counter) 0) @@ -252,10 +300,9 @@ (debug-item "markup=" markup) (debug-item "n=" (if (markup? n) (markup-markup n) n)) (if (not (string? ident)) - (skribe-type-error 'resolve-ident - "Illegal ident" - ident - "string") + (raise (condition (&invalid-argument-error ;; type error + (proc-name "resolve-ident") + (argument ident)))) (let ((mks (find-markups ident))) (and mks (if (not markup) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am index e005313..4b5797f 100644 --- a/src/guile/skribilo/skribe/Makefile.am +++ b/src/guile/skribilo/skribe/Makefile.am @@ -1,2 +1,2 @@ guilemoduledir = $(GUILE_SITE)/skribilo/skribe -dist_guilemodule_DATA = api.scm bib.scm index.scm param.scm sui.scm utils.scm +dist_guilemodule_DATA = param.scm sui.scm diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm deleted file mode 100644 index 2bc2238..0000000 --- a/src/guile/skribilo/skribe/bib.scm +++ /dev/null @@ -1,215 +0,0 @@ -;;; lib.scm -;;; -;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> -;;; -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;; USA. - -(define-skribe-module (skribilo skribe bib) - :use-module (skribilo biblio)) - -;;; Author: Manuel Serrano -;;; Commentary: -;;; -;;; A library of bibliography-related functions. -;;; -;;; Code: - - -;;; The contents of the file below are unchanged compared to Skribe 1.2d's -;;; `bib.scm' file found in the `common' directory. - -;*---------------------------------------------------------------------*/ -;* bib-load! ... */ -;*---------------------------------------------------------------------*/ -(define-public (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-public (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 (hashtable-get table i))) - (if (is-markup? en '&bib-entry) - en - #f)))) - -;*---------------------------------------------------------------------*/ -;* make-bib-entry ... */ -;*---------------------------------------------------------------------*/ -(define-public (make-bib-entry kind ident fields from) - (let* ((m (new markup - (markup '&bib-entry) - (ident ident) - (options `((kind ,kind) (from ,from))))) - (h (new 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) - (new markup - (markup (symbol-append - '&bib-entry- - (car f))) - (parent h) - (body (cadr f)))) - (bib-parse-error f))) - fields) - m)) - -;*---------------------------------------------------------------------*/ -;* bib-sort/authors ... */ -;*---------------------------------------------------------------------*/ -(define-public (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-public (bib-sort/idents l) - (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f))))) - -;*---------------------------------------------------------------------*/ -;* bib-sort/dates ... */ -;*---------------------------------------------------------------------*/ -(define-public (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-public (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 - (new markup - (markup '&bib-entry-ident) - (parent (car es)) - (options `((number ,i))) - (body (new 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 (hashtable->list 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)) - (new markup - (markup '&the-bibliography) - (options opts) - (body fes))))) - - -;;; bib.scm ends here diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm index 6aebd0a..2084b00 100644 --- a/src/guile/skribilo/skribe/param.scm +++ b/src/guile/skribilo/skribe/param.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-skribe-module (skribilo skribe param)) diff --git a/src/guile/skribilo/skribe/sui.scm b/src/guile/skribilo/skribe/sui.scm index 9baa36a..333e794 100644 --- a/src/guile/skribilo/skribe/sui.scm +++ b/src/guile/skribilo/skribe/sui.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-skribe-module (skribilo skribe sui)) diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm deleted file mode 100644 index 9aaa81f..0000000 --- a/src/guile/skribilo/skribe/utils.scm +++ /dev/null @@ -1,259 +0,0 @@ -;;; utils.scm -;;; -;;; Copyright 2003, 2004 Manuel Serrano -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> -;;; -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;; USA. - -(define-skribe-module (skribilo skribe utils)) - -;;; Author: Manuel Serrano -;;; Commentary: -;;; -;;; A library of various utilities, including AST traversal helper functions. -;;; -;;; Code: - - -;;; The contents of the file below are unchanged compared to Skribe 1.2d's -;;; `lib.scm' file found in the `common' directory. - -;*---------------------------------------------------------------------*/ -;* engine-custom-add! ... */ -;*---------------------------------------------------------------------*/ -(define-public (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))))) - -;*---------------------------------------------------------------------*/ -;* find-markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define-public (find-markup-ident ident) - (let ((r (find-markups ident))) - (if (or (pair? r) (null? r)) - r - '()))) - -;*---------------------------------------------------------------------*/ -;* container-search-down ... */ -;*---------------------------------------------------------------------*/ -(define-public (container-search-down pred obj) - (with-debug 4 'container-search-down - (debug-item "obj=" (find-runtime-type 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 - '()))))) - -;*---------------------------------------------------------------------*/ -;* search-down ... */ -;*---------------------------------------------------------------------*/ -(define-public (search-down pred obj) - (with-debug 4 'search-down - (debug-item "obj=" (find-runtime-type 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 - '()))))) - -;*---------------------------------------------------------------------*/ -;* find-down ... */ -;*---------------------------------------------------------------------*/ -(define-public (find-down pred obj) - (with-debug 4 'find-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj obj)) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (debug-item "loop=" (find-runtime-type obj) - " " (markup-ident obj)) - (if (pred obj) - (list (cons obj (loop (markup-body obj)))) - '())) - (else - (if (pred obj) - (list obj) - '())))))) - -;*---------------------------------------------------------------------*/ -;* find1-down ... */ -;*---------------------------------------------------------------------*/ -(define-public (find1-down pred obj) - (with-debug 4 'find1-down - (let loop ((obj obj) - (stack '())) - (debug-item "obj=" (find-runtime-type obj) - " " (if (markup? obj) (markup-markup obj) "???") - " " (if (markup? obj) (markup-ident obj) "")) - (cond - ((memq obj stack) - (skribe-error 'find1-down "Illegal cyclic 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))))) - -;*---------------------------------------------------------------------*/ -;* find-up ... */ -;*---------------------------------------------------------------------*/ -(define-public (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)))))) - -;*---------------------------------------------------------------------*/ -;* find1-up ... */ -;*---------------------------------------------------------------------*/ -(define-public (find1-up pred obj) - (let loop ((obj obj)) - (cond - ((not (ast? obj)) - #f) - ((pred obj) - obj) - (else - (loop (ast-parent obj)))))) - -;*---------------------------------------------------------------------*/ -;* ast-document ... */ -;*---------------------------------------------------------------------*/ -(define-public (ast-document m) - (find1-up document? m)) - -;*---------------------------------------------------------------------*/ -;* ast-chapter ... */ -;*---------------------------------------------------------------------*/ -(define-public (ast-chapter m) - (find1-up (lambda (n) (is-markup? n 'chapter)) m)) - -;*---------------------------------------------------------------------*/ -;* ast-section ... */ -;*---------------------------------------------------------------------*/ -(define-public (ast-section m) - (find1-up (lambda (n) (is-markup? n 'section)) m)) - -;*---------------------------------------------------------------------*/ -;* the-body ... */ -;* ------------------------------------------------------------- */ -;* Filter out the options */ -;*---------------------------------------------------------------------*/ -(define-public (the-body 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)))))) - -;*---------------------------------------------------------------------*/ -;* the-options ... */ -;* ------------------------------------------------------------- */ -;* Returns an list made of options. The OUT argument contains */ -;* keywords that are filtered out. */ -;*---------------------------------------------------------------------*/ -(define-public (the-options opt+ . out) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-options "Illegal options" opt*)) - ((keyword? (car opt*)) - (cond - ((null? (cdr opt*)) - (skribe-error 'the-options "Illegal option" (car opt*))) - ((memq (car opt*) out) - (loop (cdr opt*) res)) - (else - (loop (cdr opt*) - (cons (list (car opt*) (cadr opt*)) res))))) - (else - (loop (cdr opt*) res))))) - -;*---------------------------------------------------------------------*/ -;* list-split ... */ -;*---------------------------------------------------------------------*/ -(define-public (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))))) - -;;; utils.scm ends here diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index 24e4b67..a61de4f 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -16,7 +16,7 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am index fa693a1..9d9df6f 100644 --- a/src/guile/skribilo/utils/Makefile.am +++ b/src/guile/skribilo/utils/Makefile.am @@ -1,4 +1,5 @@ guilemoduledir = $(GUILE_SITE)/skribilo/utils -dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm +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 index 24ce784..c8c3bd0 100644 --- a/src/guile/skribilo/utils/compat.scm +++ b/src/guile/skribilo/utils/compat.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. @@ -32,6 +32,7 @@ :autoload (skribilo ast) (ast?) :autoload (skribilo condition) (file-search-error? &file-search-error) :autoload (skribilo reader) (make-reader) + :autoload (skribilo lib) (type-name) :use-module (skribilo debug) :re-export (file-size) ;; re-exported from `(skribilo utils files)' :replace (gensym)) @@ -169,7 +170,7 @@ (define-public skribe-eval-port evaluate-document-from-port) (set! %skribe-reader #f) -(define* (skribe-read #:optional (port (current-input-port))) +(define*-public (skribe-read #:optional (port (current-input-port))) (if (not %skribe-reader) (set! %skribe-reader (make-reader 'skribe))) (%skribe-reader port)) @@ -248,20 +249,11 @@ (hash-set! table key init-value) (set-cdr! handle (update-proc (cdr handle)))))) -(define-public hashtable->list (lambda (h) - (map cdr (hash-map->list cons h)))) +(define-public (hashtable->list h) + (hash-map->list (lambda (key val) val) h)) (define-public (find-runtime-type 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)))))) - + (type-name obj)) ;;; @@ -270,7 +262,17 @@ (use-modules ((srfi srfi-19) #:renamer (symbol-prefix-proc 's19:))) -(define (date) +(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 index 7eb1cf2..6d89d4d 100644 --- a/src/guile/skribilo/utils/files.scm +++ b/src/guile/skribilo/utils/files.scm @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo utils files) diff --git a/src/guile/skribilo/utils/images.scm b/src/guile/skribilo/utils/images.scm index 2d163bc..24405d6 100644 --- a/src/guile/skribilo/utils/images.scm +++ b/src/guile/skribilo/utils/images.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo utils images) 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/runtime.scm b/src/guile/skribilo/utils/strings.scm index 73d776c..e8e8f8f 100644 --- a/src/guile/skribilo/runtime.scm +++ b/src/guile/skribilo/utils/strings.scm @@ -1,4 +1,4 @@ -;;; runtime.scm -- Skribilo runtime system +;;; 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> @@ -15,31 +15,24 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-module (skribilo runtime) - ;; FIXME: Useful procedures are scattered between here and - ;; `(skribilo skribe utils)'. - :export (;; Utilities - strip-ref-base string-canonicalize - - ;; String writing +(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)) - -;;; ====================================================================== + ;;; -;;; U T I L I T I E S +;;; Utilities. ;;; -;;; ====================================================================== - -;;FIXME: Remonter cette fonction (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*)))) @@ -54,8 +47,9 @@ (substring file (+ l 1) (string-length file))))))) -;; FIXME: Remonter cette fonction (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) @@ -88,11 +82,10 @@ -;;; ====================================================================== + ;;; -;;; S T R I N G - W R I T I N G +;;; String writing. ;;; -;;; ====================================================================== ;; ;; (define (%make-html-replace) @@ -136,17 +129,17 @@ str) (get-output-string out))))) -(define string->html - (%make-general-string-replace '((#\" """) (#\& "&") (#\< "<") - (#\> ">")))) +(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 '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) - string->html) + ((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 index f7a5990..44bff09 100644 --- a/src/guile/skribilo/utils/syntax.scm +++ b/src/guile/skribilo/utils/syntax.scm @@ -1,6 +1,6 @@ ;;; syntax.scm -- Syntactic candy for Skribilo modules. ;;; -;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -15,7 +15,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo utils syntax) @@ -30,21 +30,33 @@ ;;; ;;; 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). +;;; 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. - (make-alternate-guile-reader '(colon-keywords - no-scsh-block-comments - srfi30-block-comments - srfi62-sexp-comments) - (lambda (chr port read) - (error "unexpected character in Skribilo module" - chr)) - 'reader/record-positions)) + (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. diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm index 960ca6b..052b5cc 100644 --- a/src/guile/skribilo/verify.scm +++ b/src/guile/skribilo/verify.scm @@ -16,18 +16,17 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo verify) - :autoload (skribilo engine) (engine-ident) + :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 runtime) (skribilo ast) (skribilo utils syntax) (oop goops)) diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm index b46cddc..b16819d 100644 --- a/src/guile/skribilo/writer.scm +++ b/src/guile/skribilo/writer.scm @@ -16,7 +16,7 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. (define-module (skribilo writer) |