115 lines
3.7 KiB
Scheme
115 lines
3.7 KiB
Scheme
(module util mzscheme
|
|
(require (lib "file.ss")
|
|
(lib "list.ss")
|
|
(lib "xml.ss" "xml")
|
|
(lib "uri-codec.ss" "net")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "contract.ss"))
|
|
|
|
;; would be nice if this could use version:version from the framework.
|
|
(define (plt-version)
|
|
(let ([mz-version (version)]
|
|
[stamp-collection
|
|
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
|
|
(collection-path "repos-time-stamp"))])
|
|
(if (and stamp-collection
|
|
(file-exists? (build-path stamp-collection "stamp.ss")))
|
|
(format "~a-svn~a" mz-version
|
|
(dynamic-require '(lib "stamp.ss" "repos-time-stamp") 'stamp))
|
|
mz-version)))
|
|
|
|
(define home-page
|
|
`(a ([href "/servlets/home.ss"] [target "_top"])
|
|
,(string-constant plt:hd:home)))
|
|
|
|
(define (get-pref/default pref default)
|
|
(get-preference pref (lambda () default)))
|
|
|
|
(define (get-bool-pref/default pref default)
|
|
(let ([raw-pref (get-pref/default pref default)])
|
|
(if (string=? raw-pref "false") #f #t)))
|
|
|
|
(define (put-prefs names vals)
|
|
(put-preferences names vals))
|
|
|
|
(define search-height-default "85")
|
|
(define search-bg-default "lightsteelblue")
|
|
(define search-text-default "black")
|
|
(define search-link-default "darkblue")
|
|
|
|
(define *the-highlight-color* "forestgreen")
|
|
|
|
;; string xexpr ... -> xexpr
|
|
(define (with-color color . s)
|
|
`(font ([color ,color]) ,@s))
|
|
|
|
;; xexpr ... -> xexpr
|
|
(define (color-highlight . s)
|
|
(apply with-color *the-highlight-color* s))
|
|
|
|
(define repos-or-nightly-build?
|
|
(let ([helpdir (collection-path "help")])
|
|
(lambda ()
|
|
(or (directory-exists? (build-path helpdir ".svn"))
|
|
(directory-exists? (build-path helpdir "CVS"))
|
|
(with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
|
(collection-path "repos-time-stamp"))))))
|
|
|
|
; string string -> xexpr
|
|
(define (collection-doc-link coll txt)
|
|
(let ([coll-file (build-path (collection-path coll) "doc.txt")])
|
|
(if (file-exists? coll-file)
|
|
`(a ((href
|
|
,(format
|
|
"~a?file=~a&name=~a&caption=Documentation for the ~a collection"
|
|
"/servlets/doc-anchor.ss"
|
|
(uri-encode (path->string coll-file))
|
|
coll
|
|
coll)))
|
|
,txt)
|
|
"")))
|
|
|
|
;; (listof string) -> string
|
|
;; result is forward-slashed web path
|
|
;; e.g. ("foo" "bar") -> "foo/bar"
|
|
(define (fold-into-web-path lst)
|
|
(foldr (lambda (s a) (if a (string-append s "/" a) s)) #f lst))
|
|
|
|
(define (format-collection-message s)
|
|
`(b ((style "color:green")) ,s))
|
|
|
|
(define (make-javascript . ss)
|
|
`(script ([language "Javascript"])
|
|
,(make-comment (apply string-append "\n"
|
|
(map (lambda (s) (string-append s "\n")) ss)))))
|
|
|
|
(define (redir-javascript k-url)
|
|
(make-javascript "function redir() {"
|
|
(string-append " document.location.href=\"" k-url "\"")
|
|
"}"))
|
|
|
|
(define (onload-redir secs)
|
|
(string-append "setTimeout(\"redir()\","
|
|
(number->string (* secs 1000)) ")"))
|
|
|
|
(provide/contract
|
|
[fold-into-web-path ((listof string?) . -> . string?)])
|
|
|
|
(provide get-pref/default
|
|
get-bool-pref/default
|
|
put-prefs
|
|
repos-or-nightly-build?
|
|
search-height-default
|
|
search-bg-default
|
|
search-text-default
|
|
search-link-default
|
|
color-highlight
|
|
with-color
|
|
collection-doc-link
|
|
home-page
|
|
format-collection-message
|
|
plt-version
|
|
make-javascript
|
|
redir-javascript
|
|
onload-redir))
|