commit 45c8f79865694dc6516f7a540f573f983d7ea911
parent 2991306101c90b8a9774b16e7c981926726c45b7
Author: Robby Findler <robby@racket-lang.org>
Date: Wed, 12 Dec 2007 17:24:57 +0000
exact matches now come first and help-desk with no arguments goes to some kind of generic page
svn: r7970
original commit: 046abd204ea6cadb36e9a127e3a71c2b025adbd2
Diffstat:
2 files changed, 72 insertions(+), 26 deletions(-)
diff --git a/collects/help/help.ss b/collects/help/help.ss
@@ -1,7 +1,18 @@
#lang scheme/base
-(require "search.ss")
-(define argv (current-command-line-arguments))
-(when (equal? argv #())
- (error 'help-desk "expected a search term on the command line"))
-(generate-search-results (vector->list argv))
+(require "search.ss"
+ browser/external
+ setup/dirs
+ mzlib/cmdline)
+
+(define search-terms '())
+(command-line "Help Desk"
+ (current-command-line-arguments)
+ (args search-term (set! search-terms search-term)))
+
+(cond
+ [(null? search-terms)
+ (let ([dest-path (build-path (find-doc-dir) "start" "index.html")])
+ (send-url (format "file://~a" (path->string dest-path))))]
+ [else
+ (generate-search-results search-terms)])
diff --git a/collects/help/search.ss b/collects/help/search.ss
@@ -57,7 +57,8 @@
(define (generate-search-results search-keys)
(let ([file (next-search-results-file)]
- [search-regexps (map (λ (x) (regexp-quote x #f)) search-keys)]
+ [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)]
[search-key-string
(cond
[(null? search-keys) ""]
@@ -71,26 +72,60 @@
(xref-render
x
(decode `(,(title (format "Search results for ~a" search-key-string))
- ,(let* ([index (xref-index x)]
- [len (length index)])
- (apply itemize
- (map
- (λ (entry)
- (apply item
- (make-link-element
- "indexlink"
- (entry-content entry)
- (entry-link-key entry))
- (make-extra-content
- (entry-desc entry))))
- (filter
- (λ (entry)
- (ormap (λ (str)
- (ormap
- (λ (key) (regexp-match key str))
- search-regexps))
- (entry-words entry)))
- index))))))
+ ,@(let* ([index (xref-index x)]
+ [len (length index)]
+ [matching-entries (filter (has-match search-regexps) index)]
+ [exact-matches (filter (has-match exact-search-regexps) matching-entries)]
+ [inexact-matches (filter (compose not (has-match exact-search-regexps)) matching-entries)])
+ (append
+ (build-itemization "Exact matches" exact-matches)
+ (build-itemization "Containing matches" inexact-matches)))))
file)
(send-url (format "file://~a" (path->string file)))
(void))))
+
+(define ((compose f g) x) (f (g x)))
+
+;; has-match : (listof regexp) -> entry -> boolean
+(define ((has-match search-regexps) entry)
+ (ormap (λ (str)
+ (ormap
+ (λ (key) (regexp-match key str))
+ search-regexps))
+ (entry-words entry)))
+
+;; build-itemization : (listof entry) -> (listof <stuff>)
+(define (build-itemization title entries)
+ (cond
+ [(null? entries) '()]
+ [else
+ (list
+ (bold title)
+ (apply itemize
+ (map
+ (λ (entry)
+ (apply item
+ (make-link-element
+ "indexlink"
+ (entry-content entry)
+ (entry-link-key entry))
+ (make-extra-content
+ (entry-desc entry))))
+ (limit-length
+ 500
+ (sort
+ entries
+ (λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))))))]))
+
+(define (limit-length n l)
+ (cond
+ [(zero? n) '()]
+ [(null? l) '()]
+ [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)))))
