aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/engine/info.scm216
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))))
generated by cgit v1.2.3 (git 2.47.1) at 2024-12-28 10:35:04 +0000