Drop usage of defaction
[clinton/lisp-on-lines.git] / 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 (defmethod/cc 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 (defmethod/cc 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 (defmethod/cc 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