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

Last change on this file since 12418 was 12418, checked in by azul, 11 years ago

Sandbox is not really needed anymore.

File size: 72.2 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 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}~%" 
632            (if (and class (member class *latex-document-classes*)) class *latex-default-document-class*) 
633            (if (and lang (member lang *latex-languages*)) lang "english"))
634    (stream-append content (string->stream "\n\\end{document}\n"))))
635
636(define (latex-environment name)
637  (latex-wrap (format #f "\\begin{~A}\n" name)
638              (format #f "\\end{~A}\n" name)))
639
640(define (latex-driver class links-base . rest)
641  (let-optionals rest ((include-in-toc (list 0 1 2 3 4))
642                       (newpage-after-section (list))
643                       )
644  (make-driver
645    'latex
646    ; horizontal line
647    (constantly stream-null)
648    ; make header
649    (let ((add (if (or (string=? class "book") (string=? class "report")) 0 1)))
650      (lambda (name depth id)
651        (stream-append
652          (let ((real-depth (+ depth add)))
653            (cond
654              ((zero? real-depth)
655               (string->stream "\\chapter{"))
656              ((<= real-depth 3)
657               (stream-append
658                 (if (member real-depth newpage-after-section) (string->stream "\\newpage\n") stream-null)
659                 (stream #\\ )
660                 (stream-concatenate (make-stream (- real-depth 1) (string->stream "sub")))
661                 (if (member real-depth include-in-toc) (string->stream "section{") (string->stream "section*{"))
662                 ))
663              (else
664                (string->stream "\\noindent \\textbf{"))))
665          (latex-text-parse name)
666          (stream #\} #\newline #\newline))))
667    ; blockquote
668    (latex-environment 'quote)
669    ; center
670    (latex-environment 'center)
671    ; small
672    (latex-environment 'small)
673    ; big
674    (latex-environment 'large)
675    ; literal
676    (latex-environment 'verbatim)
677    ; literal-line
678    (latex-wrap "\\verb|" "|")
679    ; paragraph
680    (latex-wrap "" "\n\n")
681    ; strong
682    (latex-wrap "\\textbf{" "}")
683    ; emphasis
684    (latex-wrap "\\textit{" "}")
685    ; link
686    (lambda (dst name)
687      (string->stream
688        (format #f "\\href{~A}{~A}"
689                (stream->string
690                  ((if (url-external? dst) identity links-base)
691                   (latex-text-parse dst)))
692                (stream->string (latex-text-parse name)))))
693    ; image
694    (lambda (dst name)
695      (warning "Image not implemented yet in LaTeX mode.~%")
696      (receive (type alt)
697               (stream-break (cut char=? <> #\|) name)
698        (string->stream (format #f "[[IMAGE:~A]]" (stream->string (or alt dst))))))
699    ; math
700    (lambda (text)
701      (string->stream (format #f "$$~A$$" (stream->string text))))
702    ; ordered list
703    (latex-environment 'enumerate)
704    ; bullets list
705    (latex-environment 'itemize)
706    ; list item
707    (latex-wrap "\\item " "\n\n")
708    ; definition list
709    (latex-environment 'description)
710    ; definition
711    (lambda (term definition)
712      (string->stream
713        (format #f "\\item[~A]~%~%~A~%" (stream->string term) (stream->string definition))))
714    ; toc
715    (lambda (info dst)
716      (if (stream-null? dst)
717        (string->stream "\\tableofcontents\n\n")
718        ; Can't get TOC of other documents yet:
719        stream-null))
720    ; special-character
721    (lambda (x)
722      (->stream-char
723        (case x
724          ((#\& #\$ #\{ #\} #\# #\_) (stream #\\ x))
725
726          ; Not much else we can do right now about quotation marks, is there?
727          ; We don't know if they are opening or closing quotation marks... :-/
728
729          ((#\\ #\") stream-null)
730
731          ((#\<) "<")
732          ((#\>) ">")
733          ((#\[) "\\[")
734          ((#\]) "\\]")
735          ((copyright) "(C)")
736          ((reg) "(R)")
737          ((left-arrow) "<-")
738          ((right-arrow) "->")
739          ((double-arrow) "<->")
740          ((double-arrow-wide) "<=>")
741          ((left-arrow-wide) "<=")
742          ((right-arrow-wide) "=>")
743          ((mdash) "---")
744          ((ndash) "--")
745          ((laquo) "<<")
746          ((raquo) ">>")
747          (else (string x)))))
748    ; tags
749    (constantly stream-null)
750    ; comments
751    (constantly stream-null)
752    (constantly (stream #\\ #\\ ))
753    ; anchor
754    ; TODO: I think LaTeX does support anchor, we should get them to work.
755    (constantly stream-null))))
756
757;;; Parsing
758
759(define (char-blank? x) (or (equal? x #\space) (equal? x #\tab)))
760
761; This is the parser for text that occurs inside a given set of
762; <p>, <pre>, <blockquote>, <li>, <dt> or <dd> tags.
763
764(define (text-transform info strong em literal start newline-rep)
765  (assert (wikidata? info))
766  (lambda (str fail parsed)
767    (parse-token str fail parsed
768
769      ; Cases for EOL.  If it is followed by a character, we want
770      ; to replace it with newline-rep (which is normally a space
771      ; but is a #\newline when we're inside a <pre> tag):
772
773      ((#\newline (assert newline-rep) (end)) stream-null)
774      ((#\newline (assert (and newline-rep start)) start) (stream newline-rep))
775      ((#\newline (assert (and newline-rep (not start)))) (stream newline-rep))
776
777      ; <strong> and <em>:
778
779      ((#\' #\' #\' (assert (not strong)) (bind text (*? (rule-apply (text-transform info #t em literal start newline-rep)))) #\' #\' #\')
780       (wikidata-strong info text))
781
782      ((#\' #\' (assert (not em)) (bind text (*? (rule-apply (text-transform info strong #t literal start newline-rep)))) #\' #\')
783       (wikidata-em info text))
784
785      ; Links: [ TYPE : ] DST [ | NAME ] (type and name are
786      ; optional).
787
788      ((#\[ #\[
789        (all char-whitespace?)
790        (? (bind type (*? (not (or #\[ #\: #\| #\] #\newline))))
791           (all char-whitespace?) #\: (all char-whitespace?))
792        (bind dst (*? (not (or #\[ #\| #\] #\newline))))
793        (all char-whitespace?)
794        (? #\| (all char-whitespace?)
795           (bind name (*? (rule-apply (text-transform info strong em literal start newline-rep))))
796           (all char-whitespace?))
797        #\] #\])
798       (make-link info
799         (if (stream-null? type) #f type)
800         dst
801         (if (stream-null? name) #f name)))
802
803      ; Typewritten text:
804
805      ((#\{ #\{ (bind text (*? char?)) #\} #\})
806       (wikidata-literal-line info
807         (parse-all text (lambda () (error "bar")) (text-transform info strong em #t start newline-rep) stream-null)))
808
809      ; Comments
810
811      ((#\< #\! (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?)
812        (bind text (*? char?))
813        (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?) #\>)
814       (wikidata-comment info text))
815
816      ; Span tags:
817
818      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
819        (assert
820          (and-let* ((ext (hash-table-ref/default
821                            (wikidata-extensions info)
822                            (stream->symbol (stream-downcase tag))
823                            #f)))
824            (extension-code-span ext)))
825        ; Parameters
826        (* (+ char-whitespace?)
827           (bind name (all char-alphabetic?))
828           (all char-whitespace?)
829           (? #\= (all char-whitespace?)
830              (or (#\" (bind value (all (not #\"))) #\")
831                  (#\' (bind value (all (not #\'))) #\')
832                  ((bind value (all (or char-alphabetic? char-numeric?))))))
833           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
834        (all char-whitespace?) #\>
835        (bind text (*? char?))
836        #\< (all char-whitespace?) #\/ tag (all char-whitespace?) #\>)
837
838       (run-span-extension
839         (hash-table-ref
840           (wikidata-extensions info)
841           (stream->symbol (stream-downcase tag)))
842         text
843         params
844         info))
845
846      ; Break tags:
847
848      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
849        (assert
850          (and-let* ((ext (hash-table-ref/default
851                            (wikidata-extensions info)
852                            (stream->symbol (stream-downcase tag))
853                            #f)))
854            (extension-code-break ext)))
855        ; Parameters
856        (* (+ char-whitespace?)
857           (bind name (all (or char-alphabetic? char-numeric?)))
858           (all char-whitespace?)
859           (? #\= (all char-whitespace?)
860              (or (#\" (bind value (all (not #\"))) #\")
861                  (#\' (bind value (all (not #\'))) #\')
862                  ((bind value (all (or char-alphabetic? char-numeric?))))))
863           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
864        (all char-whitespace?) (? #\/) (all char-whitespace?) #\>)
865       (run-break-extension
866         (hash-table-ref
867           (wikidata-extensions info)
868           (stream->symbol (stream-downcase tag)))
869         params
870         info))
871
872      ; Replace certain sequences with HTML entities, unless we are inside a
873      ; <pre>, <tt> or <code> tag.
874
875      ((#\< #\< (assert (not literal))) (wikidata-special-char info 'laquo))
876      ((#\> #\> (assert (not literal))) (wikidata-special-char info 'raquo))
877      ((#\( (or #\R #\r) #\) (assert (not literal))) (wikidata-special-char info 'reg))
878      ((#\( (or #\C #\c) #\) (assert (not literal))) (wikidata-special-char info 'copyright))
879      ((#\1 #\/ #\2 (assert (not literal))) (string->stream "&frac12;"))
880      ((#\1 #\/ #\4 (assert (not literal))) (string->stream "&frac14;"))
881      ((#\3 #\/ #\4 (assert (not literal))) (string->stream "&frac34;"))
882      ((#\< #\- #\> (assert (not literal))) (wikidata-special-char info 'double-arrow))
883      ((#\< #\- (assert (not literal))) (wikidata-special-char info 'left-arrow))
884      ((#\- #\> (assert (not literal))) (wikidata-special-char info 'right-arrow))
885      ((#\< #\= #\> (assert (not literal))) (wikidata-special-char info 'double-arrow-wide))
886      ((#\< #\= (assert (not literal))) (wikidata-special-char info 'left-arrow-wide))
887      ((#\= #\> (assert (not literal))) (wikidata-special-char info 'right-arrow-wide))
888      ((#\- #\- #\- (assert (not literal))) (wikidata-special-char info 'mdash))
889      ((#\- #\- (assert (not literal))) (wikidata-special-char info 'ndash))
890
891      ; Some entities that we don't want to include literally.
892
893      (((bind char special-char?))
894       (wikidata-special-char info (stream-car char)))
895
896      ; An email address:
897
898      (((bind initial (?? char?))
899        (bind email
900              char-alphabetic?
901              (all (or char-alphabetic? char-numeric? #\. #\- #\_ #\+))
902              #\@
903              (+
904                (or char-alphabetic? char-numeric?)
905                (* (or char-alphabetic? char-numeric? #\-))
906                (or char-alphabetic? char-numeric?)
907                #\.)
908              (or char-alphabetic? char-numeric?)
909              (* (or char-alphabetic? char-numeric? #\-))
910              (or char-alphabetic? char-numeric?)))
911       (stream-append
912         initial
913         (make-link info
914           (string->stream "mailto")
915           email
916           email)))
917
918      ; A URL:
919
920      (((bind initial (?? char?))
921        (bind type (all char-alphabetic?))
922        #\:
923        (assert (assoc (stream->symbol (stream-downcase type)) *allowed-url-schemes*))
924        (bind dst
925              #\/ #\/
926              (+
927                (or char-alphabetic? char-numeric?)
928                (* (or char-alphabetic? char-numeric? #\-))
929                (or char-alphabetic? char-numeric?)
930                #\.)
931              (or char-alphabetic? char-numeric?)
932              (* (or char-alphabetic? char-numeric? #\-))
933              (or char-alphabetic? char-numeric?)
934              ; Port
935              (? #\: (+ char-numeric?))
936              ; File or QUERY STRING or Anchor
937              (?
938                (or #\/ #\? #\#)
939                (?
940                  (* (or char-alphabetic? char-numeric? #\~ #\/ #\. #\? #\& #\# #\% #\= #\- #\_))
941                  ; The last character must not be a dot:
942                  (or char-alphabetic? char-numeric? #\~ #\/ #\? #\& #\# #\% #\= #\- #\_)))))
943       (stream-append initial (make-link info type dst #f)))
944
945      ; Normal text:
946
947      (((bind str
948              (not (or special-char? #\newline))
949              (all standard-char?)))
950       str))))
951
952(define (not-newline? x)
953  (not (char=? x #\newline)))
954
955(define *allowed-url-schemes*
956  '((http) (https) (ftp)))
957
958; Characters that should be handled by wikidata-special-char instead of
959; included verbatim.
960
961(define (special-char? x)
962  (case x
963    ((or #\# #\$ #\< #\> #\& #\_ #\\ #\" #\{ #\} #\@ #\[ #\] ) #t)
964    (else #f)))
965
966(define (standard-char? x)
967  (and (not (special-char? x))
968       (case x
969         ((#\newline #\' #\: #\| #\( #\space #\, #\. #\- #\=) #f)
970         (else #t))))
971
972(define (make-link info type dst name)
973  (assert (wikidata? info))
974  ((let ((type-sym (and type (stream->symbol (stream-downcase type)))))
975     (cond
976        ((not type-sym) make-default-link)
977        ((assoc type-sym *link-types*) => cadr)
978        ((hash-table-ref/default (wikidata-linktypes info) type-sym #f) => run-linktype)
979        (else make-default-link)))
980   info type dst name))
981
982(define (make-default-link info type dst name)
983  (assert (wikidata? info))
984  (let ((real-dst (if type (stream-append type (stream-cons #\: dst)) dst)))
985    (wikidata-link info real-dst (or name real-dst))))
986
987(define (make-link-image info type dst name)
988  (assert (wikidata? info))
989  (wikidata-image info dst (or name dst)))
990
991(define (register-link-tag info type dst name)
992  (assert (wikidata? info))
993  (wikidata-tags info (or name dst)))
994
995(define (make-link-include info type dst name)
996  (assert (wikidata? info))
997  ((wikidata-include info) (stream->string dst) stream-null))
998
999(define (make-link-toc info type dst name)
1000  (assert (wikidata? info))
1001  (wikidata-toc info info dst))
1002
1003(define (make-link-mailto info type dst name)
1004  (wikidata-link info (stream-append type (stream-cons #\: dst)) (or name dst)))
1005
1006(define *link-types*
1007  `((include ,make-link-include)
1008    (toc ,make-link-toc)
1009    (image ,make-link-image)
1010    (tags ,register-link-tag)
1011    (mailto ,make-link-mailto)))
1012
1013(define (list-transform info current)
1014  (assert (wikidata? info))
1015  (lambda (str fail parsed)
1016    (parse-token str fail parsed
1017      (((bind data
1018              current (all #\space) (bind list-item (or #\* #\#))
1019              (all (all #\space) (or #\* #\#))
1020              (? #\newline)
1021              (all (not (or #\* #\# #\newline))
1022                   (all (not #\newline))
1023                   (? #\newline))
1024              (all #\newline)
1025              (all
1026                current (all #\space) list-item
1027                (all (all #\space) (or #\* #\#))
1028                (? #\newline)
1029                (all (not (or #\* #\# #\newline))
1030                     (all (not #\newline))
1031                     (? #\newline))
1032                (all #\newline))))
1033       ((if (char=? (stream-car list-item) #\*)
1034          wikidata-unordered-list
1035          wikidata-ordered-list)
1036        info
1037        (parse-all data fail (list-transform info (stream-append current list-item)))))
1038      (((bind head
1039              (? current (all #\space)
1040                 (? #\newline)
1041                 (bind text
1042                       (all (not (or #\* #\# #\newline))
1043                            (all (not #\newline))
1044                            (? #\newline)))))
1045        (all #\newline)
1046        (bind tail
1047              (all current
1048                   (+all (all #\space) (or #\* #\#))
1049                   (all #\space)
1050                   (? #\newline)
1051                   (all (not (or #\* #\#))
1052                        (all (not #\newline))
1053                        (? #\newline))))
1054        (assert (not (and (stream-null? head) (stream-null? tail)))))
1055       (wikidata-list-item info
1056         (stream-append
1057           (if (stream-null? head)
1058             stream-null
1059             (parse-all
1060               (stream-reverse
1061                 (stream-drop-while
1062                   char-whitespace?
1063                   (stream-reverse text)))
1064               (lambda () (error "foo"))
1065               (text-transform info #f #f #f #f #\space)))
1066           (if (stream-null? tail)
1067             stream-null
1068             (parse-all tail fail (list-transform info current)))))))))
1069
1070(define (definition-list info)
1071  (assert (wikidata? info))
1072  (lambda (str fail parsed)
1073    (parse-token str fail parsed
1074      ((#\; (all char-whitespace?)
1075        (bind term (*? (rule-apply (text-transform info #f #f #f #f #f))))
1076        (? (all char-blank?) #\: (all char-blank?)
1077           (bind definition (*? (not #\: #\newline) (all standard-char?)))
1078           (all char-blank?))
1079        (+ (all char-blank?) (or #\newline ((end)))))
1080       (wikidata-definition-item
1081         info
1082         term
1083         (parse-all definition (lambda () (error "foo")) (text-transform info #f #f #f #f #\space)))))))
1084
1085(define (global-token output open include name linktypes extensions extensions-args)
1086  (assert (driver? output))
1087  (global-token-info (make-wikidata output open include name linktypes extensions extensions-args '() (make-hash-table))))
1088
1089; This is the global parser which gets called by wiki->html.  It
1090; splits the input in chunks of lines (corresponding to
1091; paragraphs, lists, quotes, etc.) that must be processed
1092; together.
1093
1094(define (global-token-info info)
1095  (assert (wikidata? info))
1096  (lambda (str fail parsed)
1097    (parse-token str fail parsed
1098
1099      ; Simple line break:
1100
1101      ((#\- #\- #\- #\- (all char-blank?)) (wikidata-horizontal-line info))
1102
1103      ; Get all headers.  The type of header depends on the number
1104      ; of #\= signs:
1105
1106      ((#\= (bind depth (+all #\=))
1107        (all char-blank?)
1108        (bind name (*? (not #\newline)))
1109        (all char-blank?)
1110        (? #\= depth (all char-blank?))
1111        (or #\newline ((end))))
1112       (wikidata-header
1113         info
1114         (parse-all
1115           name
1116           (lambda () (error "noparse" (stream->string name)))
1117           (text-transform info #f #f #f #f #\space))
1118         (min 5 (stream-length (stream-cdr depth)))
1119         (sections-accept-new-name! (wikidata-previous-sections info) name)))
1120
1121      ; Skip empty lines:
1122
1123      ((#\newline) stream-null)
1124
1125      ; Process <ul> or <ol> lists calling the list-transform
1126      ; parser:
1127
1128     (((bind lines
1129             (+ (+all (or #\# #\*) (all #\space))
1130                (? #\newline)
1131                (all (not (or #\* #\# #\newline (#\= #\=)))
1132                     (all (not #\newline))
1133                     (or #\newline ((end))))
1134                (all #\newline))))
1135      (parse-all lines (lambda () (error "list-transform failed to parse")) (list-transform info stream-null)))
1136
1137      ; Process definition lists with the definition-list parser:
1138
1139      (((bind lines (+ (rule-apply (definition-list info)))))
1140       (wikidata-definition-list info lines))
1141
1142      ; Get quoted text (lines starting with #\>) inside a pair of
1143      ; <blockquote> tags:
1144
1145      (((+all #\> (all (or #\space #\tab))
1146              (bind text (all (not #\newline)) (or #\newline ((end))))
1147              (bind-accum (result '()) cons text)))
1148       (wikidata-blockquote info
1149         (parse-all
1150           (stream-concatenate (list->stream (reverse result)))
1151           (lambda () (error "noparse" (stream->string (stream-reverse (stream-cdr text)))))
1152           (global-token-info info))))
1153
1154      ; Get literal text (lines starting with #\space) inside a
1155      ; pair of <pre> tags:
1156
1157      (((bind text (+ #\space (*? char?) (or #\newline ((end))))))
1158       (wikidata-literal info
1159         (parse-all (stream-cdr text) (lambda () (error "foo")) (text-transform info #f #f #t #\space #\newline))))
1160
1161      ; Comments
1162
1163      ((#\< #\! (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?)
1164        (bind text (*? char?))
1165        (all char-whitespace?) #\- (all char-whitespace?) #\- (all char-whitespace?) #\>)
1166       (wikidata-comment info text))
1167
1168      ; Detect span extensions:
1169
1170      ((#\< (all char-whitespace?) (bind tag (all (or char-alphabetic? char-numeric?)))
1171        (assert
1172          (and-let* ((ext (hash-table-ref/default
1173                            (wikidata-extensions info)
1174                            (stream->symbol (stream-downcase tag))
1175                            #f)))
1176            (extension-code-span ext)))
1177        ; Parameters
1178        (* (+ char-whitespace?)
1179           (bind name (all (or char-alphabetic? char-numeric?)))
1180           (all char-whitespace?)
1181           (? #\= (all char-whitespace?)
1182              (or (#\" (bind value (all (not #\"))) #\")
1183                  (#\' (bind value (all (not #\'))) #\')
1184                  ((bind value (all (or char-alphabetic? char-numeric?))))))
1185           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
1186        (all char-whitespace?) #\>
1187        (bind text (*? char?))
1188        #\< (all char-whitespace?) #\/ tag (all char-whitespace?) #\>)
1189
1190       ; *tags-span-external*
1191
1192       (run-span-extension
1193         (hash-table-ref
1194           (wikidata-extensions info)
1195           (stream->symbol (stream-downcase tag)))
1196         text
1197         params
1198         info))
1199
1200      ; Detect break tags:
1201
1202      ((#\< (all char-whitespace?) (bind tag (all char-alphabetic?))
1203        (assert
1204          (and-let* ((ext (hash-table-ref/default
1205                            (wikidata-extensions info)
1206                            (stream->symbol (stream-downcase tag))
1207                            #f)))
1208            (extension-code-break ext)))
1209        ; Parameters
1210        (* (+ char-whitespace?)
1211           (bind name (all (or char-alphabetic? char-numeric?)))
1212           (all char-whitespace?)
1213           (? #\= (all char-whitespace?)
1214              (or (#\" (bind value (all (not #\"))) #\")
1215                  (#\' (bind value (all (not #\'))) #\')
1216                  ((bind value (all (or char-alphabetic? char-numeric?))))))
1217           (bind-accum (params '()) cons (cons (stream->symbol (stream-downcase name)) value)))
1218        (all char-whitespace?) (? #\/) #\>)
1219
1220       (run-break-extension
1221         (hash-table-ref
1222           (wikidata-extensions info)
1223           (stream->symbol (stream-downcase tag)))
1224         params
1225         info))
1226
1227      ; Rule for normal paragraphs:
1228
1229      (((bind text (+all (not (or #\space #\newline #\> #\* #\# (#\= #\=))) (all (not #\newline)) (or #\newline ((end))))))
1230       (let ((text (parse-all text (lambda () (error "noparse" (stream->string (stream-reverse (stream-cdr text))))) (text-transform info #f #f #f #f #\space))))
1231         (if (stream-null? text)
1232           stream-null
1233           (wikidata-paragraph info text)))))))
1234
1235(define (accum-with-driver driver)
1236  (lambda (str . rest)
1237    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) (include (lambda (name tail) tail)) (linktypes (make-hash-table)) (extensions (make-hash-table)))
1238      (iterator->stream
1239        (lambda (collect stop)
1240          (stream-traverse
1241            (wiki-parse (driver collect) str tail name open include linktypes extensions)))))))
1242
1243(define wiki-links
1244  (accum-with-driver links-driver))
1245
1246(define wiki-tags
1247  (accum-with-driver tags-driver))
1248
1249; TODO: This is already broken: we need to split PROCEDURE into two procs, one
1250; to generate the file and another one to include it (which can get called even
1251; if the file does not need to be generated).
1252;
1253; data-output-func receives three arguments:
1254;
1255; - a STREAM with some representation of the contents that will get rendered to
1256; the file.  Or #f.
1257;
1258; - the MIME-TYPE (eg. "image/jpeg")
1259;
1260; - a PROCEDURE.
1261;
1262; If STREAM evaluates to true, it gets hashed and a filename (path) at some
1263; directory is created with the hash on it (only the filename, no actual file
1264; is created).  If STREAM is #f, a random path (in the same directory) is used.
1265; If data-output-func wants to allow the contents to be rendered, it calls the
1266; procedure and passes two arguments: the actual filename that should be
1267; generated and the URL where that filename can be loaded.  data-output-func
1268; returns whatever the procedure returned (or, if it doesn't want any file to
1269; be created, whatever stream it wants to display instead of the file).
1270;
1271; The caller should not assume that the file it specified was created, just
1272; assume that it may have been created.  There might have been problems that
1273; prevented the procedure from actually creating it.
1274;
1275; Alternatively, data-output-func may be just #f, in which case wiki->html will
1276; now that it is never allowed to create any files.
1277;
1278; This interface hasa the following advantages:
1279;
1280; 1. The caller to wiki->html can register all the files created as a result of
1281; the parsing.
1282;
1283; 2. The caller to wiki->html gets full control as to where the files are
1284; actually created.  It can even specify that no file should actually be
1285; created.
1286;
1287; 3. Extensions can render new files, they just need to be given access to
1288; data-output-func.
1289;
1290; 4. We reuse paths, since their names depend on the hash of the content being
1291; rendered.  That way, if some content doesn't change, wiki->html will always
1292; use the same filename for it.  While this isn't a *requirement*, it makes
1293; wiki->html generated directories/files play nice with mirror software such as
1294; the file-mirror egg (which would otherwise constantly have to reupload
1295; everything, since the paths would change).
1296;
1297; 5. The data-output-func is responsible for mapping the mime-type to the
1298; actual extension that should be used.  Which is good: wiki->html shouldn't be
1299; the one to do that (because it would require to make assumptions that may not
1300; always hold).
1301;
1302; The mime type passed is one of the following:
1303;
1304; - image/png
1305;
1306; For functions/extensions calling data-output-func, here are some guidelines:
1307;
1308; - Make sure the mime type you use is documented above.
1309;
1310; - Note that the actual pathname created will depend on the actual value of
1311; the stream (very likely be a md5 or sha1 hash of it).  You should make sure
1312; that the inputs from which your file depends are fully included in the
1313; stream.  Otherwise you could end up overwriting the file with a different
1314; one.   For that reason, your stream should always start with the name of the
1315; caller (such as "html-math") followed by a colon followed by the actual input
1316; used by that caller.  If you can't fully specify your inputs here, just use
1317; #f (but this practice is discouraged!).
1318;
1319; This interface should hopefully accomodate well the needs of extensions'
1320; creators.  I know that at some point it will break and we will need something
1321; else, but I hope quite a long time passes before that horrid day.
1322
1323(define (wiki->html str . rest)
1324  (stream-delay
1325    (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)))
1326      (wiki-parse (html-driver make-header data-output-func check-exists? url-adjust no-follow?) str tail name open include linktypes extensions extension-args))))
1327
1328(define (wiki->text str . rest)
1329  (stream-delay
1330    (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))
1331      (wiki-parse (text-driver human-readable) str tail name open include linktypes extensions extension-args))))
1332
1333(define (wiki->latex str . rest)
1334  (stream-delay
1335    (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) (include-in-toc (list 0 1 2 3 4)) (newpage-after-section (list)))
1336      (wiki-parse (latex-driver class links-base include-in-toc newpage-after-section )
1337                  str tail name open include linktypes extensions extension-args))))
1338
1339(define (wiki-parse output str . rest)
1340  (assert (driver? output))
1341  (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))
1342    (parse-all str (lambda () (error "Syntax error")) (global-token output open include name linktypes extensions extension-args) tail)))
1343
1344;;; Linktypes
1345;
1346; Used for interwiki links and stuff.  For example, have [[google:something]]
1347; translate into a Google search for that keyword.
1348
1349; Load the linktypes specified in file into hash.  The file has the format
1350; NAME:CONTENT, where CONTENT is the wiki code we will replace the link with.
1351; CONTENT must have %t for the target and %n for the link's name.
1352;
1353; E.g.: google:[[http://www.google.com/search?hl=es&q=%t|%n]]
1354;
1355; All the linktypes are added to hash hash, indexed by their type.  The value
1356; is a stream where entries are either streams of characters (to be included
1357; literally) or characters for the escape sequences.
1358
1359(define (load-linktypes hash file)
1360  (with-input-from-file file
1361    (lambda ()
1362      (stream-for-each
1363        (lambda (line)
1364          (receive (name type)
1365                   (stream-break (cut char=? #\: <>) line)
1366            (unless (stream-null? type)
1367              (hash-table-set! hash
1368                (stream->symbol (stream-downcase name))
1369                (linktype-parse (stream-cdr type))))))
1370        (stream-remove
1371          (lambda (x) (or (stream-null? x) (char=? (stream-car x) #\#)))
1372          (stream-map
1373            (cut stream-drop-while char-whitespace? <>)
1374            (stream-lines (port->stream (current-input-port)))))))))
1375
1376(define (linktype-parse type)
1377  (receive (literal escape)
1378           (stream-break (cut char=? #\% <>) type)
1379    (if (stream-null? literal)
1380      (linktype-parse-escape escape)
1381      (stream-cons literal (linktype-parse-escape escape)))))
1382
1383(define (linktype-parse-escape escape)
1384  (if (or (stream-null? escape) (stream-null? (stream-cdr escape)))
1385    stream-null
1386    (stream-cons (stream-cadr escape) (linktype-parse (stream-cddr escape)))))
1387
1388(define (run-linktype lt)
1389  (lambda (info type dst name)
1390    (let* ((type-sym (stream->symbol (stream-downcase type)))
1391           (text (run-linktype-first lt dst name)))
1392      ; Avoid infinite recursion
1393      (if (member type-sym (wikidata-linktypes-current info))
1394        text
1395        (parse-all
1396          text
1397          (lambda ()
1398            (error "Internal error: Unable to parse" (stream->string text)))
1399          (text-transform
1400            (apply make-wikidata
1401                   (map
1402                     (lambda (f) (f info))
1403                     (list
1404                       wikidata-driver
1405                       wikidata-open
1406                       wikidata-include
1407                       wikidata-name
1408                       wikidata-linktypes
1409                       wikidata-extensions
1410                       wikidata-extension-args
1411                       wikidata-previous-sections
1412                       (lambda (o)
1413                         (cons type-sym (wikidata-linktypes-current o))))))
1414            #f #f #f #f #\newline)
1415          stream-null)))))
1416
1417(define (run-linktype-first lt dst name)
1418  (let ((votes (delay (vote-linktype (or name dst)))))
1419    (let loop ((lt lt))
1420      (stream-delay
1421        (if (stream-null? lt)
1422          stream-null
1423          (stream-append
1424            (if (stream? (stream-car lt))
1425              (stream-car lt)
1426              (case (stream-car lt)
1427                ((#\c) (number->stream (stream-length (force votes))))
1428                ((#\n) (or name dst))
1429                ((#\o) (stream-map char-downcase (or name dst)))
1430                ((#\t) dst)
1431                ((#\u) (stream-map char-downcase dst))
1432                ((#\v) (string->stream (format #f "~,2F" (votes-average (force votes) 0 0))))
1433                (else (error "Invalid escape sequence" (stream-car lt)))))
1434            (loop (stream-cdr lt))))))))
1435
1436(define (votes-average str total count)
1437  (cond
1438    ((not (stream-null? str)) (votes-average (stream-cdr str) (+ total (stream-car str)) (+ count 1)))
1439    ((zero? count) 0)
1440    (else (/ total count))))
1441
1442(define (vote-linktype str)
1443  (stream-filter identity (stream-map stream->number (stream-split str char-whitespace?))))
1444
1445;;
1446
1447(define (simple-tag-span-get name get-parser)
1448  (list name
1449        (let ((open  (stream-append (stream #\<) (symbol->stream name) (stream #\>)))
1450              (close (stream-append (stream #\< #\/) (symbol->stream name) (stream #\>))))
1451          (lambda (text params . args)
1452            (stream-append
1453              open
1454              (parse-all
1455                text
1456                (lambda () (error "bar"))
1457                (apply get-parser args)
1458                stream-null)
1459              close)))))
1460
1461(define (simple-tag-span name) (simple-tag-span-get name text-transform))
1462
1463(define (shell-escape path)
1464  (list->string
1465    (cons #\space
1466      (fold-right
1467        (lambda (c rest)
1468          (if (or (char-alphabetic? c) (char-numeric? c) (member c '(#\/ #\-)))
1469            (cons c rest)
1470            (cons* #\\ c rest)))
1471        '()
1472        (stream->list path)))))
1473
1474(define *tags-span*
1475  `(
1476    ,@(map simple-tag-span '(u i span small big b sup sub))))
1477
1478;;; Sections for wiki pages
1479
1480(define (recognize-start-wiki document)
1481  (receive (result rest new-fail parsed)
1482           (parse-token document (constantly #f #f #f #f) stream-null
1483             ((#\= #\= (bind depth (all #\=))
1484               (all char-blank?)
1485               (bind name (*? (not #\newline)))
1486               (all char-blank?)
1487               (? #\= #\= depth (all char-blank?))
1488               (or #\newline ((end))))
1489              (make-section (stream-length depth) name)))
1490    (if result
1491      (values result (stream-reverse parsed) rest)
1492      (take-one-line document))))
1493
1494(define (wiki->sections document)
1495  (document->sections recognize-start-wiki document))
1496
1497(define wiki->toc (compose sections->toc wiki->sections))
1498
1499;;; Extensions
1500
1501(define (load-extensions-from-file extensions file)
1502  (set! *extensions* '()) ; just in case.
1503  (load file)
1504  (when (null? *extensions*)
1505    (warning "Extension does not define anything!" file))
1506  (for-each
1507    (lambda (alist)
1508      (and (pair? alist)
1509           (not (null? alist))
1510           (hash-table-set! extensions (car alist) (alist->extension alist))))
1511    *extensions*))
1512
1513; TODO: This is bad, we shouldn't do this.  Ugh.  But we need some way
1514; to communicate with the code in the extensions.
1515
1516(define *extensions* '())
1517
1518(define (alist->extension alist)
1519  (make-extension (car alist) (cdr alist)))
1520
1521(define (extension-data ext data)
1522  (let ((value (assoc data (extension-table ext))))
1523    (and value
1524         (pair? (cdr value))
1525         (cadr value))))
1526
1527(define extension-code-span (cut extension-data <> 'code-span))
1528(define extension-code-break (cut extension-data <> 'code-break))
1529(define extension-update (cut extension-data <> 'update))
1530(define extension-files-actions-links (cut extension-data <> 'files-actions-links))
1531(define extension-toc-header (cut extension-data <> 'toc-header))
1532
1533(define (run-span-extension extension text params info)
1534  ((extension-code-span extension)
1535
1536   ; TODO: This really ought to be an environment.
1537
1538   (lambda (op)
1539     (case op
1540
1541       ((text) text)
1542       ((params) params)
1543
1544       ((parse)
1545        (lambda (str)
1546          (parse-all str
1547                     (lambda () (error "Syntax error"))
1548                     (global-token-info info)
1549                     stream-null)))
1550
1551       ; Function to parse some text as a paragraph.  Receives the text and an
1552       ; optional alist with properties corresponding to parameters for
1553       ; text-transform.
1554
1555       ((parse-paragraph)
1556        (lambda (text . rest)
1557          (let-optionals rest ((properties '()))
1558            (parse-all
1559              text
1560              (lambda () (error "bar"))
1561              (apply
1562                text-transform
1563                info
1564                (map (lambda (data)
1565                       (cadr (or (assoc (car data) properties) data)))
1566                     '((strong #f) (em #f) (literal #f) (start #f) (newline #\newline))))
1567              stream-null))))
1568
1569       ; This used to be deprecated but it really is needed by some
1570       ; format-dependant extensions.
1571
1572       ((output-format)
1573        (driver-output-format (wikidata-driver info)))
1574
1575       ((driver)
1576        (wikidata-driver info))
1577
1578       (else ((wikidata-extension-args info) op))))))
1579
1580(define (run-break-extension extension params info)
1581  ((extension-code-break extension)
1582   (lambda (op)
1583     (case op
1584       ((params) params)
1585       ((parse)
1586        (lambda (str)
1587          (parse-all str
1588                     (lambda () (error "Syntax error"))
1589                     (global-token-info info)
1590                     stream-null)))
1591
1592       ; Function to parse some text as a paragraph.  Receives the text and an
1593       ; optional alist with properties corresponding to parameters for
1594       ; text-transform.
1595
1596       ((parse-paragraph)
1597        (lambda (text . rest)
1598          (let-optionals rest ((properties '()))
1599            (parse-all
1600              text
1601              (lambda () (error "bar"))
1602              (apply
1603                text-transform
1604                info
1605                (map (lambda (data)
1606                       (cadr (or (assoc (car data) properties) data)))
1607                     '((strong #f) (em #f) (literal #f) (start #f) (newline #\newline))))
1608              stream-null))))
1609
1610       ; Deprecated.  The reason to deprecate it is that extensions shouldn't
1611       ; have to deal with having to recognize multiple formats ever.  They
1612       ; should really on the drivers for format-specific things.
1613       ;
1614       ; Why am I committing it if it is deprecated?  Because drivers still
1615       ; don't know about <table>, <tr>, <td> and <th>.  They ought to.  Once
1616       ; they do, the core-extension tags.scm won't need output-format so this
1617       ; whole thing will go away.
1618       ;
1619       ; Including this terribly nice comment, damn.
1620
1621       ((output-format) (driver-output-format (wikidata-driver info)))
1622
1623       ((driver) (wikidata-driver info))
1624
1625       (else
1626         (if (wikidata-extension-args info)
1627           ((wikidata-extension-args info) op)
1628           (warning "Requested environment object but environment is not defined~%" op)))))))
1629
1630;;; TEXI driver
1631
1632(define (wiki->texi str . rest)
1633  (stream-delay
1634    (let-optionals rest ((tail stream-null) (name "") (open (constantly stream-null)) 
1635                         (include (lambda (name tail) tail)) (linktypes (make-hash-table)) 
1636                         (extensions (make-hash-table)) (extension-args #f))
1637     (let-values (((texi-nodes lookup-table) (texi-menu str)))
1638         (stream-append
1639          (->stream-char "@menu\n")
1640          texi-nodes
1641          (->stream-char "@end menu\n")
1642          (wiki-parse (texi-driver lookup-table) str
1643                      tail name open include linktypes extensions extension-args))))))
1644
1645(define (texi-page author title copyright first content . rest)
1646  (let-optionals rest ((subtitle #f) (month-year #f) (version #f))
1647    (stream-concatenate
1648      (stream-map
1649        ->stream-char
1650        (stream
1651          "\\input texinfo @c -*- texinfo -*-\n"
1652          (format #f "@settitle ~A\n" title)
1653          "@setchapternewpage on\n"
1654          (if month-year (format #f "@set month-year ~A\n" month-year) "")
1655          (if version (format #f "@set version ~A\n" version) "")
1656          "@copying\n"
1657          copyright
1658          "\n"
1659          "@end copying\n"
1660          "@titlepage\n"
1661          "@sp 10\n"
1662          (format #f "@title{~A}\n" title)
1663          (if subtitle (format #f "@subtitle{~A}\n" subtitle) "")
1664          (if version (format #f "@subtitle{Edition @value{version}}\n") "")
1665          (format #f "@author{~A}\n" author)
1666          "@comment  The following two commands start the copyright page.\n"
1667          "@page\n"
1668          "@vskip 0pt plus 1fill\n"
1669          copyright "\n"
1670          "@end titlepage\n"
1671          (format #f "@node Top, ~A, (dir), (dir)\n"  first)
1672          (format #f "@top ~A\n" title)
1673          (format #f "This is the top node.\n")
1674          content
1675          "\n"
1676          "@shortcontents\n"
1677          "@contents\n"
1678          "@bye\n")))))
1679
1680
1681
1682(define (texi-find-node lookup-table n up-node . rest)
1683  (let-optionals rest ((handler #f))
1684    (let ((name  (string->symbol (escape-texi-node-name n up-node))))
1685      (if handler
1686          (hash-table-ref lookup-table name handler)
1687          (hash-table-ref lookup-table name)))))
1688
1689(define (texi-wrap start end)
1690  (let ((real-start (string->stream start)) 
1691        (real-end (string->stream end)))
1692    (lambda (arg) 
1693      (stream-append real-start arg real-end))))
1694
1695(define (texi-escape-text dst)
1696  (stream-delay 
1697   (if (stream-null? dst)
1698       stream-null
1699       (case (stream-car dst)
1700         ((#\@) 
1701          (stream-cons* #\@ (stream-car dst) (texi-escape-text (stream-cdr dst))))
1702         (else (stream-cons (stream-car dst) (texi-escape-text (stream-cdr dst))))))))
1703
1704;; Look for a node starting at start-depth and checking at every level
1705;; between 0 and start-depth.
1706(define (texi-find-node-in-tree lookup-table n start-depth last-at-depth)
1707  (let ((name  (string-intersperse
1708                (string-tokenize n (char-set-complement (list->char-set (list #\#))))
1709                " - ")))
1710    (let loop ((depth start-depth))
1711      (if (positive? depth)
1712          (let* ((up-node  (vector-ref last-at-depth depth))
1713                 (node     (texi-find-node lookup-table name up-node
1714                                           (lambda () #f))))
1715            (or node  (loop (- depth 1))))
1716          (texi-find-node lookup-table name #f)))))
1717                         
1718;; If the stream has at least n elements, return a list containing
1719;; those elements, otherwise return #f
1720(define (stream->n-list strm n)
1721  (let loop ((strm strm) (i 0) (lst (list)))
1722    (if (stream-null? strm) 
1723        (if (= (+ 1 i) n) (list->string (reverse ax)) #f)
1724        (if (< i n) 
1725            (loop (stream-cdr strm) (+ 1 i) (cons (stream-car strm) lst))
1726            (list->string (reverse lst))))))
1727
1728(define (texi-unescape str)
1729  (stream-delay
1730    (if (stream-null? str) str
1731        (match (stream-car str)
1732          (#\@   (stream-cons (stream-cadr str) (texi-unescape (stream-cddr str))))
1733          (else  (stream-cons (stream-car str) (texi-unescape (stream-cdr str))))))))
1734
1735
1736(define (texi-driver lookup-table) 
1737  (let ((last-at-depth (make-vector 10 #f))
1738        (last-depth  0))
1739    (make-driver
1740     'texi
1741     ;; horizontal line
1742     ;; TODO: Implement!
1743     (constantly stream-null)
1744     ;; make header
1745     (lambda (name depth id)
1746       (let ((up-node (and (positive? depth) (vector-ref last-at-depth (- depth 1)))))
1747         (stream-append
1748          ;; print the @node and @menu.
1749          (string->stream 
1750           (let ((node (texi-find-node lookup-table (stream->string name) up-node)))
1751             (set! last-depth depth)
1752             (vector-set! last-at-depth depth node)
1753             (vector-set! last-at-depth (+ depth 1) #f)
1754             (let ((prologue (string-concatenate 
1755                              (list (case depth
1756                                      ((0)  "@chapter")
1757                                      ((1)  "@section")
1758                                      ((2)  "@subsection")
1759                                      (else "@subsubsection")) " "
1760                                      (stream->string name)))))
1761               (call-with-output-string
1762                (lambda (out) (print-node node out prologue))))))
1763          (stream #\newline #\newline))))
1764     ;; blockquote
1765     (texi-wrap "@quotation\n" "\n@end quotation\n")
1766     ;; center
1767     (texi-wrap "@center " "")
1768     ;; small
1769     (lambda (x)
1770       (error "Small not implemented yet in Texinfo mode."))
1771     ;; big
1772     (lambda (x)
1773       (error "Big not implemented yet in Texinfo mode."))
1774     ;; verbatim
1775     (lambda (arg) 
1776       (let ((start (string->stream "@verbatim\n")) 
1777             (end (string->stream "\n@end verbatim\n")))
1778      (stream-append start (texi-unescape arg) end)))
1779     ;; code
1780     (texi-wrap "@code{" "}")
1781     ;; paragraph
1782     (texi-wrap "" "\n\n")
1783     ;; strong
1784     (texi-wrap "@b{" "}")
1785     ;; emphasis
1786     (texi-wrap "@emph{" "}")
1787     ;; link
1788     (lambda (dst name)
1789       (let* ((link-external?  (url-external? dst))
1790              (link-email?     (let ((prefix (stream->n-list dst 7)))
1791                                 (and prefix (string=? prefix "mailto:" ))))
1792              (link            (if link-external? dst
1793                                   (texi-find-node-in-tree lookup-table (stream->string dst) 
1794                                                           last-depth last-at-depth))))
1795         (stream-append
1796          (string->stream (if link-external? "@uref{" "@ref{"))
1797          (if link-external? 
1798              (if link-email? (texi-escape-text dst)  dst)
1799              (string->stream (symbol->string (texi-node-name link))))
1800          (stream #\, #\space)
1801          (if link-external?
1802              (if link-email? (texi-escape-text name)  name)
1803              name)
1804          (stream #\}))))
1805     ;; image
1806     (lambda (dst name)
1807       (warning "Image not implemented in Texinfo mode.~%")
1808       (receive (type alt)
1809                (stream-break (cut char=? <> #\|) name)
1810                (stream->string (format #f "[[IMAGE:~A]]" (stream->string (or alt dst))))))
1811     ;; math
1812     (lambda (text)
1813       (string->stream (format #f "$$~A$$" (stream->string text))))
1814     ;; ordered list
1815     (texi-wrap "@enumerate\n" "\n@end enumerate\n")
1816     ;; bullets list
1817     (texi-wrap "@itemize\n" "\n@end itemize\n")
1818     ;; list item
1819     (texi-wrap "@item " "\n\n")
1820     ;; definition list
1821     (texi-wrap "@table @b\n" "\n@end table\n")
1822     ;; definition
1823     (lambda (term definition)
1824       (string->stream
1825        (format #f "@item ~A~%~%~A~%" (stream->string term) (stream->string definition))))
1826     ;; toc, gets discarded in texi files.
1827     (constantly stream-null)
1828     ;; special-character
1829     (lambda (x)
1830       (->stream-char
1831        (case x
1832          ((#\{ #\} #\@) (stream #\@ x))
1833          ((#\<) "<")
1834          ((#\>) ">")
1835          ((copyright) "(C)")
1836          ((reg) "(R)")
1837          ((left-arrow) "<-")
1838          ((right-arrow) "->")
1839          ((double-arrow) "<->")
1840          ((double-arrow-wide) "<=>")
1841          ((left-arrow-wide) "<=")
1842          ((right-arrow-wide) "=>")
1843          ((mdash) "---")
1844          ((ndash) "--")
1845          ((laquo) #\xab)
1846          ((raquo) #\xbb)
1847          (else (stream x)))))
1848     ;; tags
1849     (constantly stream-null)
1850     ;; comments
1851     (constantly stream-null)
1852     ;; line-break
1853     (constantly (stream #\\ #\\ ))
1854     ;; anchor
1855     (lambda (anchor text)
1856       (string->stream (format #f "@anchor{~A}" (stream->string text)))))))
1857
1858;;; Texi: menus, navigation, node relationships
1859
1860;; The current strategy is to do a pre-pass on the wiki-stream, and
1861;; build a lookup table of all the sections (which will become nodes
1862;; in the texi output). This table is passed as an argument when the
1863;; texi-driver is being created, and used in the TOC and Section
1864;; handlers to generate the appropriate navigational cues.
1865
1866;; This isn't very streamy code. :-) I'm sure we can make it more
1867;; consistent with the stream-wiki style once it's working correctly.
1868
1869;; Values in the lookup table are texi-node records. (Keys are
1870;; node-names.)
1871
1872(define-record texi-node name next prev up submenu depth)
1873
1874(define (print-node node out . rest)
1875  (let-optionals rest ((prologue #f))
1876  ;; print the @node line for the node, an optional prologue, and its
1877  ;; menu if any.
1878  (fprintf out "@node ~A, ~A, ~A, ~A~%"
1879           (texi-node-name node)
1880           (or (texi-node-next node) " ")
1881           (or (texi-node-prev node) " ")
1882           (let ((up-node (texi-node-up node)))
1883             (if up-node (texi-node-name up-node) "Top")))
1884  (when prologue
1885    (fprintf out "~A~%" prologue))
1886  (let ((sub (texi-node-submenu node)))
1887    (if sub
1888        (unless (null? sub)
1889          (fprintf out "~%@menu~%")
1890          (for-each (lambda (sub)
1891                      (fprintf out "* ~A::~%" sub))
1892                    (reverse sub))
1893          (fprintf out "~%@end menu~%"))))))
1894
1895(define-record-printer (texi-node node out)
1896  (print-node node out #f))
1897
1898(define (texi-name-parse str)
1899  (let loop ((mode? #t) (cmd? #f) (lst  (string->list str)) (ax (list)))
1900    (if (null? lst) (list->string (reverse ax))
1901        (match lst
1902               ((#\@ #\@ . rest)  (loop mode? cmd? rest (if mode? (cons #\@ ax) ax)))
1903               ((#\@ . rest)      (loop #f #t rest ax))
1904               ((#\{ . rest)      (loop (if (and cmd? (not mode?)) #t mode?) cmd? 
1905                                        rest ax))
1906               ((#\} . rest)      (loop mode? (not cmd?) rest ax))
1907               ((x . rest)        (loop mode? cmd? rest (if mode? (cons x ax) ax)))))))
1908
1909;; Assign compound names to sectional units inside sections, escape
1910;; periods, commas, colons and parentheses, and convert Texinfo
1911;; @cmd{str} forms to str in the resulting string.
1912(define (escape-texi-node-name s up)
1913  (let ((prefix  (if up (list (symbol->string (texi-node-name up))) (list))))
1914    (let ((n (string-intersperse (reverse (cons (texi-name-parse s) prefix)) " - ")))
1915      (string-translate* n '(("." . ";") ("," . ";") (":" . ";") ("(" . ";") (")" . ";"))))))
1916
1917(define (texi-menu str)
1918  (let ((lookup (make-hash-table)))
1919    (values ((accum-with-driver (texi-node-driver lookup)) str)
1920            lookup)))
1921
1922
1923(define (texi-node-driver lookup)
1924  (lambda (register)
1925    (let ((last-at-depth (make-vector 10 #f))
1926          (last-depth 0)
1927          (last-link #f))
1928      (vector-set! last-at-depth 0 (make-texi-node 'Top #f #f #f #f 0))
1929      (make-driver
1930       'texi-node
1931       (constantly stream-null)
1932       ;; make header
1933       (lambda (name depth id)
1934         (let* ((up-node    (and (positive? depth) (vector-ref last-at-depth (- depth 1))))
1935                (sym        (string->symbol (escape-texi-node-name (stream->string name) up-node)))
1936                (this-node  (make-texi-node sym #f #f up-node (list) depth)))
1937           (set! last-depth depth)
1938           ;; if a node by that name already exists, there are two
1939           ;; possibilities: there are two nodes of the same name in the
1940           ;; wiki document (which is an error) or a dummy node of that
1941           ;; name was created by a "Next/Previous" link (see below)
1942           (let ((l (hash-table-ref/default lookup sym #f)))
1943             (if (and l (texi-node-name l))
1944                 ;; Texinfo does not support two nodes with the same name
1945                 (error 'texi-node-driver "two nodes cannot have the same name" sym))
1946             ;; use the next/prev link in the dummy node, if it was created
1947             (and l (cond ((texi-node-prev l) (texi-node-prev-set! this-node (texi-node-prev l)))
1948                          ((texi-node-next l) (texi-node-next-set! this-node (texi-node-next l)))))
1949             ;; discard the dummy node and insert the real node in the table
1950             (hash-table-set! lookup sym this-node)
1951             (if (= 0 depth)
1952                 (stream-for-each register (string->stream (format #f "* ~A::\n" (texi-node-name this-node)))))
1953             (if up-node (texi-node-submenu-set! up-node (cons sym (texi-node-submenu up-node))))
1954             (let ((last-node (vector-ref last-at-depth depth)))
1955               (if last-node
1956                   (begin
1957                     (texi-node-next-set! last-node (texi-node-name this-node))
1958                     (texi-node-prev-set! this-node (texi-node-name last-node)))))
1959             (vector-set! last-at-depth depth this-node)
1960             (vector-set! last-at-depth (+ depth 1) #f)
1961             stream-null)))
1962
1963       ;; blockquote
1964       (constantly stream-null)
1965       ;; center
1966       identity
1967       ;; small
1968       identity
1969       ;; big
1970       identity
1971       ;; verbatim
1972       (constantly stream-null)
1973       ;; code
1974       identity
1975
1976       ;; paragraph
1977       ;; The text "Next: " or "Previous: ", followed by a link serves to
1978       ;; override the default prev/next nodes on level 0
1979       (lambda (x) 
1980         (cond ((and (<= 6 (stream-length x))
1981                     (string=? "Next: " (stream->string (stream-take x 6))))
1982                (let ((texi-last-node (vector-ref last-at-depth 0)))
1983                  (if (and texi-last-node last-link)
1984                      (let ((texi-next last-link))
1985                        (let ((texi-next-node (hash-table-ref/default lookup texi-next #f)))
1986                          (texi-node-prev-set! texi-last-node texi-next)
1987                          (if (not texi-next-node)
1988                              (let ((dummy-node (make-texi-node #f (texi-node-name texi-last-node) #f #f #f #f)))
1989                                (hash-table-set! lookup texi-next dummy-node))))))
1990                  stream-null))
1991               ((and (<= 10 (stream-length x))
1992                     (string=? "Previous: " (stream->string (stream-take x 10))))
1993                (let ((texi-last-node (vector-ref last-at-depth 0)))
1994                  (if (and texi-last-node last-link)
1995                      (let ((texi-prev last-link))
1996                        (let ((texi-prev-node (hash-table-ref/default lookup texi-prev #f)))
1997                          (texi-node-next-set! texi-last-node texi-prev)
1998                          (if (not texi-prev-node)
1999                              (let ((dummy-node (make-texi-node #f #f (texi-node-name texi-last-node) #f #f #f)))
2000                                (hash-table-set! lookup texi-prev dummy-node))))))
2001                  stream-null))
2002               
2003               (else (begin
2004                       (set! last-link #f)
2005                       stream-null))))
2006
2007       ;; strong
2008       identity
2009       ;; emphasis
2010       identity
2011       
2012       ;; link
2013       (constantly stream-null)
2014       
2015       (constantly stream-null)
2016       (constantly stream-null)
2017       (constantly stream-null) 
2018       (constantly stream-null)
2019       (constantly stream-null)
2020       (constantly stream-null)
2021       (constantly stream-null)
2022       ;; toc
2023       (constantly stream-null)
2024       ;; special-char
2025       (lambda (x)
2026         (->stream-char
2027          (case x
2028            ((#\@ #\{ #\}) (stream #\@ x))
2029            ((copyright) "(C)")
2030            ((reg) "(R)")
2031            ((left-arrow) "<-")
2032            ((right-arrow) "->")
2033            ((double-arrow) "<->")
2034            ((double-arrow-wide) "<=>")
2035            ((left-arrow-wide) "<=")
2036            ((right-arrow-wide) "=>")
2037            ((mdash) "---")
2038            ((ndash) "--")
2039            ((laquo) #\xab)
2040            ((raquo) #\xbb)
2041            (else (stream x)))))
2042       ;; tags
2043       (constantly stream-null)
2044       (constantly stream-null) 
2045       (constantly stream-null)
2046       ;; anchor
2047       (constantly stream-null)))))
2048
Note: See TracBrowser for help on using the repository browser.