(import (chicken port) matchable (chicken string) (chicken platform) (chicken pathname) (chicken file) (chicken file posix) srfi-1) (import svnwiki-sxml) (import regex) (import (chicken irregex)) (import (only uri-generic uri-encode-string)) (import chicken-doc-html) (define (path->href P) (define (encode-path path) (string-intersperse (map uri-encode-string (map ->string path)) "/")) (match P (('*manual* . rest) (encode-path rest)) (else (string-append "http://wiki.call-cc.org/egg/" (encode-path P))))) ;; (define (def->href id) ;; (string-append "#" (quote-identifier (definition->identifier id)))) (define (def->href id) #f) (define (man-filename->path fn) ;; Create virtual *manual* namespace so we can ;; distinguish egg paths and send them to the wiki. (list '*manual* (string-append fn ".html"))) ;;; html (import (only sxml-transforms pre-post-order* universal-conversion-rules* SRV:send-reply)) (define (sxml->html doc #!optional port) (let* ((rules `((lit *preorder* . ,(lambda (t b) b)) . ,universal-conversion-rules*)) (reply (lambda () (SRV:send-reply (pre-post-order* doc rules))))) (if port (with-output-to-port port reply) (with-output-to-string reply)))) (define (maybe pred x) (if pred x '())) (define (charset c) (maybe c `(meta (@ (http-equiv "content-type") (content "text/html; charset=" ,c))))) (define (javascript href) `(script (@ (type "text/javascript") (src ,href)))) (define (css-link href) `(link (@ (rel stylesheet) (href ,href) (type "text/css")))) ;;; (define manual-labor-support-dir ;; Overridable source dir for support files. (make-parameter (make-pathname (repository-path) "manual-labor-support"))) (define (copy-support-file fn outdir) (print "Copying " fn "...") (copy-file fn (make-pathname outdir (pathname-strip-directory fn)) 'clobber)) (define (copy-support-files fns outdir) (for-each (lambda (fn) (copy-support-file fn outdir)) fns)) (define (generate-html-manual mandir outdir) (let* ((support-dir (manual-labor-support-dir)) (css-files (glob (make-pathname support-dir "*.css"))) ;; might need to enforce order (js-files (glob (make-pathname support-dir "*.js")))) (create-directory outdir) ;; and parents too? (copy-support-files css-files outdir) (copy-support-files js-files outdir) (process-manual-dir mandir outdir (map pathname-strip-directory css-files) (map pathname-strip-directory js-files)))) (define ignore-filename? (let ((re:ignore (irregex '(or (: bos "#") (: bos ".") (: ".swp" eos) (: "~" eos))))) (lambda (fn) (string-search re:ignore fn)))) (define (really-regular-file? fn) (and (not (symbolic-link? fn)) ;; cannot rely on file-type before 4.6.0 (regular-file? fn))) (define (read-manual-dir dir) (filter really-regular-file? (map (lambda (fn) (make-pathname dir fn)) (remove ignore-filename? (directory dir #t))))) (define (process-manual-dir dir outdir css js) (print "Processing manual directory " dir "...") (process-manual-files (read-manual-dir dir) outdir css js)) (define (process-manual-files fns outdir css js) (for-each (lambda (fn) (process-manual-file fn outdir css js)) fns)) (define (process-manual-file fn outdir css js) (let* ((name (pathname-file fn)) (out (make-pathname outdir name ".html")) (doc (call-with-input-file fn svnwiki->sxml))) (print name) (call-with-output-file out (lambda (p) (sxml->html `((lit "") (html (head ,(charset "utf-8") ,(map css-link css) ,(map javascript js)) (title "Chicken " (& "raquo") " " ,name) (meta (@ (name "viewport") (content "initial-scale=1")))) (body (div (@ (id "body")) (div (@ (id "main")) (lit ,(chicken-doc-sxml->html doc path->href def->href man-filename->path)))))) p)))))