From f9d6b7ca101444e7d278ea821a93e4b6172ff4bb Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Fri, 28 Jul 2006 15:06:14 +0000
Subject: Moved `(skribilo skribe index)' to `(skribilo index)'.
* src/guile/skribilo/index.scm: No longer use `define-skribe-module'.
Use the native hash-table functions instead of the one from `compat'.
(*index-table*): Made an SRFI-39 parameter.
* src/guile/skribilo/module.scm (%skribilo-user-autoloads): Added
`(skribilo index)'.
(%skribe-core-modules): Removed `index'.
* src/guile/skribilo/package/base.scm: Use `(skribilo index)' instead of
`(skribilo skribe index)'.
* src/guile/skribilo/skribe/Makefile.am (dist_guilemodule_DATA): Removed
`index.scm'.
git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-33
---
src/guile/skribilo/index.scm | 170 ++++++++++++++++++++++++++++++++++
src/guile/skribilo/module.scm | 4 +-
src/guile/skribilo/package/base.scm | 4 +-
src/guile/skribilo/skribe/Makefile.am | 2 +-
src/guile/skribilo/skribe/index.scm | 149 -----------------------------
5 files changed, 175 insertions(+), 154 deletions(-)
create mode 100644 src/guile/skribilo/index.scm
delete mode 100644 src/guile/skribilo/skribe/index.scm
(limited to 'src')
diff --git a/src/guile/skribilo/index.scm b/src/guile/skribilo/index.scm
new file mode 100644
index 0000000..33f8d15
--- /dev/null
+++ b/src/guile/skribilo/index.scm
@@ -0,0 +1,170 @@
+;;; index.scm
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Court�s <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo index)
+ :use-syntax (skribilo utils syntax)
+ :use-syntax (skribilo lib)
+
+ :use-module (skribilo lib)
+ :use-module (skribilo ast)
+ :use-module (srfi srfi-39)
+
+ ;; XXX: The use of `mark' here introduces a cross-dependency between
+ ;; `index' and `package base'. Thus, we require that each of these two
+ ;; modules autoloads the other one.
+ :autoload (skribilo package base) (mark)
+
+ :export (index? make-index-table *index-table*
+ default-index resolve-the-index))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; A library of functions dealing with the creation of indices in
+;;; documents.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `index.scm' file found in the `common' directory.
+
+
+;*---------------------------------------------------------------------*/
+;* index? ... */
+;*---------------------------------------------------------------------*/
+(define (index? obj)
+ (hash-table? obj))
+
+;*---------------------------------------------------------------------*/
+;* *index-table* ... */
+;*---------------------------------------------------------------------*/
+(define *index-table* (make-parameter #f))
+
+;*---------------------------------------------------------------------*/
+;* make-index-table ... */
+;*---------------------------------------------------------------------*/
+(define (make-index-table ident)
+ (make-hash-table))
+
+;*---------------------------------------------------------------------*/
+;* default-index ... */
+;*---------------------------------------------------------------------*/
+(define (default-index)
+ (if (not (*index-table*))
+ (*index-table* (make-index-table "default-index")))
+ (*index-table*))
+
+;*---------------------------------------------------------------------*/
+;* resolve-the-index ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-the-index loc i c indexes split char-offset header-limit col)
+ ;; fetch the descriminating index name letter
+ (define (index-ref n)
+ (let ((name (markup-option n 'name)))
+ (if (>= char-offset (string-length name))
+ (skribe-error 'the-index "char-offset out of bound" char-offset)
+ (string-ref name char-offset))))
+ ;; sort a bucket of entries (the entries in a bucket share there name)
+ (define (sort-entries-bucket ie)
+ (sort ie
+ (lambda (i1 i2)
+ (or (not (markup-option i1 :note))
+ (markup-option i2 :note)))))
+ ;; accumulate all the entries starting with the same letter
+ (define (letter-references refs)
+ (let ((letter (index-ref (car (car refs)))))
+ (let loop ((refs refs)
+ (acc '()))
+ (if (or (null? refs)
+ (not (char-ci=? letter (index-ref (car (car refs))))))
+ (values (char-upcase letter) acc refs)
+ (loop (cdr refs) (cons (car refs) acc))))))
+ ;; merge the buckets that comes from different index tables
+ (define (merge-buckets buckets)
+ (if (null? buckets)
+ '()
+ (let loop ((buckets buckets)
+ (res '()))
+ (cond
+ ((null? (cdr buckets))
+ (reverse! (cons (car buckets) res)))
+ ((string=? (markup-option (car (car buckets)) 'name)
+ (markup-option (car (cadr buckets)) 'name))
+ ;; we merge
+ (loop (cons (append (car buckets) (cadr buckets))
+ (cddr buckets))
+ res))
+ (else
+ (loop (cdr buckets)
+ (cons (car buckets) res)))))))
+ (let* ((entries (apply append (map (lambda (t)
+ (hash-map->list
+ (lambda (key val) val) t))
+ indexes)))
+ (sorted (map sort-entries-bucket
+ (merge-buckets
+ (sort entries
+ (lambda (e1 e2)
+ (string-ci<?
+ (markup-option (car e1) 'name)
+ (markup-option (car e2) 'name))))))))
+ (if (and (not split) (< (apply + (map length sorted)) header-limit))
+ (new markup
+ (markup '&the-index)
+ (loc loc)
+ (ident i)
+ (class c)
+ (options `((:column ,col)))
+ (body sorted))
+ (let loop ((refs sorted)
+ (lrefs '())
+ (body '()))
+ (if (null? refs)
+ (new markup
+ (markup '&the-index)
+ (loc loc)
+ (ident i)
+ (class c)
+ (options `((:column ,col)
+ (header ,(new markup
+ (markup '&the-index-header)
+ (loc loc)
+ (body (reverse! lrefs))))))
+ (body (reverse! body)))
+ (call-with-values
+ (lambda () (letter-references refs))
+ (lambda (l lr next-refs)
+ (let* ((s (string l))
+ (m (mark (symbol->string (gensym s)) :text s))
+ (h (new handle (loc loc) (ast m)))
+ (r (ref :handle h :text s)))
+ (ast-loc-set! m loc)
+ (ast-loc-set! r loc)
+ (loop next-refs
+ (cons r lrefs)
+ (append lr (cons m body)))))))))))
+
+
+;;; index.scm ends here
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index f68d4aa..54989fb 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -75,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))
@@ -88,7 +90,7 @@
((ice-9 receive) . (receive))))
(define %skribe-core-modules
- '("index" "param" "sui"))
+ '("param" "sui"))
diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm
index 69818da..7b97c5d 100644
--- a/src/guile/skribilo/package/base.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -37,9 +37,7 @@
:autoload (skribilo color) (skribe-use-color!)
:autoload (skribilo source) (language? source-read-lines source-fontify)
:autoload (skribilo prog) (make-prog-body resolve-line)
-
- :use-module (skribilo module) ;; needed before loading the following one
- :autoload (skribilo skribe index) (make-index-table)
+ :autoload (skribilo index) (make-index-table)
:replace (symbol))
diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am
index 91e3944..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 = index.scm param.scm sui.scm
+dist_guilemodule_DATA = param.scm sui.scm
diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm
deleted file mode 100644
index 12ef31e..0000000
--- a/src/guile/skribilo/skribe/index.scm
+++ /dev/null
@@ -1,149 +0,0 @@
-;;; index.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
-;;; USA.
-
-(define-skribe-module (skribilo skribe index))
-
-;;; Author: Manuel Serrano
-;;; Commentary:
-;;;
-;;; A library of index-related functions.
-;;;
-;;; Code:
-
-
-;;; The contents of the file below are unchanged compared to Skribe 1.2d's
-;;; `index.scm' file found in the `common' directory.
-
-
-;*---------------------------------------------------------------------*/
-;* index? ... */
-;*---------------------------------------------------------------------*/
-(define-public (index? obj)
- (hashtable? obj))
-
-;*---------------------------------------------------------------------*/
-;* *index-table* ... */
-;*---------------------------------------------------------------------*/
-(define-public *index-table* #f)
-
-;*---------------------------------------------------------------------*/
-;* make-index-table ... */
-;*---------------------------------------------------------------------*/
-(define-public (make-index-table ident)
- (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* default-index ... */
-;*---------------------------------------------------------------------*/
-(define-public (default-index)
- (if (not *index-table*)
- (set! *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)
- ;; fetch the descriminating index name letter
- (define (index-ref n)
- (let ((name (markup-option n 'name)))
- (if (>= char-offset (string-length name))
- (skribe-error 'the-index "char-offset out of bound" char-offset)
- (string-ref name char-offset))))
- ;; sort a bucket of entries (the entries in a bucket share there name)
- (define (sort-entries-bucket ie)
- (sort ie
- (lambda (i1 i2)
- (or (not (markup-option i1 :note))
- (markup-option i2 :note)))))
- ;; accumulate all the entries starting with the same letter
- (define (letter-references refs)
- (let ((letter (index-ref (car (car refs)))))
- (let loop ((refs refs)
- (acc '()))
- (if (or (null? refs)
- (not (char-ci=? letter (index-ref (car (car refs))))))
- (values (char-upcase letter) acc refs)
- (loop (cdr refs) (cons (car refs) acc))))))
- ;; merge the buckets that comes from different index tables
- (define (merge-buckets buckets)
- (if (null? buckets)
- '()
- (let loop ((buckets buckets)
- (res '()))
- (cond
- ((null? (cdr buckets))
- (reverse! (cons (car buckets) res)))
- ((string=? (markup-option (car (car buckets)) 'name)
- (markup-option (car (cadr buckets)) 'name))
- ;; we merge
- (loop (cons (append (car buckets) (cadr buckets))
- (cddr buckets))
- res))
- (else
- (loop (cdr buckets)
- (cons (car buckets) res)))))))
- (let* ((entries (apply append (map hashtable->list indexes)))
- (sorted (map sort-entries-bucket
- (merge-buckets
- (sort entries
- (lambda (e1 e2)
- (string-ci<?
- (markup-option (car e1) 'name)
- (markup-option (car e2) 'name))))))))
- (if (and (not split) (< (apply + (map length sorted)) header-limit))
- (new markup
- (markup '&the-index)
- (loc loc)
- (ident i)
- (class c)
- (options `((:column ,col)))
- (body sorted))
- (let loop ((refs sorted)
- (lrefs '())
- (body '()))
- (if (null? refs)
- (new markup
- (markup '&the-index)
- (loc loc)
- (ident i)
- (class c)
- (options `((:column ,col)
- (header ,(new markup
- (markup '&the-index-header)
- (loc loc)
- (body (reverse! lrefs))))))
- (body (reverse! body)))
- (call-with-values
- (lambda () (letter-references refs))
- (lambda (l lr next-refs)
- (let* ((s (string l))
- (m (mark (symbol->string (gensym s)) :text s))
- (h (new handle (loc loc) (ast m)))
- (r (ref :handle h :text s)))
- (ast-loc-set! m loc)
- (ast-loc-set! r loc)
- (loop next-refs
- (cons r lrefs)
- (append lr (cons m body)))))))))))
-
-
-;;; index.scm ends here
--
cgit v1.2.3