diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/skribilo/engine/info.scm | 803 |
1 files changed, 358 insertions, 445 deletions
diff --git a/src/guile/skribilo/engine/info.scm b/src/guile/skribilo/engine/info.scm index 1449b30..de2cab6 100644 --- a/src/guile/skribilo/engine/info.scm +++ b/src/guile/skribilo/engine/info.scm @@ -1,23 +1,74 @@ -;*=====================================================================*/ -;* serrano/prgm/project/scribe/scribetext/info.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 23 14:03:53 2001 */ -;* Last change : Mon Oct 21 10:59:41 2002 (serrano) */ -;* Copyright : 2001-02 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The translator scribe->text */ -;*=====================================================================*/ +;;; info.scm -- GNU Info engine. +;;; +;;; Copyright 2008 Ludovic Courtès <ludo@gnu.org> +;;; Copyright 2001, 2002 Manuel Serrano +;;; +;;; +;;; 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 engine latex) + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo location) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) + :use-module (skribilo package base) + :autoload (skribilo parameters) (*destination-file*) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo output) (output) + :autoload (skribilo debug) (*debug*) + :use-module (srfi srfi-8) + :use-module (srfi srfi-13) + + :export (info-engine)) + +(fluid-set! current-reader %skribilo-module-reader) + +(define info-engine + (make-engine 'info + :version 1.0 + :format "info" + :delegate (find-engine 'base) + :filter #f ;; XXX: Do we need something? + :custom '())) + ;*---------------------------------------------------------------------*/ ;* info-dest ... */ ;*---------------------------------------------------------------------*/ (define (info-dest) - (if (string? *scribe-dest*) - *scribe-dest* + (if (string? (*destination-file*)) + (*destination-file*) "anonymous.info")) +;; +;; Convenience functions. +;; + +(define (print . args) + (for-each display args)) + +(define (%block? obj) + (and (markup? obj) + (memq (markup-markup obj) + '(chapter section subsection subsubsection)))) + ;*---------------------------------------------------------------------*/ ;* info-node ... */ ;*---------------------------------------------------------------------*/ @@ -31,38 +82,34 @@ (newline)) ;*---------------------------------------------------------------------*/ -;* node-next+prev+top ::%container ... */ -;*---------------------------------------------------------------------*/ -(define-generic (node-next+prev+top obj::%container)) - -;*---------------------------------------------------------------------*/ ;* node-next+prev+top ::%document ... */ ;*---------------------------------------------------------------------*/ -(define-method (node-next+prev+top obj::%document) - (with-access::%container obj (children) - (let loop ((c children)) - (cond - ((null? c) - (values "Top" "(dir)" "(dir)")) - ((or (%chapter? (car c)) (%section? (car c))) - (values (block-title (car c)) "(dir)" "(dir)")) - (else - (loop (cdr c))))))) +(markup-writer 'document info-engine + :action (lambda (doc e) + (let loop ((c (ast-body doc))) + (cond + ((null? c) + (values "Top" "(dir)" "(dir)")) + ((or (is-markup? (car c) 'chapter) + (is-markup? (car c) 'section)) + (values (block-title (car c)) "(dir)" "(dir)")) + (else + (loop (cdr c))))))) ;*---------------------------------------------------------------------*/ ;* node-next+prev+top ... */ ;*---------------------------------------------------------------------*/ -(define-method (node-next+prev+top obj::%block) - (with-access::%block obj (parent) - (let ((top (if (%document? parent) +(define (node-next+prev+top section) + (let ((parent (ast-parent section))) + (let ((top (if (document? parent) "Top" (block-title parent)))) - (let loop ((els (%container-children parent)) + (let loop ((els (ast-body parent)) (prev #f)) (cond ((null? els) (values top top top)) - ((eq? (car els) obj) + ((eq? (car els) section) (let ((p (if prev (block-title prev) top)) @@ -76,8 +123,8 @@ ;*---------------------------------------------------------------------*/ ;* node-menu ... */ ;*---------------------------------------------------------------------*/ -(define (node-menu obj::%container) - (with-access::%container obj (children) +(define (node-menu container e) + (let ((children (ast-body container))) (if (pair? (filter (lambda (x) (or (%chapter? x) (%section? x))) children)) (begin @@ -86,116 +133,54 @@ (newline) (for-each (lambda (c) (if (%block? c) - (print "* " (block-title c) "::"))) + (print "* " (block-title c e) "::"))) (reverse children)))) (newline))) ;*---------------------------------------------------------------------*/ -;* block-title ::%block ... */ -;*---------------------------------------------------------------------*/ -(define-generic (block-title obj::%block) - "") - -;*---------------------------------------------------------------------*/ ;* block-title ::%chapter ... */ ;*---------------------------------------------------------------------*/ -(define-method (block-title obj::%chapter) - (with-access::%chapter obj (title subtitle) +(define (block-title obj e) + (let ((title (markup-option obj :title)) + (subtitle (markup-option obj :subtitle))) (let ((title (if title title subtitle))) (if (string? title) title (with-output-to-string - (lambda () (info title))))))) - -;*---------------------------------------------------------------------*/ -;* block-title ::%section ... */ -;*---------------------------------------------------------------------*/ -(define-method (block-title obj::%section) - (with-access::%section obj (title) - (if (string? title) - title - (with-output-to-string - (lambda () (info title)))))) - -;*---------------------------------------------------------------------*/ -;* block-title ::%subsection ... */ -;*---------------------------------------------------------------------*/ -(define-method (block-title obj::%subsection) - (with-access::%subsection obj (title) - (if (string? title) - title - (with-output-to-string - (lambda () (info title)))))) - -;*---------------------------------------------------------------------*/ -;* block-title ::%subsection ... */ -;*---------------------------------------------------------------------*/ -(define-method (block-title obj::%subsubsection) - (with-access::%subsubsection obj (title) - (if (string? title) - title - (with-output-to-string - (lambda () (info title)))))) - -;*---------------------------------------------------------------------*/ -;* *text-string-processor* ... */ -;*---------------------------------------------------------------------*/ -(define *text-string-processor* - (lambda (x) x)) - -;*---------------------------------------------------------------------*/ -;* info ::obj ... */ -;*---------------------------------------------------------------------*/ -(define-generic (info obj::obj) - (cond - ((and (procedure? obj) (correct-arity? obj 0)) - (info (obj))) - ((string? obj) - (output (*text-string-processor* obj))) - ((number? obj) - (output (*text-string-processor* (number->string obj)))) - ((char? obj) - (output (*text-string-processor* (string obj)))) - ((eq? obj #unspecified) - obj) - ((list? obj) - (for-each info obj)) - ((or (symbol? obj) (boolean? obj)) - "") - (else - (with-access::%node obj (loc) - (error/location "info" - "Can't find method for node" - (find-runtime-type obj) - (car loc) - (cdr loc)))))) + (lambda () (output title e))))))) ;*---------------------------------------------------------------------*/ ;* info ::%document ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%document) - (with-document - obj - (lambda () - (with-access::%document obj (title authors body footnotes) - (scribe-document->info obj (if title title "") authors body) - (if (pair? footnotes) - (begin - (with-justification - (make-justifier *text-column-width* 'left) - (lambda () - (newline) - (newline) - (print "-------------") - (for-each (lambda (fn) - (with-access::%footnote fn (number note id) - (output (string-append - "*" - (number->string number) - ": ")) - (info note) - (output-newline))) - footnotes))))))))) +(markup-writer 'document info-engine + :action (lambda (doc e) + (let ((title (markup-option doc :title)) + (author (markup-option doc :author)) + (body (markup-body doc))) + (scribe-document->info doc (if title title "") + (if (list? authors) + authors + (list authors)) + body) + (if (pair? footnotes) + (begin + (with-justification + (make-justifier *text-column-width* 'left) + (lambda () + (newline) + (newline) + (print "-------------") + ;; FIXME: Handle footnotes. +;; (for-each (lambda (fn) +;; (with-access::%footnote fn (number note id) +;; (output (string-append +;; "*" +;; (number->string number) +;; ": ")) +;; (info note) +;; (output-newline))) +;; footnotes) + ))))))) ;*---------------------------------------------------------------------*/ ;* scribe-document->info ... */ @@ -273,7 +258,7 @@ (define (info-footer) (if *scribe-footer* (info *scribe-footer*))) ;; the main node - (multiple-value-bind (next prev top) + (receive (next prev top) (node-next+prev+top obj) (newline) (info-node "Top" next prev top)) @@ -295,64 +280,59 @@ ;*---------------------------------------------------------------------*/ ;* info ::%author ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%author) - (with-access::%author obj (name title affiliation email url address phone) - (if (or (pair? name) (string? name)) - (info name)) - (if title (begin (output-newline) (output title))) - (if affiliation (begin (output-newline) (output affiliation))) - (if (pair? address) - (for-each (lambda (x) (output-newline) (output x)) address)) - (if email (begin (output-newline) (output email))) - (if url (begin (output-newline) (output url))) - (if phone (begin (output-newline) (output phone))) - (output-newline))) +(markup-writer 'author info-engine + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (if (or (pair? name) (string? name)) + (output name e)) + (if title (begin (output-newline) (output title e))) + (if affiliation (begin (output-newline) (output affiliation e))) + (if (pair? address) + (for-each (lambda (x) (output-newline) (output x e)) address)) + (if email (begin (output-newline) (output email e))) + (if url (begin (output-newline) (output url e))) + (if phone (begin (output-newline) (output phone e))) + (output-newline)))) ;*---------------------------------------------------------------------*/ ;* scribe->html ::%toc ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%toc) - (node-menu (current-document))) - -;*---------------------------------------------------------------------*/ -;* info ::%text ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%text) - (info (%text-body obj))) +(markup-writer 'toc info-engine + :action (lambda (n e) + (node-menu (ast-document n) e))) ;*---------------------------------------------------------------------*/ ;* info ::%linebreak ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%linebreak) - (let loop ((num (%linebreak-repetition obj))) - (output-newline) - (if (>fx num 1) - (begin - (output-newline) - (loop (-fx num 1)))))) +(markup-writer 'linebreak info-engine + :action (lambda (n e) + (output-newline))) ;*---------------------------------------------------------------------*/ ;* info ::%center ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%center) - (with-justification (make-justifier (justification-width) 'center) - (lambda () - (info (%center-body obj))))) +(markup-writer 'center info-engine + :action (lambda (n e) + (with-justification (make-justifier (justification-width) 'center) + (lambda () + (output (%center-body obj) e))))) ;*---------------------------------------------------------------------*/ ;* info ::%flush ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%flush) - (with-access::%flush obj (side) - (with-justification (make-justifier (justification-width) side) - (lambda () - (info (%flush-body obj)))))) - -;*---------------------------------------------------------------------*/ -;* info ::%atom ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%atom) - (output (%atom-value obj))) +(markup-writer 'flush info-engine + :options '(:side) + :action (lambda (n e) + (let ((side (markup-option :side))) + (with-justification (make-justifier (justification-width) side) + (lambda () + (output (%flush-body obj) e)))))) ;*---------------------------------------------------------------------*/ ;* *ornaments* ... */ @@ -372,92 +352,55 @@ ;*---------------------------------------------------------------------*/ ;* info ::%ornament ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%ornament) - (with-access::%ornament obj (body kind) - (case kind - ((var) - (let ((old *text-string-processor*)) - (set! *text-string-processor* string-upcase) - (let ((res (info body))) - (set! *text-string-processor* old) - res))) - (else - (let ((d (assq kind *ornaments*))) - (if (not (pair? d)) - (info body) - (let ((start (cadr d)) - (stop (caddr d))) - (display start) - (info body) - (display stop)))))))) - +(for-each (lambda (ornament) + (let ((name (car ornament)) + (before (cadr ornament)) + (after (caddr ornament))) + (markup-writer name info-engine + :before before + :after after))) + *ornaments*) + ;*---------------------------------------------------------------------*/ ;* info ::%pre ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%pre) - (with-justification (make-justifier *text-column-width* 'verbatim) - (lambda () - (info (%pre-body obj)) - (output-newline)))) +(markup-writer 'pre info-engine + :action (lambda (n e) + (with-justification (make-justifier *text-column-width* 'verbatim) + (lambda () + (output (ast-body obj) e) + (output-newline))))) ;*---------------------------------------------------------------------*/ ;* info ::%mark ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%mark) - #unspecified) +(markup-writer 'mark info-engine + :action #f) ;*---------------------------------------------------------------------*/ ;* info ::%reference ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%reference) - (with-access::%reference obj (body anchor) - (multiple-value-bind (file mark) - (find-reference obj (current-document)) - (if (not mark) - (begin - (warning "ref" "Can't find reference -- " anchor) - (output "reference:???")) - (begin - (output "*Note ") - (info body) - (output ":: ")))))) - -;*---------------------------------------------------------------------*/ -;* info ::%sui-ref ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%sui-ref) - (info (scribe-url-ref obj))) +;; FIXME: Implement `ref' using `info-chapter-ref', etc. +;; (markup-writer 'ref info-engine +;; :action (lambda (n e) +;; #f)) ;*---------------------------------------------------------------------*/ ;* info ::%url-ref ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%url-ref) - (with-access::%url-ref obj (url anchor body) - (if (and body (not (equal? body url))) - (begin - (output "*Note ") - (info body) - (output " ("))) - (info url) - (if (or (pair? anchor) - (and (string? anchor) (>fx (string-length anchor) 0))) - (begin - (output "#") - (info anchor))) - (if (and body (not (equal? body url))) (output ")")) - (output ":: "))) - -;*---------------------------------------------------------------------*/ -;* info ::%chapter-ref ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%chapter-ref) - (multiple-value-bind (_ chapter) - (find-reference obj (current-document)) - (if (not chapter) - (with-access::%chapter-ref obj (anchor) - (warning "ref" "Can't find chapter -- " anchor) - (output "chapter:???")) - (info-chapter-ref chapter)))) +(markup-writer 'url-ref info-engine + :options '(:url :text) + :action (lambda (n e) + (let ((url (markup-option :url)) + (text (markup-option :text))) + (if text + (begin + (output "*Note ") + (output text e) + (output " ("))) + (output url e) + (if text (output ")")) + (output ":: ")))) ;*---------------------------------------------------------------------*/ ;* info-chapter-ref ... */ @@ -470,8 +413,8 @@ ;*---------------------------------------------------------------------*/ ;* info ::%section-ref ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%section-ref) - (multiple-value-bind (_ section) +(define (info obj::%section-ref) + (receive (_ section) (find-reference obj (current-document)) (if (not (%section? section)) (with-access::%section-ref obj (anchor) @@ -491,8 +434,8 @@ ;*---------------------------------------------------------------------*/ ;* info ::%subsection-ref ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%subsection-ref) - (multiple-value-bind (_ subsection) +(define (info obj::%subsection-ref) + (receive (_ subsection) (find-reference obj (current-document)) (if (not (%subsection? subsection)) (with-access::%subsection-ref obj (anchor) @@ -512,8 +455,8 @@ ;*---------------------------------------------------------------------*/ ;* info ::%subsubsection-ref ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%subsubsection-ref) - (multiple-value-bind (_ subsubsection) +(define (info obj::%subsubsection-ref) + (receive (_ subsubsection) (find-reference obj (current-document)) (if (not (%subsubsection? subsubsection)) (with-access::%subsubsection-ref obj (anchor) @@ -533,206 +476,193 @@ ;*---------------------------------------------------------------------*/ ;* info ::%biblio-ref ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%biblio-ref) - (with-access::%biblio-ref obj (anchor body) - (if body (info body)) - (output " [") - (let loop ((a+ anchor)) - (if (null? a+) - (output "]") - (let ((a (car a+))) - (cond - ((%bibentry? a) - (output (number->string (%bibentry-number a)))) - ((string? a) - (output "???") - (output a) - (output "???")) - (else - (display "bibref:???"))) - (if (pair? (cdr a+)) - (output ",")) - (loop (cdr a+))))))) +(markup-writer 'bib-ref info-engine + :options '(:text :bib) + :action (lambda (n e) + ;; XXX: Produce hyperlink to `the-bibliography'? + (let ((text (markup-option n :text)) + (bib (markup-option n :bib))) + (if text (output text e)) + (output " [") + (output bib e) + (output "]")))) ;*---------------------------------------------------------------------*/ ;* mailto ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%mailto) - (with-access::%mailto obj (email body) - (if (pair? body) - (info body) - (output email)))) +(markup-writer 'mailto info-engine + :options (:text) + :action (lambda (n e) + (let ((email (markup-body n)) + (text (markup-option n :text))) + (if text (output text e)) + (output email e)))) ;*---------------------------------------------------------------------*/ ;* info ::%item ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%item) - (with-access::%item obj (value body) - (if (not (null? value)) - (begin - (info value) - (display ": "))) - (info body))) +(markup-writer 'item info-engine + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (output k e) + (display ": "))) + (output (markup-body n) e)))) ;*---------------------------------------------------------------------*/ ;* info ::%list ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%list) - (with-access::%list obj (items kind) - (case kind - ((itemize) - (for-each (lambda (item) - (with-justification (make-justifier - (-fx (justification-width) 3) - 'left) - (lambda () +(markup-writer 'itemize info-engine + :action (lambda (n e) + (for-each (lambda (item) + (with-justification (make-justifier + (-fx (justification-width) 3) + 'left) + (lambda () (output "- ") - (info item)) - 3)) - items)) - ((enumerate) - (let loop ((num 1) - (items items)) - (if (pair? items) - (let ((item (car items))) + (output item e)) + 3)) + items))) + +(markup-writer 'enumerate info-engine + :action (lambda (n e) + (let loop ((num 1) + (items (markup-body n))) + (if (pair? items) + (let ((item (car items))) (with-justification (make-justifier (-fx (justification-width) 3) 'left) (lambda () - (output (integer->string num)) - (output " - ") - (info item)) + (output (integer->string num)) + (output " - ") + (info item)) 3) - (loop (+fx num 1) (cdr items)))))) - ((description) - (for-each (lambda (item) - (with-justification - (make-justifier - (-fx (justification-width) 3) - 'left) - (lambda () - (with-access::%item item (value body) - (output "*") - (if (pair? value) - (let loop ((vs value)) - (info (car vs)) - (if (pair? (cdr vs)) - (begin - (output " ") - (loop (cdr vs))))) - (info value)) - (output "* ") - (info body))) - 3)) - items)) - (else - (error "info" "Illegal list" kind))))) - + (loop (+ num 1) (cdr items))))))) + +(markup-writer 'description info-engine + :action (lambda (n e) + (for-each (lambda (item) + (with-justification + (make-justifier + (-fx (justification-width) 3) + 'left) + (output item e) + 3)) + items))) + ;*---------------------------------------------------------------------*/ ;* info ::%section ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%section) - (with-access::%section obj (body title) - (output-newline) - (output-flush *margin*) - (let ((t (block-title obj))) - (multiple-value-bind (next prev top) - (node-next+prev+top obj) - (info-node t next prev top) - (print t) - (print (make-string (string-length t) #\=)))) - (node-menu obj) - (with-justification (make-justifier *text-column-width* - *text-justification*) - (lambda () (info body))))) +(markup-writer 'section info-engine + :options '(:title :html-title :number :toc :file :env) + :action (lambda (n e) + (let ((body (markup-body n)) + (title (markup-option n :title))) + (output-newline) + (output-flush *margin*) + (let ((t (block-title n))) + (receive (next prev top) + (node-next+prev+top n) + (info-node t next prev top) + (print t) + (print (make-string (string-length t) #\=)))) + (node-menu n e) + (with-justification (make-justifier *text-column-width* + *text-justification*) + (lambda () (output body e)))))) ;*---------------------------------------------------------------------*/ ;* info ::%subsection ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%subsection) - (with-access::%subsection obj (body title) - (output-flush *margin*) - (let ((t (block-title obj))) - (multiple-value-bind (next prev top) - (node-next+prev+top obj) - (info-node t next prev top) - (print t) - (print (make-string (string-length t) #\-)))) - (info body))) +(markup-writer 'subsection info-engine + :options '(:title :html-title :number :toc :env :file) + :action (lambda (n e) + (let ((body (markup-body n)) + (title (markup-option n :title))) + (output-flush *margin*) + (let ((t (block-title n))) + (receive (next prev top) + (node-next+prev+top n) + (info-node t next prev top) + (print t) + (print (make-string (string-length t) #\-)))) + (output body e)))) ;*---------------------------------------------------------------------*/ ;* info ::%subsubsection ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%subsubsection) - (with-access::%subsubsection obj (body title) - (output-flush *margin*) - (let ((t (block-title obj))) - (multiple-value-bind (next prev top) - (node-next+prev+top obj) - (info-node t next prev top) - (print t) - (print (make-string (string-length t) #\~)))) - (info body))) +(markup-writer 'subsubsection info-engine + :options '(:title :html-title :number :toc :env :file) + :action (lambda (n e) + (let ((body (markup-body n)) + (title (markup-option n :title))) + (output-flush *margin*) + (let ((t (block-title n))) + (receive (next prev top) + (node-next+prev+top n) + (info-node t next prev top) + (print t) + (print (make-string (string-length t) #\~)))) + (output body e)))) ;*---------------------------------------------------------------------*/ ;* info ::%paragraph ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%paragraph) - (with-access::%paragraph obj (body) - (output-newline) - (output-flush *margin*) - (info body))) +(markup-writer 'paragraph info-engine + :action (lambda (n e) + (output-newline) + (output-flush *margin*) + (output (markup-body n) e))) ;*---------------------------------------------------------------------*/ ;* info ::%chapter ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%chapter) - (with-access::%chapter obj (body file title subtitle) - (output-newline) - (output-flush *margin*) - (let ((t (block-title obj))) - (multiple-value-bind (next prev top) - (node-next+prev+top obj) - (info-node t next prev top) - (print t) - (print (make-string (string-length t) #\*)))) - (node-menu obj) - (info body))) +(markup-writer 'chapter info-engine + :options '(:title :number :file :toc :html-title :env) + :action (lambda (n e) + (let ((body (markup-body n)) + (file (markup-option n :file)) + (title (markup-option n :title))) + (output-newline) + (output-flush *margin*) + (let ((t (block-title n))) + (receive (next prev top) + (node-next+prev+top n) + (info-node t next prev top) + (print t) + (print (make-string (string-length t) #\*)))) + (node-menu n e) + (output body e)))) ;*---------------------------------------------------------------------*/ ;* info ::%hrule ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%hrule) - (with-access::%hrule obj (width) - (let ((w (if (= width 100) - (justification-width) - (inexact->exact (* (exact->inexact (justification-width)) - (/ (exact->inexact width) 100.)))))) - (output (make-string w #\-))))) - -;*---------------------------------------------------------------------*/ -;* info ::%font ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%font) - (with-access::%font obj (body) - (info body))) - -;*---------------------------------------------------------------------*/ -;* info ::%image ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%image) - #unspecified) +(markup-writer 'hrule info-engine + :options '(:width) + :action (lambda (n e) + (let ((width (markup-option n :width))) + (let ((w (if (= width 100) + (justification-width) + (inexact->exact + (* (exact->inexact (justification-width)) + (/ (exact->inexact width) 100.)))))) + (output (make-string w #\-)))))) ;*---------------------------------------------------------------------*/ ;* info ::%table ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%table) - (with-access::%table obj (border loc) - (output-flush *margin*) - (if border - (border-table->info obj) - (table->ascii obj info)) - (output-flush *margin*))) +(markup-writer 'table info-engine + :options (:border) + :action (lambda (n e) + (let ((border (markup-option n :border))) + (output-flush *margin*) + (if border + (border-table->info n) + (table->ascii n info)) + (output-flush *margin*)))) ;*---------------------------------------------------------------------*/ ;* border-table->info ... */ @@ -741,52 +671,35 @@ (table->ascii table info)) ;*---------------------------------------------------------------------*/ -;* info ::%character ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%character) - (case (%character-value obj) - ((copyright) - (display "(c)")) - ((#\space) - (display #\space)) - ((#\tab) - (display #\tab)))) - -;*---------------------------------------------------------------------*/ -;* info ::%hook ... */ -;*---------------------------------------------------------------------*/ -(define-method (info obj::%hook) - (with-access::%hook obj (body before after process) - (if (procedure? before) - (let ((bef (before))) - (if process (info bef)))) - (call-next-method) - (if (procedure? after) - (let ((af (after))) - (if process (info af)))))) - -;*---------------------------------------------------------------------*/ ;* info ::%figure ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%figure) - (with-access::%figure obj (body legend number) - (output-newline) - (info body) - (output-newline) - (output-newline) - (output "Fig. ") - (output (number->string number)) - (output ": ") - (info legend) - (output-newline))) +(markup-writer 'figure info-engine + :options '(:legend :number) + :action (lambda (n e) + (let ((body (markup-body n)) + (legend (markup-option n :legend)) + (number (markup-option n :number))) + (output-newline) + (output body e) + (output-newline) + (output-newline) + (output "Fig. ") + (output (number->string number)) + (output ": ") + (output legend e) + (output-newline)))) ;*---------------------------------------------------------------------*/ ;* info ::%footnote ... */ ;*---------------------------------------------------------------------*/ -(define-method (info obj::%footnote) - (with-access::%footnote obj (number note body) - (info body) - (output (string-append "(*" (number->string number) ")")))) +(markup-writer 'footnote info-engine + :options '(:label) + :action (lambda (n e) + (let ((label (markup-option n :label))) + (output (markup-body n) e) + (output "(*" e) + (output label e) + (output ")" e)))) |