src/attributes/standard-attributes.lisp

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