diff options
Diffstat (limited to 'src/guile/skribilo/biblio.scm')
-rw-r--r-- | src/guile/skribilo/biblio.scm | 382 |
1 files changed, 382 insertions, 0 deletions
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm new file mode 100644 index 0000000..1fb4b78 --- /dev/null +++ b/src/guile/skribilo/biblio.scm @@ -0,0 +1,382 @@ +;;; biblio.scm -- Bibliography functions. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA.main.st + + + +(define-module (skribilo biblio) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) ;; `when', `unless' + + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :use-module (srfi srfi-1) + :autoload (skribilo condition) (&file-search-error) + + :autoload (skribilo reader) (%default-reader) + :autoload (skribilo parameters) (*bib-path*) + :autoload (skribilo ast) (<markup> <handle> is-markup?) + + :use-module (ice-9 optargs) + :use-module (oop goops) + + :export (bib-table? make-bib-table default-bib-table + bib-add! bib-duplicate bib-for-each bib-map + skribe-open-bib-file parse-bib + + bib-load! resolve-bib resolve-the-bib make-bib-entry + + ;; sorting entries + bib-sort/authors bib-sort/idents bib-sort/dates)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Provides the bibliography data type and basic bibliography handling, +;;; including simple procedures to sort bibliography entries. +;;; +;;; FIXME: This module need cleanup! +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;; FIXME: Should be a fluid? +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + + + +;;; ====================================================================== +;;; +;;; Utilities +;;; +;;; ====================================================================== + +(define (make-bib-table ident) + (make-hash-table)) + +(define (bib-table? obj) + (hash-table? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +(define (%bib-error who entry) + (let ((msg "bibliography syntax error on entry")) + (if (%epair? entry) + (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) + (skribe-error who msg entry)))) + +(define* (bib-for-each proc :optional (table (default-bib-table))) + (hash-for-each (lambda (ident entry) + (proc ident entry)) + table)) + +(define* (bib-map proc :optional (table (default-bib-table))) + (hash-map->list (lambda (ident entry) + (proc ident entry)) + table)) + + +;;; ====================================================================== +;;; +;;; BIB-DUPLICATE +;;; +;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format #f "duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format #f " using version of `~a'.\n" ofrom) + "") + (if from + (format #f " ignoring version of `~a'." from) + " ignoring redefinition.")))) + + +;;; ====================================================================== +;;; +;;; PARSE-BIB +;;; +;;; ====================================================================== +(define (parse-bib table port) + (let ((read %default-reader)) ;; FIXME: We should use a fluid + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-filename port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate ident from old) + (hash-set! table key + (make-bib-entry kind key fields from))) + (Loop (read port)))) + (else + (%bib-error 'bib-parse entry))))))))) + + +;;; ====================================================================== +;;; +;;; BIB-ADD! +;;; +;;; ====================================================================== +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate key #f old) + (hash-set! table key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + + +;;; ====================================================================== +;;; +;;; SKRIBE-OPEN-BIB-FILE +;;; +;;; ====================================================================== +;; FIXME: Factoriser +(define (skribe-open-bib-file file command) + (let ((path (search-path (*bib-path*) file))) + (if (string? path) + (begin + (when (> (*verbose*) 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format #f command path)) + path))) + (raise (condition (&file-search-error (file-name file) + (path (*bib-path*)))))))) + + +;;; +;;; High-level API. +;;; +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `bib.scm' file found in the `common' directory. The copyright notice for +;;; this file was: +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; + + +;*---------------------------------------------------------------------*/ +;* bib-load! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-load! table filename command) + (if (not (bib-table? table)) + (skribe-error 'bib-load "Illegal bibliography table" table) + ;; read the file + (let ((p (skribe-open-bib-file filename command))) + (if (not (input-port? p)) + (skribe-error 'bib-load "Can't open data base" filename) + (unwind-protect + (parse-bib table p) + (close-input-port p)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-bib table ident) + (if (not (bib-table? table)) + (skribe-error 'resolve-bib "Illegal bibliography table" table) + (let* ((i (cond + ((string? ident) ident) + ((symbol? ident) (symbol->string ident)) + (else (skribe-error 'resolve-bib "Illegal ident" ident)))) + (en (hash-ref table i))) + (if (is-markup? en '&bib-entry) + en + #f)))) + +;*---------------------------------------------------------------------*/ +;* make-bib-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-entry kind ident fields from) + (let* ((m (make <markup> + :markup '&bib-entry + :ident ident + :options `((kind ,kind) (from ,from)))) + (h (make <handle> :ast m))) + (for-each (lambda (f) + (if (and (pair? f) + (pair? (cdr f)) + (null? (cddr f)) + (symbol? (car f))) + (markup-option-add! m + (car f) + (make <markup> + :markup (symbol-append + '&bib-entry- + (car f)) + :parent h + :body (cadr f))) + (bib-parse-error f))) + fields) + m)) + +;*---------------------------------------------------------------------*/ +;* bib-sort/authors ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/authors l) + (define (cmp i1 i2 def) + (cond + ((and (markup? i1) (markup? i2)) + (cmp (markup-body i1) (markup-body i2) def)) + ((markup? i1) + (cmp (markup-body i1) i2 def)) + ((markup? i2) + (cmp i1 (markup-body i2) def)) + ((and (string? i1) (string? i2)) + (if (string=? i1 i2) + (def) + (string<? i1 i2))) + ((string? i1) + #f) + ((string? i2) + #t) + (else + (def)))) + (sort l (lambda (e1 e2) + (cmp (markup-option e1 'author) + (markup-option e2 'author) + (lambda () + (cmp (markup-option e1 'year) + (markup-option e2 'year) + (lambda () + (cmp (markup-option e1 'title) + (markup-option e2 'title) + (lambda () + (cmp (markup-ident e1) + (markup-ident e2) + (lambda () + #t))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/idents ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/idents l) + (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/dates ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/dates l) + (sort l (lambda (p1 p2) + (define (month-num m) + (let ((body (markup-body m))) + (if (not (string? body)) + 13 + (let* ((s (if (> (string-length body) 3) + (substring body 0 3) + body)) + (sy (string->symbol (string-downcase body))) + (c (assq sy '((jan . 1) + (feb . 2) + (mar . 3) + (apr . 4) + (may . 5) + (jun . 6) + (jul . 7) + (aug . 8) + (sep . 9) + (oct . 10) + (nov . 11) + (dec . 12))))) + (if (pair? c) (cdr c) 13))))) + (let ((d1 (markup-option p1 'year)) + (d2 (markup-option p2 'year))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((y1 (markup-body d1)) + (y2 (markup-body d2))) + (cond + ((string>? y1 y2) #t) + ((string<? y1 y2) #f) + (else + (let ((d1 (markup-option p1 'month)) + (d2 (markup-option p2 'month))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((m1 (month-num d1)) + (m2 (month-num d2))) + (> m1 m2)))))))))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-the-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-bib table n sort pred count opts) + (define (count! entries) + (let loop ((es entries) + (i 1)) + (if (pair? es) + (begin + (markup-option-add! (car es) + :title + (make <markup> + :markup '&bib-entry-ident + :parent (car es) + :options `((number ,i)) + :body (make <handle> :ast (car es)))) + (loop (cdr es) (+ i 1)))))) + (if (not (bib-table? table)) + (skribe-error 'resolve-the-bib "Illegal bibliography table" table) + (let* ((es (sort (hash-map->list (lambda (key val) val) table))) + (fes (filter (if (procedure? pred) + (lambda (m) (pred m n)) + (lambda (m) (pair? (markup-option m 'used)))) + es))) + (count! (if (eq? count 'full) es fes)) + (make <markup> + :markup '&the-bibliography + :options opts + :body fes)))) + + +;;; biblio.scm ends here |