-(in-package :lisp-on-lines)
-
-
-;;;; The Standard Layer Hierarchy
-(deflayer viewer)
-(deflayer editor (viewer))
-(deflayer creator (editor))
-
-;;;; 'Mixin' Layers
-(deflayer one-line)
-
-(deflayer wrap-form)
-
-(deflayer as-table)
-
-(define-attributes (contextl-default)
- (:viewer viewer)
- (:editor editor)
- (:creator creator))
-
-
-(defmacro with-component ((component) &body body)
- `(let ((self ,component))
- (flet ((display* (thing &rest args)
- (apply #'display ,component thing args)))
- ,@body)))
-
-(defmacro call-display (object &rest args)
- `(call-component self (make-instance 'standard-display-component
- :display #'(lambda (component)
- (with-component (component)
- (<:as-html ,object)
- (display ,object ,@args))))))
-
-(defmethod find-plist (object)
- (list))
-`
-(defmethod find-plist ((attribute standard-attribute))
- (attribute.plist attribute))
-
-(defmacro with-plist ((plist-form &optional prefix) &body body)
- (with-unique-names (p)
- (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
- (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
- (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
- `(let ((,p ,plist-form))
- (flet ((,get (p)
- (getf ,p p))
- (,set (p v)
- (setf (getf ,p p) v))
- (,props ()
- ,p))
- (declare (ignorable #',get #',set #',props))
- ,@body)))))
-
-
-;;;;; Macros
-(defmacro do-attributes ((var occurence attributes) &body body)
- (with-unique-names (att plist type)
- `(loop for ,att in ,attributes
- do (let* ((,att (ensure-list ,att))
- (,plist (rest ,att))
- (,type (getf ,plist :type))
- (,var (if ,type
- (make-attribute :name (first ,att) :type ,type :plist ,plist)
- (find-attribute ,occurence (first ,att)))))
- (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)
- ,@body)))))
-
-
-(defmacro defdisplay ((&key
- (in-layer nil layer-supplied-p)
- (combination nil combination-supplied-p)
- (description '(occurence standard-occurence) description-supplied-p)
- (component 'component)
- ((:class object) nil))
- &body body)
- (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))
- `(define-layered-method display-using-description
- ,@(when layer-supplied-p `(:in-layer ,in-layer))
- ,@(when combination-supplied-p `(,combination))
- (,description ,component
- ,class-spec properties)
-
-
- (with-plist ((plist-union properties (find-plist ,(car description))))
-
- ,(if (not description-supplied-p)
- `(flet ((attributes ()
- (or (getp :attributes)
- (list-slots ,(car (ensure-list class-spec))))))
- (declare (ignorable #'attributes))
-
- ,@body)
- `(progn ,@body)))) )
- )
-
-
-(define-layered-function display (component object &rest args)
- (:documentation
- "Displays OBJECT in COMPONENT.
-
- default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
-
-(define-layered-method display
- ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys)
- (let* ((occurence (find-occurence object))
- (plist (attribute.plist
- (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
- (layers (append (when type (loop for ty in (ensure-list type)
- nconc `(+ ,ty)))
- layers
- (getf plist :layers))))
- (funcall-with-layers
- layers
- #'display-using-description occurence component object (plist-union args plist))))
-
-
-(define-layered-method display
- ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
- (funcall-with-layers
- layers
- #'display-using-description t component object args))
-
-
-(define-layered-function display-using-description (description component object properties)
- (:documentation
- "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
-
-(define-layered-method display-using-description (description component object properties)
- "The standard display simply prints the object"
- (declare (ignore component properties description))
- (<:as-html object))
-
-;;;; * Object Presentations
-(define-layered-method display-using-description
- ((occurence standard-occurence) component object properties)
-
- (with-plist (properties o)
- (loop for att in (or (o-getp :attributes) (list-slots object))
- do (let* ((att (ensure-list att))
- (attribute (find-attribute occurence (first att))))
- (warn "trying to render ~A in ~A" attribute object)
- (with-plist ((plist-union (rest att) (find-plist attribute)))
- (<:p :class "attribute"
- (<:span :class "label" (<:as-html (getp :label) " "))
- (display-using-description
- attribute
- component
- object
- (rest att))))))))
-
-;;;; ** One line
-(defdisplay (:in-layer one-line)
- (do-attributes (attribute occurence (or (getp :attributes)
- (list-slots object)))
- (display-using-description attribute component object (attribute-properties))
- (<:as-html " ")))
-
-;;;; ** as-table
-
-(defdisplay (:in-layer as-table)
- (<:table
- (do-attributes (a occurence (attributes))
- (<:tr
- (<:td (<:as-html (a-getp :label)))
- (<:td (display-using-description a component object (a-properties)))))))
-
-;;;; List Displays
-(defdisplay (:class
- (list list)
- :description (desc t))
- (<:ul
- (dolist* (item list)
- (<:li (apply #'display component item properties)))))
-
-
-
-;;;; Attributes
-(defdisplay (:in-layer
- editor
- :description (attribute standard-attribute))
- "Legacy editor using UCW presentations"
- (let ((p (lol:make-view object :type :editor)))
- (present-slot-view p (getf (find-plist attribute) :slot-name))))
-
-(define-layered-method display-using-description
- ((attribute standard-attribute) component object properties)
- (let ((p (lol:make-view object :type 'mewa-viewer))
- (name (attribute.name attribute)))
- (when name (present-slot-view p name))))
-
-(defdisplay (:class
- (button (eql 'standard-form-buttons))
- :description (description t))
- (<ucw:submit :action (ok component)
- :value "Ok."))
-
-
-(defdisplay (:in-layer wrap-form
- :combination :around)
- (<ucw:form
- :action (refresh-component component)
- (call-next-method)
- (display component 'standard-form-buttons)))
-
-
-(defclass/meta test-class ()
- ((test-string :initform "test string" :type string))
- (:documentation "foo"))
-
-(define-attributes (test-class)
- (test-string t :label "String :" :editablep t))
-
-(defcomponent test-component ()
- ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
- (current-type :accessor current-type :initform 'viewer)
- (instance :accessor instance :initform (make-instance 'test-class))))
-
-(defmethod render ((self test-component))
- (let ((test (instance self)))
- (<:h1 (<:as-html "Lisp on Lines Test Component"))
- (with-component (self)
- (<ucw:form
- :action (refresh-component self)
- (<ucw:select :accessor (current-type self)
- (dolist* (type (display-types self))
- (<ucw:option :value type (<:as-html type))))
- (<:input :type "Submit" :value "update")
- (<:fieldset
- (<:legend (<:as-html (current-type self)))
- (display test :type (current-type self)))))
-
- (<:div
- (<:h2
- (<:as-html "UCW Presentation based displays (the old school"))
- (dolist (type '(:viewer :editor :creator :one-line :as-string))
- (<:h3 (<:as-html type))
- (present-view (test type self))
- (<ucw:a :action (call-view (test type self))
- (<:as-html "Call to " type))))))
-
-
-(defcomponent standard-display-component ()
- ((display-function :accessor display-function :initarg :display)))
-
-(defmethod render ((self standard-display-component))
- (funcall (display-function self) self))
-
-
-
-
-
-
+(in-package :lisp-on-lines)
+
+;;;; The Standard Layers
+(deflayer viewer)
+(deflayer editor)
+
+(define-layered-method label (anything)
+ nil)
+
+(defdisplay
+ :in-layer editor :around (description object)
+ "It is useful to remove the viewer layer when in the editing layer.
+This allows us to dispatch to a subclasses editor.
+"
+ (with-inactive-layers (viewer)
+ (call-next-method)))
+
+;;;; These layers affect the layout of the object
+(deflayer one-line)
+(deflayer as-table)
+(deflayer as-string)
+
+(defdisplay
+ :in-layer as-string (d o)
+ (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+ (do-attributes (a d)
+ (display-attribute a o)
+ (<:as-is " "))))
+
+(defmethod list-slots (thing)
+ (list 'identity))
+
+;;;; * Object displays.
+
+
+
+;;;; TODO: all lisp types should have occurences and attributes defined for them.
+
+(defdisplay ((description t) lisp-value)
+ (<:as-html lisp-value))
+
+(defdisplay (description (object string))
+ (<:as-html object))
+
+(defdisplay (description (object symbol))
+ (<:as-html object))
+
+(defdisplay (description object (component t))
+ "The default display for CLOS objects"
+ (print (class-name (class-of object)))
+ (dolist* (slot-name (list-slots object))
+
+ (let ((boundp (slot-boundp object slot-name)))
+ (format t "~A~A : ~A" (strcat slot-name)
+ (if boundp
+ ""
+ "(unbound)")
+ (if boundp
+ (slot-value object slot-name) "")))))
+
+(defdisplay ((description t) object)
+ "The default display for CLOS objects in UCW components"
+ (dolist* (slot-name (list-slots object))
+
+ (let ((boundp (slot-boundp object slot-name)))
+ (<:label :class "lol-label"
+ (display-attribute 'label (strcat slot-name))
+ (if boundp
+ ""
+ "(unbound)"))
+ (<:as-html
+ (if boundp
+ (slot-value object slot-name) "")))))
+
+;;;; ** The default displays for objects with a MEWA occurence
+
+(defdisplay (description object)
+ (<:div
+ :class "lol-display"
+ (when (label description)
+ (<:span
+ :class "title"
+ (<:as-html (label description))))
+ (do-attributes (attribute description)
+ (<:div
+ :class "attribute"
+ (display-attribute attribute object)))))
+
+;;;; ** One line
+(defdisplay
+ :in-layer one-line (description object)
+ "The one line presentation just displays the attributes with a #\Space between them"
+ (do-attributes (attribute description)
+ (display-attribute attribute object)
+ (<:as-html " ")))
+
+;;;; ** as-table
+
+(defdisplay :in-layer as-table (description object)
+ (<:table
+ (do-attributes (a description)
+ (<:tr
+ (<:td :class "lol-label" (<:as-html (label a)))
+ (<:td (display-attribute a object))))))
+
+;;;; List Displays
+
+(deflayer list-display-layer)
+
+(define-layered-class description
+ :in-layer list-display-layer ()
+ ((list-item :initarg :list-item
+ :initarg :table-item
+ :initform nil
+ :special t
+ :accessor list-item)))
+
+(defdisplay (desc (list list))
+ (with-active-layers (list-display-layer)
+ (<:ul
+ (dolist* (item list)
+ (<:li (apply #'display* item (list-item desc)))))))
+
+(defdisplay :in-layer as-table (description (list list))
+ (with-active-layers (list-display-layer)
+ (let ((item-description (find-occurence (first list))))
+ (<:table
+ (funcall
+ (apply #'lol::make-display-function self (first list)
+ (list-item description))
+ (lambda (desc item component)
+ (<:tr
+ (do-attributes (a desc)
+ (<:th (<:as-html (label a)))))
+
+ (dolist* (obj list)
+ (<:tr
+ (do-attributes (a desc)
+ (<:td (display-attribute a obj)))))))))))
+
+;;;; Attributes
+(defdisplay
+ :in-layer editor
+ ((attribute standard-attribute) object)
+ (call-next-method))
+
+(define-layered-method display-using-description
+ ((attribute standard-attribute) object component)
+ (with-component (component)
+ (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
+ (<:as-html "*" )))
+ (<:as-html (attribute-value object attribute)))
+
+
+
+
+
+
+
+
+
+
+
HCoop / clinton / lisp-on-lines.git / blobdiff