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

misc improvements

Browse Source 
svn: r7189
This commit is contained in:
Eli Barzilay 2007-08-27 00:50:44 +00:00
parent 74b20d58d1
commit b4dd7515c4
1 changed files with 414 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
collects/help/servlets/home.ss
View File

@ -19,22 +19,21 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
; html-subpage : xexprs -> xexpr ;; html-subpage : xexprs -> xexpr
(define (html-subpage . xs) (define (html-subpage . xs)
(case (helpdesk-platform) (apply (case (helpdesk-platform)
[(internal-browser-simple) [(internal-browser-simple) make-simple-page/internal-browser]
(apply make-simple-page/internal-browser xs)] [(internal-browser) make-split-page/internal-browser]
[(internal-browser) [else make-split-page])
(apply make-split-page/internal-browser xs)] xs))
[else
(apply make-split-page xs)]))
(define (start initial-request) (define (start initial-request)
; Note : DrScheme preferences calls start with a #f argument, ;; Note : DrScheme preferences calls start with a #f argument,
; so initial-request can be either a request structure or #f ;; so initial-request can be either a request structure or #f
(unless initial-request (unless initial-request
(set! initial-request (set! initial-request
(make-request 'get (string->url "") '() '() #f "localhost" (internal-port) "localhost"))) (make-request 'get (string->url "") '() '() #f "localhost"
(internal-port) "localhost")))
(with-errors-to-browser (with-errors-to-browser
send/finish send/finish
(lambda () (lambda ()
@ -42,9 +41,9 @@
[subpage (if (exists-binding? 'subpage bindings) [subpage (if (exists-binding? 'subpage bindings)
(extract-binding/single 'subpage bindings) (extract-binding/single 'subpage bindings)
"home")]) "home")])
; dispatch on subpage ;; dispatch on subpage
; the dynamic ones (manuals and release) are handled are here, ;; the dynamic ones (manuals and release) are handled are here,
; the static pages below ;; the static pages below
(match subpage (match subpage
["manuals" ["manuals"
(html-subpage (html-subpage
@ -52,50 +51,46 @@
(html-top initial-request) (left-items) "" (html-top initial-request) (left-items) ""
`(,@(if (eq? (helpdesk-platform) 'external-browser) `(,@(if (eq? (helpdesk-platform) 'external-browser)
'((h3 "NOTE") '((h3 "NOTE")
(p "To see the list of manuals installed on " (i "your") " computer, " (p "To see the list of manuals installed on " (i "your") " computer,"
" use the HelpDesk from within DrScheme. This list of manuals reflects " " use the HelpDesk from within DrScheme. This list of manuals reflects"
"what is installed on this HelpDesk server only.")) " what is installed on this HelpDesk server only."))
'()) '())
(VERBATIM ,(find-manuals)) (VERBATIM ,(find-manuals))
(p) (p)
(i "Version: " ,(plt-version))))] (i "Version: " ,(plt-version))))]
["release" ["release"
(let () (let ([link-stuff (lambda (url txt)
(define (link-stuff url txt) `(li (b (a ([href ,url]) ,txt)))) `(li (b (a ([href ,url]) ,txt))))])
(html-subpage (html-subpage
"PLT Scheme Help Desk: Release Info" "PLT Scheme Help Desk: Release Info"
(html-top initial-request) (left-items) "" (html-top initial-request) (left-items) ""
`((VERBATIM `((VERBATIM
((h3 "NOTE") ((h3 "NOTE")
(p "To see the release information for your installation, use the HelpDesk from " (p "To see the release information for your installation,"
"within DrScheme. " " use the HelpDesk from within DrScheme."
"The following information reflects the installation on this server only.") " The following information reflects the installation on"
" this server only.")
(h1 "Release Information") (h1 "Release Information")
(p) (p (i "Version: " ,(plt-version)))
(i "Version: " ,(plt-version))
(p)
(ul ,(link-stuff url-helpdesk-license "License") (ul ,(link-stuff url-helpdesk-license "License")
,(link-stuff url-helpdesk-release-notes "Release Notes") ,(link-stuff url-helpdesk-release-notes "Release Notes")
,(link-stuff url-helpdesk-known-bugs "Known Bugs") ,(link-stuff url-helpdesk-known-bugs "Known Bugs")
,(link-stuff url-helpdesk-patches "Downloadable Patches")) ,(link-stuff url-helpdesk-patches "Downloadable Patches"))
(p) (p "The PLT software is installed on this machine at" (br)
"The PLT software is installed on this machine at" (br)
(pre nbsp nbsp (pre nbsp nbsp
,(let-values ([(base file dir?) ,(path->string (find-collects-dir)))))))))]
(split-path (collection-path "mzlib"))])
(path->string base))))))))]
[_ [_
(let-values ([(right-header right-items) (let-values ([(right-header right-items)
(page-tag->title+items subpage)]) (page-tag->title+items subpage)])
(cond (cond
[(and (eq? (helpdesk-platform) 'internal-browser-simple) [(and (eq? (helpdesk-platform) 'internal-browser-simple)
(equal? subpage "home")) (equal? subpage "home"))
; change the "home" page for internal HelpDesk with no menus ;; change the "home" page for internal HelpDesk with no menus
(html-subpage "PLT Scheme Help Desk: Home" (html-subpage "PLT Scheme Help Desk: Home"
(html-top initial-request) (html-top initial-request)
"home" "home"
right-header (append (left-items) right-header
(append (left-items)
`(((p) `(((p)
(i "Version: " ,(plt-version))))))] (i "Version: " ,(plt-version))))))]
[else [else
@ -104,7 +99,7 @@
(left-items) (left-items)
right-header right-items)]))]))))) right-header right-items)]))])))))
(define (br) (define (br*)
(if (eq? (helpdesk-platform) 'external-browser) (if (eq? (helpdesk-platform) 'external-browser)
'() '()
'((br) (br)))) '((br) (br))))
@ -114,7 +109,7 @@
("Get help: " ("Get help: "
nbsp nbsp nbsp nbsp nbsp nbsp nbsp nbsp
(b (a ((href ,url-helpdesk-help)) "Help Desk")) (b (a ((href ,url-helpdesk-help)) "Help Desk"))
,@(br)) ,@(br*))
-- -- -- --
("Learn to program in Scheme: " ("Learn to program in Scheme: "
nbsp nbsp nbsp nbsp nbsp nbsp nbsp nbsp
@ -128,7 +123,7 @@
(a ((href ,url-helpdesk-books)) "Books") ", " (a ((href ,url-helpdesk-books)) "Books") ", "
(a ((href ,url-helpdesk-languages)) "Languages") ", " (a ((href ,url-helpdesk-languages)) "Languages") ", "
(a ((href ,url-helpdesk-teachpacks)) "Teachpacks") (a ((href ,url-helpdesk-teachpacks)) "Teachpacks")
,@(br)) ,@(br*))
-- -- -- --
("How to run programs: " ("How to run programs: "
nbsp nbsp nbsp nbsp (b (a ((href ,url-helpdesk-software)) "Software: ")) nbsp nbsp nbsp nbsp (b (a ((href ,url-helpdesk-software)) "Software: "))
@ -136,17 +131,18 @@
(a ((href ,url-helpdesk-tour)) "Tour") ", " (a ((href ,url-helpdesk-tour)) "Tour") ", "
(a ((href ,url-helpdesk-drscheme)) "DrScheme") ", " (a ((href ,url-helpdesk-drscheme)) "DrScheme") ", "
(a ((href ,url-helpdesk-release)) "Release") (a ((href ,url-helpdesk-release)) "Release")
,@(br) ,@(br*)
; (a ((href ,url-helpdesk-drscheme-faq)) "FAQ")) ; Moved to the DrScheme page ;; (a ((href ,url-helpdesk-drscheme-faq)) "FAQ") ; Moved to DrScheme page
) )
-- -- -- --
("Get involved:" ("Get involved:"
nbsp nbsp nbsp nbsp nbsp nbsp nbsp nbsp
(a ((href ,url-helpdesk-mailing-lists)) "Mailing Lists") (a ((href ,url-helpdesk-mailing-lists)) "Mailing Lists")
,@(case (helpdesk-platform) ,@(case (helpdesk-platform)
((external-browser) `(", " (a ((href ,url-external-send-bug-report)) "Send a bug report"))) [(external-browser)
(else '())) `(", " (a ((href ,url-external-send-bug-report)) "Send a bug report"))]
,@(br)) [else '()])
,@(br*))
-- -- -- --
("" (""
" " " " " " " "
@ -157,7 +153,7 @@
(font ([color "forestgreen"]) "Send a bug report"))) (font ([color "forestgreen"]) "Send a bug report")))
nbsp nbsp)] nbsp nbsp)]
[else `()]) [else `()])
; DrScheme Acknowledgements ;; DrScheme Acknowledgements
,@(case (helpdesk-platform) ,@(case (helpdesk-platform)
[(internal-browser internal-browser-simple) [(internal-browser internal-browser-simple)
`((b (a ((href ,url-helpdesk-acknowledge)) `((b (a ((href ,url-helpdesk-acknowledge))
@ -165,15 +161,14 @@
[else '()])) [else '()]))
-- -- -- --)) -- -- -- --))
; page-tag->title+items : string -> (values string list-of-right-items) ;; page-tag->title+items : string -> (values string list-of-right-items)
(define (page-tag->title+items page-tag) (define (page-tag->title+items page-tag)
(match (assoc page-tag easy-pages) (match (assoc page-tag easy-pages)
[#f (page-tag->title+items "home")] [#f (page-tag->title+items "home")]
[(tag header body) (values header body)])) [(tag header body) (values header body)]))
;; static subpages
; static subpages ;; - In ALPHABETICAL order
; - In ALPHABETICAL order
(define easy-pages (define easy-pages
`(("acknowledge" "Acknowledgements" `(("acknowledge" "Acknowledgements"
((p ,(get-general-acks)) ((p ,(get-general-acks))
@ -225,7 +220,7 @@
((p "DrScheme supports many dialects of Scheme. " ((p "DrScheme supports many dialects of Scheme. "
"The following dialects are specifically designed for teaching " "The following dialects are specifically designed for teaching "
"computer science. In DrScheme's " "computer science. In DrScheme's "
; TODO: (a ([href "/servlets/scheme/what.ss#lang-sel"]) "language selection menu") ;; TODO: (a ([href "/servlets/scheme/what.ss#lang-sel"]) "language selection menu")
(b "Language selection menu") ", " (b "Language selection menu") ", "
"they are found under the heading " "they are found under the heading "
(b "How to Design Programs") "." (b "How to Design Programs") "."
@ -289,10 +284,8 @@
"COPYING.LIB") "COPYING.LIB")
" for more information.") " for more information.")
(p "PLT software includes or extends the following copyrighted material:" (p "PLT software includes or extends the following copyrighted material:"
,@(let () ,@(map
(define (make-item ss) `(ul (li ,@(map (lambda (s) `(div ,s (br))) ss)))) (lambda (ss) `(ul (li ,@(map (lambda (s) `(div ,s (br))) ss))))
(map
make-item
`(("DrScheme" `(("DrScheme"
,(format "Copyright (c) 1995-~a PLT" copyright-year) ,(format "Copyright (c) 1995-~a PLT" copyright-year)
,(format "Copyright (c) 2004-~a PLT Scheme Inc." copyright-year) ,(format "Copyright (c) 2004-~a PLT Scheme Inc." copyright-year)
@ -343,7 +336,7 @@
("GNU lightning" ("GNU lightning"
"Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.") "Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.")
("GNU Classpath" ("GNU Classpath"
"GNU Public License with special exception"))))))) "GNU Public License with special exception"))))))
("mailing-lists" "Mailing Lists" ("mailing-lists" "Mailing Lists"
((p "There are two mailing lists: the discussion list and the announcements only list.") ((p "There are two mailing lists: the discussion list and the announcements only list.")
(h3 "Archives") (h3 "Archives")
@ -352,8 +345,10 @@
" - " (a ((href ,url-external-discussion-list-archive-old)) "(old archive)")) " - " (a ((href ,url-external-discussion-list-archive-old)) "(old archive)"))
(li (a ((href ,url-external-announcement-list-archive)) "Announcements only")))) (li (a ((href ,url-external-announcement-list-archive)) "Announcements only"))))
(h3 "Subscribing") (h3 "Subscribing")
(p "Visit the " (a ((href ,url-external-mailing-list-subscription)) (p "Visit the "
"subscription page") " to join the mailing lists."))) (a ((href ,url-external-mailing-list-subscription))
"subscription page")
" to join the mailing lists.")))
("patches" "Downloadable Patches" ("patches" "Downloadable Patches"
((p (a ([name "patches"] [value "Downloadable patches"])) ((p (a ([name "patches"] [value "Downloadable patches"]))
"The following Web page may contain downloadable patches to fix " "The following Web page may contain downloadable patches to fix "
@ -404,10 +399,10 @@
((ul (li (a ((href ,url-helpdesk-drscheme)) "DrScheme") ": The programming environment") ((ul (li (a ((href ,url-helpdesk-drscheme)) "DrScheme") ": The programming environment")
(li (a ((href ,url-helpdesk-languages)) "Languages") ": The family of languages " (li (a ((href ,url-helpdesk-languages)) "Languages") ": The family of languages "
"supported by PLT Software") "supported by PLT Software")
; (li (a ((href ,url-helpdesk-documentation)) "Documentation") ;; (li (a ((href ,url-helpdesk-documentation)) "Documentation")
; ": Organization and manuals") ;; ": Organization and manuals")
; (li (a ((href ,url-helpdesk-hints)) "Hints") ;; (li (a ((href ,url-helpdesk-hints)) "Hints")
; ": How to do things in Scheme") ;; ": How to do things in Scheme")
))) )))
("teachpacks" "Teachpacks" ("teachpacks" "Teachpacks"
((ul (li (a ((href ,url-helpdesk-teachpacks-for-htdp)) ((ul (li (a ((href ,url-helpdesk-teachpacks-for-htdp))