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

fixed help with #:search, made most of the help-related overhead loaded when help is used

Browse Source 
svn: r11885
This commit is contained in:
Eli Barzilay 2008-09-27 02:07:59 +00:00
parent 989a17ede4
commit 59b1eea0bc
2 changed files with 119 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
collects/scheme/help.ss
View File

@ -1,121 +1,49 @@
#lang scheme/base
(require setup/xref
scribble/xref
scribble/manual-struct
net/uri-codec
net/sendurl
scheme/path
(for-syntax scheme/base))
(require (for-syntax scheme/base) scheme/promise)
(provide help)
(define-syntax (help stx)
(if (identifier? stx)
#'(open-help-start)
(syntax-case stx ()
[(help)
#'(open-help-start)]
[(help id)
(identifier? #'id)
#'(find-help (quote-syntax id))]
[(help id #:from lib)
(if (identifier? #'id)
(if (module-path? (syntax->datum #'lib))
#'(find-help/lib (quote id) (quote lib))
(raise-syntax-error
#f
"expected a module path after #:from"
stx
#'lib))
(raise-syntax-error
#f
"expected an identifier before #:from"
stx
#'id))]
[(help #:search str ...)
(with-syntax ([(str ...)
(map (lambda (e)
(if (string? (syntax-e e))
e
(format "~s"
(syntax->datum e))))
(syntax->list #'(str ...)))])
#'(search-for (list str ...)))]
[_
(raise-syntax-error #f
"expects a single identifer, a #:from clause, or a #:search clause; try just `help' for more information"
stx)])))
#'(open-help-start)
(syntax-case stx ()
[(help)
#'(open-help-start)]
[(help id)
(identifier? #'id)
#'(find-help (quote-syntax id))]
[(help id #:from lib)
(if (identifier? #'id)
(if (module-path? (syntax->datum #'lib))
#'(find-help/lib (quote id) (quote lib))
(raise-syntax-error
#f "expected a module path after #:from" stx #'lib))
(raise-syntax-error
#f "expected an identifier before #:from" stx #'id))]
[(help #:search str ...)
(with-syntax ([(str ...)
(map (lambda (e)
(if (string? (syntax-e e))
e
(format "~s" (syntax->datum e))))
(syntax->list #'(str ...)))])
#'(search-for (list str ...)))]
[_
(raise-syntax-error
#f
(string-append "expects a single identifer, a #:from clause, or a"
" #:search clause; try just `help' for more information")
stx)])))
(define (open-help-start)
(find-help #'help))
(define-namespace-anchor anchor)
(define (find-help/lib sym lib)
(let ([id (parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(namespace-require `(for-label ,lib))
(namespace-syntax-introduce (datum->syntax #f sym)))])
(if (identifier-label-binding id)
(find-help id)
(error 'help
"no binding for identifier: ~a from module: ~a"
sym
lib))))
(define (find-help id)
(let* ([lb (identifier-label-binding id)]
[b (and (not lb) (identifier-binding id))]
[xref (load-collections-xref
(lambda ()
(printf "Loading help index...\n")))])
(if (or lb b)
(let ([tag (xref-binding->definition-tag
xref
(or lb b)
(if lb #f 0))])
(if tag
(go-to-tag xref tag)
(error 'help
"no documentation found for: ~e provided by: ~a"
(syntax-e id)
(module-path-index-resolve (caddr (or lb b))))))
(search-for-exports xref (syntax-e id)))))
(define (search-for-exports xref sym)
(let ([idx (xref-index xref)]
[libs null])
(for-each (lambda (entry)
(when (exported-index-desc? (entry-desc entry))
(when (eq? sym (exported-index-desc-name (entry-desc entry)))
(set! libs (append libs (exported-index-desc-from-libs (entry-desc entry)))))))
idx)
(if (null? libs)
(printf "Not found in any library's documentation: ~a\n" sym)
(begin
(printf "No documentation for current binding, but provided by:\n")
(let loop ([libs libs])
(unless (null? libs)
(unless (member (car libs) (cdr libs))
(printf " ~a\n" (car libs)))
(loop (cdr libs))))))))
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n" file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (and anchor (uri-encode anchor)))
(error 'help "browser launch failed"))))
(define generate-search-results #f)
(define (search-for strs)
(printf "Generating and opening search page...\n")
(unless generate-search-results
(parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(set! generate-search-results
(dynamic-require 'help/search 'perform-search))))
(generate-search-results strs))
(define-syntax-rule (define-help-autoload id)
(begin
(define auto (delay (dynamic-require 'scheme/private/help-autoload 'id)))
(define (id . args) (apply (force auto) args))))
(define-help-autoload find-help)
(define-help-autoload find-help/lib)
(define-help-autoload search-for)

82
collects/scheme/private/help-autoload.ss Normal file
View File

@ -0,0 +1,82 @@
#lang scheme/base
(require setup/xref
scribble/xref
scribble/manual-struct
net/uri-codec
net/sendurl
scheme/path
scheme/list)
(provide find-help find-help/lib search-for)
(define-namespace-anchor anchor)
(define (find-help/lib sym lib)
(let ([id (parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(namespace-require `(for-label ,lib))
(namespace-syntax-introduce (datum->syntax #f sym)))])
(if (identifier-label-binding id)
(find-help id)
(error 'help
"no binding for identifier: ~a from module: ~a"
sym
lib))))
(define (find-help id)
(let* ([lb (identifier-label-binding id)]
[b (and (not lb) (identifier-binding id))]
[xref (load-collections-xref
(lambda ()
(printf "Loading help index...\n")))])
(if (or lb b)
(let ([tag (xref-binding->definition-tag
xref
(or lb b)
(if lb #f 0))])
(if tag
(go-to-tag xref tag)
(error 'help
"no documentation found for: ~e provided by: ~a"
(syntax-e id)
(module-path-index-resolve (caddr (or lb b))))))
(search-for-exports xref (syntax-e id)))))
(define (search-for-exports xref sym)
(let ([idx (xref-index xref)]
[libs null])
(for-each (lambda (entry)
(when (exported-index-desc? (entry-desc entry))
(when (eq? sym (exported-index-desc-name (entry-desc entry)))
(set! libs (append libs (exported-index-desc-from-libs (entry-desc entry)))))))
idx)
(if (null? libs)
(printf "Not found in any library's documentation: ~a\n" sym)
(begin
(printf "No documentation for current binding, but provided by:\n")
(let loop ([libs libs])
(unless (null? libs)
(unless (member (car libs) (cdr libs))
(printf " ~a\n" (car libs)))
(loop (cdr libs))))))))
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n" file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (and anchor (uri-encode anchor)))
(error 'help "browser launch failed"))))
(define generate-search-results #f)
(define (search-for strs)
(printf "Generating and opening search page...\n")
(unless generate-search-results
(parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(set! generate-search-results
(dynamic-require 'help/search 'perform-search))))
(generate-search-results (apply string-append
(add-between strs " "))))