search-dialog.rkt

#lang racket/base
; search-dialog.rkt
(require racket/class
         racket/gui/base
         racket/list
         "base.rkt"
         "config.rkt"
         "db.rkt"
         "search-results.rkt")
(provide search-tag-dialog
         search-tfield)

(define (ok-callback)
  (send search-tag-dialog show #f)
  (define tags (tfield->list search-tfield))
  (define search-type (string->symbol (hash-ref config-hash 'search-type)))
  ; make sure there aren't any nonexistant files in the database
  (clean-db!)
  (define imgs
    (if (empty? tags)
        ; table-column: (or/c (listof path?) empty?)
        (table-column 'images 'Path)
        (if (exact-search?)
            (search-db-exact search-type tags)
            (search-db-inexact search-type tags))))
  (define exclude-tags (tfield->list exclude-tfield))
  (cond [(empty? imgs)
         (display-nil-results-alert)
         (send (send search-tfield get-editor) select-all)
         (send search-tag-dialog center 'both)
         (send search-tag-dialog show #t)]
        [else
         (if (empty? exclude-tags)
             (display-tags (sort imgs path<?))
             (if (exact-search?)
                 (display-tags (sort (exclude-search-exact imgs exclude-tags) path<?))
                 (display-tags (sort (exclude-search-inexact imgs exclude-tags) path<?))))]))

(define search-tag-dialog
  (new dialog%
       [label "Ivy - Search Tags"]
       [width 400]
       [height 100]
       [style '(close-button)]))

(define search-tfield
  (new text-field%
       [parent search-tag-dialog]
       [label "Search tags:   "]
       [callback
        (λ (tf evt)
          (when (and
                 (eq? (send evt get-event-type) 'text-field-enter)
                 (not (string-null? (send tf get-value))))
            (ok-callback)))]))

(define exclude-tfield
  (new text-field%
       [parent search-tag-dialog]
       [label "Exclude tags: "]
       [callback
        (λ (tf evt)
          (when (and
                 (eq? (send evt get-event-type) 'text-field-enter)
                 (not (string-null? (send tf get-value))))
            (ok-callback)))]))

(define modifier-hpanel
  (new horizontal-panel%
       [parent search-tag-dialog]
       [alignment '(center center)]
       [stretchable-height #f]))

(define checkbox-pane
  (new pane%
       [parent modifier-hpanel]
       [alignment '(right center)]))

(define exact-checkbox
  (new check-box%
       [parent checkbox-pane]
       [label "Exact"]
       [value (hash-ref config-hash 'search-exact?)]
       [callback (λ (button event)
                   (exact-search? (send button get-value))
                   (hash-set! config-hash 'search-exact? (exact-search?))
                   (save-config))]))

(define type-pane
  (new pane%
       [parent modifier-hpanel]
       [alignment '(center center)]))

(define type-rbox
  (new radio-box%
       [parent type-pane]
       [label "Search type"]
       [choices '("and" "or")]
       [selection (let ([s (hash-ref config-hash 'search-type)])
                    (if (string=? s "and") 0 1))]
       [style '(horizontal)]
       [callback (λ (rbox evt)
                   (define search-type (send rbox get-item-label (send rbox get-selection)))
                   (hash-set! config-hash 'search-type search-type)
                   (save-config))]))

(define button-hpanel
  (new horizontal-panel%
       [parent search-tag-dialog]
       [alignment '(right center)]
       [stretchable-height #f]))

; make the button position consistent with the host system
; e.g. A Windows host will have the Ok button before Cancel
; while on *NIX it will be the other way around
(void
 (cond [(system-position-ok-before-cancel?)
        (new button%
             [parent button-hpanel]
             [label "&Ok"]
             [callback
              (λ (button event)
                (unless (string-null? (send search-tfield get-value))
                  (ok-callback)))])
        (new button%
             [parent button-hpanel]
             [label "&Cancel"]
             [callback (λ (button event)
                         (send search-tag-dialog show #f))])]
       [else
        (new button%
             [parent button-hpanel]
             [label "&Cancel"]
             [callback (λ (button event)
                         (send search-tag-dialog show #f))])
        (new button%
             [parent button-hpanel]
             [label "&Ok"]
             [callback
              (λ (button event)
                (unless (string-null? (send search-tfield get-value))
                  (ok-callback)))])]))