From 91b9f259d38073a9847ede172cdda1218f2c35fb Mon Sep 17 00:00:00 2001
From: drewc <drewc@tech.coop>
Date: Mon, 29 May 2006 18:12:59 -0700
Subject: [PATCH] Removed most of the old LoL stuff for good.

darcs-hash:20060530011259-39164-cb6dd4434ba378f27e9352eacd48625811f642ad.gz
---
 lisp-on-lines.asd                             |  20 +-
 src/{ => attributes}/dojo-attributes.lisp     |   0
 src/attributes/numbers.lisp                   |   7 +-
 .../relational-attributes.lisp                |   9 +-
 src/{ => attributes}/standard-attributes.lisp |   0
 src/packages.lisp                             |  58 +-
 src/presentations.lisp                        | 250 -----
 src/slot-presentations.lisp                   | 480 ---------
 src/slot-presentations/date.lisp              | 246 -----
 src/standard-display.lisp                     |  30 +-
 src/static-presentations.lisp                 | 944 ------------------
 11 files changed, 24 insertions(+), 2020 deletions(-)
 rename src/{ => attributes}/dojo-attributes.lisp (100%)
 rename src/{ => attributes}/relational-attributes.lisp (91%)
 rename src/{ => attributes}/standard-attributes.lisp (100%)
 delete mode 100644 src/presentations.lisp
 delete mode 100644 src/slot-presentations.lisp
 delete mode 100644 src/slot-presentations/date.lisp
 delete mode 100644 src/static-presentations.lisp

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index b0e6b99..2e4eb26 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -11,7 +11,8 @@
 (defsystem :lisp-on-lines
   :components ((:static-file "lisp-on-lines.asd")
 	       (:module :patches			  
-			:components ((:file "yaclml")))
+			:components ((:file "yaclml")
+				     (:file "ucw")))
 	       (:module :src
 			:components ((:file "packages")
 				     (:file "special-initargs")
@@ -23,17 +24,18 @@
 				     (:file "defdisplay")
 				     (:file "standard-display")
 				     (:file "standard-occurence")
-				     (:file "standard-attributes")
-				     (:file "dojo-attributes")
 				     (:file "standard-wrappers")
-				     (:file "relational-attributes")
-
 				     (:file "lines")
-
-				     (:file "backwards-compat")
+				     (:file "defdescription")
 				     (:module :attributes
-
-					      :components ((:file "numbers"))))
+					      :components (
+							   (:file "standard-attributes")
+							   (:file "numbers")
+							   (:file "relational-attributes")
+							   (:file "dojo-attributes"))
+					      :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/dojo-attributes.lisp b/src/attributes/dojo-attributes.lisp
similarity index 100%
rename from src/dojo-attributes.lisp
rename to src/attributes/dojo-attributes.lisp
diff --git a/src/attributes/numbers.lisp b/src/attributes/numbers.lisp
index a2d4b8f..520e621 100644
--- a/src/attributes/numbers.lisp
+++ b/src/attributes/numbers.lisp
@@ -12,6 +12,9 @@
 (defattribute integer-attribute (number-attribute integer-field)
   ()
   (:in-layer editor)
+  (:default-initargs
+      :default-value ""
+    :default-value-predicate (complement #'numberp))
   (:type-name integer))
 
 
@@ -41,10 +44,6 @@
   ()
   (:type-name currency))
 
-(defdisplay
-   ((currency currency-attribute) object)
- (<:as-html "$")
- (call-next-method))
 
 (defdisplay :in-layer editor
    ((currency currency-attribute) object)
diff --git a/src/relational-attributes.lisp b/src/attributes/relational-attributes.lisp
similarity index 91%
rename from src/relational-attributes.lisp
rename to src/attributes/relational-attributes.lisp
index 7e17d58..2b7cdbf 100644
--- a/src/relational-attributes.lisp
+++ b/src/attributes/relational-attributes.lisp
@@ -14,7 +14,14 @@
 
 ;;
 (define-layered-method attribute-value (object (attribute has-a))
- (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))		       
+ (multiple-value-bind (obj key class)
+     (meta-model:explode-foreign-key object (slot-name attribute) :nilp t)		       
+  (if (persistentp object)
+      obj
+      (first  (select class
+		      :where [= [slot-value class key] (call-next-method)]
+		      :flatp t
+		      )))))		       
 
 (define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
   (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
diff --git a/src/standard-attributes.lisp b/src/attributes/standard-attributes.lisp
similarity index 100%
rename from src/standard-attributes.lisp
rename to src/attributes/standard-attributes.lisp
diff --git a/src/packages.lisp b/src/packages.lisp
index 683edfe..ace541f 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -23,19 +23,6 @@
    :time-element
    :time+
    :date-element)
-
-  (:shadow
-   :present
-   :present-slot
-   :presentation
-   :instance
-   :slot-presentation
-   :integer-slot-presentation
-   :string-slot-presentation
-   :object-presentation
-   :one-line-presentation
-   :presentation-slot-value
-   :get-foreign-instances)
   
   (:export 
    ;;;; CLSQL meta-model/default attributes definers
@@ -61,28 +48,11 @@
    :as-table
    ;;;; "Lines", the newest creation.
    :defline
-   :line-in
-   :line-out
-
 
+   ;;;; A macro shortcut for creating ucw actions
    :action
-   
-
-   ;;;;a wrapper for calling make-presentation
-   :call-view
-   :present-view
-   :slot-view
-   :present-slot-view
-   :make-view
-   ;;;; Ajax
-   :auto-complete
-   :call-auto-complete
 
    ;;;; Mewa Exports
-   :mewa ;the superclass of all mewa-presentations
-   :make-presentation
-   :call-presentation
-
    :find-occurence
 
    ;;attributes
@@ -93,32 +63,6 @@
    :set-default-attributes
    :set-attribute
    :find-attribute
-   :perform-set-attributes
-   ;;
-   :perform-set-attribute-properties
-   :define-attributes
-
-   ;; presentation objects
-   :mewa-object-presentation
-   :mewa-one-line-presentation
-   :mewa-list-presentation
-   :mewa-search-presentation
-   :mewa-presentation-search
-
-   :editablep
-   :global-properties
-   ;; SLOT presentations
-  
-   :mewa-relation-slot-presentation
-   :mewa-string-slot-presentation
-   :has-many-slot-presentation 
-   :has-a
-   :has-many
-   :has-very-many
-   :many-to-many
-   
-   ;; CRUD
-   :instance-is-stored-p
 
    ;;;; Meta Model Exports))
    :define-meta-model
diff --git a/src/presentations.lisp b/src/presentations.lisp
deleted file mode 100644
index b463210..0000000
--- a/src/presentations.lisp
+++ /dev/null
@@ -1,250 +0,0 @@
-(declaim (optimize (speed 0) (space 3) (safety 0)))
-(in-package :lisp-on-lines)
-
-
-(defmethod render ((self mewa))
-  (lol::present self))
-
-(defaction edit-instance ((self mewa))
-  (call-presentation (instance self) :type :editor))
-
-;;;one-line objects
-(defcomponent mewa-one-line-presentation (mewa lol::one-line-presentation)
-  ()
-  (:default-initargs
-   :attributes-getter #'one-line-attributes-getter
-   :global-properties '(:editablep nil)))
-
-(defmethod one-line-attributes-getter ((self mewa))
-  (or (meta-model::find-slots-of-type (instance self))
-      (meta-model::list-keys (instance self))))
-
-;;;objects
-(defcomponent mewa-object-presentation (mewa lol::object-presentation) 
-  ((instance :accessor instance :initarg :instance :initform nil)))
-
-(defcomponent mewa-viewer (mewa-object-presentation)
-  ()
-  (:default-initargs
-   :global-properties '(:editablep nil)))
-
-(defcomponent mewa-editor (mewa-object-presentation)
-  ()
-  (:default-initargs
-   :global-properties '(:editablep t)))
-
-(defcomponent mewa-creator (mewa-editor)
-  ())
-
-(defmethod present ((pres mewa-object-presentation))
-  (<:table :class (css-class pres)
-    (dolist (slot (slots pres))
-      (<:tr :class "presentation-slot-row"
-	    (present-slot-as-row pres slot))))
-  (render-options pres (instance pres)))
-        
-(defmethod present-slot-as-row ((pres mewa-object-presentation) (slot slot-presentation))
-  (<:td :class "presentation-slot-label" (<:as-html (label slot)))
-  (<:td :class "presentation-slot-value" (present-slot slot (instance pres))))
-
-
-(defcomponent two-column-presentation (mewa-object-presentation) ())
-
-(defmethod present ((pres two-column-presentation))
-  
-  (<:table :class (css-class pres)
-	   (loop for slot on (slots pres) by #'cddr
-		 do 
-		 (<:tr :class "presentation-slot-row"
-		       (<:td :class "presentation-slot-label" 
-			     (<:as-html (label (first slot))))
-		       (<:td :class "presentation-slot-value" 
-			     (present-slot (first slot) (instance pres)))
-		       (when (second slot)
-			 (<:td :class "presentation-slot-label" 
-			       (<:as-html (label (second slot))))
-			 (<:td :class "presentation-slot-value" 
-			       (present-slot (second slot) (instance pres))))))
-	   (render-options pres (instance pres))))
-
-
-;;;lists
-(defcomponent mewa-list-presentation (mewa list-presentation) 
-  ((instances :accessor instances :initarg :instances :initform nil)
-   (instance :accessor instance)
-   (select-label :accessor select-label :initform "select" :initarg :select-label)
-   (selectablep :accessor selectablep :initform t :initarg :selectablep)
-   (deleteablep :accessor deletablep :initarg :deletablep :initform nil)
-   (viewablep :accessor viewablep :initarg :viewablep :initform nil)))
-
-(defaction select-from-listing ((listing mewa-list-presentation) object index)
-  (answer object))
-
-(defmethod render-list-row ((listing mewa-list-presentation) object index)
-  (<:tr :class "item-row"
-    (<:td :align "center" :valign "top"
-      (when (editablep listing)
-	(let ((object object))
-	  (<ucw:input :type "submit"
-		      :action (edit-from-listing listing object index)
-		      :value (edit-label listing))))
-      (<:as-is " ")
-      (when (deleteablep listing)
-	(let ((index index))
-	  (<ucw:input :type "submit"
-		      :action (delete-from-listing listing object index)
-		      :value (delete-label listing))))
-      (when (selectablep listing)
-	(let ((index index))
-	  (<ucw:input :type "submit"
-		      :action (select-from-listing listing object index)
-		      :value (select-label listing))))
-      (when (viewablep listing)
-	(let ((index index))
-	  (<ucw:input :type "submit"
-		      :action (call-component listing  (make-presentation object))
-		      :value "view"))))
-    (dolist (slot (slots listing))
-      (<:td :class "data-cell" (present-slot slot object)))
-    (<:td :class "index-number-cell")))
-
-(defmethod get-all-instances ((self mewa-list-presentation))
-  (instances self))
-
-
-;;;; * Presentation Searches
-
-
-;;;; ** "search all fields" criteria
-
-(defgeneric search-expr (criteria instance)
-  (:documentation "Return ready to apply criteria.
-                   to do with What it is backend dependent."))
-
-(defmacro def-search-expr (((self criteria-type)) (model-expr &body body))
-  `(defmethod search-expr ((,self ,criteria-type) instance)
-     (,model-expr
-      instance
-      (slot-name (presentation ,self))
-      ,@body)))
-
-(defmethod search-expr ((self negated-criteria) instance)
-  (when (criteria self)
-    (meta-model:expr-not
-     instance
-     (search-expr (criteria self) instance))))
-
-(def-search-expr ((self string-starts-with))
-    (meta-model:expr-starts-with (search-text self)))
-
-(def-search-expr ((self string-ends-with))
-    (meta-model:expr-ends-with (search-text self)))
-
-(def-search-expr ((self string-contains))
-    (meta-model:expr-contains (search-text self)))
-
-(def-search-expr ((self number-less-than))
-    (meta-model:expr-< (number-input self)))
-
-(def-search-expr ((self number-greater-than))
-    (meta-model:expr-> (number-input self)))
-
-(def-search-expr ((self number-equal-to))
-    (meta-model:expr-= (number-input self)))
-
-
-
-(defcomponent mewa-presentation-search (presentation-search)
-  ((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil)
-   (criteria-input :accessor criteria-input :initform "")
-   (new-criteria :accessor new-criteria :initform nil)))
-
-(defmethod instance ((self mewa:mewa-presentation-search))
-  (instance (search-presentation self)))
-
-(defmethod search-expr ((self mewa:mewa-presentation-search) instance)
-  (apply #'meta-model:expr-and instance
-         (mapcan (lambda (c) (let ((e  (search-expr c instance)))
-                               (if (listp e) e (list e))))
-                 (criteria self))))
-
-(defmethod search-query ((self mewa:mewa-presentation-search))
-  (search-expr self (instance self)))
-
-(defmethod valid-instances ((self mewa:mewa-presentation-search))
-  (meta-model:select-instances (instance self) (search-query self)))
-
-(defmethod get-all-instances ((self mewa-presentation-search))
-  (meta-model:select-instances (instance self)))
-
-(defmethod ok ((self mewa-presentation-search) &optional arg)
-  (declare (ignore arg))
-  (setf (instances (list-presentation self)) (valid-instances self))
-  (setf (display-results-p self) t))
-
-
-(defmethod set-search-input-for-criteria ((criteria criteria) (input t))
-  (error "No search-input-for-criteria method for ~A : ~A" criteria input))
-
-(defmethod set-search-input-for-criteria ((c string-criteria) input)
-  (setf (search-text c) input))
-
-(defmethod set-search-input-for-criteria ((c negated-criteria) i)
-  nil)
-
-
-(defmethod mewa-add-criteria ((self component) (criteria criteria))
-  (set-search-input-for-criteria criteria (criteria-input self))
-  (add-criteria self criteria))
-
-(defmethod find-default-criteria (c mewa-string-slot-presentation)
-  'string-contains)
-
-(defmethod render-criteria ((res response) (s mewa-presentation-search))
-  (setf (criteria-input s) "")
-  (<:ul
-   (dolist (c (criteria s))
-     (<:li (render-on res c)
-	   (let ((c c))
-	     (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
-     (<:li 
-      "Search For: "
-      (<ucw:input :type "text" :accessor (criteria-input s))
-      " Using : "
-       (<ucw:select :accessor (new-criteria s) 
-         (dolist (criteria (applicable-criteria s))
-	   (<ucw:option :value criteria (<:as-html (label criteria)))))
-       (<ucw:input :type "submit" :action (mewa-add-criteria s (new-criteria s))
-		   :value "add"))))
-
-(defmethod submit-search ((s mewa-presentation-search))
-  (with-slots (criteria-input) s
-    
-    (unless (or (null criteria-input)
-		(string-equal "" (remove #\Space criteria-input)))
-      
-      (mewa-add-criteria s (new-criteria s)))
-	       
-    (ok s)))
-
-(defmethod render-on ((res response) (self mewa-presentation-search))
-  ;(<:as-html (search-query self))
-  (render-criteria res self)
-  (<ucw:input :type "submit" :value "Search" :action (submit-search self))
-  (when (display-results-p self)
-    (let ((listing (list-presentation self)))
-      (setf 
-       (slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
-       (slot-value listing 'ucw::place) (slot-value self 'ucw::place)
-       (slot-value listing 'ucw::continuation) (slot-value self 'ucw::continuation))
-      
-      (render-on res listing))))
-
-
-;;;; 
-(defcomponent dont-show-unset-slots ()())
-
-(defmethod slots :around ((self dont-show-unset-slots))
-  (remove-if-not #'(lambda (s) (let ((s (presentation-slot-value s (instance self))))
-				 (and s (not (equal "" s)))))
-		 (call-next-method)))
\ No newline at end of file
diff --git a/src/slot-presentations.lisp b/src/slot-presentations.lisp
deleted file mode 100644
index 2f75737..0000000
--- a/src/slot-presentations.lisp
+++ /dev/null
@@ -1,480 +0,0 @@
-;; i know this is horrible, but it works wonders.
-(declaim (optimize (speed 0) (space 3) (safety 0)))
-
-
-(in-package :lisp-on-lines)
-
-
-;;;; I dont think i'm using these anymore.
-(defun multiple-value-funcall->list (function &rest args)
-  "The function to be called by m-v-bf"
-		   (multiple-value-call #'list (apply function args)))
-
-(defmacro multiple-value-bindf (vars form &body body)
-  "Like M-V-B, only it works in actions. form must be a function call"
-		   `(destructuring-bind ,vars 
-		     (multiple-value-funcall->list #',(car form) ,@(cdr form))
-		     ,@body))
-
-
-;;;; ** Textarea Slot Presentation
-
-(defslot-presentation text-slot-presentation ()
-  ((rows :initarg :rows :accessor rows :initform 5)
-   (columns :initarg :columns :accessor columns :initform 40)
-   (escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil)
-   (convert-newlines-p :initarg :convert-newlines-p :accessor convert-newlines-p :initform nil))
-  (:type-name text))
-
-(defmethod present-slot ((slot text-slot-presentation) instance)
-  (flet ((maybe-convert-newline-and-escape-html-then-print ()
-	   (let ((string (if (convert-newlines-p slot)
-			     (with-output-to-string (new-string)
-			       (with-input-from-string
-				   (s (presentation-slot-value slot instance))
-				 (loop for line = (read-line s nil)
-				       while line
-				       do (format new-string "~A~A" line "<br/>"))))
-			     (presentation-slot-value slot instance))))
-	     (if (escape-html-p slot)
-		 (<:as-html string)
-		 (<:as-is string)))))
-    
-    (if (editablep slot)
-	(<ucw:textarea
-	 :accessor (presentation-slot-value slot instance)
-	 :reader (or (presentation-slot-value slot instance)
-		 "")
-	 :rows (rows slot)
-	 :cols (columns slot))
-	(when (presentation-slot-value slot instance)
-	  (maybe-convert-newline-and-escape-html-then-print)))))
-
-
-(defcomponent mewa-slot-presentation ()
-  ((validate-functions :accessor validate-functions :initform (list (constantly t)))
-   (slot-name :accessor slot-name 
-	      :initarg :slot-name 
-	      :documentation 
-	      "The name of the slot being accessed")
-   (fill-gaps-only-p :accessor fill-gaps-only-p 
-		     :initarg :fill-gaps-only-p
-		     :initform nil
-		     :documentation 
-		     "When nil, the instance is syncronised with the database. 
-When T, only the default value for primary keys and the joins are updated.")
-   (show-label-p :accessor show-label-p :initarg :show-label-p :initform t)
-   (creatablep :accessor creatablep :initarg :creatablep :initform t))
-  (:documentation "The superclass of all Mewa slot presentations"))
-
-
-
-;;;; this has to be in the eval when i would think
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun generate-slot-presentation-definition-for-type (type)
-    (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
-	   (sp-name (intern (format nil "MEWA-~A" u-name)))
-	   (t-name (intern (format nil "MEWA-~A" type))))
-      `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
-	()
-	(:type-name ,t-name)))))
-
-(defmacro define-base-mewa-presentations (&body types)
-  "Define the mewa-slot-presentations by subclassing the base UCW ones"
-    `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
-		      types)))
-
-;;;then actually define the base presentations :
-(define-base-mewa-presentations 
-  boolean
-  string
-  number
-  integer
-  currency)
-
-(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
-       ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
-	(trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
-	(default-to-now-p :accessor default-to-now-p :initarg :default-to-now-p :initform nil))
-       (:type-name clsql-sys:wall-time))
-
-(defmethod lol::presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
-  (let ((date (call-next-method)))
-    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
-      (format nil "~a/~a/~a" m d y)))))
-
-(defmethod (setf lol::presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
-  (let ((new-time (clsql:parse-date-time (remove #\Space value)))
-	(old-time (when (slot-boundp instance (slot-name slot))
-		    (slot-value instance (slot-name slot)))))
-    (unless (or (eql old-time new-time)
-		(when (and new-time old-time)
-		  (equal :equal (clsql:time-compare new-time old-time))))
-    (setf (presentation-slot-value slot instance) new-time))))
-
-(defmethod label :around ((slot clsql-wall-time-slot-presentation))
-  (concatenate 'string (call-next-method) "  (m/d/y)"))
-
-(defmethod lol::present-slot ((slot clsql-wall-time-slot-presentation) instance)
-  (let ((date (lol::presentation-slot-value slot instance)))
-    ;; Default values
-    (when (and (not date) (default-to-now-p slot))
-      (setf (lol::presentation-slot-value slot instance) (clsql:get-time)))
-    ;;simple viewer
-    (if (and date (not (editablep slot)))
-	(<:as-html date))
-    ;; editor
-    (when (editablep slot)
-      (<ucw:input :accessor (lol::presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
-      (<:button :id (trigger-id slot) (<:as-html "[...]"))
-      (<:script :type "text/javascript" 
-		(<:as-is (format nil " 
-      
-Calendar.setup({
- inputField     :    \"~a\",
- button         :    \"~a\",
- ifFormat       :    \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
-
-(defslot-presentation  mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
-  ((foreign-instance :accessor foreign-instance)
-   (linkedp :accessor linkedp :initarg :linkedp :initform t)
-   (creator :accessor creator :initarg :creator :initform :editor)
-   (new-instance :accessor new-instance :initform nil))
-  (:type-name relation))
-
-(defaction search-records ((slot mewa-relation-slot-presentation) instance)
-  (multiple-value-bindf (finstance foreign-slot-name)
-      (meta-model:explode-foreign-key instance (slot-name slot))
-    (let ((new-instance (new-instance self)))
-      (unless new-instance
-	(setf (new-instance self)
-	      (call-component 
-	       (ucw::parent slot)
-	       (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
-				  'mewa::mewa-presentation-search)
-			      :search-presentation
-			      (mewa:make-presentation finstance 
-						      :type :search-presentation)
-			      :list-presentation 
-			      (mewa:make-presentation finstance 
-						      :type :listing)))))
-      (sync-foreign-instance slot new-instance))))
-
-(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
-  (let ((instance (instance (ucw::parent slot))))
-    (multiple-value-bind (foo f-slot-name)
-	(meta-model:explode-foreign-key instance (slot-name slot))
-      (setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
-      (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
-
-    
-(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
-  (multiple-value-bindf (finstance foreign-slot-name)
-      (meta-model:explode-foreign-key instance (slot-name slot))
-    (let ((new-instance
-           (call-component
-            (ucw::parent slot)
-            (mewa:make-presentation finstance :type (creator self)))))
-      
-      ;;;; TODO: this next bit is due to a bad design decision. 
-      ;;;; Components should always have (ok) return self, but somewhere 
-      ;;;; i've made in return (instance self) sometimes, and this
-      ;;;; bahaviour is totatlly fucked.
-      
-     (when (typep new-instance 'mewa::mewa)
-       (setf new-instance (instance new-instance)))
-
-      ;;;; sorry about that, and now back t our regular program.
-      
-      (meta-model:sync-instance new-instance)
-      (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
-      (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
-      
-
-(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
- ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
-  (let* ((i (foreign-instance slot))
-	 (pres (mewa::make-presentation 
-		i
-		:type :one-line 
-		:initargs (list 
-			   :global-properties 
-			   (list :editablep nil :linkedp nil)))))
-      (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
-	(setf (component.place pres) (component.place (ucw::parent slot))))
-      (when i (<ucw:render-component :component pres))))
-
-(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
-  (present-relation slot instance))
-
-(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
-  ()
-  (:type-name foreign-key)
-  (:default-initargs))
-
-(defaction view-instance ((self component) instance &rest initargs)
-  (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
-  ;; the viewed instance could have been changed/deleted, so we sync this instance
-  (meta-model:sync-instance (instance (ucw::parent self))))
-
-(defmethod  present-slot :around ((slot foreign-key-slot-presentation) instance)  
-  (setf (foreign-instance slot) 
-	(when (lol::presentation-slot-value slot instance) 
-	  (meta-model:explode-foreign-key instance (slot-name slot) :nilp t)))
-  (flet ((render () (when (foreign-instance slot)(call-next-method))))
-    (if (slot-boundp slot 'ucw::place)
-        (cond 
-          ((editablep slot)
-	   (render)
-           (<ucw:submit :action  (search-records slot instance) :value "Search" :style "display:inline")
-           (<ucw:submit :action  (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
-          ((linkedp slot)
-           (<ucw:a :action (view-instance slot (foreign-instance slot)) 
-                   (render)))
-          (t       
-           (render)))
-	;; presentation is used only for rendering
-        (render))))
-
-
-(defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
-  (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))
-		:order-by (car (list-keys (instance slot)))))
-
-
-
-;;;; HAS MANY 
-(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
-  ((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
-  (:type-name has-many))
-
-(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
-  ;; if the instance is not stored we must make sure to mark it stored now!
-  (unless (meta-model::persistentp instance)
-    (setf (mewa::modifiedp (ucw::parent self)) t))
-  ;; sync up the instance
-  ;;(mewa:ensure-instance-sync (parent slot))
-  (meta-model:sync-instance (instance (ucw::parent slot)))
-  
-  (multiple-value-bindf (class home foreign) 
-      (meta-model:explode-has-many instance (slot-name slot))
-    (let ((new (make-instance class)))
-      (setf (slot-value new foreign) (slot-value instance home))
-      (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
-      (call-component (ucw::parent slot)  (mewa:make-presentation new :type (creator slot)))
-      (meta-model:sync-instance instance))))
-
-(defmethod present-slot ((slot has-many-slot-presentation) instance)
-  (when (slot-boundp slot 'ucw::place)
-    (<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
-  (let* ((i (get-foreign-instances slot instance))
-	 (presentation (and i (make-presentation (car  i) :type :one-line))))
-    (when i
-      (flet ((linker (i string)
-	       (<ucw:a
-		:action (view-instance slot i
-				       :initargs
-				       `(:global-properties ,
-					 (list
-					  :linkedp t
-					  :editablep nil)))
-		(<:as-html string))))
-	(<:table :cellpadding 10
-	 (<:tr
-	  (<:th)			;empty col for (view) link
-	  (dolist (s (slots presentation))
-	    (<:th (<:as-html  (label s)))))
-	 (dolist (s i)
-	   (let ((s s))
-	     (setf (foreign-instance slot) s)
-	     (when (slot-boundp slot 'ucw::place)
-	       (<:tr
-		(<:td (linker s " (view) "))
-		(dolist (p (slots (make-presentation s :type :one-line
-						     :initargs
-						     '(:global-properties
-						       (:editablep nil)))))
-		  (<:td 	     
-				
-		   (present-slot p s))))))))))))
-		       
-
-(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
-  (sort (slot-value instance (slot-name slot)) #'<  
-	:key #'(lambda (x) (funcall (car (list-keys x)) x))))
-
-(defmethod lol::presentation-slot-value ((slot has-many-slot-presentation) instance)
-  (get-foreign-instances slot instance))
-
-(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
-  ((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
-   (current :accessor current :initform 0)
-   (len :accessor len )
-   (instances :accessor instances))
-  (:type-name has-very-many))
-
-(defmethod list-next ((slot has-very-many-slot-presentation))
-  (setf (current slot) (incf (current slot) (number-to-display slot)))
-  (when (< (len slot) (current slot))
-    (setf (current slot) (- (number-to-display slot) (len slot)))))
-
-(defmethod list-prev ((slot has-very-many-slot-presentation))
-  (setf (current slot) (decf (current slot) (number-to-display slot)))
-  (when  (> 0 (current slot))
-    ;;what to do here is open to debate
-    (setf (current slot) (- (len slot)(number-to-display slot)  ))))
-
-
-(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
-  ;;(<:as-html "isance: " instance)
-  (if (slot-boundp slot 'ucw::place)
-      (progn
-        (<ucw:a :action (list-prev slot) (<:as-html "<<"))
-        (let ((self (ucw::parent slot)))
-          (<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
-	        (<:as-html  (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
-        (<ucw:a :action (list-next slot) (<:as-html ">>"))
-        (call-next-method)
-        (<:as-html "total :" (len slot)))
-      (call-next-method)))
-
-(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
-  (let ((f (call-next-method)))
-    (setf (len slot) (length f))
-    (setf (instances slot) f)
-  (loop for cons on (nthcdr (current slot) f)
-		   for i from 0 upto (number-to-display slot)
-		   collect (car cons))))
-
-
-;;;; * Has-a
-(defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
-  ((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
-   (attributes :accessor attributes :initarg :attributes :initform nil))
-  (:type-name has-a))
-
-(defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
-  (multiple-value-bind (c s)      
-      (meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
-    (slot-value object s)))
-
-(defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
-  (clsql:select (class-name (class-of
-			     (meta-model:explode-foreign-key instance (slot-name slot))))
-		:flatp t))
-
-(defmethod present-slot ((slot has-a-slot-presentation) instance)
-;      (<:as-html (lol::presentation-slot-value slot instance))
-  (if (editablep slot)
-      (progn (<ucw:select :accessor (lol::presentation-slot-value slot instance) :test #'equalp
-        (when (allow-nil-p slot)
-	  (<ucw:option :value nil (<:as-html "none")))
-	(dolist (option (get-foreign-instances slot instance))
-	  (<ucw:option :value (find-foreign-slot-value slot option)
-		       (lol::present
-			(lol::make-presentation option
-			   :type :as-string
-			   :initargs
-			   `(:attributes ,(attributes slot)))
-			))))
-	     (when (creatablep slot)
-	       (<ucw:submit :action  (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))) 
-      (if (lol::presentation-slot-value slot instance)
-	  (progn
-	   (lol::present
-	    (lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
-			   :type :one-line
-			   :initargs
-			   `(:attributes ,(attributes slot)))
-			   ))
-	   (<:as-html "--"))))
-
-(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
-  ((list-view :accessor list-view :initarg :list-view :initform :one-line)
-   (action-view :accessor action-view :initarg :action-view :initform :viewer)
-   (create-view :initform :creator)
-   (select-view :initform :as-string :accessor select-view)
-   (can-add-new-p :initarg :can-add-new-p :accessor can-add-new-p :initform t)
-   (can-add-existing-p :initarg :can-add-existing-p :accessor can-add-existing-p :initform t))
-  (:type-name many-to-many)
-  (:default-initargs :label "many to many"))
-
-(defun %delete-item (item)
-  (clsql:with-default-database (clsql:*default-database*)
-    (ignore-errors
-    (clsql:delete-instance-records item))))
-
-(defaction delete-item ((self component) instance)
-  (multiple-value-bind (res err) (%delete-item instance)
-  (if (not err) 
-      (call 'info-message :message "Removed Instance")
-      (call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))
-
-(defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
-  (delete-item (ucw::parent self) rel)
-  (sync-instance instance)
-  (answer-component (ucw::parent self)   t))
-
-
-(defun find-many-to-many-join-class (slot instance)
-  (let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
-		    :db-info))
-	 (jc (make-instance (getf imd :join-class)))
-	 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
-		     :db-info)))
-    (getf jcmd :join-class)))
-
-(defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
-  (clsql:select (find-many-to-many-join-class slot instance) :flatp t))
-
-(defmethod present-slot ((slot many-to-many-slot-presentation) instance)  
-  (let ((instances (slot-value instance (slot-name slot)))
-	new-instance)
-    (<:ul
-     (when (can-add-new-p slot)
-       (<:li 
-	(<ucw:submit :action (add-to-many-to-many slot instance)
-			
-		     :value "Add New")))
-     (when (can-add-existing-p slot )
-       (<:li  (<ucw:submit :action (add-to-many-to-many slot instance new-instance)
-			   :value "Add:")
-	      (<ucw:select :accessor new-instance
-			   (arnesi:dolist* (i (find-all-instances slot instance))
-			     (<ucw:option
-			      :value i
-			      (lol:present-view (i (select-view slot) slot)))))))
-     (dolist* (i instances)
-       (<:li
-	(<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
-		(<:as-html "(view) "))
-	(<ucw:a :action (delete-relationship slot (second i) instance)
-		(<:as-html "(remove) "))
-	(present-view ((car i) (list-view slot) (ucw::parent slot))))))))
-
-
-(defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
-  ;;;; First things first, we sync.
-  (sync-instance instance)
-  (let* (new
-	 (imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
-		    :db-info))
-	 (jc (make-instance (getf imd :join-class)))
-	 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
-		     :db-info))
-	 (fc (make-instance (getf jcmd :join-class)))
-	 (c (if
-	     foreign-instance
-	     foreign-instance
-	     (call-view (fc :creator (ucw::parent slot))))))
-    (when c
-      (sync-instance c)
-;      (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
-      (setf (slot-value jc (getf imd :foreign-key))
-	    (slot-value instance (getf imd :home-key)))
-      (setf (slot-value jc (getf jcmd :home-key))
-	    (slot-value c (getf jcmd :foreign-key)))
-      (sync-instance jc)
-      
-      (sync-instance instance)
-      c)))
diff --git a/src/slot-presentations/date.lisp b/src/slot-presentations/date.lisp
deleted file mode 100644
index 973f8fe..0000000
--- a/src/slot-presentations/date.lisp
+++ /dev/null
@@ -1,246 +0,0 @@
-(in-package :lol)
-
-(defclass form-element (widget-component)
-  ((client-value :accessor client-value :initform ""
-		 :initarg :client-value
-                 :documentation "Whetever the client's browse sent for this form element."
-                 :backtrack t)
-   (lisp-value :accessor lisp-value :initform +uninitialized+
-               :initarg :lisp-value
-               :documentation "The current lisp object in this form element."
-               :backtrack t))
-  (:metaclass standard-component-class)
-  (:documentation "A single value in a form.
-
-A form-element is, simply put, a wrapper for a value in an html
-form."))
-
-;;;; Expiry date picker
-
-(defslot-presentation date-slot-presentation (clsql-wall-time-slot-presentation)
-  ((date-field :component (my-date-field :year-min 2005 :year-max 2015)
-	       :accessor date-field))
-  (:type-name date))
-
-(defmethod update-value ((slot date-slot-presentation))
-  (multiple-value-bind (year month day)
-      (time-ymd (presentation-slot-value slot (instance (ucw::parent slot))))
-    (multiple-value-bind (new-year new-month new-day)
-	(time-ymd)
-      (if (remove nil (map 'list #'(lambda (old new)
-				     (unless (equal (car old) (car new))
-				       t))
-			   (list year month day)
-			   (list new-year new-month new-day)))
-	  (setf (presentation-slot-value slot (instance (ucw::parent slot)))
-		(make-time t))))))
-
-(defmethod present-slot ((slot date-slot-presentation) instance)
-  (let ((date (slot-value instance (slot-name slot))))
-    ;; Default values
-    (when (and (not date) (default-to-now-p slot))
-      (setf date (clsql:get-time)
-	    (presentation-slot-value slot instance) date))
-    ;;simple viewer
-    (if (and date (not (editablep slot)))
-	(<:as-html date))
-    ;; editor
-    (when (editablep slot)
-      (with-slots ((m month)  (y year))
-	  (date-field slot)
-	
-      (multiple-value-bind (year month) (time-ymd date)
-	(setf (lisp-value m) month
-	      (lisp-value y) year)
-      (<ucw:render-component :component (date-field slot)))))))
-
-
-
-
-(defcomponent %integer-range-field (integer-range-field)
-  ())
-
-(defmethod (setf lisp-value) :after (value (self %integer-range-field))
-  ())
-(defclass date-field (form-element)
-  ((day :component (integer-range-field :min-value 1 :max-value 31))
-   (month :component (integer-range-field :min-value 1 :max-value 12))
-   (year :component integer-range-field))
-  (:metaclass standard-component-class))
-
-(defmethod shared-initialize :after ((field date-field) slot-names
-                                     &key (year-min 1960) (year-max 2010))
-  (declare (ignore slot-names))
-  (setf (min-value (slot-value field 'year)) year-min
-        (max-value (slot-value field 'year)) year-max
-        (max-value (slot-value field 'day)) 31
-        (max-value (slot-value field 'month)) 12))
-
-(defmethod read-client-value ((date date-field))
-  (with-slots (year month day)
-      date
-    (read-client-value year)
-    (read-client-value month)
-    (read-client-value day)
-    (setf (lisp-value date) (encode-universal-time 0 0 0
-                                                   (lisp-value day)
-                                                   (lisp-value month)
-                                                   (lisp-value year)))))
-
- 
-(defclass %date-field (date-field)
-  ((day :component (%integer-range-field :min-value 1 :max-value 31))
-   (month :component (%integer-range-field :min-value 1 :max-value 12))
-   (year :component (%integer-range-field :min-value 2006 :max-value 2015) ))
-  (:metaclass standard-component-class))
-
-(defmethod shared-initialize :after ((field %date-field) slot-names
-                                     &key (year-min 1960) (year-max 2010))
-  (declare (ignore slot-names year-min year-max))
-  (mapcar #'(lambda (x) (setf (slot-value (slot-value field x) 'ucw::parent) field))
-	  '(year month day)))
-
-(defclass my-date-field (%date-field)
-  ()
-  (:metaclass standard-component-class))
-
-(defmethod present ((date my-date-field))
-  (with-slots (year month)
-      date
-    (<ucw:render-component :component month)
-      "/"
-      (<ucw:render-component :component year)))
-
-
-
-(defconstant +uninitialized+ '+uninitialized+
-  "The value used in UCW form elements to specify that there is no value.
-
-This obviously implies that you can't have a form element whose
-real value is +uninitialized+, since +uninitialized+ is a ucw
-internal symbol this shouldn't be a problem.")
-
-
-
-(defgeneric read-client-value (element)
-  (:method ((element form-element))
-    (setf (lisp-value element) (client-value element))))
-
-(defclass form-component (widget-component)
-  ()
-  (:metaclass standard-component-class))
-
-;; remeber that actions are just methods
-(defgeneric/cc submit (form))
-
-(defaction submit :before ((f form-component))
-  (iterate
-    (with form-element-class = (find-class 'form-element))
-    (for slot in (mopp:class-slots (class-of f)))
-    (for slot-name = (mopp:slot-definition-name slot))
-    (when (and (slot-boundp f slot-name)
-               (subtypep (class-of (slot-value f slot-name)) form-element-class))
-      (read-client-value (slot-value f slot-name)))))
-
-(defaction submit ((f form-component)) t)
-
-
-(defclass select-field (form-element)
-  ((options :accessor options :initform '() :initarg :options)
-   (key :accessor key :initform #'identity :initarg :key)
-   (test :accessor test :initform #'eql :initarg :test)
-   (option-map :accessor option-map :initform (make-array 10 :adjustable t :fill-pointer 0))
-   (option-writer :accessor option-writer :initform #'princ-to-string))
-  (:metaclass standard-component-class))
-
-(defmethod render-option ((select select-field) (object t))
-  (<:as-html (funcall (option-writer select) object)))
-
-(defmethod render ( (select select-field))
-  (setf (fill-pointer (option-map select)) 0)
-  (<:select :name (make-new-callback (context.current-frame *context*)
-                                     (lambda (v) (setf (client-value select) v)))
-    (iterate
-      (for o in (options select))
-      (for index upfrom 0)
-      (vector-push-extend o (option-map select))
-      (<:option :value index
-                :selected (funcall (test select)
-                                   (funcall (key select) o)
-                                   (funcall (key select) (lisp-value select))) 
-        (render-option res select o)))))
-
-(defmethod read-client-value ((select select-field))
-  (with-slots (lisp-value option-map client-value)
-      select
-    (setf lisp-value (aref option-map (parse-integer client-value)))))
-
-;;;; Numbers from text inputs
-
-(defclass number-field (form-element)
-  ((min-value :accessor min-value :initform nil :initarg :min-value)
-   (max-value :accessor max-value :initform nil :initarg :max-value)
-   (size :accessor size :initarg :size :initform 0)
-   (maxlength :accessor maxlength :initarg :maxlength :initform 20))
-  (:metaclass standard-component-class))
-
-(defmethod validate-form-element ((number number-field))
-  (with-slots (min-value max-value lisp-value)
-      number
-    (if (eql +uninitialized+ lisp-value)
-	nil
-	(if (numberp lisp-value)
-	    (cond
-	      ((and min-value max-value)
-	       (< min-value lisp-value max-value))
-	      (min-value (< min-value lisp-value))
-	      (max-value (< lisp-value max-value))
-	      (t lisp-value))
-	    nil))))
-
-(defmethod read-client-value :around ((number number-field))
-  (unless (or (null (client-value number))
-              (string= "" (client-value number)))
-    (ignore-errors ; returns NIL in case of SIMPLE-PARSE-ERROR
-      (call-next-method))))
-
-(defmethod render ( (n number-field))
-  (<ucw:input :type "text" :accessor (client-value n)
-              :size (size n)
-	      :value (if (eql +uninitialized+ (lisp-value n))
-			 ""
-			 (lisp-value n))
-	      :maxlength (maxlength n)))
-
-(defclass decimal-field (number-field)
-  ((precision :accessor precision :initarg :precision :initform nil
-              :documentation "Number of significant digits."))
-  (:metaclass standard-component-class))
-
-(defmethod read-client-value ((decimal number-field))
-  (setf (lisp-value decimal) (parse-float (client-value decimal))))
-
-(defclass integer-field (number-field)
-  ()
-  (:metaclass standard-component-class))
-
-(defmethod read-client-value ((integer integer-field))    
-  (setf (lisp-value integer) (parse-integer (client-value integer))))
-
-(defclass integer-range-field (integer-field)
-  ()
-  (:metaclass standard-component-class)
-  (:default-initargs :min-value 1 :max-value 5))
-
-(defmethod shared-initialize :after ((field integer-range-field) slot-names
-                                     &rest initargs)
-  (declare (ignore slot-names initargs))
-  (setf (lisp-value field) (min-value field)))
-
-(defmethod render ( (range integer-range-field))
-  (<:select :name (ucw::make-new-callback 
-                                     (lambda (v) (setf (client-value range) v)))
-    (iterate
-      (for value from (min-value range) to (max-value range))
-      (<:option :value value :selected (= value (lisp-value range))
-                (<:as-html value)))))
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index ba2846b..0fe6df5 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -29,31 +29,6 @@ This allows us to dispatch to a subclasses editor."
 (defmethod list-slots (thing)
   (list 'identity))
 
-
-;;;; TODO : this doesn't work
-
-(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)))))
-
-(defmacro call-display (component object &rest properties)
-  `(let ()
-    (call-display-with-context ,component ,object nil  ,@properties)))
-
-(defcomponent standard-display-component ()
-  ((context :accessor context :initarg :context)
-   (object :accessor object-of :initarg :object)
-   (args :accessor args :initarg :args)))
-
-(defmethod render ((self standard-display-component))
-  
-  (apply #'display self (object-of self) (args self)))
-
-
 ;;;; * Object displays.
 
 
@@ -134,7 +109,6 @@ This allows us to dispatch to a subclasses editor."
 
 (defdisplay (desc (list list))
  (with-active-layers (list-display-layer)
-   	    
    (<:ul
     (dolist* (item list)
       (<:li  (apply #'display* item (list-item desc)))))))
@@ -143,9 +117,7 @@ This allows us to dispatch to a subclasses editor."
 (defdisplay
     :in-layer editor
     ((attribute standard-attribute) object)
-    "Legacy editor using UCW presentations"
-    
-    (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
+    (call-next-method))
 
 (define-layered-method display-using-description
   ((attribute standard-attribute) object component)
diff --git a/src/static-presentations.lisp b/src/static-presentations.lisp
deleted file mode 100644
index 68541d9..0000000
--- a/src/static-presentations.lisp
+++ /dev/null
@@ -1,944 +0,0 @@
-;;;; -*- lisp -*-
-
-(in-package :lisp-on-lines)
-
-(defcomponent presentation ()
-  ((css-class :accessor css-class :initarg :css-class :initform nil))
-  (:documentation "The super class of all UCW presentations.
-
-A presentation object is a UCW component which knows how to
-read/write different kinds of data types.
-
-There are three major kinds of presentations:
-
-1) object-presentation - Managing a single object.
-
-2) slot-presentation - Managing the single parts (slots) which
-   make up an object.
-
-3) collection-presentation - Managing multiple objects.
-
-Presentations are independant of the underlying application
-specific lisp objects they manage. A presentation can be created
-once and reused or modified before and aftre it has been used.
-
-Presentations fulfill two distinct roles: on the one hand they
-create, given a lisp object, a grahpical (html) rendering of that
-object, they also deal with whatever operations the user might
-wish to perform on that object.
-
-* Creating Presentation Objects
-
-Presentation objects are created by making an instance of either
-an object-presentation or a collection-presentation and then
-filling the slots property of this object."))
-
-(defgeneric present (presentation)
-  (:documentation "Render PRESENTATION (generally called from render-on)."))
-
-(defmacro present-object (object &key using presentation)
-  (assert (xor using presentation)
-	  (using presentation)
-	  "Must specify exactly one of :USING and :PRESENTATION.")
-  (if using
-      (destructuring-bind (type &rest args)
-	  (ensure-list using)
-	`(call ',type ,@args 'instance ,object))
-      (rebinding (presentation)
-	`(progn
-	   (setf (slot-value ,presentation 'instance) ,object)
-	   (call-component self ,presentation)))))
-
-(defmacro present-collection (presentation-type &rest initargs)
-  `(call ',presentation-type ,@initargs))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; object-presentation
-
-(defcomponent object-presentation (presentation)
-  ((slots :accessor slots :initarg :slots :initform nil)
-   (instance :initform nil :initarg instance :accessor instance))
-  (:documentation "Presentations for single objects."))
-
-(defmethod render-on ((res response) (o object-presentation))
-  (unless (slot-value o 'instance)
-    (error "Attempting to render the presentation ~S, but it has no instance object to present."
-	   o))
-  (present o))
-
-(defmethod present ((pres object-presentation))
-  (<:table :class (css-class pres)
-    (dolist (slot (slots pres))
-      (<:tr :class "presentation-slot-row"
-        (<:td :class "presentation-slot-label" (<:as-html (label slot)))
-	(<:td :class "presentation-slot-value" (present-slot slot (instance pres)))))
-    (render-options pres (instance pres))))
-
-(defmethod render-options ((pres object-presentation) instance)
-  (declare (ignore instance pres))
-  #| (<:tr
-    (<:td :colspan 2 :align "center"
-      (<ucw:input :type "submit" :action (ok pres) :value "Ok."))) |# )
-
-(defaction ok ((o object-presentation) &optional (value (slot-value o 'instance)))
-  (answer value))
-
-(defmethod find-slot ((o object-presentation) slot-label)
-  (find slot-label (slots o) :test #'string= :key #'label))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; inline objects are extremly similar to object-presentations
-;;;; except that we assume they're being edited within the context of
-;;;; some other and so don't get their own edit/delete/confirm
-;;;; whatever buttons.
-
-(defcomponent inline-object-presentation (object-presentation)
-  ())
-
-(defmethod render-options ((pres inline-object-presentation) instance)
-  (declare (ignore instance))
-  nil)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; 'one line' objects
-
-(defcomponent one-line-presentation (object-presentation)
-  ((before :accessor before :initform "" :initarg :before
-	   :documentation "Text to render before rendirng the slots.")
-   (between :accessor between :initform " " :initarg :between
-	    :documentation "Text to render between each slot.")
-   (after :accessor after :initform "" :initarg after
-	  :documentation "Text to render after all the slots have been rendered.")))
-
-(defmethod present ((pres one-line-presentation))
-  (<:as-is (before pres))
-  (when (slots pres)
-    (present-slot (first (slots pres)) (instance pres)))
-  (dolist (slot (cdr (slots pres)))
-    (<:as-is (between pres))
-    (present-slot slot (instance pres)))
-  (<:as-is (after pres)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; List
-
-(defcomponent list-presentation (presentation)
-  ((slots :accessor slots :initarg :slots)
-   (editablep :accessor editablep :initform t :initarg :editablep)
-   (edit-label :accessor edit-label :initform "Edit")
-   (deleteablep :accessor deleteablep :initform t :initarg :deleteablep)
-   (delete-label :accessor delete-label :initform "Delete")
-   (instances :accessor instances)))
-
-(defmethod initialize-instance :after ((l list-presentation) &rest initargs)
-  (declare (ignore initargs))
-  (setf (instances l) (get-all-instances l)))
-
-(defmethod render-on ((res response) (l list-presentation))
-  (present l))
-
-(defgeneric get-all-instances (listing)
-  (:documentation "Returns all the instances which should be viewable with LISTING.
-
-This method is also used by relation-slot-presentations for the same reason."))
-
-(defmethod present ((listing list-presentation))
-  (<:table :class (css-class listing)
-    (render-list-heading listing)
-    (iterate
-      (for element in (instances listing))
-      (for index upfrom 0)
-      (render-list-row listing element index))))
-
-(defmethod render-list-heading ((listing list-presentation))
-  (<:tr :class "presentation-list-heading-row"
-    (<:th "")
-    (dolist (slot (slots listing))
-      (<:th :class "presentation-list-heading-cell"
-        (<:as-html (label slot))))
-    (<:th "")))
-  
-(defmethod render-list-row ((listing list-presentation) object index)
-  (<:tr :class "item-row"
-    (<:td :class "index-number-cell"
-      (<:i (<:as-html index)))
-    (dolist (slot (slots listing))
-      (<:td :class "data-cell" (present-slot slot object)))
-    (<:td :align "center" :valign "top"
-      (when (editablep listing)
-	(let ((object object))
-	  (<ucw:input :type "submit"
-		      :action (edit-from-listing listing object index)
-		      :value (edit-label listing))))
-      (<:as-is " ")
-      (when (deleteablep listing)
-	(let ((index index))
-	  (<ucw:input :type "submit"
-		      :action (delete-from-listing listing object index)
-		      :value (delete-label listing)))))))
-
-(defgeneric/cc create-from-listing (listing))
-
-(defmethod/cc create-from-listing :after ((l list-presentation))
-  (setf (instances l) (get-all-instances l)))
-
-(defgeneric/cc delete-from-listing (listing item index))
-
-(defmethod/cc delete-from-listing :after ((l list-presentation) item index)
-  (declare (ignore item index))
-  (setf (instances l) (get-all-instances l)))
-
-(defgeneric/cc edit-from-listing (listing item index))
-
-(defmethod/cc edit-from-listing :after ((l list-presentation) item index)
-  (declare (ignore item index))
-  (setf (instances l) (get-all-instances l)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Searching/Filtering
-
-(defcomponent presentation-search (presentation)
-  ((criteria :accessor criteria :initform '())
-   (search-presentation :accessor search-presentation :initarg :search-presentation
-			:documentation "The presentation object
-			used in determining what the possible
-			search options are.")
-   (list-presentation :accessor list-presentation :initarg :list-presentation
-		      :documentation "The presentation object used when showing the results.")))
-
-(defgeneric applicable-criteria (presentation)
-  (:method-combination nconc))
-
-(defmethod applicable-criteria nconc ((search presentation-search))
-  (let ((criteria '()))
-    (dolist (slot (slots (search-presentation search)))
-      (setf criteria (append criteria (applicable-criteria slot))))
-    (cons (make-instance 'negated-criteria :presentation search)
-	  criteria)))
-
-(defcomponent criteria ()
-  ((presentation :accessor presentation :initarg :presentation)))
-
-(defaction add-criteria ((search presentation-search) (criteria criteria))
-  (push criteria (criteria search)))
-
-(defaction drop-criteria ((search presentation-search) (criteria criteria))
-  (setf (criteria search) (delete criteria (criteria search))))
-
-(defgeneric apply-criteria (criteria instance)
-  (:method-combination and))
-
-(defmethod valid-instances ((search presentation-search))
-  (let ((valid '()))
-    (dolist (i (get-all-instances search))
-      (block apply-criteria
-	(dolist (criteria (criteria search))
-	  (unless (apply-criteria criteria i)
-	    (return-from apply-criteria nil)))
-	(push i valid)))
-    valid))
-
-(defcomponent search-results-list (list-presentation)
-  ((search-presentation :accessor search-presentation)))
-
-(defmethod render-on ((res response) (s presentation-search))
-  (<:p "Results:")
-  (let ((listing (list-presentation s)))
-    (<:table
-      (<:tr :class "presentation-list-heading-row"
-        (<:th "")
-	(dolist (slot (slots (list-presentation s)))
-	  (<:th :class "presentation-list-heading-cell"
-	    (<:as-html (label slot))))
-	(<:th ""))
-      (loop
-         for object in (valid-instances s)
-         for index upfrom 0
-         do (<:tr :class "item-row"
-              (<:td :class "index-number-cell" (<:i (<:as-html index)))
-              (dolist (slot (slots (list-presentation s)))
-                (<:td :class "data-cell" (present-slot slot object)))
-              (<:td :align "center" :valign "top"
-                (when (editablep listing)
-                  (let ((object object))
-                    (<ucw:input :type "submit"
-                                :action (edit-from-search s object index)
-                                :value (edit-label listing))))
-                (<:as-is " ")
-                (when (deleteablep listing)
-                  (let ((index index))
-                    (<ucw:input :type "submit"
-                                :action (delete-from-search s object index)
-                                :value (delete-label listing)))))))))
-  (<:p "Search Criteria:")
-  (<:ul
-   (render-criteria res s)
-   (<:li (<ucw:input :type "submit" :action (refresh-component s)
-		     :value "update"))))
-
-(defmethod render-criteria ((res response) (s presentation-search))
-  (<:ul
-   (dolist (c (criteria s))
-     (<:li (render-on res c)
-	   (let ((c c))
-	     (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
-   (let ((new-criteria nil))
-     (<:li "Add Criteria: "
-       (<ucw:select :accessor new-criteria
-         (dolist (criteria (applicable-criteria s))
-	   (<ucw:option :value criteria (<:as-html (label criteria)))))
-       (<ucw:input :type "submit" :action (add-criteria s new-criteria)
-		   :value "add")))))
-
-(defgeneric/cc edit-from-search (search object index))
-
-(defgeneric/cc delete-from-search (search object index))
-
-;;;; meta criteria
-
-(defcomponent negated-criteria (criteria)
-  ((criteria :accessor criteria :initform nil)))
-
-(defmethod label ((n negated-criteria)) "Not:")
-
-(defmethod render-on ((res response) (n negated-criteria))
-  (<:p "Not: "
-       (when (criteria n)
-	 (render-on res (criteria n))))
-  (let ((new-criteria nil))
-    (<:p "Set Criteria: "
-      (<ucw:select :accessor new-criteria
-        (dolist (criteria (applicable-criteria (presentation n)))
-	  (<ucw:option :value criteria (<:as-html (label criteria)))))
-      (<ucw:input :type "submit" :action (setf (criteria n) new-criteria)
-		  :value "add"))))
-
-(defmethod apply-criteria and ((n negated-criteria) instance)
-  (if (criteria n)
-      (not (apply-criteria (criteria n) instance))
-      t))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Slot presentations
-
-(defcomponent slot-presentation (presentation)
-  ((label :accessor label :initarg :label)
-   (label-plural :accessor label-plural :initarg :label-plural)
-   (getter :accessor getter :initarg :getter
-	   :documentation "A function used for getting the
-	   current value of the object. It will be passed the
-	   objcet and must return the current value.")
-   (setter :accessor setter :initarg :setter
-	   :documentation "A function used for updatig the value of
-	   the underlying object. It will be passed the new
-	   value and the object (in that order).")
-   (editablep :accessor editablep :initarg :editablep :initform t)
-   (print-object-label)))
-
-(defmethod print-object ((s slot-presentation) stream)
-  (if *print-readably*
-      (call-next-method)
-      (print-unreadable-object (s stream :type t :identity t)
-        (princ (label s) stream)
-        (princ " (" stream)
-        (princ (slot-value s 'print-object-label) stream)
-        (princ ")" stream))))
-
-(defgeneric present-slot (slot instance))
-
-(defmethod initialize-instance :after ((presentation slot-presentation)
-				       &key slot-name getter setter &allow-other-keys)
-  (if slot-name
-      (setf (slot-value presentation 'print-object-label) slot-name)
-      (setf (slot-value presentation 'print-object-label) getter))
-  (when slot-name
-    (assert (not (or getter setter))
-	    (slot-name getter setter)
-	    "Can't specify :GETTER and/or :SETTER alnog with :SLOT-NAME.")
-    (setf (getter presentation) (lambda (object)
-				  (when (slot-boundp object slot-name)
-				    (slot-value object slot-name)))
-	  (setter presentation) (lambda (value object)
-				  (setf (slot-value object slot-name) value)))))
-
-(defvar *presentation-slot-type-mapping* (make-hash-table :test 'eql))
-
-(defun register-slot-type-mapping (name class-name)
-  (setf (gethash name *presentation-slot-type-mapping*) class-name))
-
-(defmacro defslot-presentation (name supers slots &rest options)
-  `(progn
-     (defcomponent ,name ,(or supers `(slot-presentation))
-       ,slots
-       ,@(remove :type-name options :key #'car))
-     ,(let ((type-name (assoc :type-name options)))
-	(when type-name
-	`(register-slot-type-mapping ',(second type-name) ',name)))
-     ',name))
-
-(defgeneric presentation-slot-value (slot instance)
-  (:method ((slot slot-presentation) instance)
-    (funcall (getter slot) instance)))
-
-(defgeneric (setf presentation-slot-value) (value slot instance)
-  (:method (value (slot slot-presentation) instance)
-    (funcall (setter slot) value instance)))
-
-(defmethod applicable-criteria nconc ((s slot-presentation))
-  nil)
-
-(defmacro criteria-for-slot-presentation (slot &body criteria-clauses)
-  (rebinding (slot)
-    `(list
-      ,@(mapcar (lambda (criteria-clause)
-		  (let ((criteria-clause (ensure-list criteria-clause)))
-		    `(make-instance ',(first criteria-clause)
-				    ,@(cdr criteria-clause)
-				    :presentation ,slot)))
-		criteria-clauses))))
-
-(defmacro defslot-critera (class-name supers slots &key label apply-criteria)
-  (with-unique-names (obj instance)
-    (list
-     'progn
-     `(defcomponent ,class-name ,supers ,slots)
-     (when label
-       `(defmethod label ((,obj ,class-name))
-          (format nil ,label (label (presentation ,obj)))))
-
-     (when apply-criteria
-       `(defmethod apply-criteria and ((,obj ,class-name) ,instance)
-          (funcall ,apply-criteria
-                   ,obj
-                   ,instance
-                   (presentation-slot-value (presentation ,obj) ,instance))))
-     `(quote ,class-name))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Boolean
-
-(defslot-presentation boolean-slot-presentation ()
-  ()
-  (:type-name boolean))
-
-(defmethod present-slot ((slot boolean-slot-presentation) instance)
-  (if (editablep slot)
-    (let ((callback (ucw::make-new-callback
-		   (lambda (val)
-		     
-		     (if (listp val)
-			 (setf (presentation-slot-value slot instance) t)
-			 (setf (presentation-slot-value slot instance) nil))))))
-    (<:input :type "hidden" :name callback :value "DEFAULT")
-    (<:input :type "checkbox"
-	     :name callback
-	     :checked  (slot-value instance (slot-name slot))))
-    (<:as-html
-     (if (presentation-slot-value slot instance)
-	 "YES"
-	 "NO"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; strings
-
-(defslot-presentation string-slot-presentation ()
-  ((max-length :accessor max-length :initarg :max-length :initform nil)
-   (size :accessor size :initarg :size :initform nil))
-  (:type-name string))
-
-(defmethod present-slot ((slot string-slot-presentation) instance)
-  (if (editablep slot)
-      (<ucw:input :type "text"
-		  :accessor (presentation-slot-value slot instance)
-		  :size (or (size slot)
-			    (if (string= "" (presentation-slot-value slot instance))
-				(size slot)
-				(+ 3 (length (presentation-slot-value slot instance)))))
-		  :maxlength (max-length slot))
-      (<:as-html (presentation-slot-value slot instance))))
-
-;;;; Critera
-
-(defmethod applicable-criteria nconc ((s string-slot-presentation))
-  (criteria-for-slot-presentation s
-    string-starts-with
-    string-contains
-    string-ends-with))
-
-(defcomponent string-criteria (criteria)
-  ((search-text :accessor search-text :initform nil)))
-
-(defmethod render-on ((res response) (criteria string-criteria))
-  (<:as-html (label criteria) " ")
-  (<ucw:input :type "text" :accessor (search-text criteria) :size 10))
-
-(defslot-critera string-contains (string-criteria)
-  ()
-  :label "~A contains:"
-  :apply-criteria (lambda (criteria instance slot-value)
-		    (declare (ignore instance))
-		    (and (<= (length (search-text criteria)) (length slot-value))
-			 (search (search-text criteria) slot-value :test #'char-equal))))
-
-(defslot-critera string-starts-with (string-contains)
-  ()
-  :label "~A starts with:"
-  :apply-criteria (lambda (criteria instance slot-value)
-                    (declare (ignore instance))
-		    (and (<= (length (search-text criteria)) (length slot-value))
-			 (= 0 (or (search (search-text criteria) slot-value
-					  :test #'char-equal)
-				  -1)))))
-
-(defslot-critera string-ends-with (string-contains)
-  ()
-  :label "~A ends with:"
-  :apply-criteria (lambda (criteria instance slot-value)
-		    (declare (ignore instance))
-		    (and  (<= (length (search-text criteria)) (length slot-value))
-			  (= (- (length slot-value) (length (search-text criteria)))
-			     (or (search (search-text criteria) slot-value
-					 :from-end t
-					 :test #'char-equal)
-				 -1)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; numbers
-
-(defslot-presentation number-slot-presentation ()
-  ((min-value :accessor min-value :initarg :min-value :initform nil)
-   (max-value :accessor max-value :initarg :max-value :initform nil)))
-
-(defcomponent number-criteria (criteria)
-  ((number-input :accessor number-input :initform nil)))
-
-(defmethod applicable-criteria nconc ((s number-slot-presentation))
-  (criteria-for-slot-presentation s
-    number-less-than
-    number-greater-than
-    number-equal-to))
-
-(defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria)
-  `(progn
-     (defslot-critera ,name (number-criteria)
-       ()
-       :label ,label
-       :apply-criteria (lambda (criteria instance slot-value)
-			 (declare (ignore instance))
-			 (if (numberp slot-value)
-			     (if (number-input criteria)
-				 (funcall ,apply-criteria slot-value (number-input criteria))
-				 t)
-			     nil)))
-
-     (defmethod render-on ((res response) (obj ,name))
-       (<:as-html (format nil ,render-on-prefix (label (presentation obj))))
-       (<ucw:input :type "text"
-		   :reader (or (number-input obj) "")
-		   :writer (lambda (v)
-			     (unless (string= "" v)
-			       (let ((n (parse-float v)))
-				 (when n
-				   (setf (number-input obj) n)))))))))
-
-(defnumber-criteria number-equal-to
-  :apply-criteria (lambda (slot-value number-input)
-		    (= slot-value number-input))
-  :label "~A is equal to:"
-  :render-on-prefix "~A = ")
-
-(defnumber-criteria number-less-than
-  :apply-criteria (lambda (slot-value number-input)
-		    (< slot-value number-input))
-  :label "~A is less than:"
-  :render-on-prefix "~A < ")
-
-(defnumber-criteria number-greater-than
-  :apply-criteria (lambda (slot-value number-input)
-		    (> slot-value number-input))
-  :label "~A is greater than:"
-  :render-on-prefix "~A > ")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Integers
-
-(defslot-presentation integer-slot-presentation (number-slot-presentation)
-  ()
-  (:type-name integer))
-
-(defmethod presentation-slot-value ((slot integer-slot-presentation) instance)
-  (declare (ignore instance))
-  (or (call-next-method) ""))
-
-(defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance)
-  (unless (string= "" value)
-    (let ((i (parse-integer value :junk-allowed t)))
-      (when i
-	(setf (presentation-slot-value slot instance) i)))))
-
-(defmethod present-slot ((slot integer-slot-presentation) instance)
-  (if (editablep slot)
-      (<ucw:input :type "text"
-		  :accessor (presentation-slot-value slot instance))
-      (<:as-html (presentation-slot-value slot instance))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Reals
-
-(defcomponent real-slot-presentation (number-slot-presentation)
-  ())
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Currency (double precision reals)
-
-(defslot-presentation currency-slot-presentation (real-slot-presentation)
-  ((as-money-p :accessor as-money-p :initarg :as-money-p :initform nil))
-  (:type-name currency))
-
-(defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance)
-  (let ((*read-eval* nil))
-    (unless (string= "" value)
-      (let ((value (read-from-string value)))
-	(when (numberp value)
-	  (setf (presentation-slot-value c instance) value))))))
-
-(defmethod present-slot ((currency currency-slot-presentation) instance)
-  (if (editablep currency)
-      (<ucw:input :type "text" :size 10
-		  :accessor (presentation-slot-value currency instance))
-      (<:as-html (format nil (if (as-money-p currency)
-				 "$~$"
-				 "~D")
-			 (presentation-slot-value currency instance)) )))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; dates and times
-
-(defslot-presentation timestamp-slot-presentation (slot-presentation)
-  ()
-  (:type-name timestamp))
-
-(defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg)
-  (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor))))
-    `(progn
-       (defgeneric ,accessor-name (slot instance))
-       (defgeneric (setf ,accessor-name) (value slot instance))
-       (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance)
-	 (when (presentation-slot-value slot instance)
-	   (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance)))))
-       (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance)
-	 (if (presentation-slot-value slot instance)
-	     (setf (presentation-slot-value slot instance)
-		   (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance)))
-	     (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value))))
-       (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance)
-         (setf (,accessor-name slot instance)
-               (if (string= "" value)
-                   nil
-                   (parse-integer value))))
-       (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance)
-         (setf (presentation-slot-value slot instance) nil)))))
-
-(deftimestamp-slot-accessor second time-hms 2 :second)
-(deftimestamp-slot-accessor minute time-hms 1 :minute)
-(deftimestamp-slot-accessor hour time-hms 0 :hour)
-(deftimestamp-slot-accessor year time-ymd 0 :year)
-(deftimestamp-slot-accessor month time-ymd 1 :month)
-(deftimestamp-slot-accessor day time-ymd 2 :day)
-
-(defslot-presentation ymd-slot-presentation (timestamp-slot-presentation)
-  ()
-  (:type-name date))
-
-(defmethod present-slot ((slot ymd-slot-presentation) instance)
-  (if (editablep slot)
-      (<:progn
-        (<ucw:input :class (css-class slot) :type "text" :size 2
-                    :accessor (timestamp-slot-day slot instance))
-        "/"
-        (<ucw:input :class (css-class slot) :type "text" :size 2
-                    :accessor (timestamp-slot-month slot instance))
-        "/"
-        (<ucw:input :class (css-class slot) :type "text" :size 4
-                    :accessor (timestamp-slot-year slot instance)))
-      (if (presentation-slot-value slot instance)
-	  (<:progn
-	    (<:as-html (timestamp-slot-day slot instance))
-	    "/"
-	    (<:as-html (timestamp-slot-month slot instance))
-	    "/"
-	    (<:as-html (timestamp-slot-year slot instance)))
-	  (<:as-html "---"))))
-
-(defmethod applicable-criteria nconc ((slot ymd-slot-presentation))
-  (criteria-for-slot-presentation slot
-    date-before-criteria))
-
-(defslot-critera date-before-criteria (criteria)
-  ((target :accessor target))
-  :label "Date Before:")
-
-(defmethod render-on ((res response) (dbc date-before-criteria))
-  (<:as-html "Date Before: "))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Relations
-
-(defcomponent relation-slot-presentation (slot-presentation)
-  ((presentation :accessor presentation
-		 :initarg :presentation
-		 :documentation "The class of presentation
-		 objects used to fill the options of a select
-		 tag.")
-   (search-presentation :accessor search-presentation
-			:initarg :search-presentation
-			:initform nil)
-   (allow-nil-p :accessor allow-nil-p
-		:initarg :allow-nil-p
-		:initform t
-		:documentation "Can this relation not exist.")))
-
-(defmethod presentation ((slot relation-slot-presentation))
-  (with-slots (presentation)
-      slot
-    (if (or (symbolp presentation)
-	    (consp presentation))
-	(setf presentation (apply #'make-instance (ensure-list presentation)))
-	presentation)))
-
-(defgeneric get-foreign-instances (pres instance))
-
-(defcomponent relation-criteria (criteria presentation-search)
-  ((criteria :accessor criteria :initform '())))
-
-(defmethod search-presentation ((criteria relation-criteria))
-  (or (search-presentation (presentation criteria))
-      (presentation (presentation criteria))))
-
-;;;; One-Of
-
-(defslot-presentation one-of-presentation (relation-slot-presentation)
-  ((none-label :initarg :none-label :accessor none-label
-	       :initform "none"))
-  (:type-name one-of))
-
-(defmethod present-slot ((slot one-of-presentation) instance)
-  (if (editablep slot)
-      (<ucw:select :accessor (presentation-slot-value slot instance)
-        (when (allow-nil-p slot)
-	  (<ucw:option :value nil (<:as-html (none-label slot))))
-	(dolist (option (get-foreign-instances (presentation slot) instance))
-	  (setf (instance (presentation slot)) option)
-	  (<ucw:option :value option (present (presentation slot)))))
-      (if (presentation-slot-value slot instance)
-	  (progn
-	    (setf (instance (presentation slot)) (presentation-slot-value slot instance))
-	    (present (presentation slot)))
-	  (<:as-html "--"))))
-
-(defmethod applicable-criteria nconc ((slot one-of-presentation))
-  (criteria-for-slot-presentation slot
-    one-of-criteria
-    one-of-not-null))
-
-(defslot-critera one-of-criteria (relation-criteria)
-  ())
-
-(defmethod label ((ooc one-of-criteria))
-  (strcat (label (presentation ooc)) " with:"))
-
-(defmethod render-on ((res response) (ooc one-of-criteria))
-  (<:as-html (label (presentation ooc)) " with:")
-  (render-criteria res ooc))
-
-(defmethod apply-criteria and ((ooc one-of-criteria) instance)
-  (let ((nested-instance (presentation-slot-value (presentation ooc) instance))
-	(criteria (criteria ooc)))
-    (if criteria
-	(if nested-instance
-	    (dolist (c (criteria ooc) t)
-	      (unless (apply-criteria c nested-instance)
-		(return-from apply-criteria nil)))
-	    nil)
-	t)))
-
-(defslot-critera one-of-not-null (criteria)
-  ())
-
-(defmethod label ((oonn one-of-not-null))
-  (strcat (label (presentation oonn)) " exists."))
-
-(defmethod apply-criteria and ((oonn one-of-not-null) instance)
-  (not (null (presentation-slot-value (presentation oonn) instance))))
-
-(defmethod render-on ((res response) (oonn one-of-not-null))
-  (<:as-html (label (presentation oonn)) " exists."))
-
-;;;; Some-Of
-
-(defslot-presentation some-of-presentation (relation-slot-presentation)
-  ()
-  (:type-name some-of))
-
-(defmethod present-slot ((slot some-of-presentation) instance)
-  (<:ul
-   (if (presentation-slot-value slot instance)
-       (loop
-          for option in (presentation-slot-value slot instance)
-          for index upfrom 0
-          do (let ((option option) ;; loop changes the values, it does
-                                   ;; not create fresh bindings
-                   (index index))
-               (<:li
-                 (<:table
-                   (<:tr
-                     (<:td (setf (instance (presentation slot)) option)
-                           (present (presentation slot)))
-                     (when (editablep slot)
-                       (<:td :align "left" :valign "top"
-                         (<ucw:input :type "submit"
-                                     :action (delete-element slot instance option index)
-                                     :value (concatenate 'string "Delete " (label slot))))))))))
-       (<:li "None."))
-   (render-add-new-item slot instance)))
-
-(defmethod render-add-new-item ((slot some-of-presentation) instance)
-  (let ((new-object nil)
-	(foreign-instances (get-foreign-instances (presentation slot) instance)))
-    (when (and foreign-instances (editablep slot))
-      (<:li "Add: "
-        (<ucw:select :accessor new-object
-	  (dolist (option foreign-instances)
-	    (setf (instance (presentation slot)) option)
-	    (<ucw:option :value option (present (presentation slot)))))
-	(<ucw:input :type "submit"
-		    :action (add-element slot instance new-object)
-		    :value "Add")))))
-
-(defaction add-element ((some-of some-of-presentation) instance item)
-  (push item (presentation-slot-value some-of instance)))
-
-(defaction delete-element ((some-of some-of-presentation) instance item index)
-  (let ((nth (nth index (presentation-slot-value some-of instance))))
-    (unless (eq nth item)
-      (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
-	     index item index nth))
-    (setf (presentation-slot-value some-of instance)
-	  (iterate
-	    (for element in (presentation-slot-value some-of instance))
-	    (for i upfrom 0)
-	    (unless (= index i)
-	      (collect element))))))
-
-(defmethod applicable-criteria nconc ((slot some-of-presentation))
-  (criteria-for-slot-presentation slot
-    some-of-any
-    some-of-all))
-
-(defslot-critera some-of-criteria (relation-criteria)
-  ())
-
-(defmethod render-on ((res response) (soa some-of-criteria))
-  (<:as-html (label soa))
-  (render-criteria res soa))
-
-(defmacro defsome-of-criteria (name supers slots &key label apply-criteria)
-  (with-unique-names (obj)
-    `(progn
-       (defslot-critera ,name ,supers ,slots)
-       (defmethod label ((,obj ,name))
-	 (format nil ,label (label (presentation ,obj))))
-       (defmethod apply-criteria and ((,obj ,name) instance)
-	 (let ((nested-instances (presentation-slot-value (presentation ,obj) instance))
-	       (criteria (criteria ,obj)))
-	   (if criteria
-	       (if nested-instances
-		   (funcall ,apply-criteria (criteria ,obj) nested-instances)
-		   nil)
-	       t))))))
-
-(defsome-of-criteria some-of-any (some-of-criteria)
-  ()
-  :label "Any ~A with:"
-  :apply-criteria (lambda (criteria nested-instances)
-		    ;; return T if any nested-instance meets all of criteria
-		    (some (lambda (instance)
-			    (every (lambda (criteria)
-				     (apply-criteria criteria instance))
-				   criteria))
-			  nested-instances)))
-
-(defsome-of-criteria some-of-all (some-of-criteria)
-  ()
-  :label "All ~A with:"
-  :apply-criteria (lambda (criteria nested-instances)
-		    ;; return T only if every nested-instances meets
-		    ;; all of our criteria
-		    (every (lambda (instance)
-			     (every (lambda (criteria)
-				      (apply-criteria criteria instance))
-				    criteria))
-			   nested-instances)))
-
-;;;; An-Object
-
-(defslot-presentation an-object-presentation (one-of-presentation)
-  ()
-  (:type-name an-object))
-
-(defmethod present-slot ((slot an-object-presentation) instance)
-  (if (presentation-slot-value slot instance)
-      (progn
-	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
-	(present (presentation slot))
-	(<ucw:input :type "submit" :action (delete-an-object slot instance)
-                    :value (concatenate 'string "Delete " (label slot))))
-      (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create")))
-
-(defaction delete-an-object ((slot an-object-presentation) instance)
-  (setf (presentation-slot-value slot instance) nil))
-
-(defaction create-an-object ((slot an-object-presentation) instance)
-  (let ((obj (make-new-instance (presentation slot) instance)))
-    (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj)
-    (setf (presentation-slot-value slot instance) obj)))
-
-;;;; Some-Objects
-
-(defslot-presentation some-objects-presentation (some-of-presentation)
-  ()
-  (:type-name some-objects))
-
-(defmethod render-add-new-item ((slot some-objects-presentation) instance)
-  (when (editablep slot)
-    (<:li (<ucw:input :type "submit"
-		      :action (add-an-object slot instance)
-		      :value "Add new object."))))
-
-(defgeneric make-new-instance (presentation instance)
-  (:documentation "Create an new instance suitable for
-  PRESENTATION which will be added to INSTANCE (according to
-  PRESENTATION)."))
-
-(defaction add-an-object ((slot some-objects-presentation) instance)
-  (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Convience macros/functions
-
-(defmacro slot-presentations (&rest slot-specs)
-  `(list ,@(mapcar (lambda (slot)
-		     (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*)))
-		       (if class-name
-			   `(make-instance ',class-name ,@(cdr slot))
-			   (error "Unknown slot type ~S." (car slot)))))
-		   slot-specs)))
-
-(defmacro defpresentation (name supers slots &rest default-initargs)
-  `(defcomponent ,name ,supers
-     ()
-     (:default-initargs
-       ,@(when slots `(:slots (slot-presentations ,@slots)))
-       ,@default-initargs)))
-
-- 
2.20.1