From 216cf9f038983c2309c256218433c78dc0ad6c3c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 20 Nov 2007 00:11:10 +0000 Subject: [PATCH] removed most stuff, replaced with a command-line searcher svn: r7773 original commit: 1c61b75f1834a2a241e5033543d0a8fc9789c3b3 --- collects/help/help.ss | 46 +-- collects/help/private/search.ss | 604 -------------------------------- 2 files changed, 6 insertions(+), 644 deletions(-) delete mode 100644 collects/help/private/search.ss diff --git a/collects/help/help.ss b/collects/help/help.ss index fddcf11e..add58808 100644 --- a/collects/help/help.ss +++ b/collects/help/help.ss @@ -1,41 +1,7 @@ -#| +#lang scheme/base -This file contains all of the initialization of the Help Desk application. -It is only loaded when Help Desk is run by itself (outside DrScheme). - -|# - -(module help mzscheme - (require "bug-report.ss" ;; load now to init the preferences early enough - (lib "cmdline.ss") - (lib "class.ss") - (lib "framework.ss" "framework") - (lib "external.ss" "browser") - "private/link.ss" - (lib "string-constant.ss" "string-constants") - (lib "mred.ss" "mred")) - - (command-line - "help-desk" - (current-command-line-arguments)) - - (add-help-desk-font-prefs #f) - (color-prefs:add-background-preferences-panel) - (preferences:add-warnings-checkbox-panel) - (install-help-browser-preference-panel) - - ;; for use by the bug report frame. - ;(namespace-set-variable-value! 'help-desk:frame-mixin (make-bug-report/help-desk-mixin 'the-hd-cookie)) - - (handler:current-create-new-window - (lambda (filename) - (let ([browser-frame '((hd-cookie-new-browser the-hd-cookie))]) - (when (and filename - (file-exists? filename)) - (send (send (send browser-frame get-hyper-panel) get-canvas) goto-url - (string-append "file://" filename) - #f)) - browser-frame))) - - (new-help-desk)) - \ No newline at end of file +(require "private/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)) diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss deleted file mode 100644 index 3c201064..00000000 --- a/collects/help/private/search.ss +++ /dev/null @@ -1,604 +0,0 @@ -(module search mzscheme - (require (lib "string-constant.ss" "string-constants") - "colldocs.ss" - "path.ss" - "manuals.ss" - (lib "port.ss") - (lib "getinfo.ss" "setup") - (lib "list.ss") - (lib "plt-match.ss") - (lib "contract.ss") - (lib "dirs.ss" "setup")) - - (provide doc-collections-changed - reset-doc-lists - extract-doc-txt - load-txt-keywords-into-hash-table) - (provide/contract - [do-search - (string? - number? - boolean? - boolean? - (listof path?) - boolean? - any/c - (-> any) - (string? any/c . -> . void?) - (string? any/c . -> . void?) - (string? string? string? path? (or/c string? number? false/c) any/c . -> . void?) - . -> . - (or/c string? false/c))] - - (build-string-finds/finds (string? - boolean? - boolean? - . -> . - (values (listof string?) - (listof (or/c regexp? string?))))) - - (non-regexp (string? . -> . string?))) - - (define doc-dirs (get-doc-search-dirs)) - - ; These are set by reset-doc-lists: - ; docs, doc-names and doc-kinds are parallel lists. doc-kinds - ; distinguishes between the two variants of docs. - ; docs : (list-of (union string (list path string))) - (define docs null) - ; doc-names : (list-of string) - (define doc-names null) - ; doc-kinds : (list-of symbol) - (define doc-kinds null) - ; doc-collection-date : (union #f number 'none) - (define doc-collection-dates (map (lambda (x) #f) doc-dirs)) - - (define (dir-date/none dir) - (with-handlers ([exn:fail:filesystem? (lambda (x) 'none)]) - (file-or-directory-modify-seconds dir))) - - (define (reset-doc-lists) - ; Locate standard HTML documentation - (define-values (std-docs std-doc-names) - (let* ([docs (find-doc-directories)] - [doc-names (map get-doc-name docs)]) - (values docs doc-names))) - - ; Check collections for doc.txt files: - (define-values (txt-docs txt-doc-names) (colldocs)) - - (set! docs (append std-docs txt-docs)) - - (set! doc-names (append - std-doc-names - (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))) - - (set! doc-collection-dates (map dir-date/none doc-dirs))) - - (define MAX-HIT-COUNT 300) - - (define (clean-html s) - (regexp-replace* - "&[^;]*;" - (regexp-replace* - "<[^>]*>" - (regexp-replace* - "&" - (regexp-replace* - ">" - (regexp-replace* - "<" - s - "<") - ">") - "\\&") - "") - "")) - - (define (with-hash-table ht key compute) - (hash-table-get - ht - key - (lambda () - (let ([v (compute)]) - (hash-table-put! ht key v) - v)))) - - (define html-keywords (make-hash-table 'equal)) - (define (load-html-keywords doc) - (with-hash-table - html-keywords - doc - (lambda () - (transform-keywords - (build-path doc "keywords"))))) - - (define html-indices (make-hash-table 'equal)) - (define (load-html-index doc) - (with-hash-table - html-indices - doc - (lambda () - (transform-hdindex - (build-path doc "hdindex"))))) - - ;; transform-hdindex : any -> (listof (list string path string string) - ;; makes sure the input from the file is well-formed and changes - ;; the bytes to paths. - (define (transform-hdindex filename) - (verify-file filename - (λ (l) - (match l - [`(,(? string? index) - ,(? string? file) - ,(? string? label) - ,(? string? title)) - #t] - [else - #f])))) - - ;; transform-keywords : any -> (listof (list string string path string string) - ;; as with transform-hdindex - (define (transform-keywords filename) - (verify-file filename - (λ (l) - (match l - [`(,(? string? keyword) - ,(? string? result) - ,(? path-string? file) - ,(? string? label) - ,(? string? title)) - #t] - [else - #f])))) - - (define (verify-file filename ele-ok?) - (let/ec k - (let ([fail (lambda (why) - (fprintf (current-error-port) - "loading docs from ~a failed: ~a\n" - (path->string filename) - why) - (k '()))]) - (with-handlers ([exn:fail:read? (lambda (x) - (fail - (format "read error when opening the file ~a" - (exn-message x))))] - [exn:fail:filesystem? - (lambda (x) - (fail (format - "filesystem error when opening the file ~a" - (exn-message x))))]) - (let ([l (if (file-exists? filename) - (call-with-input-file filename read) - '())]) - (unless (list? l) (fail "not a list")) - (for-each (lambda (l) - (unless (ele-ok? l) - (fail (format "line ~s is malformed" l)))) - l) - l))))) - - (define (parse-txt-file doc ht handle-parsing) - (with-hash-table - ht - doc - (lambda () - (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (call-with-input-file doc - handle-parsing))))) - - (define re:keyword-line (regexp "\n>")) - (define text-keywords (make-hash-table 'equal)) - - (define (load-txt-keywords doc) - (load-txt-keywords-into-hash-table text-keywords doc)) - - (define (load-txt-keywords-into-hash-table ht doc) - (parse-txt-file - (apply build-path doc) - ht - (λ (p) - (port-count-lines! p) - (let loop () - (let ([m (regexp-match re:keyword-line p)]) - (cond - [m - (let/ec k - (let* ([peek-port (let-values ([(line col pos) (port-next-location p)]) - (let ([pp (peeking-input-port p)]) - (port-count-lines! pp) - (let ([rp (relocate-input-port pp line col pos)]) - (port-count-lines! rp) - rp)))] - [entry (parameterize ([read-accept-bar-quote #f]) - (with-handlers ([exn:fail:read? - (lambda (x) - (fprintf (current-error-port) - "found > on line ~a in ~s that did not parse properly\n first-line: ~a\n exn-msg: ~a\n" - (let-values ([(line col pos) (port-next-location p)]) - line) - (path->string (apply build-path doc)) - (read-line (peeking-input-port p)) - (exn-message x)) - (k null))]) - (read peek-port)))] - [key (let loop ([l-entry entry]) - (cond - [(symbol? l-entry) l-entry] - [(keyword? l-entry) l-entry] - [(pair? l-entry) (if (and (eq? (car l-entry) 'quote) - (pair? (cdr l-entry))) - (loop (cadr l-entry)) - (loop (car l-entry)))] - [else (fprintf (current-error-port) "load-txt-keyword: bad entry in ~s: ~s\n" doc entry) - #f]))] - [content (if (symbol? entry) - (with-handlers ([exn:fail:read? (lambda (x) #f)]) - (let ([s (read peek-port)]) - (if (eq? s '::) - (format "~s ~s ~s" entry s (read peek-port)) - #f))) - #f)] - [txt-to-display - (let ([p (open-output-string)]) - (if content - (display content p) - (if (and (pair? entry) - (pair? (cdr entry)) - (eq? (car entry) 'quote)) - (fprintf p "'~s" (cadr entry)) - (display entry p))) - (get-output-string p))] - [kwd-entry - (and key - ; Make the keyword entry: - (list (format "~s" key) ; the keyword name - txt-to-display ; the text to display - (cadr doc) ; file - (let-values ([(line col pos) (port-next-location p)]) - (- pos 2)) ; label (a position in this case) - "doc.txt"))]) - (if kwd-entry - (cons kwd-entry (loop)) - (loop))))] ; title - [else null])))))) - - (define re:index-line (regexp "_([^_]*)_(.*)")) - (define text-indices (make-hash-table 'equal)) - (define (load-txt-index doc) - (parse-txt-file - (apply build-path doc) - text-indices - (λ (p) - (let loop ([start 0]) - (let* ([r (read-line p 'any)] - [next (if (eof-object? r) - start - (+ start (string-length r) 1))]) - (cond - [(eof-object? r) null] - [(regexp-match re:index-line r) - => - (lambda (m) - (append (let loop ([m m]) - (let ([s (cadr m)]) - (cons - ; Make an index entry: - (cons s start) - (let ([m (regexp-match re:index-line (caddr m))]) - (if m - (loop m) - null))))) - (loop next)))] - [else (loop next)])))))) - - (define re:splitter (regexp "^ *([^ ]+)(.*)")) - (define (split-words s) - (let ([m (regexp-match re:splitter s)]) - (if m - (cons (cadr m) - (split-words (caddr m))) - null))) - - ;; non-regexp : string -> string - (define (non-regexp s) - (list->string - (apply - append - (map - (lambda (c) - (cond - [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^)) - (list #\\ c)] - [(char-alphabetic? c) - (list #\[ (char-upcase c) (char-downcase c) #\])] - [else (list c)])) - (string->list s))))) - - (define (doc-collections-changed) - (reset-relevant-directories-state!) - (reset-doc-lists) - (set! doc-collection-dates (map (lambda (x) #f) doc-dirs)) - (set! html-keywords (make-hash-table 'equal)) - (set! html-indices (make-hash-table 'equal)) - (set! text-keywords (make-hash-table 'equal)) - (set! text-indices (make-hash-table 'equal))) - - (define max-reached #f) - - (define (build-string-finds/finds given-find regexp? exact?) - (cond - [exact? (values (list given-find) - (list given-find))] - [regexp? (values (list given-find) - (list (regexp given-find)))] - [else (let ([wl (split-words given-find)]) - (values wl - (map regexp (map non-regexp wl))))])) - - ; do-search : (string ; the search text, unprocessed - ; num ; 0 = keyword, 1 = keyword+index, 2 = all text - ; boolean ; #t if string should be used as a regexp - ; boolean ; #t if the string should match exactly (not just "contains") - ; (listof path) ; the manuals to search - ; boolean ; #t if the doc.txt files should be searched - ; value ; arbitrary key supplied to the "add" functions - ; (-> A) ; called when more than enough are found; must escape - ; (string value -> void) ; called to output a document section header (e.g., a manual name) - ; (symbol value -> void) ; called to output a document-kind section header, 'text or 'html - ; (string string string path (union string #f) value -> void) - ; ^ ^ ^ ^ ^- label within page - ; ^ ^ ^ ^- path to doc page - ; ^ ^ ^- source doc title - ; ^ ^- display label - ; ^- found entry's key - ; -> - ; (union string #f)) - (define (do-search given-find search-level regexp? exact? manuals doc-txt? - ckey maxxed-out - add-doc-section add-kind-section add-choice) - ; When new docs are installed, the directory's modification date changes: - (set! max-reached #f) - - (when (ormap (lambda (date new-date) - (cond - [(not date) #t] - [(equal? date new-date) #f] - [(eq? date 'none) #t] - [(eq? new-date 'none) #t] - [else (new-date . > . date)])) - doc-collection-dates - (map dir-date/none doc-dirs)) - (reset-doc-lists)) - - (let ([hit-count 0]) - (let-values ([(string-finds finds) (build-string-finds/finds given-find regexp? exact?)] - [(filtered-docs filtered-doc-names filtered-doc-kinds) - (filter-docs manuals doc-txt?)]) - (for-each - (lambda (doc doc-name doc-kind) - (define found-one #f) - (define (found kind) - (unless found-one - (add-doc-section doc-name ckey)) - (unless (equal? found-one kind) - (set! found-one kind) - (add-kind-section kind ckey)) - (set! hit-count (add1 hit-count)) - (unless (< hit-count MAX-HIT-COUNT) - (maxxed-out))) - - ; Keyword search - (let ([keys (case doc-kind - [(html) (load-html-keywords doc)] - [(text) (load-txt-keywords doc)] - [else null])] - [add-key-choice (lambda (v) - (when (and (pair? v) - (pair? (cdr v)) - (pair? (cddr v)) - (pair? (cdddr v)) - (pair? (cddddr v))) - (found "keyword entries") - (add-choice - (car v) ; key - (cadr v) ; display - (list-ref v 4) ; title - (if (eq? 'text doc-kind) - (apply build-path doc) - (let ([file (bytes->path - (string->bytes/utf-8 - (list-ref v 2)))]) - (if (servlet-path? file) - file - (build-path doc file)))) - (list-ref v 3) ; label - ckey)))]) - - (unless regexp? - (for-each - (lambda (v) - (when (string=? given-find (car v)) - (add-key-choice v))) - keys)) - (unless (or exact? (null? finds)) - (for-each - (lambda (v) - (when (andmap (lambda (find) (regexp-match find (car v))) finds) - (unless (and (not regexp?) (string=? given-find (car v))) - (add-key-choice v)))) - keys))) - - ; Index search - (unless (< search-level 1) - (let ([index (case doc-kind - [(html) (load-html-index doc)] - [(text) (load-txt-index doc)] - [else null])] - [add-index-choice (lambda (name desc) - (case doc-kind - [(html) - (when (and (pair? desc) - (pair? (cdr desc)) - (pair? (cddr desc))) - (found "index entries") - (add-choice - "" name - (list-ref desc 2) - (let ([filename (bytes->path (string->bytes/utf-8 (list-ref desc 0)))]) - (if (servlet-path? filename) - filename - (build-path doc filename))) - (list-ref desc 1) - ckey))] - [(text) - (found "index entries") - (add-choice - "" name - "indexed content" - (apply build-path doc) - desc - ckey)]))]) - (when index - (unless regexp? - (for-each - (lambda (v) - (when (string=? given-find (car v)) - (add-index-choice (car v) (cdr v)))) - index)) - (unless (or exact? (null? finds)) - (for-each - (lambda (v) - (when (andmap (lambda (find) (regexp-match find (car v))) finds) - (unless (and (not regexp?) (string=? given-find (car v))) - (add-index-choice (car v) (cdr v))))) - index))))) - - ; Content Search - (unless (or (< search-level 2) exact? (null? finds)) - (let ([files (case doc-kind - [(html) (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (map (lambda (x) (build-path doc x)) - (filter - (lambda (x) - (let ([str (path->string x)]) - (cond - [(or (regexp-match "--h\\.idx$" str) - (regexp-match "--h\\.ind$" str) - (regexp-match "Z-A\\.scm$" str) - (regexp-match "Z-L\\.scm$" str) - (regexp-match "gif$" str) - (regexp-match "png$" str) - (regexp-match "hdindex$" str) - (regexp-match "keywords$" str)) - #f] - [else - (file-exists? (build-path doc x))]))) - (directory-list doc))))] - [(text) (list (apply build-path doc))] - [else null])]) - (for-each - (lambda (f) - (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (with-input-from-file f - (lambda () - (let loop () - (let ([pos (file-position (current-input-port))] - [r (read-line)]) - (unless (eof-object? r) - (let ([m (andmap (lambda (find) (regexp-match find r)) finds)]) - (when m - (found "text") - (add-choice (car m) - ; Strip leading space and clean HTML - (regexp-replace - "^ [ ]*" - (if (eq? doc-kind 'html) - (clean-html r) - r) - "") - "content" - f - (if (eq? doc-kind 'text) pos "NO TAG") - ckey))) - (loop)))))))) - files)))) - filtered-docs filtered-doc-names filtered-doc-kinds) - - (if (= 0 hit-count) - (format (string-constant plt:hd:nothing-found-for) - (if (null? string-finds) - "" - (apply - string-append - (cons (format "\"~a\"" (car string-finds)) - (map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i)) - (cdr string-finds)))))) - #f)))) - - ;; filter-docs : (listof path) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist]) - ;; given the list of manuals specified by `manuals', returns the sublists of the global - ;; variables docs, doc-names, and doc-kinds that make sense for this search. - (define (filter-docs manuals doc-txt?) - (let loop ([manuals manuals]) - (cond - [(null? manuals) (if doc-txt? - (extract-doc-txt) - (values null null null))] - [else (let ([man (car manuals)]) - (let-values ([(r-doc r-doc-names r-doc-kinds) (loop (cdr manuals))] - [(t-doc t-doc-names t-doc-kinds) (find-doc man)]) - (if t-doc - (values (cons t-doc r-doc) - (cons t-doc-names r-doc-names) - (cons t-doc-kinds r-doc-kinds)) - (values r-doc - r-doc-names - r-doc-kinds))))]))) - - ;; find-doc : - ;; path -> (values doc[element of docs] doc-name[element of doc-names] doc-kind[element of doc-kinds]) - (define (find-doc man) - (let loop ([x-docs docs] - [x-doc-names doc-names] - [x-doc-kinds doc-kinds]) - (cond - [(and (null? x-docs) (null? x-doc-names) (null? x-doc-kinds)) - (values #f #f #f)] - [(or (null? x-docs) (null? x-doc-names) (null? x-doc-kinds)) - (error 'find-doc "mismatched lists\n")] - [else - (let ([doc (car x-docs)]) - (cond - [(eq? 'html (car x-doc-kinds)) - (let-values ([(base name dir?) (split-path doc)]) - (cond - [(equal? man name) - (values doc (car x-doc-names) (car x-doc-kinds))] - [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))] - [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))]))) - - ;; extract-doc-txt : (listof string) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist]) - ;; returns the manuals that are not 'html. - (define (extract-doc-txt) - (let loop ([x-docs docs] - [x-doc-names doc-names] - [x-doc-kinds doc-kinds]) - (cond - [(null? x-docs) (values null null null)] - [(or (null? x-doc-names) (null? x-doc-kinds)) - (error 'extract-doc-txt "mismatched lists\n")] - [else - (if (eq? (car x-doc-kinds) 'html) - (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds)) - (let-values ([(r-docs r-doc-names r-doc-kinds) (loop (cdr x-docs) - (cdr x-doc-names) - (cdr x-doc-kinds))]) - (values (cons (car x-docs) r-docs) - (cons (car x-doc-names) r-doc-names) - (cons (car x-doc-kinds) r-doc-kinds))))])))) - -