Merge from skribilo@sv.gnu.org--2006

Patches applied:

 * lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2  (patch 122-127)
 * skribilo@sv.gnu.org--2006/skribilo--devo--1.2  (patch 138-143)

   - sui: Small autoload fix.
   - `outline' reader: Fixed `append-trees'.
   - Added `html-navtabs' by Manuel Serrano.
   - html-navtabs: Permit disabling of CSS output.
   - Allow arbitrary keyword arguments in `define-markup'.
   - Documented `html-navtabs'.

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

5 files changed, 400 insertions, 25 deletions

diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index 3be013a..8c4c382 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,7 +1,7 @@
 ;;; lib.scm -- Utilities.
 ;;;
 ;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;; Copyright 2005, 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2005, 2007  Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -73,29 +73,38 @@
 (define-macro (define-markup bindings . body)
   ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
   ;; keyword-style conversion enabled.  However, using `(ice-9 optargs)', the
-  ;; `#:rest' argument can only appear last, which is not what Skribe/DSSSL
-  ;; expect, hence `fix-rest-arg'.
+  ;; `:rest' argument can only appear last, which is not what Skribe/DSSSL
+  ;; expect, hence `fix-rest-arg'.  In addition, all keyword arguments are
+  ;; allowed (hence `:allow-other-keys'); they are then checked by `verify'.
   (define (fix-rest-arg args)
-    (let loop ((args args)
-	       (result '())
-	       (rest-arg #f))
+    (let loop ((args          args)
+	       (result        '())
+	       (rest-arg      '())
+               (has-keywords? #f))
       (cond ((null? args)
-	     (if rest-arg
-		 (append (reverse result) rest-arg)
-		 (reverse result)))
+             (let ((result (if has-keywords?
+                               (cons :allow-other-keys result)
+                               result)))
+               (append! (reverse! result) rest-arg)))
 
 	    ((list? args)
-	     (let ((is-rest-arg? (eq? (car args) #:rest)))
-	       (loop (if is-rest-arg? (cddr args) (cdr args))
-		     (if is-rest-arg? result (cons (car args) result))
-		     (if is-rest-arg?
-			 (list (car args) (cadr args))
-			 rest-arg))))
+	     (let ((is-rest-arg? (eq? (car args) :rest))
+                   (is-keyword?  (eq? (car args) :key)))
+               (if is-rest-arg?
+                   (loop (cddr args)
+                         result
+                         (list (car args) (cadr args))
+                         (or has-keywords? is-keyword?))
+                   (loop (cdr args)
+                         (cons (car args) result)
+                         rest-arg
+                         (or has-keywords? is-keyword?)))))
 
 	    ((pair? args)
 	     (loop '()
 		   (cons (car args) result)
-		   (list #:rest (cdr args)))))))
+		   (list #:rest (cdr args))
+                   has-keywords?)))))
 
   (let ((name (car bindings))
 	(opts (cdr bindings)))
diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am
index 2d26fce..62a8c1c 100644
--- a/src/guile/skribilo/package/Makefile.am
+++ b/src/guile/skribilo/package/Makefile.am
@@ -2,7 +2,8 @@ guilemoduledir = $(GUILE_SITE)/skribilo/package
 dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm	\
 			lncs.scm scribe.scm sigplan.scm			\
 			slide.scm web-article.scm web-book.scm		\
-			eq.scm pie.scm base.scm diff.scm
+			eq.scm pie.scm base.scm diff.scm		\
+			html-navtabs.scm
 
 SUBDIRS = slide eq pie
 
diff --git a/src/guile/skribilo/package/html-navtabs.scm b/src/guile/skribilo/package/html-navtabs.scm
new file mode 100644
index 0000000..d50f456
--- /dev/null
+++ b/src/guile/skribilo/package/html-navtabs.scm
@@ -0,0 +1,359 @@
+;;; html-navtabs.scm  --  Producing HTML navigation tabs.
+;;;
+;;; Copyright 2004  Manuel Serrano
+;;; Copyright 2007  Ludovic Courtès <ludo@gnu.org>
+;;;
+;;;
+;;; 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 package html-navtabs)
+  :use-module (skribilo lib)
+  :use-module (skribilo ast)
+  :use-module (skribilo engine)
+  :use-module (skribilo writer)
+  :autoload   (skribilo output)        (output)
+  :autoload   (skribilo package base)  (handle)
+  :autoload   (skribilo engine html)   (html-width html-class html-file)
+  :autoload   (skribilo parameters)    (*destination-file*)
+  :use-module (skribilo utils strings)
+  :use-module (skribilo utils syntax))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+(define (unspecified? obj)
+  ;; Return true if OBJ is "unspecified" (see, e.g., `engine-custom').
+  (eq? obj 'unspecified))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-title ...                                      */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-title n e)
+   (display "  div.navtabs-title {
+    padding: 0 0 0 0;
+    margin: 0 0 0 0;
+    border: 0 0 0 0;
+    text-align: left;
+")
+   (let ((bg (engine-custom e 'title-background)))
+      (unless (unspecified? bg)
+	 (display "    background: ")
+	 (output bg e)
+	 (display ";\n")))
+   (display "  }\n"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-tabs ...                                       */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-tabs n e)
+   (display "  div.navtabs-tabs {
+    clear: left;
+    margin: 0 0 0 0;
+    border: 0 0 0 0;
+    text-align: left;
+")
+   (let ((pd (engine-custom e 'html-navtabs-padding))
+	 (ls (engine-custom e 'left-margin-size)))
+      (display "    padding: 0 0 0 ")
+      (if (and (unspecified? pd) (unspecified? ls))
+	  (display "20%;\n")
+	  (begin
+	     (output (if (unspecified? pd)
+			 (html-width ls)
+			 (html-width pd))
+		     e)
+	     (display ";\n"))))
+   (let ((bg (engine-custom e 'title-background)))
+      (unless (unspecified? bg)
+	 (display "    background: ")
+	 (output bg e)
+	 (display ";\n")))
+   (display "  }\n"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-bar ...                                        */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-bar n e)
+   (display "  div.navtabs-bar {
+    margin: 0 0 0 0;
+    border: 0 0 0 0;
+    text-align: left;
+    border-top-color: black;
+    border-top-style: solid;
+    border-top-width: 1px;
+")
+   (let ((pd (engine-custom e 'html-navtabs-padding))
+	 (ls (engine-custom e 'left-margin-size)))
+      (display "    padding: 0 0 0 ")
+      (if (and (unspecified? pd) (unspecified? ls))
+	  (display "20%;\n")
+	  (begin
+	     (output (if (unspecified? pd)
+			 (html-width ls)
+			 (html-width pd))
+		     e)
+	     (display ";\n"))))
+   (let ((bg1 (engine-custom e 'html-navtabs-bar-background))
+	 (bg2 (engine-custom e 'left-margin-background)))
+      (unless (and (unspecified? bg1) (unspecified? bg2))
+	 (display "    background: ")
+	 (output (if (unspecified? bg1) bg2 bg1) e)
+	 (display ";\n")))
+   (display "  }\n"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-active ...                                     */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-active n e)
+   (display "  div.navtabs-tabs a.active {
+    color: black;
+    border-width: 1px;
+    border-color: black;
+    border-style: solid;
+    padding: 2px 10px 0px 10px;
+    margin: 0 1px 0 0;
+    text-decoration: none;
+")
+   (let ((bg (engine-custom e 'left-margin-background)))
+      (unless (unspecified? bg)
+	 (display "    background: ")
+	 (output bg e)
+	 (display ";\n")
+	 (display "    border-bottom-color: ")
+	 (output bg e)
+	 (display ";\n")))
+   (display "  }\n"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-active ...                                     */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-inactive n e)
+   (display "  div.navtabs-tabs a.inactive {
+    background: white;
+    color: black;
+    border-width: 1px;
+    border-color: black;
+    border-style: solid;
+    padding: 2px 10px 0px 10px;
+    margin: 0 1px 0 0;
+    text-decoration: none;
+  }
+  div.navtabs-tabs a.inactive:hover {
+     color: ")
+   (let ((bg (engine-custom e 'title-background)))
+      (if (not (unspecified? bg))
+	  (output bg e)
+	  (display "#ff0000")))
+   (display "
+  }
+"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-css-margins ...                                    */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-css-margins n e)
+   ;; FIXME: This is both outdated and questionable.
+   (display "  td div.skribe-left-margin {
+    border-width: 0 1px 0 0;
+    border-right-style: solid;
+    border-right-color: black;
+    margin: 0;
+    height: 100%;
+  }
+    table.skribe-margins td.skribe-left-margin {
+    border-bottom-width:1px;
+    border-bottom-style: solid;
+    border-bottom-color: black;
+  }
+  table.skribe-margins td div.skribe-body {
+    border-width: 1px 0 0 0;
+    border-style: solid;
+    border-color: black;
+    margin: 0;
+    height: 100%;
+  }
+  td div.skribe-right-margin {
+    border-width: 0 0 0 1px;
+    border-left-style: solid;
+    border-left-color: black;
+    margin: 0;
+    height: 100%;
+  }
+  table.skribe-margins td.skribe-right-margin {
+    border-bottom-width: 1px;
+    border-bottom-style: solid;
+    border-bottom-color: black;
+  }
+"))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-default-tabs ...                                   */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-default-tabs n e)
+   (let* ((main (ast-document n))
+	  (children (container-search-down
+		     (lambda (c)
+			(and (container? c)
+			     (not (markup-option c :no-tabs))
+			     (markup-option c :file)))
+		     main)))
+      (cons (handle main) (map handle children))))
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-old-generic-title ...                              */
+;*---------------------------------------------------------------------*/
+(define &html-navtabs-old-generic-title #f)
+
+;*---------------------------------------------------------------------*/
+;*    &html-navtabs-generic-title ...                                  */
+;*---------------------------------------------------------------------*/
+(define (&html-navtabs-generic-title n e)
+   (display "<div class=\"navtabs-title\">\n")
+   (let ((nn (if (document? n)
+		 n
+		 (new markup
+		    (markup (markup-markup n))
+		    (options (markup-options n))
+		    (body (markup-option (ast-document n) :title))))))
+      (output nn e &html-navtabs-old-generic-title))
+   (display "</div>\n")
+   (display "<div class=\"navtabs-tabs\">\n")
+   (let* ((et (engine-custom e 'html-navtabs))
+	  (tabs (if (procedure? et)
+		    (et n e)
+		    (&html-navtabs-default-tabs n e))))
+      (for-each (lambda (t)
+		   (if (handle? t)
+		       (output (new markup
+				  (markup '&html-tabs-tab)
+				  (parent (ast-parent n))
+				  (body t))
+			       e)
+		       (skribe-type-error 'tr "Illegal tabs, " t "handle")))
+		tabs))
+   (display "</div>\n")
+   (output (new markup
+	      (markup '&html-tabs-bar)
+	      (body (markup-option (ast-parent n) :html-tabs-bar) e))
+	   e))
+
+
+;*---------------------------------------------------------------------*/
+;*    HTML customization                                               */
+;*---------------------------------------------------------------------*/
+(when-engine-is-loaded 'html
+  (lambda ()
+    (let* ((he   (find-engine 'html))
+           (oldd (markup-writer-get 'document he))
+           (oldh (markup-writer-get '&html-header-style he)))
+       (set! &html-navtabs-old-generic-title
+             (markup-writer-get '&html-document-title he))
+       ;; re-bindings
+       (markup-writer 'chapter he
+          :options '(:html-tabs-bar :title :number :file :toc :html-title :env)
+          :predicate (lambda (n e)
+                        (or (markup-option n :file)
+                            (engine-custom e 'chapter-file)))
+          :action (lambda (n e)
+                     (output n e oldd)))
+       (markup-writer 'section he
+          :options '(:html-tabs-bar :title :number :file :toc :html-title :env)
+          :predicate (lambda (n e)
+                        (or (markup-option n :file)
+                            (engine-custom e 'section-file)))
+          :action (lambda (n e)
+                     (output n e oldd)))
+       (markup-writer 'subsection he
+          :options '(:html-tabs-bar :title :number :file :toc :html-title :env)
+          :predicate (lambda (n e)
+                        (or (markup-option n :file)
+                            (engine-custom e 'subsection-file)))
+          :action (lambda (n e)
+                     (output n e oldd)))
+       (markup-writer 'subsubsection he
+          :options '(:html-tabs-bar :title :number :file :toc :html-title :env)
+          :predicate (lambda (n e)
+                        (or (markup-option n :file)
+                            (engine-custom e 'subsubsection-file)))
+          :action (lambda (n e)
+                     (output n e oldd)))
+       (markup-writer '&html-header-style he
+          :options 'all
+          :before (writer-before oldh)
+          :action (lambda (n e)
+                     ((writer-action oldh) n e)
+                     (let ((css? (engine-custom e 'html-navtabs-produce-css?)))
+                       (if (or css? (unspecified? css?))
+                           (for-each (lambda (m)
+                                       (output (new markup
+                                                    (markup m)
+                                                    (parent n))
+                                               e))
+                                     '(&html-navtabs-css-title
+                                       &html-navtabs-css-tabs
+                                       &html-navtabs-css-bar
+                                       &html-navtabs-css-active
+                                       &html-navtabs-css-inactive
+                                       &html-navtabs-css-margins)))))
+          :after (writer-after oldh))
+       (markup-writer '&html-document-title he :action &html-navtabs-generic-title)
+       (markup-writer '&html-chapter-title he :action &html-navtabs-generic-title)
+       (markup-writer '&html-section-title he :action &html-navtabs-generic-title)
+       (markup-writer '&html-subsection-title he :action &html-navtabs-generic-title)
+       (markup-writer '&html-subsubsection-title he :action &html-navtabs-generic-title)
+       ;; html-divs
+       (markup-writer '&html-navtabs-css-title :action &html-navtabs-css-title)
+       (markup-writer '&html-navtabs-css-tabs :action &html-navtabs-css-tabs)
+       (markup-writer '&html-navtabs-css-bar :action &html-navtabs-css-bar)
+       (markup-writer '&html-navtabs-css-active :action &html-navtabs-css-active)
+       (markup-writer '&html-navtabs-css-inactive :action &html-navtabs-css-inactive)
+       ;;(markup-writer '&html-navtabs-css-margins :action &html-navtabs-css-margins)
+       ;; html-tabs
+       (markup-writer 'html-tabs he
+          :options '(:unresolved :width handles)
+          :before "<div class=\"navtabs-tabs\">\n"
+          :after "</div>\n")
+       ;; &html-tabs-bar
+       (markup-writer '&html-tabs-bar he
+          :options '()
+          :before "<div class=\"navtabs-bar\">\n"
+          :after "</div>\n")
+       ;; &html-tabs-handle
+       (markup-writer '&html-tabs-tab he
+          :before (lambda (n e)
+                     (let* ((c (handle-ast (markup-body n)))
+                            (id (markup-ident c))
+                            (f (html-file c e))
+                            (l (let loop ((l (ast-parent n)))
+                                  (if (markup-option l :no-tabs)
+                                      (loop (ast-parent l))
+                                      l))))
+                        (format #t "<a href=\"~a#~a\" class=\"~a\""
+                                (strip-ref-base (or f (*destination-file*) ""))
+                                (string-canonicalize id)
+                                (if (eq? c l) "active" "inactive"))
+                        (html-class n)
+                        (display ">")))
+          :action (lambda (n e)
+                     (let ((p (handle-ast (markup-body n))))
+                        (if (document? p)
+                            (let ((ht (markup-option p :html-title)))
+                               (output (if ht ht (markup-option p :title)) e))
+                            (output (markup-option p :title) e))))
+          :after "</a>\n"))))
+
+
+;;; arch-tag: 9538d2a2-14c9-4fa7-9320-7380404ad243
diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm
index 7411892..1e64d01 100644
--- a/src/guile/skribilo/reader/outline.scm
+++ b/src/guile/skribilo/reader/outline.scm
@@ -83,15 +83,21 @@ equal to @var{name}, a markup name."
   (let loop ((trees trees)
 	     (result '()))
     (if (null? trees)
-	result
+	(let ((result (reverse! result)))
+          (cond ((and (pair? result)
+                      (not (symbol? (car result))))
+                 ;; Make sure only symbols end up in the head.
+                 (cons 'list result))
+                (else
+                 result)))
 	(let ((tree (car trees)))
 	  (loop (cdr trees)
-		(append result
-			(if (list? tree)
-			    (cond ((null? tree) '())
-				  ((symbol? (car tree)) (list tree))
-				  (else tree))
-			    (list tree))))))))
+		(append (if (list? tree)
+                            (cond ((null? tree) '())
+                                  ((symbol? (car tree)) (list tree))
+                                  (else tree))
+                            (list tree))
+                        result))))))
 
 (define (null-string? s)
   (and (string? s) (string=? s "")))
diff --git a/src/guile/skribilo/sui.scm b/src/guile/skribilo/sui.scm
index 6535c66..8dc1a9e 100644
--- a/src/guile/skribilo/sui.scm
+++ b/src/guile/skribilo/sui.scm
@@ -22,7 +22,7 @@
 (define-module (skribilo sui)
   :use-module (skribilo lib)
   :use-module (skribilo ast)
-  :autoload   (skribilo parameters) (*verbose*)
+  :autoload   (skribilo parameters) (*verbose* *destination-file*)
   :autoload   (skribilo reader)     (make-reader)
   :autoload   (skribilo engine)     (find-engine)
   :autoload   (skribilo evaluator)  (evaluate-document)