suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

misc improvements

Browse Source 
svn: r7190
This commit is contained in:
Eli Barzilay 2007-08-27 01:54:18 +00:00
parent b4dd7515c4
commit 4b7a9ce822
1 changed files with 104 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
collects/help/servlets/private/html.ss
View File

@ -1,6 +1,6 @@
(module html mzscheme (module html mzscheme
(provide (all-defined)) (provide (all-defined))
(require (lib "servlets/private/search-util.ss" "help") (require (lib "servlets/private/search-util.ss" "help")
(lib "servlet.ss" "web-server") (lib "servlet.ss" "web-server")
(lib "etc.ss") (lib "etc.ss")
@ -11,177 +11,160 @@
;;; ;;;
;;; STYLESHEET ;;; STYLESHEET
;;; ;;;
; css : -> string ;; css : -> string
; fetch stylesheet from disk ;; fetch stylesheet from disk
; (convenient during development) ;; (convenient during development)
(define (css) (define (css)
(define (port->string port) (define (port->string port)
(let ([os (open-output-string)]) (let ([os (open-output-string)])
(copy-port port os) (copy-port port os)
(get-output-string os))) (get-output-string os)))
(call-with-input-file (call-with-input-file (build-path (this-expression-source-directory)
(build-path (this-expression-source-directory) "helpdesk.css")
"helpdesk.css")
port->string)) port->string))
;;; ;;;
;;; GENERATE XML FOR THE ENTIRE PAGE ;;; GENERATE XML FOR THE ENTIRE PAGE
;;; ;;;
; html-page : xexpr (list xml) (list xml) -> xexpr ;; html-page : xexpr (list xml) (list xml) -> xexpr
(define/kw (html-page #:key title (top '()) (bodies '()) body) (define/kw (html-page #:key title (top '()) (bodies '()) body)
(let ([bodies (if body (append bodies (list body)) bodies)]) (let ([bodies (if body (append bodies (list body)) bodies)])
`(html `(html
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8"))) (meta ([http-equiv "Content-Type"] [content "text/html;charset=UTF-8"]))
(meta ((name "generator") (content "PLT Scheme"))) (meta ([name "generator"] [content "PLT Scheme"]))
; TODO: Ask Eli what exactly to put here in the online version ;; TODO: Ask Eli what exactly to put here in the online version
;(script ((src "http://www.google-analytics.com/urchin.js") (type "text/javascript"))) ;; (script ((src "http://www.google-analytics.com/urchin.js") (type "text/javascript")))
;(script ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();") ;; (script ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();")
(head (title ,title) (head
(style ((type "text/css")) "\n" (title ,title)
,(css)) (style ([type "text/css"]) "\n" ,(css))
; TODO: Check the icons work in online version ;; TODO: Check the icons work in online version
(link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"])) (link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"]))
(link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"]))) (link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"])))
(body (body ,@top ,@bodies))))
,@top
,@bodies)))) ;; html-select : string (list string) natural -> xexpr
; html-select : string (list string) natural -> xexpr
(define (html-select name descriptions selected-index) (define (html-select name descriptions selected-index)
`(select ((name ,name)) `(select ([name ,name])
,@(let loop ([i 0] [ds descriptions] [xexprs '()]) ,@(let loop ([i 0] [ds descriptions] [xexprs '()])
(cond (cond [(null? ds) (reverse! xexprs)]
[(null? ds) (reverse! xexprs)] [(= i selected-index)
[(= i selected-index) (loop (+ i 1) (cdr ds) (loop (+ i 1) (cdr ds)
(cons (car ds) (list* (car ds) `(option ((selected "selected")))
(cons `(option ((selected "selected"))) xexprs))]
xexprs)))] [else (loop (+ i 1) (cdr ds)
[else (loop (+ i 1) (cdr ds) (list* (car ds) `(option) xexprs))]))))
(cons (car ds)
(cons `(option)
xexprs)))]))))
;;; ;;;
;;; THE TOP SEARCH BAR ;;; THE TOP SEARCH BAR
;;; (online version online) ;;; (online version online)
; html-top : requrest -> (list xml) ;; html-top : requrest -> (list xml)
(define (html-top request) (define (html-top request)
(let* ([bindings (request-bindings request)] (define bindings (request-bindings request))
[search-string (get-binding bindings 'search-string "")] (define search-string (get-binding bindings 'search-string ""))
[search-type (get-binding bindings 'search-type search-type-default)] (define search-type (get-binding bindings 'search-type search-type-default))
[match-type (get-binding bindings 'match-type match-type-default)]) (define match-type (get-binding bindings 'match-type match-type-default))
`((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; ")) `((div ([style "border: 1px solid black; padding: 3px; background-color: #74ca56;"])
(table ((width "98%")) (table ([width "98%"])
(tr (td ((align "right")) (tr (td ([align "right"])
(img ((class "image") (img ([class "image"]
(src "http://www.plt-scheme.org/plt-green.jpg") [src "http://www.plt-scheme.org/plt-green.jpg"]
(width "133") (height "128") (alt "[icon]")))) [width "133"] [height "128"] [alt "[icon]"])))
(td ((align "center")) (td ([align "center"])
(form ((method "GET") (action ,url-helpdesk-results)) (form ([method "GET"] [action ,url-helpdesk-results])
(table (tr (td ((align "center") (class "sansa")) (table (tr (td ([align "center"] [class "sansa"])
"Search the Help Desk for documentation on: " )) "Search the Help Desk for documentation on: "))
(tr (td (input ((name "search-string") (type "text") (size "70") (tr (td (input ([name "search-string"] [type "text"]
(value ,search-string)))) [size "70"] [value ,search-string])))
(td 'nbsp 'nbsp (button "Search"))) (td nbsp nbsp (button "Search")))
(tr (td ((align "center")) (tr (td ([align "center"])
,(html-select "search-type" ,(html-select "search-type"
search-type-descriptions search-type-descriptions
(search-type->index search-type)) (search-type->index search-type))
'nbsp 'nbsp 'nbsp 'nbsp nbsp nbsp nbsp nbsp
,(html-select "match-type" ,(html-select "match-type"
match-type-descriptions match-type-descriptions
(match-type->index match-type))))))) (match-type->index match-type)))))))
(td 'nbsp) (td 'nbsp) (td 'nbsp) (td nbsp) (td nbsp) (td nbsp)
(td (table (tr (td ((align "center")) (td (table (tr (td ([align "center"])
(a ((href ,url-helpdesk-home) (class "sansa")) "HOME"))) (a ([href ,url-helpdesk-home] [class "sansa"])
(tr (td ((align "center")) "HOME")))
(a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS"))))) (tr (td ([align "center"])
))) (a ([href ,url-helpdesk-manuals] [class "sansa"])
(p " ")))) "MANUALS"))))))))
(p " ")))
;;; ;;;
;;; BINDINGS ;;; BINDINGS
;;; ;;;
(define (get-binding bindings name default-value) (define (get-binding bindings name default-value)
(if (exists-binding? name bindings) (if (exists-binding? name bindings)
(extract-binding/single name bindings) (extract-binding/single name bindings)
default-value)) default-value))
(define (delete-binding id bindings) (define (delete-binding id bindings)
(cond (cond [(null? bindings) '()]
[(null? bindings) [(equal? (binding-id (car bindings)) id) (cdr bindings)]
'()] [else (cons (car bindings) (delete-binding id (cdr bindings)))]))
[(equal? (binding-id (car bindings)) id)
(cdr bindings)]
[else
(cons (car bindings)
(delete-binding id (cdr bindings)))]))
(define (delete-bindings ids bindings) (define (delete-bindings ids bindings)
(cond [(null? ids) bindings] (if (null? ids)
[else (delete-bindings (cdr ids) bindings
(delete-binding (car ids) (delete-bindings (cdr ids) (delete-binding (car ids) bindings))))
bindings))]))
(define (display-binding binding) (define (display-binding binding)
; for debugging ;; for debugging
(display "binding: ") (printf "binding: ~a=~s\n"
(display (binding-id binding)) (binding-id binding)
(display "=") (binding:form-value binding)))
(write (binding:form-value binding))
(newline))
;;; ;;;
;;; SEARCH DESCRIPTIONS AND SHORT NAMES ;;; SEARCH DESCRIPTIONS AND SHORT NAMES
;;; ;;;
(define (search-type-description i) (define (search-type-description i)
(cadr (list-ref search-types i))) (cadr (list-ref search-types i)))
(define (match-type-description i) (define (match-type-description i)
(cadr (list-ref match-types i))) (cadr (list-ref match-types i)))
(define reversed-search-types (define reversed-search-types
(map reverse search-types)) (map reverse search-types))
(define reversed-match-types (define reversed-match-types
(map reverse match-types)) (map reverse match-types))
(define (search-type-description->search-type desc) (define (search-type-description->search-type desc)
(cond [(assoc desc reversed-search-types) => cadr] (cond [(assoc desc reversed-search-types) => cadr]
[else search-type-default])) [else search-type-default]))
(define (match-type-description->match-type desc) (define (match-type-description->match-type desc)
(cond [(assoc desc reversed-match-types) => cadr] (cond [(assoc desc reversed-match-types) => cadr]
[else match-type-default])) [else match-type-default]))
(define search-type->index (define search-type->index
(let* ([types (map car search-types)] (let* ([types (map car search-types)]
[len (length types)]) [len (length types)])
(lambda (t) (lambda (t)
(cond (cond [(member t types) => (lambda (tail) (- len (length tail)))]
[(member t types) [else -1]))))
=> (lambda (tail) (- len (length tail)))]
[else -1]))))
(define match-type->index (define match-type->index
(let* ([types (map car match-types)] (let* ([types (map car match-types)]
[len (length types)]) [len (length types)])
(lambda (t) (lambda (t)
(cond (cond [(member t types) => (lambda (tail) (- len (length tail)))]
[(member t types) [else -1]))))
=> (lambda (tail) (- len (length tail)))]
[else -1]))))
(define search-type-descriptions (define search-type-descriptions
(map cadr search-types)) (map cadr search-types))
(define match-type-descriptions (define match-type-descriptions
(map cadr match-types)) (map cadr match-types))
) )