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