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

much improved search, extended and fixed sendurl, string-based rendering for xrefs

Browse Source 
svn: r8577
This commit is contained in:
Eli Barzilay 2008-02-08 04:32:49 +00:00
parent 11d4f9c00c
commit 7539945a3d
6 changed files with 139 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/help/search.ss
View File

@ -26,12 +26,12 @@
(define exact-score 1000)
(define exact-word-score 600)
(define words1-score 400)
(define words2-score 200)
(define prefix-score 100)
(define words2-score 100)
(define prefix-score 200)
(define suffix-score 20)
(define contain-score 10)
(define exported-entry-bonus 200) ; prefer bindings and modules
(define regexp-score-factor 1.25) ; regexps get higher score
(define exported-entry-factor 1.1) ; prefer bindings and modules
(define regexp-score-factor 1.1) ; regexps get higher score
(define nomatch-score -1) ; prefer less irrelevant terms
(define (perform-search terms #:exact? [exact? #f] #:go-if-one? [go-if-one? #t])
@ -47,13 +47,15 @@
(loop (cdr es)
(let* ([e (car es)] [score (scorer e)])
(if (score . > . 0) (cons (cons score e) r) r)))))]
;; use to debug weird search results
;; [_ (for ([x (sort entries scored-entry<?)])
;; (printf "~a ~s\n" (car x) (entry-words (cdr x))))]
[entries (map cdr (sort entries scored-entry<?))])
(if (and go-if-one? (= 1 (length entries)))
(let*-values ([(tag) (entry-tag (car entries))]
[(path tag) (xref-tag->path+anchor xref tag)])
(send-url/file path #:fragment (uri-encode tag)))
(let* ([file (next-search-results-file)]
[term->label
(send-url/file path #:fragment (and tag (uri-encode tag))))
(let* ([term->label
(λ (t) (format "``~a''" (if (regexp? t) (object-name t) t)))]
[search-title ; note: terms is not null at this point (see above)
(apply string-append (term->label (car terms))
@ -65,8 +67,8 @@
(list (make-element "schemeerror" (list "No results found.")))
(build-itemization entries))]
[contents (cons (title search-title) contents)])
(xref-render xref (decode contents) file)
(send-url/file file))))))
(send-url/contents (xref-render xref (decode contents) #f)
#:delete-at (* 60 10)))))))
;; converts a list of search terms to a scoring function
(define (terms->scorer terms exact?)
@ -108,13 +110,16 @@
sc))))
terms))
(lambda (entry)
(foldl (lambda (word acc)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word))) 0 scorers)))
;; give some bonus for bindings and modules
(let ([desc (entry-desc entry)])
(if (or (exported-index-desc? desc) (module-path-index-desc? desc))
exported-entry-bonus 0))
(entry-words entry))))
(let ([sc (foldl (lambda (word acc)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word)))
0 scorers)))
0
(entry-words entry))])
;; give some bonus for bindings and modules
(let ([desc (entry-desc entry)])
(if (or (exported-index-desc? desc) (module-path-index-desc? desc))
(* sc exported-entry-factor)
sc)))))
(define (scored-entry<? x y)
(let ([xsc (car x)] [ysc (car y)])
@ -128,14 +133,7 @@
(or (loop (cdr xs) (cdr ys))
;; Try string<? so "Foo" still precedes "foo"
(string<? (car xs) (car ys)))]
[else (string-ci<? (car xs) (car xs))]))])))
(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)))))
[else (string-ci<? (car xs) (car ys))]))])))
;; build-itemization : (nonempty-listof entry) -> (listof <stuff>)
(define (build-itemization entries)

46
collects/net/scribblings/sendurl.scrbl
View File

@ -13,7 +13,8 @@ See also @schememodname[browser/external], which requires
browser preference is set.
@defproc[(send-url [str string?] [separate-window? any/c #t])
@defproc[(send-url [str string?] [separate-window? any/c #t]
#:escape [escape? any/c #t])
void?]{
Opens @scheme[str], which represents a URL, in a platform-specific
@ -22,16 +23,51 @@ manner. For some platforms and configurations, the
a new window to display the URL or not.
Under Windows, @scheme[send-url] normally uses @scheme[shell-execute]
to launch a browser. If the URL appears to contain a fragment, it may
instead use @exec{ftype htmlfile} to obtain a command-line to run,
since @scheme[shell-execute] drops a fragment.
to launch a browser. (If the URL appears to contain a fragment, it may
use an intermediate redirecting file due to a bug in IE7.)
Under Mac OS X, @scheme[send-url] runs @exec{osascript} to start the
user's chosen browser.
Under Unix, @scheme[send-url] uses the value of the
@scheme[external-browser] parameter to select a browser.}
@scheme[external-browser] parameter to select a browser.
The @scheme[url] string is usually escaped to avoid dangerous shell
characters (quotations, dollar signs, backslashes, and non-ASCII).
Note that it is a good idea to encode URLs before passing them to this
function. Also note that the encoding is meant to make the URL work
in shell quotes: URLs can still hold characters like @litchar{#},
@litchar{?}, and @litchar{&}, so the @scheme[external-browser] should
use quotations.}
@defproc[(send-url/file [path path-string?] [separate-window? any/c #t]
#:fragment [fragment (or/c string? false/c) #f]
#:query [query (or/c string? false/c) #f])
void?]{
Similar to @scheme[send-url], but accepts a path to a file to be
displayed by the browser. Use this function when you want to display
a local file: it takes care of the peculiarities of constructing the
correct @litchar{file://} URL, and uses @scheme[send-url] to display
the file. If you need to use an anchor fragment or a query string,
use the corresponding keyword arguments.}
@defproc[(send-url/contents [contents string?] [separate-window? any/c #t]
#:fragment [fragment (or/c string? false/c) #f]
#:query [query (or/c string? false/c) #f]
#:delete-at [seconds (or/c number? false/c) #f])
void?]{
Similar to @scheme[send-url/file], but it consumes the contents of a
page to show, and displayes it from a temporary file.
If @scheme[delete-at] is a number, the temporary file is removed after
this many seconds. The deletion happens in a thread, so if mzscheme
exits before that it will not happen --- when this function is called
it scans old generated files (this happens randomly, not on every
call) and removes them to avoid cluttering the temporary directory.
If @scheme[delete-at] is @scheme[#f], no delayed deletion happens, but
old temporary files are still deleted as described above.}
@defparam[external-browser cmd browser-preference?]{

84
collects/net/sendurl.ss
View File

@ -8,7 +8,7 @@
scheme/promise
scheme/port)
(provide send-url send-url/file
(provide send-url send-url/file send-url/contents
unix-browser-list browser-preference? external-browser)
(define separate-by-default?
@ -77,7 +77,7 @@
;; only these characters. This is only for protection when passing arguments
;; to subprocesses, it's best to pass properly escaped urls to `send-url'.
(define (escape-url url)
(regexp-replace* #px"(?:[^[:graph:]]|[\"'`\\\\])" url %escape))
(regexp-replace* #px"(?:[^[:graph:]]|[$\"'`\\\\])" url %escape))
;; send-url : str [bool] -> void
(define (send-url url-str [separate-window? separate-by-default?]
@ -117,6 +117,34 @@
path)])
(send-url path separate-window? #:escape? #f)))
;; See the documentation for the `delete-at' argument
(define (send-url/contents contents [separate-window? separate-by-default?]
#:fragment [fragment #f] #:query [query #f]
#:delete-at [delete-at #f])
(define tmp-tmpl "plt-sendurl-contents-file-~a.html")
(define tmp-rx #rx"^plt-sendurl-contents-file-.*\\.html$")
;; The code below will often leave leftovers (for example, plt-help will quit
;; before deletion happens), so every once in a while, do a cleanup. This
;; can also remove files that were created with no intention for deletion
;; (when delete-at is #f), so don't remove files that are less than 15
;; minutes old.
(when (zero? (random 5))
(parameterize ([current-directory (find-system-path 'temp-dir)])
(let ([now (current-seconds)])
(for ([file (directory-list)]
#:when (and (file-exists? file)
(regexp-match tmp-rx (path-element->string file))
(> (- now (file-or-directory-modify-seconds file))
(* 15 60))))
;; The temp directory may be shared with other users, so silently
;; ignore failures to remove files.
(with-handlers ([void void]) (delete-file file))))))
(let ([temp (make-temporary-file tmp-tmpl)])
(with-output-to-file temp #:exists 'truncate
(lambda () (display contents)))
(when delete-at (thread (lambda () (sleep delete-at) (delete-file temp))))
(send-url/file temp)))
(define osascript (delay (find-exe "osascript")))
(define (send-url/mac url)
(browser-run (force osascript) "-e" (format "open location \"~a\"" url)))
@ -176,45 +204,27 @@
;; http://support.microsoft.com/default.aspx/kb/942172
;; It seems that the IE7 problem happens either way (`shell-execute' or running
;; directly) -- but it also happens with firefox when using `shell-execute'.
;; The current solution is to run `ftype http' to find the default browser
;; command, if it uses `iexplore.exe', then change it to `explorer.exe', and
;; One possible solution is to run `ftype http' to find the default browser
;; command, and if it uses `iexplore.exe' then change it to `explorer.exe', and
;; run the resulting command directly. This is described at
;; http://www.tutorials-win.com/IE/Lauching-HTML/
;; Hopefully this works. One question is whether IE6 will still work fine;
;; another is other browsers work; and finally, we need to parse the command
;; and substitute the url for `%1' (if it appears). If there are other `%'s,
;; throw an error so we can hack that in too.
;; Oh and it seems that there is no way to get this to work on Vista, the above
;; MS page says that the problem is that IE will start a more priviliged one,
;; handing over the URL -- which, again, gets the fragment+query stripped
;; away...
(define windows-http-command
(delay (let ([out (open-output-string)])
(parameterize ([current-output-port out]
[current-input-port (open-input-string "")]
[current-error-port (open-output-nowhere)])
(and (system "ftype http")
(cond [(regexp-match #rx"(?:^|\r?\n)?http=([^\r\n]+)\r?\n"
(get-output-string out))
=> cadr]
[else #f]))))))
;; But this still fails on Vista, since the problem there is that launching a
;; browser with a file:// URL makes it start a more priviliged process, and
;; doing that drops the fragment again. So the solution that the code below
;; implements is to write and use (via `send-url/contents') a trampoline html
;; that redirects to the actual file and fragment.
(define (send-url/win url)
(let ([cmd (force windows-http-command)])
(browser-run
#:shell #t #:ignore-exit-code #t
(cond [(and (or (not cmd)
(regexp-match? #px"(?:^|[/\\\\])(?i:iexplore.exe)" cmd))
;; IE: try to find exeplorer instead
(find-exe "explorer.exe"))
=> (lambda (exe) (format "\"~a\" ~a" exe url))]
[(not (regexp-match? #rx"%" cmd))
(format "~a ~a" cmd url)]
[(regexp-match? #rx"%[^1]" cmd)
(error 'send-url/win "Unknown browser configuration: ~s\n~a"
cmd "*** Please report this as a bug!")]
[else (regexp-replace* #rx"%1" cmd url)]))))
(if (not (regexp-match? #rx"[#?]" url))
(shell-execute #f url "" (current-directory) 'SW_SHOWNORMAL)
(send-url/contents
(string-append
"<html><head><meta http-equiv=\"refresh\" content=\"0;URL="url"\"></head>"
"<body>Please go <a href=\""url"\">here</a>.</body></html>")
;; starting the browser may take a while, don't remove the file
;; immediately (this means that when used via plt-help, these files are
;; never removed by a timer)
#:delete-at 15)))
;; Process helper
(define (browser-run #:shell [shell? #f] #:ignore-exit-code [nowait? #f] . args)

10
collects/scribble/base-render.ss
View File

@ -279,9 +279,15 @@
(define/public (render ds fns ri)
(map (lambda (d fn)
(define (one) (render-one d ri fn))
(when report-output? (printf " [Output to ~a]\n" fn))
(with-output-to-file fn #:exists 'truncate/replace
(lambda () (render-one d ri fn))))
(if fn
(with-output-to-file fn #:exists 'truncate/replace one)
;; a #f filename means return the contents as a string
(let ([o (open-output-string)])
(parameterize ([current-output-port o])
(one)
(get-output-string o)))))
ds
fns))

34
collects/scribble/xref.ss
View File

@ -53,23 +53,27 @@
(define (xref-index xrefs)
(filter
values
(hash-table-map (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
(lambda (k v)
(and (pair? k)
(eq? (car k) 'index-entry)
(make-entry (car v)
(cadr v)
(cadr k)
(caddr v)))))))
(hash-table-map
(collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
(lambda (k v)
(and (pair? k)
(eq? (car k) 'index-entry)
(make-entry (car v) (cadr v) (cadr k) (caddr v)))))))
(define (xref-render xrefs doc dest-file #:render% [render% (html:render-mixin render%)])
;; dest-file can be #f, which will make it return a string holding the
;; resulting html
(define (xref-render xrefs doc dest-file
#:render% [render% (html:render-mixin render%)])
(let* ([dest-file (if (string? dest-file) (string->path dest-file) dest-file)]
[renderer (new render% [dest-dir (path-only dest-file)])]
[ci (send renderer collect (list doc) (list dest-file))])
(send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
(let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
(send renderer render (list doc) (list dest-file) ri)
(void))))
[renderer (new render% [dest-dir (and dest-file (path-only dest-file))]
[css-path 'inline])]
[ci (send renderer collect (list doc) (list dest-file))]
[_ (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))]
[ri (send renderer resolve (list doc) (list dest-file) ci)]
[xs (send renderer render (list doc) (list dest-file) ri)])
(if dest-file
(void)
(car xs))))
;; Returns (values <tag-or-#f> <form?>)
(define xref-binding-tag