From 1cc831d4c7b9ecba47578b8a85ea046ef4e3915a Mon Sep 17 00:00:00 2001
From: drewc <drewc@tech.coop>
Date: Sat, 5 May 2007 12:39:34 -0700
Subject: [PATCH 1/1] Massive patch to compile with modern versions of the
 libraries. This is only 1/2 way done.

darcs-hash:20070505193934-39164-25ee49282ce3be26a5b4420040ad45b880ded75e.gz
---
 lisp-on-lines.asd                       |   6 +-
 src/attributes/dojo-attributes.lisp     |   2 +-
 src/attributes/standard-attributes.lisp |  46 +++++++---
 src/components/crud.lisp                |   2 +-
 src/defdisplay.lisp                     |  46 +++-------
 src/lisp-on-lines.lisp                  |   2 +-
 src/mewa.lisp                           | 108 ++++++++++++++++--------
 src/packages.lisp                       |   4 +
 src/standard-display.lisp               |  48 +++++++----
 src/standard-wrappers.lisp              |   6 +-
 10 files changed, 165 insertions(+), 105 deletions(-)

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 33a79ed..12306c7 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -12,7 +12,8 @@
   :components ((:static-file "lisp-on-lines.asd")
 	       (:module :patches			  
 			:components ((:file "yaclml")
-				     (:file "ucw")))
+				     (:file "ucw")
+				     (:file "clsql")))
 	       (:module :src
 			:components ((:file "packages")
 				     (:file "special-initargs")
@@ -38,8 +39,7 @@
 					       (:file "standard-validation")
 					       (:file "email-address"))
 					      :serial t)
-				     (:module :components
-					      :components ((:file "crud"))))
+				     )
 			:serial t))
   :serial t
   :depends-on (:arnesi :ucw :meta-model :split-sequence :contextl :cl-ppcre :cl-fad))
diff --git a/src/attributes/dojo-attributes.lisp b/src/attributes/dojo-attributes.lisp
index 8cb5447..39f3acc 100644
--- a/src/attributes/dojo-attributes.lisp
+++ b/src/attributes/dojo-attributes.lisp
@@ -2,7 +2,7 @@
 
 (deflayer dojo)
 
-(define-layered-class
+#+nil(define-layered-class
     description :in-layer dojo ()
   ((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
 
diff --git a/src/attributes/standard-attributes.lisp b/src/attributes/standard-attributes.lisp
index 8b739ab..bdf3c80 100644
--- a/src/attributes/standard-attributes.lisp
+++ b/src/attributes/standard-attributes.lisp
@@ -1,5 +1,11 @@
 (in-package :lisp-on-lines)
 
+
+;TODO: get rid of this.
+(defun attribute.name (attribute)
+  (attribute-name attribute))
+
+
 ;;;; A few layers related to attributes
 (deflayer omit-nil-attributes)
 
@@ -8,17 +14,30 @@
  (when (attribute-value object attribute)
    (call-next-method)))
 
+;;;; Labels
 (deflayer show-attribute-labels)
 
+(defattribute attribute-label (attribute)
+  ()
+  (:default-properties
+      :attribute nil))
+
+(defdisplay
+  ((label attribute-label) object)    
+ (<:label
+  :class "lol-label"
+  (<:as-html (or (label (attribute label))
+		 (attribute-name (attribute label)) " ")
+	     "   ")))  
+
+(defvar *attribute-label-attribute*
+  (make-instance 'attribute-label))
+
 (defdisplay
     :in-layer show-attribute-labels
     :around ((attribute standard-attribute) object)    
-  (<:label
-   :class "lol-label"
-   (<:as-html (or (label attribute) (attribute.name attribute)) " "))
-  (<:span
-   :class "lol-attribute"
-   (call-next-method)))
+ (display-attribute *attribute-label-attribute* object :attribute attribute)
+ (call-next-method))
 
 (deflayer use-pretty-labels)
 
@@ -35,11 +54,11 @@
 (defdisplay :in-layer inspect-attributes
 	    :around ((attribute standard-attribute) object)
  (call-next-method)
-  (<ucw:a :action (ucw::call-inspector self attribute)
+ (<ucw:a :action-body (ucw::call-inspector self attribute)
 	  :title
 	  (strcat "Inspect "
-			 (attribute.name attribute) ":"
-			 (description.type attribute) ":"
+			 (attribute-name attribute) ":"
+			 (description-type attribute) ":"
 			 (type-of attribute))
 	  (<:as-html "(i)")))
 
@@ -144,7 +163,7 @@
     :in-layer editor :around ((string base-attribute) object)
     (dletf (((callback string)
 	     (or (callback string)
-		 (ucw::make-new-callback
+		 (ucw::register-callback
 		  #'(lambda (val)
 		      (setf (attribute-value object string) val)))))
 	    ((object string) object))
@@ -161,6 +180,9 @@
     :max-length nil
     :default-value ""))
 
+
+#| 
+
 (defdisplay :in-layer omit-nil-attributes
 	    :around ((attribute string-attribute) object)
  (when (< 0 (length  (attribute-value object attribute)))
@@ -175,7 +197,7 @@
 
 
 ;;;; editor
-(defattribute string-attribute (base-attribute)
+#+nil (defattribute string-attribute (base-attribute)
   ()
   (:in-layer editor)
   (:default-properties
@@ -262,7 +284,7 @@
 
     (<:div
      :class "lol-image-thumbnails"
-     (<:as-html "imagie")))
+     (<:as-html "imagie"))) |#
 
 
 
diff --git a/src/components/crud.lisp b/src/components/crud.lisp
index 66ac06e..6d4ab6c 100644
--- a/src/components/crud.lisp
+++ b/src/components/crud.lisp
@@ -138,7 +138,7 @@ note the omitted COMPONENT argument. sugar is all."
   "Around every attribute of a CRUD instance, i'd like to wrap a div."
   (<:div
    :class (format nil "crud-~A" (string-downcase
-				 (string (attribute.name attribute))))
+				 (string (attribute-name attribute))))
    (call-next-method)))
 
 ;;;; A description contains attributes.
diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index 36df62f..e86bbf6 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -22,10 +22,10 @@ The function (which is usually display-using-description) will be called with th
     (let* ((description (find-occurence object)))
 
       (if description
-	  (dletf (((description.type description) type)
+	  (dletf (((description-type description) type)
 		  ((attributes description) (or
 					     (attributes description)
-					     (list-slots object))))
+					     (list-attributes description))))
 	    ;; apply the default line to the description
 	    (funcall-with-description
 	     description
@@ -43,9 +43,7 @@ The function (which is usually display-using-description) will be called with th
    "Displays OBJECT in COMPONENT."))
 
 (define-layered-method display ((component t) (object t)
-				&rest properties
-				&key type (line #'line-in)
-				&allow-other-keys)
+				&rest properties)
   " The default display dispatch method
 
   DISPLAY takes two required arguments, 
@@ -56,25 +54,8 @@ The function (which is usually display-using-description) will be called with th
   that is to say the parameters that come together to create the output.
 
 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
-
-  (let* ((description (find-occurence object)))
-
-    (if description
-	(dletf (((description.type description) type)
-		((attributes description) (or
-					   (attributes description)
-					   (list-slots object))))
-	  ;; apply the default line to the description
-	  (funcall-with-description
-	   description
-	   (funcall line object)
-	   ;; apply the passed in arguments and call display-using-description
-	   #'(lambda ()		 
-	       (funcall-with-description
-		description
-		properties
-		#'display-using-description description object component))))
-	(error "no description for ~A" object))))
+  (funcall (apply 'make-display-function component object properties)
+	   'display-using-description))
 
 ;;;;; Macros
 
@@ -82,16 +63,16 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
 (defun funcall-with-description (description properties function &rest args)
   
   (if description
-      (dletf* (((description.type description) (or
+      (dletf* (((description-type description) (or
 						(getf properties :type)
-						(description.type description)))
+						(description-type description)))
 	    
-	       ((description.layers description) (append 
-							 (description.layers description)
+	       ((description-layers description) (append 
+							 (description-layers description)
 							 (getf properties :layers)))
-	       ((description.properties description) (append (description.properties description) properties)))
+	       ((description-properties description) (append (description-properties description) properties)))
 	(funcall-with-layers 
-	 (description.layers description)
+	 (description-layers description)
 	 #'(lambda ()
 	     (contextl::funcall-with-special-initargs
 	      (list (cons description properties))
@@ -137,7 +118,8 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
     (declare (ignorable self))
     (flet ((display* (thing &rest args)
 	     (apply #'display ,component thing args))
-	   (display-attribute (attribute obj &optional props)
+	   (display-attribute (attribute obj &rest
+					 props)
 	     (if props
 		 (funcall-with-description
 		  attribute props
@@ -185,7 +167,7 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
 		      component)
 		     (t
 		      (setf c component)
-		      `(,c component))))
+		      `(,c t))))
 		  (with-component (,c)  
 			 ,@(cdr tail)))))))))
 
diff --git a/src/lisp-on-lines.lisp b/src/lisp-on-lines.lisp
index 7bc4040..911b02d 100644
--- a/src/lisp-on-lines.lisp
+++ b/src/lisp-on-lines.lisp
@@ -56,7 +56,7 @@ Generates a form that, when evaluated, initialises the given table as an lol obj
 This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation"
 
     `(progn 
-       (def-view-class-from-table ,table)
+       (rofl::gen-view-class ,table :generate-joins :all)
        (set-default-attributes (quote ,(meta-model::sql->sym table))))))
     
 (defmacro define-view-for-table (&rest tables)
diff --git a/src/mewa.lisp b/src/mewa.lisp
index 8ec2a8a..24aa788 100644
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -1,21 +1,19 @@
 (in-package :lisp-on-lines)
 
+(defun persistentp (object)
+  (slot-value object 'clsql-sys::view-database))
+
 (define-layered-class description ()
   ((description-type
     :initarg :type
-    :accessor description.type
+    :accessor description-type
     :initform 'viewer
     :special t)
    (description-layers
     :initarg :layers
-    :accessor description.layers
+    :accessor description-layers
     :initform nil
     :special t)
-   (description-properties
-    :accessor description.properties
-    :initform nil
-    :special t
-    :documentation "TODO: not used much anymore, and shouldn't be relied on")
    (described-object
     :layered-accessor object
     :initform nil
@@ -30,6 +28,11 @@
     :initarg :attributes
     :initform nil
     :special t)
+   (description-properties
+    :accessor description-properties
+    :initarg :properties
+    :initform '()
+    :special t)
    (description-default-properties
     :accessor default-properties
     :initarg :default-properties
@@ -39,8 +42,7 @@
 (defmethod attributes :around ((description description))
   "Add any default properties to the attributes"
   
-  (let ((default-properties (default-properties description)))
-    (if (and (listp default-properties)
+  (let ((default-properties (default-properties description)))    (if (and (listp default-properties)
 	     (not (null default-properties)))
 	(let ((a (mapcar #'(lambda (att)
 		    (append (ensure-list att) default-properties))
@@ -72,29 +74,62 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
 
 (defun find-or-create-occurence (name)
   "Returns the occurence associated with this name."
-  (let ((occurence (gethash name *occurence-map*)))
-    (if occurence
-	occurence
-	(let ((new-occurence (make-instance 'standard-occurence :name name)))
-	  (setf (gethash name *occurence-map*) new-occurence)
-	  new-occurence))))
+  (or (get-occurence name)
+      (values (setf (get-occurence name) (make-instance 'standard-occurence :name name))
+	      t)))
+
+(defun get-occurence (name)
+  (gethash name *occurence-map*))
+
+(defun (setf get-occurence) (occurence name)
+    (setf (gethash name *occurence-map*) occurence))
 
 (defun clear-occurence (occurence)
   "removes all attributes from the occurence"
   (setf (attribute-map occurence) (make-hash-table)))
 
+(defmethod make-attribute-using-slot-definition (slotd)
+  (make-attribute
+   :name (closer-mop:slot-definition-name slotd)
+   :type-spec (closer-mop:slot-definition-type slotd)
+   :type (first (remove-if (lambda (item)
+			     (or
+			      (eql item 'or)
+			      (eql item 'null)
+			      (eql item nil)))
+			   (ensure-list (closer-mop:slot-definition-type slotd))))))
+
+(defmethod initialize-occurence-for-instance (occurence instance)
+  (let ((slots (closer-mop:class-slots (class-of instance))))
+    (dolist (s slots)
+      (let ((att (make-attribute-using-slot-definition s)))
+	(setf (find-attribute occurence (attribute-name att)) att)))
+    occurence))
+
 (defgeneric find-occurence (name)
   (:method (thing)
     nil)
   (:method ((name symbol))
     (find-or-create-occurence name))
   (:method ((instance standard-object))
-    (find-or-create-occurence (class-name (class-of instance)))))
+    (multiple-value-bind (occ new?)
+	(find-or-create-occurence (class-name-of instance))
+      (if new?
+	  (initialize-occurence-for-instance occ instance)
+	  occ))))
+
+(defun list-attributes (occurence)
+  (let (res)
+    (maphash (lambda (k v)
+	       (declare (ignore v))
+	       (push k res))
+	     (attribute-map occurence))
+    res))
 
 
 (define-layered-class
     attribute (description)
-    ((attribute-name :layered-accessor attribute.name
+    ((attribute-name :layered-accessor attribute-name
 	   :initarg :name
 	   :initform (gensym "ATTRIBUTE-")
 	   :special t)
@@ -113,11 +148,12 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
     ((setter :accessor setter :initarg :setter :special t :initform nil)
      (getter :accessor getter :initarg :getter :special t :initform nil)
      (value :accessor value :initarg :value :special t)
-     (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil))
+     (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil)
+     (typespec :accessor type-spec :initarg :type-spec :initform nil))
     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
 
 (define-layered-method label :around ((attribute standard-attribute))
- (or (call-next-method) (attribute.name attribute)))
+ (or (call-next-method) (attribute-name attribute)))
 
 (defmacro defattribute (name supers slots &rest args)
   (let* (
@@ -229,10 +265,10 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
   (find-attribute (occurence attribute-with-occurence) attribute-name))
 
 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
-  (setf (description.properties attribute) (plist-nunion
+  (setf (description-properties attribute) (plist-nunion
 					    properties
-					    (description.properties attribute)))
-  (loop for (initarg value) on (description.properties attribute) 
+					    (description-properties attribute)))
+  (loop for (initarg value) on (description-properties attribute) 
 	      by #'cddr
 	      with map = (initargs.slot-names attribute)
 	      do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))
@@ -250,14 +286,14 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
 otherwise, (setf find-attribute)"
   (let ((att (find-attribute occurence-name attribute-name)))
     (if (and att inherit (or (eql (car attribute-spec)
-			      (description.type att))
+			      (description-type att))
 			     (eq (car attribute-spec) t)))
 	(set-attribute-properties occurence-name att (cdr attribute-spec))
 	(setf (find-attribute occurence-name attribute-name)
 	      (cons  (car attribute-spec)
 		     (plist-nunion
 		      (cdr attribute-spec) 
-		      (when att (description.properties att))))))))
+		      (when att (description-properties att))))))))
 
 (defmethod perform-define-attributes ((occurence-name t) attributes)
   (loop for attribute in attributes
@@ -280,8 +316,8 @@ otherwise, (setf find-attribute)"
 ;;"Unused???"
 (defmethod setter (attribute)
   (warn "Setting ~A in ~A" attribute *context*)
-  (let ((setter (getf (description.properties attribute) :setter))
-	(slot-name (getf (description.properties attribute) :slot-name)))
+  (let ((setter (getf (description-properties attribute) :setter))
+	(slot-name (getf (description-properties attribute) :slot-name)))
     (cond (setter
 	   setter)
 	  (slot-name
@@ -310,13 +346,13 @@ we return slot-value-or nil either boundp or not."
 		   slot-value-or-nil (slot-value
 				      instance
 				      (slot-name attribute))))))
-	((and (slot-exists-p instance (attribute.name attribute)))
+	((and (slot-exists-p instance (attribute-name attribute)))
 	 (setf existsp t)
-	 (when (slot-boundp instance (attribute.name attribute))
+	 (when (slot-boundp instance (attribute-name attribute))
 	   (setf boundp t
 		 slot-value-or-nil (slot-value
 				    instance
-				    (attribute.name attribute))))))
+				    (attribute-name attribute))))))
     (VALUES slot-value-or-nil existsp boundp)))
   
 (define-layered-method attribute-value (instance (attribute standard-attribute))
@@ -339,8 +375,8 @@ we return slot-value-or nil either boundp or not."
 	   (funcall setter value instance))
 	  ((and (slot-boundp attribute 'slot-name) slot-name)
 	   (setf (slot-value instance slot-name) value))
-	  ((and (slot-exists-p instance (attribute.name attribute)))
-	   (setf (slot-value instance (attribute.name attribute)) value))
+	  ((and (slot-exists-p instance (attribute-name attribute)))
+	   (setf (slot-value instance (attribute-name attribute)) value))
 	  (t
 	   (error "Cannot set ~A in ~A" attribute instance)))))
 
@@ -368,9 +404,9 @@ we return slot-value-or nil either boundp or not."
   (foreign-key has-a))
 
 (defun attribute-to-definition (attribute)
-  (nconc (list (attribute.name attribute)
-	       (description.type attribute))
-	 (description.properties attribute)))
+  (nconc (list (attribute-name attribute)
+	       (description-type attribute))
+	 (description-properties attribute)))
 
 (defun find-default-presentation-attribute-definitions ()
   nil)
@@ -381,9 +417,9 @@ we return slot-value-or nil either boundp or not."
 	 (real-default (find-attribute 'default type)))
     (cond
       (possible-default
-	(description.type possible-default))
+	(description-type possible-default))
        (real-default
-	(description.type real-default))
+	(description-type real-default))
        (t type))))
 
 (defun gen-presentation-slots (instance)
diff --git a/src/packages.lisp b/src/packages.lisp
index bd02074..42ceab3 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -7,6 +7,10 @@
 	:clsql
 	:contextl)
   (:nicknames :lol :mewa)
+
+  (:shadowing-import-from
+   :ucw
+   :parent)
   
   (:shadowing-import-from
    :iterate
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index 35d57e1..041541d 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -4,6 +4,22 @@
 (deflayer viewer)
 (deflayer editor)
 
+;;;; 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)
 
@@ -20,12 +36,24 @@ This allows us to dispatch to a subclasses editor.
 (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-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+  (with-output-to-string (yaclml::*yaclml-stream*)
     (do-attributes (a d)
       (display-attribute a o)
-      (<:as-is " "))))
+      (<:as-html " "))
+    #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+)))
 
 (defmethod list-slots (thing)
   (list 'identity))
@@ -49,7 +77,6 @@ This allows us to dispatch to a subclasses editor.
   "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
@@ -105,7 +132,7 @@ This allows us to dispatch to a subclasses editor.
 
 ;;;; List Displays
 
-(deflayer list-display-layer)
+#| (deflayer list-display-layer)
 
 (define-layered-class description
   :in-layer list-display-layer ()
@@ -136,20 +163,9 @@ This allows us to dispatch to a subclasses editor.
 	   (dolist* (obj list)
 	     (<:tr 
 	      (do-attributes (a desc)
-		(<:td (display-attribute a obj)))))))))))
+		(<: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)))
 
 
 
diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp
index 110bdd3..bdc975c 100644
--- a/src/standard-wrappers.lisp
+++ b/src/standard-wrappers.lisp
@@ -25,7 +25,7 @@
 
 (defvar *link-wrapped-p* nil)
 
-(define-layered-class description
+#+nil(define-layered-class description
   :in-layer wrap-link ()
   ((link :initarg :link-action
 	 :initarg :action
@@ -59,7 +59,7 @@
 
 (defvar *in-form-p* nil)
 
-(define-layered-class description
+#+nil(define-layered-class description
   :in-layer wrap-form ()
   ((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)
    (form-type :initarg :form-type :initform '<ucw:simple-form :special t :accessor form-type)))
@@ -112,7 +112,7 @@
 
 (deflayer wrap-div)
 
-(define-layered-class description
+#+nil(define-layered-class description
   :in-layer wrap-div ()
   ((div-attributes :accessor div-attributes :initarg :div :special t :initform nil)))
 
-- 
2.20.1