:components ((:static-file "lisp-on-lines.asd")
(:file "src/packages")
(:module :src
- :components ((:file "static-presentations")
+ :components ((:file "special-initargs")
+ (:file "properties")
+ ;;;; legacy UCW presentations
+ (:file "static-presentations")
+
(:file "mewa")
(:file "validation")
(:file "validation/email-address")
(:file "slot-presentations/date")
(:file "defdisplay")
(:file "standard-display")
+ (:file "standard-occurence")
(:file "standard-attributes")
+ (:file "dojo-attributes")
(:file "standard-wrappers")
(:file "relational-attributes")
(:file "backwards-compat"))
:serial t)
+ (:module :attributes
+ :pathname "src/attributes/"
+ :components ((:file "numbers")))
(:module :components
:pathname "src/components/"
:components ((:file "range-list")
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defattribute number-attribute (base-attribute)
+ ()
+ (:type-name number))
+
+;;;; INTEGER
+(defattribute integer-attribute (base-attribute)
+ ()
+ (:type-name integer))
+
+;;;; REALS
+
+(defattribute real-attribute (base-attribute)
+ ()
+ (:type-name real))
+
+
+;;;; Currency
+(defattribute currency-attribute (base-attribute)
+ ()
+ (:type-name currency))
+
+(defdisplay
+ ((currency currency-attribute) object)
+ (<:as-html (format nil "$~$" (attribute-value object currency))))
;;;; with the past. You learn to live with it.
+(defmethod find-old-type (type)
+ type)
+
;;!legacy string
(defmethod find-attribute-class-for-type ((type (eql 'mewa-string)))
'string-attribute)
+;; legacy int
+(defmethod find-attribute-class-for-type ((type (eql 'mewa-integer)))
+ 'integer-attribute)
+
+;; currency
+(defmethod find-attribute-class-for-type ((type (eql 'mewa-currency)))
+ 'currency-attribute)
+;; legacy relations
+
+(defmethod find-attribute-class-for-type ((type (eql 'ajax-foreign-key)))
+ 'lol::has-a)
+
+
+(defmethod find-attribute-class-for-type ((type (eql 'foreign-key)))
+ 'lol::has-a)
+
+(defmethod find-layer-for-type ((type (eql 'mewa-one-line-presentation)))
+ 'one-line)
+
+(defmethod find-old-type ((type (eql 'one-line)))
+ 'mewa-one-line-presentation)
+
+(defmethod find-old-type ((type (eql 'one-line)))
+ 'mewa-one-line-presentation)
+
+
+
+
(meta-model:explode-foreign-key instance (slot-name slot)))))))
(flet ((render-s () (when foreign-instance (call-next-method))))
+
(if (slot-boundp slot 'ucw::place)
(cond
((editablep slot)
(<ucw:render-component :component (live-search slot))
#+ (or) (<ucw:submit :action (revert-foreign-slot slot)
:value "Undo")
- (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline"))
+ #+ (or) (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline"))
((mewa::linkedp slot)
(<ucw:a :action (mewa::view-instance slot foreign-instance)
(render-s)))
(t
(render-s)))
;; presentation is used only for rendering
- (render-s)))))
\ No newline at end of file
+ (render-s))))
+)
\ No newline at end of file
,(lol::make-action-url
,component
(progn
- ,@actions
- (call-component nil (output-component self))))))
+ ,@actions))))
,@ (unless
,(getf args :post-content)
`(:post-content (+ ,,@(loop for c in callbacks
--- /dev/null
+(in-package :lisp-on-lines)
+
+
+(defmethod simple-word-search (class-name slots search-terms)
+ (select class-name
+ :where (simple-word-search-where class-name slots search-terms)
+ :flatp t))
+
+(defmethod simple-word-search-where (class-name slots search-terms)
+ (sql-or
+ (mapcar #'(lambda (term)
+ (apply #'sql-or
+ (mapcar #'(lambda (slot)
+ (sql-uplike
+ (sql-slot-value class-name slot)
+ (format nil "%~a%" term)))
+ slots)))
+ search-terms)))
+
+(defmethod find-slots-of-type (model &key (type 'string)
+ (types '((string)) types-supplied-p))
+ "returns a list of slots matching TYPE, or matching any of TYPES"
+ (let (ty)
+ (if types-supplied-p
+ (setf ty types)
+ (setf ty (list type)))
+ (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
+ (first st)))
+ (list-slot-types model)))))
+
+;;;; * Simple Search Component
+
+(defcomponent simple-search ()
+ ((search-term :initarg :search-term :accessor search-term :initform "")
+ (listing :initarg :listing :accessor listing :initform :listing)
+ (select-returns-p :initarg :select-returns-p :accessor select-returns-p :initform nil)
+ (search-tables :initarg :search-tables :accessor search-tables :initform nil)))
+
+(defmethod render-on ((res response)(self simple-search))
+ (<ucw:input :type "text" :accessor (search-term self))
+ (<ucw:submit :action (do-search self)))
+
+(defmethod perform-simple-search ((self simple-search) &key (base-classes (meta-model:list-base-classes :clsql)))
+ (when (search-tables self)
+ (setf base-classes (search-tables self)))
+ (remove nil (mapcar #'(lambda (x)
+ (simple-word-search x
+ (find-slots-of-type x)
+ (split-sequence #\Space (search-term self))))
+ base-classes)))
+
+
+(defaction do-search ((self simple-search))
+ (let* ((target (or (slot-value self 'ucw::parent) self))
+ (result (call-component
+ target
+ (make-instance 'simple-search-results
+ :listing (listing self)
+ :results
+ (perform-simple-search self :base-classes
+ (remove 'claim-history (meta-model:list-base-classes :clsql)))
+ :search-term (split-sequence #\Space (search-term self))))))
+ (when result
+ (if (select-returns-p self)
+ (answer result)
+ (call-component target (make-presentation result :type :viewer))))))
+
+(defcomponent simple-search-results ()
+ ((results :accessor results :initarg :results :initform nil)
+ (listing :initarg :listing :accessor listing :initform :listing)
+ (search-term :initarg :search-term :accessor search-term :initform nil)))
+
+(defmethod view-name (view)
+ (class-name (class-of view)))
+
+(defmethod render-on ((res response) (self simple-search-results))
+ (<:h3 (<:as-html "Search results for " (search-term self)))
+ (dolist (r (results self))
+ (<:fieldset
+ (<:legend (<:as-html (format nil "Found ~A results in ~A:" (length r) (view-name (car r)))))
+ (render-on res
+ (embed-component
+ self
+ (make-presentation
+ (car r)
+ :type :listing
+ :initargs `(:instances ,r)))))))
+
+(defaction ok ((self simple-search-results) &optional arg)
+ (declare (ignore arg))
+ (answer nil))
+
+
+
+;;;; * Advanced Search Component
+
+(defcomponent advanced-search ()
+ ((simple-search :component simple-search :accessor simple-search)
+ (search-table :accessor search-table :initform nil)
+ (search-presentation :accessor search-presentation :initform nil)))
+
+(defmethod render-on ((res response) (self advanced-search))
+ (<:h2 (<:as-html "Advanced Search"))
+ ;; simple search :
+ (<:fieldset
+ (<:legend (<:as-html "simple text search"))
+ (render-on res (simple-search self)))
+ ;; complex-search
+ (<:fieldset
+ (<:legend (<:as-html "Complex Search"))
+ (<:as-html "Choose search table:")
+ (<ucw:select
+ :accessor (search-table self)
+ (dolist (tbl (meta-model:list-base-classes :clsql))
+ (<ucw:option :value tbl (<:as-html tbl))))
+ (<ucw:submit :action (select-search-table self) :value "select")
+ ;;
+ (when (search-presentation self)
+ (<:fieldset
+ (<:legend (<:as-html (format nil "search ~A" (search-table self))))
+ (render-on res (embed-component self (search-presentation self)))))))
+
+
+(defun make-search-presentation (instance )
+ (make-instance 'mewa::mewa-presentation-search
+ :search-presentation (make-presentation instance :type :search-model)
+ :list-presentation (make-presentation instance :type :listing
+(defaction select-search-table ((self advanced-search))
+ (let* ((i (make-instance (search-table self)))
+ (p (make-search-presentation i)))
+ (embed-component self p)
+ (setf (search-presentation self) p) ))
+
+
+(defcomponent table-search
+
+
+
+
-(in-package :lisp-on-lines)
-
-(defmethod find-properties (object)
- (list))
-
-(defmethod find-properties ((attribute standard-attribute))
- (warn "atttributre properties ~A" (attribute.properties attribute))
- (attribute.properties attribute))
-
-(defmacro with-properties ((properties &optional prefix) &body body)
- (with-unique-names (p)
- (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
- (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
- (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
- `(let ((,p ,properties))
- (flet ((,get (p)
- (getf ,p p))
- (,set (p v)
- (setf (getf ,p p) v))
- (,props ()
- ,p))
- (declare (ignorable #',get #',set #',props))
- ,@body)))))
-
-
-;;;;; Macros
-(defmacro do-attributes ((var occurence attributes) &body body)
- (with-unique-names (att properties type)
- `(loop for ,att in ,attributes
- do (let* ((,att (ensure-list ,att))
- (,properties (rest ,att))
- (,type (getf ,properties :type))
- (,var (if ,type
- (make-attribute :name (first ,att) :type ,type :properties ,properties)
- (find-attribute ,occurence (first ,att)))))
- (with-properties ((plist-union (rest ,att) (find-properties ,var)) ,var)
- ,@body)))))
-
-
-
-
-(defmacro defdisplay (object (&key in-layer combination
- (description t
- description-supplied-p)
- (component 'component
- component-supplied-p))
- &body body)
- (with-unique-names (d c p)
- (let ((obj (car (ensure-list object))))
- `(define-layered-method display-using-description
- ,@(when in-layer `(:in-layer ,in-layer))
- ,@(when combination`(,combination))
- (,(cond
- (description-supplied-p
- (setf d description))
- ((null description)
- d)
- (t
- `(,d standard-occurence)))
- ,(cond
- (component-supplied-p
- (setf c component))
- ((null component)
- c)
- (t
- `(,c component)))
- ,object ,p)
- (with-component (,c)
- (with-properties ((plist-union ,p (find-properties ,(car (ensure-list d) ))))
- ,(if (not description-supplied-p)
- `(progn
-
- (setp :attributes (or (getp :attributes) (list-slots ,obj)))
- (macrolet ((do-attributes* ((var &optional attributes) &body body)
- `(do-attributes (,var ,',d (or ,attributes (getp :attributes)))
-
- (flet ((display-current-attribute ()
- (display-using-description* ,var ,',obj (,(intern (strcat var "-PROPERTIES"))))))
- ,@body))))
- ,@body))
- `(progn ,@body))))))))
\ No newline at end of file
+(in-package :lisp-on-lines)
+
+(define-layered-function display-using-description (description object component)
+ (:documentation
+ "Render the object in component,
+ using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
+
+(define-layered-method
+ display-using-description (d o c)
+ (<:as-html "default :" o))
+
+(defmethod find-layer-for-type (type)
+ type)
+
+
+(define-layered-function display (component object &rest args)
+ (:documentation
+ "Displays OBJECT in COMPONENT."))
+
+(define-layered-method display ((component t) (object t)
+ &rest properties
+ &key type
+ &allow-other-keys)
+ "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
+
+ (let* ((occurence (find-occurence object))
+ (description (or (find-display-attribute
+ occurence
+ (setf type (or type (description.type occurence))))
+ occurence)))
+ (if description
+ (dletf (((description.type occurence) type)
+ ((description.layers description) (append `(+
+
+ ;;find-layer-for-type is a
+ ;; backwards compat thing
+ ,(find-layer-for-type
+ type))
+ (description.layers description)))
+ ((attributes description) (or
+ (attributes description)
+ (list-slots object))))
+ (funcall-with-description
+ description properties
+ #'display-using-description description object component))
+ (error "no description for ~A" object))))
+
+;;;;; Macros
+;;;; TODO: " should really be a funcall-with function with a small wrapper."
+
+(defun funcall-with-description (description properties function &rest args)
+ (if description
+ (dletf* (((description.type description) (or
+ (getf properties :type)
+ (description.type description)))
+
+ ((description.layers description) (append
+ (description.layers description)
+ (getf properties :layers)))
+ ((description.properties description) properties))
+ (funcall-with-layers
+ (description.layers description)
+ #'(lambda ()
+ (funcall-with-special-initargs
+ description properties
+ #'(lambda ()
+ (apply function args))))))
+ (apply function args)))
+
+
+
+(defmacro with-description ((description &rest properties) &body body)
+ `(funcall-with-description ,description (if ',(cdr properties)
+ (list ,@properties)
+ ,(car properties))
+ #'(lambda ()
+ ,@body)))
+
+(defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body body)
+ (with-unique-names (att properties type)
+ `(dolist* (,att ,attributes)
+ (let* ((,att (ensure-list ,att))
+ (,properties (rest ,att))
+ (,type (getf ,properties :type))
+ (,var (let ((a (find-attribute ,description (first ,att))))
+ (if ,type
+ (apply #'make-attribute :name (first ,att) :type ,type ,properties)
+ (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
+ (funcall-with-description ,var ,properties
+ #'(lambda () ,@body))))))
+
+(defmacro with-component ((component) &body body)
+ `(let ((self ,component))
+ (declare (ignorable self))
+ (flet ((display* (thing &rest args)
+ (apply #'display ,component thing args))
+ (display-attribute (attribute obj &optional props)
+ (if props
+ (funcall-with-description
+ attribute props
+ #'display-using-description attribute obj ,component)
+ (display-using-description attribute obj ,component))))
+ (declare (ignorable #'display* #'display-attribute))
+ ,@body)))
+
+(defmacro defdisplay (&body body)
+ (loop with in-layerp = (eq (car body) :in-layer)
+ with layer = (if in-layerp (cadr body) 't)
+ for tail on (if in-layerp (cddr body) body)
+ until (listp (car tail))
+ collect (car tail) into qualifiers
+ finally
+ (when (member :in-layer qualifiers)
+ (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
+ (return
+ (destructuring-bind (description object &optional component) (car tail)
+ (with-unique-names (d c)
+ (let (standard-description-p)
+ `(define-layered-method
+ display-using-description
+ :in-layer ,layer
+ ,@qualifiers
+
+ (,(cond
+ ((listp description)
+ (setf d (car description))
+ description)
+ (t
+ (setf d description)
+ (setf standard-description-p t)
+ `(,d description)))
+ ,object
+ ,(cond
+ ((null component)
+ `(,c component))
+ ((listp component)
+ (setf c (car component))
+ component)
+ (t
+ (setf c component)
+ `(,c component))))
+ (with-component (,c)
+ ,@(cdr tail)))))))))
+
+
--- /dev/null
+(in-package :lisp-on-lines)
+
+(deflayer dojo)
+
+(define-layered-class
+ attribute :in-layer dojo ()
+ ((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
+
+
+(defgeneric display-as-dojo-type (type attribute object component))
+
+(defdisplay
+ :in-layer dojo :after ((attribute standard-attribute) object)
+ (when (dojo-type attribute)
+ (display-as-dojo-type (dojo-type attribute) attribute object self)))
+
+(defcomponent dojo-test (window-component)
+ (
+ (results :accessor results :initarg :results)))
+
+(defmethod render ((self dojo-test))
+ (<:as-is (js:js* `(array
+ ,@(loop for r in (results self)
+ for n upfrom 0
+ collect `(array ,
+ (with-output-to-string (s)
+ (yaclml:with-yaclml-stream s
+ (display self r :type 'as-string))) ,n))))))
+
+
+(defmethod display-as-dojo-type ((type (eql 'combo-box)) attribute object component)
+
+ (let* ((search-function (search-function attribute))
+ (select-function (select-function attribute))
+ (select-callback (ucw::make-new-callback (lambda (x)
+ (warn "setting index to ~A" (parse-integer x))
+ (funcall select-function
+ (parse-integer x))))))
+ "The combo box widget"
+ (<ucw:script
+ `(dojo.require "dojo.*")
+ `(dojo.require "dojo.widget.*")
+ `(dojo.require "dojo.widget.html.ComboBox")
+ (js:with-unique-js-names (element combo-box)
+
+ `(dojo.add-on-load
+ (lambda ()
+ (setf ,element (dojo.by-id ,(id attribute)))
+ (setf ,combo-box
+ (dojo.widget.from-script
+ "ComboBox"
+ (create
+ :data-url (+ , (lol::make-action-url
+ component
+ (call-component
+ (context.window-component *context*)
+ (make-instance 'dojo-test
+ :results
+ (funcall search-function
+ (attribute-value object attribute)))))
+ "&"
+ ,(escape-as-uri (callback attribute))
+ "=%{searchString}")
+ :mode "remote")
+ ,element))
+ ((slot-value ,combo-box 'set-value) (slot-value ,element 'value))
+ (dojo.event.connect
+ ,combo-box "selectOption"
+ (lambda ()
+ (setf (slot-value ,element 'value)
+ (slot-value ,combo-box 'selected-result))
+ (dojo.io.bind
+ (create
+ :url (+ ,(lol::make-action-url
+ component
+ nil)
+ "&"
+ ,(escape-as-uri (callback attribute))
+ "="
+ (slot-value ,combo-box 'selected-result)
+ "&"
+ ,select-callback
+ "="
+ (slot-value ,combo-box 'combo-box-selection-value.value))))))))))))
+
\ No newline at end of file
(defparameter *default-type* :ucw)
-;;;; I think these are unused now
-(defmethod perform-set-attributes ((occurence-name t) definitions)
- (dolist (def definitions)
- (funcall #'set-attribute occurence-name (first def) (rest def))))
-
-(defmethod perform-set-attribute-properties ((occurence-name t) definitions)
- (dolist (def definitions)
- (funcall #'set-attribute-properties occurence-name (car def) (cdr def))))
-
-;;;; PLIST Utilities.
-
-(defun plist-nunion (new-props plist)
- "Destructive Merge of plists. PLIST is modified and returned.
-NEW-PROPS is merged into PLIST such that any properties
-in both PLIST and NEW-PROPS get the value in NEW-PROPS.
-The other properties in PLIST are left untouched."
- (loop for cons on new-props by #'cddr
- do (setf (getf plist (first cons)) (second cons))
- finally (return plist))
- plist)
-
-(defun plist-union (new-props plist)
- "Non-destructive version of plist-nunion"
- (plist-nunion new-props (copy-list plist)))
+(define-layered-class description ()
+ ((description-type
+ :initarg :type
+ :accessor description.type
+ :initform 'viewer
+ :special t)
+ (description-layers
+ :initarg :layers
+ :accessor description.layers
+ :initform nil
+ :special t)
+ (description-properties
+ :accessor description.properties
+ :initform nil
+ :special t)
+ (description-attributes
+ :accessor attributes
+ :initarg :attributes
+ :initform nil
+ :special t)))
+(defmethod print-object ((self description) stream)
+ (print-unreadable-object (self stream :type t)
+ (with-slots (description-type) self
+ (format t "~A" description-type))))
;;;; * Occurences
(defvar *occurence-map* (make-hash-table)
- "Presentations are created by associating an 'occurence'
+ "a display is generated by associating an 'occurence'
with an instance of a class. This is usually keyed off class-name,
although an arbitrary occurence can be used with an arbitrary class.")
(define-layered-class
- standard-occurence ()
+ standard-occurence (description)
((attribute-map :accessor attribute-map :initform (make-hash-table)))
(:documentation
"an occurence holds the attributes like a class holds slot-definitions.
(find-or-create-occurence (class-name (class-of instance)))))
+(define-layered-class
+ attribute (description)
+ ((name :layered-accessor attribute.name
+ :initarg :name
+ :initform (gensym "ATTRIBUTE-")
+ :special t)
+ (occurence :accessor occurence :initarg :occurence :initform nil)
+ (label :initarg :label :accessor label :initform nil :special t)))
+
;;;; * Attributes
+(defmethod print-object ((self attribute) stream)
+ (print-unreadable-object (self stream :type t)
+ (with-slots (name description-type) self
+ (format stream "~A ~A" description-type name))))
(define-layered-class
- standard-attribute ()
- ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
- (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
- (properties :layered-accessor attribute.properties :initarg :properties :initform nil))
+ standard-attribute (attribute)
+ ((setter :accessor setter :initarg :setter :special t :initform nil)
+ (getter :accessor getter :initarg :getter :special t :initform nil)
+ (slot-name :accessor slot-name :initarg :slot-name :special t)
+ (id :accessor id :initarg :id :special t :initform (random-string)))
(: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."))
(defmacro defattribute (name supers slots &rest args)
(let ((type (or (second (assoc :type-name args)) name))
- (properties (cdr (assoc :default-properties args))))
+ (layer (or (second (assoc :in-layer args)) nil))
+ (properties (cdr (assoc :default-properties args)))
+ (cargs (remove-if #'(lambda (key)
+ (or (eql key :type-name)
+ (eql key :default-properties)
+ (eql key :default-initargs)
+ (eql key :in-layer)))
+ args
+ :key #'car)))
+
`(progn
-
(define-layered-class
;;;; TODO: fix the naive way of making sure s-a is a superclass
- ,name ,(or supers '(standard-attribute))
- ,slots
- #+ (or) ,@ (cdr args)
- (:default-initargs :properties (list ,@properties)))
+ ;;;; Need some MOPey goodness.
+ ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
+ ,(append slots (properties-as-slots properties))
+ #+ (or) ,@ (cdr cargs)
+ ,@cargs
+ (:default-initargs :properties (list ,@properties)
+ ,@ (cdr (assoc :default-initargs args))))
+
(defmethod find-attribute-class-for-type ((type (eql ',type)))
',name))))
-(defmethod print-object ((self standard-attribute) stream)
- (print-unreadable-object (self stream :type t)
- (with-slots (name type) self
- (format stream "~A ~A" name type))))
+
(define-layered-class
- presentation-attribute (standard-attribute)
+ display-attribute (attribute)
()
(:documentation "Presentation Attributes are used to display objects
using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
(defmethod find-attribute-class-for-name (name)
"presentation attributes are named using keywords"
(if (keywordp name)
- 'presentation-attribute
+ 'display-attribute
'standard-attribute))
-(defun make-attribute (&key name type properties)
- (let ((i (make-instance (or (find-attribute-class-for-type type)
- (find-attribute-class-for-name name))
- :name name :type type)))
- (setf (attribute.properties i)
- (plist-union properties (attribute.properties i)))
- i))
+(defun make-attribute (&rest args &key name type &allow-other-keys)
+ (apply #'make-instance
+ (or (find-attribute-class-for-type type)
+ (find-attribute-class-for-name name))
+ args))
-(defmethod ensure-attribute ((occurence standard-occurence) name type properties)
+(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
"Creates an attribute in the given occurence"
- (setf (gethash name (attribute-map occurence))
- (make-attribute :name name :type type :properties properties)))
+ (let ((attribute (apply #'make-attribute :occurence occurence args)))
+ (setf (description.properties attribute) args)
+ (setf (gethash name (attribute-map occurence))
+ attribute)))
(defmethod find-attribute ((occurence standard-occurence) name)
(gethash name (attribute-map occurence)))
(loop for att being the hash-values of (attribute-map occurence)
collect att))
-(defmethod ensure-attribute (occurence-name name type properties)
- (ensure-attribute
+(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
+ (declare (ignore name type))
+ (apply #'ensure-attribute
(find-occurence occurence-name)
- name
- type
- properties))
+ args))
;;;; The following functions make up the public interface to the
;;;; MEWA Attribute Occurence system.
(find-all-attributes (find-occurence occurence-name)))
(defmethod find-attribute (occurence-name attribute-name)
- "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
+ "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
(find-attribute (find-occurence occurence-name) attribute-name))
-(defmethod (setf find-attribute) ((def list) occurence-name attribute-name)
- (ensure-attribute occurence-name attribute-name (first def) (rest def)))
+(defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name)
+ "Create a new attribute in the occurence.
+ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
+ (apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec)))
-(defmethod set-attribute (occurence-name attribute-name definition &key (inherit t))
- (let ((att (find-attribute occurence-name attribute-name)))
- (setf (find-attribute occurence-name attribute-name)
- (if (and att inherit)
- (cons (car definition)
- (plist-union (cdr definition)
- (attribute.properties att)))
- definition))))
+
+(defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
+ (find-attribute (occurence attribute-with-occurence) attribute-name))
(defmethod set-attribute-properties ((occurence-name t) attribute properties)
- (let ((a (find-attribute occurence-name attribute)))
- (if a
- (setf (attribute.properties a) (plist-nunion properties (attribute.properties a)))
- (error "Attribute ~A does not exist" attribute))))
+ (setf (description.properties attribute) (plist-nunion
+ properties
+ (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)))
+
+ (if s-n
+ (progn
+ (setf (slot-value attribute
+ (cdr s-n))
+ value))
+ (warn "Cannot find initarg ~A in attribute ~S" initarg attribute)))
+ finally (return attribute)))
+
+(defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t))
+ "If inherit is T, sets the properties of the attribute only, unless the type has changed.
+otherwise, (setf find-attribute)"
+ (let ((att (find-attribute occurence-name attribute-name)))
+ (if (and att inherit (or (eql (car attribute-spec)
+ (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))))))))
(defmethod perform-define-attributes ((occurence-name t) attributes)
(loop for attribute in attributes
do (destructuring-bind (name type &rest args)
attribute
- (cond ((eq type t)
- ;;use the existing (default) type
- (set-attribute-properties occurence-name name args))
- ((not (null type))
- ;;set the type as well
- (set-attribute occurence-name name (cons type args)))))))
+ (cond ((not (null type))
+ ;;set the type as well
+ (set-attribute occurence-name name (cons type args)))))))
(defmacro define-attributes (occurence-names &body attribute-definitions)
`(progn
,@(loop for occurence-name in occurence-names
collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
+(defmethod find-display-attribute (occurence name)
+ (find-attribute occurence (intern (symbol-name name) "KEYWORD")))
+
+(defmethod find-description (object type)
+ (let ((occurence (find-occurence object)))
+ (or (find-display-attribute
+ occurence
+ type)
+ occurence)))
(defmethod setter (attribute)
(warn "Setting ~A in ~A" attribute *context*)
- (let ((setter (getf (attribute.properties attribute) :setter))
- (slot-name (getf (attribute.properties attribute) :slot-name)))
+ (let ((setter (getf (description.properties attribute) :setter))
+ (slot-name (getf (description.properties attribute) :slot-name)))
(cond (setter
setter)
(slot-name
(setf (slot-value object slot-name) value)))
(t
#'(lambda (value object)
- (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
+ (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
-(defmethod getter (attribute)
- (let ((getter (getf (attribute.properties attribute) :getter))
- (slot-name (getf (attribute.properties attribute) :slot-name)))
- (cond (getter
- getter)
- (slot-name
- #'(lambda (object)
- (when (slot-boundp object slot-name)
- (slot-value object slot-name)))))))
-
(define-layered-function attribute-value (instance attribute)
(:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
(define-layered-method attribute-value (instance (attribute standard-attribute))
- (funcall (getter attribute) instance))
+ (with-slots (getter slot-name) attribute
+ (cond ((and (slot-boundp attribute 'getter) getter)
+ (funcall getter instance))
+ ((and (slot-boundp attribute 'slot-name) slot-name)
+ (when (slot-boundp instance slot-name)
+ (slot-value instance slot-name)))
+ ((and (slot-exists-p instance (attribute.name attribute)) )
+ (when (slot-boundp instance (attribute.name attribute))
+ (slot-value instance (attribute.name attribute)))))))
(define-layered-function (setf attribute-value) (value instance attribute))
-(define-layered-method (setf attribute-value) (value instance (attribute standard-attribute))
- (funcall (setter attribute) value instance))
+(define-layered-method
+ (setf attribute-value) (value instance (attribute standard-attribute))
+
+ (with-slots (setter slot-name) attribute
+ (cond ((and (slot-boundp attribute 'setter) setter)
+
+ (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)) slot-name)
+ (setf (slot-value instance (attribute.name attribute)) value))
+ (t
+ (error "Cannot set ~A in ~A" attribute instance)))))
;;;; ** Default Attributes
(defun find-presentation-attributes (occurence-name)
(loop for att in (find-all-attributes occurence-name)
- when (typep att 'presentation-attribute)
+ when (typep att 'display-attribute)
collect att))
(defun attribute-to-definition (attribute)
(nconc (list (attribute.name attribute)
- (attribute.type attribute))
- (attribute.properties attribute)))
+ (description.type attribute))
+ (description.properties attribute)))
(defun find-default-presentation-attribute-definitions ()
(if (eql *default-attributes-class-name* 'default)
(real-default (find-attribute 'default type)))
(cond
(possible-default
- (attribute.type possible-default))
+ (description.type possible-default))
(real-default
- (attribute.type real-default))
+ (description.type real-default))
(t type))))
(defun gen-presentation-slots (instance)
-;;;presentations
+;;;; DEPRECIATED: Mewa presentations
+;;;; this is legacy cruft.
+
+
(defcomponent mewa ()
((instance :accessor instance :initarg :instance)
(attributes
(declare (type list plist) (type symbol att-name))
"This is a ucw specific function that will eventually be factored elsewhere."
(let* ((attribute (find-attribute occurence att-name))
- (type (when attribute (or type (attribute.type attribute))))
+ (type (when attribute (or type (description.type attribute))))
(class-name
(or (gethash (if (consp type)
(car type)
type)
*presentation-slot-type-mapping*)
(error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation))))
-
- (cons (attribute.name attribute) (apply #'make-instance
+
+ ;(warn "~%~% **** Making attribute ~A ~%~%" class-name)
+ (cons (attribute.name attribute) (apply #'make-instance
class-name
(append (plist-nunion
plist
(plist-union
(global-properties parent-presentation)
- (attribute.properties attribute)))
+ (description.properties attribute)))
(list :size 30 :parent parent-presentation))))))
(defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
+ (warn "making old-style for ~A ~A ~A" object type initargs)
;(warn "Initargs : ~A" initargs)
- (let* ((a (find-attribute object type))
+ (let* ((a (find-attribute object type))
+ (d-a (when a (find-display-attribute (occurence a) (description.type (occurence a)))))
(i (apply #'make-instance
- (if a
- (attribute.type a)
+ (if d-a
+ (find-old-type (description.type a))
type)
(plist-union initargs (when a
- (attribute.properties a))))))
-
+ (description.properties a))))))
+ (warn "attribute? ~A ~A " (and a (description.type (find-attribute object type)) ) (description.properties a))
(setf (slot-value i 'instance) object)
(initialize-slots i)
(setf (slot-value i 'initializedp) t)
:display-using-description
:call-display
+
;;;;a wrapper for calling make-presentation
:call-view
:present-view
:make-presentation
:call-presentation
+ :find-occurence
+
;;attributes
:attributes
+ :attribute-value
:define-attributes
:with-default-attributes
:set-default-attributes
--- /dev/null
+(in-package :lisp-on-lines)
+
+
+
+
+;;;; PLIST Utilities.
+
+(defun plist-nunion (new-props plist)
+ "Destructive Merge of plists. PLIST is modified and returned.
+NEW-PROPS is merged into PLIST such that any properties
+in both PLIST and NEW-PROPS get the value in NEW-PROPS.
+The other properties in PLIST are left untouched."
+ (loop for cons on new-props by #'cddr
+ do (setf (getf plist (first cons)) (second cons))
+ finally (return plist))
+ plist)
+
+(defun plist-union (new-props plist)
+ "Non-destructive version of plist-nunion"
+ (plist-nunion new-props (copy-list plist)))
+
+
+
+
+
+
+(defun slots-as-properties (object)
+ "Makes a plist by making a keyword from the ...ahh .. read the damn code"
+ (mapcan
+ #'(lambda (slot-name)
+ (when (slot-boundp object slot-name)
+
+ (list (intern (symbol-name slot-name)
+ (find-package :keyword))
+ (slot-value object slot-name))))
+ (list-slots object)))
+
+(defun properties-as-slots (plist)
+ "takes a plist and turns it into slot-definitions, interning the key names in *package*"
+ (loop for (key val) on plist by #'cddr
+ collect (let ((name (intern (symbol-name key))))
+ `(,name :accessor ,name :initarg ,key :special t :initform ,val))))
+
+(defmacro with-properties ((properties &optional (prefix '||)) &body body)
+ (with-unique-names (p)
+ (let ((get (intern (strcat prefix '.get)))
+ (set (intern (strcat prefix '.set)))
+ (props (intern (strcat prefix '.properties))))
+ `(let ((,p ,properties))
+ (flet ((,get (p)
+ (getf ,p p))
+ (,set (p v)
+ (setf (getf ,p p) v))
+ (,props ()
+ ,p))
+ (declare (ignorable #',get #',set #',props))
+ ,@body)))))
\ No newline at end of file
;;;; * Relational Attributes
+
+;;;; ** has-a
+
+(defattribute has-a ()
+ ()
+ (:default-properties
+ :has-a nil))
+
+(define-layered-method attribute-value (object (attribute has-a))
+ (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
+
+(defdisplay ((attribute has-a) object)
+ (let ((args (plist-union (description.properties attribute) (has-a attribute)))
+ (val (attribute-value object attribute)))
+ (when val
+ (setf (getf args :type)
+ 'lol::one-line))
+ (apply #'display* val
+ args)))
+
+
;;;; ** Has-Many attribute
(defattribute has-many ()
()
(:default-properties
:add-new-label "Add New"
- :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x)))))
+ :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
+ (:default-initargs
+ :type 'lol::one-line))
+
+(define-layered-method
+ attribute-value (object (has-many has-many))
+ (slot-value object (slot-name has-many)))
-(defdisplay object (:description (attribute has-many))
+(defdisplay ((attribute has-many) object)
;
- (<ucw:submit :action (add-to-has-many slot instance) :value (getp :add-new-label))
- (let* ((i (apply #'sort (slot-value object (getp :slot-name))
- (getp :sort-arguments))))
- (display component i
- :type'lol::one-line
- :layers '(+ wrap-link))))
+ ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
+
+ (<:div :style "clear:both;"
+ (let* ((i (apply #'sort (slot-value object (slot-name attribute))
+ (sort-arguments attribute))))
+ (<:ul
+ (dolist* (x i)
+ (<:li (display* x
+ :type 'lol::one-line
+ :layers '(+ wrap-link - label-attributes))))))))
(defun find-many-to-many-class (slot-name instance)
-(defdisplay object (:description (attribute many-to-many))
+(defdisplay ((attribute many-to-many) object)
(<:as-html "ASDASD"))
#+nil(let ((instances (select-instances object t))
new-instance)
(<:ul
- (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))
+ (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
(<:as-html "Add New")))
(<:li (<ucw:button :action (add-new-relation component object new-instance)
(<:as-html "Add:"))
(<ucw:a :action (delete-relationship slot (second i) instance)
(<:as-html "(remove) "))
(display component object)))))
- ;(display component (mapcar #'car (slot-value object (getp :slot-name))))
+ ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
\ No newline at end of file
;; 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))))
+ (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
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defmethod initargs.slot-names (object)
+ "Returns ALIST of (initargs) . slot-name."
+ (nreverse (mapcar #'(lambda (slot)
+ (cons (closer-mop:slot-definition-initargs slot)
+ (closer-mop:slot-definition-name slot)))
+ (closer-mop:class-slots (class-of object)))))
+
+(defun find-slot-names-from-initargs-plist (object initargs-plist)
+ "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS.
+SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE."
+ (let (slot-names values
+ (initargs.slot-names-alist (initargs.slot-names object)))
+ (loop for (initarg value) on initargs-plist
+ do (let ((slot-name
+ (cdr (assoc-if #'(lambda (x) (member initarg x))
+ initargs.slot-names-alist))))
+ (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
+ (push slot-name slot-names)
+ (push value values)))
+ finally (return (values slot-names values)))))
+
+(defun funcall-with-special-initargs (object initargs function &rest args)
+ "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist"
+ (multiple-value-bind (slot-names values)
+ (find-slot-names-from-initargs-plist object initargs)
+ (special-symbol-progv
+ (with-symbol-access
+ (loop for slot-name in slot-names
+ collect (slot-value object slot-name)))
+ values
+ (apply function args))))
+
+(defmacro with-special-initargs ((object &rest initargs) &body body)
+ `(funcall-with-special-initargs ,object ,initargs
+ #'(lambda ()
+ ,@body)))
\ No newline at end of file
-(in-package :lisp-on-lines)
-
-;;;; Strings
-
-(defattribute string-attribute ()
- ()
- (:type-name string)
- (:default-properties
- :escape-html-p t))
-
-(defdisplay object (:description (string string-attribute))
- (<:as-html "ASD")
- (if (getp :escape-html-p)
- (<:as-html (attribute-value object string))
- (<:as-is (attribute-value object string))))
-
-
-(defattribute image ()
- ())
-
-(defdisplay object (:description (buttons (eql 'image-editor-buttons)))
- (<ucw:a :action (ok component object)
- (<:as-html "select this image")))
-
-(defdisplay object (:description (image image))
- (<:img
- :class (or (getp :css-class) "lol-image")
- :src (arnesi:strcat
- (or (getp :prefix) "images/")
- (escape-as-uri
- (attribute-value object image)))))
-
-(defdisplay object (:description (image image)
- :in-layer editor)
- (<:div
- :class "lol-image-thumbnails"
-
- (dolist* (i (or (getp :directory)
- (cl-fad:list-directory (strcat *default-pathname-defaults* "wwwroot/images/"))))
- (<:div
- :style "border: 1px solid black;width:100px;"
- (<:img
- :width "90px"
- :src (strcat (or (getp :prefix) "images/")
- (file-namestring i)))
- (display-using-description 'image-editor-buttons component (file-namestring i) properties))
- (<:p :style "clear:both;"))))
-
-
-
-
-
-
+(in-package :lisp-on-lines)
+
+(deflayer omit-nil-attributes)
+
+(defdisplay :in-layer omit-nil-attributes
+ :around ((attribute standard-attribute) object)
+ (when (attribute-value object attribute)
+ (call-next-method)))
+
+(deflayer label-attributes)
+
+(defdisplay :in-layer label-attributes
+ :around ((attribute standard-attribute) object)
+
+ (<:span
+ :class "lol-label"
+ (<:as-html (or (label attribute) (attribute.name attribute))))
+ (<:span
+ :class "lol-attribute"
+ (call-next-method)))
+
+;;;; * Base Types
+
+(defattribute base-attribute ()
+ ())
+
+(defdisplay ((base base-attribute) object)
+ (<:as-html (attribute-value object base)))
+
+;;;; Strings
+
+(defattribute string-attribute (base-attribute)
+ ()
+
+ (:type-name string)
+ (:default-properties
+ :escape-html-p t
+ :size nil
+ :max-length nil))
+
+(defdisplay :in-layer omit-nil-attributes
+ :around ((attribute string-attribute) object)
+ (when (< 0 (length (attribute-value object attribute)))
+ (call-next-method)))
+
+
+;;;; default
+(defdisplay ((string string-attribute) object)
+ (if (escape-html-p string)
+ (<:as-html (attribute-value object string))
+ (<:as-is (attribute-value object string))))
+
+
+;;;; editor
+(defattribute string-attribute (base-attribute)
+ ()
+ (:in-layer editor)
+ (:default-properties
+ :callback nil))
+
+(defdisplay
+ :in-layer editor :around ((string string-attribute) object)
+ (dletf (((callback string) (ucw::make-new-callback
+ #'(lambda (val)
+ (setf (attribute-value object string) val)))))
+ (call-next-method)))
+
+(defdisplay :in-layer editor ((string string-attribute) object)
+ (<:input
+ :type "text"
+ :id (id string)
+ :name (callback string)
+ :value (or (attribute-value object string) "")))
+
+(defattribute string-search-attribute (string-attribute)
+ ()
+ (:default-properties
+ ;; the func that find search results
+
+ :search-action #'(lambda ()
+ (with-call/cc
+ nil))
+ ;; when chosing from a list of results, this function selects one.
+ :select-function (constantly t))
+ (:type-name string-search))
+
+(defdisplay
+ :in-layer editor :after ((search string-search-attribute) object)
+ (IT.BESE.YACLML.TAGS:INPUT
+ :TYPE "submit"
+ :VALUE "search"
+ :ONCLICK
+ (JS:JS-INLINE*
+ `(PROGN
+ (IT.BESE.UCW::SET-ACTION-PARAMETER
+ ,(IT.BESE.UCW::MAKE-NEW-ACTION
+ (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
+ (search-action search)))
+ (RETURN T)))))
+
+;;;; textarea
+
+(defattribute text-attribute (string-attribute)
+ ()
+ (:type-name text))
+
+(defdisplay :in-layer editor ((string text-attribute) object)
+ (<:textarea
+ :id (id string)
+ :name (callback string)
+ (or (attribute-value object string) "")))
+
+
+
+;;;; WALL-TIME
+
+(defattribute wall-time-attribute (string-attribute)
+ ()
+ (:type-name clsql-sys:wall-time))
+
+(define-layered-method attribute-value (object (attribute wall-time-attribute))
+ (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)))))
+
+(defdisplay
+ ((time wall-time-attribute) object)
+ (<:as-html (attribute-value object time)))
+
+
+
+(defattribute image ()
+ ())
+
+(defdisplay ((buttons (eql 'image-editor-buttons)) object)
+ (<ucw:a :action (ok component object)
+ (<:as-html "select this image")))
+
+(defdisplay ((image image) object)
+ (<:img
+ :class (or (.get :css-class) "lol-image")
+ :src (arnesi:strcat
+ (or (.get :prefix) "images/")
+ (escape-as-uri
+ (attribute-value object image)))))
+
+(defdisplay
+ :in-layer editor ((image image) object)
+
+ (<:div
+ :class "lol-image-thumbnails"
+
+ (dolist* (i (or (.get :directory)
+ (cl-fad:list-directory (strcat *default-pathname-defaults* "wwwroot/images/"))))
+ (<:div
+ :style "border: 1px solid black;width:100px;"
+ (<:img
+ :width "90px"
+ :src (strcat (or (.get :prefix) "images/")
+ (file-namestring i)))
+ (display-using-description* 'image-editor-buttons (file-namestring i) (.properties)))
+ (<:p :style "clear:both;"))))
+
+
+
+
+
+
-(in-package :lisp-on-lines)
-
-
-;;;; The Standard Layer Hierarchy
-(deflayer viewer)
-(deflayer editor (viewer))
-(deflayer creator (editor))
-
-;;;; 'Mixin' Layers
-(deflayer one-line)
-
-(deflayer wrap-form)
-
-(deflayer as-table)
-
-(define-attributes (contextl-default)
- (:viewer viewer)
- (:editor editor)
- (:creator creator))
-
-
-(defmacro with-component ((component) &body body)
- `(let ((self ,component))
- (declare (ignorable self))
- (flet ((display* (thing &rest args)
- (apply #'display ,component thing args))
- (display-using-description* (desc obj &optional props)
- (display-using-description desc ,component obj props)))
- (declare (ignorable #'display* #'display-using-description*))
- ,@body)))
-
-
-(define-layered-function find-display-type (object))
-
-(define-layered-method find-display-type (object)
- 'viewer)
-
-(define-layered-function find-display-layers (object))
-
-(define-layered-method find-display-layers (object)
- "layered function"
- nil)
-
-(defmacro call-display (component object &rest args)
- `(call-component ,component (make-instance 'standard-display-component
- :display #'(lambda (component)
- (with-component (component)
- (display ,component ,object ,@args))))))
-
-
-
-;;;; * Object displays.
-
-;;;; We like to have a label for attributes, and meta-model provides a default.
-(defdisplay label
- (:description (d (eql 'attribute-label)))
- (<:span
- :class "label"
- (<:as-html label)))
-
-
-(define-layered-function display (component object &rest args)
- (:documentation
- "Displays OBJECT in COMPONENT.
-
- default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
-
-(define-layered-method display
- ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys)
- (let* ((occurence (find-occurence object))
- (properties (attribute.properties
- (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
- (layers (append (when type (loop for ty in (ensure-list type)
- nconc `(+ ,ty)))
- layers
- (getf properties :layers))))
- (funcall-with-layers
- layers
- #'display-using-description occurence component object (plist-union args properties))))
-
-
-(define-layered-method display
- ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
- (funcall-with-layers
- layers
- #'display-using-description t component object args))
-
-
-(define-layered-function display-using-description (description component object properties)
- (:documentation
- "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
-
-(define-layered-method display-using-description (description component object properties)
- "The standard display simply prints the object"
- (declare (ignore component properties description))
- (<:as-html object))
-
-
-
-;;;; ** The default display
-
-
-
-;;;; ** One line
-(defdisplay object (:in-layer one-line)
- "The one line presentation just displays the attributes with a #\Space between them"
- (do-attributes* (attribute)
- (display-current-attribute)
- (<:as-html " ")))
-
-;;;; ** as-table
-
-(defdisplay object (:in-layer as-table)
- (<:table
- (do-attributes* (a)
- (<:tr
- (<:td (<:as-html (a-getp :label)))
- (<:td (display-current-attribute))))))
-
-;;;; List Displays
-(defdisplay (list list) ()
- (<:ul
- (dolist* (item list)
- (<:li (apply #'display component item properties)))))
-
-;;;; Attributes
-(defdisplay object (:in-layer
- editor
- :description (attribute standard-attribute))
- "Legacy editor using UCW presentations"
- (warn "USING LEGACY EDITOR FOR ~A" (getf (find-properties attribute) :slot-name))
- (let ((p (lol:make-view object :type :editor)))
- (present-slot-view p (getf (find-properties attribute) :slot-name))))
-
-(define-layered-method display-using-description
- ((attribute standard-attribute) component object properties)
- (<:as-html (attribute.type attribute) " ")
-
- (<:as-html (attribute-value object attribute)))
-
-(defdisplay (button (eql 'standard-form-buttons))
- (:description (description t))
- (<ucw:submit :action (ok component)
- :value "Ok."))
-
-(defdisplay object (:in-layer wrap-form
- :combination :around)
- (<ucw:form
- :action (refresh-component component)
- (call-next-method)
- (display component 'standard-form-buttons)))
-
-
-(defcomponent standard-display-component ()
- ((display-function :accessor display-function :initarg :display)))
-
-(defmethod render ((self standard-display-component))
- (funcall (display-function self) self))
-
-
-
-
-
-
+(in-package :lisp-on-lines)
+
+;;;; The Standard Layers
+(deflayer viewer)
+(deflayer editor)
+(deflayer creator)
+(deflayer one-line)
+(deflayer as-table)
+(deflayer as-string)
+
+(defdisplay
+ :in-layer as-string (d o)
+ (do-attributes (a d)
+ (display-attribute a o)
+ (<:as-is " ")))
+
+(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 :initarg :object)
+ (args :accessor args :initarg :args)))
+
+(defmethod render ((self standard-display-component))
+
+ (apply #'display self (object self) (args self)))
+
+
+;;;; * Object displays.
+
+;;;; We like to have a label for attributes, and meta-model provides a default.
+(defdisplay ((desc (eql 'label)) label)
+ (<:span
+ :class "label"
+ (<:as-html label)))
+
+;;;; TODO: all lisp types should have occurences and attributes defined for them.
+
+(defdisplay ((description t) lisp-value)
+ (<:as-html lisp-value))
+
+(defdisplay (description (object string))
+ (<:as-html object))
+
+(defdisplay (description object (component t))
+ "The default display for CLOS objects"
+ (print (class-name (class-of object)))
+ (dolist* (slot-name (list-slots object))
+
+ (let ((boundp (slot-boundp object slot-name)))
+ (format t "~A~A : ~A" (strcat slot-name)
+ (if boundp
+ ""
+ "(unbound)")
+ (if boundp
+ (slot-value object slot-name) "")))))
+
+(defdisplay ((description t) object)
+ "The default display for CLOS objects in UCW components"
+ (dolist* (slot-name (list-slots object))
+
+ (let ((boundp (slot-boundp object slot-name)))
+ (<:label :class "lol-label"
+ (display-attribute 'label (strcat slot-name))
+ (if boundp
+ ""
+ "(unbound)"))
+ (<:as-html
+ (if boundp
+ (slot-value object slot-name) "")))))
+
+;;;; ** The default displays for objects with a MEWA occurence
+
+(defdisplay (description object)
+ (<:div
+ :class "lol-display"
+ (do-attributes (attribute description)
+ (<:div
+ :class "lol-attribute-row"
+ (display-attribute attribute object)))))
+
+;;;; ** One line
+(defdisplay
+ :in-layer one-line (description object)
+ "The one line presentation just displays the attributes with a #\Space between them"
+ (do-attributes (attribute description)
+ (display-attribute attribute object)
+ (<:as-html " ")))
+
+;;;; ** as-table
+
+(defdisplay :in-layer as-table (description object)
+ (<:table
+ (do-attributes (a description)
+ (<:tr
+ (<:td :class "lol-label" (<:as-html (label a)))
+ (<:td (display-attribute a object))))))
+
+;;;; List Displays
+(defdisplay (desc (list list))
+ (<:ul
+ (dolist* (item list)
+ (<:li (display* item)
+ (<:as-html item)))))
+
+;;;; Attributes
+(defdisplay
+ :in-layer editor
+ ((attribute standard-attribute) object)
+ "Legacy editor using UCW presentations"
+
+ (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
+
+(define-layered-method display-using-description
+ ((attribute standard-attribute) object component)
+ (with-component (component)
+ (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
+ (<:as-html "*" )))
+ (<:as-html (attribute-value object attribute)))
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+(in-package :lisp-on-lines)
+
+;;;; STRINGS
+
+(find-or-create-occurence 'string)
+
+(defmethod find-occurence ((string string))
+ (find-occurence 'string))
+
+(set-attribute 'string 'identity `(string :getter ,#'(lambda (x)
+ (identity x))))
+(set-default-attributes 'string)
+
+;;;; LISTS
+
+(find-or-create-occurence 'list)
+
+(defmethod find-occurence ((list list))
+ (find-occurence 'list))
+
+(set-attribute 'list 'identity `(string :getter ,#'(lambda (x)
+ (identity x))))
+(set-default-attributes 'string)
+
-(in-package :lisp-on-lines)
-
-;;;;; Wrap a display in "back buttons"
-(deflayer wrap-back-buttons)
-
-(defdisplay object (:in-layer
- wrap-back-buttons
- :combination :around)
- (<ucw:a :class "wiz-button previous" :action (ok component t)
- (<:as-html "Go Back"))
- (<:div :style "clear:both;"
- (call-next-method))
- (<ucw:a :class "wiz-button previous" :action (ok component t)
- (<:as-html "Go Back")))
-
-;;;; Wrap an object display in with a link to the object
-
-(deflayer wrap-link)
-
-(defdisplay object (:in-layer
- wrap-link
- :combination :around)
- (let ((layers (find-display-layers object)))
- (<ucw:a :action (call-display self object
- :type (find-display-type object)
- :layers layers)
-
- (call-next-method))))
\ No newline at end of file
+(in-package :lisp-on-lines)
+
+;;;;; Wrap a display in "back buttons"
+(deflayer wrap-back-buttons)
+
+(defdisplay
+ :in-layer wrap-back-buttons :around
+ (description object)
+
+ (<ucw:a :class "wiz-button previous" :action (ok component t)
+ (<:as-html "Go Back"))
+ (<:div :style "clear:both;"
+ (call-next-method))
+ (<ucw:a :class "wiz-button previous" :action (ok component t)
+ (<:as-html "Go Back")))
+
+;;;; Wrap an object display in with a link to the object
+
+(deflayer wrap-link)
+
+(defvar *link-wrapped-p* nil)
+
+(define-layered-class description
+ :in-layer wrap-link ()
+ ((link :initarg :link :initform nil :special t :accessor link)))
+
+(defdisplay
+ :in-layer wrap-link :around (description object)
+ (let ((link (link description)))
+
+ (with-inactive-layers (wrap-link)
+ (if *link-wrapped-p*
+ (call-next-method)
+ (let ((*link-wrapped-p* t))
+ (<ucw:a :action (call-display self object link)
+ (call-next-method)))))))
+
+
+
+;;; wrap-a-form
+(deflayer wrap-form)
+
+(defdisplay ((description t) (button (eql 'standard-form-buttons)))
+ (<ucw:submit :action (ok self)
+ :value "Ok."))
+
+(defdisplay :in-layer wrap-form :around (object description)
+ (<ucw:form
+ :action (refresh-component self)
+ (with-inactive-layers (wrap-form)
+
+ (call-next-method)
+ ;(display* 'standard-form-buttons)
+ )))
\ No newline at end of file
(in-package :lisp-on-lines)
;;;; LoL CLOS Test Class
-(defclass/meta test-class ()
- ((test-string :initform "test string" :type string))
+(defclass lol-test-class ()
+ ((test-string :initform "test string"))
(:documentation "foo"))
-(define-attributes (test-class)
- (test-string t :label "String :" :editablep t))
+(set-default-attributes 'lol-test-class)
+
+(define-attributes (lol-test-class)
+ (test-string t :label "String :"))
(defcomponent test-component ()
((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
HCoop / clinton / lisp-on-lines.git / commitdiff