X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/d2882889dc2234eef5882eeaa79e83e4e0d638a3..1d51a2eea8537084e9e681c297422047ae858989:/src/standard-display.lisp?ds=inline

diff --git a/src/standard-display.lisp b/src/standard-display.lisp
dissimilarity index 96%
index 2a72992..b8282c5 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -1,254 +1,181 @@
-(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 t) &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)
+
+(deflayer lisp-on-lines ())
+
+;;;; The Standard Layers
+(deflayer viewer (lisp-on-lines))
+(deflayer editor (lisp-on-lines))
+
+;;;; Attributes 
+(defdisplay
+    :in-layer editor
+    ((attribute standard-attribute) object)
+    (call-next-method))
+
+(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)))
+
+(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 (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)
+)))
+
+
+(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.
+
+
+
+;;;; 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))))))))))) |#
+
+
+
+
+
+
+
+
+
+       
+				     
+
+