From 59b1eea0bc3720450d65016266d265dca4d7641b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 27 Sep 2008 02:07:59 +0000 Subject: [PATCH] fixed help with #:search, made most of the help-related overhead loaded when help is used svn: r11885 --- collects/scheme/help.ss | 146 ++++++----------------- collects/scheme/private/help-autoload.ss | 82 +++++++++++++ 2 files changed, 119 insertions(+), 109 deletions(-) create mode 100644 collects/scheme/private/help-autoload.ss diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index 1e54e765b4..f8569728ee 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -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) diff --git a/collects/scheme/private/help-autoload.ss b/collects/scheme/private/help-autoload.ss new file mode 100644 index 0000000000..a1b7e818be --- /dev/null +++ b/collects/scheme/private/help-autoload.ss @@ -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 " ")))) +