source: project/release/3/stream-wiki/trunk/extensions/chicken.scm @ 8753

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

Import.

File size: 3.9 KB
Line 
1(use syntax-case svn-post-commit-hooks orders format-modular srfi-40)
2
3(define-syntax environment
4  (syntax-rules ()
5    ((environment original ((name expr) ...))
6     (lambda (op)
7       (case op
8         ((name) expr)
9         ...
10         (else (original op)))))
11    ((environment ((name expr) ...))
12     (environment (lambda (op)
13                    (warning "unbound variable (dynamic environment)" op)
14                    (if #f #f))
15                  ((name expr) ...)))))
16
17(define-syntax environment-get
18  (syntax-rules ()
19    ((environment-get env sym) (env 'sym))))
20
21(define-syntax let-from-environment
22  (syntax-rules ()
23    ((let-from-environment env (sym ...) body ...)
24     (let ((sym (environment-get env sym)) ...) body ...))))
25
26(define-syntax environment-capture
27  (syntax-rules ()
28    ((environment-capture env (sym ...))
29     (environment env ((sym sym) ...)))
30    ((environment-capture (sym ...))
31     (environment ((sym sym) ...)))))
32
33(define *url-eggs*
34  "http://www.call-with-current-continuation.org/eggs/")
35
36(define (chicken-egg-html env)
37  (let-from-environment env (params parse path-in)
38    (or
39      (and-let* ((name-stream (assoc 'name params))
40                 (name (stream->string (cdr name-stream)))
41                 (description (assoc 'description params))
42                 (license (assoc 'license params))
43                 (author (assoc 'author params)))
44        (parse
45          (html-stream 
46            (tr (td (if (file-exists? (svnwiki-make-pathname path-in name))
47                      (format #f "[[~A]]" name)
48                      (format #f "[[~A~A.html|~A]]" *url-eggs* name name)))
49                (td (cdr description))
50                (td (cdr license))
51                (td "[[" (cdr author) "]]")
52                (td "[[http://chicken.wiki.br/dep-graphs/" name ".png|Dependencies]]")))))
53      stream-null)))
54
55(define (chicken-def name env)
56  (let-from-environment env (text)
57    ; Remove whitespace at beginning or end
58    (let ((text (stream-reverse
59                  (stream-drop-while
60                    char-whitespace?
61                    (stream-reverse
62                      (stream-drop-while
63                        char-whitespace?
64                        text))))))
65      (parse
66        (html-stream
67          "["
68          name
69          "] {{"
70          (if (and (not (stream-null? text))
71                   (char=? (stream-car text) "(")
72                   (char=? (stream-last text) ")"))
73              (receive (symbol rest)
74                       (stream-break char-whitespace?
75                                     (stream-cdr (stream-butlast text)))
76                (html-stream
77                  "('''"
78                  symbol
79                  "'''"
80                  rest
81                  ")}}\n\n"))
82              text))))))
83
84(define (chicken-examples env)
85  (let-from-environment env (params parse text)
86    (parse
87      (html-stream
88        "Examples:\n\n"
89        "<enscript highlight=scheme>" (parse text) "</enscript>"))))
90
91(define (chicken-expr env)
92  (let-from-environment env (text)
93    (html-stream text "\n")))
94
95(define (chicken-result prefix env)
96  (let-from-environment env (text)
97    (html-stream prefix " " text "\n")))
98
99(define *extensions*
100  `((chickenegg (code-break ,chicken-egg-html))
101    (procedure (code-span ,(cut chicken-def "procedure" <>)))
102    (macro     (code-span ,(cut chicken-def "macro" <>)))
103    (read      (code-span ,(cut chicken-def "read" <>)))
104    (parameter (code-span ,(cut chicken-def "parameter" <>)))
105    (record    (code-span ,(cut chicken-def "record" <>)))
106    (string    (code-span ,(cut chicken-def "string" <>)))
107    (class     (code-span ,(cut chicken-def "class" <>)))
108    (method    (code-span ,(cut chicken-def "method" <>)))
109    (examples (code-span ,chicken-examples))
110    (expr (code-span ,chicken-expr))
111    (result (code-span ,(chicken-example "=>" <>)))
112    (input  (code-span ,(chicken-example "[input]" <>)))
113    (output (code-span ,(chicken-example "[output]" <>)))))
Note: See TracBrowser for help on using the repository browser.