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

added planet info to help desk manuals listing and search results

Browse Source 
svn: r7318
This commit is contained in:
Ryan Culpepper 2007-09-11 15:54:25 +00:00
parent ec23be9160
commit 9096231611
2 changed files with 54 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/help/private/colldocs.ss
View File

@ -2,28 +2,63 @@
(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 ([dirs (sort (map path->string (find-relevant-directories
'(doc.txt) 'all-available))
string<?)]
(let loop ([dirrecs (find-doc-directory-records)]
[docs null]
[names null])
(cond
[(null? dirs) (values (reverse docs) (reverse names))]
[else (let* ([dir (string->path (car dirs))]
[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 dirs)
(cons (list dir (string->path doc.txt-path))
docs)
(cons name names))
(loop (cdr dirs) docs names)))
(loop (cdr dirs) docs names)))])))
[(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?))

2
collects/help/private/search.ss
View File

@ -68,7 +68,7 @@
(set! doc-names (append
std-doc-names
(map (lambda (s) (format "the ~a collection" s))
(map (lambda (s) (format "the ~a" s))
txt-doc-names)))
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))