From 5dd18dadcb4b7634c3035abf4f6f0d87fd65ae90 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 Feb 2008 19:59:39 +0000 Subject: [PATCH] removed help/* leftovers that are not used in v4 svn: r8528 --- collects/help/bug-report.ss | 3 +- collects/help/help-desk-urls.ss | 3 - collects/help/info.ss | 12 - collects/help/installer.ss | 59 ++-- collects/help/private/buginfo.ss | 28 +- collects/help/private/colldocs.ss | 65 ---- collects/help/private/docpos.ss | 65 ---- collects/help/private/finddoc.ss | 79 ----- collects/help/private/get-help-url.ss | 68 ---- collects/help/private/info.ss | 2 - collects/help/private/internal-hp.ss | 54 --- collects/help/private/manuals.ss | 380 --------------------- collects/help/private/options.ss | 22 -- collects/help/private/path.ss | 10 - collects/help/private/standard-urls.ss | 134 -------- collects/help/search.ss | 128 +++---- collects/help/servlets/private/url.ss | 83 ----- collects/help/servlets/private/util.ss | 114 ------- collects/help/servlets/scheme/misc/info.ss | 2 - 19 files changed, 91 insertions(+), 1220 deletions(-) delete mode 100644 collects/help/help-desk-urls.ss delete mode 100644 collects/help/private/colldocs.ss delete mode 100644 collects/help/private/docpos.ss delete mode 100644 collects/help/private/finddoc.ss delete mode 100644 collects/help/private/get-help-url.ss delete mode 100644 collects/help/private/info.ss delete mode 100644 collects/help/private/internal-hp.ss delete mode 100644 collects/help/private/manuals.ss delete mode 100644 collects/help/private/options.ss delete mode 100644 collects/help/private/path.ss delete mode 100644 collects/help/private/standard-urls.ss delete mode 100644 collects/help/servlets/private/url.ss delete mode 100644 collects/help/servlets/private/util.ss delete mode 100644 collects/help/servlets/scheme/misc/info.ss diff --git a/collects/help/bug-report.ss b/collects/help/bug-report.ss index faddd5015c..eb9f76af26 100644 --- a/collects/help/bug-report.ss +++ b/collects/help/bug-report.ss @@ -11,8 +11,7 @@ (lib "uri-codec.ss" "net") (lib "htmltext.ss" "browser") (lib "dirs.ss" "setup") - "private/buginfo.ss" - "private/manuals.ss") + "private/buginfo.ss") (provide help-desk:report-bug) diff --git a/collects/help/help-desk-urls.ss b/collects/help/help-desk-urls.ss deleted file mode 100644 index df14cb4c0b..0000000000 --- a/collects/help/help-desk-urls.ss +++ /dev/null @@ -1,3 +0,0 @@ -(module help-desk-urls mzscheme - (require "servlets/private/url.ss") - (provide (all-from "servlets/private/url.ss"))) \ No newline at end of file diff --git a/collects/help/info.ss b/collects/help/info.ss index 06530a2973..f6b82e031f 100644 --- a/collects/help/info.ss +++ b/collects/help/info.ss @@ -1,16 +1,4 @@ ; help collection (module info setup/infotab (define name "Help") - ;(define doc.txt "doc.txt") - (define compile-subcollections - '(("help" "private")) -#| - ("help" "servlets") - ("help" "servlets" "private") - ("help" "servlets" "release") - ("help" "servlets" "scheme") - ("help" "servlets" "scheme" "misc") -|# - ) - (define post-install-collection "installer.ss")) diff --git a/collects/help/installer.ss b/collects/help/installer.ss index 7ad000182e..b75c8872f5 100644 --- a/collects/help/installer.ss +++ b/collects/help/installer.ss @@ -1,38 +1,29 @@ ;; Builds different kinds of executables for different platforms. -(module installer mzscheme - (provide post-installer) - (require (lib "launcher.ss" "launcher")) +#lang scheme/base - (define post-installer - (lambda (path) - (case (system-type) - [(macosx) - (make-mred-exe) - (make-mzscheme-exe)] - [(windows) - (make-mred-exe)] - [else - (make-mzscheme-exe)]))) +(provide post-installer) +(require launcher/launcher) - (define (make-mred-exe) - (for-each - (lambda (variant) - (parameterize ([current-launcher-variant variant]) - (make-mred-launcher '("-l" "help/help") - (mred-program-launcher-path "plt-help") - (append - '((exe-name . "plt-help") - (relative? . #t)) - (build-aux-from-path - (build-path (collection-path "help") "help")))))) - (available-mred-variants))) +(define post-installer + (lambda (path) + (case (system-type) + [(macosx) (make-mred-exe) (make-mzscheme-exe)] + [(windows) (make-mred-exe)] + [else (make-mzscheme-exe)]))) - (define (make-mzscheme-exe) - (for-each - (lambda (variant) - (parameterize ([current-launcher-variant variant]) - (make-mzscheme-launcher '("-l" "help/help") - (mzscheme-program-launcher-path "plt-help") - '((exe-name . "plt-help") - (relative? . #t))))) - (available-mzscheme-variants)))) +(define (make-mred-exe) + (for ([variant (available-mred-variants)]) + (parameterize ([current-launcher-variant variant]) + (make-mred-launcher + '("-l" "help/help") + (mred-program-launcher-path "plt-help") + (append '((exe-name . "plt-help") (relative? . #t)) + (build-aux-from-path + (build-path (collection-path "help") "help"))))))) + +(define (make-mzscheme-exe) + (for ([variant (available-mzscheme-variants)]) + (parameterize ([current-launcher-variant variant]) + (make-mzscheme-launcher '("-l" "help/help") + (mzscheme-program-launcher-path "plt-help") + '((exe-name . "plt-help") (relative? . #t)))))) diff --git a/collects/help/private/buginfo.ss b/collects/help/private/buginfo.ss index 010524c632..5dd1ccf0f4 100644 --- a/collects/help/private/buginfo.ss +++ b/collects/help/private/buginfo.ss @@ -1,21 +1,17 @@ -(module buginfo mzscheme +#lang mzscheme - (provide set-bug-report-info! - get-bug-report-infos - bri-label - bri-value) - - (define-struct bri (label get-value)) - (define (bri-value bri) ((bri-get-value bri))) - - ; update with symbol/string assoc list - (define bug-report-infos null) - - (define (set-bug-report-info! str thunk) - (set! bug-report-infos (cons (make-bri str thunk) bug-report-infos))) - - (define (get-bug-report-infos) bug-report-infos)) +(provide set-bug-report-info! + get-bug-report-infos + bri-label + bri-value) +(define-struct bri (label get-value)) +(define (bri-value bri) ((bri-get-value bri))) +;; update with symbol/string assoc list +(define bug-report-infos null) +(define (set-bug-report-info! str thunk) + (set! bug-report-infos (cons (make-bri str thunk) bug-report-infos))) +(define (get-bug-report-infos) bug-report-infos) diff --git a/collects/help/private/colldocs.ss b/collects/help/private/colldocs.ss deleted file mode 100644 index f2ccee00ce..0000000000 --- a/collects/help/private/colldocs.ss +++ /dev/null @@ -1,65 +0,0 @@ -(module colldocs mzscheme - (require (lib "list.ss") - (lib "getinfo.ss" "setup") - (lib "contract.ss")) - - ;; find-doc-directory-records : -> (list-of directory-record) - ;; Returns directory records containing doc.txt files, sorted first - ;; by lib/planet, then by path. - (define (find-doc-directory-records) - (define allrecs - (find-relevant-directory-records '(doc.txt) 'all-available)) - (define (recbytes (directory-record-path a)) - (path->bytes (directory-record-path b)))) - (define (librec? dirrec) - (let ([spec (directory-record-spec dirrec)]) - (and (pair? spec) (eq? (car spec) 'lib)))) - (append (sort (filter librec? allrecs) rec (values (list-of (list string path)) (list-of string)) - ;; Returns two lists having equal length. Each item in the first list - ;; contains a list containing a string (the directory) and a path (to - ;; the doc.txt file). The second list contains the corresponding descriptive - ;; names. - (define (colldocs) - (let loop ([dirrecs (find-doc-directory-records)] - [docs null] - [names null]) - (cond - [(null? dirrecs) (values (reverse docs) (reverse names))] - [else - (let* ([dirrec (car dirrecs)] - [dir (directory-record-path dirrec)] - [info-proc (get-info/full dir)]) - (if info-proc - (let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))] - [name (info-proc 'name (lambda () #f))]) - (if (and (path-string? doc.txt-path) - (string? name)) - (loop (cdr dirrecs) - (cons (list dir (string->path doc.txt-path)) - docs) - (cons (pleasant-name name dirrec) - names)) - (loop (cdr dirrecs) docs names))) - (loop (cdr dirrecs) docs names)))]))) - - ;; pleasant-name : string directory-record -> string - ;; Generates a descriptive name for the collection/package. - (define (pleasant-name name dirrec) - (let ([spec (directory-record-spec dirrec)]) - (if (and (pair? spec) (list? spec)) - (case (car spec) - ((lib) (format "~a collection" name)) - ((planet) (format "~a package ~s" - name - `(,@(cdr spec) - ,(directory-record-maj dirrec) - ,(directory-record-min dirrec))))) - name))) - - (provide/contract - [colldocs (-> (values (listof (list/c path? path?)) - (listof string?)))])) diff --git a/collects/help/private/docpos.ss b/collects/help/private/docpos.ss deleted file mode 100644 index 364ad70e67..0000000000 --- a/collects/help/private/docpos.ss +++ /dev/null @@ -1,65 +0,0 @@ -(module docpos mzscheme - (require (lib "list.ss") - (lib "contract.ss")) - - ;; Define an order on the standard docs. - (define (standard-html-doc-position d) - (let ([str (path->string d)]) - (if (equal? str "help") - -1 - (let ([line (assoc str docs-and-positions)]) - (if line - (caddr line) - 100))))) - - - ;; (listof (list string string number)) - ;; the first string is the collection name - ;; the second string is the title of the the manual - ;; the number determines the sorting order for the manuals in the manuals page - (define docs-and-positions - `(("r5rs" "Revised^5 Report on the Algorithmic Language Scheme" -50) - ("mzscheme" "PLT MzScheme: Language Manual" -49) - ("mred" "PLT MrEd: Graphical Toolbox Manual" -48) - - ("tour" "A Brief Tour of DrScheme" 0) - ("drscheme" "PLT DrScheme: Programming Environment Manual" 1) - - ("srfi" "SRFI documents inside PLT" 3) - - ("mzlib" "PLT MzLib: Libraries Manual" 5) - ("misclib" "PLT Miscellaneous Libraries: Reference Manual" 6) - ("mrlib" "PLT MrLib: Graphical Libraries Manual" 7) - ("framework" "PLT Framework: GUI Application Framework" 8) - - ("mzc" "PLT mzc: MzScheme Compiler Manual" 10) - ("foreign" "PLT Foreign Interface Manual" 10) - - ("tools" "PLT Tools: DrScheme Extension Manual" 30) - ("insidemz" "Inside PLT MzScheme" 50) - - ("web-server" "Web Server Manual" 60) - ("swindle" "Swindle Manual" 61) - ("plot" "PLoT Manual" 62) - - ("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100) - ("tex2page" "TeX2page" 101) - - ("beginning" "Beginning Student Language" 200) - ("beginning-abbr" "Beginning Student with List Abbreviations Language" 201) - ("intermediate" "Intermediate Student Language" 202) - ("intermediate-lambda" "Intermediate Student with Lambda Language" 203) - ("advanced" "Advanced Student Language" 204) - ("teachpack" "Teachpacks for How to Design Programs" 205) - ("teachpack-htdc" "Teachpacks for How to Design Classes" 206) - - ("profj-beginner" "ProfessorJ Beginner Language" 210) - ("profj-intermediate" "ProfessorJ Intermediate Language" 211) - ("profj-intermediate-access" "ProfessorJ Intermediate + access Language" 212) - ("profj-advanced" "ProfessorJ Advanced Language" 213))) - - (define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions)) - - (provide/contract - [standard-html-doc-position (path? . -> . number?)] - [known-docs (listof (cons/c path? string?))])) diff --git a/collects/help/private/finddoc.ss b/collects/help/private/finddoc.ss deleted file mode 100644 index 10cf41af40..0000000000 --- a/collects/help/private/finddoc.ss +++ /dev/null @@ -1,79 +0,0 @@ -(module finddoc mzscheme - (require (lib "dirs.ss" "setup") - (lib "match.ss") - "path.ss" - "get-help-url.ss") - - (provide finddoc - finddoc-page - finddoc-page-anchor - find-doc-directory) - - ;; Creates a "file:" link into the indicated manual. - ;; The link doesn't go to a particular anchor, - ;; because "file:" does not support that. - (define (finddoc manual index-key label) - (match (lookup manual index-key label) - [(docdir index-key filename anchor title) - `(a ((href ,(string-append - "file:" (path->string (build-path docdir filename))))) - ,label)] - [m m])) - - ; finddoc-page-help : string string boolean -> string - ; return url to the page where index-key is in manual, - ; optionally append an anchor - (define (finddoc-page-help manual index-key anchor?) - (match (lookup manual index-key "dummy") - [(docdir index-key filename anchor title) - (cond - [(servlet-path? (string->path filename)) - (string-append - filename (if anchor? (string-append "#" anchor) ""))] - [else - (get-help-url (build-path docdir filename) anchor)])] - [_ (error (format "Error finding index \"~a\" in manual \"~a\"" - index-key manual))])) - - ; finddoc-page : string string -> string - ; returns path for use by PLT Web server - ; path is of form /doc/manual/page, or - ; /servlet/ - (define (finddoc-page manual index-key) - (finddoc-page-help manual index-key #f)) - - ; finddoc-page-anchor : string string -> string - ; returns path (with anchor) for use by PLT Web server - ; path is of form /doc/manual/page#anchor, or - ; /servlet/#anchor - (define (finddoc-page-anchor manual index-key) - (finddoc-page-help manual index-key #t)) - - (define ht (make-hash-table)) - - ;; returns (list docdir index-key filename anchor title) - ;; or throws an error - (define (lookup manual index-key label) - (let* ([key (string->symbol manual)] - [docdir (find-doc-directory manual)] - [l (hash-table-get ht key - (lambda () - (let ([f (and docdir (build-path docdir "hdindex"))]) - (if (and f (file-exists? f)) - (let ([l (with-input-from-file f read)]) - (hash-table-put! ht key l) - l) - (error 'finddoc "manual index ~s not installed" manual)))))] - [m (assoc index-key l)]) - (if m - (cons docdir m) - (error 'finddoc "index key ~s not found in manual ~s" index-key manual)))) - - ;; finds the full path of the doc directory, if one exists - ;; input is just the short name of the directory (as a path) - (define (find-doc-directory doc) - (ormap (lambda (d) - (let ([p (build-path d doc)]) - (and (directory-exists? p) - p))) - (get-doc-search-dirs)))) diff --git a/collects/help/private/get-help-url.ss b/collects/help/private/get-help-url.ss deleted file mode 100644 index 497b8c2c53..0000000000 --- a/collects/help/private/get-help-url.ss +++ /dev/null @@ -1,68 +0,0 @@ -(module get-help-url mzscheme - - #| Library responsible for turning a path on disk into a URL the help desk can use |# - (require (lib "file.ss") - "internal-hp.ss" - (lib "contract.ss") - (lib "etc.ss") - (lib "config.ss" "planet") - (lib "dirs.ss" "setup")) - - ; given a manual path, convert to absolute Web path - ; manual path is an anchored path to a doc manual, never a servlet - (define get-help-url - (opt-lambda (manual-path [anchor #f]) - (let ([segments (explode-path (normalize-path manual-path))]) - (let loop ([candidates manual-path-candidates]) - (cond - ;; shouldn't happen, unless documentation is outside - ;; the set of doc dirs: - [(null? candidates) "/cannot-find-docs.html"] - [else - (let ([candidate (car candidates)]) - (cond - [(subpath/tail (car candidate) segments) - => - (λ (l-o-path) - ((cadr candidate) l-o-path anchor))] - [else - (loop (cdr candidates))]))]))))) - - (define manual-path-candidates '()) - (define (maybe-add-candidate candidate host) - (with-handlers ([exn:fail? void]) - (set! manual-path-candidates - (cons (list (explode-path (normalize-path candidate)) - (λ (segments anchor) - (format "http://~a:~a/servlets/static.ss/~a~a~a" - internal-host - (internal-port) - host - (apply string-append (map (λ (x) (format "/~a" (path->string x))) - segments)) - (if anchor - (string-append "#" anchor) - "")))) - manual-path-candidates)))) - - ;; Add doc dirs later, so that they take precedence: - (maybe-add-candidate (PLANET-DIR) planet-host) - (for-each (λ (dir host) (maybe-add-candidate dir host)) - (append collects-dirs doc-dirs) - (append collects-hosts doc-hosts)) - - (define (subpath/tail short long) - (let loop ([short short] - [long long]) - (cond - [(null? short) long] - [(null? long) #f] - [(equal? (car short) (car long)) - (loop (cdr short) (cdr long))] - [else #f]))) - - (provide/contract (get-help-url - (opt-> - ((or/c path? path-string?)) - (string?) - string?)))) diff --git a/collects/help/private/info.ss b/collects/help/private/info.ss deleted file mode 100644 index 0ffcbdd1ac..0000000000 --- a/collects/help/private/info.ss +++ /dev/null @@ -1,2 +0,0 @@ -(module info setup/infotab - (define name "Help private")) diff --git a/collects/help/private/internal-hp.ss b/collects/help/private/internal-hp.ss deleted file mode 100644 index 4ae2ffb15c..0000000000 --- a/collects/help/private/internal-hp.ss +++ /dev/null @@ -1,54 +0,0 @@ -(module internal-hp mzscheme - (require (lib "dirs.ss" "setup") - (lib "config.ss" "planet") - "options.ss") - (provide internal-port - is-internal-host? internal-host - collects-hosts collects-dirs - doc-hosts doc-dirs - planet-host) - - ;; Hostnames defined here should not exist as real machines - - ;; The general idea is that there's one "virtual" host for - ;; every filesystem tree that we need to access. - ;; (now we use static.ss/host/yadayda instead of the virtual - ;; host docX.localhost, but we still need to keep track of - ;; the file system roots) - ;; The "get-help-url.ss" library provides a function to - ;; convert a path into a suitable URL (i.e., a URL using - ;; the right virtual host). - ;; The "gui.ss" library performs a bit of extra URL - ;; processing at the last minute, sometimes switching - ;; a URL for a manual to a different host. (That's needed - ;; when cross-manual references are implemented as relative - ;; URLs.) - - (define internal-host "localhost") - - (define (is-internal-host? str) - (member str all-internal-hosts)) - - (define (generate-hosts prefix dirs) - (let loop ([dirs dirs][n 0]) - (if (null? dirs) - null - (cons (format "~a~a" prefix n) - (loop (cdr dirs) (add1 n)))))) - - (define planet-host "planet") - - (define collects-dirs - (get-collects-search-dirs)) - (define collects-hosts - (generate-hosts "collects" collects-dirs)) - - (define doc-dirs - (get-doc-search-dirs)) - (define doc-hosts - (generate-hosts "doc" doc-dirs)) - - (define all-internal-hosts - (append (list internal-host planet-host) - collects-hosts - doc-hosts))) diff --git a/collects/help/private/manuals.ss b/collects/help/private/manuals.ss deleted file mode 100644 index f0d08eeca5..0000000000 --- a/collects/help/private/manuals.ss +++ /dev/null @@ -1,380 +0,0 @@ -(module manuals mzscheme - (require (lib "list.ss") - (lib "date.ss") - (lib "string-constant.ss" "string-constants") - (lib "xml.ss" "xml") - (lib "contract.ss") - (lib "getinfo.ss" "setup") - (lib "uri-codec.ss" "net") - (lib "dirs.ss" "setup") - (lib "match.ss") - "finddoc.ss" - "colldocs.ss" - "docpos.ss" - "standard-urls.ss" - "get-help-url.ss" - "../servlets/private/util.ss") - - ;; type sec = (make-sec name regexp (listof regexp)) - (define-struct sec (name reg seps)) - - ;; sections : (listof sec) - ;; determines the section breakdown for the manuals - ;; elements in the outer list: - ;; string : name of section - ;; predicate : determines if a manual is in the section (based on its title) - ;; breaks -- where to insert newlines - (define sections - (list (make-sec "Getting started" - #rx"(Tour)|(Teach Yourself)" - '()) - (make-sec "Languages" - #rx"Language|MrEd" - '(#rx"Beginning Student" #rx"ProfessorJ Beginner")) - (make-sec "Tools" #rx"PLT DrScheme|PLT mzc|TeX2page|Web Server|PLoT" '()) - (make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '()) - (make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '()) - (make-sec "Other" #rx"" '()))) - - ; main-manual-page : string -> xexpr - ; return link to main manual page of a doc collection, like "mred" - (define (main-manual-page manual) - (let* ([entry (assoc (string->path manual) known-docs)] - [name (or (and entry (cdr entry)) - manual)] - [doc-dir (find-doc-directory manual)]) - (if doc-dir - (let ([href (get-help-url doc-dir)]) - `(A ((HREF ,href)) ,name)) - name))) - - ; manual-entry: string string string -> xexpr - ; man is manual name - ; ndx is index into the manual - ; txt is the link text - (define (manual-entry man ndx txt) - (with-handlers ([exn:fail? - ;; warning: if the index file isn't present, this page - (lambda (x) - `(font ((color "red")) ,txt " [" ,(exn-message x) "]"))]) - `(A ((HREF ,(finddoc-page man ndx))) ,txt))) - - (define (basename path) - (let-values ([(dir name dir?) (split-path path)]) name)) - - (define (find-doc-names) - (let* ([dirs (find-doc-directories)] - [installed (map basename dirs)] - [uninstalled (filter (lambda (x) (not (member (car x) installed))) - known-docs)]) - (append (map (lambda (short-name long-name) - (cons short-name (get-doc-name long-name))) - installed dirs) - uninstalled))) - - ;; find-doc-directories : -> (listof path) - ;; constructs a sorted list of directories where documentation may reside. - (define (find-doc-directories) - (let ([unsorted (append (find-info.ss-doc-directories) - (find-doc-directories-in-toplevel-docs))]) - (sort unsorted compare-docs))) - - (define (find-info.ss-doc-directories) - (let ([dirs (find-relevant-directories '(html-docs) 'all-available)]) - (let loop ([dirs dirs]) - (cond - [(null? dirs) null] - [else (let* ([dir (car dirs)] - [info (get-info/full dir)]) - (cond - [info - (let ([html-doc-paths (info 'html-docs (lambda () #f))]) - (cond - [(and (list? html-doc-paths) - (andmap path-string? html-doc-paths)) - (let ([candidates (map (lambda (x) (build-path dir x)) html-doc-paths)]) - (for-each (λ (c) - (unless (directory-exists? c) - (fprintf (current-error-port) - "found reference to ~a in html-docs for ~a, but it is not a directory\n" - (path->string c) - (path->string dir)))) - candidates) - (append (filter directory-exists? candidates) - (loop (cdr dirs))))] - [else - (loop (cdr dirs))]))] - [else (loop (cdr dirs))]))])))) - - (define (find-doc-directories-in-toplevel-docs) - (apply append - (map (lambda (docs-path) - (filter directory-exists? - (map (lambda (doc-path) - (build-path docs-path doc-path)) - (if (directory-exists? docs-path) - (filter (lambda (x) - (not (member (path->string x) - '(".svn" "CVS")))) - (directory-list docs-path)) - '())))) - (get-doc-search-dirs)))) - - (define (find-manuals) - (let* ([docs (sort (filter get-index-file (find-doc-directories)) - compare-docs)] - [names (map get-doc-name docs)] - [names+paths (map cons names docs)]) - (let-values ([(collections-doc-files collection-names) (colldocs)]) - `((H1 "Installed Manuals") - ,@(if (repos-or-nightly-build?) - (list - '(b "Subversion: ") - `(a ((mzscheme - ,(to-string/escape-quotes - `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals))))) - ,(string-constant plt:hd:refresh-all-manuals)) - 'nbsp 'nbsp - `(a ((href ,flush-manuals-url)) "flush index and keyword cache") - '(br)) - (list)) - ,@(build-known-manuals names+paths) - (h3 "Doc.txt") - (ul ,@(map - (lambda (collection-doc-file name) - (let ([path (build-path (car collection-doc-file) (cadr collection-doc-file))]) - `(li ,(cond - [(file-exists? path) - `(a ((href ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a" - ;; escape colons and other junk - (uri-encode (path->string path)) - (uri-encode name) - (format "Documentation for ~a " name)))) - ,(format "~a " name))] - [else - `(font ((color "red")) - ,(format "~a: specified doc.txt file (~a) not found" - name path))])))) - collections-doc-files - collection-names)) - - ,@(let ([uninstalled (get-uninstalled docs)]) - (if (null? uninstalled) - '() - `((h3 "Uninstalled Manuals") - (ul ,@(map - (lambda (doc-pair) - (let* ([manual (car doc-pair)] - [name (cdr doc-pair)] - [manual-path (find-doc-directory manual)]) - `(li "Download and install " - (a ((mzscheme - ,(to-string/escape-quotes - `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals) - (list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path) - ,(path->bytes manual)) - ,name)))))) - ,name) - ,(if (and manual-path - (or (file-exists? (build-path manual-path "hdindex")) - (file-exists? (build-path manual-path "keywords")))) - " (index installed)" - "")))) - uninstalled))))))))) - - - ;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof xexpr) - (define (build-known-manuals names+paths) - (let loop ([sections sections] - [manuals names+paths]) - (cond - [(null? sections) null] - [else - (let* ([section (car sections)] - [in (filter (lambda (x) (regexp-match (sec-reg section) - (car x))) - manuals)] - [out (filter (lambda (x) (not (regexp-match (sec-reg section) - (car x)))) - manuals)]) - (append (build-known-section section in) - (loop (cdr sections) out)))]))) - - ;; build-known-section : sec (listof (cons string[title] string[path]))) -> (listof xexpr) - (define (build-known-section sec names+paths) - (if (null? names+paths) - '() - `((h3 ,(sec-name sec)) - (ul ,@(map (match-lambda - ["

" '(p)] - [(title . path) (mk-link path title)]) - (let loop ([breaks (sec-seps sec)] - [names+paths names+paths]) - (cond - [(null? breaks) names+paths] - [else - (let ([break (car breaks)]) - (loop (cdr breaks) - (break-between (car breaks) names+paths)))]))))))) - - ;; break-between : regexp - ;; (listof (union string (cons string string))) - ;; -> (listof (union string (cons string string))) - ;; adds the para-mark string into the list at the first place - ;; that the regexp fails to match (not counting other para-marks - ;; in the list) - (define (break-between re l) - (let ([para-mark "

"]) - (let loop ([l l]) - (cond - [(null? l) null] - [else - (let ([fst (car l)]) - (cond - [(pair? fst) - (let ([name (car fst)]) - (if (regexp-match re name) - (cons para-mark l) - (cons fst (loop (cdr l)))))] - [else (cons fst (loop (cdr l)))]))])))) - - - ;; mk-link : string string -> xexpr - (define (mk-link doc-path name) - (let* ([manual-name (basename doc-path)] - [index-file (get-index-file doc-path)]) - `(li (a ((href ,(get-help-url (build-path doc-path index-file)))) - ,name) - ,@(cond - [(and (repos-or-nightly-build?) - (file-exists? (build-path doc-path index-file))) - `((br) - 'nbsp - 'nbsp - (font ((size "-1")) - ,@(if (is-known-doc? doc-path) - (list - "[" - `(a ((mzscheme - ,(to-string/escape-quotes - `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals) - (list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path) - ,(path->bytes manual-name)) - ,name)))))) - ,(string-constant plt:hd:refresh)) - "]" 'nbsp) - (list))))] - [else - (list - (format (string-constant plt:hd:manual-installed-date) - (date->string - (seconds->date - (file-or-directory-modify-seconds - (build-path doc-path index-file))))))])))) - - (define (to-string/escape-quotes exp) - (regexp-replace* #rx"\"" (format "~s" exp) "|")) - - ;; get-doc-name : path -> string - (define cached-doc-names (make-hash-table 'equal)) - (define (get-doc-name doc-dir) - (hash-table-get cached-doc-names doc-dir - (lambda () - (let ([res (compute-doc-name doc-dir)]) - (hash-table-put! cached-doc-names doc-dir res) - res)))) - - ;; compute-doc-name : path -> string[title of manual] - ;; gets the title either from the known docs list, by parsing the - ;; html, or if both those fail, by using the name of the directory - ;; Special-cases the help collection. It's not a known doc directory - ;; per se, so it won't appear in known-docs, but its name is always - ;; the same. - (define (compute-doc-name doc-dir) - (let ([doc-short-dir-name (basename doc-dir)]) - (cond - [(equal? (string->path "help") doc-short-dir-name) "PLT Help Desk"] - [(get-known-doc-name doc-dir) => values] - [else (let* ([main-file (get-index-file doc-dir)] - [m (and main-file - (call-with-input-file (build-path doc-dir main-file) - (lambda (inp) (regexp-match re:title inp))))]) - (if m - (bytes->string/utf-8 (cadr m)) - (path->string doc-short-dir-name)))]))) - (define re:title - #rx"<[tT][iI][tT][lL][eE]>[ \t\r\n]*(.*?)[ \t\r\n]*") - - ;; is-known-doc? : string[path] -> boolean - (define (is-known-doc? doc-path) - (and (assoc (basename doc-path) known-docs) #t)) - - ;; get-known-doc-name : string[full-path] -> (union string #f) - (define (get-known-doc-name doc-path) - (cond [(assoc (basename doc-path) known-docs) => cdr] [else #f])) - - ;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name])) - (define (get-uninstalled docs) - (let ([ht (make-hash-table 'equal)]) - (for-each (lambda (known-doc) - (hash-table-put! ht - (car known-doc) - (cdr known-doc))) - known-docs) - (for-each (lambda (doc) (hash-table-remove! ht (basename doc))) docs) - (sort (hash-table-map ht cons) - (λ (a b) (compare-docs (car a) (car b)))))) - - (define (compare-docs a b) - (let ([ap (standard-html-doc-position (basename a))] - [bp (standard-html-doc-position (basename b))]) - (cond [(= ap bp) (stringstring a) (path->string b))] - [else (< ap bp)]))) - - ;; get-manual-index : string -> html - (define (get-manual-index manual-dirname) (get-help-url (build-path (find-doc-dir) manual-dirname))) - - ;; get-index-file : path -> (union #f path) - ;; returns the name of the main file, if one can be found - (define (get-index-file doc-dir) - (cond - [(file-exists? (build-path doc-dir "index.htm")) - (build-path "index.htm")] - [(file-exists? (build-path doc-dir "index.html")) - (build-path "index.html")] - [(tex2page-detected doc-dir) - => - (lambda (x) x)] - [else #f])) - - ;; tex2page-detected : string -> (union #f string) - (define (tex2page-detected dir) - (let loop ([contents (directory-list dir)]) - (cond - [(null? contents) #f] - [else (let* ([file (car contents)] - [m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))]) - (or (and m - (file-exists? (build-path dir file)) - (let ([index-file - (bytes->path - (bytes-append (cadr m) #".html"))]) - (if (file-exists? (build-path dir index-file)) - index-file - #f))) - (loop (cdr contents))))]))) - - - (provide find-manuals - main-manual-page - finddoc - finddoc-page-anchor) - - (provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)] - [finddoc-page (string? string? . -> . string?)] - [get-doc-name (path? . -> . string?)] - [find-doc-directories (-> (listof path?))] - [find-doc-directory (path? . -> . (or/c false/c path?))] - [find-doc-names (-> (listof (cons/c path? string?)))] - [get-manual-index (-> string? string?)] - [get-index-file (path? . -> . (or/c false/c path?))])) diff --git a/collects/help/private/options.ss b/collects/help/private/options.ss deleted file mode 100644 index d3e54d264a..0000000000 --- a/collects/help/private/options.ss +++ /dev/null @@ -1,22 +0,0 @@ -(module options mzscheme - - ;; This module provides configuration options that are shared - ;; between servlets and the web-server. (Mostly to allow - ;; configuration as an application or as a standalone server.) - - (provide helpdesk-platform internal-port) - - ;; internal browser or external browser? - ;; (used to produce simpler html for the internal browser) - (define helpdesk-platform - (make-parameter - 'internal-browser-simple ; main page only - ;; 'internal-browser ; menu + main page - ;; 'external-browser - )) - - ;; Port for the server to listen on - ;; (relevant only for a standalone server) - (define internal-port (make-parameter 8012)) - - ) diff --git a/collects/help/private/path.ss b/collects/help/private/path.ss deleted file mode 100644 index f842a3ae08..0000000000 --- a/collects/help/private/path.ss +++ /dev/null @@ -1,10 +0,0 @@ -(module path mzscheme - (require (lib "contract.ss")) - (define (servlet-path? path) - (if (regexp-match #rx#"^/servlets/" - (path->bytes path)) - #t - #f)) - (provide/contract - [servlet-path? (path? . -> . boolean?)])) - diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss deleted file mode 100644 index 33a4654597..0000000000 --- a/collects/help/private/standard-urls.ss +++ /dev/null @@ -1,134 +0,0 @@ -(module standard-urls mzscheme - (require (lib "uri-codec.ss" "net") - (lib "dirs.ss" "setup") - (lib "contract.ss") - (lib "config.ss" "planet") - (lib "help-desk-urls.ss" "help") - "../servlets/private/util.ss" - "internal-hp.ss" - "get-help-url.ss") - - (provide home-page-url host+dirs) - - (define (search-type? x) - (member x '("keyword" "keyword-index" "keyword-index-text"))) - - (define (search-how? x) - (member x '("exact-match" "containing-match" "regexp-match"))) - - (define (base-docs-url) - (if (repos-or-nightly-build?) - "http://pre.plt-scheme.org/docs" - (string-append "http://download.plt-scheme.org/doc/" (version)))) - - (define (make-docs-plt-url manual-name) - (format "~a/bundles/~a-doc.plt" (base-docs-url) manual-name)) - - (define (make-docs-html-url manual-name) - (format "~a/html/~a/index.htm" (base-docs-url) manual-name)) - - (define (prefix-with-server suffix) - (format "http://~a:~a~a" internal-host (internal-port) suffix)) - - (define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host (internal-port))) - (define flush-manuals-path "/servlets/results.ss?flush=yes") - (define flush-manuals-url (format "http://~a:~a~a" internal-host (internal-port) flush-manuals-path)) - - - (define relative-results-url-prefix "/servlets/results.ss?") - - (define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host (internal-port))) - - (define (make-missing-manual-url coll name link) - (format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a" - internal-host - (internal-port) - coll - (uri-encode name) - (uri-encode link))) - - (define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name) - (string-append - relative-results-url-prefix - (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name))) - - (define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name) - (string-append - results-url-prefix - (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name))) - - (define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name) - (let ([start - (format - (string-append "search-string=~a&" - "search-type=~a&" - "match-type=~a&" - "lucky=~a&" - "manuals=~a&" - "doctxt=~a") - (uri-encode search-string) - search-type - match-type - (if lucky? "true" "false") - (uri-encode (format "~s" (map path->bytes manuals))) - (if doc.txt? "true" "false"))]) - (if language-name - (string-append start (format "&langname=~a" (uri-encode language-name))) - start))) - - ; sym, string assoc list - (define hd-locations - `((hd-tour ,(format "~a/index.html" (get-help-url (build-path (find-doc-dir) "tour")))) - (release-notes ,url-helpdesk-release-notes) - (plt-license ,url-helpdesk-license) - (front-page ,url-helpdesk-home))) - - (define hd-location-syms (map car hd-locations)) - - (define (get-hd-location sym) - ; the assq is guarded by the contract - (cadr (assq sym hd-locations))) - - ; host+dirs : (list (cons host-string dir-path)) - ; association between internal (in normal Helpdesk also virtual) - ; hosts and their corresponding file root. - (define host+dirs - (map cons - (append collects-hosts doc-hosts) - (append collects-dirs doc-dirs))) - - (define (host+file->path host file-path) - (cond [(assoc host host+dirs) - => (lambda (internal-host+path) - (let ([path (cdr internal-host+path)]) - (build-path path file-path)))] - [(equal? host "planet") - (build-path (PLANET-DIR) file-path)] - [else #f])) - - (provide host+file->path) - (provide search-type? search-how?) - (provide/contract - (make-relative-results-url (string? - search-type? - search-how? - any/c - (listof path?) - any/c - (or/c false/c string?) . -> . string?)) - (make-results-url (string? - search-type? search-how? any/c - (listof path?) - any/c - (or/c false/c string?) - . -> . - string?)) - (flush-manuals-url string?) - (flush-manuals-path string?) - (make-missing-manual-url (string? string? string? . -> . string?)) - (get-hd-location ((lambda (sym) (memq sym hd-location-syms)) - . -> . - string?)) - [prefix-with-server (string? . -> . string?)] - [make-docs-plt-url (string? . -> . string?)] - [make-docs-html-url (string? . -> . string?)])) diff --git a/collects/help/search.ss b/collects/help/search.ss index 1a628c74fd..c51b5f2c97 100644 --- a/collects/help/search.ss +++ b/collects/help/search.ss @@ -13,9 +13,9 @@ setup/dirs) (provide/contract - [generate-search-results (-> (listof string?) void?)] - [send-exact-results (-> string? void?)] - [send-main-page (-> void?)]) + [generate-search-results (-> (listof string?) void?)] + [send-exact-results (-> string? void?)] + [send-main-page (-> void?)]) (define (send-main-page) (let* ([path (build-path (find-user-doc-dir) "index.html")] @@ -32,28 +32,24 @@ [index (xref-index x)] [len (length index)] [exact-matches (filter (has-match (list exact-search-regexp)) index)]) - (cond - [(or (null? exact-matches) - (not (null? (cdr exact-matches)))) - (generate-search-results (list search-key))] - [else - (let ([match (car exact-matches)]) - (let-values ([(path tag) (xref-tag->path+anchor x (entry-tag match))]) - (send-url/file path #:fragment (uri-encode tag))))]))) + (if (or (null? exact-matches) + (not (null? (cdr exact-matches)))) + (generate-search-results (list search-key)) + (let ([match (car exact-matches)]) + (let-values ([(path tag) (xref-tag->path+anchor x (entry-tag match))]) + (send-url/file path #:fragment (uri-encode tag))))))) (define (generate-search-results search-keys) (let ([file (next-search-results-file)] [search-regexps (map (λ (x) (regexp (regexp-quote x #f))) search-keys)] - [exact-search-regexps (map (λ (x) (regexp (format "^~a$" (regexp-quote x #f)))) search-keys)] + [exact-search-regexps + (map (λ (x) (regexp (format "^~a$" (regexp-quote x #f)))) search-keys)] [search-key-string - (cond - [(null? search-keys) ""] - [else - (apply - string-append - (car search-keys) - (map (λ (x) (format ", or ~a" x)) - (cdr search-keys)))])]) + (if (null? search-keys) + "" + (apply string-append + (car search-keys) + (map (λ (x) (format ", or ~a" x)) (cdr search-keys))))]) (let ([x (load-collections-xref)]) (xref-render x @@ -78,51 +74,34 @@ (define (make-extra-content desc) ;; Use `desc' to provide more details on the link: (append - (cond - [(method-index-desc? desc) - (list " method of " - ;; This is bad. We need a more abstract way to take a - ;; binding name and tag/source to create a Scheme link. - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - (list (symbol->string (exported-index-desc-name desc))) - (method-index-desc-class-tag desc)))))] - [else null]) - (cond - [(and (exported-index-desc? desc) - (not (null? (exported-index-desc-from-libs desc)))) - (cons ", provided from " - (cdr (apply append - (map (lambda (lib) - (list ", " - (scheme:to-element lib))) - (exported-index-desc-from-libs desc)))))] - [else null]))) + (if (method-index-desc? desc) + (list " method of " + ;; This is bad. We need a more abstract way to take a + ;; binding name and tag/source to create a Scheme link. + (make-element + "schemesymbol" + (list (make-link-element + "schemevaluelink" + (list (symbol->string (exported-index-desc-name desc))) + (method-index-desc-class-tag desc))))) + null) + (if (and (exported-index-desc? desc) + (not (null? (exported-index-desc-from-libs desc)))) + (cons ", provided from " + (cdr (apply append + (map (lambda (lib) (list ", " (scheme:to-element lib))) + (exported-index-desc-from-libs desc))))) + null))) -(define search-results-files - (reverse - (let loop ([n 10]) - (cond - [(zero? n) '()] - [else - (cons (build-path (find-system-path 'temp-dir) - (format "search-results-~a.html" n)) - (loop (- n 1)))])))) - -(define (next-search-results-file) - (begin0 (car search-results-files) - (set! search-results-files - (append (cdr search-results-files) - (list (car search-results-files)))))) +(define next-search-results-file + (let ([n -1] [tmp (find-system-path 'temp-dir)]) + (lambda () + (set! n (modulo (add1 n) 10)) + (build-path tmp (format "search-results-~a.html" n))))) ;; has-match : (listof regexp) -> entry -> boolean (define ((has-match search-regexps) entry) - (ormap (λ (str) - (ormap - (λ (key) (regexp-match key str)) - search-regexps)) + (ormap (λ (str) (ormap (λ (key) (regexp-match key str)) search-regexps)) (entry-words entry))) ;; limit : exact-positive-integer @@ -131,13 +110,12 @@ ;; build-itemization : (listof entry) -> (listof ) (define (build-itemization title entries) - (cond - [(null? entries) '()] - [else - (let ([entries - (sort - entries - (λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))]) + (if (null? entries) + '() + (let ([entries + (sort + entries + (λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))]) (list* (bold title) (apply itemize @@ -155,17 +133,17 @@ entries))) (if (<= (length entries) limit) '() - (list (make-element "schemeerror" (list (format "Search truncated after ~a hits." limit)))))))])) + (list (make-element "schemeerror" + (list (format "Search truncated after ~a hits." + limit))))))))) (define (limit-length n l) - (cond - [(null? l) '()] - [(zero? n) '()] - [else (cons (car l) (limit-length (- n 1) (cdr l)))])) + (cond [(null? l) '()] + [(zero? n) '()] + [else (cons (car l) (limit-length (- n 1) (cdr l)))])) (define (entry->sort-key e) (let ([words (entry-words e)]) (apply string-append (car words) - (map (λ (x) (string-append ", " x)) - (cdr words))))) + (map (λ (x) (string-append ", " x)) (cdr words))))) diff --git a/collects/help/servlets/private/url.ss b/collects/help/servlets/private/url.ss deleted file mode 100644 index 27a552a452..0000000000 --- a/collects/help/servlets/private/url.ss +++ /dev/null @@ -1,83 +0,0 @@ -(module url mzscheme - (require "../../private/internal-hp.ss") - - (provide (all-defined)) - - (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-master-index (string-append url-helpdesk-root "master-index.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) - (format "http://download.plt-scheme.org/doc/~a/html/~a/" - (version-major) manual)) - - (define (url-static doc manual path) - (format "~astatic.ss/~a/~a/~a" - url-helpdesk-root 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-mrflow "http://www.plt-scheme.org/software/mrflow/") - (define url-external-mrspidey "http://www.plt-scheme.org/software/mrspidey/") - (define url-external-mysterx "http://www.plt-scheme.org/software/mysterx/") - (define url-external-mzcom "http://www.plt-scheme.org/software/mzcom/") - (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-external-srpersist "http://www.plt-scheme.org/software/srpersist/") - - (define url-helpdesk-acknowledge (url-home-subpage "acknowledge")) - (define url-helpdesk-batch (url-home-subpage "batch")) - (define url-helpdesk-books (url-home-subpage "books")) - (define url-helpdesk-cgi (url-home-subpage "cgi")) - (define url-helpdesk-databases (url-home-subpage "databases")) - (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-graphics (url-home-subpage "graphics")) - (define url-helpdesk-help (url-home-subpage "help")) - (define url-helpdesk-how-to-search (url-home-subpage "how-to-search")) - (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-script (url-home-subpage "script")) - (define url-helpdesk-search (url-home-subpage "search")) - (define url-helpdesk-software (url-home-subpage "software")) - (define url-helpdesk-srpersist (url-home-subpage "srpersist")) - (define url-helpdesk-stand-alone (url-home-subpage "stand-alone")) - (define url-helpdesk-system (url-home-subpage "system")) - (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")) - - ) diff --git a/collects/help/servlets/private/util.ss b/collects/help/servlets/private/util.ss deleted file mode 100644 index 301316427c..0000000000 --- a/collects/help/servlets/private/util.ss +++ /dev/null @@ -1,114 +0,0 @@ -(module util mzscheme - (require (lib "file.ss") - (lib "list.ss") - (lib "xml.ss" "xml") - (lib "uri-codec.ss" "net") - (lib "string-constant.ss" "string-constants") - (lib "contract.ss")) - - ;; would be nice if this could use version:version from the framework. - (define (plt-version) - (let ([mz-version (version)] - [stamp-collection - (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) - (collection-path "repos-time-stamp"))]) - (if (and stamp-collection - (file-exists? (build-path stamp-collection "stamp.ss"))) - (format "~a-svn~a" mz-version - (dynamic-require '(lib "repos-time-stamp/stamp.ss") 'stamp)) - mz-version))) - - (define home-page - `(a ([href "/servlets/home.ss"] [target "_top"]) - ,(string-constant plt:hd:home))) - - (define (get-pref/default pref default) - (get-preference pref (lambda () default))) - - (define (get-bool-pref/default pref default) - (let ([raw-pref (get-pref/default pref default)]) - (if (string=? raw-pref "false") #f #t))) - - (define (put-prefs names vals) - (put-preferences names vals)) - - (define search-height-default "85") - (define search-bg-default "lightsteelblue") - (define search-text-default "black") - (define search-link-default "darkblue") - - (define *the-highlight-color* "forestgreen") - - ;; string xexpr ... -> xexpr - (define (with-color color . s) - `(font ([color ,color]) ,@s)) - - ;; xexpr ... -> xexpr - (define (color-highlight . s) - (apply with-color *the-highlight-color* s)) - - (define repos-or-nightly-build? - (let ([helpdir (collection-path "help")]) - (lambda () - (or (directory-exists? (build-path helpdir ".svn")) - (directory-exists? (build-path helpdir "CVS")) - (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (collection-path "repos-time-stamp")))))) - - ; string string -> xexpr - (define (collection-doc-link coll txt) - (let ([coll-file (build-path (collection-path coll) "doc.txt")]) - (if (file-exists? coll-file) - `(a ((href - ,(format - "~a?file=~a&name=~a&caption=Documentation for the ~a collection" - "/servlets/doc-anchor.ss" - (uri-encode (path->string coll-file)) - coll - coll))) - ,txt) - ""))) - - ;; (listof string) -> string - ;; result is forward-slashed web path - ;; e.g. ("foo" "bar") -> "foo/bar" - (define (fold-into-web-path lst) - (foldr (lambda (s a) (if a (string-append s "/" a) s)) #f lst)) - - (define (format-collection-message s) - `(b ((style "color:green")) ,s)) - - (define (make-javascript . ss) - `(script ([language "Javascript"]) - ,(make-comment (apply string-append "\n" - (map (lambda (s) (string-append s "\n")) ss))))) - - (define (redir-javascript k-url) - (make-javascript "function redir() {" - (string-append " document.location.href=\"" k-url "\"") - "}")) - - (define (onload-redir secs) - (string-append "setTimeout(\"redir()\"," - (number->string (* secs 1000)) ")")) - - (provide/contract - [fold-into-web-path ((listof string?) . -> . string?)]) - - (provide get-pref/default - get-bool-pref/default - put-prefs - repos-or-nightly-build? - search-height-default - search-bg-default - search-text-default - search-link-default - color-highlight - with-color - collection-doc-link - home-page - format-collection-message - plt-version - make-javascript - redir-javascript - onload-redir)) diff --git a/collects/help/servlets/scheme/misc/info.ss b/collects/help/servlets/scheme/misc/info.ss deleted file mode 100644 index 4b69c01c00..0000000000 --- a/collects/help/servlets/scheme/misc/info.ss +++ /dev/null @@ -1,2 +0,0 @@ -(module info setup/infotab - (define name "Help Servlets Scheme Misc"))