src/standard-display.lisp

   1 (in-package :lisp-on-lines)
   2
   3
   4 ;;;; The Standard Layer Hierarchy
   5 (deflayer viewer)
   6 (deflayer editor (viewer))
   7 (deflayer creator (editor))
   8
   9 ;;;; 'Mixin' Layers
  10 (deflayer one-line)
  11
  12 (deflayer wrap-form)
  13
  14 (deflayer as-table)
  15
  16 (define-attributes (contextl-default)
  17   (:viewer viewer)
  18   (:editor editor)
  19   (:creator creator))
  20
  21
  22 (defmacro with-component ((component) &body body)
  23   `(let ((self ,component))
  24     (flet ((display* (thing &rest args)
  25              (apply #'display ,component thing args)))
  26       ,@body)))
  27
  28
  29 (define-layered-function find-display-type (object))
  30
  31 (define-layered-method find-display-type (object)
  32   'viewer)
  33
  34 (define-layered-function find-display-layers (object))
  35
  36 (define-layered-method find-display-layers (object)
  37   "layered function"
  38   nil)
  39
  40 (defmacro call-display (component object &rest args)
  41   `(call-component ,component (make-instance 'standard-display-component
  42                          :display #'(lambda (component)
  43                                       (with-component (component)
  44                                         (display ,component ,object ,@args))))))
  45
  46 (defmethod find-plist (object)
  47   (list))
  48
  49 (defmethod find-plist ((attribute standard-attribute))
  50   (warn "atttributre plist ~A" (attribute.plist attribute))
  51   (attribute.plist attribute))
  52
  53 (defmacro with-plist ((plist-form &optional prefix)  &body body)
  54   (with-unique-names (p)
  55     (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
  56           (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
  57           (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
  58       `(let ((,p ,plist-form))
  59         (flet ((,get  (p)
  60                  (getf ,p p))
  61                (,set (p v)
  62                  (setf (getf ,p p) v))
  63                (,props ()
  64                  ,p))
  65           (declare (ignorable #',get #',set #',props))
  66           ,@body)))))
  67
  68
  69 ;;;;; Macros
  70 (defmacro do-attributes ((var occurence attributes) &body body)
  71   (with-unique-names (att plist type)
  72     `(loop for ,att in ,attributes
  73       do (let* ((,att (ensure-list ,att))
  74                 (,plist (rest ,att))
  75                 (,type (getf ,plist :type))
  76                 (,var (if ,type
  77                           (make-attribute :name (first ,att) :type ,type :plist ,plist)
  78                           (find-attribute ,occurence (first ,att)))))
  79            (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)
  80              ,@body)))))
  81
  82
  83 (defmacro defdisplay ((&key
  84                        (in-layer nil layer-supplied-p)
  85                        (combination nil combination-supplied-p)
  86                        (description '(occurence standard-occurence) description-supplied-p)
  87                        (component 'component)
  88                        ((:class object)  nil))
  89                       &body body)
  90   (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))
  91   `(define-layered-method display-using-description
  92     ,@(when layer-supplied-p `(:in-layer ,in-layer))
  93     ,@(when combination-supplied-p `(,combination))
  94     (,description ,component
  95      ,class-spec  properties)
  96
  97
  98     (with-plist ((plist-union properties (find-plist ,(car description))))
  99
 100       ,(if (not description-supplied-p)
 101            `(flet ((attributes ()
 102                     (or (getp :attributes)
 103                         (list-slots ,(car (ensure-list class-spec))))))
 104              (declare (ignorable #'attributes))
 105
 106              ,@body)
 107            `(progn ,@body))))  )
 108   )
 109
 110
 111 (define-layered-function display (component object &rest args)
 112   (:documentation
 113    "Displays OBJECT in COMPONENT.
 114
 115  default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
 116
 117 (define-layered-method display
 118     ((component t) (object standard-object) &rest args &key layers (type 'viewer)  &allow-other-keys)
 119   (let* ((occurence (find-occurence object))
 120          (plist (attribute.plist
 121                  (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
 122          (layers (append (when type (loop for ty in (ensure-list type)
 123                                           nconc `(+ ,ty)))
 124                          layers
 125                          (getf plist :layers))))
 126     (funcall-with-layers
 127      layers
 128      #'display-using-description  occurence component object (plist-union args plist))))
 129
 130
 131 (define-layered-method display
 132   ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
 133   (funcall-with-layers
 134    layers
 135    #'display-using-description  t component object args))
 136
 137
 138 (define-layered-function display-using-description (description component object properties)
 139   (:documentation
 140    "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
 141
 142 (define-layered-method display-using-description (description component object properties)
 143   "The standard display simply prints the object"
 144   (declare (ignore component properties description))
 145   (<:as-html object))
 146
 147 ;;;; * Object Presentations
 148 (define-layered-method display-using-description
 149   ((occurence standard-occurence) component object properties)
 150
 151   (with-plist (properties o)
 152     (loop for att in (or (o-getp :attributes) (list-slots object))
 153           do (let* ((att (ensure-list att))
 154                     (attribute (find-attribute occurence (first att))))
 155                (with-plist ((plist-union (rest att) (find-plist attribute)))
 156                  (<:p :class "attribute"
 157                       (and (o-getp :show-labels-p)
 158                            (<:span :class "label" (<:as-html (or (getp :label) "")  " ")))
 159                       (display-using-description
 160                        attribute
 161                        component
 162                        object
 163                        (rest att))))))))
 164
 165
 166
 167
 168 ;;;; ** One line
 169 (defdisplay (:in-layer one-line)
 170   "The one line presentation just displays the attributes with a #\Space between them"
 171   (do-attributes (attribute occurence (or (getp :attributes)
 172                                           (list-slots object)))
 173         (display-using-description attribute component object (attribute-properties))
 174         (<:as-html " ")))
 175
 176 ;;;; ** as-table
 177
 178 (defdisplay (:in-layer as-table)
 179   (<:table
 180    (do-attributes (a occurence (attributes))
 181      (<:tr
 182       (<:td  (<:as-html (a-getp :label)))
 183       (<:td (display-using-description a component object (a-properties)))))))
 184
 185 ;;;; List Displays
 186 (defdisplay (:class
 187              (list list)
 188              :description (desc t))
 189   (<:ul
 190    (dolist* (item list)
 191      (<:li  (apply #'display component item properties)))))
 192
 193
 194
 195 ;;;; Attributes
 196 (defdisplay (:in-layer
 197              editor
 198              :description (attribute standard-attribute))
 199     "Legacy editor using UCW presentations"
 200   (let ((p (lol:make-view object :type :editor)))
 201     (present-slot-view p (getf (find-plist attribute) :slot-name))))
 202
 203 (define-layered-method display-using-description
 204     ((attribute standard-attribute) component object properties)
 205   (let ((p (lol:make-view object :type 'mewa-viewer))
 206         (name (attribute.name attribute)))
 207     (when name (present-slot-view p name))))
 208
 209 (defdisplay (:class
 210              (button (eql 'standard-form-buttons))
 211              :description (description t))
 212     (<ucw:submit :action (ok component)
 213                  :value "Ok."))
 214
 215 (defdisplay (:in-layer wrap-form
 216                        :combination :around)
 217   (<ucw:form
 218    :action (refresh-component component)
 219    (call-next-method)
 220    (display component 'standard-form-buttons)))
 221
 222
 223 (defclass/meta test-class ()
 224   ((test-string :initform "test string" :type string))
 225   (:documentation "foo"))
 226
 227 (define-attributes (test-class)
 228   (test-string t :label "String :" :editablep t))
 229
 230 (defcomponent test-component ()
 231   ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
 232    (current-type :accessor current-type :initform 'viewer)
 233    (instance :accessor instance :initform (make-instance 'test-class))))
 234
 235 (defmethod render ((self test-component))
 236   (let ((test (instance self)))
 237     (<:h1 (<:as-html "Lisp on Lines Test Component"))
 238     (with-component (self)
 239       (<ucw:form
 240        :action (refresh-component self)
 241        (<ucw:select :accessor (current-type self)
 242                     (dolist* (type (display-types self))
 243                       (<ucw:option :value type (<:as-html type))))
 244        (<:input :type "Submit" :value "update")
 245        (<:fieldset
 246         (<:legend (<:as-html (current-type self)))
 247         (display test :type (current-type self)))))
 248
 249     (<:div
 250      (<:h2
 251       (<:as-html "UCW Presentation based displays (the old school"))
 252      (dolist (type '(:viewer :editor :creator :one-line :as-string))
 253        (<:h3 (<:as-html type))
 254        (present-view (test type self))
 255        (<ucw:a :action (call-view (test type self))
 256                (<:as-html "Call to " type))))))
 257
 258
 259 (defcomponent standard-display-component ()
 260   ((display-function :accessor display-function :initarg :display)))
 261
 262 (defmethod render ((self standard-display-component))
 263   (funcall (display-function self) self))
 264
 265
 266
 267
 268
 269