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