diff options
| -rw-r--r-- | src/guile/skribilo/engine/info.scm | 216 |
1 files changed, 94 insertions, 122 deletions
diff --git a/src/guile/skribilo/engine/info.scm b/src/guile/skribilo/engine/info.scm index e2b4f7c..08c969c 100644 --- a/src/guile/skribilo/engine/info.scm +++ b/src/guile/skribilo/engine/info.scm @@ -24,14 +24,10 @@ :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*) :autoload (skribilo utils justify) (make-justifier) :autoload (skribilo utils text-table) (table->ascii) :use-module (srfi srfi-8) @@ -41,7 +37,6 @@ (fluid-set! current-reader %skribilo-module-reader) - (define info-engine (make-engine 'info @@ -94,18 +89,18 @@ (values "Top" "(dir)" "(dir)")) ((or (is-markup? (car c) 'chapter) (is-markup? (car c) 'section)) - (values (block-title (car c)) "(dir)" "(dir)")) + (values (block-title (car c) e) "(dir)" "(dir)")) (else (loop (cdr c))))))) ;*---------------------------------------------------------------------*/ ;* node-next+prev+top ... */ ;*---------------------------------------------------------------------*/ -(define (node-next+prev+top section) +(define (node-next+prev+top section e) (let ((parent (ast-parent section))) (let ((top (if (document? parent) "Top" - (block-title parent)))) + (block-title parent e)))) (let loop ((els (markup-body parent)) (prev #f)) (cond @@ -113,11 +108,11 @@ (values top top top)) ((eq? (car els) section) (let ((p (if prev - (block-title prev) + (block-title prev e) top)) (n (if (null? (cdr els)) top - (block-title (cadr els))))) + (block-title (cadr els) e)))) (values p n top))) (else (loop (cdr els) (car els)))))))) @@ -127,7 +122,9 @@ ;*---------------------------------------------------------------------*/ (define (node-menu container e) (let ((children (markup-body container))) - (if (pair? (filter (lambda (x) (or (%chapter? x) (%section? x))) + (if (pair? (filter (lambda (x) + (memq (markup-markup x) + '(chapter section))) children)) (begin (newline) @@ -157,15 +154,15 @@ (markup-writer 'document info-engine :action (lambda (doc e) (let ((title (markup-option doc :title)) - (author (markup-option doc :author)) + (authors (markup-option doc :author)) (body (markup-body doc)) (footnotes (reverse! - (container-env-get n 'footnote-env)))) + (container-env-get doc 'footnote-env)))) (scribe-document->info doc (if title title "") (if (list? authors) authors (list authors)) - body) + body e) (if (pair? footnotes) (begin (with-justification @@ -179,10 +176,7 @@ (let ((label (markup-option fn :label)) (note (markup-body fn)) (id (markup-ident fn))) - (output (string-append "*" - (number->string number) - ": ") - e) + (output (list "*" label ": ") e) (output note e) (output-newline))) footnotes) @@ -191,9 +185,9 @@ ;*---------------------------------------------------------------------*/ ;* scribe-document->info ... */ ;*---------------------------------------------------------------------*/ -(define (scribe-document->info obj title authors body) +(define (scribe-document->info obj title authors body e) (define (info-authors1 author) - (info author) + (output author e) (output-newline) (output-newline)) (define (info-authorsN authors cols first) @@ -219,16 +213,17 @@ rows (cons (car authors) row) (+ cnum 1)))))) - (info (apply table + (output (apply table (if first (cons (make-row (list (car authors)) :colspan cols) (make-rows (cdr authors))) - (make-rows authors))))) + (make-rows authors))) + e)) (define (info-authors authors) (if (pair? authors) (begin (output-newline) - (output "--o-0-o--") + (output-justified "--o-0-o--") (output-newline) (output-newline) (let ((len (length authors))) @@ -246,38 +241,37 @@ (with-justification (make-justifier (justification-width) 'center) (lambda () - (output (make-string *text-column-width* #\=)) + (output-justified (make-string *text-column-width* #\=)) (output-newline) (if (string? title) - (output (list->string + (output-justified + (list->string (apply append (map (lambda (c) (list c #\bs)) (string->list title))))) - (info title)) + (output title e)) (output-newline) (info-authors authors) - (output (make-string *text-column-width* #\=)) + (output-justified (make-string *text-column-width* #\=)) (output-newline) (output-newline) (output-flush *margin*)))) -;; display the footer - (define (info-footer) - (if *scribe-footer* (info *scribe-footer*))) + ;; the main node (receive (next prev top) - (node-next+prev+top obj) + (node-next+prev+top obj e) (newline) (info-node "Top" next prev top)) ;; the title (info-title title authors) (output-flush 0) ;; the main info menu - (node-menu obj) + (node-menu obj e) ;; the body - (info body) + (output body e) (output-flush 0) ;; the footer of the document - (info-footer) + ;(info-footer) (output-flush 0) ;; we are done (newline) @@ -327,7 +321,7 @@ :action (lambda (n e) (with-justification (make-justifier (justification-width) 'center) (lambda () - (output (%center-body obj) e))))) + (output (markup-body n) e))))) ;*---------------------------------------------------------------------*/ ;* info ::%flush ... */ @@ -335,10 +329,10 @@ (markup-writer 'flush info-engine :options '(:side) :action (lambda (n e) - (let ((side (markup-option :side))) + (let ((side (markup-option n :side))) (with-justification (make-justifier (justification-width) side) (lambda () - (output (%flush-body obj) e)))))) + (output (markup-body n) e)))))) ;*---------------------------------------------------------------------*/ ;* *ornaments* ... */ @@ -374,7 +368,7 @@ :action (lambda (n e) (with-justification (make-justifier *text-column-width* 'verbatim) (lambda () - (output (markup-body obj) e) + (output (markup-body n) e) (output-newline))))) ;*---------------------------------------------------------------------*/ @@ -386,10 +380,22 @@ ;*---------------------------------------------------------------------*/ ;* info ::%reference ... */ ;*---------------------------------------------------------------------*/ -;; FIXME: Implement `ref' using `info-chapter-ref', etc. -;; (markup-writer 'ref info-engine -;; :action (lambda (n e) -;; #f)) +(markup-writer 'ref info-engine + :action (lambda (n e) + (let ((target (handle-ast (markup-body n)))) + (case (markup-markup target) + ((chapter) + (info-chapter-ref target e)) + ((section) + (info-section-ref target e)) + ((subsection) + (info-subsection-ref target e)) + ((subsubsection) + (info-subsubsection-ref target e)) + (else + (skribe-warning/ast 1 target + "ref: don't know how to refer to target") + (output-justified "section:???")))))) ;*---------------------------------------------------------------------*/ ;* info ::%url-ref ... */ @@ -397,87 +403,51 @@ (markup-writer 'url-ref info-engine :options '(:url :text) :action (lambda (n e) - (let ((url (markup-option :url)) - (text (markup-option :text))) + (let ((url (markup-option n :url)) + (text (markup-option n :text))) (if text (begin - (output "*Note ") + (output-justified "*Note ") (output text e) - (output " ("))) + (output-justified " ("))) (output url e) - (if text (output ")")) - (output ":: ")))) + (if text (output-justified ")")) + (output-justified ":: ")))) ;*---------------------------------------------------------------------*/ ;* info-chapter-ref ... */ ;*---------------------------------------------------------------------*/ -(define (info-chapter-ref obj) - (output "*Note ") - (output (block-title obj)) - (output ":: ")) - -;*---------------------------------------------------------------------*/ -;* info ::%section-ref ... */ -;*---------------------------------------------------------------------*/ -(define (info obj) - (receive (_ section) - (find-reference obj (current-document)) - (if (not (%section? section)) - (let ((anchor (markup-ident obj))) - (warning "ref" "Can't find section -- " anchor) - (output "section:???")) - (info-section-ref section)))) +(define (info-chapter-ref obj e) + (output-justified "*Note ") + (output (block-title obj e) e) + (output-justified ":: ")) ;*---------------------------------------------------------------------*/ ;* info-section-ref ... */ ;*---------------------------------------------------------------------*/ -(define (info-section-ref obj) +(define (info-section-ref obj e) (let ((title (markup-option obj :title))) - (output "*Note ") - (output title) - (output ":: "))) - -;*---------------------------------------------------------------------*/ -;* info ::%subsection-ref ... */ -;*---------------------------------------------------------------------*/ -(define (info obj) - (receive (_ subsection) - (find-reference obj (current-document)) - (if (not (%subsection? subsection)) - (let ((anchor (markup-ident obj))) - (warning "ref" "Can't find subsection -- " anchor) - (output "subsection:???")) - (info-subsection-ref subsection)))) + (output-justified "*Note ") + (output title e) + (output-justified ":: "))) ;*---------------------------------------------------------------------*/ ;* info-subsection-ref ... */ ;*---------------------------------------------------------------------*/ -(define (info-subsection-ref obj) +(define (info-subsection-ref obj e) (let ((title (markup-option obj :title))) - (output "*Note ") - (output title) - (output ":: "))) - -;*---------------------------------------------------------------------*/ -;* info ::%subsubsection-ref ... */ -;*---------------------------------------------------------------------*/ -(define (info obj) - (receive (_ subsubsection) - (find-reference obj (current-document)) - (if (not (%subsubsection? subsubsection)) - (let ((anchor (markup-ident obj))) - (warning "ref" "Can't find subsubsection -- " anchor) - (output "subsubsection:???")) - (info-subsubsection-ref subsubsection)))) + (output-justified "*Note ") + (output title e) + (output-justified ":: "))) ;*---------------------------------------------------------------------*/ ;* info-subsubsection-ref ... */ ;*---------------------------------------------------------------------*/ -(define (info-subsubsection-ref obj) +(define (info-subsubsection-ref obj e) (let ((title (markup-option obj :title))) - (output "*Note ") - (output title) - (output ":: "))) + (output-justified "*Note ") + (output title e) + (output-justified ":: "))) ;*---------------------------------------------------------------------*/ ;* info ::%biblio-ref ... */ @@ -489,9 +459,9 @@ (let ((text (markup-option n :text)) (bib (markup-option n :bib))) (if text (output text e)) - (output " [") + (output-justified " [") (output bib e) - (output "]")))) + (output-justified "]")))) ;*---------------------------------------------------------------------*/ ;* mailto ... */ @@ -527,10 +497,10 @@ (- (justification-width) 3) 'left) (lambda () - (output "- ") + (output-justified "- ") (output item e)) 3)) - items))) + (markup-body n)))) (markup-writer 'enumerate info-engine :action (lambda (n e) @@ -542,9 +512,9 @@ (- (justification-width) 3) 'left) (lambda () - (output (integer->string num)) - (output " - ") - (info item)) + (output-justified (number->string num)) + (output-justified " - ") + (output item e)) 3) (loop (+ num 1) (cdr items))))))) @@ -557,7 +527,7 @@ 'left) (output item e) 3)) - items))) + (markup-body n)))) ;*---------------------------------------------------------------------*/ ;* info ::%section ... */ @@ -569,9 +539,9 @@ (title (markup-option n :title))) (output-newline) (output-flush *margin*) - (let ((t (block-title n))) + (let ((t (block-title n e))) (receive (next prev top) - (node-next+prev+top n) + (node-next+prev+top n e) (info-node t next prev top) (print t) (print (make-string (string-length t) #\=)))) @@ -589,9 +559,9 @@ (let ((body (markup-body n)) (title (markup-option n :title))) (output-flush *margin*) - (let ((t (block-title n))) + (let ((t (block-title n e))) (receive (next prev top) - (node-next+prev+top n) + (node-next+prev+top n e) (info-node t next prev top) (print t) (print (make-string (string-length t) #\-)))) @@ -606,9 +576,9 @@ (let ((body (markup-body n)) (title (markup-option n :title))) (output-flush *margin*) - (let ((t (block-title n))) + (let ((t (block-title n e))) (receive (next prev top) - (node-next+prev+top n) + (node-next+prev+top n e) (info-node t next prev top) (print t) (print (make-string (string-length t) #\~)))) @@ -634,9 +604,9 @@ (title (markup-option n :title))) (output-newline) (output-flush *margin*) - (let ((t (block-title n))) + (let ((t (block-title n e))) (receive (next prev top) - (node-next+prev+top n) + (node-next+prev+top n e) (info-node t next prev top) (print t) (print (make-string (string-length t) #\*)))) @@ -655,7 +625,7 @@ (inexact->exact (* (exact->inexact (justification-width)) (/ (exact->inexact width) 100.)))))) - (output (make-string w #\-)))))) + (output-justified (make-string w #\-)))))) ;*---------------------------------------------------------------------*/ ;* info ::%table ... */ @@ -667,14 +637,16 @@ (output-flush *margin*) (if border (border-table->info n) - (table->ascii n info)) + (table->ascii n (lambda (obj) + (output obj e)))) (output-flush *margin*)))) ;*---------------------------------------------------------------------*/ ;* border-table->info ... */ ;*---------------------------------------------------------------------*/ (define (border-table->info table) - (table->ascii table info)) + (table->ascii table (lambda (obj) + (output obj info-engine)))) ;*---------------------------------------------------------------------*/ ;* info ::%figure ... */ @@ -689,9 +661,9 @@ (output body e) (output-newline) (output-newline) - (output "Fig. ") - (output (number->string number)) - (output ": ") + (output-justified "Fig. ") + (output-justified (number->string number)) + (output-justified ": ") (output legend e) (output-newline)))) |