Factorized `bib-ref+', add a `:sort-bib-refs' options to `ref'.

* src/guile/skribilo/biblio.scm (bib-sort-refs/number): New.

* src/guile/skribilo/engine/base.scm: Use `%skribilo-module-reader'
  instead of the Skribe reader.
  (bib-ref, bib-ref+): New writer.  Handle `:sort-bib-refs' in
  `bib-ref+'.

* src/guile/skribilo/engine/context.scm (bib-ref+): Removed.

* src/guile/skribilo/engine/html.scm (bib-ref+): Removed.

* src/guile/skribilo/engine/latex.scm (bib-ref, bib-ref+): Removed.

* src/guile/skribilo/engine/lout.scm (lout-bib-refs-sort/number):
  Removed.
  (lout-engine): Documented `bib-refs-sort-proc' as unused.
  (bib-ref, bib-ref+): Removed.

* src/guile/skribilo/package/base.scm (ref): New `:sort-bib-refs' option.
  [bib-ref]: Add it to the markup's option list.

git-archimport-id: lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-80

5 files changed, 56 insertions, 163 deletions

diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm
index 9941ff1..9e9445e 100644
--- a/src/guile/skribilo/engine/base.scm
+++ b/src/guile/skribilo/engine/base.scm
@@ -31,12 +31,11 @@
   :autoload   (skribilo biblio template) (make-bib-entry-template/default
                                           output-bib-entry-template)
   ;; syntactic sugar
-  :use-module (skribilo reader)
   :use-module (skribilo utils syntax)
 
   :export (base-engine))
 
-(fluid-set! current-reader (make-reader 'skribe))
+(fluid-set! current-reader %skribilo-module-reader)
 
 
 ;*---------------------------------------------------------------------*/
@@ -195,6 +194,57 @@
    :action #f)
 
 ;*---------------------------------------------------------------------*/
+;*    bib-ref ...                                                      */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+   :options '(:text :bib)
+   :before "["
+   :action (lambda (n e)
+             (let* ((ref   (markup-body n))
+                    (entry (handle-ast ref)))
+               (output (markup-option entry :title) e)))
+   :after "]")
+
+;*---------------------------------------------------------------------*/
+;*    bib-ref+ ...                                                     */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+   :options '(:text :bib :sort-bib-refs)
+   :before "["
+   :action (lambda (n e)
+             (define (make-sort-proc proc)
+               ;; Return a safe sort procedure that passes PROC two
+               ;; `&bib-entry' markups.
+               (lambda (r1 r2)
+                 ;; don't pass `unref's to PROC
+                 (and (is-markup? r1 'bib-ref)
+                      (is-markup? r2 'bib-ref)
+                      (let ((e1 (handle-ast (markup-body r1)))
+                            (e2 (handle-ast (markup-body r2))))
+                        (proc e1 e2)))))
+
+             (define sort-refs (markup-option n :sort-bib-refs))
+
+             (let loop ((refs (if (procedure? sort-refs)
+                                  (sort (markup-body n)
+                                        (make-sort-proc sort-refs))
+                                  (markup-body n))))
+               (cond
+                ((null? refs)
+                 #f)
+                (else
+                 (if (is-markup? (car refs) 'bib-ref)
+                     (invoke (writer-action (markup-writer-get 'bib-ref e))
+                             (car refs)
+                             e)
+                     (output (car refs) e))
+                 (if (pair? (cdr refs))
+                     (begin
+                       (display ", ")
+                       (loop (cdr refs))))))))
+   :after "]")
+
+;*---------------------------------------------------------------------*/
 ;*    &the-bibliography ...                                            */
 ;*---------------------------------------------------------------------*/
 (markup-writer '&the-bibliography
diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm
index 87d36df..1b4301b 100644
--- a/src/guile/skribilo/engine/context.scm
+++ b/src/guile/skribilo/engine/context.scm
@@ -1051,28 +1051,6 @@
 	       (format #t "\\goto{~a}[~a]" ref (string-canonicalize ident))))
    :after (lambda (n e) (output "]" e)))
 
-;;; ======================================================================
-;;;   bib-ref+ ...
-;;; ======================================================================
-(markup-writer 'bib-ref+
-   :options '(:text :bib)
-   :before (lambda (n e) (output "[" e))
-   :action (lambda (n e)
-	      (let loop ((rs (markup-body n)))
-		 (cond
-		    ((null? rs)
-		     #f)
-		    (else
-		     (if (is-markup? (car rs) 'bib-ref)
-			 (invoke (writer-action (markup-writer-get 'bib-ref e))
-				 (car rs)
-				 e)
-			 (output (car rs) e))
-		     (if (pair? (cdr rs))
-			 (begin
-			    (display ",")
-			    (loop (cdr rs))))))))
-   :after (lambda (n e) (output "]" e)))
 
 ;;; ======================================================================
 ;;;	url-ref ...
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
index 86af489..688d33d 100644
--- a/src/guile/skribilo/engine/html.scm
+++ b/src/guile/skribilo/engine/html.scm
@@ -2032,28 +2032,9 @@
 (markup-writer 'bib-ref
    :options '(:text :bib)
    :before "["
-   :action (lambda (n e) (output n e (markup-writer-get 'ref e)))
-   :after "]")
-
-;*---------------------------------------------------------------------*/
-;*    bib-ref+ ...                                                     */
-;*---------------------------------------------------------------------*/
-(markup-writer 'bib-ref+
-   :options '(:text :bib)
-   :before "["
    :action (lambda (n e)
-	      (let loop ((rs (markup-body n)))
-		 (cond
-		    ((null? rs)
-		     #f)
-		    (else
-		     (if (is-markup? (car rs) 'bib-ref)
-			 (output (car rs) e (markup-writer-get 'ref e))
-			 (output (car rs) e))
-		     (if (pair? (cdr rs))
-			 (begin
-			    (display ",")
-			    (loop (cdr rs))))))))
+             ;; Produce a hyperlink.
+             (output n e (markup-writer-get 'ref e)))
    :after "]")
 
 ;*---------------------------------------------------------------------*/
diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm
index 50b59d6..9b49545 100644
--- a/src/guile/skribilo/engine/latex.scm
+++ b/src/guile/skribilo/engine/latex.scm
@@ -1545,39 +1545,6 @@
                                (string-canonicalize id)))))))
 
 ;*---------------------------------------------------------------------*/
-;*    bib-ref ...                                                      */
-;*---------------------------------------------------------------------*/
-(markup-writer 'bib-ref
-   :options '(:text :bib)
-   :before "["
-   :action (lambda (n e)
-	      (output (markup-option (handle-ast (markup-body n)) :title) e))
-   :after "]")
-
-;*---------------------------------------------------------------------*/
-;*    bib-ref+ ...                                                     */
-;*---------------------------------------------------------------------*/
-(markup-writer 'bib-ref+
-   :options '(:text :bib)
-   :before "["
-   :action (lambda (n e) 
-	      (let loop ((rs (markup-body n)))
-		 (cond
-		    ((null? rs)
-		     #f)
-		    (else
-		     (if (is-markup? (car rs) 'bib-ref)
-			 (invoke (writer-action (markup-writer-get 'bib-ref e))
-				 (car rs)
-				 e)
-			 (output (car rs) e))
-		     (if (pair? (cdr rs))
-			 (begin
-			    (display ",")
-			    (loop (cdr rs))))))))
-   :after "]")
-
-;*---------------------------------------------------------------------*/
 ;*    url-ref ...                                                      */
 ;*---------------------------------------------------------------------*/
 (markup-writer 'url-ref
diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
index b500488..bc796bd 100644
--- a/src/guile/skribilo/engine/lout.scm
+++ b/src/guile/skribilo/engine/lout.scm
@@ -538,21 +538,6 @@
 	    (output (bold title) engine)
 	    (output title engine)))))
 
-(define (lout-bib-refs-sort/number entry1 entry2)
-  ;; Default implementation of the `bib-refs-sort-proc' custom.  Compare
-  ;; bibliography entries `entry1' and `entry2' (of type `&bib-entry') for
-  ;; use by `sort' in `bib-ref+'.
-  (let ((ident1 (markup-option entry1 :title))
-	(ident2 (markup-option entry2 :title)))
-    (if (and (markup? ident1) (markup? ident2))
-        (let ((n1 (markup-option ident1 'number))
-              (n2 (markup-option ident2 'number)))
-          (and (number? n1) (number? n2)
-               (< n1 n2)))
-	(begin
-	  (format (current-error-port) "i1: ~a, ~a" ident1 entry1)
-	  (format (current-error-port) "i2: ~a, ~a" ident2 entry2)))))
-
 (define (lout-pdf-bookmark-title node engine)
   ;; Default implementation of the `pdf-bookmark-title-proc' custom that
   ;; returns a title (a string) for the PDF bookmark of `node'.
@@ -636,14 +621,8 @@
 			 (doc-cover-sheet-proc
 			  ,lout-make-doc-cover-sheet)
 
-			 ;; Procedure used to sort bibliography
-			 ;; references when several are referred to at
-			 ;; the same time, as in:
-			 ;;  (ref :bib '("smith03" "jones98")) .
-			 ;; By default they are sorted by number.  If
-			 ;; `#f' is given, they are left as is.
-			 (bib-refs-sort-proc
-			  ,lout-bib-refs-sort/number)
+                         ;; Kept for backward compability, do not use.
+			 (bib-refs-sort-proc #f)
 
 			 ;; Lout code for paragraph gaps (similar to
 			 ;; `@PP' with `@ParaGap' equal to `1.0vx' by
@@ -2458,68 +2437,6 @@
                               (if show-page-num?
                                   (format #t (lout-page-of ident))))))))))
 
-
-;*---------------------------------------------------------------------*/
-;*    bib-ref ...                                                      */
-;*---------------------------------------------------------------------*/
-(markup-writer 'bib-ref
-   :options '(:text :bib)
-   :before "["
-   :action (lambda (n e)
-	     (let ((entry (handle-ast (markup-body n))))
-	       (output (markup-option entry :title) e)))
-   :after "]")
-
-;*---------------------------------------------------------------------*/
-;*    bib-ref+ ...                                                     */
-;*---------------------------------------------------------------------*/
-(markup-writer 'bib-ref+
-   ;; When several references are passed.  Strangely enough, the list of
-   ;; entries passed to this writer (as its body) contains both `bib-ref' and
-   ;; `bib-entry' objects, hence the `canonicalize-entry' function below.
-   :options '(:text :bib)
-   :before "["
-   :action (lambda (n e)
-	     (let* ((entries (markup-body n))
-		    (canonicalize-entry (lambda (x)
-					  (cond
-					   ((is-markup? x 'bib-entry) x)
-					   ((is-markup? x 'bib-ref)
-					    (handle-ast (markup-body x)))
-                                           ((is-markup? x 'unref) #f)
-					   (else
-					    (skribe-error
-					     'lout
-					     "bib-ref+: invalid entry type"
-					     x)))))
-		    (help-proc (lambda (proc)
-				 (lambda (e1 e2)
-                                   (let ((e1 (canonicalize-entry e1))
-                                         (e2 (canonicalize-entry e2)))
-                                     ;; don't pass `unref's to PROC
-                                     (if (and e1 e2)
-                                         (proc e1 e2)
-                                         #f)))))
-		    (sort-proc (engine-custom e 'bib-refs-sort-proc)))
-
-	       (let loop ((rs (if sort-proc
-				  (sort entries (help-proc sort-proc))
-				  entries)))
-		 (cond
-		  ((null? rs)
-		   #f)
-		  (else
-		   (if (is-markup? (car rs) 'bib-ref)
-		       (invoke (writer-action (markup-writer-get 'bib-ref e))
-			       (car rs)
-			       e)
-		       (output (car rs) e))
-		   (if (pair? (cdr rs))
-		       (begin
-			 (display ", ")
-			 (loop (cdr rs)))))))))
-   :after "]")
-
 ;*---------------------------------------------------------------------*/
 ;*    lout-make-url-breakable ...                                      */
 ;*---------------------------------------------------------------------*/