:components ((:static-file "lisp-on-lines.asd")
(:module :patches
:components ((:file "yaclml")
- (:file "ucw")))
+ (:file "ucw")
+ (:file "clsql")))
(:module :src
:components ((:file "packages")
(:file "special-initargs")
(:file "standard-validation")
(:file "email-address"))
:serial t)
- (:module :components
- :components ((:file "crud"))))
+ )
:serial t))
:serial t
:depends-on (:arnesi :ucw :meta-model :split-sequence :contextl :cl-ppcre :cl-fad))
(deflayer dojo)
-(define-layered-class
+#+nil(define-layered-class
description :in-layer dojo ()
((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
(in-package :lisp-on-lines)
+
+;TODO: get rid of this.
+(defun attribute.name (attribute)
+ (attribute-name attribute))
+
+
;;;; A few layers related to attributes
(deflayer omit-nil-attributes)
(when (attribute-value object attribute)
(call-next-method)))
+;;;; Labels
(deflayer show-attribute-labels)
+(defattribute attribute-label (attribute)
+ ()
+ (:default-properties
+ :attribute nil))
+
+(defdisplay
+ ((label attribute-label) object)
+ (<:label
+ :class "lol-label"
+ (<:as-html (or (label (attribute label))
+ (attribute-name (attribute label)) " ")
+ " ")))
+
+(defvar *attribute-label-attribute*
+ (make-instance 'attribute-label))
+
(defdisplay
:in-layer show-attribute-labels
:around ((attribute standard-attribute) object)
- (<:label
- :class "lol-label"
- (<:as-html (or (label attribute) (attribute.name attribute)) " "))
- (<:span
- :class "lol-attribute"
- (call-next-method)))
+ (display-attribute *attribute-label-attribute* object :attribute attribute)
+ (call-next-method))
(deflayer use-pretty-labels)
(defdisplay :in-layer inspect-attributes
:around ((attribute standard-attribute) object)
(call-next-method)
- (<ucw:a :action (ucw::call-inspector self attribute)
+ (<ucw:a :action-body (ucw::call-inspector self attribute)
:title
(strcat "Inspect "
- (attribute.name attribute) ":"
- (description.type attribute) ":"
+ (attribute-name attribute) ":"
+ (description-type attribute) ":"
(type-of attribute))
(<:as-html "(i)")))
:in-layer editor :around ((string base-attribute) object)
(dletf (((callback string)
(or (callback string)
- (ucw::make-new-callback
+ (ucw::register-callback
#'(lambda (val)
(setf (attribute-value object string) val)))))
((object string) object))
:max-length nil
:default-value ""))
+
+#|
+
(defdisplay :in-layer omit-nil-attributes
:around ((attribute string-attribute) object)
(when (< 0 (length (attribute-value object attribute)))
;;;; editor
-(defattribute string-attribute (base-attribute)
+#+nil (defattribute string-attribute (base-attribute)
()
(:in-layer editor)
(:default-properties
(<:div
:class "lol-image-thumbnails"
- (<:as-html "imagie")))
+ (<:as-html "imagie"))) |#
"Around every attribute of a CRUD instance, i'd like to wrap a div."
(<:div
:class (format nil "crud-~A" (string-downcase
- (string (attribute.name attribute))))
+ (string (attribute-name attribute))))
(call-next-method)))
;;;; A description contains attributes.
(let* ((description (find-occurence object)))
(if description
- (dletf (((description.type description) type)
+ (dletf (((description-type description) type)
((attributes description) (or
(attributes description)
- (list-slots object))))
+ (list-attributes description))))
;; apply the default line to the description
(funcall-with-description
description
"Displays OBJECT in COMPONENT."))
(define-layered-method display ((component t) (object t)
- &rest properties
- &key type (line #'line-in)
- &allow-other-keys)
+ &rest properties)
" The default display dispatch method
DISPLAY takes two required arguments,
that is to say the parameters that come together to create the output.
The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
-
- (let* ((description (find-occurence object)))
-
- (if description
- (dletf (((description.type description) type)
- ((attributes description) (or
- (attributes description)
- (list-slots object))))
- ;; apply the default line to the description
- (funcall-with-description
- description
- (funcall line object)
- ;; apply the passed in arguments and call display-using-description
- #'(lambda ()
- (funcall-with-description
- description
- properties
- #'display-using-description description object component))))
- (error "no description for ~A" object))))
+ (funcall (apply 'make-display-function component object properties)
+ 'display-using-description))
;;;;; Macros
(defun funcall-with-description (description properties function &rest args)
(if description
- (dletf* (((description.type description) (or
+ (dletf* (((description-type description) (or
(getf properties :type)
- (description.type description)))
+ (description-type description)))
- ((description.layers description) (append
- (description.layers description)
+ ((description-layers description) (append
+ (description-layers description)
(getf properties :layers)))
- ((description.properties description) (append (description.properties description) properties)))
+ ((description-properties description) (append (description-properties description) properties)))
(funcall-with-layers
- (description.layers description)
+ (description-layers description)
#'(lambda ()
(contextl::funcall-with-special-initargs
(list (cons description properties))
(declare (ignorable self))
(flet ((display* (thing &rest args)
(apply #'display ,component thing args))
- (display-attribute (attribute obj &optional props)
+ (display-attribute (attribute obj &rest
+ props)
(if props
(funcall-with-description
attribute props
component)
(t
(setf c component)
- `(,c component))))
+ `(,c t))))
(with-component (,c)
,@(cdr tail)))))))))
This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation"
`(progn
- (def-view-class-from-table ,table)
+ (rofl::gen-view-class ,table :generate-joins :all)
(set-default-attributes (quote ,(meta-model::sql->sym table))))))
(defmacro define-view-for-table (&rest tables)
(in-package :lisp-on-lines)
+(defun persistentp (object)
+ (slot-value object 'clsql-sys::view-database))
+
(define-layered-class description ()
((description-type
:initarg :type
- :accessor description.type
+ :accessor description-type
:initform 'viewer
:special t)
(description-layers
:initarg :layers
- :accessor description.layers
+ :accessor description-layers
:initform nil
:special t)
- (description-properties
- :accessor description.properties
- :initform nil
- :special t
- :documentation "TODO: not used much anymore, and shouldn't be relied on")
(described-object
:layered-accessor object
:initform nil
:initarg :attributes
:initform nil
:special t)
+ (description-properties
+ :accessor description-properties
+ :initarg :properties
+ :initform '()
+ :special t)
(description-default-properties
:accessor default-properties
:initarg :default-properties
(defmethod attributes :around ((description description))
"Add any default properties to the attributes"
- (let ((default-properties (default-properties description)))
- (if (and (listp default-properties)
+ (let ((default-properties (default-properties description))) (if (and (listp default-properties)
(not (null default-properties)))
(let ((a (mapcar #'(lambda (att)
(append (ensure-list att) default-properties))
(defun find-or-create-occurence (name)
"Returns the occurence associated with this name."
- (let ((occurence (gethash name *occurence-map*)))
- (if occurence
- occurence
- (let ((new-occurence (make-instance 'standard-occurence :name name)))
- (setf (gethash name *occurence-map*) new-occurence)
- new-occurence))))
+ (or (get-occurence name)
+ (values (setf (get-occurence name) (make-instance 'standard-occurence :name name))
+ t)))
+
+(defun get-occurence (name)
+ (gethash name *occurence-map*))
+
+(defun (setf get-occurence) (occurence name)
+ (setf (gethash name *occurence-map*) occurence))
(defun clear-occurence (occurence)
"removes all attributes from the occurence"
(setf (attribute-map occurence) (make-hash-table)))
+(defmethod make-attribute-using-slot-definition (slotd)
+ (make-attribute
+ :name (closer-mop:slot-definition-name slotd)
+ :type-spec (closer-mop:slot-definition-type slotd)
+ :type (first (remove-if (lambda (item)
+ (or
+ (eql item 'or)
+ (eql item 'null)
+ (eql item nil)))
+ (ensure-list (closer-mop:slot-definition-type slotd))))))
+
+(defmethod initialize-occurence-for-instance (occurence instance)
+ (let ((slots (closer-mop:class-slots (class-of instance))))
+ (dolist (s slots)
+ (let ((att (make-attribute-using-slot-definition s)))
+ (setf (find-attribute occurence (attribute-name att)) att)))
+ occurence))
+
(defgeneric find-occurence (name)
(:method (thing)
nil)
(:method ((name symbol))
(find-or-create-occurence name))
(:method ((instance standard-object))
- (find-or-create-occurence (class-name (class-of instance)))))
+ (multiple-value-bind (occ new?)
+ (find-or-create-occurence (class-name-of instance))
+ (if new?
+ (initialize-occurence-for-instance occ instance)
+ occ))))
+
+(defun list-attributes (occurence)
+ (let (res)
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (push k res))
+ (attribute-map occurence))
+ res))
(define-layered-class
attribute (description)
- ((attribute-name :layered-accessor attribute.name
+ ((attribute-name :layered-accessor attribute-name
:initarg :name
:initform (gensym "ATTRIBUTE-")
:special t)
((setter :accessor setter :initarg :setter :special t :initform nil)
(getter :accessor getter :initarg :getter :special t :initform nil)
(value :accessor value :initarg :value :special t)
- (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil))
+ (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil)
+ (typespec :accessor type-spec :initarg :type-spec :initform nil))
(:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
(define-layered-method label :around ((attribute standard-attribute))
- (or (call-next-method) (attribute.name attribute)))
+ (or (call-next-method) (attribute-name attribute)))
(defmacro defattribute (name supers slots &rest args)
(let* (
(find-attribute (occurence attribute-with-occurence) attribute-name))
(defmethod set-attribute-properties ((occurence-name t) attribute properties)
- (setf (description.properties attribute) (plist-nunion
+ (setf (description-properties attribute) (plist-nunion
properties
- (description.properties attribute)))
- (loop for (initarg value) on (description.properties attribute)
+ (description-properties attribute)))
+ (loop for (initarg value) on (description-properties attribute)
by #'cddr
with map = (initargs.slot-names attribute)
do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))
otherwise, (setf find-attribute)"
(let ((att (find-attribute occurence-name attribute-name)))
(if (and att inherit (or (eql (car attribute-spec)
- (description.type att))
+ (description-type att))
(eq (car attribute-spec) t)))
(set-attribute-properties occurence-name att (cdr attribute-spec))
(setf (find-attribute occurence-name attribute-name)
(cons (car attribute-spec)
(plist-nunion
(cdr attribute-spec)
- (when att (description.properties att))))))))
+ (when att (description-properties att))))))))
(defmethod perform-define-attributes ((occurence-name t) attributes)
(loop for attribute in attributes
;;"Unused???"
(defmethod setter (attribute)
(warn "Setting ~A in ~A" attribute *context*)
- (let ((setter (getf (description.properties attribute) :setter))
- (slot-name (getf (description.properties attribute) :slot-name)))
+ (let ((setter (getf (description-properties attribute) :setter))
+ (slot-name (getf (description-properties attribute) :slot-name)))
(cond (setter
setter)
(slot-name
slot-value-or-nil (slot-value
instance
(slot-name attribute))))))
- ((and (slot-exists-p instance (attribute.name attribute)))
+ ((and (slot-exists-p instance (attribute-name attribute)))
(setf existsp t)
- (when (slot-boundp instance (attribute.name attribute))
+ (when (slot-boundp instance (attribute-name attribute))
(setf boundp t
slot-value-or-nil (slot-value
instance
- (attribute.name attribute))))))
+ (attribute-name attribute))))))
(VALUES slot-value-or-nil existsp boundp)))
(define-layered-method attribute-value (instance (attribute standard-attribute))
(funcall setter value instance))
((and (slot-boundp attribute 'slot-name) slot-name)
(setf (slot-value instance slot-name) value))
- ((and (slot-exists-p instance (attribute.name attribute)))
- (setf (slot-value instance (attribute.name attribute)) value))
+ ((and (slot-exists-p instance (attribute-name attribute)))
+ (setf (slot-value instance (attribute-name attribute)) value))
(t
(error "Cannot set ~A in ~A" attribute instance)))))
(foreign-key has-a))
(defun attribute-to-definition (attribute)
- (nconc (list (attribute.name attribute)
- (description.type attribute))
- (description.properties attribute)))
+ (nconc (list (attribute-name attribute)
+ (description-type attribute))
+ (description-properties attribute)))
(defun find-default-presentation-attribute-definitions ()
nil)
(real-default (find-attribute 'default type)))
(cond
(possible-default
- (description.type possible-default))
+ (description-type possible-default))
(real-default
- (description.type real-default))
+ (description-type real-default))
(t type))))
(defun gen-presentation-slots (instance)
:clsql
:contextl)
(:nicknames :lol :mewa)
+
+ (:shadowing-import-from
+ :ucw
+ :parent)
(:shadowing-import-from
:iterate
(deflayer viewer)
(deflayer editor)
+;;;; Attributes
+(defdisplay
+ :in-layer editor
+ ((attribute standard-attribute) object)
+ (call-next-method))
+
+(defdisplay
+ ((attribute standard-attribute) object component)
+ (<:as-html (attribute-value object attribute)))
+
+(define-layered-method display-using-description
+ ((attribute standard-attribute) object component)
+ (with-component (component)
+ )
+ (<:as-html (attribute-value object attribute)))
+
(define-layered-method label (anything)
nil)
(deflayer as-table)
(deflayer as-string)
+(defdisplay
+ :in-layer as-string (d o (self t))
+ (with-output-to-string (yaclml::*yaclml-stream*)
+ (do-attributes (a d)
+ (display-attribute a o)
+ (<:as-html " "))
+ #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+)))
+
+
(defdisplay
:in-layer as-string (d o)
- (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+ (with-output-to-string (yaclml::*yaclml-stream*)
(do-attributes (a d)
(display-attribute a o)
- (<:as-is " "))))
+ (<:as-html " "))
+ #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
+)))
(defmethod list-slots (thing)
(list 'identity))
"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
;;;; List Displays
-(deflayer list-display-layer)
+#| (deflayer list-display-layer)
(define-layered-class description
:in-layer list-display-layer ()
(dolist* (obj list)
(<:tr
(do-attributes (a desc)
- (<:td (display-attribute a obj)))))))))))
+ (<:td (display-attribute a obj))))))))))) |#
-;;;; Attributes
-(defdisplay
- :in-layer editor
- ((attribute standard-attribute) object)
- (call-next-method))
-(define-layered-method display-using-description
- ((attribute standard-attribute) object component)
- (with-component (component)
- (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
- (<:as-html "*" )))
- (<:as-html (attribute-value object attribute)))
(defvar *link-wrapped-p* nil)
-(define-layered-class description
+#+nil(define-layered-class description
:in-layer wrap-link ()
((link :initarg :link-action
:initarg :action
(defvar *in-form-p* nil)
-(define-layered-class description
+#+nil(define-layered-class description
:in-layer wrap-form ()
((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)
(form-type :initarg :form-type :initform '<ucw:simple-form :special t :accessor form-type)))
(deflayer wrap-div)
-(define-layered-class description
+#+nil(define-layered-class description
:in-layer wrap-div ()
((div-attributes :accessor div-attributes :initarg :div :special t :initform nil)))
HCoop / clinton / lisp-on-lines.git / commitdiff