src/attributes/standard-attributes.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; A few layers related to attributes
   4 (deflayer omit-nil-attributes)
   5
   6 (defdisplay :in-layer omit-nil-attributes
   7             :around ((attribute standard-attribute) object)
   8  (when (attribute-value object attribute)
   9    (call-next-method)))
  10
  11 (deflayer show-attribute-labels)
  12
  13 (defdisplay
  14     :in-layer show-attribute-labels
  15     :around ((attribute standard-attribute) object)
  16   (<:label
  17    :class "lol-label"
  18    (<:as-html (or (label attribute) (attribute.name attribute)) " "))
  19   (<:span
  20    :class "lol-attribute"
  21    (call-next-method)))
  22
  23 (deflayer use-pretty-labels)
  24
  25 (define-layered-method label
  26    :in-layer use-pretty-labels
  27    :around (standard-attribute)
  28  (let ((label (call-next-method)))
  29    (when label
  30      (string-capitalize
  31       (substitute #\Space #\- label)))))
  32
  33 (deflayer inspect-attributes)
  34
  35 (defdisplay :in-layer inspect-attributes
  36             :around ((attribute standard-attribute) object)
  37  (call-next-method)
  38   (<ucw:a :action (ucw::call-inspector self attribute)
  39           :title
  40           (strcat "Inspect "
  41                          (attribute.name attribute) ":"
  42                          (description.type attribute) ":"
  43                          (type-of attribute))
  44           (<:as-html "(i)")))
  45
  46 ;;;; Functional attributes
  47 (defattribute display-attribute ()
  48   ((display-arguments
  49     :accessor display-arguments
  50     :initarg :display
  51     :special t
  52     :initform nil))
  53   (:type-name display)
  54   (:documentation "Apply the display function to this object"))
  55
  56 (defdisplay ((attribute display-attribute) object)
  57   (apply #'display self (attribute-value object attribute)
  58          (display-arguments attribute)))
  59
  60 (defattribute function-attribute ()
  61   ((function :accessor function-of
  62              :initarg :function
  63              :initform #'funcall
  64              :special t))
  65   (:type-name function)
  66   (:documentation ""))
  67
  68 (defdisplay ((function function-attribute) object)
  69   (funcall (function-of function)
  70            (attribute-value object function)))
  71
  72
  73 ;;;; Attribute Grouping
  74 (defattribute attribute-group ()
  75   ()
  76   (:default-properties
  77    :group nil)
  78   (:type-name group))
  79
  80 (defdisplay ((group attribute-group) object)
  81   (apply #'display self object
  82          :attributes (attributes group)
  83          (group group)))
  84
  85
  86 (defattribute select-attribute (display-attribute)
  87   ()
  88   (:default-properties
  89     :test 'meta-model::generic-equal
  90     :options-getter (constantly nil))
  91   (:type-name select))
  92
  93 (defdisplay ((attribute select-attribute) object)
  94  (<ucw:select
  95   :accessor (attribute-value object attribute)
  96
  97   :test (test attribute)
  98   (dolist* (obj (funcall (options-getter attribute) object))
  99     (<ucw:option
 100      :value obj
 101      (apply #'display* obj (display-arguments attribute))))))
 102
 103 ;;;; * Base Types
 104
 105 (defattribute base-attribute ()
 106   ()
 107   (:default-properties
 108       :default-value ""))
 109
 110 (defdisplay ((base base-attribute) object)
 111  (<:as-html (attribute-value object base)))
 112
 113 (defattribute base-attribute ()
 114   ()
 115   (:in-layer editor)
 116   (:default-properties
 117     :callback nil
 118     :default-value nil
 119     :default-value-predicate #'null
 120     :dom-id (js:gen-js-name-string :prefix "_ucw_")
 121     :input-size nil))
 122
 123 (define-layered-function display-value (attribute value)
 124   (:method (attribute value)
 125     (if (funcall (default-value-predicate attribute) value)
 126         (default-value attribute)
 127         value)))
 128
 129 (defdisplay
 130   :in-layer editor ((field base-attribute) object)
 131   (LET ((value (attribute-value (object field) field)))
 132     (<:input
 133      :NAME
 134      (callback field)
 135      :VALUE (escape-as-html (strcat (display-value field value)))
 136      :TYPE
 137      "text"
 138      :ID
 139      (DOM-ID FIELD)
 140      :SIZE
 141      (INPUT-SIZE FIELD))))
 142
 143 (defdisplay
 144     :in-layer editor :around ((string base-attribute) object)
 145     (dletf (((callback string)
 146              (or (callback string)
 147                  (ucw::make-new-callback
 148                   #'(lambda (val)
 149                       (setf (attribute-value object string) val)))))
 150             ((object string) object))
 151       (call-next-method)))
 152
 153 ;;;; Strings
 154
 155 (defattribute string-attribute (base-attribute)
 156   ()
 157   (:type-name string)
 158   (:default-properties
 159       :escape-html-p t
 160     :size nil
 161     :max-length nil
 162     :default-value ""))
 163
 164 (defdisplay :in-layer omit-nil-attributes
 165             :around ((attribute string-attribute) object)
 166  (when (< 0 (length  (attribute-value object attribute)))
 167    (call-next-method)))
 168
 169 ;;;; default
 170 (defdisplay :in-layer viewer
 171             ((string string-attribute) object)
 172   (if (escape-html-p string)
 173       (<:as-html (attribute-value object string))
 174       (<:as-is (attribute-value object string))))
 175
 176
 177 ;;;; editor
 178 (defattribute string-attribute (base-attribute)
 179   ()
 180   (:in-layer editor)
 181   (:default-properties
 182       :callback nil))
 183
 184
 185 (defattribute string-search-attribute (string-attribute)
 186   ()
 187   (:default-properties
 188       ;; the func that find search results
 189
 190       :search-action #'(lambda ()
 191                          (with-call/cc
 192                            nil))
 193     ;; when chosing from a list of results, this function selects one.
 194     :select-function (constantly t))
 195   (:type-name string-search))
 196
 197 (defdisplay
 198    :in-layer editor :after ((search string-search-attribute) object)
 199    (<:input
 200     :TYPE "submit"
 201     :VALUE "search"
 202     :ONCLICK
 203     (JS:JS-INLINE*
 204      `(PROGN
 205        (IT.BESE.UCW::SET-ACTION-PARAMETER
 206         ,(IT.BESE.UCW::MAKE-NEW-ACTION
 207           (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
 208           (search-action search)))
 209        (RETURN T)))))
 210
 211 ;;;; textarea
 212
 213 (defattribute text-attribute (string-attribute)
 214       ()
 215       (:type-name text))
 216
 217 (defdisplay :in-layer editor ((string text-attribute) object)
 218  (<:textarea
 219   :id (dom-id string)
 220   :name (callback string)
 221   (or (attribute-value object string) "")))
 222
 223
 224
 225 ;;;; WALL-TIME
 226
 227 (defattribute wall-time-attribute (string-attribute)
 228   ()
 229   (:type-name clsql-sys:wall-time))
 230
 231 (define-layered-method attribute-value (object (attribute wall-time-attribute))
 232  (let ((date (call-next-method)))
 233    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
 234                 (format nil "~a/~a/~a" m d y)))))
 235
 236 (defdisplay
 237   ((time wall-time-attribute) object)
 238   (<:as-html (attribute-value object time)))
 239
 240
 241
 242 (defattribute image ()
 243   ()
 244   (:default-properties
 245       :css-class "lol-image"
 246     :prefix "images/"))
 247
 248 (defdisplay ((buttons (eql 'image-editor-buttons)) object)
 249   (<ucw:a :action (ok component object)
 250           (<:as-html "select this image")))
 251
 252 (defdisplay ((image image) object)
 253   (<:img
 254    :class (or (css-class image) "lol-image")
 255    :src (arnesi:strcat
 256          (or (prefix image) "images/")
 257          (escape-as-uri
 258           (attribute-value object image)))))
 259
 260 (defdisplay
 261     :in-layer editor ((image image)  object)
 262
 263     (<:div
 264      :class "lol-image-thumbnails"
 265      (<:as-html "imagie")))
 266
 267
 268
 269
 270
 271