source: project/release/5/manual-labor/trunk/manual-labor.scm @ 40025

Last change on this file since 40025 was 40025, checked in by Jim Ursetto, 2 months ago

manual-labor: fix HTML child nesting (fixes #1747)

File size: 4.6 KB
Line 
1(import (chicken port)
2        matchable 
3        (chicken string) (chicken platform) (chicken pathname)
4        (chicken file) (chicken file posix)
5        srfi-1)
6(import svnwiki-sxml)
7(import regex) (import (chicken irregex))
8(import (only uri-generic uri-encode-string))
9(import chicken-doc-html)
10
11(define (path->href P)
12  (define (encode-path path)
13    (string-intersperse (map uri-encode-string
14                             (map ->string path))
15                        "/"))
16  (match P
17         (('*manual* . rest)
18          (encode-path rest))
19         (else
20          (string-append
21           "http://wiki.call-cc.org/egg/"
22           (encode-path P)))))
23
24;; (define (def->href id)
25;;   (string-append "#" (quote-identifier (definition->identifier id))))
26(define (def->href id) #f)
27(define (man-filename->path fn)  ;; Create virtual *manual* namespace so we can
28                                 ;; distinguish egg paths and send them to the wiki.
29  (list '*manual* (string-append fn ".html")))
30
31;;; html
32
33(import (only sxml-transforms
34           pre-post-order* universal-conversion-rules* SRV:send-reply))
35
36(define (sxml->html doc #!optional port)
37  (let* ((rules `((lit *preorder* . ,(lambda (t b) b))
38                  . ,universal-conversion-rules*))
39         (reply (lambda () (SRV:send-reply (pre-post-order* doc rules)))))
40    (if port
41        (with-output-to-port port reply)
42        (with-output-to-string reply))))
43
44(define (maybe pred x)
45  (if pred x '()))
46
47(define (charset c)
48  (maybe c
49         `(meta (@ (http-equiv "content-type")
50                   (content "text/html; charset=" ,c)))))
51(define (javascript href)
52  `(script (@ (type "text/javascript")
53              (src ,href))))
54(define (css-link href)
55  `(link (@ (rel stylesheet)
56            (href ,href)
57            (type "text/css"))))
58
59;;;
60
61(define manual-labor-support-dir  ;; Overridable source dir for support files.
62  (make-parameter (make-pathname (car ##sys#include-pathnames) ; hack
63                                 "manual-labor-support")))
64
65(define (copy-support-file fn outdir)
66  (print "Copying " fn "...")
67  (copy-file fn (make-pathname outdir (pathname-strip-directory fn))
68             'clobber))
69(define (copy-support-files fns outdir)
70  (for-each (lambda (fn) (copy-support-file fn outdir))
71            fns))
72
73(define (generate-html-manual mandir outdir)
74  (let* ((support-dir (manual-labor-support-dir))
75         (css-files (glob (make-pathname support-dir "*.css")))  ;; might need to enforce order
76         (js-files (glob (make-pathname support-dir "*.js"))))
77    (create-directory outdir)  ;; and parents too?
78    (copy-support-files css-files outdir)
79    (copy-support-files js-files outdir)
80    (process-manual-dir mandir
81                        outdir
82                        (map pathname-strip-directory css-files)
83                        (map pathname-strip-directory js-files))))
84
85(define ignore-filename?
86  (let ((re:ignore (irregex '(or (: bos "#")
87                                 (: bos ".")
88                                 (: ".swp" eos)
89                                 (: "~" eos)))))
90    (lambda (fn)
91      (string-search re:ignore fn))))
92(define (really-regular-file? fn)
93  (and (not (symbolic-link? fn))      ;; cannot rely on file-type before 4.6.0
94       (regular-file? fn)))
95
96(define (read-manual-dir dir)
97  (filter really-regular-file?
98          (map (lambda (fn) (make-pathname dir fn))
99               (remove ignore-filename? (directory dir #t)))))
100
101(define (process-manual-dir dir outdir css js)
102  (print "Processing manual directory " dir "...")
103  (process-manual-files (read-manual-dir dir)
104                        outdir css js))
105
106(define (process-manual-files fns outdir css js)
107  (for-each (lambda (fn) (process-manual-file fn outdir css js))
108            fns))
109
110(define (process-manual-file fn outdir css js)
111  (let* ((name (pathname-file fn))
112         (out (make-pathname outdir name ".html"))
113         (doc (call-with-input-file fn svnwiki->sxml)))
114    (print name)
115    (call-with-output-file out
116      (lambda (p)
117        (sxml->html
118         `((lit "<!doctype html>")
119           (html
120            (head ,(charset "utf-8")
121                  ,(map css-link css)
122                  ,(map javascript js)
123                  (title "Chicken " (& "raquo") " " ,name)
124                  (meta (@ (name "viewport")
125                           (content "initial-scale=1"))))
126            (body
127             (div (@ (id "body"))
128                  (div (@ (id "main"))
129                       (lit ,(chicken-doc-sxml->html doc path->href def->href
130                                                     man-filename->path)))))))
131         p)))))
Note: See TracBrowser for help on using the repository browser.