Renamed fill-gaps-only to fill-gaps-only-p, and added the :fill-gaps-only-p initarg...
[clinton/lisp-on-lines.git] / src / backend / ucw.lisp
1 (in-package :it.bese.ucw)
2
3 (defslot-presentation clsql-wall-time-slot-presentation ()
4 ()
5 (:type-name clsql-sys:wall-time))
6
7 (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
8 (<:as-html (presentation-slot-value slot instance)))
9
10 (defslot-presentation mewa-relation-slot-presentation ()
11 ((slot-name :accessor slot-name :initarg :slot-name)
12 (foreign-instance :accessor foreign-instance)
13 (editablep :initarg :editablep :accessor editablep :initform :inherit))
14 (:type-name relation))
15
16 (defmethod present-relation (( slot mewa-relation-slot-presentation) instance)
17 (when (foreign-instance slot)
18 (when (eql (editablep slot) :inherit)
19 (setf (editablep slot) (editablep (parent slot))))
20 (flet ((render-slot ()
21 (<ucw:render-component
22 :component (mewa::make-presentation (foreign-instance slot) :type :one-line :initargs '(:global-properties (:editablep nil))))))
23 (if (editablep slot)
24 (render-slot)
25 (<ucw:a :action (view-instance slot instance)
26 (render-slot))))))
27
28 (defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
29 (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot)))
30 (present-relation slot instance))
31
32 (defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
33 ()
34 (:type-name foreign-key)
35 (:default-initargs :editablep :inherit))
36
37 (defaction view-instance ((self component) instance &rest initargs)
38 (call-component (parent self) (apply #'mewa:make-presentation (foreign-instance self) initargs)))
39
40 (defmethod present-slot :before ((slot foreign-key-slot-presentation) instance)
41 (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot))))
42
43
44 (defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
45 ()
46 (:type-name has-many))
47
48 (defmethod present-slot ((slot has-many-slot-presentation) instance)
49 (<:ul
50 (dolist (s (slot-value instance (slot-name slot)))
51 (setf (foreign-instance slot) s)
52 (<:li (present-relation slot instance)))))
53
54
55
56 (defslot-presentation has-a-slot-presentation (one-of-presentation)
57 ((key :initarg :key :accessor key))
58 (:type-name has-a))
59
60 (defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
61 (slot-value object slot-name))
62
63 (defmethod present-slot ((slot has-a-slot-presentation) instance)
64 (<:as-html (presentation-slot-value slot instance))
65 (if (editablep slot)
66 (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
67 (when (allow-nil-p slot)
68 (<ucw:option :value nil (<:as-html (none-label slot))))
69 (dolist (option (get-foreign-instances (presentation slot) instance))
70 (setf (instance (presentation slot)) option)
71 (<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
72 (if (presentation-slot-value slot instance)
73 (progn
74 (setf (instance (presentation slot)) (presentation-slot-value slot instance))
75 (present (presentation slot)))
76 (<:as-html "--"))))