src/ucw/standard-components.lisp

   1 (in-package :lisp-on-lines-ucw)
   2
   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
  30 (defclass described-component-class (standard-component-class described-class)
  31   ())
  32
  33 (defmacro defaction (&rest args-and-body)
  34   `(arnesi:defmethod/cc ,@args-and-body))
  35
  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))
  42
  43
  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
  57    (loop
  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))))
  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
  77 (defmethod render-html-body ((window standard-window-component))
  78   (ucw:render (window-body window)))
  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