diff options
| -rw-r--r-- | src/guile/skribilo/biblio.scm | 223 | ||||
| -rw-r--r-- | src/guile/skribilo/module.scm | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/skribe/Makefile.am | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/skribe/bib.scm | 215 |
4 files changed, 218 insertions, 224 deletions
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index 2d5f1ea..04a8bfd 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 @@ -23,20 +23,38 @@ (define-module (skribilo biblio) :use-module (skribilo runtime) :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 (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 bib-for-each bib-map - skribe-open-bib-file parse-bib)) + 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) @@ -171,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/module.scm b/src/guile/skribilo/module.scm index 753aca8..1d716be 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -86,7 +86,7 @@ ((ice-9 receive) . (receive)))) (define %skribe-core-modules - '("utils" "api" "bib" "index" "param" "sui")) + '("utils" "api" "index" "param" "sui")) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am index e005313..5b329b4 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 = api.scm index.scm param.scm sui.scm utils.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 |