diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/skribilo/lib.scm | 41 | ||||
| -rw-r--r-- | src/guile/skribilo/package/Makefile.am | 3 | ||||
| -rw-r--r-- | src/guile/skribilo/package/html-navtabs.scm | 359 | ||||
| -rw-r--r-- | src/guile/skribilo/reader/outline.scm | 20 | ||||
| -rw-r--r-- | src/guile/skribilo/sui.scm | 2 |
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) |