diff --git a/collects/help/launch.ss b/collects/help/launch.ss
index b89449859f..1265cff70f 100644
--- a/collects/help/launch.ss
+++ b/collects/help/launch.ss
@@ -1,36 +1,36 @@
-;;; launch.ss
-
-; PURPOSE
-; This file launches a web-server serving an online
-; version of the HelpDesk pages.
-; This is intended for testing the online version,
-; not as a way of deplying it.
-
-; NOTES
-; The web-server uses the port given by internal-port
-; in "collects/help/private/internal-hp.ss".
-
-; Change the parameter current-helpdesk-platform
-; in "collects/help/servlets/private/platform.ss"
-; to 'external-browser when testing the online version.
-
-; Startpage:
-; http://localhost:8000/servlets/home.ss
-; (where 8000 is the port given by internal-port)
-
-(require (lib "web-server.ss" "web-server")
- (lib "web-config-unit.ss" "web-server")
- "private/config.ss"
- "private/internal-hp.ss")
-
-; start the HelpDesk server, and store a shutdown
-(define shutdown
- (serve/web-config@ config))
-
-(display "Did you remember to change current-helpdesk-platform in platform.ss?\n\n")
-(display (format "Start here: http://~a:~a/servlets/home.ss\n\n"
- internal-host internal-port))
-
-(display "Press enter to shutdown.\n")
-(read-line)
-;(shutdown)
+;;; launch.ss
+
+; PURPOSE
+; This file launches a web-server serving an online
+; version of the HelpDesk pages.
+; This is intended for testing the online version,
+; not as a way of deplying it.
+
+; NOTES
+; The web-server uses the port given by internal-port
+; in "collects/help/private/internal-hp.ss".
+
+; Change the parameter current-helpdesk-platform
+; in "collects/help/servlets/private/platform.ss"
+; to 'external-browser when testing the online version.
+
+; Startpage:
+; http://localhost:8000/servlets/home.ss
+; (where 8000 is the port given by internal-port)
+
+(require (lib "web-server.ss" "web-server")
+ (lib "web-config-unit.ss" "web-server")
+ "private/config.ss"
+ "private/internal-hp.ss")
+
+; start the HelpDesk server, and store a shutdown
+(define shutdown
+ (serve/web-config@ config))
+
+(display "Did you remember to change current-helpdesk-platform in platform.ss?\n\n")
+(display (format "Start here: http://~a:~a/servlets/home.ss\n\n"
+ internal-host internal-port))
+
+(display "Press enter to shutdown.\n")
+(read-line)
+;(shutdown)
diff --git a/collects/help/servlets/private/helpdesk.css b/collects/help/servlets/private/helpdesk.css
index 844d06d6d0..266199c1de 100644
--- a/collects/help/servlets/private/helpdesk.css
+++ b/collects/help/servlets/private/helpdesk.css
@@ -1,6 +1,6 @@
-.sansa { font-family: Arial, Helvetica, sans-serif; }
-.sansa a:link { color: #3a652b; text-decoration: none; background-color: transparent; }
-.sansa a:visited { color: #3a652b; text-decoration: none; background-color: transparent; }
-.sansa a:active { color: #3a652b; text-decoration: none; background-color: #97d881; }
-.sansa a:hover { color: #3a652b; text-decoration: none; background-color: #97d881; }
-body { background-color: white; font-family: Arial, Helvetica, sans-serif; }
+.sansa { font-family: Arial, Helvetica, sans-serif; }
+.sansa a:link { color: #3a652b; text-decoration: none; background-color: transparent; }
+.sansa a:visited { color: #3a652b; text-decoration: none; background-color: transparent; }
+.sansa a:active { color: #3a652b; text-decoration: none; background-color: #97d881; }
+.sansa a:hover { color: #3a652b; text-decoration: none; background-color: #97d881; }
+body { background-color: white; font-family: Arial, Helvetica, sans-serif; }
diff --git a/collects/help/servlets/private/html.ss b/collects/help/servlets/private/html.ss
index 90f6973e93..2db474c14d 100644
--- a/collects/help/servlets/private/html.ss
+++ b/collects/help/servlets/private/html.ss
@@ -1,187 +1,187 @@
-(module html mzscheme
- (provide (all-defined))
-
- (require (lib "servlets/private/search-util.ss" "help")
- (lib "servlet.ss" "web-server")
- (lib "etc.ss")
- (lib "kw.ss")
- (lib "port.ss")
- "url.ss")
-
- ;;;
- ;;; STYLESHEET
- ;;;
-
- ; 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")
- port->string))
-
- ;;;
- ;;; GENERATE XML FOR THE ENTIRE PAGE
- ;;;
-
- ; 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
- (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)))]))))
-
- ;;;
- ;;; THE TOP SEARCH BAR
- ;;; (online version online)
-
- ; 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 " "))))
-
-
- ;;;
- ;;; BINDINGS
- ;;;
-
- (define (get-binding bindings name default-value)
- (if (exists-binding? name bindings)
- (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)))]))
-
- (define (delete-bindings ids bindings)
- (cond [(null? ids) bindings]
- [else (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))
-
- ;;;
- ;;; 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]))))
-
- (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]))))
-
- (define search-type-descriptions
- (map cadr search-types))
-
- (define match-type-descriptions
- (map cadr match-types))
-
+(module html mzscheme
+ (provide (all-defined))
+
+ (require (lib "servlets/private/search-util.ss" "help")
+ (lib "servlet.ss" "web-server")
+ (lib "etc.ss")
+ (lib "kw.ss")
+ (lib "port.ss")
+ "url.ss")
+
+ ;;;
+ ;;; STYLESHEET
+ ;;;
+
+ ; 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")
+ port->string))
+
+ ;;;
+ ;;; GENERATE XML FOR THE ENTIRE PAGE
+ ;;;
+
+ ; 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
+ (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)))]))))
+
+ ;;;
+ ;;; THE TOP SEARCH BAR
+ ;;; (online version online)
+
+ ; 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 " "))))
+
+
+ ;;;
+ ;;; BINDINGS
+ ;;;
+
+ (define (get-binding bindings name default-value)
+ (if (exists-binding? name bindings)
+ (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)))]))
+
+ (define (delete-bindings ids bindings)
+ (cond [(null? ids) bindings]
+ [else (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))
+
+ ;;;
+ ;;; 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]))))
+
+ (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]))))
+
+ (define search-type-descriptions
+ (map cadr search-types))
+
+ (define match-type-descriptions
+ (map cadr match-types))
+
)
\ No newline at end of file
diff --git a/collects/help/servlets/private/platform.ss b/collects/help/servlets/private/platform.ss
index e706c36dee..fedf57083b 100644
--- a/collects/help/servlets/private/platform.ss
+++ b/collects/help/servlets/private/platform.ss
@@ -1,11 +1,11 @@
-(module platform mzscheme
- (provide current-helpdesk-platform)
-
- ; internal browser or external browser?
- ; (used to produce simpler html for the internal browser)
- (define current-helpdesk-platform
- (make-parameter
- 'internal-browser-simple ; main page only
- ; 'internal-browser ; menu + main page
- ; 'external-browser
+(module platform mzscheme
+ (provide current-helpdesk-platform)
+
+ ; internal browser or external browser?
+ ; (used to produce simpler html for the internal browser)
+ (define current-helpdesk-platform
+ (make-parameter
+ 'internal-browser-simple ; main page only
+ ; 'internal-browser ; menu + main page
+ ; 'external-browser
)))
\ No newline at end of file
diff --git a/collects/help/servlets/private/split-screen.ss b/collects/help/servlets/private/split-screen.ss
index a6e53d526d..43cb9342df 100644
--- a/collects/help/servlets/private/split-screen.ss
+++ b/collects/help/servlets/private/split-screen.ss
@@ -1,125 +1,125 @@
-(module split-screen mzscheme
- (require (lib "match.ss")
- (only (lib "misc.ss" "swindle") mappend)
- "html.ss"
- "url.ss"
- "platform.ss")
-
- ; These items are common to all split screens
-
- (define left-header-items
- `((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
-
- (define left-footer-items
- (case (current-helpdesk-platform)
- [(internal-browser)
- '(nbsp)]
- [else
- '(nbsp
- (VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
- (VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
- (VERBATIM (nobr
- (small ((class "sansa"))
- (a ((href "http://www.plt-scheme.org/")) "PLT")
- nbsp "|" nbsp
- (a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
- nbsp "|" nbsp
- (a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
- nbsp "|" nbsp
- (a ((href "http://www.htdp.org/")) "HtDP") nbsp
- "|" nbsp
- (a ((href "http://planet.plt-scheme.org/")) "PLaneT")
- nbsp)))
- ; Google Search for PLT Documentation
- #;(VERBATIM (div ((align "center"))
- (div ((style "display: inline; margin: 0; white-space: nowrap;"))
- ; The Google "Search Documentation" field and button
- (form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
- (action "http://www.plt-scheme.org/search/")
- (style "display: inline; margin: 0;"))
- (input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
- (input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
- (input ((type "hidden") (name "hq") (value "more:plt")))
- (input ((type "hidden") (name "cxq") (value "more:docs")))
- (input ((type "submit") (name "sa") (value "Search Documentation")
- (style "font-size: 75%;")))
- (input ((type "hidden") (name "cof") (value "FORID:9")))))
- nbsp)))]))
-
-
- ; the internal browser makes a "split" screen by having the left items at the top,
- ; and the right items at the bottom
- (define (make-split-page/internal-browser title top-items left-items right-header right-items)
- (html-page
- #:title title
- #:body `(div ,(html-left-items (append #;left-header-items
- left-items left-footer-items))
- (hr)
- ,@(html-right-items right-items))))
-
- (define (make-simple-page/internal-browser title top-items left-items right-header right-items)
- (html-page
- #:title title
- #:body (if (equal? left-items "home")
- `(div ,(html-left-items right-items))
- `(div ,@(html-right-items right-items)))))
-
- ; an external is capable of displaying a proper split screen
- (define (make-split-page title top-items left-items right-header right-items)
- (html-page
- #:title title
- #:bodies `(,@top-items ,(make-split-screen left-items right-header right-items))))
-
-
- (define (make-split-screen left-items right-header right-items)
- `(table ((height "80%") (width "100%") (align "center") (border "0") (cellspacing "0") (cellpadding "30"))
- (tr ((valign "top"))
- (td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
- ; LEFT TABLE
- (table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
- #;(tr (td ((align "center"))
- (img ((src "http://www.plt-scheme.org/plt-green.jpg")
- (width "133") (height "128") (alt "[icon]")))))
- ,(html-left-items (append left-header-items left-items left-footer-items)))
- (td ((height "100%") (width "50%") (align "left") (valign "top"))
- ; RIGHT TABLE
- (table ((width "80%") (class "sansa") (align "center") (border "0")
- (cellpadding "0") (cellspacing "0"))
- (tr (td (h1 ,right-header)))
- ;(tr (td (small (small nbsp))))
- (tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
- ,@(html-right-items right-items))))))))))
-
- ;;;
- ;;; ITEM FORMATTING
- ;;; (ad hoc markup inherited)
-
- (define (html-left-items items)
- `(tr (td (table ,@(mappend html-left-item items)))))
-
- (define (html-left-item item)
- (match item
- ['UP (list '(font ((size "-2")) nbsp))]
- ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
- [('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
- [(header) (list `(tr (td #;((colspan "2")) ,header)))]
- [(header body ...) (list `(tr (td #;((colspan "2")) ,header))
- `(tr (td ,@body)))]
- [other (list other)]))
-
- (define (html-right-items items)
- (mappend html-right-item items))
-
- (define (html-right-item item)
- (match item
- ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
- [('VERBATIM item) item]
- [(body ...) (list body)]))
-
-
- (provide make-split-screen
- make-split-page
- make-split-page/internal-browser
- make-simple-page/internal-browser)
-
+(module split-screen mzscheme
+ (require (lib "match.ss")
+ (only (lib "misc.ss" "swindle") mappend)
+ "html.ss"
+ "url.ss"
+ "platform.ss")
+
+ ; These items are common to all split screens
+
+ (define left-header-items
+ `((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
+
+ (define left-footer-items
+ (case (current-helpdesk-platform)
+ [(internal-browser)
+ '(nbsp)]
+ [else
+ '(nbsp
+ (VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
+ (VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
+ (VERBATIM (nobr
+ (small ((class "sansa"))
+ (a ((href "http://www.plt-scheme.org/")) "PLT")
+ nbsp "|" nbsp
+ (a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
+ nbsp "|" nbsp
+ (a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
+ nbsp "|" nbsp
+ (a ((href "http://www.htdp.org/")) "HtDP") nbsp
+ "|" nbsp
+ (a ((href "http://planet.plt-scheme.org/")) "PLaneT")
+ nbsp)))
+ ; Google Search for PLT Documentation
+ #;(VERBATIM (div ((align "center"))
+ (div ((style "display: inline; margin: 0; white-space: nowrap;"))
+ ; The Google "Search Documentation" field and button
+ (form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
+ (action "http://www.plt-scheme.org/search/")
+ (style "display: inline; margin: 0;"))
+ (input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
+ (input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
+ (input ((type "hidden") (name "hq") (value "more:plt")))
+ (input ((type "hidden") (name "cxq") (value "more:docs")))
+ (input ((type "submit") (name "sa") (value "Search Documentation")
+ (style "font-size: 75%;")))
+ (input ((type "hidden") (name "cof") (value "FORID:9")))))
+ nbsp)))]))
+
+
+ ; the internal browser makes a "split" screen by having the left items at the top,
+ ; and the right items at the bottom
+ (define (make-split-page/internal-browser title top-items left-items right-header right-items)
+ (html-page
+ #:title title
+ #:body `(div ,(html-left-items (append #;left-header-items
+ left-items left-footer-items))
+ (hr)
+ ,@(html-right-items right-items))))
+
+ (define (make-simple-page/internal-browser title top-items left-items right-header right-items)
+ (html-page
+ #:title title
+ #:body (if (equal? left-items "home")
+ `(div ,(html-left-items right-items))
+ `(div ,@(html-right-items right-items)))))
+
+ ; an external is capable of displaying a proper split screen
+ (define (make-split-page title top-items left-items right-header right-items)
+ (html-page
+ #:title title
+ #:bodies `(,@top-items ,(make-split-screen left-items right-header right-items))))
+
+
+ (define (make-split-screen left-items right-header right-items)
+ `(table ((height "80%") (width "100%") (align "center") (border "0") (cellspacing "0") (cellpadding "30"))
+ (tr ((valign "top"))
+ (td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
+ ; LEFT TABLE
+ (table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
+ #;(tr (td ((align "center"))
+ (img ((src "http://www.plt-scheme.org/plt-green.jpg")
+ (width "133") (height "128") (alt "[icon]")))))
+ ,(html-left-items (append left-header-items left-items left-footer-items)))
+ (td ((height "100%") (width "50%") (align "left") (valign "top"))
+ ; RIGHT TABLE
+ (table ((width "80%") (class "sansa") (align "center") (border "0")
+ (cellpadding "0") (cellspacing "0"))
+ (tr (td (h1 ,right-header)))
+ ;(tr (td (small (small nbsp))))
+ (tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
+ ,@(html-right-items right-items))))))))))
+
+ ;;;
+ ;;; ITEM FORMATTING
+ ;;; (ad hoc markup inherited)
+
+ (define (html-left-items items)
+ `(tr (td (table ,@(mappend html-left-item items)))))
+
+ (define (html-left-item item)
+ (match item
+ ['UP (list '(font ((size "-2")) nbsp))]
+ ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
+ [('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
+ [(header) (list `(tr (td #;((colspan "2")) ,header)))]
+ [(header body ...) (list `(tr (td #;((colspan "2")) ,header))
+ `(tr (td ,@body)))]
+ [other (list other)]))
+
+ (define (html-right-items items)
+ (mappend html-right-item items))
+
+ (define (html-right-item item)
+ (match item
+ ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
+ [('VERBATIM item) item]
+ [(body ...) (list body)]))
+
+
+ (provide make-split-screen
+ make-split-page
+ make-split-page/internal-browser
+ make-simple-page/internal-browser)
+
)
\ No newline at end of file
diff --git a/collects/help/servlets/private/url.ss b/collects/help/servlets/private/url.ss
index 0d0f1e7e32..b5b9433011 100644
--- a/collects/help/servlets/private/url.ss
+++ b/collects/help/servlets/private/url.ss
@@ -1,68 +1,68 @@
-(module url mzscheme
- (require "../../private/internal-hp.ss")
-
- (provide (all-defined))
-
- (define url-helpdesk-root
- (string-append
- "http://" internal-host ":" (number->string internal-port) "/servlets/"))
-
- (define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
- (define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
-
- (define (url-home-subpage subpage-str)
- (string-append url-helpdesk-home "?subpage=" subpage-str))
-
- (define (version-major)
- ; TODO: Fix this
- (cond [(regexp-match #px"^(\\d+).*$" (version))
- => cadr]
- [else "352"]))
-
- (define (url-manual-on-doc-server manual)
- (string-append
- "http://download.plt-scheme.org/doc/"
- (version-major) "/html/" manual "/"))
-
- (define (url-static doc manual path)
- (string-append url-helpdesk-root "static.ss/" doc "/" manual "/" path))
-
- (define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/")
- (define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/")
- (define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/")
- (define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
- (define url-external-send-bug-report "http://bugs.plt-scheme.org/")
- (define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/")
- (define url-external-planet "http://planet.plt-scheme.org/")
-
- (define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
- (define url-helpdesk-books (url-home-subpage "books"))
- (define url-helpdesk-documentation (url-home-subpage "documentation"))
- (define url-helpdesk-drscheme (url-home-subpage "drscheme"))
- (define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5"))
- (define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm"))
- (define url-helpdesk-faq (url-home-subpage "faq"))
- (define url-helpdesk-help (url-home-subpage "help"))
- (define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2"))
- (define url-helpdesk-known-bugs (url-home-subpage "known-bugs"))
- (define url-helpdesk-languages (url-home-subpage "languages"))
- (define url-helpdesk-libraries (url-home-subpage "libraries"))
- (define url-helpdesk-license (url-home-subpage "license"))
- (define url-helpdesk-manuals (url-home-subpage "manuals"))
- (define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
- (define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
- (define url-helpdesk-patches (url-home-subpage "patches"))
- (define url-helpdesk-program-design (url-home-subpage "program-design"))
- (define url-helpdesk-release (url-home-subpage "release"))
- (define url-helpdesk-release-notes (url-home-subpage "release-notes"))
- (define url-helpdesk-search (url-home-subpage "search"))
- (define url-helpdesk-software (url-home-subpage "software"))
- (define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
- (define url-helpdesk-teachscheme (url-home-subpage "teachscheme"))
- (define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP"))
- (define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC"))
- (define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm"))
- (define url-helpdesk-tour (url-home-subpage "tour"))
- (define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
-
+(module url mzscheme
+ (require "../../private/internal-hp.ss")
+
+ (provide (all-defined))
+
+ (define url-helpdesk-root
+ (string-append
+ "http://" internal-host ":" (number->string internal-port) "/servlets/"))
+
+ (define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
+ (define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
+
+ (define (url-home-subpage subpage-str)
+ (string-append url-helpdesk-home "?subpage=" subpage-str))
+
+ (define (version-major)
+ ; TODO: Fix this
+ (cond [(regexp-match #px"^(\\d+).*$" (version))
+ => cadr]
+ [else "352"]))
+
+ (define (url-manual-on-doc-server manual)
+ (string-append
+ "http://download.plt-scheme.org/doc/"
+ (version-major) "/html/" manual "/"))
+
+ (define (url-static doc manual path)
+ (string-append url-helpdesk-root "static.ss/" doc "/" manual "/" path))
+
+ (define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/")
+ (define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/")
+ (define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/")
+ (define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
+ (define url-external-send-bug-report "http://bugs.plt-scheme.org/")
+ (define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/")
+ (define url-external-planet "http://planet.plt-scheme.org/")
+
+ (define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
+ (define url-helpdesk-books (url-home-subpage "books"))
+ (define url-helpdesk-documentation (url-home-subpage "documentation"))
+ (define url-helpdesk-drscheme (url-home-subpage "drscheme"))
+ (define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5"))
+ (define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm"))
+ (define url-helpdesk-faq (url-home-subpage "faq"))
+ (define url-helpdesk-help (url-home-subpage "help"))
+ (define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2"))
+ (define url-helpdesk-known-bugs (url-home-subpage "known-bugs"))
+ (define url-helpdesk-languages (url-home-subpage "languages"))
+ (define url-helpdesk-libraries (url-home-subpage "libraries"))
+ (define url-helpdesk-license (url-home-subpage "license"))
+ (define url-helpdesk-manuals (url-home-subpage "manuals"))
+ (define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
+ (define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
+ (define url-helpdesk-patches (url-home-subpage "patches"))
+ (define url-helpdesk-program-design (url-home-subpage "program-design"))
+ (define url-helpdesk-release (url-home-subpage "release"))
+ (define url-helpdesk-release-notes (url-home-subpage "release-notes"))
+ (define url-helpdesk-search (url-home-subpage "search"))
+ (define url-helpdesk-software (url-home-subpage "software"))
+ (define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
+ (define url-helpdesk-teachscheme (url-home-subpage "teachscheme"))
+ (define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP"))
+ (define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC"))
+ (define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm"))
+ (define url-helpdesk-tour (url-home-subpage "tour"))
+ (define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
+
)
\ No newline at end of file
diff --git a/collects/help/servlets/static.ss b/collects/help/servlets/static.ss
index f2a782c68f..51998a2df5 100644
--- a/collects/help/servlets/static.ss
+++ b/collects/help/servlets/static.ss
@@ -1,124 +1,124 @@
-; Serve static documentation.
-; A search bar is added on top of the screen, when an external browser is used.
-; (which is why we don't let the web-server serve the documentation directly)
-
-(module static mzscheme
- (require (lib "private/mime-types.ss" "web-server")
- (lib "servlet.ss" "web-server")
- (lib "xml.ss" "xml")
- (lib "match.ss")
- (lib "url.ss" "net")
- (lib "dirs.ss" "setup")
- (lib "port.ss")
- "../private/standard-urls.ss"
- "../private/docpos.ss"
- "private/platform.ss"
- "private/html.ss")
-
- (provide interface-version timeout start)
- (define interface-version 'v1)
- (define timeout +inf.0)
-
- ;;;
- ;;; PORT UTILS
- ;;;
-
- (define (port->string port)
- (let ([os (open-output-string)])
- (copy-port port os)
- (get-output-string os)))
-
- (define (file->string path)
- (call-with-input-file path
- port->string))
-
- (define (port->bytes port)
- (let ([ob (open-output-bytes)])
- (copy-port port ob)
- (get-output-bytes ob)))
-
- (define (file->bytes path)
- (call-with-input-file path
- port->bytes))
-
- ;;;
- ;;; MIME
- ;;;
-
- ; get-mime-type : path -> string
- (define get-mime-type
- (;make-get-mime-type
- make-path->mime-type
- (build-path (find-collects-dir)
- "web-server" "default-web-root" "mime.types")))
-
-
- (define (text-mime-type? file-path)
- (regexp-match #rx"^text"
- (get-mime-type file-path)))
-
- ;;;
- ;;; URL
- ;;;
-
- ; file-parts->file : string (list string) -> string
- ; (list "foo" "bar" "baz") => "foo/bar/baz"
- (define (file-parts->file manual fs)
- (apply string-append
- (let loop ([fs (cons manual fs)])
- (cond
- [(null? fs) (list "")]
- [(null? (cdr fs)) (list (car fs))]
- [else (cons (string-append (car fs) "/")
- (loop (cdr fs)))]))))
-
- ;;;
- ;;; TITLES
- ;;;
-
- (define (short->manual-title s)
- (match (assoc (string->path s) known-docs)
- [#f "Documentation"]
- [(path . long) long]))
-
- (define (start request)
- (with-errors-to-browser
- send/finish
- (lambda ()
- (let* ([bindings (request-bindings request)]
- [file (get-binding bindings 'file "no file")]
- [host (get-binding bindings 'host "no host")]
-
- [url (request-uri request)])
- (let-values
- ([(file-path host manual)
- (match (map path/param-path (url-path url))
- [("servlets" "static.ss" host manual . file-parts)
- (values (host+file->path host (file-parts->file manual file-parts))
- host
- manual)])])
- (cond
- [(not file-path)
- (list #"text/html"
- "Not foundFile not found.")]
- [(and (file-exists? file-path)
- (text-mime-type? file-path))
- (list (get-mime-type file-path)
- (string-append (xexpr->string
- (html-page
- #:title (short->manual-title manual)
- #:top (case (current-helpdesk-platform)
- [(internal-browser) '()]
- [(internal-browser-simple) '()]
- [else (html-top request)])
- #:body " "))
- (file->string file-path)))]
- [(file-exists? file-path)
- (list (get-mime-type file-path)
- (file->bytes file-path))]
- [else
- (list #"text/html"
- (format "Not foundFile not found: ~a"
- file-path))]))))))
-
+; Serve static documentation.
+; A search bar is added on top of the screen, when an external browser is used.
+; (which is why we don't let the web-server serve the documentation directly)
+
+(module static mzscheme
+ (require (lib "private/mime-types.ss" "web-server")
+ (lib "servlet.ss" "web-server")
+ (lib "xml.ss" "xml")
+ (lib "match.ss")
+ (lib "url.ss" "net")
+ (lib "dirs.ss" "setup")
+ (lib "port.ss")
+ "../private/standard-urls.ss"
+ "../private/docpos.ss"
+ "private/platform.ss"
+ "private/html.ss")
+
+ (provide interface-version timeout start)
+ (define interface-version 'v1)
+ (define timeout +inf.0)
+
+ ;;;
+ ;;; PORT UTILS
+ ;;;
+
+ (define (port->string port)
+ (let ([os (open-output-string)])
+ (copy-port port os)
+ (get-output-string os)))
+
+ (define (file->string path)
+ (call-with-input-file path
+ port->string))
+
+ (define (port->bytes port)
+ (let ([ob (open-output-bytes)])
+ (copy-port port ob)
+ (get-output-bytes ob)))
+
+ (define (file->bytes path)
+ (call-with-input-file path
+ port->bytes))
+
+ ;;;
+ ;;; MIME
+ ;;;
+
+ ; get-mime-type : path -> string
+ (define get-mime-type
+ (;make-get-mime-type
+ make-path->mime-type
+ (build-path (find-collects-dir)
+ "web-server" "default-web-root" "mime.types")))
+
+
+ (define (text-mime-type? file-path)
+ (regexp-match #rx"^text"
+ (get-mime-type file-path)))
+
+ ;;;
+ ;;; URL
+ ;;;
+
+ ; file-parts->file : string (list string) -> string
+ ; (list "foo" "bar" "baz") => "foo/bar/baz"
+ (define (file-parts->file manual fs)
+ (apply string-append
+ (let loop ([fs (cons manual fs)])
+ (cond
+ [(null? fs) (list "")]
+ [(null? (cdr fs)) (list (car fs))]
+ [else (cons (string-append (car fs) "/")
+ (loop (cdr fs)))]))))
+
+ ;;;
+ ;;; TITLES
+ ;;;
+
+ (define (short->manual-title s)
+ (match (assoc (string->path s) known-docs)
+ [#f "Documentation"]
+ [(path . long) long]))
+
+ (define (start request)
+ (with-errors-to-browser
+ send/finish
+ (lambda ()
+ (let* ([bindings (request-bindings request)]
+ [file (get-binding bindings 'file "no file")]
+ [host (get-binding bindings 'host "no host")]
+
+ [url (request-uri request)])
+ (let-values
+ ([(file-path host manual)
+ (match (map path/param-path (url-path url))
+ [("servlets" "static.ss" host manual . file-parts)
+ (values (host+file->path host (file-parts->file manual file-parts))
+ host
+ manual)])])
+ (cond
+ [(not file-path)
+ (list #"text/html"
+ "Not foundFile not found.")]
+ [(and (file-exists? file-path)
+ (text-mime-type? file-path))
+ (list (get-mime-type file-path)
+ (string-append (xexpr->string
+ (html-page
+ #:title (short->manual-title manual)
+ #:top (case (current-helpdesk-platform)
+ [(internal-browser) '()]
+ [(internal-browser-simple) '()]
+ [else (html-top request)])
+ #:body " "))
+ (file->string file-path)))]
+ [(file-exists? file-path)
+ (list (get-mime-type file-path)
+ (file->bytes file-path))]
+ [else
+ (list #"text/html"
+ (format "Not foundFile not found: ~a"
+ file-path))]))))))
+
)
\ No newline at end of file