381 lines
17 KiB
Scheme
381 lines
17 KiB
Scheme
(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?))]))
|