b972a0940d
being edited in DrRacket (via places) Added an API to let tools have access to that information (and compute more stuff) Used that to make an online version of Check Syntax which led to a separately callable Check Syntax API.
674 lines
30 KiB
Racket
674 lines
30 KiB
Racket
#lang racket/unit
|
|
(require framework
|
|
mzlib/class
|
|
mred
|
|
racket/file
|
|
racket/path
|
|
mzlib/thread
|
|
mzlib/async-channel
|
|
string-constants
|
|
"drsig.rkt")
|
|
|
|
(import [prefix drracket:frame: drracket:frame^]
|
|
[prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export drracket:multi-file-search^)
|
|
|
|
;; multi-file-search : -> void
|
|
;; opens a dialog to configure the search and initiates the search
|
|
(define (multi-file-search)
|
|
(let ([search-info (configure-search)])
|
|
(when search-info
|
|
(open-search-window search-info))))
|
|
|
|
;; searcher = (string (string int int int -> void) -> void)
|
|
;; this performs a single search.
|
|
;; the first argument is the filename to be searched
|
|
;; 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
|
|
(define (open-search-window search-info)
|
|
(define frame (new search-size-frame%
|
|
[name (format (string-constant mfs-drscheme-multi-file-search-title)
|
|
(search-info-search-string search-info))]))
|
|
(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 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
|
|
(λ (x y) (stop-callback))))
|
|
(define grow-box-pane (make-object grow-box-spacer-pane% button-panel))
|
|
|
|
(define zoom-text (make-object scheme:text%))
|
|
(define results-text (make-object results-text% zoom-text))
|
|
(define results-ec (instantiate searching-canvas% ()
|
|
(parent panel)
|
|
(editor results-text)
|
|
(frame frame)))
|
|
(define zoom-ec (instantiate searching-canvas% ()
|
|
(parent panel)
|
|
(editor zoom-text)
|
|
(frame frame)))
|
|
|
|
(define (open-file-callback)
|
|
(send results-text open-file))
|
|
|
|
;; sometimes, breaking the other thread puts
|
|
;; the break message in the channel behind
|
|
;; many many requests. Rather than show those,
|
|
;; we use the `broken?' flag as a shortcut.
|
|
(define broken? #f)
|
|
(define (stop-callback)
|
|
(break-thread search-thd)
|
|
(set! broken? #t)
|
|
(send stop-button enable #f))
|
|
|
|
;; channel : async-channel[(union 'done search-entry)]
|
|
(define channel (make-async-channel 100))
|
|
(define search-thd (thread (λ () (do-search search-info channel))))
|
|
|
|
(send frame set-text-to-search results-text) ;; just to initialize it to something.
|
|
(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 ()
|
|
(let ([match (yield channel)])
|
|
(yield)
|
|
(cond
|
|
[(eq? match 'done)
|
|
(send results-text search-complete)
|
|
(send stop-button enable #f)]
|
|
[(or broken? (eq? match 'break))
|
|
(send results-text search-interrupted)]
|
|
[else
|
|
(send results-text add-match
|
|
(search-info-dir search-info)
|
|
(search-entry-filename match)
|
|
(search-entry-line-string match)
|
|
(search-entry-line-number match)
|
|
(search-entry-col-number match)
|
|
(search-entry-match-length match))
|
|
(loop)]))))
|
|
|
|
(define results-super-text%
|
|
(text:hide-caret/selection-mixin
|
|
(text:basic-mixin
|
|
(editor:standard-style-list-mixin
|
|
(editor:basic-mixin
|
|
text%)))))
|
|
|
|
;; results-text% : derived from text%
|
|
;; init args: zoom-text
|
|
;; zoom-text : (instance-of text%)
|
|
;; public-methods:
|
|
;; add-match : string string int int int int -> void
|
|
;; adds a match to the text
|
|
;; search-interrupted : -> void
|
|
;; inserts a message saying "search interrupted".
|
|
;; search-complete is not expected to be called if this method is called.
|
|
;; search-complete : -> void
|
|
;; inserts a message saying "no matches found" if none were reported
|
|
(define results-text%
|
|
(class results-super-text%
|
|
(init-field zoom-text)
|
|
(inherit insert last-paragraph erase
|
|
paragraph-start-position paragraph-end-position
|
|
last-position change-style
|
|
set-clickback set-position
|
|
end-edit-sequence begin-edit-sequence
|
|
lock)
|
|
|
|
[define filename-delta (make-object style-delta% 'change-bold)]
|
|
[define match-delta (let ([d (make-object style-delta%)])
|
|
(send d set-delta-foreground
|
|
(make-object color%
|
|
0
|
|
160
|
|
0))
|
|
d)]
|
|
[define hilite-line-delta (make-object style-delta% 'change-style 'italic)]
|
|
[define unhilite-line-delta (make-object style-delta% 'change-style 'normal)]
|
|
[define widest-filename #f]
|
|
[define/private indent-all-lines
|
|
;; indent-all-lines : number -> void
|
|
;; inserts `offset' spaces to the beginning of each line,
|
|
;; except the last one. Must be at least one such line in the text.
|
|
(λ (offset)
|
|
(let ([spaces (make-string offset #\space)])
|
|
(let loop ([para (- (last-paragraph) 1)])
|
|
(let ([para-start (paragraph-start-position para)])
|
|
(insert spaces para-start para-start)
|
|
(change-style filename-delta para-start (+ para-start offset)))
|
|
(unless (zero? para)
|
|
(loop (- para 1))))))]
|
|
|
|
;; match-shown? : boolean
|
|
;; indicates if a match has ever been shown.
|
|
;; if not, need to clean out the "searching" message
|
|
;; and show a match. Done in `add-match'
|
|
[define match-shown? #f]
|
|
|
|
;; current-file : (union #f string)
|
|
;; the name of the currently viewed file, if one if viewed.
|
|
;; line-in-current-file and col-in-current-file are linked
|
|
[define current-file #f]
|
|
[define line-in-current-file #f]
|
|
[define col-in-current-file #f]
|
|
|
|
[define old-line #f]
|
|
[define/private hilite-line
|
|
(λ (line)
|
|
(begin-edit-sequence)
|
|
(lock #f)
|
|
(when old-line
|
|
(change-style unhilite-line-delta
|
|
(paragraph-start-position old-line)
|
|
(paragraph-end-position old-line)))
|
|
(when line
|
|
(change-style hilite-line-delta
|
|
(paragraph-start-position line)
|
|
(paragraph-end-position line)))
|
|
(set! old-line line)
|
|
(lock #t)
|
|
(end-edit-sequence))]
|
|
|
|
[define/public (open-file)
|
|
(when current-file
|
|
(let ([f (handler:edit-file current-file)])
|
|
(when (and f
|
|
(is-a? f drracket:unit:frame<%>))
|
|
(let* ([t (send f get-definitions-text)]
|
|
[pos (+ (send t paragraph-start-position line-in-current-file)
|
|
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)
|
|
(lock #f)
|
|
(let* ([new-line-position (last-position)]
|
|
[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
|
|
(λ ()
|
|
(set! match-shown? #t)
|
|
(set! current-file full-filename)
|
|
(set! line-in-current-file line-number)
|
|
(set! col-in-current-file col-number)
|
|
(set-position new-line-position new-line-position)
|
|
(send zoom-text begin-edit-sequence)
|
|
(send zoom-text lock #f)
|
|
(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 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))])
|
|
(unless match-shown?
|
|
(erase))
|
|
(unless widest-filename
|
|
(set! widest-filename len))
|
|
(if (<= len widest-filename)
|
|
(begin
|
|
(set! insertion-start (last-position))
|
|
(insert (make-string (- widest-filename len) #\space)
|
|
(last-position) (last-position)))
|
|
(begin
|
|
(indent-all-lines (- len widest-filename))
|
|
(set! insertion-start (last-position))
|
|
(set! widest-filename len)))
|
|
(let ([filename-start (last-position)])
|
|
(insert short-filename (last-position) (last-position))
|
|
(insert ": " (last-position) (last-position))
|
|
(change-style filename-delta insertion-start (last-position))
|
|
(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)))
|
|
(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))]
|
|
|
|
(define/public (search-interrupted)
|
|
(lock #f)
|
|
(insert #\newline (last-position) (last-position))
|
|
(insert (string-constant mfs-search-interrupted) (last-position) (last-position))
|
|
(lock #t))
|
|
|
|
(define/public (search-complete)
|
|
(unless match-shown?
|
|
(lock #f)
|
|
(insert #\newline (last-position) (last-position))
|
|
(insert (string-constant mfs-no-matches-found) (last-position) (last-position))
|
|
(lock #t)))
|
|
|
|
(inherit get-style-list set-style-list set-styles-sticky)
|
|
(super-instantiate ())
|
|
(send zoom-text lock #t)
|
|
(set-styles-sticky #f)
|
|
(insert (string-constant mfs-searching...))))
|
|
|
|
;; collaborates with search-size-frame%
|
|
(define searching-canvas%
|
|
(class canvas:basic%
|
|
(init-field frame)
|
|
(inherit get-editor)
|
|
(define/override (on-focus on?)
|
|
(when on?
|
|
(send frame set-text-to-search (get-editor)))
|
|
(super on-focus on?))
|
|
(super-instantiate ())))
|
|
|
|
;; thread: eventspace main thread
|
|
(define search-size-frame%
|
|
(class (drracket:frame:basics-mixin
|
|
(frame:searchable-mixin
|
|
frame:standard-menus%))
|
|
(init-field name)
|
|
(define/override (on-size w h)
|
|
(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))))))
|
|
|
|
|
|
;; this vertical-resizable class just remembers the percentage between the
|
|
;; two panels
|
|
;; thread: eventspace main thread
|
|
(define saved-vertical-resizable%
|
|
(class panel:vertical-dragable%
|
|
(inherit get-percentages)
|
|
(define/augment (after-percentage-change)
|
|
(let ([ps (get-percentages)])
|
|
(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)
|
|
(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 (make-object text-field% (string-constant mfs-dir) dir-panel
|
|
(λ (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 signalled.
|
|
(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 ([_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 (string->path 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)
|
|
(let ([d (get-directory)])
|
|
(when (and d
|
|
(directory-exists? d))
|
|
(preferences:set 'drracket:multi-file-search:directory d)
|
|
(send dir-field set-value (path->string d)))))
|
|
|
|
(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 (path->string
|
|
(let ([p (preferences:get 'drracket:multi-file-search:directory)])
|
|
(if (not p)
|
|
(let ([p (car (filesystem-root-list))])
|
|
(preferences:set 'drracket:multi-file-search:directory p)
|
|
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)
|
|
(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))))
|
|
|
|
|
|
;; 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))])
|
|
(with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))])
|
|
(let loop ()
|
|
(let ([filename (get-filenames)])
|
|
(when filename
|
|
(searcher filename
|
|
(λ (line-string line-number col-number match-length)
|
|
(async-channel-put
|
|
channel
|
|
(make-search-entry
|
|
filename
|
|
line-string
|
|
line-number
|
|
col-number
|
|
match-length))))
|
|
(loop))))
|
|
(async-channel-put channel 'done))))
|
|
|
|
;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f))
|
|
;; thread: search thread
|
|
(define (build-recursive-file-list dir filter)
|
|
(letrec ([touched (make-hash)]
|
|
[next-thunk (λ () (process-dir dir (λ () #f)))]
|
|
[process-dir
|
|
; string[dirname] (listof string[filename]) -> (listof string[filename])
|
|
(λ (dir k)
|
|
(let* ([key (normalize-path dir)]
|
|
[traversed? (hash-ref touched key (λ () #f))])
|
|
(if traversed?
|
|
(k)
|
|
(begin
|
|
(hash-set! touched key #t)
|
|
(process-dir-contents
|
|
(map (λ (x) (build-path dir x))
|
|
(directory-list dir))
|
|
k)))))]
|
|
[process-dir-contents
|
|
; string[dirname] (listof string[filename]) -> (listof string[filename])
|
|
(λ (contents k)
|
|
(cond
|
|
[(null? contents)
|
|
(k)]
|
|
[else
|
|
(let ([file/dir (car contents)])
|
|
(cond
|
|
[(and (file-exists? file/dir)
|
|
(or (not filter)
|
|
(regexp-match filter (path->string file/dir))))
|
|
(set! next-thunk
|
|
(λ ()
|
|
(process-dir-contents (cdr contents) k)))
|
|
file/dir]
|
|
[(directory-exists? file/dir)
|
|
(process-dir-contents
|
|
(cdr contents)
|
|
(λ ()
|
|
(process-dir file/dir k)))]
|
|
[else
|
|
(process-dir-contents (cdr contents) k)]))]))])
|
|
(λ () (next-thunk))))
|
|
|
|
;; build-flat-file-list : path (union #f regexp) -> (-> (union string #f))
|
|
;; thread: searching thread
|
|
(define (build-flat-file-list dir filter)
|
|
(let ([contents (map (λ (x) (build-path dir x)) (directory-list dir))])
|
|
(λ ()
|
|
(let loop ()
|
|
(cond
|
|
[(null? contents)
|
|
#f]
|
|
[(and filter (regexp-match filter (path->string (car contents))))
|
|
(begin0
|
|
(car contents)
|
|
(set! contents (cdr contents)))]
|
|
[else
|
|
(set! contents (cdr contents))
|
|
(loop)])))))
|
|
|
|
;; exact-match-searcher : make-searcher
|
|
(define (exact-match-searcher params key) ;; thread: main eventspace thread
|
|
(let ([case-sensitive? (car params)])
|
|
(λ (filename add-entry) ;; thread: searching thread
|
|
(let ([text (make-object text:basic%)])
|
|
(send text load-file filename)
|
|
(let loop ([pos 0])
|
|
(let ([found (send text find-string key 'forward pos 'eof #t case-sensitive?)])
|
|
(when found
|
|
(let* ([para (send text position-paragraph found)]
|
|
[para-start (send text paragraph-start-position para)]
|
|
[line-string (send text get-text para-start
|
|
(send text paragraph-end-position para))]
|
|
[line-number para]
|
|
[col-number (- found para-start)]
|
|
[match-length (string-length key)])
|
|
(add-entry line-string line-number col-number match-length)
|
|
(loop (+ found 1))))))))))
|
|
|
|
;; regexp-match-searcher : make-searcher
|
|
;; thread: searching thread
|
|
(define (regexp-match-searcher parmas key) ;; thread: main eventspace thread
|
|
(let ([re:key (with-handlers ([(λ (x) #t)
|
|
(λ (exn)
|
|
(format "~a" (exn-message exn)))])
|
|
(regexp key))])
|
|
(if (string? re:key)
|
|
re:key
|
|
(λ (filename add-entry) ;; thread: searching thread
|
|
(call-with-input-file filename
|
|
(λ (port)
|
|
(let loop ([line-number 0])
|
|
(let ([line (read-line port)])
|
|
(cond
|
|
[(eof-object? line) (void)]
|
|
[else
|
|
(let ([match (regexp-match-positions re:key line)])
|
|
(when match
|
|
(let ([pos (car match)])
|
|
(add-entry line line-number
|
|
(car pos)
|
|
(- (cdr pos) (car pos))))))
|
|
(loop (+ line-number 1))]))))
|
|
#:mode 'text)))))
|