aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo/lib.scm41
-rw-r--r--src/guile/skribilo/package/Makefile.am3
-rw-r--r--src/guile/skribilo/package/html-navtabs.scm359
-rw-r--r--src/guile/skribilo/reader/outline.scm20
-rw-r--r--src/guile/skribilo/sui.scm2
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)
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-16 21:33:25 +0000