subclass UCW's form classes in the editor layer.
[clinton/lisp-on-lines.git] / src / relational-attributes.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; * Relational Attributes
4
5
6 ;;;; ** has-a
7 ;;;; Used for foreign keys, currently only works with clsql.
8
9 (defattribute has-a ()
10 ()
11 (:default-properties
12 :has-a nil
13 :test 'meta-model::generic-equal))
14
15 ;;
16 (define-layered-method attribute-value (object (attribute has-a))
17 (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
18
19 (define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
20 (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
21 (setf (attribute-value object attribute) val)))
22
23
24
25 (define-layered-function find-all-foreign-objects (o a))
26
27 (define-layered-method find-all-foreign-objects (object (attribute has-a))
28 (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
29
30 (defdisplay ((attribute has-a) object)
31 (let ((args (plist-union (description.properties attribute) (has-a attribute)))
32 (val (attribute-value object attribute)))
33 (when val
34 (setf (getf args :type)
35 'lol::one-line))
36 (apply #'display* val
37 args)))
38
39
40 (defdisplay
41 :in-layer editor ((attribute has-a) object)
42 (<ucw:select
43 :accessor (attribute-value object attribute)
44
45 :test (test attribute)
46 (dolist* (obj (find-all-foreign-objects object attribute))
47 (<ucw:option
48 :value obj
49 (display* obj :type 'as-string)))))
50
51
52 ;;;; ** Has-Many attribute
53
54 (defattribute has-many ()
55 ()
56 (:default-properties
57 :add-new-label "Add New"
58 :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
59 (:default-initargs
60 :type 'lol::one-line))
61
62 (define-layered-method
63 attribute-value (object (has-many has-many))
64 (slot-value object (slot-name has-many)))
65
66 (defdisplay ((attribute has-many) object)
67 ;
68 ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
69
70 (<:div :style "clear:both;"
71 (let* ((i (apply #'sort (slot-value object (slot-name attribute))
72 (sort-arguments attribute))))
73 (<:ul
74 (dolist* (x i)
75 (<:li (display* x
76 :type 'lol::one-line
77 :layers '(+ wrap-link - label-attributes))))))))
78
79
80 (defun find-many-to-many-class (slot-name instance)
81 (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
82 :db-info))
83 (jc (make-instance (getf imd :join-class)))
84 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
85 :db-info)))
86 (getf jcmd :join-class)))
87
88
89 (defattribute many-to-many ()
90 ())
91
92
93
94 (defdisplay ((attribute many-to-many) object)
95 (<:as-html "ASDASD"))
96
97 #+nil(let ((instances (select-instances object t))
98 new-instance)
99 (<:ul
100 (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
101 (<:as-html "Add New")))
102 (<:li (<ucw:button :action (add-new-relation component object new-instance)
103 (<:as-html "Add:"))
104 (<ucw:select :accessor new-instance
105 (arnesi:dolist* (i instances)
106 (<ucw:option
107 :value i
108 (display component i :type 'one-line)))))
109 (dolist* (i (attribute-value object attribute))
110 (<:li
111 (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
112 (<:as-html "(view) "))
113 (<ucw:a :action (delete-relationship slot (second i) instance)
114 (<:as-html "(remove) "))
115 (display component object)))))
116 ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
117