source: project/chicken/branches/scrutiny/scripts/make-egg-index.scm @ 13965

Last change on this file since 13965 was 13965, checked in by felix winkelmann, 10 years ago

merged trunk rev. 13953

File size: 6.1 KB
Line 
1;;;; make-egg-index.scm - create index page for extension release directory
2
3(load-relative "tools.scm")
4
5(use setup-download matchable htmlprag data-structures regex)
6
7(import irregex)
8
9(define *major-version* (##sys#fudge 41))
10
11(define +link-regexp+
12  '(: #\[ #\[ (submatch (* (~ #\] #\|))) #\] #\]))
13
14(define +stylesheet+ #<<EOF
15/* table mods by zb */
16table {
17  background: #f6f6ff;
18  padding: 0.2em;
19  margin: 1.2em 2.0em;
20  border: 1px solid #aac;
21  border-collapse: collapse;
22  font-size: 100%;
23}
24th {
25  text-align: left;
26  border-bottom: 1px solid #aac;
27  border-left: 1px solid #aac;
28  padding: 0.25em 1.0em 0.25em 1.0em;
29} 
30td { 
31  padding: 0.25em 1.0em 0.25em 1.0em;
32  border-left: 1px solid #aac;
33}
34blockquote, pre {
35  background-color: #fafaff;
36  display: block;
37  border: 1px dashed gray;
38  margin: 1.0em 0em;
39  padding: 0.5em 1.0em;
40  overflow: auto;
41}
42pre {
43  line-height: 1.3;
44}
45h2, h3, h4, h5, h6 {
46   color: #226;
47   padding-top: 1em;
48}
49
50h1 {
51    background-color: #336;
52        color: #fff;
53        width: 100%;
54        padding: 0;
55    padding: 0.25em 16px 0.25em 0.5em;
56        margin: 0 0 0em 0;
57        font-size: 160%;
58}
59
60EOF
61)
62
63(define +categories+
64  '((lang-exts "Language extensions")
65    (graphics "Graphics")
66    (debugging "Debugging tools")
67    (logic "Logic programming")
68    (net "Networking")
69    (io "Input/Output")
70    (db "Databases")
71    (os "OS interface")
72    (ffi "Interfacing to other languages")
73    (web "Web programing")
74    (xml "XML processing")
75    (doc-tools "Documentation tools")
76    (egg-tools "Egg tools")
77    (math "Mathematical libraries")
78    (oop "Object-oriented programming")
79    (data "Algorithms and data-structures")
80    (parsing "Data formats and parsing")
81    (tools "Tools")
82    (sound "Sound")
83    (testing "Unit-testing")
84    (crypt "Cryptography")
85    (ui "User interface toolkits")
86    (code-generation "Code generation")
87    (macros "Macros and meta-syntax")
88    (misc "Miscellaneous")
89    (hell "Concurrency and parallelism")
90    (uncategorized "Not categerized")
91    (obsolete "Unsupported or redundant") ) )
92
93(define (d fstr . args)
94  (fprintf (current-error-port) "~?~%" fstr args))
95
96(define (usage code)
97  (print "make-egg-index.scm [--major-version=MAJOR] [DIR]")
98  (exit code))
99
100(define (make-egg-index dir)
101  (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
102        (eggs (gather-egg-information dir)))
103    (write-shtml-as-html
104     `(html
105       ,(header title)
106       (body
107        ,@(prelude title)
108        ,@(emit-egg-information eggs)
109        ,@(trailer))))))
110
111(define (header title)
112  `(head
113    (style (@ (type "text/css")) 
114      ,+stylesheet+)
115    (title ,title)))
116
117(define (prelude title)
118  `((h1 ,title)
119    (p (b "Last updated: " ,(seconds->string (current-seconds))))
120    (p "A library of extensions for the Chicken Scheme system.")
121    (h3 "Installation")
122    (p "Just enter")
123    (pre "  chicken-install EXTENSIONNAME\n")
124    (p "This will download anything needed to compile and install the library. "
125       "If your " (i "extension repository") " is placed at a location for which "
126       "you don't have write permissions, then run " (tt "chicken-install") 
127       "with the " (tt "-sudo") " option or run it as root (not recommended).")
128    (p "You can obtain the repository location by running")
129    (pre "  csi -p \"(repository-path)\"\n")
130    (p "If you only want to download the extension and install it later, pass the "
131       (tt "-retrieve") " option to " (tt "chicken-install") ":")
132    (pre "  chicken-install -retrieve EXTENSIONNAME\n")
133    (p "By default the archive will be unpacked into a temporary directory (named "
134       (tt "EXTENSIONNAME.egg-dir") " and the directory will be removed if the "
135       "installation completed successfully. To keep the extracted files add "
136       (tt "-keep") "to the options passed to " (tt "chicken-install") ".")
137    (p "For more information, enter")
138    (pre "  chicken-install -help\n")
139    (p "If you would like to access the subversion repository, see "
140       (a (@ (href "http://chicken.wiki.br/eggs tutorial")) "the "
141          (i "Egg tutorial")) ".")
142    (p "If you are looking for 3rd party libraries used by one the extensions, "
143       "check out the CHICKEN "
144       (a (@ (href "http://www.call-with-current-continuation.org/tarballs/") )
145          (i "tarball repository")))
146    (h3 "List of available eggs")))
147
148(define (trailer)
149  '())
150
151(define (emit-egg-information eggs)
152  (append-map
153   (match-lambda
154     ((cat catname)
155      (let ((eggs (append-map
156                   make-egg-entry
157                   (sort
158                    (filter (lambda (info) 
159                              (and (eq? cat (cadr (or (assq 'category (cdr info))
160                                                      '(#f uncategorized))))
161                                   (not (assq 'hidden (cdr info)))))
162                            eggs) 
163                    (lambda (e1 e2)
164                      (string<? (symbol->string (car e1)) (symbol->string (car e2))))))))
165        (if (null? eggs)
166            '()
167            (begin
168              (d "category: ~a" catname)
169              `((h3 ,catname)
170                (table
171                 (tr (th "Name") (th "Description") (th "License") (th "author") (th "maintainer") (th "version"))
172                 ,@eggs)))))))
173   +categories+))
174
175(define (make-egg-entry egg)
176  (call/cc
177   (lambda (return)
178     (define (prop name def pred)
179       (cond ((assq name (cdr egg)) => (o (cut check pred <> name) cadr))
180             (else def)))
181     (define (check pred x p)
182       (cond ((pred x) x)
183             (else
184              (warning "extension has incorrectly typed .meta entry and will not be listed" (car egg) p x)
185              (return '()))))
186     (d "  ~a   ~a" (car egg) (prop 'version "HEAD" any?))
187     `((tr (td ,(symbol->string (car egg)))
188           (td ,(prop 'synopsis "unknown" string?))
189           (td ,(prop 'license "unknown" name?))
190           (td ,(linkify-names (prop 'author "unknown" name?)))
191           (td ,(linkify-names (prop 'maintainer "" name?)))
192           (td ,(prop 'version "" version?)))))))
193
194(define (linkify-names str)
195  ;; silly
196  (html->shtml
197   (open-input-string
198    (irregex-replace/all
199     +link-regexp+ 
200     str
201     (lambda (m)
202       (let ((name (irregex-match-substring m 1)))
203         (string-append "<a href=\"http://chicken.wiki.br/" name "\">" name "</a>")))))))
204
205(define name?
206  (disjoin string? symbol?))
207
208(define version?
209  (disjoin string? number?))
210
211(define (main args)
212  (match args
213    ((dir)
214     (make-egg-index dir))
215    (() (make-egg-index "."))
216    (_ (usage 1))))
217
218(main (simple-args (command-line-arguments)))
Note: See TracBrowser for help on using the repository browser.