From 43d1ade366511da4dfd6af3f507a6713fb1ef0e7 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Wed, 25 Oct 2006 12:41:54 +0000
Subject: slide: Improved HTML output, especially wrt. the use of CSS.

* src/guile/skribilo/package/slide.scm (slide-topic): Pass CLASS as the
  `class' slot rather than as an option.
  (slide-subtopic): Likewise.

* src/guile/skribilo/package/slide/base.scm (make-outline-slide): Use
  `(markup-class topic)' instead of `(markup-option topic :class)'.

* src/guile/skribilo/package/slide/html.scm: Use a native Guile module.
  Use `format' instead of `printf'.
  (%slide-html-initialize): Simply issue `div' tags when a class is
  specified.

git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-69
---
 src/guile/skribilo/package/slide.scm      |  10 ++-
 src/guile/skribilo/package/slide/base.scm |   2 +-
 src/guile/skribilo/package/slide/html.scm | 123 +++++++++++++++++++++---------
 3 files changed, 96 insertions(+), 39 deletions(-)

diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index c0a8473..898f105 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -228,13 +228,14 @@
 ;*---------------------------------------------------------------------*/
 (define-markup (slide-topic #!rest opt
 			    #!key title (outline? #t)
-                            (ident #f) (class "slide-topic"))
+                            (ident #f) (class #f))
    (new container
       (markup 'slide-topic)
       (required-options '(:title :outline?))
       (ident (or ident (symbol->string (gensym 'slide-topic))))
+      (class class)
       (options `((:outline? ,outline?)
-                 ,@(the-options opt :outline?)))
+                 ,@(the-options opt :outline? :class)))
       (body (the-body opt))))
 
 ;*---------------------------------------------------------------------*/
@@ -242,13 +243,14 @@
 ;*---------------------------------------------------------------------*/
 (define-markup (slide-subtopic #!rest opt
 			       #!key title (outline? #f)
-                               (ident #f) (class "slide-subtopic"))
+                               (ident #f) (class #f))
    (new container
       (markup 'slide-subtopic)
       (required-options '(:title :outline?))
       (ident (or ident (symbol->string (gensym 'slide-subtopic))))
+      (class class)
       (options `((:outline? ,outline?)
-                 ,@(the-options opt :outline?)))
+                 ,@(the-options opt :outline? :class)))
       (body (the-body opt))))
 
 
diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm
index c8e652c..1eeb25f 100644
--- a/src/guile/skribilo/package/slide/base.scm
+++ b/src/guile/skribilo/package/slide/base.scm
@@ -155,7 +155,7 @@
                                       (is-markup? n 'slide-topic))
                                     topic))))
     (output (slide :title %slide-outline-title :toc #f
-                   :class (markup-option topic :class)
+                   :class (markup-class topic)
                    ;; The mark below is needed for cross-referencing by PDF
                    ;; bookmarks.
                    (if (markup-ident topic) (mark (markup-ident topic)) "")
diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm
index d47ef82..8fcbfed 100644
--- a/src/guile/skribilo/package/slide/html.scm
+++ b/src/guile/skribilo/package/slide/html.scm
@@ -18,43 +18,77 @@
 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
 ;;; USA.
 
-(define-skribe-module (skribilo package slide html)
-  :use-module (skribilo package slide))
+(define-module (skribilo package slide html)
+  :use-module (skribilo utils syntax)
 
+  :use-module (skribilo ast)
+  :use-module (skribilo engine)
+  :use-module (skribilo writer)
+  :autoload   (skribilo resolve)     (resolve!)
+  :autoload   (skribilo output)      (output)
+  :autoload   (skribilo evaluator)   (evaluate-document)
+  :autoload   (skribilo engine html) (html-width html-title-authors)
 
+  :use-module (skribilo package slide)
+  :use-module ((skribilo package base) :select (ref))) 
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
 (define-public (%slide-html-initialize!)
   (let ((he (find-engine 'html)))
-    (skribe-message "HTML slides setup...\n")
+    (display "HTML slides setup...\n" (current-error-port))
+
     ;; &html-page-title
     (markup-writer '&html-document-title he
        ;;:predicate (lambda (n e) %slide-initialized)
        :action html-slide-title)
+
     ;; slide
     (markup-writer 'slide he
        :options '(:title :number :transition :toc :bg)
        :before (lambda (n e)
-		  (printf "<a name=\"~a\">" (markup-ident n))
+		  (format #t "<a name=\"~a\">" (markup-ident n))
 		  (display "<br>\n"))
        :action (lambda (n e)
 		  (let ((nb (markup-option n :number))
-			(t (markup-option n :title)))
-		     (skribe-eval
-		      (center
-			 (color :width (slide-body-width e)
-			    :bg (or (markup-option n :bg) "#ffffff")
-			    (table :width 100.
-			       (tr (th :align 'left
-				      (list
-				       (if nb
-					   (format #f "~a / ~a -- " nb
-						   (slide-number)))
-				       t)))
-			       (tr (td (hrule)))
-			       (tr (td :width 100. :align 'left
-				      (markup-body n))))
-			    (linebreak)))
-		      e)))
+			(t (markup-option n :title))
+                        (class (markup-class n)))
+                     (if class
+                         (let ((title-class (string-append class "-title")))
+                           ;; When a class is specified, let the user play
+                           ;; with CSS.
+                           (format #t "\n<div class=\"~a\">" class)
+                           (format #t "\n<a name=\"~a\"></a>\n"
+                                   (markup-ident n))
+                           (format #t "<div class=\"~a\">" title-class)
+                           (format #t "~a / ~a -- " nb (slide-number))
+                           (output t e)
+                           (display "</div>\n")
+                           (output (markup-body n) e)
+                           (display "\n</div>\n"))
+                         ;; When no class is specified, do HTML tricks.
+                         (evaluate-document
+                          (center
+                           (color :width (slide-body-width e)
+                                  :bg (or (markup-option n :bg) "#ffffff")
+                                  (table :width 100.
+                                         (tr (th :align 'left
+                                                 (list
+                                                  (if nb
+                                                      (format #f "~a / ~a -- "
+                                                              nb
+                                                              (slide-number)))
+                                                  t)))
+                                         (tr (td (hrule)))
+                                         (tr (td :width 100. :align 'left
+                                                 (markup-body n))))
+                                  (linebreak)))
+                          e))))
        :after "<br>")
+
     ;; slide-vspace
     (markup-writer 'slide-vspace he
        :action (lambda (n e) (display "<br>")))))
@@ -76,23 +110,23 @@
 	  (tbg (engine-custom e 'title-background))
 	  (tfg (engine-custom e 'title-foreground))
 	  (tfont (engine-custom e 'title-font)))
-      (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>"
+      (format #t "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribilo-title\"><tbody>\n<tr>"
 	      (html-width (slide-body-width e)))
       (if (string? tbg)
-	  (printf "<td bgcolor=\"~a\">" tbg)
+	  (format #t  "<td bgcolor=\"~a\">" tbg)
 	  (display "<td>"))
       (if (string? tfg)
-	  (printf "<font color=\"~a\">" tfg))
+	  (format #t  "<font color=\"~a\">" tfg))
       (if title
 	  (begin
 	     (display "<center>")
 	     (if (string? tfont)
 		 (begin
-		    (printf "<font ~a><strong>" tfont)
+		    (format #t  "<font ~a><strong>" tfont)
 		    (output title e)
 		    (display "</strong></font>"))
 		 (begin
-		    (printf "<div class=\"skribetitle\"><strong><big><big><big>")
+		    (display "<div class=\"skribilo-title\"><strong><big><big><big>")
 		    (output title e)
 		    (display "</big></big></big></strong</div>")))
 	     (display "</center>\n")))
@@ -113,22 +147,43 @@
    :options '(:title :outline? :class :ident)
    :action (lambda (n e)
 	      (let ((title (markup-option n :title))
-		    (body (markup-body n)))
-		 (display "\n<h2 class=\"slide-topic:title\">")
+		    (body (markup-body n))
+                    (class (markup-class n)))
+                 ;; top-level class
+                 (if class (format #t "\n<div class=\"~a\">" class))
+
+                 ;; the title
+                 (if class
+                     (format #t "\n<div class=\"~a-title\">" class)
+                     (display "\n<h2 class=\"slide-topic:title\">"))
 		 (if (markup-ident n)
-		     (printf "<a name=\"~a\"></a>" (markup-ident n)))
+		     (format #t "<a name=\"~a\"></a>" (markup-ident n)))
 		 (output title e)
-		 (display "</h2> <br>\n")
-		 (display "\n<div class=\"slide-topic:slide-list\">")
+                 (if class
+                     (display "</div>\n")
+                     (display "</h2> <br>\n"))
+
+                 ;; pointers to the slides
+                 (if class
+                     (format #t "\n<div class=\"~a-slide-list\">"
+                             class)
+                     (display "\n<div class=\"slide-topic:slide-list\">"))
 		 (for-each (lambda (s)
-			      (output (markup-option s :title) e)
-			      (display "&nbsp;--&nbsp;"))
+                             (let* ((title (markup-option s :title))
+                                    (ident (markup-ident s))
+                                    (sref (ref :text title :ident ident))
+                                    (sref* (resolve! sref e `((parent ,n)))))
+                               (output sref* e)
+                               (display "&nbsp;--&nbsp;")))
 			   (filter (lambda (n)
 				      (or (is-markup? n 'slide-subtopic)
 					  (is-markup? n 'slide)))
 				   (markup-body n)))
 		 (display "\n</div> <!-- slide-topic:slide-list -->")
-		 (display "\n<hr><br>\n")
+
+                 (if class
+                     (display "\n</div> <!-- slide-topic -->\n")
+                     (display "\n<hr><br>\n"))
 
 		 ;; the slides
 		 (output (markup-body n) e))))
-- 
cgit v1.2.3