X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/2b0fd9c886908c6492c66cc30fcacf5fd600bf8e..1d51a2eea8537084e9e681c297422047ae858989:/src/standard-display.lisp diff --git a/src/standard-display.lisp b/src/standard-display.lisp index 1845491..b8282c5 100644 --- a/src/standard-display.lisp +++ b/src/standard-display.lisp @@ -1,54 +1,68 @@ (in-package :lisp-on-lines) +(deflayer lisp-on-lines ()) + ;;;; The Standard Layers -(deflayer viewer) -(deflayer editor) -(deflayer creator) -(deflayer one-line) -(deflayer as-table) -(deflayer as-string) +(deflayer viewer (lisp-on-lines)) +(deflayer editor (lisp-on-lines)) +;;;; Attributes (defdisplay - :in-layer as-string (d o) - (do-attributes (a d) - (display-attribute a o) - (<:as-is " "))) + :in-layer editor + ((attribute standard-attribute) object) + (call-next-method)) -(defmethod list-slots (thing) - (list 'identity)) +(defdisplay + ((attribute standard-attribute) object component) + (<:as-html (attribute-value object attribute))) +(define-layered-method display-using-description + ((attribute standard-attribute) object component) + (with-component (component) + ) + (<:as-html (attribute-value object attribute))) -;;;; TODO : this doesn't work +(define-layered-method label (anything) + nil) -(defaction call-display-with-context ((from component) object context &rest properties) - (call-component self (make-instance 'standard-display-component - :context context - :object object - :args (if (cdr properties) - properties - (car properties))))) +(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) -(defmacro call-display (component object &rest properties) - `(let () - (call-display-with-context ,component ,object nil ,@properties))) +(defdisplay + :in-layer as-string (d o (self t)) + (with-output-to-string (yaclml::*yaclml-stream*) + (do-attributes (a d) + (display-attribute a o) + (<:as-html " ")) + #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) +))) -(defcomponent standard-display-component () - ((context :accessor context :initarg :context) - (object :accessor object :initarg :object) - (args :accessor args :initarg :args))) -(defmethod render ((self standard-display-component)) - - (apply #'display self (object self) (args self))) +(defdisplay + :in-layer as-string (d o) + (with-output-to-string (yaclml::*yaclml-stream*) + (do-attributes (a d) + (display-attribute a o) + (<:as-html " ")) + #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) +))) +(defmethod list-slots (thing) + (list 'identity)) ;;;; * Object displays. -;;;; We like to have a label for attributes, and meta-model provides a default. -(defdisplay ((desc (eql 'label)) label) - (<:span - :class "label" - (<:as-html label))) + ;;;; TODO: all lisp types should have occurences and attributes defined for them. @@ -58,11 +72,13 @@ (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 @@ -89,19 +105,23 @@ (defdisplay (description object) (<:div - :class "lol-display" + :class "lol-display" + (when (label description) + (<:span + :class "title" + (<:as-html (label description)))) (do-attributes (attribute description) (<:div - :class "lol-attribute-row" + :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 " "))) + :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 @@ -113,26 +133,41 @@ (<: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)) - (<:ul - (dolist* (item list) - (<:li (display* item) - (<:as-html item))))) + (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) - "Legacy editor using UCW presentations" - - (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute))) -(define-layered-method display-using-description - ((attribute standard-attribute) object component) - (with-component (component) - (