Expanded support for Configurable editing.
[clinton/lisp-on-lines.git] / src / ucw / standard-components.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines-ucw)
2
b7657b86 3(defparameter *source-component* nil)
4
5(defclass standard-basic-action (basic-action)
6 ((source-component :accessor action-source-component))
7 (:metaclass mopp:funcallable-standard-class))
8
9(defmethod shared-initialize :before ((action standard-basic-action) slots &rest args)
10 (declare (ignore slots args))
11 (setf (action-source-component action) *source-component*))
12
13(defmethod handle-action :around ((action standard-basic-action) a s f)
14 (let ((*source-component* (action-source-component action)))
15 (call-next-method)))
16
17(defmethod render :around (component)
18 (let ((*source-component* component))
19 (call-next-method)))
20
21
22(defun/cc call (name &rest args)
23 (call-component *source-component*
24 (apply #'make-instance name args)))
25
26(defun/cc answer (&optional val)
27 (answer-component *source-component*
28 val))
29
6de8d300 30(defclass described-component-class (standard-component-class described-class)
31 ())
32
4358148e 33(defmacro defaction (&rest args-and-body)
34 `(arnesi:defmethod/cc ,@args-and-body))
35
b7657b86 36(defparameter *default-action-class* 'standard-basic-action)
37
38(defun make-action (lambda &rest initargs &key (class *default-action-class*) &allow-other-keys)
39 "Makes a new unregistered action."
40 (remf-keywords initargs :class)
41 (apply #'make-instance class :lambda lambda initargs))
4358148e 42
b7657b86 43
4358148e 44(defclass standard-application (ucw:basic-application)
45 ())
46
47(defclass standard-request-context (ucw::standard-request-context)
48 ())
49
50(defmethod ucw:request-context-class list ((application standard-application))
51 'standard-request-context)
52
53(defvar +action-compound-name-delimiter+ #\|)
54
55(defmethod ucw::find-action-id :around ((context standard-request-context))
56 (or
6fe664d1 57 (loop
6fe664d1 58 :for (k . v) in (ucw::parameters
59 (context.request context))
60 :do(destructuring-bind (param-name &optional action-id)
61 (split-sequence:split-sequence
62 +action-compound-name-delimiter+ k)
63 (when (and action-id
64 (string=
65 ucw::+action-parameter-name+ param-name))
66 (return action-id))))
4358148e 67 (call-next-method)))
68
69(defcomponent standard-window-component
70 (ucw:basic-window-component)
71 ((body
72 :initform nil
73 :accessor window-body
74 :component t
75 :initarg :body)))
76
6de8d300 77(defmethod render-html-body ((window standard-window-component))
4358148e 78 (ucw:render (window-body window)))
b7657b86 79
80(defcomponent info-message ()
81 ((message :accessor message :initarg :message)))
82
83(defmethod render ((m info-message))
84 (<:div
85 :class "info-mssage"
86 (<:as-html (message m)))
87 (<lol:a :action (answer-component m nil) "Ok"))
88
89