removed help/* leftovers that are not used in v4
svn: r8528
This commit is contained in:
Eli Barzilay
parent
fb57b0df03
commit
5dd18dadcb
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
(module help-desk-urls mzscheme
|
||||
(require "servlets/private/url.ss")
|
||||
(provide (all-from "servlets/private/url.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"))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 (rec<? a b)
|
||||
(bytes<? (path->bytes (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<?)
|
||||
(sort (filter (lambda (x) (not (librec? x))) allrecs) rec<?)))
|
||||
|
||||
;; colldocs : -> (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?)))]))
|
||||
|
|
@ -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?))]))
|
||||
|
|
@ -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/<rest-of-path>
|
||||
(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/<rest-of-path>#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))))
|
||||
|
|
@ -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?))))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(module info setup/infotab
|
||||
(define name "Help private"))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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>" '(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 "<p>"])
|
||||
(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]*</[tT][iI][tT][lL][eE]>")
|
||||
|
||||
;; 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) (string<? (path->string 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?))]))
|
||||
|
|
@ -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))
|
||||
|
||||
)
|
||||
|
|
@ -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?)]))
|
||||
|
||||
|
|
@ -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?)]))
|
||||
|
|
@ -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 <stuff>)
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
)
|
||||
|
|
@ -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))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(module info setup/infotab
|
||||
(define name "Help Servlets Scheme Misc"))
|
||||
Loading…
Reference in New Issue
Block a user