source: project/stream-wiki/tags/1.11/stream-wiki.scm @ 8348

Last change on this file since 8348 was 8348, checked in by Ivan Raikov, 12 years ago

Created release 1.11

File size: 71.8 KB
Line 
1;; $Id: stream-wiki.scm 5587 2006-05-19 06:24:51Z azul $
2;;
3;; This file is in the public domain and may be reproduced or copied without
4;; permission from its author.  Citation of the source is appreciated.
5;;
6;; Alejandro Forero Cuervo <azul@freaks-unidos.net>
7;;
8;; This file implements an egg for Chicken Scheme for parsing files in wiki
9;; format and rendering them to HTML.
10;;
11;; Documentation is available in HTML format.
12;;
13;; Newer versions might be available at:
14;;
15;;    http://anonymous:@afc.no-ip.info:8000/svn/home/src/chicken-eggs/stream-wiki
16
17(declare
18  (export
19    make-html-header
20    wiki->html
21    wiki->text
22    wiki->toc wiki->sections
23    load-linktypes
24    wiki->latex latex-page
25    wiki->texi texi-page
26    wiki-links
27    wiki-tags
28    load-extensions-from-file
29    extension-update
30    extension-files-actions-links
31    extension-toc-header
32    extension-data
33
34    ; Exports for extensions:
35
36    driver-horizontal-line
37    driver-math
38    driver-literal
39    driver-literal-line
40    driver-center
41    driver-big
42    driver-em
43    driver-strong
44    driver-small
45    driver-header
46    driver-blockquote
47    driver-line-break
48    driver-anchor
49
50    *extensions*)
51  (usual-integrations)
52  (run-time-macros))
53
54(include "chicken-more-macros")                                                                                               
55
56(use srfi-1 srfi-40 stream-ext html-stream stream-parser sandbox posix format-modular stream-sections uri)
57
58; An output driver is simply a table of functions.
59
60; For each field FIELD in our driver record, we also want to define a function
61; wikidata-FIELD such that
62;
63;   (wikidata-FIELD x)
64;
65; evaluates to whatever
66;
67;   (driver-FIELD (wikidata-driver x))
68;
69; evaluates to.  This is just to save some typing, since actually the driver is
70; usuall stored inside a wikidata record everywhere.
71;
72; That's all there is to the following macro.
73
74(define-macro (define-driver-record . funcs)
75  `(begin
76     (define-record driver ,@funcs)
77     ,@(map (lambda (sym)
78              `(define (,(string->symbol (format #f "wikidata-~A" sym)) info . args)
79                 (apply
80                   (,(string->symbol (format #f "driver-~A" sym)) (wikidata-driver info))
81                   args)))
82            funcs)))
83
84; Now lets define all the functions that make up an output driver.
85;
86; linktypes is a hashing table: the first element is a symbol for the name of
87; the type of link and the second is what we should use, with escape character
88; %t (replaced with the link's target).
89
90(define-driver-record output-format horizontal-line header blockquote center small big literal literal-line paragraph strong em link image math ordered-list unordered-list list-item definition-list definition-item toc special-char tags comment line-break anchor)
91
92(let ((get driver-anchor))
93  (set! driver-anchor
94    (lambda (driver)
95      (lambda (anchor . rest)
96        (let-optionals rest ((text stream-null))
97          ((get driver) (text->html-id anchor) text))))))
98
99; An extension tag for the wiki syntax.
100
101; name is a symbol with the name for the tag (all in lower).
102
103(define-record extension name table)
104
105; Output is an output driver.  See html-driver for an example.
106
107; linktypes-current is a list with the currently applied linktypes.  When
108; expanding a linktype (parsing its output recursively), we append its type
109; to linktypes-current.  That way we can detect infinite loops and react
110; gracefully.
111
112; tags is a hash table of record objects of type tags.
113
114(define-record wikidata driver open include name linktypes extensions extension-args linktypes-current previous-sections)
115
116; Macro used to generate the functions in the HTML driver.
117
118(define-macro (tags-func . tags)
119  (let ((arg (gensym "arg")))
120    `(lambda (,arg)
121       (html-stream
122         ,(fold-right list arg tags)))))
123
124;;; Helper functions
125;
126; Functions useful for all the drivers.
127
128; Is URL external?  Currently we simply check to see if it is an absolute URL.
129; We could be smarter than this if we had more information about the canonical
130; URL for the repository and of the current file but this is not that easy (for
131; instance, "/foo", "http://bar/foo" and "../foo" might be external or not).
132;
133; This function is replicated in svnwiki's links.scm.
134
135(define (url-external? url)
136  (let ((rest (stream-drop-while
137                (disjoin char-alphabetic? char-numeric?)
138                url)))
139    (and (not (stream-null? rest))
140         (not (stream-null? (stream-cdr rest)))
141         (char=? (stream-car rest) #\:))))
142
143; I had to duplicate this in Svnwiki.  It should really be a function passwd
144; by the caller.
145
146(define (name-to-base str)
147  (stream-downcase
148    (stream-map
149      (lambda (c) (if (char-whitespace? c) #\- c))
150      (stream-filter
151        (disjoin char-alphabetic?
152                 char-numeric?
153                 char-whitespace?
154                 (cut char=? <> #\/)
155                 (cut char=? <> #\-))
156        str))))
157
158(define (fix-suffix suffix)
159  (receive (querystring anchor)
160           (stream-break (cut char=? <> #\#) suffix)
161    (if (stream-null? anchor)
162      suffix
163      (stream-append querystring
164                     (stream-cons #\#
165                                  (text->html-id (stream-cdr anchor)))))))
166
167; Function to handle links intelligently.
168;
169; Analyzes the target and returns two things:
170;
171; - The type of link ("external", "internal" or "unexistant")
172;
173; - The URL that should be used as the target.  This is based on the input
174;   target but it might be modified.  For instance, its case might be changed
175;   to match a file (so users won't have to worry about the case of files when
176;   creating links) or a relative URL might be turned into an absolute URL.
177
178(define (parse-link dst check-exists? url-adjust)
179  (assert (and 'parse-link (stream? dst)))
180  (if (url-external? dst)
181    (values 'external dst)
182    (receive (dst-file dst-suffix)
183             (stream-break (disjoin (cut char=? <> #\?) (cut char=? <> #\#)) dst)
184      (let ((dst-real (stream-find check-exists? (parse-link-file dst-file))))
185        (if dst-real
186          (values "internal" (url-adjust (stream-append dst-real (fix-suffix dst-suffix))))
187          (values "unexistant" (name-to-base dst-file)))))))
188
189(define (parse-link-file file)
190  (stream-map
191    (lambda (f) (f file))
192    (stream identity stream-downcase name-to-base)))
193
194;;; OpenOffice.org Driver
195
196; Wildly incomplete.
197
198(define (ooo-driver header-start)
199  (make-driver
200    'open-document-format
201    (constantly (html-stream (hr)))
202    (lambda (name depth id)
203      (stream-append
204        (html-stream ((a name (text->html-id name))))
205        (string->stream (format #f "<h~A>" (min 6 (+ depth header-start))))
206        name
207        (string->stream (format #f "</h~A>" (min 6 (+ depth header-start))))))
208    (tags-func blockquote)
209    (tags-func center)
210    (tags-func small)
211    (tags-func big)
212    (tags-func pre)
213    (tags-func tt)
214    (tags-func p)
215    (tags-func strong)
216    (tags-func em)
217    (lambda (dst name) (html-stream ((a href dst) name)))
218    (lambda (dst name)
219      (receive (type alt)
220               (stream-break (cut char=? <> #\|) name)
221        (cond
222          ((stream-null? alt) (html-stream ((img src dst alt name))))
223          ((stream= char=? type (stream #\r #\i #\g #\h #\t))
224           (html-stream ((img style "margin-top: 1em; margin-left: 1em; margin-bottom: 1em;" align "right" src dst alt (stream-cdr alt)))))
225          ((stream= char=? type (stream #\l #\e #\f #\t))
226           (html-stream ((img style "margin-top: 1em; margin-right: 1em; margin-bottom: 1em;" align "left" src dst alt (stream-cdr alt)))))
227          (else (html-stream ((img src dst alt name)))))))
228    (lambda (text)
229      (string->stream "[[Math support is currently disabled]]"))
230    (constantly stream-null)
231    (lambda (char)
232      (if (char? char)
233        (stream char)
234        stream-null))
235    (constantly stream-null)
236    (constantly stream-null)
237    (constantly (html-stream (br)))
238    ; anchor
239    (constantly stream-null)))
240
241;;; HTML Driver
242
243; header-start is the depth of the headers (for example, 1 makes == become
244; <h1>).
245;
246; header-prefix is a function
247
248(define (make-html-header . rest)
249  (let-optionals rest ((header-start 1))
250    (lambda (name depth id)
251      (html-stream
252        ((a name (text->html-id id)))
253        (string->stream (format #f "<h~A>" (min 6 (+ depth header-start))))
254        name
255        (string->stream (format #f "</h~A>" (min 6 (+ depth header-start))))))))
256
257(define (html-driver-link check-exists? url-adjust no-follow? dst name)
258  (assert (and 'html-driver-link (stream? dst)))
259  (assert (and 'html-driver-link (stream? name)))
260  (receive (type dst-real)
261           (parse-link dst check-exists? url-adjust)
262    (assert (and html-driver-link '(stream? dst-real)))
263    (if (and (eq? type 'external)
264             (no-follow? dst-real))
265      (html-stream ((a href dst-real class type rel "nofollow") name))
266      (html-stream ((a href dst-real class type) name)))))
267
268(define (html-driver-image check-exists? url-adjust dst name)
269  (assert (and 'html-driver-image (stream? dst)))
270  (assert (and 'html-driver-image (stream? name)))
271  (receive (type alt)
272           (stream-break (cut char=? <> #\|) name)
273    (receive (_ url)
274             (parse-link dst check-exists? url-adjust)
275      (if (and (not (stream-null? alt))
276               (or (stream= char=? type (string->stream "right"))
277                   (stream= char=? type (string->stream "left"))
278                   (stream= char=? type (string->stream "center"))))
279        (let ((class (format #f "image-~A" (stream->string type))))
280          (html-stream
281            ((div class class)
282             ((img class class src url alt (stream-cdr alt)))
283             (if (stream-null? (stream-cdr alt))
284               stream-null
285               (html-stream ((p class class) (stream-cdr alt)))))))
286        (html-stream ((img src url alt name)))))))
287
288(define (texvc-math data-output-func text)
289  (data-output-func
290    (stream-append (string->stream "texvc-math:") text)
291    "image/png"
292    (lambda (file url)
293      (if (file-exists? file)
294        (html-stream ((img src url)))
295        (let ((dir (string-intersperse (butlast (cons "" (string-split file "/"))) "/")))
296          (receive (in out pid)
297                   (process (format #f "texvc /tmp ~A ~A latin1" dir (shell-escape text)))
298            (close-output-port out)
299            (let ((texvc-in (port->stream in)))
300              (case (and (not (stream-null? texvc-in)) (stream-car texvc-in))
301                ((#\+ #\c #\m #\l #\C #\M #\L #\X)
302                 (rename-file (string-append dir "/" (stream->string (stream-take (stream-cdr texvc-in) 32)) ".png") file)
303                 (html-stream ((img src url))))
304                (else
305                  (string->stream "[[Markup error or TexVC not found]]"))))))))))
306
307(define (html-driver make-header data-output-func check-exists? url-adjust no-follow?)
308  (make-driver
309    'html
310    ; horizontal line
311    (constantly (html-stream (hr)))
312    ; make header
313    make-header
314    ; blockquote
315    (tags-func blockquote)
316    ; center
317    (tags-func center)
318    ; small
319    (tags-func small)
320    ; big
321    (tags-func big)
322    ; literal
323    (tags-func pre)
324    ; literal-line
325    (tags-func tt)
326    ; paragraph
327    (tags-func p)
328    ; strong
329    (tags-func strong)
330    ; emphasis
331    (tags-func em)
332    ; link
333    (cut html-driver-link check-exists? url-adjust no-follow? <...>)
334    ; image
335    (cut html-driver-image check-exists? url-adjust <...>)
336    ; math
337    (if data-output-func
338      (cut texvc-math data-output-func <>)
339      (lambda (text)
340        (string->stream "[[Math support is currently disabled]]")))
341    ; ordered list
342    (tags-func ol)
343    ; bullets list
344    (tags-func ul)
345    ; list item
346    (tags-func li)
347    ; definition list
348    (tags-func dl)
349    ; definition
350    (lambda (term definition)
351      (html-stream
352        (if (stream-null? term)
353          stream-null
354          (html-stream (dt term)))
355        (if (stream-null? definition)
356          stream-null
357          (html-stream (dd definition)))))
358    ; toc
359    (lambda (info dst)
360      (let* ((file (if (stream-null? dst) (wikidata-name info) (stream->string dst))))
361        (wiki-parse (wikidata-driver info) (wiki->toc ((wikidata-open info) file)) stream-null file (wikidata-open info) (wikidata-include info) (wikidata-extensions info))))
362    ; special-char
363    (lambda (x)
364      (string->stream
365        (case x
366          ((#\&) "&amp;")
367          ((#\<) "&lt;")
368          ((#\>) "&gt;")
369          ((copyright) "&copy;")
370          ((reg) "&reg;")
371          ((left-arrow) "&larr;")
372          ((right-arrow) "&rarr;")
373          ((double-arrow) "&harr;")
374          ((double-arrow-wide) "&hArr;")
375          ((left-arrow-wide) "&lArr;")
376          ((right-arrow-wide) "&rArr;")
377          ((mdash) "&mdash;")
378          ((ndash) "&ndash;")
379          ((laquo) "&laquo;")
380          ((raquo) "&raquo;")
381          (else
382            (cond
383              ((char? x) (string x))
384              ((symbol? x) (symbol->string x)))))))
385    ; tags
386    (constantly stream-null)
387    ; comments
388    (lambda (text)
389      (stream-append
390        (string->stream "<!-- ")
391        text
392        (string->stream " -->")))
393    ; line-break
394    (constantly (html-stream (br)))
395    (lambda (anchor text)
396      (html-stream ((a name anchor) text)))))
397
398;;; Plain text driver
399
400; human-readable is a boolean specifying that the output should be optimized
401; to be read by a human (as opposed to a machine indexing the text in the
402; file, say a search engine).
403
404(define (text-driver human-readable)
405  (make-driver
406    'text
407    ; horizontal line
408    (if human-readable
409      (constantly (stream-append (make-stream 60 #\-) (stream #\newline)))
410      (constantly stream-null))
411    ; make header
412    (lambda (name depth id)
413      (stream-append name (stream #\newline #\newline)))
414    ; blockquote
415    (if human-readable
416      (lambda (text)
417        (stream-cons* #\> #\space text))
418      identity)
419    ; center
420    identity
421    ; small
422    identity
423    ; big
424    identity
425    ; literal
426    identity
427    ; literal-line
428    identity
429    ; paragraph
430    (lambda (text)
431      (assert (stream? text))
432      (stream-append text (stream #\newline #\newline)))
433    ; strong
434    identity
435    ; emphasis
436    identity
437    ; link
438    (lambda (dst name)
439      (assert (stream? dst))
440      (assert (stream? name))
441      (if (stream= char=? dst name)
442        (stream-append (stream #\[) dst (stream #\]))
443        (stream-append name (stream #\space #\[) dst (stream #\]))))
444    ; image
445    (if human-readable
446      (lambda (dst name)
447        (stream-append
448          (string->stream "[IMAGE:")
449          name
450          (stream #\])))
451      (lambda (dst name)
452        name))
453    ; math
454    identity
455    ; ordered list
456    identity
457    ; bullets list
458    identity
459    ; list item
460    (lambda (item)
461      ; TODO: Somehow get the depth right!
462      (stream-append
463        (if human-readable (stream #\* #\space) stream-null)
464        item
465        (stream #\newline #\newline)))
466    ; definition list
467    identity
468    ; definition
469    (lambda (term definition)
470      (stream-append
471        (if human-readable (stream #\- #\space) stream-null)
472        term
473        (stream #\newline #\newline #\space #\space)
474        definition
475        (stream #\newline #\newline)))
476    ; toc
477    (lambda (info dst)
478      ; TODO: write!
479      stream-null)
480    ; special-char
481    (lambda (x)
482      (string->stream
483        (case x
484          ((#\&) "&")
485          ((#\<) "<")
486          ((#\>) ">")
487          ((copyright) "(copyright)")
488          ((reg) "(reg)")
489          ((left-arrow) "<-")
490          ((right-arrow) "->")
491          ((double-arrow) "<->")
492          ((double-arrow-wide) "<=>")
493          ((left-arrow-wide) "<=")
494          ((right-arrow-wide) "=>")
495          ((mdash) "---")
496          ((ndash) "--")
497          ((laquo) "<<")
498          ((raquo) ">>")
499          (else
500            (cond
501              ((char? x) (string x))
502              ((symbol? x) (symbol->string x)))))))
503    ; tags
504    (constantly stream-null)
505    ; comments
506    (constantly stream-null)
507    (constantly (stream #\newline))
508    ; anchor
509    (lambda (anchor text)
510      text)))
511
512;;; Special Drivers
513
514(define (stream-traverse x)
515  (stream-null? (stream-drop-while (constantly #t) x)))
516
517(define (links-driver register)
518  (make-driver
519    'links
520    (constantly stream-null)
521    (constantly stream-null)
522    (compose (constantly stream-null) stream-traverse)
523    (compose (constantly stream-null) stream-traverse)
524    (compose (constantly stream-null) stream-traverse)
525    (compose (constantly stream-null) stream-traverse)
526    (compose (constantly stream-null) stream-traverse)
527    (compose (constantly stream-null) stream-traverse)
528    (compose (constantly stream-null) stream-traverse)
529    (compose (constantly stream-null) stream-traverse)
530    (compose (constantly stream-null) stream-traverse)
531    (lambda (dst name)
532      (register (list (stream-take-while (complement (conjoin (cut char=? <> #\|) (cut char=? <> #\#))) dst) name))
533      stream-null)
534    (constantly stream-null)
535    (constantly stream-null)
536    (compose (constantly stream-null) stream-traverse)
537    (compose (constantly stream-null) stream-traverse)
538    (compose (constantly stream-null) stream-traverse)
539    (compose (constantly stream-null) stream-traverse)
540    (lambda (t d)
541      (stream-traverse t)
542      (stream-traverse d)
543      stream-null)
544    ; toc
545    (constantly stream-null)
546    ; special-char
547    (constantly stream-null)
548    ; tags
549    (constantly stream-null)
550    ; comments
551    (constantly stream-null)
552    ; line-break
553    (constantly stream-null)
554    ; anchor
555    (constantly stream-null)))
556
557(define (tags-driver register)
558  (make-driver
559    'tags
560    (constantly stream-null)
561    (constantly stream-null)
562    (compose (constantly stream-null) stream-traverse)
563    (compose (constantly stream-null) stream-traverse)
564    (compose (constantly stream-null) stream-traverse)
565    (compose (constantly stream-null) stream-traverse)
566    (compose (constantly stream-null) stream-traverse)
567    (compose (constantly stream-null) stream-traverse)
568    (compose (constantly stream-null) stream-traverse)
569    (compose (constantly stream-null) stream-traverse)
570    (compose (constantly stream-null) stream-traverse)
571    (constantly stream-null)
572    (constantly stream-null)
573    (constantly stream-null)
574    (compose (constantly stream-null) stream-traverse)
575    (compose (constantly stream-null) stream-traverse)
576    (compose (constantly stream-null) stream-traverse)
577    (compose (constantly stream-null) stream-traverse)
578    (lambda (t d)
579      (stream-traverse t)
580      (stream-traverse d)
581      stream-null)
582    ; toc
583    (constantly stream-null)
584    ; special-char
585    (constantly stream-null)
586    ; tags
587    (let ((old-tags (make-hash-table)))
588      (lambda (tags)
589        (stream-for-each
590          (lambda (t)
591            (let ((ts (stream->symbol t)))
592              (unless (hash-table-ref/default old-tags ts #f)
593                (register ts)
594                (hash-table-set! old-tags ts #t))))
595          (stream-filter
596            (complement stream-null?)
597            (stream-split
598              (stream-map
599                char-downcase
600                (stream-filter
601                  (disjoin char-numeric? char-alphabetic? char-whitespace?)
602                  tags))
603              char-whitespace?)))
604        stream-null))
605    (compose (constantly stream-null) stream-traverse)
606    (constantly stream-null)
607    ; anchor
608    (constantly stream-null)))
609
610;;; LaTeX driver
611
612(define (latex-text-parse dst)
613  (if (stream-null? dst)
614    stream-null
615    (case (stream-car dst)
616      ((#\& #\$ #\{ #\} #\# #\_) (stream-cons* #\\ (stream-car dst) (latex-text-parse (stream-cdr dst))))
617      (else (stream-cons (stream-car dst) (latex-text-parse (stream-cdr dst)))))))
618
619(define (latex-wrap start end . rest)
620  (let-optionals rest ((parse #f))
621    (let ((real-start (string->stream start)) (real-end (string->stream end)) (parse-func (if parse latex-text-parse identity)))
622      (lambda (arg) (stream-append real-start (parse-func arg) real-end)))))
623
624(define *latex-default-document-class* "article")
625
626(define *latex-document-classes* '("article" "book" "report"))
627(define *latex-languages* '("spanish" "english" "german"))
628
629(define (latex-page lang class content)
630  (->stream-char
631    (format #f "\\documentclass[12pt]{~A}~%\\usepackage[~A]{babel}~%\\usepackage[T1]{fontenc}~%\\usepackage[utf8]{inputenc}~%\\usepackage{palatino}~%\\usepackage[pdftex]{hyperref}\\begin{document}~%" (if (and class (member class *latex-document-classes*)) class *latex-default-document-class*) (if (and lang (member lang *latex-languages*)) lang "english"))
632    (stream-append content (string->stream "\n\\end{document}\n"))))
633
634(define (latex-environment name)
635  (latex-wrap (format #f "\\begin{~A}\n" name)
636              (format #f "\\end{~A}\n" name)))
637
638(define (latex-driver class links-base)
639  (make-driver
640    'latex
641    ; horizontal line
642    (constantly stream-null)
643    ; make header
644    (let ((add (if (or (string=? class "book") (string=? class "report")) 0 1)))
645      (lambda (name depth id)
646        (stream-append
647          (let ((real-depth (+ depth add)))
648            (cond
649              ((zero? real-depth)
650               (string->stream "\\chapter{"))
651              ((<= real-depth 3)
652               (stream-append
653                 (stream #\\ )
654                 (stream-concatenate (make-stream (- real-depth 1) (string->stream "sub")))
655                 (string->stream "section{")))
656              (else
657                (string->stream "\\noindent \\textbf{"))))
658          (latex-text-parse name)
659          (stream #\} #\newline #\newline))))
660    ; blockquote
661    (latex-environment 'quote)
662    ; center
663    (latex-environment 'center)
664    ; small
665    (latex-environment 'small)
666    ; big
667    (latex-environment 'large)
668    ; literal
669    (latex-environment 'verbatim)
670    ; literal-line
671    (latex-wrap "\\verb|" "|")
672    ; paragraph
673    (latex-wrap "" "\n\n")
674    ; strong
675    (latex-wrap "\\textbf{" "}")
676    ; emphasis
677    (latex-wrap "\\textit{" "}")
678    ; link
679    (lambda (dst name)
680      (string->stream
681        (format #f "\\href{~A}{~A}"
682                (stream->string
683                  ((if (url-external? dst) identity links-base)
684                   (latex-text-parse dst)))
685                (stream->string (latex-text-parse name)))))
686    ; image
687    (lambda (dst name)
688      (warning "Image not implemented yet in LaTeX mode.~%")
689      (receive (type alt)
690               (stream-break (cut char=? <> #\|) name)
691        (string->stream (format #f "[[IMAGE:~A]]" (stream->string (or alt dst))))))
692    ; math
693    (lambda (text)
694      (string->stream (format #f "$$~A$$" (stream->string text))))
695    ; ordered list
696    (latex-environment 'enumerate)
697    ; bullets list
698    (latex-environment 'itemize)
699    ; list item
700    (latex-wrap "\\item " "\n\n")
701    ; definition list
702    (latex-environment 'description)
703    ; definition
704    (lambda (term definition)
705      (string->stream
706        (format #f "\\item[~A]~%~%~A~%" (stream->string term) (stream->string definition))))
707    ; toc
708    (lambda (info dst)
709      (if (stream-null? dst)
710        (string->stream "\\tableofcontents\n\n")
711        ; Can't get TOC of other documents yet:
712        stream-null))
713    ; special-character
714    (lambda (x)
715      (->stream-char
716        (case x
717          ((#\& #\$ #\{ #\} #\# #\_) (stream #\\ x))
718
719          ; Not much else we can do right now about quotation marks, is there?
720          ; We don't know if they are opening or closing quotation marks... :-/
721
722          ((#\\ #\") stream-null)
723
724          ((#\<) "<")
725          ((#\>) ">")
726          ((copyright) "(C)")
727          ((reg) "(R)")
728          ((left-arrow) "<-")
729          ((right-arrow) "->")
730          ((double-arrow) "<->")
731          ((double-arrow-wide) "<=>")
732          ((left-arrow-wide) "<=")
733          ((right-arrow-wide) "=>")
734          ((mdash) "---")
735          ((ndash) "--")
736          ((laquo) "<<")
737          ((raquo) ">>")
738          (else (string x)))))
739    ; tags
740    (constantly stream-null)
741    ; comments
742    (constantly stream-null)
743    (constantly (stream #\\ #\\ ))
744    ; anchor
745    ; TODO: I think LaTeX does support anchor, we should get them to work.
746    (constantly stream-null)))
747
748;;; Parsing
749
750(define (char-blank? x) (or (equal? x #\space) (equal? x #\tab)))
751
752; This is the parser for text that occurs inside a given set of
753; <p>, <pre>, <blockquote>, <li>, <dt> or <dd> tags.
754
755(define (text-transform info strong em literal start newline-rep)
756  (assert (wikidata? info))
757  (lambda (str fail parsed)
758    (parse-token str fail parsed
759
760      ; Cases for EOL.  If it is followed by a character, we want
761      ; to replace it with newline-rep (which is normally a space
762      ; but is a #\newline when we're inside a <pre> tag):
763
764      ((#\newline (assert newline-rep) (end)) stream-null)
765      ((#\newline (assert (and newline-rep start)) start) (stream newline-rep))
766      ((#\newline (assert (and newline-rep (not start)))) (stream newline-rep))
767
768      ; <strong> and <em>:
769
770      ((#\' #\' #\' (assert (not strong)) (bind text (*? (rule-apply (text-transform info #t em literal start newline-rep)))) #\' #\' #\')
771       (wikidata-strong info text))
772
773      ((#\' #\' (assert (not em)) (bind text (*? (rule-apply (text-transform info strong #t literal start newline-rep)))) #\' #\')
774       (wikidata-em info text))
775
776      ; Links: [ TYPE : ] DST [ | NAME ] (type and name are
777      ; optional).
778
779      ((#\[ #\[
780        (all char-whitespace?)
781        (? (bind type (*? (not (or #\[ #\: #\| #\] #\newline))))
782           (all char-whitespace?) #\: (all char-whitespace?))
783        (bind dst (*? (not (or #\[ #\| #\] #\newline))))
784        (all char-whitespace?)
785        (? #\| (all char-whitespace?)
786           (bind name (*? (rule-apply (text-transform info strong em literal start newline-rep))))
787           (all char-whitespace?))
788        #\] #\])
789       (make-link info
790         (if (stream-null? type) #f type)
791         dst
792         (if (stream-null? name) #f name)))
793
794      ; Typewritten text:
795
796      ((#\{ #\{ (bind text (*? char?)) #\} #\})
797       (wikidata-literal-line info
798         (parse-all text (lambda () (error "bar")) (text-transform info strong em #t start newline-rep) stream-null)))
799
800      ; Comments
801
802      ((#\< #\! (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?)
803        (bind text (*? char?))
804        (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?) #\>)
805       (wikidata-comment info text))
806
807      ; Span tags:
808
809      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
810        (assert
811          (and-let* ((ext (hash-table-ref/default
812                            (wikidata-extensions info)
813                            (stream->symbol (stream-downcase tag))
814                            #f)))
815            (extension-code-span ext)))
816        ; Parameters
817        (* (+ char-whitespace?)
818           (bind name (all char-alphabetic?))
819           (all char-whitespace?)
820           (? #\= (all char-whitespace?)
821              (or (#\" (bind value (all (not #\"))) #\")
822                  (#\' (bind value (all (not #\'))) #\')
823                  ((bind value (all (or char-alphabetic? char-numeric?))))))
824           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
825        (all char-whitespace?) #\>
826        (bind text (*? char?))
827        #\< (all char-whitespace?) #\/ tag (all char-whitespace?) #\>)
828
829       (run-span-extension
830         (hash-table-ref
831           (wikidata-extensions info)
832           (stream->symbol (stream-downcase tag)))
833         text
834         params
835         info))
836
837      ; Break tags:
838
839      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
840        (assert
841          (and-let* ((ext (hash-table-ref/default
842                            (wikidata-extensions info)
843                            (stream->symbol (stream-downcase tag))
844                            #f)))
845            (extension-code-break ext)))
846        ; Parameters
847        (* (+ char-whitespace?)
848           (bind name (all (or char-alphabetic? char-numeric?)))
849           (all char-whitespace?)
850           (? #\= (all char-whitespace?)
851              (or (#\" (bind value (all (not #\"))) #\")
852                  (#\' (bind value (all (not #\'))) #\')
853                  ((bind value (all (or char-alphabetic? char-numeric?))))))
854           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
855        (all char-whitespace?) (? #\/) (all char-whitespace?) #\>)
856       (run-break-extension
857         (hash-table-ref
858           (wikidata-extensions info)
859           (stream->symbol (stream-downcase tag)))
860         params
861         info))
862
863      ; Replace certain sequences with HTML entities, unless we are inside a
864      ; <pre>, <tt> or <code> tag.
865
866      ((#\< #\< (assert (not literal))) (wikidata-special-char info 'laquo))
867      ((#\> #\> (assert (not literal))) (wikidata-special-char info 'raquo))
868      ((#\( (or #\R #\r) #\) (assert (not literal))) (wikidata-special-char info 'reg))
869      ((#\( (or #\C #\c) #\) (assert (not literal))) (wikidata-special-char info 'copyright))
870      ((#\1 #\/ #\2 (assert (not literal))) (string->stream "&frac12;"))
871      ((#\1 #\/ #\4 (assert (not literal))) (string->stream "&frac14;"))
872      ((#\3 #\/ #\4 (assert (not literal))) (string->stream "&frac34;"))
873      ((#\< #\- #\> (assert (not literal))) (wikidata-special-char info 'double-arrow))
874      ((#\< #\- (assert (not literal))) (wikidata-special-char info 'left-arrow))
875      ((#\- #\> (assert (not literal))) (wikidata-special-char info 'right-arrow))
876      ((#\< #\= #\> (assert (not literal))) (wikidata-special-char info 'double-arrow-wide))
877      ((#\< #\= (assert (not literal))) (wikidata-special-char info 'left-arrow-wide))
878      ((#\= #\> (assert (not literal))) (wikidata-special-char info 'right-arrow-wide))
879      ((#\- #\- #\- (assert (not literal))) (wikidata-special-char info 'mdash))
880      ((#\- #\- (assert (not literal))) (wikidata-special-char info 'ndash))
881
882      ; Some entities that we don't want to include literally.
883
884      (((bind char special-char?))
885       (wikidata-special-char info (stream-car char)))
886
887      ; An email address:
888
889      (((bind initial (?? char?))
890        (bind email
891              char-alphabetic?
892              (all (or char-alphabetic? char-numeric? #\. #\- #\_ #\+))
893              #\@
894              (+
895                (or char-alphabetic? char-numeric?)
896                (* (or char-alphabetic? char-numeric? #\-))
897                (or char-alphabetic? char-numeric?)
898                #\.)
899              (or char-alphabetic? char-numeric?)
900              (* (or char-alphabetic? char-numeric? #\-))
901              (or char-alphabetic? char-numeric?)))
902       (stream-append
903         initial
904         (make-link info
905           (string->stream "mailto")
906           email
907           email)))
908
909      ; A URL:
910
911      (((bind initial (?? char?))
912        (bind type (all char-alphabetic?))
913        #\:
914        (assert (assoc (stream->symbol (stream-downcase type)) *allowed-url-schemes*))
915        (bind dst
916              #\/ #\/
917              (+
918                (or char-alphabetic? char-numeric?)
919                (* (or char-alphabetic? char-numeric? #\-))
920                (or char-alphabetic? char-numeric?)
921                #\.)
922              (or char-alphabetic? char-numeric?)
923              (* (or char-alphabetic? char-numeric? #\-))
924              (or char-alphabetic? char-numeric?)
925              ; Port
926              (? #\: (+ char-numeric?))
927              ; File or QUERY STRING or Anchor
928              (?
929                (or #\/ #\? #\#)
930                (?
931                  (* (or char-alphabetic? char-numeric? #\~ #\/ #\. #\? #\& #\# #\% #\= #\- #\_))
932                  ; The last character must not be a dot:
933                  (or char-alphabetic? char-numeric? #\~ #\/ #\? #\& #\# #\% #\= #\- #\_)))))
934       (stream-append initial (make-link info type dst #f)))
935
936      ; Normal text:
937
938      (((bind str
939              (not (or special-char? #\newline))
940              (all standard-char?)))
941       str))))
942
943(define (not-newline? x)
944  (not (char=? x #\newline)))
945
946(define *allowed-url-schemes*
947  '((http) (https) (ftp)))
948
949; Characters that should be handled by wikidata-special-char instead of
950; included verbatim.
951
952(define (special-char? x)
953  (case x
954    ((or #\# #\$ #\< #\> #\& #\_ #\\ #\" #\{ #\} #\@) #t)
955    (else #f)))
956
957(define (standard-char? x)
958  (and (not (special-char? x))
959       (case x
960         ((#\newline #\' #\[ #\] #\: #\| #\( #\space #\, #\. #\- #\=) #f)
961         (else #t))))
962
963(define (make-link info type dst name)
964  (assert (wikidata? info))
965  ((let ((type-sym (and type (stream->symbol (stream-downcase type)))))
966     (cond
967        ((not type-sym) make-default-link)
968        ((assoc type-sym *link-types*) => cadr)
969        ((hash-table-ref/default (wikidata-linktypes info) type-sym #f) => run-linktype)
970        (else make-default-link)))
971   info type dst name))
972
973(define (make-default-link info type dst name)
974  (assert (wikidata? info))
975  (let ((real-dst (if type (stream-append type (stream-cons #\: dst)) dst)))
976    (wikidata-link info real-dst (or name real-dst))))
977
978(define (make-link-image info type dst name)
979  (assert (wikidata? info))
980  (wikidata-image info dst (or name dst)))
981
982(define (register-link-tag info type dst name)
983  (assert (wikidata? info))
984  (wikidata-tags info (or name dst)))
985
986(define (make-link-include info type dst name)
987  (assert (wikidata? info))
988  ((wikidata-include info) (stream->string dst) stream-null))
989
990(define (make-link-toc info type dst name)
991  (assert (wikidata? info))
992  (wikidata-toc info info dst))
993
994(define (make-link-mailto info type dst name)
995  (wikidata-link info (stream-append type (stream-cons #\: dst)) (or name dst)))
996
997(define *link-types*
998  `((include ,make-link-include)
999    (toc ,make-link-toc)
1000    (image ,make-link-image)
1001    (tags ,register-link-tag)
1002    (mailto ,make-link-mailto)))
1003
1004(define (list-transform info current)
1005  (assert (wikidata? info))
1006  (lambda (str fail parsed)
1007    (parse-token str fail parsed
1008      (((bind data
1009              current (all #\space) (bind list-item (or #\* #\#))
1010              (all (all #\space) (or #\* #\#))
1011              (? #\newline)
1012              (all (not (or #\* #\# #\newline))
1013                   (all (not #\newline))
1014                   (? #\newline))
1015              (all #\newline)
1016              (all
1017                current (all #\space) list-item
1018                (all (all #\space) (or #\* #\#))
1019                (? #\newline)
1020                (all (not (or #\* #\# #\newline))
1021                     (all (not #\newline))
1022                     (? #\newline))
1023                (all #\newline))))
1024       ((if (char=? (stream-car list-item) #\*)
1025          wikidata-unordered-list
1026          wikidata-ordered-list)
1027        info
1028        (parse-all data fail (list-transform info (stream-append current list-item)))))
1029      (((bind head
1030              (? current (all #\space)
1031                 (? #\newline)
1032                 (bind text
1033                       (all (not (or #\* #\# #\newline))
1034                            (all (not #\newline))
1035                            (? #\newline)))))
1036        (all #\newline)
1037        (bind tail
1038              (all current
1039                   (+all (all #\space) (or #\* #\#))
1040                   (all #\space)
1041                   (? #\newline)
1042                   (all (not (or #\* #\#))
1043                        (all (not #\newline))
1044                        (? #\newline))))
1045        (assert (not (and (stream-null? head) (stream-null? tail)))))
1046       (wikidata-list-item info
1047         (stream-append
1048           (if (stream-null? head)
1049             stream-null
1050             (parse-all
1051               (stream-reverse
1052                 (stream-drop-while
1053                   char-whitespace?
1054                   (stream-reverse text)))
1055               (lambda () (error "foo"))
1056               (text-transform info #f #f #f #f #\space)))
1057           (if (stream-null? tail)
1058             stream-null
1059             (parse-all tail fail (list-transform info current)))))))))
1060
1061(define (definition-list info)
1062  (assert (wikidata? info))
1063  (lambda (str fail parsed)
1064    (parse-token str fail parsed
1065      ((#\; (all char-whitespace?)
1066        (bind term (*? (rule-apply (text-transform info #f #f #f #f #f))))
1067        (? (all char-blank?) #\: (all char-blank?)
1068           (bind definition (*? (not #\: #\newline) (all standard-char?)))
1069           (all char-blank?))
1070        (+ (all char-blank?) (or #\newline ((end)))))
1071       (wikidata-definition-item
1072         info
1073         term
1074         (parse-all definition (lambda () (error "foo")) (text-transform info #f #f #f #f #\space)))))))
1075
1076(define (global-token output open include name linktypes extensions extensions-args)
1077  (assert (driver? output))
1078  (global-token-info (make-wikidata output open include name linktypes extensions extensions-args '() (make-hash-table))))
1079
1080; This is the global parser which gets called by wiki->html.  It
1081; splits the input in chunks of lines (corresponding to
1082; paragraphs, lists, quotes, etc.) that must be processed
1083; together.
1084
1085(define (global-token-info info)
1086  (assert (wikidata? info))
1087  (lambda (str fail parsed)
1088    (parse-token str fail parsed
1089
1090      ; Simple line break:
1091
1092      ((#\- #\- #\- #\- (all char-blank?)) (wikidata-horizontal-line info))
1093
1094      ; Get all headers.  The type of header depends on the number
1095      ; of #\= signs:
1096
1097      ((#\= (bind depth (+all #\=))
1098        (all char-blank?)
1099        (bind name (*? (not #\newline)))
1100        (all char-blank?)
1101        (? #\= depth (all char-blank?))
1102        (or #\newline ((end))))
1103       (wikidata-header
1104         info
1105         (parse-all
1106           name
1107           (lambda () (error "noparse" (stream->string name)))
1108           (text-transform info #f #f #f #f #\space))
1109         (min 5 (stream-length (stream-cdr depth)))
1110         (sections-accept-new-name! (wikidata-previous-sections info) name)))
1111
1112      ; Skip empty lines:
1113
1114      ((#\newline) stream-null)
1115
1116      ; Process <ul> or <ol> lists calling the list-transform
1117      ; parser:
1118
1119     (((bind lines
1120             (+ (+all (or #\# #\*) (all #\space))
1121                (? #\newline)
1122                (all (not (or #\* #\# #\newline (#\= #\=)))
1123                     (all (not #\newline))
1124                     (or #\newline ((end))))
1125                (all #\newline))))
1126      (parse-all lines (lambda () (error "list-transform failed to parse")) (list-transform info stream-null)))
1127
1128      ; Process definition lists with the definition-list parser:
1129
1130      (((bind lines (+ (rule-apply (definition-list info)))))
1131       (wikidata-definition-list info lines))
1132
1133      ; Get quoted text (lines starting with #\>) inside a pair of
1134      ; <blockquote> tags:
1135
1136      (((+all #\> (all (or #\space #\tab))
1137              (bind text (all (not #\newline)) (or #\newline ((end))))
1138              (bind-accum (result '()) cons text)))
1139       (wikidata-blockquote info
1140         (parse-all
1141           (stream-concatenate (list->stream (reverse result)))
1142           (lambda () (error "noparse" (stream->string (stream-reverse (stream-cdr text)))))
1143           (global-token-info info))))
1144
1145      ; Get literal text (lines starting with #\space) inside a
1146      ; pair of <pre> tags:
1147
1148      (((bind text (+ #\space (*? char?) (or #\newline ((end))))))
1149       (wikidata-literal info
1150         (parse-all (stream-cdr text) (lambda () (error "foo")) (text-transform info #f #f #t #\space #\newline))))
1151
1152      ; Comments
1153
1154      ((#\< #\! (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?)
1155        (bind text (*? char?))
1156        (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?) #\>)
1157       (wikidata-comment info text))
1158
1159      ; Detect span extensions:
1160
1161      ((#\< (all char-whitespace?) (bind tag (all (or char-alphabetic? char-numeric?)))
1162        (assert
1163          (and-let* ((ext (hash-table-ref/default
1164                            (wikidata-extensions info)
1165                            (stream->symbol (stream-downcase tag))
1166                            #f)))
1167            (extension-code-span ext)))
1168        ; Parameters
1169        (* (+ char-whitespace?)
1170           (bind name (all (or char-alphabetic? char-numeric?)))
1171           (all char-whitespace?)
1172           (? #\= (all char-whitespace?)
1173              (or (#\" (bind value (all (not #\"))) #\")
1174                  (#\' (bind value (all (not #\'))) #\')
1175                  ((bind value (all (or char-alphabetic? char-numeric?))))))
1176           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
1177        (all char-whitespace?) #\>
1178        (bind text (*? char?))
1179        #\< (all char-whitespace?) #\/ tag (all char-whitespace?) #\>)
1180
1181       ; *tags-span-external*
1182
1183       (run-span-extension
1184         (hash-table-ref
1185           (wikidata-extensions info)
1186           (stream->symbol (stream-downcase tag)))
1187         text
1188         params
1189         info))
1190
1191      ; Detect break tags:
1192
1193      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
1194        (assert
1195          (and-let* ((ext (hash-table-ref/default
1196                            (wikidata-extensions info)
1197                            (stream->symbol (stream-downcase tag))
1198                            #f)))
1199            (extension-code-break ext)))
1200        ; Parameters
1201        (* (+ char-whitespace?)
1202           (bind name (all (or char-alphabetic? char-numeric?)))
1203           (all char-whitespace?)
1204           (? #\= (all char-whitespace?)
1205              (or (#\" (bind value (all (not #\"))) #\")
1206                  (#\' (bind value (all (not #\'))) #\')
1207                  ((bind value (all (or char-alphabetic? char-numeric?))))))
1208           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
1209        (all char-whitespace?) (? #\/) #\>)
1210
1211       (run-break-extension
1212         (hash-table-ref
1213           (wikidata-extensions info)
1214           (stream->symbol (stream-downcase tag)))
1215         params
1216         info))
1217
1218      ; Rule for normal paragraphs:
1219
1220      (((bind text (+all (not (or #\space #\newline #\> #\* #\# (#\= #\=))) (all (not #\newline)) (or #\newline ((end))))))
1221       (let ((text (parse-all text (lambda () (error "noparse" (stream->string (stream-reverse (stream-cdr text))))) (text-transform info #f #f #f #f #\space))))
1222         (if (stream-null? text)
1223           stream-null
1224           (wikidata-paragraph info text)))))))
1225
1226(define (accum-with-driver driver)
1227  (lambda (str . rest)
1228    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (extensions (make-hash-table)))
1229      (iterator->stream
1230        (lambda (collect stop)
1231          (stream-traverse
1232            (wiki-parse (driver collect) str tail name open include linktypes extensions)))))))
1233
1234(define wiki-links
1235  (accum-with-driver links-driver))
1236
1237(define wiki-tags
1238  (accum-with-driver tags-driver))
1239
1240; TODO: This is already broken: we need to split PROCEDURE into two procs, one
1241; to generate the file and another one to include it (which can get called even
1242; if the file does not need to be generated).
1243;
1244; data-output-func receives three arguments:
1245;
1246; - a STREAM with some representation of the contents that will get rendered to
1247; the file.  Or #f.
1248;
1249; - the MIME-TYPE (eg. "image/jpeg")
1250;
1251; - a PROCEDURE.
1252;
1253; If STREAM evaluates to true, it gets hashed and a filename (path) at some
1254; directory is created with the hash on it (only the filename, no actual file
1255; is created).  If STREAM is #f, a random path (in the same directory) is used.
1256; If data-output-func wants to allow the contents to be rendered, it calls the
1257; procedure and passes two arguments: the actual filename that should be
1258; generated and the URL where that filename can be loaded.  data-output-func
1259; returns whatever the procedure returned (or, if it doesn't want any file to
1260; be created, whatever stream it wants to display instead of the file).
1261;
1262; The caller should not assume that the file it specified was created, just
1263; assume that it may have been created.  There might have been problems that
1264; prevented the procedure from actually creating it.
1265;
1266; Alternatively, data-output-func may be just #f, in which case wiki->html will
1267; now that it is never allowed to create any files.
1268;
1269; This interface hasa the following advantages:
1270;
1271; 1. The caller to wiki->html can register all the files created as a result of
1272; the parsing.
1273;
1274; 2. The caller to wiki->html gets full control as to where the files are
1275; actually created.  It can even specify that no file should actually be
1276; created.
1277;
1278; 3. Extensions can render new files, they just need to be given access to
1279; data-output-func.
1280;
1281; 4. We reuse paths, since their names depend on the hash of the content being
1282; rendered.  That way, if some content doesn't change, wiki->html will always
1283; use the same filename for it.  While this isn't a *requirement*, it makes
1284; wiki->html generated directories/files play nice with mirror software such as
1285; the file-mirror egg (which would otherwise constantly have to reupload
1286; everything, since the paths would change).
1287;
1288; 5. The data-output-func is responsible for mapping the mime-type to the
1289; actual extension that should be used.  Which is good: wiki->html shouldn't be
1290; the one to do that (because it would require to make assumptions that may not
1291; always hold).
1292;
1293; The mime type passed is one of the following:
1294;
1295; - image/png
1296;
1297; For functions/extensions calling data-output-func, here are some guidelines:
1298;
1299; - Make sure the mime type you use is documented above.
1300;
1301; - Note that the actual pathname created will depend on the actual value of
1302; the stream (very likely be a md5 or sha1 hash of it).  You should make sure
1303; that the inputs from which your file depends are fully included in the
1304; stream.  Otherwise you could end up overwriting the file with a different
1305; one.   For that reason, your stream should always start with the name of the
1306; caller (such as "html-math") followed by a colon followed by the actual input
1307; used by that caller.  If you can't fully specify your inputs here, just use
1308; #f (but this practice is discouraged!).
1309;
1310; This interface should hopefully accomodate well the needs of extensions'
1311; creators.  I know that at some point it will break and we will need something
1312; else, but I hope quite a long time passes before that horrid day.
1313
1314(define (wiki->html str . rest)
1315  (stream-delay
1316    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (make-header (make-html-header)) (data-output-func (constantly stream-null)) (check-exists? (constantly #t)) (extensions (make-hash-table)) (url-adjust identity) (extension-args #f) (no-follow? (constantly #f)))
1317      (wiki-parse (html-driver make-header data-output-func check-exists? url-adjust no-follow?) str tail name open include linktypes extensions extension-args))))
1318
1319(define (wiki->text str . rest)
1320  (stream-delay
1321    (let-optionals rest ((human-readable #t) (tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (extensions (make-hash-table)) (extension-args #f))
1322      (wiki-parse (text-driver human-readable) str tail name open include linktypes extensions extension-args))))
1323
1324(define (wiki->latex str . rest)
1325  (stream-delay
1326    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (extensions (make-hash-table)) (class *latex-default-document-class*) (links-base identity) (extension-args #f))
1327      (wiki-parse (latex-driver class links-base) str tail name open include linktypes extensions extension-args))))
1328
1329(define (wiki-parse output str . rest)
1330  (assert (driver? output))
1331  (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (extensions (make-hash-table)) (extension-args #f))
1332    (parse-all str (lambda () (error "Syntax error")) (global-token output open include name linktypes extensions extension-args) tail)))
1333
1334;;; Linktypes
1335;
1336; Used for interwiki links and stuff.  For example, have [[google:something]]
1337; translate into a Google search for that keyword.
1338
1339; Load the linktypes specified in file into hash.  The file has the format
1340; NAME:CONTENT, where CONTENT is the wiki code we will replace the link with.
1341; CONTENT must have %t for the target and %n for the link's name.
1342;
1343; E.g.: google:[[http://www.google.com/search?hl=es&q=%t|%n]]
1344;
1345; All the linktypes are added to hash hash, indexed by their type.  The value
1346; is a stream where entries are either streams of characters (to be included
1347; literally) or characters for the escape sequences.
1348
1349(define (load-linktypes hash file)
1350  (with-input-from-file file
1351    (lambda ()
1352      (stream-for-each
1353        (lambda (line)
1354          (receive (name type)
1355                   (stream-break (cut char=? #\: <>) line)
1356            (unless (stream-null? type)
1357              (hash-table-set! hash
1358                (stream->symbol (stream-downcase name))
1359                (linktype-parse (stream-cdr type))))))
1360        (stream-remove
1361          (lambda (x) (or (stream-null? x) (char=? (stream-car x) #\#)))
1362          (stream-map
1363            (cut stream-drop-while char-whitespace? <>)
1364            (stream-lines (port->stream (current-input-port)))))))))
1365
1366(define (linktype-parse type)
1367  (receive (literal escape)
1368           (stream-break (cut char=? #\% <>) type)
1369    (if (stream-null? literal)
1370      (linktype-parse-escape escape)
1371      (stream-cons literal (linktype-parse-escape escape)))))
1372
1373(define (linktype-parse-escape escape)
1374  (if (or (stream-null? escape) (stream-null? (stream-cdr escape)))
1375    stream-null
1376    (stream-cons (stream-cadr escape) (linktype-parse (stream-cddr escape)))))
1377
1378(define (run-linktype lt)
1379  (lambda (info type dst name)
1380    (let* ((type-sym (stream->symbol (stream-downcase type)))
1381           (text (run-linktype-first lt dst name)))
1382      ; Avoid infinite recursion
1383      (if (member type-sym (wikidata-linktypes-current info))
1384        text
1385        (parse-all
1386          text
1387          (lambda ()
1388            (error "Internal error: Unable to parse" (stream->string text)))
1389          (text-transform
1390            (apply make-wikidata
1391                   (map
1392                     (lambda (f) (f info))
1393                     (list
1394                       wikidata-driver
1395                       wikidata-open
1396                       wikidata-include
1397                       wikidata-name
1398                       wikidata-linktypes
1399                       wikidata-extensions
1400                       wikidata-extension-args
1401                       wikidata-previous-sections
1402                       (lambda (o)
1403                         (cons type-sym (wikidata-linktypes-current o))))))
1404            #f #f #f #f #\newline)
1405          stream-null)))))
1406
1407(define (run-linktype-first lt dst name)
1408  (let ((votes (delay (vote-linktype (or name dst)))))
1409    (let loop ((lt lt))
1410      (stream-delay
1411        (if (stream-null? lt)
1412          stream-null
1413          (stream-append
1414            (if (stream? (stream-car lt))
1415              (stream-car lt)
1416              (case (stream-car lt)
1417                ((#\c) (number->stream (stream-length (force votes))))
1418                ((#\n) (or name dst))
1419                ((#\o) (stream-map char-downcase (or name dst)))
1420                ((#\t) dst)
1421                ((#\u) (stream-map char-downcase dst))
1422                ((#\v) (string->stream (format #f "~,2F" (votes-average (force votes) 0 0))))
1423                (else (error "Invalid escape sequence" (stream-car lt)))))
1424            (loop (stream-cdr lt))))))))
1425
1426(define (votes-average str total count)
1427  (cond
1428    ((not (stream-null? str)) (votes-average (stream-cdr str) (+ total (stream-car str)) (+ count 1)))
1429    ((zero? count) 0)
1430    (else (/ total count))))
1431
1432(define (vote-linktype str)
1433  (stream-filter identity (stream-map stream->number (stream-split str char-whitespace?))))
1434
1435;;
1436
1437(define (simple-tag-span-get name get-parser)
1438  (list name
1439        (let ((open  (stream-append (stream #\<) (symbol->stream name) (stream #\>)))
1440              (close (stream-append (stream #\< #\/) (symbol->stream name) (stream #\>))))
1441          (lambda (text params . args)
1442            (stream-append
1443              open
1444              (parse-all
1445                text
1446                (lambda () (error "bar"))
1447                (apply get-parser args)
1448                stream-null)
1449              close)))))
1450
1451(define (simple-tag-span name) (simple-tag-span-get name text-transform))
1452
1453(define (shell-escape path)
1454  (list->string
1455    (cons #\space
1456      (fold-right
1457        (lambda (c rest)
1458          (if (or (char-alphabetic? c) (char-numeric? c) (member c '(#\/ #\-)))
1459            (cons c rest)
1460            (cons* #\\ c rest)))
1461        '()
1462        (stream->list path)))))
1463
1464(define *tags-span*
1465  `(
1466    ,@(map simple-tag-span '(u i span small big b sup sub))))
1467
1468;;; Sections for wiki pages
1469
1470(define (recognize-start-wiki document)
1471  (receive (result rest new-fail parsed)
1472           (parse-token document (constantly #f #f #f #f) stream-null
1473             ((#\= #\= (bind depth (all #\=))
1474               (all char-blank?)
1475               (bind name (*? (not #\newline)))
1476               (all char-blank?)
1477               (? #\= #\= depth (all char-blank?))
1478               (or #\newline ((end))))
1479              (make-section (stream-length depth) name)))
1480    (if result
1481      (values result (stream-reverse parsed) rest)
1482      (take-one-line document))))
1483
1484(define (wiki->sections document)
1485  (document->sections recognize-start-wiki document))
1486
1487(define wiki->toc (compose sections->toc wiki->sections))
1488
1489;;; Extensions
1490
1491(define (load-extensions-from-file extensions file)
1492  (set! *extensions* '()) ; just in case.
1493  (load file)
1494  (when (null? *extensions*)
1495    (warning "Extension does not define anything!" file))
1496  (for-each
1497    (lambda (alist)
1498      (and (pair? alist)
1499           (not (null? alist))
1500           (hash-table-set! extensions (car alist) (alist->extension alist))))
1501    *extensions*))
1502
1503; TODO: This is bad, we shouldn't do this.  Ugh.  But we need some way
1504; to communicate with the code in the extensions.
1505
1506(define *extensions* '())
1507
1508(define (alist->extension alist)
1509  (make-extension (car alist) (cdr alist)))
1510
1511(define (extension-data ext data)
1512  (let ((value (assoc data (extension-table ext))))
1513    (and value
1514         (pair? (cdr value))
1515         (cadr value))))
1516
1517(define extension-code-span (cut extension-data <> 'code-span))
1518(define extension-code-break (cut extension-data <> 'code-break))
1519(define extension-update (cut extension-data <> 'update))
1520(define extension-files-actions-links (cut extension-data <> 'files-actions-links))
1521(define extension-toc-header (cut extension-data <> 'toc-header))
1522
1523(define (run-span-extension extension text params info)
1524  ((extension-code-span extension)
1525
1526   ; TODO: This really ought to be an environment.
1527
1528   (lambda (op)
1529     (case op
1530
1531       ((text) text)
1532       ((params) params)
1533
1534       ((parse)
1535        (lambda (str)
1536          (parse-all str
1537                     (lambda () (error "Syntax error"))
1538                     (global-token-info info)
1539                     stream-null)))
1540
1541       ; Function to parse some text as a paragraph.  Receives the text and an
1542       ; optional alist with properties corresponding to parameters for
1543       ; text-transform.
1544
1545       ((parse-paragraph)
1546        (lambda (text . rest)
1547          (let-optionals rest ((properties '()))
1548            (parse-all
1549              text
1550              (lambda () (error "bar"))
1551              (apply
1552                text-transform
1553                info
1554                (map (lambda (data)
1555                       (cadr (or (assoc (car data) properties) data)))
1556                     '((strong #f) (em #f) (literal #f) (start #f) (newline #\newline))))
1557              stream-null))))
1558
1559       ; This used to be deprecated but it really is needed by some
1560       ; format-dependant extensions.
1561
1562       ((output-format)
1563        (driver-output-format (wikidata-driver info)))
1564
1565       ((driver)
1566        (wikidata-driver info))
1567
1568       (else ((wikidata-extension-args info) op))))))
1569
1570(define (run-break-extension extension params info)
1571  ((extension-code-break extension)
1572   (lambda (op)
1573     (case op
1574       ((params) params)
1575       ((parse)
1576        (lambda (str)
1577          (parse-all str
1578                     (lambda () (error "Syntax error"))
1579                     (global-token-info info)
1580                     stream-null)))
1581
1582       ; Function to parse some text as a paragraph.  Receives the text and an
1583       ; optional alist with properties corresponding to parameters for
1584       ; text-transform.
1585
1586       ((parse-paragraph)
1587        (lambda (text . rest)
1588          (let-optionals rest ((properties '()))
1589            (parse-all
1590              text
1591              (lambda () (error "bar"))
1592              (apply
1593                text-transform
1594                info
1595                (map (lambda (data)
1596                       (cadr (or (assoc (car data) properties) data)))
1597                     '((strong #f) (em #f) (literal #f) (start #f) (newline #\newline))))
1598              stream-null))))
1599
1600       ; Deprecated.  The reason to deprecate it is that extensions shouldn't
1601       ; have to deal with having to recognize multiple formats ever.  They
1602       ; should really on the drivers for format-specific things.
1603       ;
1604       ; Why am I committing it if it is deprecated?  Because drivers still
1605       ; don't know about <table>, <tr>, <td> and <th>.  They ought to.  Once
1606       ; they do, the core-extension tags.scm won't need output-format so this
1607       ; whole thing will go away.
1608       ;
1609       ; Including this terribly nice comment, damn.
1610
1611       ((output-format) (driver-output-format (wikidata-driver info)))
1612
1613       ((driver) (wikidata-driver info))
1614
1615       (else
1616         (if (wikidata-extension-args info)
1617           ((wikidata-extension-args info) op)
1618           (warning "Requested environment object but environment is not defined~%" op)))))))
1619
1620;;; TEXI driver
1621
1622(define (wiki->texi str . rest)
1623  (stream-delay
1624    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) 
1625                         (include (lambda (name tail) tail)) (linktypes (make-hash-table)) 
1626                         (extensions (make-hash-table)) (extension-args #f))
1627     (let-values (((texi-nodes lookup-table) (texi-menu str)))
1628         (stream-append
1629          (->stream-char "@menu\n")
1630          texi-nodes
1631          (->stream-char "@end menu\n")
1632          (wiki-parse (texi-driver lookup-table) str
1633                      tail name open include linktypes extensions extension-args))))))
1634
1635(define (texi-page author title copyright first content . rest)
1636  (let-optionals rest ((subtitle #f) (month-year #f) (version #f))
1637    (stream-concatenate
1638      (stream-map
1639        ->stream-char
1640        (stream
1641          "\\input texinfo @c -*- texinfo -*-\n"
1642          (format #f "@settitle ~A\n" title)
1643          "@setchapternewpage on\n"
1644          (if month-year (format #f "@set month-year ~A\n" month-year) "")
1645          (if version (format #f "@set version ~A\n" version) "")
1646          "@copying\n"
1647          copyright
1648          "\n"
1649          "@end copying\n"
1650          "@titlepage\n"
1651          "@sp 10\n"
1652          (format #f "@title{~A}\n" title)
1653          (if subtitle (format #f "@subtitle{~A}\n" subtitle) "")
1654          (if version (format #f "@subtitle{Edition @value{version}}\n") "")
1655          (format #f "@author{~A}\n" author)
1656          "@comment  The following two commands start the copyright page.\n"
1657          "@page\n"
1658          "@vskip 0pt plus 1fill\n"
1659          copyright "\n"
1660          "@end titlepage\n"
1661          (format #f "@node Top, ~A, (dir), (dir)\n"  first)
1662          (format #f "@top ~A\n" title)
1663          (format #f "This is the top node.\n")
1664          content
1665          "\n"
1666          "@shortcontents\n"
1667          "@contents\n"
1668          "@bye\n")))))
1669
1670
1671
1672(define (texi-find-node lookup-table n up-node . rest)
1673  (let-optionals rest ((handler #f))
1674    (let ((name  (string->symbol (escape-texi-node-name n up-node))))
1675      (if handler
1676          (hash-table-ref lookup-table name handler)
1677          (hash-table-ref lookup-table name)))))
1678
1679(define (texi-wrap start end)
1680  (let ((real-start (string->stream start)) 
1681        (real-end (string->stream end)))
1682    (lambda (arg) 
1683      (stream-append real-start arg real-end))))
1684
1685(define (texi-escape-text dst)
1686  (stream-delay 
1687   (if (stream-null? dst)
1688       stream-null
1689       (case (stream-car dst)
1690         ((#\@) 
1691          (stream-cons* #\@ (stream-car dst) (texi-escape-text (stream-cdr dst))))
1692         (else (stream-cons (stream-car dst) (texi-escape-text (stream-cdr dst))))))))
1693
1694;; Look for a node starting at start-depth and checking at every level
1695;; between 0 and start-depth.
1696(define (texi-find-node-in-tree lookup-table n start-depth last-at-depth)
1697  (let ((name  (string-intersperse
1698                (string-tokenize n (char-set-complement (list->char-set (list #\#))))
1699                " - ")))
1700    (let loop ((depth start-depth))
1701      (if (positive? depth)
1702          (let* ((up-node  (vector-ref last-at-depth depth))
1703                 (node     (texi-find-node lookup-table name up-node
1704                                           (lambda () #f))))
1705            (or node  (loop (- depth 1))))
1706          (texi-find-node lookup-table name #f)))))
1707                         
1708;; If the stream has at least n elements, return a list containing
1709;; those elements, otherwise return #f
1710(define (stream->n-list strm n)
1711  (let loop ((strm strm) (i 0) (lst (list)))
1712    (if (stream-null? strm) 
1713        (if (= (+ 1 i) n) (list->string (reverse ax)) #f)
1714        (if (< i n) 
1715            (loop (stream-cdr strm) (+ 1 i) (cons (stream-car strm) lst))
1716            (list->string (reverse lst))))))
1717
1718(define (texi-unescape str)
1719  (stream-delay
1720    (if (stream-null? str) str
1721        (match (stream-car str)
1722          (#\@   (stream-cons (stream-cadr str) (texi-unescape (stream-cddr str))))
1723          (else  (stream-cons (stream-car str) (texi-unescape (stream-cdr str))))))))
1724
1725
1726(define (texi-driver lookup-table) 
1727  (let ((last-at-depth (make-vector 10 #f))
1728        (last-depth  0))
1729    (make-driver
1730     'texi
1731     ;; horizontal line
1732     ;; TODO: Implement!
1733     (constantly stream-null)
1734     ;; make header
1735     (lambda (name depth id)
1736       (let ((up-node (and (positive? depth) (vector-ref last-at-depth (- depth 1)))))
1737         (stream-append
1738          ;; print the @node and @menu.
1739          (string->stream 
1740           (let ((node (texi-find-node lookup-table (stream->string name) up-node)))
1741             (set! last-depth depth)
1742             (vector-set! last-at-depth depth node)
1743             (vector-set! last-at-depth (+ depth 1) #f)
1744             (let ((prologue (string-concatenate 
1745                              (list (case depth
1746                                      ((0)  "@chapter")
1747                                      ((1)  "@section")
1748                                      ((2)  "@subsection")
1749                                      (else "@subsubsection")) " "
1750                                      (stream->string name)))))
1751               (call-with-output-string
1752                (lambda (out) (print-node node out prologue))))))
1753          (stream #\newline #\newline))))
1754     ;; blockquote
1755     (texi-wrap "@quotation\n" "\n@end quotation\n")
1756     ;; center
1757     (texi-wrap "@center " "")
1758     ;; small
1759     (lambda (x)
1760       (error "Small not implemented yet in Texinfo mode."))
1761     ;; big
1762     (lambda (x)
1763       (error "Big not implemented yet in Texinfo mode."))
1764     ;; verbatim
1765     (lambda (arg) 
1766       (let ((start (string->stream "@verbatim\n")) 
1767             (end (string->stream "\n@end verbatim\n")))
1768      (stream-append start (texi-unescape arg) end)))
1769     ;; code
1770     (texi-wrap "@code{" "}")
1771     ;; paragraph
1772     (texi-wrap "" "\n\n")
1773     ;; strong
1774     (texi-wrap "@b{" "}")
1775     ;; emphasis
1776     (texi-wrap "@emph{" "}")
1777     ;; link
1778     (lambda (dst name)
1779       (let* ((link-external?  (url-external? dst))
1780              (link-email?     (let ((prefix (stream->n-list dst 7)))
1781                                 (and prefix (string=? prefix "mailto:" ))))
1782              (link            (if link-external? dst
1783                                   (texi-find-node-in-tree lookup-table (stream->string dst) 
1784                                                           last-depth last-at-depth))))
1785         (stream-append
1786          (string->stream (if link-external? "@uref{" "@ref{"))
1787          (if link-external? 
1788              (if link-email? (texi-escape-text dst)  dst)
1789              (string->stream (symbol->string (texi-node-name link))))
1790          (stream #\, #\space)
1791          (if link-external?
1792              (if link-email? (texi-escape-text name)  name)
1793              name)
1794          (stream #\}))))
1795     ;; image
1796     (lambda (dst name)
1797       (warning "Image not implemented in Texinfo mode.~%")
1798       (receive (type alt)
1799                (stream-break (cut char=? <> #\|) name)
1800                (stream->string (format #f "[[IMAGE:~A]]" (stream->string (or alt dst))))))
1801     ;; math
1802     (lambda (text)
1803       (string->stream (format #f "$$~A$$" (stream->string text))))
1804     ;; ordered list
1805     (texi-wrap "@enumerate\n" "\n@end enumerate\n")
1806     ;; bullets list
1807     (texi-wrap "@itemize\n" "\n@end itemize\n")
1808     ;; list item
1809     (texi-wrap "@item " "\n\n")
1810     ;; definition list
1811     (texi-wrap "@table @b\n" "\n@end table\n")
1812     ;; definition
1813     (lambda (term definition)
1814       (string->stream
1815        (format #f "@item ~A~%~%~A~%" (stream->string term) (stream->string definition))))
1816     ;; toc, gets discarded in texi files.
1817     (constantly stream-null)
1818     ;; special-character
1819     (lambda (x)
1820       (->stream-char
1821        (case x
1822          ((#\{ #\} #\@) (stream #\@ x))
1823          ((#\<) "<")
1824          ((#\>) ">")
1825          ((copyright) "(C)")
1826          ((reg) "(R)")
1827          ((left-arrow) "<-")
1828          ((right-arrow) "->")
1829          ((double-arrow) "<->")
1830          ((double-arrow-wide) "<=>")
1831          ((left-arrow-wide) "<=")
1832          ((right-arrow-wide) "=>")
1833          ((mdash) "---")
1834          ((ndash) "--")
1835          ((laquo) #\xab)
1836          ((raquo) #\xbb)
1837          (else (stream x)))))
1838     ;; tags
1839     (constantly stream-null)
1840     ;; comments
1841     (constantly stream-null)
1842     ;; line-break
1843     (constantly (stream #\\ #\\ ))
1844     ;; anchor
1845     (lambda (anchor text)
1846       (string->stream (format #f "@anchor{~A}" (stream->string text)))))))
1847
1848;;; Texi: menus, navigation, node relationships
1849
1850;; The current strategy is to do a pre-pass on the wiki-stream, and
1851;; build a lookup table of all the sections (which will become nodes
1852;; in the texi output). This table is passed as an argument when the
1853;; texi-driver is being created, and used in the TOC and Section
1854;; handlers to generate the appropriate navigational cues.
1855
1856;; This isn't very streamy code. :-) I'm sure we can make it more
1857;; consistent with the stream-wiki style once it's working correctly.
1858
1859;; Values in the lookup table are texi-node records. (Keys are
1860;; node-names.)
1861
1862(define-record texi-node name next prev up submenu depth)
1863
1864(define (print-node node out . rest)
1865  (let-optionals rest ((prologue #f))
1866  ;; print the @node line for the node, an optional prologue, and its
1867  ;; menu if any.
1868  (fprintf out "@node ~A, ~A, ~A, ~A~%"
1869           (texi-node-name node)
1870           (or (texi-node-next node) " ")
1871           (or (texi-node-prev node) " ")
1872           (let ((up-node (texi-node-up node)))
1873             (if up-node (texi-node-name up-node) "Top")))
1874  (when prologue
1875    (fprintf out "~A~%" prologue))
1876  (let ((sub (texi-node-submenu node)))
1877    (if sub
1878        (unless (null? sub)
1879          (fprintf out "~%@menu~%")
1880          (for-each (lambda (sub)
1881                      (fprintf out "* ~A::~%" sub))
1882                    (reverse sub))
1883          (fprintf out "~%@end menu~%"))))))
1884
1885(define-record-printer (texi-node node out)
1886  (print-node node out #f))
1887
1888(define (texi-name-parse str)
1889  (let loop ((mode? #t) (cmd? #f) (lst  (string->list str)) (ax (list)))
1890    (if (null? lst) (list->string (reverse ax))
1891        (match lst
1892               ((#\@ #\@ . rest)  (loop mode? cmd? rest (if mode? (cons #\@ ax) ax)))
1893               ((#\@ . rest)      (loop #f #t rest ax))
1894               ((#\{ . rest)      (loop (if (and cmd? (not mode?)) #t mode?) cmd? 
1895                                        rest ax))
1896               ((#\} . rest)      (loop mode? (not cmd?) rest ax))
1897               ((x . rest)        (loop mode? cmd? rest (if mode? (cons x ax) ax)))))))
1898
1899;; Assign compound names to sectional units inside sections, escape
1900;; periods, commas, colons and parentheses, and convert Texinfo
1901;; @cmd{str} forms to str in the resulting string.
1902(define (escape-texi-node-name s up)
1903  (let ((prefix  (if up (list (symbol->string (texi-node-name up))) (list))))
1904    (let ((n (string-intersperse (reverse (cons (texi-name-parse s) prefix)) " - ")))
1905      (string-translate* n '(("." . ";") ("," . ";") (":" . ";") ("(" . ";") (")" . ";"))))))
1906
1907(define (texi-menu str)
1908  (let ((lookup (make-hash-table)))
1909    (values ((accum-with-driver (texi-node-driver lookup)) str)
1910            lookup)))
1911
1912
1913(define (texi-node-driver lookup)
1914  (lambda (register)
1915    (let ((last-at-depth (make-vector 10 #f))
1916          (last-depth 0)
1917          (last-link #f))
1918      (vector-set! last-at-depth 0 (make-texi-node 'Top #f #f #f #f 0))
1919      (make-driver
1920       'texi-node
1921       (constantly stream-null)
1922       ;; make header
1923       (lambda (name depth id)
1924         (let* ((up-node    (and (positive? depth) (vector-ref last-at-depth (- depth 1))))
1925                (sym        (string->symbol (escape-texi-node-name (stream->string name) up-node)))
1926                (this-node  (make-texi-node sym #f #f up-node (list) depth)))
1927           (set! last-depth depth)
1928           ;; if a node by that name already exists, there are two
1929           ;; possibilities: there are two nodes of the same name in the
1930           ;; wiki document (which is an error) or a dummy node of that
1931           ;; name was created by a "Next/Previous" link (see below)
1932           (let ((l (hash-table-ref/default lookup sym #f)))
1933             (if (and l (texi-node-name l))
1934                 ;; Texinfo does not support two nodes with the same name
1935                 (error 'texi-node-driver "two nodes cannot have the same name" sym))
1936             ;; use the next/prev link in the dummy node, if it was created
1937             (and l (cond ((texi-node-prev l) (texi-node-prev-set! this-node (texi-node-prev l)))
1938                          ((texi-node-next l) (texi-node-next-set! this-node (texi-node-next l)))))
1939             ;; discard the dummy node and insert the real node in the table
1940             (hash-table-set! lookup sym this-node)
1941             (if (= 0 depth)
1942                 (stream-for-each register (string->stream (format #f "* ~A::\n" (texi-node-name this-node)))))
1943             (if up-node (texi-node-submenu-set! up-node (cons sym (texi-node-submenu up-node))))
1944             (let ((last-node (vector-ref last-at-depth depth)))
1945               (if last-node
1946                   (begin
1947                     (texi-node-next-set! last-node (texi-node-name this-node))
1948                     (texi-node-prev-set! this-node (texi-node-name last-node)))))
1949             (vector-set! last-at-depth depth this-node)
1950             (vector-set! last-at-depth (+ depth 1) #f)
1951             stream-null)))
1952
1953       ;; blockquote
1954       (constantly stream-null)
1955       ;; center
1956       identity
1957       ;; small
1958       identity
1959       ;; big
1960       identity
1961       ;; verbatim
1962       (constantly stream-null)
1963       ;; code
1964       identity
1965
1966       ;; paragraph
1967       ;; The text "Next: " or "Previous: ", followed by a link serves to
1968       ;; override the default prev/next nodes on level 0
1969       (lambda (x) 
1970         (cond ((and (<= 6 (stream-length x))
1971                     (string=? "Next: " (stream->string (stream-take x 6))))
1972                (let ((texi-last-node (vector-ref last-at-depth 0)))
1973                  (if (and texi-last-node last-link)
1974                      (let ((texi-next last-link))
1975                        (let ((texi-next-node (hash-table-ref/default lookup texi-next #f)))
1976                          (texi-node-prev-set! texi-last-node texi-next)
1977                          (if (not texi-next-node)
1978                              (let ((dummy-node (make-texi-node #f (texi-node-name texi-last-node) #f #f #f #f)))
1979                                (hash-table-set! lookup texi-next dummy-node))))))
1980                  stream-null))
1981               ((and (<= 10 (stream-length x))
1982                     (string=? "Previous: " (stream->string (stream-take x 10))))
1983                (let ((texi-last-node (vector-ref last-at-depth 0)))
1984                  (if (and texi-last-node last-link)
1985                      (let ((texi-prev last-link))
1986                        (let ((texi-prev-node (hash-table-ref/default lookup texi-prev #f)))
1987                          (texi-node-next-set! texi-last-node texi-prev)
1988                          (if (not texi-prev-node)
1989                              (let ((dummy-node (make-texi-node #f #f (texi-node-name texi-last-node) #f #f #f)))
1990                                (hash-table-set! lookup texi-prev dummy-node))))))
1991                  stream-null))
1992               
1993               (else (begin
1994                       (set! last-link #f)
1995                       stream-null))))
1996
1997       ;; strong
1998       identity
1999       ;; emphasis
2000       identity
2001       
2002       ;; link
2003       (constantly stream-null)
2004       
2005       (constantly stream-null)
2006       (constantly stream-null)
2007       (constantly stream-null) 
2008       (constantly stream-null)
2009       (constantly stream-null)
2010       (constantly stream-null)
2011       (constantly stream-null)
2012       ;; toc
2013       (constantly stream-null)
2014       ;; special-char
2015       (lambda (x)
2016         (->stream-char
2017          (case x
2018            ((#\@ #\{ #\}) (stream #\@ x))
2019            ((copyright) "(C)")
2020            ((reg) "(R)")
2021            ((left-arrow) "<-")
2022            ((right-arrow) "->")
2023            ((double-arrow) "<->")
2024            ((double-arrow-wide) "<=>")
2025            ((left-arrow-wide) "<=")
2026            ((right-arrow-wide) "=>")
2027            ((mdash) "---")
2028            ((ndash) "--")
2029            ((laquo) #\xab)
2030            ((raquo) #\xbb)
2031            (else (stream x)))))
2032       ;; tags
2033       (constantly stream-null)
2034       (constantly stream-null) 
2035       (constantly stream-null)
2036       ;; anchor
2037       (constantly stream-null)))))
2038
Note: See TracBrowser for help on using the repository browser.