src/components/search.lisp

   1 (in-package :lisp-on-lines)
   2
   3
   4 (defmethod simple-word-search (class-name slots search-terms)
   5   (select class-name
   6           :where  (simple-word-search-where class-name slots search-terms)
   7           :flatp t))
   8
   9 (defmethod simple-word-search-where (class-name slots search-terms)
  10     (sql-or
  11                   (mapcar #'(lambda (term)
  12                               (apply #'sql-or
  13                                      (mapcar #'(lambda (slot)
  14                                                  (sql-uplike
  15                                                   (sql-slot-value class-name slot)
  16                                                   (format nil "%~a%" term)))
  17                                              slots)))
  18                           search-terms)))
  19
  20 (defmethod find-slots-of-type (model &key (type 'string)
  21                               (types '((string)) types-supplied-p))
  22   "returns a list of slots matching TYPE, or matching any of TYPES"
  23   (let (ty)
  24     (if types-supplied-p
  25         (setf ty types)
  26         (setf ty (list type)))
  27     (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
  28                                          (first st)))
  29              (list-slot-types model)))))
  30
  31 ;;;; * Simple Search Component
  32
  33 (defcomponent simple-search ()
  34   ((search-term :initarg :search-term :accessor search-term :initform "")
  35    (listing :initarg :listing :accessor listing :initform :listing)
  36    (select-returns-p :initarg :select-returns-p :accessor select-returns-p :initform nil)
  37    (search-tables :initarg :search-tables :accessor search-tables :initform nil)))
  38
  39 (defmethod render-on ((res response)(self simple-search))
  40   (<ucw:input :type "text" :accessor (search-term self))
  41   (<ucw:submit :action (do-search self)))
  42
  43 (defmethod perform-simple-search ((self simple-search) &key (base-classes (meta-model:list-base-classes :clsql)))
  44   (when (search-tables self)
  45     (setf base-classes (search-tables self)))
  46   (remove nil (mapcar #'(lambda (x)
  47                           (simple-word-search  x
  48                                                (find-slots-of-type x)
  49                                                (split-sequence #\Space (search-term self))))
  50                       base-classes)))
  51
  52
  53 (defaction do-search ((self simple-search))
  54   (let* ((target (or (slot-value self 'ucw::parent) self))
  55          (result (call-component
  56                   target
  57                   (make-instance 'simple-search-results
  58                                  :listing (listing self)
  59                                  :results
  60                                  (perform-simple-search self :base-classes
  61                                                         (remove 'claim-history (meta-model:list-base-classes :clsql)))
  62                                  :search-term (split-sequence #\Space (search-term self))))))
  63     (when result
  64       (if (select-returns-p self)
  65           (answer result)
  66           (call-component target (make-presentation result :type :viewer))))))
  67
  68 (defcomponent simple-search-results ()
  69   ((results :accessor results :initarg :results :initform nil)
  70    (listing :initarg :listing :accessor listing :initform :listing)
  71    (search-term :initarg :search-term :accessor search-term :initform nil)))
  72
  73 (defmethod view-name (view)
  74   (class-name (class-of view)))
  75
  76 (defmethod render-on ((res response) (self simple-search-results))
  77   (<:h3 (<:as-html "Search results for " (search-term self)))
  78   (dolist (r (results self))
  79     (<:fieldset
  80      (<:legend (<:as-html (format nil "Found ~A results in ~A:" (length r) (view-name (car r)))))
  81     (render-on res
  82                (embed-component
  83                 self
  84                 (make-presentation
  85                  (car r)
  86                  :type :listing
  87                  :initargs `(:instances ,r)))))))
  88
  89 (defaction ok ((self simple-search-results) &optional arg)
  90   (declare (ignore arg))
  91   (answer nil))
  92
  93
  94
  95 ;;;; * Advanced Search Component
  96
  97 (defcomponent advanced-search ()
  98   ((simple-search :component simple-search :accessor simple-search)
  99    (search-table :accessor search-table :initform nil)
 100    (search-presentation :accessor search-presentation :initform nil)))
 101
 102 (defmethod render-on ((res response) (self advanced-search))
 103   (<:h2 (<:as-html "Advanced Search"))
 104   ;; simple search :
 105   (<:fieldset
 106    (<:legend (<:as-html "simple text search"))
 107    (render-on res (simple-search self)))
 108   ;; complex-search
 109   (<:fieldset
 110    (<:legend (<:as-html "Complex Search"))
 111    (<:as-html "Choose search table:")
 112    (<ucw:select
 113     :accessor (search-table self)
 114     (dolist (tbl (meta-model:list-base-classes :clsql))
 115       (<ucw:option :value tbl (<:as-html tbl))))
 116    (<ucw:submit :action (select-search-table self) :value "select")
 117    ;;
 118    (when (search-presentation self)
 119      (<:fieldset
 120       (<:legend (<:as-html (format nil "search ~A" (search-table self))))
 121       (render-on res (embed-component self (search-presentation self)))))))
 122
 123
 124 (defun make-search-presentation (instance )
 125   (make-instance 'mewa::mewa-presentation-search
 126                      :search-presentation (make-presentation instance :type :search-model)
 127                      :list-presentation (make-presentation instance :type :listing
 128 (defaction select-search-table ((self advanced-search))
 129   (let* ((i (make-instance (search-table self)))
 130          (p (make-search-presentation i)))
 131     (embed-component self p)
 132     (setf (search-presentation self) p) ))
 133
 134
 135 (defcomponent table-search
 136
 137
 138
 139