diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss index a265140e52..33a4654597 100644 --- a/collects/help/private/standard-urls.ss +++ b/collects/help/private/standard-urls.ss @@ -8,7 +8,7 @@ "internal-hp.ss" "get-help-url.ss") - (provide home-page-url) + (provide home-page-url host+dirs) (define (search-type? x) (member x '("keyword" "keyword-index" "keyword-index-text"))) diff --git a/collects/help/servlets/home.ss b/collects/help/servlets/home.ss index da513feb91..f2fcf25e11 100644 --- a/collects/help/servlets/home.ss +++ b/collects/help/servlets/home.ss @@ -175,7 +175,11 @@ ;; static subpages ;; - In ALPHABETICAL order (define easy-pages - `(("acknowledge" "Acknowledgements" + `(("about-the-master-index" "About the Master Index" + ((p "The master index is a list of all keywords present in the html documentation.") + (p (a ([href ,url-helpdesk-master-index]) "The Master Index")))) + ;; + ("acknowledge" "Acknowledgements" ((p ,(get-general-acks)) (p ,(get-translating-acks)))) ;; @@ -187,8 +191,7 @@ "MzScheme, or MrEd. MysterX is available from ") (pre nbsp nbsp - (a ((href "http://www.plt-scheme.org/software/mysterx/") - (target "_top")) + (a ([href "http://www.plt-scheme.org/software/mysterx/"]) "http://www.plt-scheme.org/software/mysterx/")) (p ,(collection-doc-link "mysterx" "The MysterX collection")))) ;; diff --git a/collects/help/servlets/master-index.ss b/collects/help/servlets/master-index.ss new file mode 100644 index 0000000000..b5f6ccd340 --- /dev/null +++ b/collects/help/servlets/master-index.ss @@ -0,0 +1,101 @@ +(module master-index mzscheme + (require (lib "servlet.ss" "web-server") + (lib "xml.ss" "xml") + (lib "match.ss") + (lib "dirs.ss" "setup") + (lib "list.ss") + (lib "match.ss") + "../private/options.ss" + "private/url.ss" + "../private/standard-urls.ss" + "private/html.ss") + + (provide interface-version timeout start) + (define interface-version 'v1) + (define timeout +inf.0) + + (define (start request) + (with-errors-to-browser + send/finish + (lambda () + (html-page + #:title "Master Index" + #:top (case (helpdesk-platform) + [(internal-browser) '()] + [(internal-browser-simple) '()] + [else (html-top request)]) + #:body (html-master-index))))) + + + (define-struct entry (keyword host manual file label title) (make-inspector)) + (define entries (make-hash-table 'equal)) + + ;;; + ;;; HTML + ;;; + + (define (html-entry the-entry) + (match the-entry + [($ entry keyword host manual file label title) + `(div 'nbsp 'nbsp 'nbsp 'nbsp + (a ([href ,(file-path->url host manual file label)]) + ,title))])) + + (define (html-keyword keyword) + `(div (b ,keyword) + ,@(map html-entry (hash-table-get entries keyword)))) + + (define (html-master-index) + (let ([keywords (sort (hash-table-map entries (lambda (key val) key)) stringurl host manual file label) + (string-append (url-static host manual file) + (if label (format "#~a" label) ""))) + + ;;; + ;;; ENTRIES + ;;; + + (define (add-entry! entry) + (let* ([keyword (entry-keyword entry)] + [old (hash-table-get entries keyword (lambda () '()))]) + (hash-table-put! entries (entry-keyword entry) (cons entry old)))) + + (define (keyword->entry host manual keyword-list) + (match keyword-list + [(keyword result-display html-file html-label title) + (make-entry keyword host manual html-file html-label title)] + [_ + (error 'keyword->list + "Expected a four element list: ( ), got: " + keyword-list)])) + + ;;; + ;;; TRAVERSAL + ;;; + + (define (add-keywords-in-directory! host manual dir) + (when (directory-exists? dir) + (let ([keywords-path (build-path dir "keywords")]) + (when (file-exists? keywords-path) + (with-input-from-file keywords-path + (lambda () + (let ([keyword-entries (read)]) + (for-each (lambda (k) (add-entry! (keyword->entry host manual k))) + keyword-entries)))))))) + + (define (add-keywords-in-sub-directories! host+dir) + (match host+dir + [(host . dir) + (when (directory-exists? dir) + (for-each (lambda (manual) + (add-keywords-in-directory! host manual + (build-path dir manual))) + (directory-list dir)))])) + + (for-each add-keywords-in-sub-directories! + host+dirs) + ) \ No newline at end of file diff --git a/collects/help/servlets/private/url.ss b/collects/help/servlets/private/url.ss index 94082c0767..27a552a452 100644 --- a/collects/help/servlets/private/url.ss +++ b/collects/help/servlets/private/url.ss @@ -6,8 +6,10 @@ (define url-helpdesk-root (format "http://~a:~a/servlets/" internal-host (internal-port))) - (define url-helpdesk-home (string-append url-helpdesk-root "home.ss")) - (define url-helpdesk-results (string-append url-helpdesk-root "results.ss")) + (define url-helpdesk-home (string-append url-helpdesk-root "home.ss")) + (define url-helpdesk-results (string-append url-helpdesk-root "results.ss")) + (define url-helpdesk-master-index (string-append url-helpdesk-root "master-index.ss")) + (define (url-home-subpage subpage-str) (string-append url-helpdesk-home "?subpage=" subpage-str))