adjust multi-file search to make it support searching in multiple directories
Also, add a button that populates the directories from collections and refactor it to make the "configure search" dialog easier to work with, ie so it can be run without starting up drracket
This commit is contained in:
Robby Findler
parent
b36d072e1b
commit
d5588f6209
|
|
@ -580,49 +580,6 @@
|
|||
|
||||
(preferences:set-default 'drracket:show-killed-dialog #t boolean?)
|
||||
|
||||
(drr:set-default 'drracket:multi-file-search:recur? #t boolean?)
|
||||
(drr:set-default 'drracket:multi-file-search:filter? #t boolean?)
|
||||
(drr:set-default 'drracket:multi-file-search:filter-regexp "\\.(rkt.?|scrbl|ss|scm)$" string?)
|
||||
(drr:set-default 'drracket:multi-file-search:search-string "" string?)
|
||||
(drr:set-default 'drracket:multi-file-search:search-type
|
||||
1
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(exact? x)
|
||||
(integer? x)
|
||||
(<= 0 x)
|
||||
(< x (length drracket:multi-file-search:search-types)))))
|
||||
|
||||
;; drracket:mult-file-search:search-check-boxes : (listof (listof boolean))
|
||||
(drr:set-default 'drracket:multi-file-search:search-check-boxes
|
||||
(map (λ (x) (map cdr (drracket:multi-file-search:search-type-params x)))
|
||||
drracket:multi-file-search:search-types)
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(andmap (λ (x)
|
||||
(and (list? x)
|
||||
(andmap boolean? x)))
|
||||
x))))
|
||||
|
||||
(drr:set-default 'drracket:multi-file-search:percentages
|
||||
'(1/3 2/3)
|
||||
(λ (x) (and (list? x)
|
||||
(= 2 (length x))
|
||||
(= 1 (apply + x)))))
|
||||
|
||||
(drr:set-default 'drracket:multi-file-search:frame-size '(300 . 400)
|
||||
(λ (x) (and (pair? x)
|
||||
(number? (car x))
|
||||
(number? (cdr x)))))
|
||||
(drr:set-default 'drracket:multi-file-search:directories
|
||||
'()
|
||||
(lambda (x) (and (list? x) (andmap string? x))))
|
||||
(drr:set-default 'drracket:multi-file-search:directory
|
||||
;; The default is #f because
|
||||
;; filesystem-root-list is expensive under Windows
|
||||
#f
|
||||
(lambda (x) (or (not x) (string? x))))
|
||||
|
||||
|
||||
(drr:set-default 'drracket:large-letters-font #f (λ (x)
|
||||
(or (and (pair? x)
|
||||
|
|
|
|||
|
|
@ -1,20 +1,61 @@
|
|||
#lang racket/unit
|
||||
#lang racket/base
|
||||
|
||||
(require framework
|
||||
mzlib/class
|
||||
mred
|
||||
racket/file
|
||||
racket/class
|
||||
racket/contract
|
||||
racket/unit
|
||||
racket/path
|
||||
racket/list
|
||||
mzlib/thread
|
||||
racket/gui/base
|
||||
mzlib/async-channel
|
||||
string-constants
|
||||
drracket/private/drsig)
|
||||
drracket/private/drsig
|
||||
mrlib/close-icon
|
||||
"get-module-path.rkt")
|
||||
|
||||
(define sc-browse-collections "Browse\nCollections")
|
||||
(define sc-add-another-directory "Add Another Directory")
|
||||
|
||||
(provide multi-file-search@)
|
||||
|
||||
;; search-type = (make-search-type string make-searcher (listof (cons string boolean)))
|
||||
;; the param strings are the labels for checkboxes
|
||||
;; the param booleans are the default values for the checkboxes
|
||||
;; these are the available searches
|
||||
(define-struct search-type (label make-searcher params) #:transparent)
|
||||
|
||||
;; search-info = (make-search-info (listof string) boolean (union #f regexp) search-type string)
|
||||
;; the search-string field is only informative; not used for actual searching
|
||||
(define-struct search-info (dirs recur? filter searcher search-string) #:transparent)
|
||||
|
||||
;; search-types : (listof search-type)
|
||||
(define search-types
|
||||
(list (make-search-type
|
||||
(string-constant mfs-string-match/graphics)
|
||||
(λ (info search-string) (exact-match-searcher info search-string))
|
||||
(list (cons (string-constant mfs-case-sensitive-label) #f)))
|
||||
(make-search-type
|
||||
(string-constant mfs-regexp-match/no-graphics)
|
||||
(λ (info search-string) (regexp-match-searcher info search-string))
|
||||
(list))))
|
||||
|
||||
;; search-entry = (make-search-entry string string number number number)
|
||||
(define-struct search-entry (base-dir filename line-string line-number col-number match-length)
|
||||
#:transparent)
|
||||
|
||||
;; to make these available to be defined in the unit with the right names.
|
||||
(define _search-types search-types)
|
||||
(define _search-type-params search-type-params)
|
||||
|
||||
(define-unit multi-file-search@
|
||||
(import [prefix drracket:frame: drracket:frame^]
|
||||
[prefix drracket:unit: drracket:unit^]
|
||||
[prefix drracket: drracket:interface^])
|
||||
(export drracket:multi-file-search^)
|
||||
|
||||
(define search-type-params _search-type-params)
|
||||
(define search-types _search-types)
|
||||
|
||||
;; multi-file-search : -> void
|
||||
;; opens a dialog to configure the search and initiates the search
|
||||
(define (multi-file-search)
|
||||
|
|
@ -28,31 +69,6 @@
|
|||
;; the second argument is called for each match.
|
||||
;; the arguments are: line-string line-number col-number match-length
|
||||
|
||||
|
||||
;; search-type = (make-search-type string make-searcher (listof (cons string boolean)))
|
||||
;; the param strings are the labels for checkboxes
|
||||
;; the param booleans are the default values for the checkboxes
|
||||
;; these are the available searches
|
||||
(define-struct search-type (label make-searcher params))
|
||||
|
||||
;; search-info = (make-search-info string boolean (union #f regexp) search-type string)
|
||||
;; the search-string field is only informative; not used for actual searching
|
||||
(define-struct search-info (dir recur? filter searcher search-string))
|
||||
|
||||
;; search-types : (listof search-type)
|
||||
(define search-types
|
||||
(list (make-search-type
|
||||
(string-constant mfs-string-match/graphics)
|
||||
(λ (info search-string) (exact-match-searcher info search-string))
|
||||
(list (cons (string-constant mfs-case-sensitive-label) #f)))
|
||||
(make-search-type
|
||||
(string-constant mfs-regexp-match/no-graphics)
|
||||
(λ (info search-string) (regexp-match-searcher info search-string))
|
||||
(list))))
|
||||
|
||||
;; search-entry = (make-search-entry string number number number)
|
||||
(define-struct search-entry (filename line-string line-number col-number match-length))
|
||||
|
||||
;; open-search-window : search-info -> void
|
||||
;; thread: eventspace main thread
|
||||
;; opens a window and creates the thread that does the search
|
||||
|
|
@ -65,7 +81,10 @@
|
|||
(gui-utils:trim-string (search-info-search-string search-info)
|
||||
(- 200 (string-length fmt-s)))))]))
|
||||
(define panel (make-object saved-vertical-resizable% (send frame get-area-container)))
|
||||
(define button-panel (make-object horizontal-panel% (send frame get-area-container)))
|
||||
(define button-panel (new horizontal-panel%
|
||||
[parent (send frame get-area-container)]
|
||||
[alignment '(right center)]
|
||||
[stretchable-height #f]))
|
||||
(define open-button (make-object button% (string-constant mfs-open-file) button-panel
|
||||
(λ (x y) (open-file-callback))))
|
||||
(define stop-button (make-object button% (string-constant mfs-stop-search) button-panel
|
||||
|
|
@ -104,8 +123,6 @@
|
|||
(send results-text lock #t)
|
||||
(send frame reflow-container)
|
||||
(send panel set-percentages (preferences:get 'drracket:multi-file-search:percentages))
|
||||
(send button-panel set-alignment 'right 'center)
|
||||
(send button-panel stretchable-height #f)
|
||||
(send frame show #t)
|
||||
|
||||
(let loop ()
|
||||
|
|
@ -119,7 +136,7 @@
|
|||
(send results-text search-interrupted)]
|
||||
[else
|
||||
(send results-text add-match
|
||||
(search-info-dir search-info)
|
||||
(search-entry-base-dir match)
|
||||
(search-entry-filename match)
|
||||
(search-entry-line-string match)
|
||||
(search-entry-line-number match)
|
||||
|
|
@ -220,37 +237,35 @@
|
|||
col-in-current-file)])
|
||||
(send t set-position pos)))))]
|
||||
|
||||
[define/public add-match
|
||||
(λ (base-filename full-filename line-string line-number col-number match-length)
|
||||
(define/public (add-match base-filename full-filename line-string line col match-length)
|
||||
(lock #f)
|
||||
(let* ([new-line-position (last-position)]
|
||||
[short-filename
|
||||
(define new-line-position (last-position))
|
||||
(define short-filename
|
||||
(path->string
|
||||
(find-relative-path
|
||||
(normalize-path base-filename)
|
||||
(normalize-path full-filename)))]
|
||||
[this-match-number (last-paragraph)]
|
||||
[len (string-length short-filename)]
|
||||
[insertion-start #f]
|
||||
[show-this-match
|
||||
(λ ()
|
||||
(normalize-path full-filename))))
|
||||
(define this-match-number (last-paragraph))
|
||||
(define len (string-length short-filename))
|
||||
(define insertion-start #f)
|
||||
(define (show-this-match)
|
||||
(set! match-shown? #t)
|
||||
(set! current-file full-filename)
|
||||
(set! line-in-current-file line-number)
|
||||
(set! col-in-current-file col-number)
|
||||
(set! line-in-current-file line)
|
||||
(set! col-in-current-file col)
|
||||
(set-position new-line-position new-line-position)
|
||||
(send zoom-text begin-edit-sequence)
|
||||
(send zoom-text lock #f)
|
||||
(unless (really-same-file? full-filename (send zoom-text get-filename))
|
||||
(send zoom-text load-file/gui-error full-filename))
|
||||
(send zoom-text set-position (send zoom-text paragraph-start-position line-number))
|
||||
(let ([start (+ (send zoom-text paragraph-start-position line-number)
|
||||
col-number)])
|
||||
(send zoom-text set-position (send zoom-text paragraph-start-position line))
|
||||
(let ([start (+ (send zoom-text paragraph-start-position line)
|
||||
col)])
|
||||
(send zoom-text change-style match-delta start (+ start match-length)))
|
||||
(send zoom-text lock #t)
|
||||
(send zoom-text set-caret-owner #f 'global)
|
||||
(hilite-line this-match-number)
|
||||
(send zoom-text end-edit-sequence))])
|
||||
(send zoom-text end-edit-sequence))
|
||||
(unless match-shown?
|
||||
(erase))
|
||||
(unless widest-filename
|
||||
|
|
@ -271,16 +286,16 @@
|
|||
(let ([line-start (last-position)])
|
||||
(insert line-string (last-position) (last-position))
|
||||
(change-style match-delta
|
||||
(+ line-start col-number)
|
||||
(+ line-start col-number match-length)))
|
||||
(+ line-start col)
|
||||
(+ line-start col match-length)))
|
||||
(set-clickback filename-start (last-position)
|
||||
(λ (_1 _2 _3)
|
||||
(show-this-match)))
|
||||
(insert #\newline (last-position) (last-position))
|
||||
|
||||
(unless match-shown?
|
||||
(show-this-match))))
|
||||
(lock #t))]
|
||||
(show-this-match)))
|
||||
(lock #t))
|
||||
|
||||
(define/public (search-interrupted)
|
||||
(lock #f)
|
||||
|
|
@ -296,7 +311,7 @@
|
|||
(lock #t)))
|
||||
|
||||
(inherit get-style-list set-style-list set-styles-sticky)
|
||||
(super-instantiate ())
|
||||
(super-new)
|
||||
(send zoom-text lock #t)
|
||||
(set-styles-sticky #f)
|
||||
(insert (string-constant mfs-searching...))))
|
||||
|
|
@ -324,7 +339,7 @@
|
|||
(when on?
|
||||
(send frame set-text-to-search (get-editor)))
|
||||
(super on-focus on?))
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
;; thread: eventspace main thread
|
||||
(define search-size-frame%
|
||||
|
|
@ -336,10 +351,9 @@
|
|||
(preferences:set 'drracket:multi-file-search:frame-size (cons w h))
|
||||
(super on-size w h))
|
||||
(let ([size (preferences:get 'drracket:multi-file-search:frame-size)])
|
||||
(super-instantiate ()
|
||||
(label name)
|
||||
(width (car size))
|
||||
(height (cdr size))))))
|
||||
(super-new [label name]
|
||||
[width (car size)]
|
||||
[height (cdr size)]))))
|
||||
|
||||
|
||||
;; this vertical-resizable class just remembers the percentage between the
|
||||
|
|
@ -353,246 +367,20 @@
|
|||
(when (= (length ps) 2)
|
||||
(preferences:set 'drracket:multi-file-search:percentages ps)))
|
||||
(inner (void) after-percentage-change))
|
||||
(super-instantiate ())))
|
||||
|
||||
;; configure-search : -> (union #f search-info)
|
||||
;; thread: eventspace main thread
|
||||
;; configures the search
|
||||
(define (configure-search)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
(define dialog (make-object dialog% (string-constant mfs-configure-search)
|
||||
#f 500 #f #f #f '(resize-border)))
|
||||
(define outer-files-panel (make-object vertical-panel% dialog '(border)))
|
||||
(define outer-method-panel (make-object vertical-panel% dialog '(border)))
|
||||
(define button-panel (make-object horizontal-panel% dialog))
|
||||
(define files-label (make-object message% (string-constant mfs-files-section) outer-files-panel))
|
||||
(define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel))
|
||||
(define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel))
|
||||
(define files-panel (make-object vertical-panel% files-inset-outer-panel))
|
||||
(define method-label (make-object message% (string-constant mfs-search-section) outer-method-panel))
|
||||
(define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel))
|
||||
(define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel))
|
||||
(define method-panel (make-object vertical-panel% method-inset-outer-panel))
|
||||
|
||||
(define dir-panel (make-object horizontal-panel% files-panel))
|
||||
(define dir-field
|
||||
(new combo-field%
|
||||
[parent dir-panel]
|
||||
[label (string-constant mfs-dir)]
|
||||
[choices (preferences:get 'drracket:multi-file-search:directories)]
|
||||
[stretchable-width #t]
|
||||
[stretchable-height #f]
|
||||
[callback (λ (x y) (dir-field-callback))]))
|
||||
|
||||
(define dir-button (make-object button% (string-constant browse...) dir-panel
|
||||
(λ (x y) (dir-button-callback))))
|
||||
|
||||
(define recur-check-box (make-object check-box% (string-constant mfs-recur-over-subdirectories) files-panel
|
||||
(λ (x y) (recur-check-box-callback))))
|
||||
|
||||
(define filter-panel (make-object horizontal-panel% files-panel))
|
||||
(define filter-check-box (make-object check-box% (string-constant mfs-regexp-filename-filter) filter-panel
|
||||
(λ (x y) (filter-check-box-callback))))
|
||||
(define filter-text-field (make-object text-field% #f filter-panel
|
||||
(λ (x y) (filter-text-field-callback))))
|
||||
|
||||
(define methods-choice (make-object choice% #f (map search-type-label search-types) method-panel
|
||||
(λ (x y) (methods-choice-callback))))
|
||||
(define search-text-field (make-object text-field% (string-constant mfs-search-string) method-panel
|
||||
(λ (x y) (search-text-field-callback))))
|
||||
(define active-method-panel (make-object panel:single% method-panel))
|
||||
(define methods-check-boxess
|
||||
(let ([pref (preferences:get 'drracket:multi-file-search:search-check-boxes)])
|
||||
(map
|
||||
(λ (search-type prefs-settings)
|
||||
(let ([p (make-object vertical-panel% active-method-panel)]
|
||||
[params (search-type-params search-type)])
|
||||
(send p set-alignment 'left 'center)
|
||||
(map (λ (flag-pair prefs-setting)
|
||||
(let ([cb (make-object check-box%
|
||||
(car flag-pair)
|
||||
p
|
||||
(λ (evt chk) (method-callback chk)))])
|
||||
(send cb set-value prefs-setting)
|
||||
cb))
|
||||
params
|
||||
(if (= (length params) (length prefs-settings))
|
||||
prefs-settings
|
||||
(map (λ (x) #f) params)))))
|
||||
search-types
|
||||
(if (= (length search-types) (length pref))
|
||||
pref
|
||||
(map (λ (x) '()) search-types)))))
|
||||
(define-values (ok-button cancel-button)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
button-panel
|
||||
(λ (x y) (ok-button-callback))
|
||||
(λ (x y) (cancel-button-callback))))
|
||||
(define spacer (make-object grow-box-spacer-pane% button-panel))
|
||||
|
||||
;; initialized to a searcher during the ok button callback
|
||||
;; so the user can be informed of an error before the dialog
|
||||
;; closes.
|
||||
(define searcher #f)
|
||||
|
||||
;; initialized to a regexp if the user wants to filter filenames,
|
||||
;; during the ok-button-callback, so errors can be signaled.
|
||||
(define filter #f)
|
||||
|
||||
;; title for message box that signals error messages
|
||||
(define message-box-title (string-constant mfs-drscheme-multi-file-search))
|
||||
|
||||
(define (ok-button-callback)
|
||||
(cond
|
||||
[(with-handlers ([exn:fail:filesystem?
|
||||
(λ (x) #f)])
|
||||
(directory-exists? (send dir-field get-value)))
|
||||
|
||||
(let ([df (send dir-field get-value)])
|
||||
(when (path-string? df)
|
||||
(define new-l (cons df (remove df (preferences:get 'drracket:multi-file-search:directories))))
|
||||
(preferences:set 'drracket:multi-file-search:directories
|
||||
(take new-l (min (length new-l) 10)))))
|
||||
|
||||
(let ([_searcher
|
||||
((search-type-make-searcher (list-ref search-types (send methods-choice get-selection)))
|
||||
(map (λ (cb) (send cb get-value))
|
||||
(send (send active-method-panel active-child) get-children))
|
||||
(send search-text-field get-value))])
|
||||
(if (string? _searcher)
|
||||
(message-box message-box-title _searcher dialog)
|
||||
(let ([regexp (with-handlers ([(λ (x) #t)
|
||||
(λ (exn)
|
||||
(format "~a" (exn-message exn)))])
|
||||
(and (send filter-check-box get-value)
|
||||
(regexp (send filter-text-field get-value))))])
|
||||
(if (string? regexp)
|
||||
(message-box message-box-title regexp dialog)
|
||||
(begin (set! searcher _searcher)
|
||||
(set! filter regexp)
|
||||
(set! ok? #t)
|
||||
(send dialog show #f))))))]
|
||||
[else
|
||||
(message-box message-box-title
|
||||
(format (string-constant mfs-not-a-dir) (send dir-field get-value))
|
||||
dialog)]))
|
||||
(define (cancel-button-callback)
|
||||
(send dialog show #f))
|
||||
|
||||
(define (method-callback chk)
|
||||
(preferences:set
|
||||
'drracket:multi-file-search:search-check-boxes
|
||||
(let loop ([methods-check-boxess methods-check-boxess])
|
||||
(cond
|
||||
[(null? methods-check-boxess) null]
|
||||
[else
|
||||
(cons (let loop ([methods-check-boxes (car methods-check-boxess)])
|
||||
(cond
|
||||
[(null? methods-check-boxes) null]
|
||||
[else (cons (send (car methods-check-boxes) get-value)
|
||||
(loop (cdr methods-check-boxes)))]))
|
||||
(loop (cdr methods-check-boxess)))]))))
|
||||
|
||||
(define (dir-field-callback)
|
||||
(let ([df (send dir-field get-value)])
|
||||
(when (path-string? df)
|
||||
(preferences:set 'drracket:multi-file-search:directory df))))
|
||||
|
||||
(define (filter-check-box-callback)
|
||||
(preferences:set 'drracket:multi-file-search:filter? (send filter-check-box get-value))
|
||||
(send filter-text-field enable (send filter-check-box get-value)))
|
||||
(define (filter-text-field-callback)
|
||||
(preferences:set 'drracket:multi-file-search:filter-regexp (send filter-text-field get-value)))
|
||||
|
||||
(define (recur-check-box-callback)
|
||||
(preferences:set 'drracket:multi-file-search:recur? (send recur-check-box get-value)))
|
||||
(define (methods-choice-callback)
|
||||
(define which (send methods-choice get-selection))
|
||||
(preferences:set 'drracket:multi-file-search:search-type which)
|
||||
(set-method which))
|
||||
(define (set-method which)
|
||||
(send active-method-panel active-child
|
||||
(list-ref (send active-method-panel get-children)
|
||||
which)))
|
||||
(define (search-text-field-callback)
|
||||
(preferences:set 'drracket:multi-file-search:search-string (send search-text-field get-value)))
|
||||
(define (dir-button-callback)
|
||||
(define old-d (string->path (send dir-field get-value)))
|
||||
(define new-d (get-directory #f
|
||||
#f
|
||||
(and (directory-exists? old-d)
|
||||
old-d)))
|
||||
(when (and new-d
|
||||
(directory-exists? new-d))
|
||||
(define str (path->string new-d))
|
||||
(preferences:set 'drracket:multi-file-search:directory str)
|
||||
(send dir-field set-value str)))
|
||||
|
||||
(define (get-files)
|
||||
(let ([dir (string->path (send dir-field get-value))])
|
||||
(and (directory-exists? dir)
|
||||
(if (send recur-check-box get-value)
|
||||
(build-recursive-file-list dir filter)
|
||||
(build-flat-file-list dir filter)))))
|
||||
|
||||
(define ok? #f)
|
||||
|
||||
(send button-panel set-alignment 'right 'center)
|
||||
(send dir-panel stretchable-height #f)
|
||||
(send outer-files-panel stretchable-height #f)
|
||||
(send outer-files-panel set-alignment 'left 'center)
|
||||
(send files-inset-panel min-width 20)
|
||||
(send files-inset-panel stretchable-width #f)
|
||||
(send files-panel set-alignment 'left 'center)
|
||||
|
||||
(send recur-check-box set-value (preferences:get 'drracket:multi-file-search:recur?))
|
||||
(send filter-check-box set-value (preferences:get 'drracket:multi-file-search:filter?))
|
||||
(send search-text-field set-value (preferences:get 'drracket:multi-file-search:search-string))
|
||||
(send filter-text-field set-value (preferences:get 'drracket:multi-file-search:filter-regexp))
|
||||
(send dir-field set-value (let ([p (preferences:get 'drracket:multi-file-search:directory)])
|
||||
(or p
|
||||
(let ([p (path->string (car (filesystem-root-list)))])
|
||||
(preferences:set 'drracket:multi-file-search:directory p)
|
||||
p))))
|
||||
|
||||
(send outer-method-panel stretchable-height #f)
|
||||
(send outer-method-panel set-alignment 'left 'center)
|
||||
(send method-inset-panel min-width 20)
|
||||
(send method-inset-panel stretchable-width #f)
|
||||
(send method-panel set-alignment 'left 'center)
|
||||
(send filter-panel stretchable-height #f)
|
||||
|
||||
(send methods-choice set-selection (preferences:get 'drracket:multi-file-search:search-type))
|
||||
(set-method (preferences:get 'drracket:multi-file-search:search-type))
|
||||
|
||||
(send search-text-field focus)
|
||||
(let ([t (send search-text-field get-editor)])
|
||||
(send t set-position 0 (send t last-position)))
|
||||
(send dialog show #t)
|
||||
|
||||
(and
|
||||
ok?
|
||||
(make-search-info
|
||||
(send dir-field get-value)
|
||||
(send recur-check-box get-value)
|
||||
(and (send filter-check-box get-value)
|
||||
(regexp (send filter-text-field get-value)))
|
||||
searcher
|
||||
(send search-text-field get-value))))))
|
||||
(super-new)))
|
||||
|
||||
|
||||
;; do-search : search-info text -> void
|
||||
;; thread: searching thread
|
||||
;; called in a new thread that may be broken (to indicate a stop)
|
||||
(define (do-search search-info channel)
|
||||
(let* ([dir (search-info-dir search-info)]
|
||||
[filter (search-info-filter search-info)]
|
||||
[searcher (search-info-searcher search-info)]
|
||||
[get-filenames (if (search-info-recur? search-info)
|
||||
(build-recursive-file-list dir filter)
|
||||
(build-flat-file-list dir filter))])
|
||||
(define filter (search-info-filter search-info))
|
||||
(define searcher (search-info-searcher search-info))
|
||||
(with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))])
|
||||
(for ([dir (in-list (search-info-dirs search-info))])
|
||||
(define get-filenames (if (search-info-recur? search-info)
|
||||
(build-recursive-file-list dir filter)
|
||||
(build-flat-file-list dir filter)))
|
||||
(let loop ()
|
||||
(let ([filename (get-filenames)])
|
||||
(when filename
|
||||
|
|
@ -601,13 +389,14 @@
|
|||
(async-channel-put
|
||||
channel
|
||||
(make-search-entry
|
||||
dir
|
||||
filename
|
||||
line-string
|
||||
line-number
|
||||
col-number
|
||||
match-length))))
|
||||
(loop))))
|
||||
(async-channel-put channel 'done))))
|
||||
(loop)))))
|
||||
(async-channel-put channel 'done)))
|
||||
|
||||
;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f))
|
||||
;; thread: search thread
|
||||
|
|
@ -667,7 +456,338 @@
|
|||
(set! contents (cdr contents)))]
|
||||
[else
|
||||
(set! contents (cdr contents))
|
||||
(loop)])))))
|
||||
(loop)]))))))
|
||||
|
||||
;; configure-search : -> (union #f search-info)
|
||||
;; thread: eventspace main thread
|
||||
;; configures the search
|
||||
(define (configure-search)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
(define dialog (new dialog%
|
||||
[label (string-constant mfs-configure-search)]
|
||||
[width 500]
|
||||
[style '(resize-border)]
|
||||
[stretchable-height #f]))
|
||||
(define outer-files-panel (make-object vertical-panel% dialog '(border)))
|
||||
(define outer-method-panel (make-object vertical-panel% dialog '(border)))
|
||||
(define button-panel (new horizontal-panel%
|
||||
[parent dialog]
|
||||
[alignment '(right center)]
|
||||
[stretchable-height #f]))
|
||||
(define files-label (make-object message% (string-constant mfs-files-section)
|
||||
outer-files-panel))
|
||||
(define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel))
|
||||
(define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel))
|
||||
(define files-panel (make-object vertical-panel% files-inset-outer-panel))
|
||||
(define method-label (make-object message% (string-constant mfs-search-section)
|
||||
outer-method-panel))
|
||||
(define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel))
|
||||
(define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel))
|
||||
(define method-panel (make-object vertical-panel% method-inset-outer-panel))
|
||||
|
||||
(define multi-dir+browse-collections-panel (new horizontal-panel%
|
||||
[alignment '(center top)]
|
||||
[stretchable-height #f]
|
||||
[parent files-panel]))
|
||||
(define multi-dir-panel (new vertical-panel% [parent multi-dir+browse-collections-panel]))
|
||||
(define dir-fields '())
|
||||
(define (add-a-dir-field init-value)
|
||||
(send dialog begin-container-sequence)
|
||||
(define need-to-add-closers? (and (pair? dir-fields) (null? (cdr dir-fields))))
|
||||
(define dir-panel (new horizontal-panel%
|
||||
[parent multi-dir-panel]
|
||||
[stretchable-height #f]))
|
||||
(define dir-field
|
||||
(new combo-field%
|
||||
[parent dir-panel]
|
||||
[label (string-constant mfs-dir)]
|
||||
[choices (preferences:get 'drracket:multi-file-search:directories)]
|
||||
[init-value init-value]
|
||||
[stretchable-width #t]
|
||||
[stretchable-height #f]
|
||||
[callback (λ (x y) (update-directory-prefs))]))
|
||||
|
||||
(define dir-button (new button%
|
||||
[label (string-constant browse...)]
|
||||
[parent dir-panel]
|
||||
[callback (λ (x y) (dir-button-callback))]))
|
||||
(define (dir-button-callback)
|
||||
(define old-d (string->path (send dir-field get-value)))
|
||||
(define new-d (get-directory #f
|
||||
#f
|
||||
(and (directory-exists? old-d)
|
||||
old-d)))
|
||||
(when (and new-d
|
||||
(directory-exists? new-d))
|
||||
(define str (path->string new-d))
|
||||
(send dir-field set-value str)
|
||||
(update-directory-prefs)))
|
||||
(set! dir-fields (cons dir-field dir-fields))
|
||||
(update-directory-prefs)
|
||||
(cond
|
||||
[(null? (cdr dir-fields))
|
||||
;; len=1 : add to none of them
|
||||
(void)]
|
||||
[(null? (cddr dir-fields))
|
||||
;; len=2 : add to all of them
|
||||
(for ([dir-panel (in-list (send multi-dir-panel get-children))])
|
||||
(add-a-closer dir-panel))]
|
||||
[else
|
||||
;; len>2 : add to this one
|
||||
(add-a-closer dir-panel)])
|
||||
(send dialog end-container-sequence))
|
||||
|
||||
(define (add-a-closer dir-panel)
|
||||
(define ci
|
||||
(new close-icon%
|
||||
[parent dir-panel]
|
||||
[callback
|
||||
(λ () (remove-a-dir-panel dir-panel))]))
|
||||
(send dir-panel change-children
|
||||
(λ (l)
|
||||
(append (remove ci l) (list ci)))))
|
||||
|
||||
(define (remove-a-dir-panel dir-panel)
|
||||
(define dir-field (for/or ([child (in-list (send dir-panel get-children))])
|
||||
(and (is-a? child combo-field%)
|
||||
child)))
|
||||
(set! dir-fields (remove dir-field dir-fields))
|
||||
(send multi-dir-panel change-children (λ (l) (remove dir-panel l)))
|
||||
(update-directory-prefs)
|
||||
(when (and (pair? dir-fields)
|
||||
(null? (cdr dir-fields)))
|
||||
;; only one dir field left, get rid of the close-icon
|
||||
(let loop ([parent multi-dir-panel])
|
||||
(for ([child (in-list (send parent get-children))])
|
||||
(cond
|
||||
[(is-a? child close-icon%)
|
||||
(send parent change-children (λ (l) (remove child l)))]
|
||||
[(is-a? child area-container<%>) (loop child)])))))
|
||||
|
||||
(define (update-directory-prefs)
|
||||
(define new-pref
|
||||
(for/list ([dir-field (in-list dir-fields)])
|
||||
(define dfv (send dir-field get-value))
|
||||
(and (path-string? dfv) dfv)))
|
||||
(when (andmap values new-pref)
|
||||
(preferences:set 'drracket:multi-file-search:directory new-pref)))
|
||||
|
||||
(define browse-collections-button
|
||||
(new button%
|
||||
[label sc-browse-collections]
|
||||
[parent multi-dir+browse-collections-panel]
|
||||
[callback (λ (x y)
|
||||
(define paths (get-module-path-from-user #:dir? #t))
|
||||
(when paths
|
||||
(define delta-dirs (- (length dir-fields) (length paths)))
|
||||
(cond
|
||||
[(< delta-dirs 0)
|
||||
(for ([x (in-range (- delta-dirs))])
|
||||
(add-a-dir-field ""))]
|
||||
[(> delta-dirs 0)
|
||||
(for ([x (in-range delta-dirs)]
|
||||
[dir-field (in-list (send multi-dir-panel get-children))])
|
||||
(remove-a-dir-panel dir-field))])
|
||||
(for ([path (in-list paths)]
|
||||
[dir-field (in-list dir-fields)])
|
||||
(send dir-field set-value (path->string path)))
|
||||
(update-directory-prefs)))]))
|
||||
(define recur+another-parent (new horizontal-panel%
|
||||
[parent files-panel]
|
||||
[stretchable-height #f]))
|
||||
(define recur-check-box (new check-box%
|
||||
[label (string-constant mfs-recur-over-subdirectories)]
|
||||
[parent recur+another-parent]
|
||||
[callback (λ (x y) (recur-check-box-callback))]))
|
||||
(new horizontal-panel% [parent recur+another-parent]) ;; spacer
|
||||
(define another-dir-button (new button%
|
||||
[label sc-add-another-directory]
|
||||
[parent recur+another-parent]
|
||||
[callback (λ (x y) (add-a-dir-field ""))]))
|
||||
|
||||
(define filter-panel (make-object horizontal-panel% files-panel))
|
||||
(define filter-check-box (make-object check-box%
|
||||
(string-constant mfs-regexp-filename-filter)
|
||||
filter-panel
|
||||
(λ (x y) (filter-check-box-callback))))
|
||||
(define filter-text-field (make-object text-field% #f filter-panel
|
||||
(λ (x y) (filter-text-field-callback))))
|
||||
|
||||
(define methods-choice (make-object choice%
|
||||
#f (map search-type-label search-types) method-panel
|
||||
(λ (x y) (methods-choice-callback))))
|
||||
(define search-text-field (make-object text-field%
|
||||
(string-constant mfs-search-string) method-panel
|
||||
(λ (x y) (search-text-field-callback))))
|
||||
(define active-method-panel (make-object panel:single% method-panel))
|
||||
(define methods-check-boxess
|
||||
(let ([pref (preferences:get 'drracket:multi-file-search:search-check-boxes)])
|
||||
(map
|
||||
(λ (search-type prefs-settings)
|
||||
(let ([p (make-object vertical-panel% active-method-panel)]
|
||||
[params (search-type-params search-type)])
|
||||
(send p set-alignment 'left 'center)
|
||||
(map (λ (flag-pair prefs-setting)
|
||||
(let ([cb (make-object check-box%
|
||||
(car flag-pair)
|
||||
p
|
||||
(λ (evt chk) (method-callback chk)))])
|
||||
(send cb set-value prefs-setting)
|
||||
cb))
|
||||
params
|
||||
(if (= (length params) (length prefs-settings))
|
||||
prefs-settings
|
||||
(map (λ (x) #f) params)))))
|
||||
search-types
|
||||
(if (= (length search-types) (length pref))
|
||||
pref
|
||||
(map (λ (x) '()) search-types)))))
|
||||
(define-values (ok-button cancel-button)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
button-panel
|
||||
(λ (x y) (ok-button-callback))
|
||||
(λ (x y) (cancel-button-callback))))
|
||||
(define spacer (make-object grow-box-spacer-pane% button-panel))
|
||||
|
||||
;; initialized to a searcher during the ok button callback
|
||||
;; so the user can be informed of an error before the dialog
|
||||
;; closes.
|
||||
(define searcher #f)
|
||||
|
||||
;; initialized to a regexp if the user wants to filter filenames,
|
||||
;; during the ok-button-callback, so errors can be signaled.
|
||||
(define filter #f)
|
||||
|
||||
;; title for message box that signals error messages
|
||||
(define message-box-title (string-constant mfs-drscheme-multi-file-search))
|
||||
|
||||
(define (ok-button-callback)
|
||||
(define dirs (for/list ([df (in-list dir-fields)])
|
||||
(send df get-value)))
|
||||
(define dont-exist
|
||||
(for/list ([dir (in-list dirs)]
|
||||
#:unless
|
||||
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
|
||||
(and (path-string? dir)
|
||||
(directory-exists? dir))))
|
||||
dir))
|
||||
|
||||
(cond
|
||||
[(null? dont-exist)
|
||||
(define new-l (append dirs
|
||||
(remove* dirs
|
||||
(preferences:get
|
||||
'drracket:multi-file-search:directories))))
|
||||
(preferences:set 'drracket:multi-file-search:directories
|
||||
(take new-l (min (length new-l) 10)))
|
||||
|
||||
(define _searcher
|
||||
((search-type-make-searcher (list-ref search-types (send methods-choice get-selection)))
|
||||
(map (λ (cb) (send cb get-value))
|
||||
(send (send active-method-panel active-child) get-children))
|
||||
(send search-text-field get-value)))
|
||||
(if (string? _searcher)
|
||||
(message-box message-box-title _searcher dialog)
|
||||
(let ([regexp (with-handlers ([(λ (x) #t)
|
||||
(λ (exn)
|
||||
(format "~a" (exn-message exn)))])
|
||||
(and (send filter-check-box get-value)
|
||||
(regexp (send filter-text-field get-value))))])
|
||||
(if (string? regexp)
|
||||
(message-box message-box-title regexp dialog)
|
||||
(begin (set! searcher _searcher)
|
||||
(set! filter regexp)
|
||||
(set! ok? #t)
|
||||
(send dialog show #f)))))]
|
||||
[else
|
||||
(message-box message-box-title
|
||||
(format (string-constant mfs-not-a-dir)
|
||||
(car dont-exist))
|
||||
dialog)]))
|
||||
(define (cancel-button-callback)
|
||||
(send dialog show #f))
|
||||
|
||||
(define (method-callback chk)
|
||||
(preferences:set
|
||||
'drracket:multi-file-search:search-check-boxes
|
||||
(let loop ([methods-check-boxess methods-check-boxess])
|
||||
(cond
|
||||
[(null? methods-check-boxess) null]
|
||||
[else
|
||||
(cons (let loop ([methods-check-boxes (car methods-check-boxess)])
|
||||
(cond
|
||||
[(null? methods-check-boxes) null]
|
||||
[else (cons (send (car methods-check-boxes) get-value)
|
||||
(loop (cdr methods-check-boxes)))]))
|
||||
(loop (cdr methods-check-boxess)))]))))
|
||||
|
||||
(define (filter-check-box-callback)
|
||||
(preferences:set 'drracket:multi-file-search:filter? (send filter-check-box get-value))
|
||||
(send filter-text-field enable (send filter-check-box get-value)))
|
||||
(define (filter-text-field-callback)
|
||||
(preferences:set 'drracket:multi-file-search:filter-regexp
|
||||
(send filter-text-field get-value)))
|
||||
|
||||
(define (recur-check-box-callback)
|
||||
(preferences:set 'drracket:multi-file-search:recur? (send recur-check-box get-value)))
|
||||
(define (methods-choice-callback)
|
||||
(define which (send methods-choice get-selection))
|
||||
(preferences:set 'drracket:multi-file-search:search-type which)
|
||||
(set-method which))
|
||||
(define (set-method which)
|
||||
(send active-method-panel active-child
|
||||
(list-ref (send active-method-panel get-children)
|
||||
which)))
|
||||
(define (search-text-field-callback)
|
||||
(preferences:set 'drracket:multi-file-search:search-string
|
||||
(send search-text-field get-value)))
|
||||
|
||||
(define ok? #f)
|
||||
|
||||
(send outer-files-panel stretchable-height #f)
|
||||
(send outer-files-panel set-alignment 'left 'center)
|
||||
(send files-inset-panel min-width 20)
|
||||
(send files-inset-panel stretchable-width #f)
|
||||
(send files-panel set-alignment 'left 'center)
|
||||
|
||||
(send recur-check-box set-value (preferences:get 'drracket:multi-file-search:recur?))
|
||||
(send filter-check-box set-value (preferences:get 'drracket:multi-file-search:filter?))
|
||||
(send search-text-field set-value (preferences:get 'drracket:multi-file-search:search-string))
|
||||
(send filter-text-field set-value (preferences:get 'drracket:multi-file-search:filter-regexp))
|
||||
(for ([pth/f (in-list (preferences:get 'drracket:multi-file-search:directory))])
|
||||
(define pth (or pth/f (path->string (car (filesystem-root-list)))))
|
||||
(add-a-dir-field pth))
|
||||
|
||||
(send outer-method-panel stretchable-height #f)
|
||||
(send outer-method-panel set-alignment 'left 'center)
|
||||
(send method-inset-panel min-width 20)
|
||||
(send method-inset-panel stretchable-width #f)
|
||||
(send method-panel set-alignment 'left 'center)
|
||||
(send filter-panel stretchable-height #f)
|
||||
|
||||
(send methods-choice set-selection (preferences:get 'drracket:multi-file-search:search-type))
|
||||
(set-method (preferences:get 'drracket:multi-file-search:search-type))
|
||||
|
||||
(send search-text-field focus)
|
||||
(let ([t (send search-text-field get-editor)])
|
||||
(send t set-position 0 (send t last-position)))
|
||||
(send dialog show #t)
|
||||
|
||||
(and
|
||||
ok?
|
||||
(make-search-info
|
||||
(for/list ([dir-field (in-list dir-fields)])
|
||||
(send dir-field get-value))
|
||||
(send recur-check-box get-value)
|
||||
(and (send filter-check-box get-value)
|
||||
(regexp (send filter-text-field get-value)))
|
||||
searcher
|
||||
(send search-text-field get-value))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; exact-match-searcher : make-searcher
|
||||
(define (exact-match-searcher params key) ;; thread: main eventspace thread
|
||||
|
|
@ -713,3 +833,40 @@
|
|||
(- (cdr pos) (car pos))))))
|
||||
(loop (+ line-number 1))]))))
|
||||
#:mode 'text)))))
|
||||
|
||||
|
||||
(preferences:set-default 'drracket:multi-file-search:directories
|
||||
'()
|
||||
(lambda (x) (and (list? x) (andmap string? x))))
|
||||
;; drracket:mult-file-search:search-check-boxes : (listof (listof boolean))
|
||||
(preferences:set-default 'drracket:multi-file-search:search-check-boxes
|
||||
(map (λ (x) (map cdr (search-type-params x))) search-types)
|
||||
(listof (listof boolean?)))
|
||||
(preferences:set-default 'drracket:multi-file-search:recur? #t boolean?)
|
||||
(preferences:set-default 'drracket:multi-file-search:filter? #t boolean?)
|
||||
(preferences:set-default 'drracket:multi-file-search:filter-regexp
|
||||
"\\.(rkt[^~]?|scrbl|ss|scm)$" string?)
|
||||
(preferences:set-default 'drracket:multi-file-search:search-string "" string?)
|
||||
(preferences:set-default 'drracket:multi-file-search:search-type
|
||||
1
|
||||
(λ (x)
|
||||
(and (exact-nonnegative-integer? x)
|
||||
(< x (length search-types)))))
|
||||
|
||||
(preferences:set-default 'drracket:multi-file-search:percentages
|
||||
'(1/3 2/3)
|
||||
(and/c (listof (between/c 0 1))
|
||||
(λ (x) (= 1 (apply + x)))))
|
||||
|
||||
(preferences:set-default 'drracket:multi-file-search:frame-size '(300 . 400)
|
||||
(cons/c dimension-integer? dimension-integer?))
|
||||
(preferences:set-default 'drracket:multi-file-search:directory
|
||||
;; #f means the filesystem root, but that's
|
||||
;; expensive to compute under windows so we
|
||||
;; delay the computation until the dialog
|
||||
;; is opened.
|
||||
'(#f)
|
||||
(non-empty-listof (or/c #f (and/c string? path-string?))))
|
||||
|
||||
|
||||
(module+ main (configure-search))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user