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

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

merged trunk changes until 14826 into scrutiny branch

File size: 9.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 sxml-transforms data-structures regex)
6
7(import irregex)
8
9(define *help* #f)
10(define *major-version* (##sys#fudge 41))
11
12(define +link-regexp+
13  (irregex '(: #\[ #\[ (submatch (* (~ #\] #\|))) #\] #\])))
14
15(define +categories+
16  '((lang-exts "Language extensions")
17    (graphics "Graphics")
18    (debugging "Debugging tools")
19    (logic "Logic programming")
20    (net "Networking")
21    (io "Input/Output")
22    (db "Databases")
23    (os "OS interface")
24    (ffi "Interfacing to other languages")
25    (web "Web programming")
26    (xml "XML processing")
27    (doc-tools "Documentation tools")
28    (egg-tools "Egg tools")
29    (math "Mathematical libraries")
30    (oop "Object-oriented programming")
31    (data "Algorithms and data-structures")
32    (parsing "Data formats and parsing")
33    (tools "Tools")
34    (sound "Sound")
35    (testing "Unit-testing")
36    (crypt "Cryptography")
37    (ui "User interface toolkits")
38    (code-generation "Code generation")
39    (macros "Macros and meta-syntax")
40    (misc "Miscellaneous")
41    (hell "Concurrency and parallelism")
42    (uncategorized "Uncategorized")
43    (obsolete "Unsupported or redundant") ) )
44
45(define (d fstr . args)
46  (fprintf (current-error-port) "~?~%" fstr args))
47
48(define (usage code)
49  (print "make-egg-index.scm [--help] [--major-version=MAJOR] [DIR]")
50  (exit code))
51
52(define (sxml->html doc)
53  (SRV:send-reply
54   (pre-post-order
55    doc
56    ;; LITERAL tag contents are used as raw HTML.
57    `((literal *preorder* . ,(lambda (tag . body) (map ->string body)))
58      ,@universal-conversion-rules))))
59
60(define (make-egg-index dir)
61  (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
62        (eggs (gather-egg-information dir)))
63    (sxml->html
64     `((literal "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
65       (literal "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
66       (html
67        ,(header title)
68        (body
69         ,(titlebar title)
70         ,(sidebar)
71         ,(content (prelude title)
72                   (emit-egg-information eggs))
73         ,(trailer)))))))
74
75(define (wiki-link path desc)
76  `(a (@ (href "http://chicken.wiki.br/" ,path))
77      ,desc))
78
79(define (sidebar)
80  `(div (@ (id "toc-links"))
81        (div (@ (id "toc"))
82             (p ,(wiki-link "" "Home") (br)
83                ,(wiki-link "manual/index" "Manual") (br)
84                ,(wiki-link "eggs" "Eggs") (br)
85                ,(wiki-link "users" "Users") (br)
86                ))))
87
88(define (content . body)
89  `(div (@ (id "content-box"))
90        (div (@ (class "content"))
91             ,body)))
92
93(define (header title)
94  `(head
95;;     (style (@ (type "text/css"))
96;;       ,+stylesheet+)
97    (link (@ (rel "stylesheet")
98             (type "text/css")
99             (href "http://chicken.wiki.br/common-css")))
100    (title ,title)))
101
102(define (titlebar title)
103  `(div (@ (id "header"))
104        (h1 (a (@ (href "http://chicken.wiki.br/eggs"))
105               ,title))))
106
107(define (prelude title)
108  `((p (img (@
109             (style "float: right;")
110             (src "http://www.call-with-current-continuation.org/eggs/3/egg.jpg"))))
111    (p (b "Last updated: " ,(seconds->string (current-seconds))))
112    (p "A library of extensions for the Chicken Scheme system.")
113    (h2 "Installation")
114    (p "Just enter")
115    (pre "  chicken-install EXTENSIONNAME\n")
116    (p "This will download anything needed to compile and install the library. "
117       "If your " (i "extension repository") " is placed at a location for which "
118       "you don't have write permissions, then run " (tt "chicken-install") 
119       " with the " (tt "-sudo") " option or run it as root (not recommended).")
120    (p "You can obtain the repository location by running")
121    (pre "  csi -p \"(repository-path)\"\n")
122    (p "If you only want to download the extension and install it later, pass the "
123       (tt "-retrieve") " option to " (tt "chicken-install") ":")
124    (pre "  chicken-install -retrieve EXTENSIONNAME\n")
125    (p "By default the archive will be unpacked into a temporary directory (named "
126       (tt "EXTENSIONNAME.egg-dir") ") and the directory will be removed if the "
127       "installation completed successfully. To keep the extracted files add "
128       (tt "-keep") " to the options passed to " (tt "chicken-install") ".")
129    (p "For more information, enter")
130    (pre "  chicken-install -help\n")
131    (p "If you would like to access the subversion repository, see the "
132       (a (@ (href "http://chicken.wiki.br/eggs tutorial"))
133          "Egg tutorial") ".")
134    (p "If you are looking for 3rd party libraries used by one of the extensions, "
135       "check out the CHICKEN "
136       (a (@ (href "http://www.call-with-current-continuation.org/tarballs/") )
137          "tarball repository") ".")
138    (h2 "List of available eggs")
139    (a (@ (name "category-list")))
140    (h3 "Categories")
141    ,(category-link-list)
142    ))
143
144;; information on empty categories not available yet; link all possible categories
145(define (category-link-list)
146  `(ul (@ (style "list-style-type: none; padding-left: 2em;"))
147       ,@(map
148          (match-lambda
149           ((cat catname)
150            `(li (a (@ (href "#" ,cat))
151                    ,catname))))
152          +categories+)))
153
154(define (trailer)
155  `(div (@ (id "credits"))
156        (p "Generated with Chicken " ,(chicken-version))))
157
158(define (emit-egg-information eggs)
159  (append-map
160   (match-lambda
161     ((cat catname)
162      (let ((eggs (append-map
163                   make-egg-entry
164                   (sort
165                    (filter (lambda (info) 
166                              (and (eq? cat (cadr (or (assq 'category (cdr info))
167                                                      '(#f uncategorized))))
168                                   (not (assq 'hidden (cdr info)))))
169                            eggs) 
170                    (lambda (e1 e2)
171                      (string<? (symbol->string (car e1)) (symbol->string (car e2))))))))
172        (if (null? eggs)
173            '()
174            (begin
175              (d "category: ~a" catname)
176              `((a (@ (name ,cat)))
177                (h3 (a (@ (href "#category-list"))
178                       ,catname))
179                (table
180                 (tr (th "Name") (th "Description") (th "License") (th "author") (th "maintainer") (th "version"))
181                 ,@eggs)))))))
182   +categories+))
183
184(define (make-egg-entry egg)
185  (call/cc
186   (lambda (return)
187     (define (prop name def pred)
188       (cond ((assq name (cdr egg)) => (o (cut check pred <> name) cadr))
189             (else def)))
190     (define (check pred x p)
191       (cond ((pred x) x)
192             (else
193              (warning "extension has .meta entry of incorrect type and will not be listed" (car egg) p x)
194              (return '()))))
195     (d "  ~a   ~a" (car egg) (prop 'version "HEAD" any?))
196     `((tr (td (a (@ (href ,(sprintf "http://chicken.wiki.br/eggref/~a/~a" *major-version* (car egg))))
197                  ,(symbol->string (car egg))))
198           (td ,(prop 'synopsis "unknown" string?))
199           (td ,(prop 'license "unknown" name?))
200           (td ,(linkify-names (prop 'author "unknown" name?)))
201           (td ,(linkify-names (prop 'maintainer "" name?)))
202           (td ,(prop 'version "" version?)))))))
203
204;; Names are either raw HTML, or [[user name]] denoting a wiki link.
205(define (linkify-names str)
206  ;; Call MATCHED on (sub)matches and DID-NOT-MATCH on non-matches in STR,
207  ;; and collect into a list.
208  (define (transform irx str matched did-not-match)
209    ;; IRREGEX-FOLD is exported for SVN trunk >= r14283, delete this if
210    ;; installed Chicken is new enough.
211    (define (irregex-fold irx kons knil str . o)
212      (let* ((irx (irregex irx))
213             (finish (if (pair? o) (car o) (lambda (i acc) acc)))
214             (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
215             (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
216                      (caddr o)
217                      (string-length str))))
218        (let lp ((i start) (acc knil))
219          (if (>= i end)
220              (finish i acc)
221              (let ((m (irregex-search irx str i end)))
222                (if (not m)
223                    (finish i acc)
224                    (let* ((end (irregex-match-end m 0))
225                           (acc (kons i m acc)))
226                      (lp end acc))))))))
227    (let ((irregex-match-start-index irregex-match-start)) ;; upcoming API change in irregex 0.7
228      (irregex-fold irx
229                    (lambda (i m s)
230                      (cons (matched (irregex-match-substring m 1))
231                            (cons (did-not-match
232                                   (substring str i (irregex-match-start-index m 0)))
233                                  s)))
234                    '()
235                    str
236                    (lambda (i s)
237                      (reverse (cons (did-not-match (substring str i))
238                                     s))))))
239  (transform
240   +link-regexp+
241   str
242   (lambda (name)  ;; wiki username
243     `(a (@ (href ,(string-append "http://chicken.wiki.br/users/"
244                                  (string-substitute " " "-" name 'global))))
245         ,name))
246   (lambda (x)     ;; raw HTML chunk
247     `(literal ,x))))
248
249(define name?
250  (disjoin string? symbol?))
251
252(define version?
253  (disjoin string? number?))
254
255(define (main args)
256  (when *help* (usage 0))
257  (match args
258    ((dir)
259     (make-egg-index dir))
260    (() (make-egg-index "."))
261    (_ (usage 1))))
262
263(main (simple-args (command-line-arguments)))
Note: See TracBrowser for help on using the repository browser.