source: project/release/3/stream-wiki/trunk/stream-wiki.scm @ 12650

Last change on this file since 12650 was 12650, checked in by azul, 13 years ago

implemented wiki-extension, to let an extension aggregate data.

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