source: project/release/3/svnwiki-scheme-library/trunk/svnwiki-scheme-library.scm @ 18250

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

importing

File size: 6.5 KB
Line 
1; $id$
2;
3; License: GPL-3
4
5(use syntax-case)
6
7(define-syntax stream-if
8  (syntax-rules ()
9    ((_ condition body) (if condition body stream-null))))
10
11(use svnwiki-extensions-support posix srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
12
13(define (html-prop name value)
14  (stream-if name
15    (html-prop-param
16      "; " name " : " value)))
17
18(define (html-prop-param name symbol params)
19  (html-prop name
20    (and-let* ((data (assoc symbol params)))
21      (cdr data))))
22
23(define (output-autogenerated-header env)
24  (let-from-environment env (static-url path new-rev)
25    (format #t "; FILE AUTOMATICALLY GENERATED!~%")
26    (format #t ";~%")
27    (format #t "; This file was automatically generated by the svnwiki-scheme-library extension.~%")
28    (format #t "; The authoritative source for this is:~%")
29    (format #t ";~%")
30    (format #t ";   ~A~A~%" static-url path)
31    (format #t ";~%")
32    (format #t "; Generation data:~%")
33    (format #t ";~%")
34    (format #t ";   Input revision: ~A~%" new-rev)
35    (format #t ";   User: ~A~%" (current-user-name))
36    (format #t ";   Machine: ~A~%" (current-hostname))
37    (format #t ";   Date: ~A~%" (seconds->string (current-seconds)))
38    (newline)))
39
40(define (generate-setup-contents env)
41  (let-from-environment env (params)
42    (string->stream
43      (with-output-to-string
44        (lambda ()
45          (let ((name (cdr (assoc 'name params))))
46            (output-autogenerated-header)
47            (format #t "(define *has-exports* (string>=? (chicken-version) \"2.310\"))~%~%")
48            (newline)
49            (format #t "(define (dynld-name fn) (make-pathname #f fn ##sys#load-dynamic-extension))~%~%")
50            (newline)
51            (for-each
52              (lambda (file)
53                (format #t "(compile -O2 -d0 -s~%")
54                (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
55                (format #t "  ~A.scm)" file))
56              (get-list-of-runtime-files env))
57            (format #t "(install-extension ~A~%" name)
58            (format #t "  ; Files to install:~%")
59            (format #t "  `(,@(if has-exports? '(\"~A.exports\") (list))~{~%  ,(dynld-name ~S)~})~%"
60                    name (get-list-of-runtime-files env))
61            (format #t "  ; Extension properties:~%")
62            (format #t "  `(")
63            ; TODO: Support syntax extensions
64            (format #t "(documentation \"~A.html\")~%" name)
65            (format #t "  (version ,(if (file-exists? \"version\") (with-input-from-file \"version\" read) \"unknown\")))")))))))
66
67(test-group parse-list-of-tokens
68  (test (parse-list-of-tokens (string->stream "   foo   bar   hey  "))
69        '("foo" "bar" "hey"))
70  (test (parse-list-of-tokens (string->stream "foo"))
71        '("foo"))
72  (test (parse-list-of-tokens (string->stream "foo bar"))
73        '("foo" "bar"))
74  (test (parse-list-of-tokens (string->stream ""))
75        '()))
76
77(define (parse-list-of-tokens str)
78  (map stream->string
79       (stream->list
80         (stream-remove
81           stream-null?
82           (stream-split str char-whitespace?)))))
83
84(define (get-list-of-runtime-files env)
85  (let-from-environment env (params)
86    (let ((runtime-files (assoc 'runtime-files params)))
87      (if runtime-files
88        (parse-list-of-tokens (cdr runtime-files))
89        (list (cdr (assoc 'name params)))))))
90
91(define (output-meta-prop symbol params)
92  (and-let* ((value (assoc symbol params)))
93    (format #t " (~A \"~A\")~%" symbol (stream->string (cdr value)))))
94
95(define (generate-meta-contents env)
96  (let-from-environment env (params)
97    (string->stream
98      (with-output-to-string
99        (lambda ()
100          (let ((name (cdr (assoc 'name params)))
101                (author (assoc 'author params))
102                (synosys (assoc 'synosys params)))
103            (output-autogenerated-header env)
104            (format #t "(")
105            (format #t "(files \"~A.setup\" \"~A.html\" ~{\"~A.scm\"~})~%" name (get-list-of-runtime-files env))
106            (output-meta-prop 'author params)
107            (output-meta-prop 'synopsis params)
108            (output-meta-prop 'category params)
109            (output-meta-prop 'license params)
110            (format #t " (egg \"~A.egg\"))~%" name)))))))
111
112; TODO: Maybe use render-template?
113(define (generate-html-contents env)
114  (let-from-environment env (params static-url path)
115    (let ((name (assoc 'name params)))
116      (html-stream
117        (html
118          (head (title (cdr name)))
119          (body
120            (p "The documentation and implementation information for the "
121               (cdr name) " egg is available at:")
122            (ul (li ((a href (format #f "~A~A" static-url path))
123                     static-url path)))))))))
124
125(define (generate-header env)
126  (with-output-to-string (lambda () (output-autogenerated-header env))))
127
128(define (scheme-library-definition env)
129  (let-from-environment env (output-format parse return params)
130    (format (current-error-port) "scheme-library-definition: ~A~%" params)
131    (let ((name (assoc 'name params)))
132      (cond
133        ((not name)
134         (html-stream "[scheme-library error: name parameter missing"))
135        ((eq? output-format 'enscript)
136         (return
137           (list (cdr name)
138                 "application/x-scheme-chicken-meta"
139                 (generate-meta-contents env)))
140         (return
141           (list (cdr name)
142                 "text/html"
143                 (generate-html-contents env)))
144         (return
145           (list (cdr name)
146                 "application/x-scheme-chicken-setup"
147                 (generate-setup-contents env)))
148         (for-each
149           (lambda (file)
150             (return file "application/x-scheme" (generate-header env)))
151           (get-list-of-runtime-files env)))
152        (else
153          (parse
154            (html-stream
155              "Scheme Library: '''" (cdr name) "'''\n\n"
156              (html-prop "Author"
157                (let ((author (assoc 'author params))
158                      (author-email (assoc 'author-email params)))
159                  (and author
160                       (stream-concatenate
161                         (cdr author)
162                         (stream-if author-email (html-stream "<" author-email ">"))))))
163              (html-prop-param "Category" 'category params)
164              (html-prop-param "Synopsis" 'synospis params)
165              (html-prop-param "License" 'license params)
166              (html-prop-param "Dependencies" 'dependencies params)
167              (html-prop-param "Exports" 'exports params))))))))
168
169(svnwiki-extension-define 'code-break 'schemelibrarydefinition scheme-library-definition)
Note: See TracBrowser for help on using the repository browser.