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