aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo/biblio.scm223
-rw-r--r--src/guile/skribilo/module.scm2
-rw-r--r--src/guile/skribilo/skribe/Makefile.am2
-rw-r--r--src/guile/skribilo/skribe/bib.scm215
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
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-20 08:51:10 +0000