#!/bin/sh #| cd "`dirname $0`" if [ "`pwd`" != "$HOME/Swindle" ]; then echo "This script is in a bad place." exit 1 fi origdir="`pwd`" tmpdir="/tmp/swindle-$$" # trap errors and exit error_handler() { echo "Abort!" 1>&2; exit 1; } cleanup() { cd "$origdir" ; /bin/rm -rf "$tmpdir" ; } trap error_handler 2 3 9 15 trap cleanup 0 set -e force=no; doc=no; plt=no; html=no; while [ $# -gt 0 ]; do case "$1" in f*) force=yes ;; d*) doc=yes ;; p*) plt=yes ;; h*) html=yes ;; all) force=yes; doc=yes; plt=yes; html=yes; ;; esac; shift done oPLTCOLLECTS="$PLTCOLLECTS" PLTCOLLECTS="$HOME/Swindle:$oPLTCOLLECTS"; export PLTCOLLECTS cd "$HOME/Swindle" if [ "$force" = "yes" ]; then rm -rf swindle/compiled; fi mzc --collection-zos "swindle" 2>&1 | \ egrep -v \ '^ *(((check|process|compil|skipp)ing)|end compile: |newer src\.\.\.)' if [ "$doc" = "yes" ]; then swindle -r "`basename $0`" fi if [ "$plt" = "yes" ]; then mkdir -p "$tmpdir/collects" ln -s "$HOME/Swindle/swindle" "$tmpdir/collects/swindle" PLTCOLLECTS="$tmpdir/collects:$oPLTCOLLECTS"; export PLTCOLLECTS mzc --collection-plt "swindle.plt" --replace --at-plt "swindle" fi exit |# (require (lib "html.ss" "swindle")) (current-exception-handler (lambda (e) (apply eprintf (if (exn:break? e) '("break\n") (list "error: ~a\n" (if (exn? e) (exn-message e) e)))) (exit 1))) (echo "Making docs...") (define (split-by-empty-lines lines) (let ([r (list '())]) (dolist [l lines] (if (equal? "" l) (push! '() r) (push! l (car r)))) (map! reverse! (reverse! (filter pair? r))))) (define (split-by-star-lines . lines) (let ([r '()]) (dolist [l lines] (regexp-case l [(#rx"^ *\\* *(.*[^ ]) *$" line) (push! (list line) r)] [(#rx"^(.*[^ ]) *$" line) (push! line (car r))] [#rx"^ *$" (unless (or (null? r) (null? (cdar r))) (push! "" (car r)))])) (map! reverse! (reverse! r)))) ;; Read documentation info (define doc-file "documentation.txt") (defsubst (def* var lines ...) (define var (split-by-star-lines lines ...))) (display-mixed-file doc-file :metas '("}" "{") :scheme? #t :split-lines? #t) ;; echo settings (echo :set-user :lines (lambda (ls) (echo-quote list :\{ ls :n :\})) :set-user :title (lambda (title) (concat (make-string 4 #\=) "< " title " >" (make-string (- 72 4 2 (string-length title) 2) #\=))) :set-user :title-lines (lambda (ls) (echo-quote list* :title (caar ls) :n :n :lines (cdar ls) (echo-quote list :\{ "*" :\{ (cdr ls) :n :\} :^ :n :\} :n))) :set-user :multiple-title-lines (lambda args (echo-quote list :\{ :title-lines args :^ :n :\} :title "*")) :set-user :symbols (lambda (l) (echo-quote list :push :s- :\{ "`" l "'" :^ ", " :\} :pop))) (define (make-version) (with-output-to-file (concat src-dir "/version.txt") (thunk (let* ([d (seconds->date (current-seconds))] [y (date-year d)] [m (date-month d)] [d (date-day d)]) (echo "Swindle:" :s- y (if (< m 10) "0" "") m (if (< d 10) "0" "") d :s+ :n "PLT:" (version)))) 'truncate)) (define (make-readme) (define (rule title) (concat (make-string 10 #\=) "< " title " >" (make-string (- 72 10 2 (string-length title) 2) #\-))) (with-output-to-file (concat src-dir "/readme.txt") (thunk (echo :multiple-title-lines prolog feature-list source-descriptions quick-copyright)) 'truncate)) ;; The final part is too heavy for lists... (defclass () name lines [parent :initvalue #f] :auto #t) (defclass () type classinfo definition :auto #t) (defclass () docs requires syntax-requires variables syntaxes re-exports html-doc :auto #t) (*make-safely* #t) (define all-bindings (make-hash-table)) (defaftermethod (initialize [b ] args) (set! (hash-table-get all-bindings (doc-name b)) b)) (define (find-binding sym) (hash-table-get all-bindings sym (lambda () #f))) (defmethod (push-line! [l ] [d ]) (let ([m (regexp-match #rx"^ *$" l)]) (unless (and m (null? (doc-lines d))) (push! l (doc-lines d))))) (defmethod (process-lines (d )) (set! (doc-lines d) (reverse! (let loop ([l (doc-lines d)]) (if (and (pair? l) (equal? "" (car l))) (loop (cdr l)) l))))) (define (get-module-data modname) (define (idx->symbol-list mod-path) (if (module-path-index? mod-path) (let-values ([(p b) (module-path-index-split mod-path)]) (let ([p (match p [('lib (regexp #rx"^(.*)\\.ss$" _ l) "swindle") (string->symbol l)] [('lib (regexp #rx"^(.*)\\.ss$" _ l)) (string->symbol (concat "mzlib/" l))] [else p])]) (and p (cons p (let ([b (idx->symbol-list b)]) (or b '())))))) mod-path)) (define (idx->symbol mod-path) (let ([x (idx->symbol-list mod-path)]) (if (and (pair? x) (null? (cdr x))) (car x) x))) (let* ([file (format "~a/~a.ss" src-dir modname)] [expr (expand (with-input-from-file file read))] [comp (compile expr)]) (define (prop p) (syntax-property expr p)) (unless (compiled-module-expression? comp) (error 'make-doc "didn't get a compiled module expression from ~s" file)) (unless (eq? (module-compiled-name comp) modname) (error 'make-doc "loading ~s didn't define module ~s" file modname)) (let ([req (map idx->symbol (prop 'module-direct-requires))] [sreq (map idx->symbol (prop 'module-direct-for-syntax-requires))] [vars (maptree idx->symbol (prop 'module-variable-provides))] [syns (maptree idx->symbol (prop 'module-syntax-provides))] [exps '()]) (define (do-exps xs) (let ([r '()]) (dolist [x xs] (if (and (pair? x) (pair? (cdr x))) (when (symbol? (car x)) (let ([x (if (regexp-match #rx"^#%" (symbol->string (car x))) '#%kernel (car x))]) (unless (member x exps) (push! x exps)))) (push! (if (pair? x) (car x) x) r))) r)) (set! vars (do-exps vars)) (set! syns (do-exps syns)) (make :name modname :lines '() :docs '() :requires req :syntax-requires sreq :variables vars :syntaxes syns :re-exports exps)))) (define (get-module-descriptions) (define mod #f) (define vars #f) (define syns #f) (define cur #f) (define r '()) (define def-re #rx"^> +([^a-zA-Z0-9!?*+#%~/<>:-]*([a-zA-Z0-9!?*+#%~/<>:-]+)(.*[^ ])?) *$") (define (find-binding-type! sym) (define (search l) (find-if (lambda (x) (eq? sym (cond [(and (pair? x) (pair? (cdr x))) (cadr x)] [(pair? x) (car x)] [else x]))) l)) (cond [(memq sym vars) (set! vars (remq sym vars)) 'variable] [(memq sym syns) (set! syns (remq sym syns)) 'syntax] [else (error 'make-doc "got description for unknown symbol `~s' in `~s'" sym (doc-name (car r)))])) (define (check-bindings) (when (pair? vars) (error 'make-doc "some varaibles in `~s' left undocumented: ~s\n" (doc-name (car r)) vars)) (when (pair? syns) (error 'make-doc "some syntaxes in `~s' left undocumented: ~s\n" (doc-name (car r)) syns))) (dolist [m documented-modules] (set! cur (get-module-data m) mod cur vars (module-d-variables cur) syns (module-d-syntaxes cur)) (push! cur r) (with-input-from-file (format "~a/~a.ss" src-dir m) (thunk (let loop () (let ([l (read-line)]) (unless (eof-object? l) (regexp-case l [(doc-line-re l) (regexp-case l [(doc-sep-re name) (set! cur (make :name (and (not (equal? "" name)) name) :lines '())) (push! cur (module-d-docs mod))] [(def-re def sym . _) (let ([sym (string->symbol sym)]) (let ([type (regexp-case def [(additional-doc-re newdef type) (set! def newdef) (string->symbol type)] [else (find-binding-type! sym)])]) (set! cur (make :name sym :type type :classinfo #f :definition def :lines '() :parent mod)) (unless (regexp-match hidden-doc-re def) (push! cur (module-d-docs mod)))))] [else (push-line! l cur)])]) (loop)))))) (check-bindings) (process-lines mod) (dolist [d (module-d-docs mod)] (process-lines d)) (set! (module-d-docs mod) (reverse! (module-d-docs mod)))) (reverse! r)) (define (process-description mod-d) (with-slots mod-d (re-exports lines docs) (define (add-line! line) (set! lines (append! lines (list line)))) (unless (null? re-exports) (let ([k? (memq '#%kernel re-exports)] [xps (remq '#%kernel re-exports)]) (add-line! "") (unless (null? xps) (add-line! (echos :s- "This module exports bindings from: " :symbols xps "."))) (when k? (add-line! (echos (if (null? xps) "This module" "It") "is intended to be used as a language module")) (add-line! "(as an initial-import for other modules).")))) (dolist [d docs] (when (binding-d? d) (with-slots d [name classinfo type] (let* ([v (and (eq? type 'variable) (namespace-variable-value name))] [t (case type [(variable) (cond [(generic? v) 'generic] [(class? v) 'class] [(instance? v) (string->symbol (regexp-replace #rx"^<(.*)>$" (symbol->string (class-name (class-of v))) "\\1"))] [(parameter? v) 'parameter] [(procedure? v) 'procedure] [else 'value])] [(syntax) (let ([syntax-param? (eval #`(letsyntax ([get (lambda (stx) (with-handlers ([void (lambda _ #'#f)]) ((syntax-local-value #'#,name)) #'#t))]) (get)))]) (if syntax-param? 'syntax-parameter type))] [(local) 'local] [else (error 'make-doc "unknown type tag `~e'" type)])]) (set! type t classinfo (and (class? v) (map class-name (cons (class-of v) (class-direct-supers v))))))))))) (define module-descriptions (get-module-descriptions)) (for-each process-description module-descriptions) (define (make-doc) (define width 72) (define (rule &optional (w width) (ch #\-)) (make-string w ch)) (define =rule (rule width #\=)) (define -rule (rule width #\-)) (define (center str) (concat (make-string (round (/ (- width (string-length str)) 2)) #\space) str)) (define prev-was-empty #f) (with-output-to-file (concat src-dir "/doc.txt") (thunk (echo =rule :n (center "_Swindle_") :n =rule :n :n :lines (cdar prolog)) (dolist [md module-descriptions] (with-slots md [name lines docs] (echo :s- :n -rule :n "_" name "_ _" name ".ss_" :n -rule :n :n :lines lines) (dolist [d docs] (if (binding-d? d) (with-slots d [name orig definition type classinfo lines] (echo :s- "> " definition (make-string (- width 4 (string-length definition) (string-length (symbol->string type))) #\space) "[" type "]") (unless (null? lines) (for-each echo lines) (when (and classinfo (not prev-was-empty)) (echo :s- :n- " Instance of `" (car classinfo) "'") (if (null? (cdr classinfo)) (echo ".") (echo :s- ", subclass of " :symbols (cdr classinfo) "."))) (newline)) (set! prev-was-empty (null? lines))) (with-slots d [name lines] (when name (let ([header (echos :s- "_" name "_")]) (echo header :n (rule (string-length header)) :n))) (unless (null? lines) (echo :n- :lines lines) (newline)) (set! prev-was-empty #f))))))) 'truncate)) ;; HTML docs (define source-description-lists (map (lambda (ls) (regexp-case (car ls) [(#rx"^([^ ]*) *(\\(.*\\))?$" file flags) (list* file flags (map (lambda (x) (regexp-replace #rx"^ +" x "")) (cdr ls)))])) (cdr source-descriptions))) (define (get-file-description f) (cond [(assoc f source-description-lists) => (lambda (d) (pop! d) (apply small~: 2 (i: (car d)) (regexp-case f [(#rx"^([^ ]+)\\.ss$" m) (let* ([m (string->symbol m)] [d (find-if (lambda (x) (eq? m (doc-name x))) module-descriptions)]) (and d "\\ \\ " : (ref~: (html-ref-name (module-d-html-doc d)) "[DOC]")))]) br: (cdr d)))])) (define ((file-precedes? prefix) f1 f2) (define (memprefix x l) (and (pair? l) (if (or (equal? x (caar l)) (and (> (string-length (caar l)) (string-length x)) (equal? x (substring (caar l) 0 (string-length x))))) l (memprefix x (cdr l))))) (let* ([f1 (concat prefix f1)] [m1 (memprefix f1 source-description-lists)] [f2 (concat prefix f2)] [m2 (memprefix f2 source-description-lists)]) (cond [(memprefix f2 m1) #t] [(memprefix f1 m2) #f] [(and m1 (not m2)) #t] [(and m2 (not m1)) #f] [else (stringdocname f) (echos :s- (regexp-replace #rx"\\.ss$" (as f) "") "-doc")) (define (swindle-file: f &optional (txt f)) (let ([s (concat src-dir "/" f)]) (and (file-exists? s) (ref~: :title "go to '": f :"'" s (tt: txt))))) (define (swindle-doc: f &optional (txt f)) (let ([h (concat (file->docname f) (*html-suffix*))]) (and (file-exists? h) (ref~: :title "on-line documentation for the '": (regexp-replace #rx"\\.ss$" f "") :"' module" h (tt: txt))))) (define-values (r* r**) (let* ([(no-verb f) (lambda (x . xs) (thunk (if (*verbatim?*) x (f x . xs))))] [(symbol* _ s) (let* ([b (find-binding (string->symbol s))] [s (if b (ref~: :title "documentation for '":(doc-name b):"'" (echos :s- (file->docname (doc-name (doc-parent b))) (*html-suffix*) "#" (doc-name b)) (tt: s)) (tt: s))]) (list "'": s :"'"))] [(char* _ c) "\"":(tt: c):"\""] [(tt* c) (tt: c)] [(file* _ f) (let* ([tt (tt: f)] [l (or (swindle-doc: f) (swindle-file: f))]) "\"":(or l tt):"\"")] [(www* u . _) (let ([url (concat "http://" (regexp-replace #rx"^[^/]*$" (regexp-replace #rx"^http://" u "") "\\0/"))]) (ref~: url (tt: u)))] [doc-replacements `((#rx"`([^ `'\"]+)'" ,symbol*))] [replacements `((#rx"<[^<> .,;'\"]+>|[:&][<>{}:a-z0-9*][<>{}:a-z0-9*+-]*" ,(no-verb tt*)) (#rx"`([^ `'\"]+|\\([^`']*\\))'" ,(no-verb symbol*)) (#rx"\"([^ ])\"" ,(no-verb char*)) (#rx"\"([^ `'\".]+\\.[^ `'\".]+)\"" ,(no-verb file*)) (#rx"[a-zA-Z0-9-]*@[a-zA-Z0-9.-]*[a-zA-Z0-9]" ,mailto~) (#rx"(http://|www\\.)[a-zA-Z0-9./-]+[a-zA-Z0-9/]" ,www*))]) (values (lambda (x) (do-replacements replacements x)) (lambda (x) ;;(do-replacements doc-replacements x) x)))) (define ((dochtml: . lines) &keys title) (html: (head: (title: "Documentation for ": title :".ss")) (body: ::args body-args (h1: :align 'center "Documentation for \"":(swindle-file: (format "~a.ss" title)):"\"") hr: . lines))) (define keyword-index '()) (dolist [md module-descriptions] (with-slots md [name lines docs html-doc] (set! html-doc (html-obj! :name (file->docname name) :title name (dochtml: (mapply p: (split-by-empty-lines (r* lines))) hr: (let ([text '()]) (define cur-table #f) (define (bslash x) (regexp-replace* #rx"\\\\" x "\\\\\\\\")) (define (add! . ls) (table!) (if (and (not (null? ls)) (every string? ls)) (let loop ([ls ls] [r '()]) (define (p!) (unless (null? r) (push! (apply pre: (map (lambda (l) (list (r** (bslash l)) "\n")) (reverse! r))) text))) (if (null? ls) (p!) (regexp-case (car ls) [(#rx"^ *\\*\\*\\* *(.*[^ ]) *" h) (p!) (push! (h3: h) text) (loop (cdr ls) '())] (else (loop (cdr ls) (cons (car ls) r)))))) (dolist [l ls] (push! (r* l) text)))) (define (table!) (when cur-table (let ([t (apply table*: ::args def-table-args (reverse! cur-table))]) (set! cur-table #f) (add! t)))) (define (row! . data) (if cur-table (push! data cur-table) (set! cur-table (list data)))) (define prev-was-empty #f) (dolist [d docs] (if (binding-d? d) (with-slots d [name definition type classinfo lines] (push! (list html-doc name) keyword-index) (row! (name~: name (tt: (b: definition))) (list :align 'right "[": type :"]")) (unless (null? lines) (add! . lines)) (when (and classinfo (not prev-was-empty)) (add! (echos :s- " Instance of `" (car classinfo) "'" (if (null? (cdr classinfo)) "" (echos :s- ", subclass of " :symbols (cdr classinfo))) "."))) (set! prev-was-empty (null? lines))) (with-slots d [name lines] (when name (add! hr: (h2: name))) (unless (null? lines) (add! . lines)) (set! prev-was-empty #f)))) (apply text: (reverse! text))) (counter-thing (echos :s- "swindle/" (doc-name md)))))))) (defhtml _keyword-index (html: (head: (title: "Swindle Index")) (body: ::args body-args (h1: "Swindle Index") (let ([curchar #f] [chars '()]) (text: hr: (delay (big: (apply center: (map (lambda (ch) "[":(ref~: "#": ch ch):"]") (reverse chars))))) hr: (mapply (lambda (page symbol) (text: (let ([ch (char-upcase (string-ref (as symbol) 0))]) (unless (eq? curchar ch) (set! curchar ch) (push! ch chars) (big: (h1: (table*: ::args def-table-args (list :align 'center (name~: ch (strong: ch)))))))) (ref~: (html-ref-name page):"#": symbol symbol) br:)) (sort keyword-index (lambda (x y) (string (2nd x)) (as (2nd y)))))))) hr: (counter-thing "swindle/keywords")))) (defhtml _index (html: (head: (title: "Swindle")) (let ([prolog (r* prolog)] [feature-list (r* feature-list)] [source-descriptions (r* source-descriptions)] [quick-copyright (r* quick-copyright)]) (define (scan dir &optional (prefix "")) (parameterize ([current-directory dir]) (let* ([files (sort (directory-list) (file-precedes? prefix))] [dirs (filter directory-exists? files)] [files (filter (lambda (x) (not (memq x dirs))) files)] [dirs (filter (lambda (d) (not (equal? d "compiled"))) dirs)]) (apply itemize: (append (map (lambda (f) (text: (tt: prefix : (ref~: (concat src-dir "/" prefix f) (b: f))) (get-file-description (concat prefix f)))) files) (map (lambda (d) (text: (b: (tt: prefix : d) : ":") (get-file-description (concat prefix d)) (scan d (concat prefix d "/")))) dirs)))))) (body: ::args body-args (h1: (center: (i: (size+4: "Swindle"))) (gif~ "SwindleFlash" "Swindle" :align 'right :hspace 20)) hr: (mapply p: (split-by-empty-lines (cdar prolog))) hr: (h2: "Downloading Swindle") (let* ([read-version (lambda () (regexp-replace* #rx"^.* ([^ ]*) *$" (read-line) "\\1"))] [(values swindle-version plt-version) (with-input-from-file (concat src-dir "/version.txt") (thunk (values (read-version) (read-version))))]) (text: (p: "To download Swindle for PLT v": plt-version :", get" (ref~ plt-file) "and install it with the PLT setup tool." "(Older version files:" (mapconcat identity (list-of (ref~: f (2nd m)) (f <- (sort (directory-list) string