+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defmethod/cc read-instance ((self component) instance)
- "View an existing instance"
- (call 'crud-viewer :instance instance))
-
-(defmethod/cc update-instance ((self component) instance)
- "Edit an instance, possibly a newly created one"
- (call 'crud-editor :instance instance))
-
-(defmethod/cc create-instance ((self component) class &rest initargs)
- "Create a new instance and edit it."
- (update-instance self (apply #'make-instance class initargs)))
-
-(defun %delete-instance-and-return-nil (instance)
- "returns nil on success"
- (handler-case (clsql:delete-instance-records instance)
- (error (x)
- (return-from %delete-instance-and-return-nil x)))
- nil)
-
-(defun display-as-string (instance)
- (with-output-to-string (s)
- (yaclml:with-yaclml-stream s
- (display (make-instance 'component) instance
- :layers '(+ as-string)))))
-
-(defmethod/cc delete-instance ((self component) instance)
- (when (call 'option-dialog
- :message (format nil "Really Delete ~A" (display-as-string instance))
- :options '((t "Yes, really delete it,")
- (nil "No, i'll hold on to this one.")))
- (let ((delete-failed (%delete-instance-and-return-nil instance)))
- (if (not delete-failed)
- (answer t)
- (progn
- (call 'info-message :message delete-failed)
- (answer t))))))
-
-
-(defmethod breadcrumb-name (component)
- (string-downcase (string (class-name (class-of component)))))
-
-(defun render-breadcrumb (self)
- (<:p :class "breadcrumb"
- (let ((count 0)
- (trail-length 3))
- (labels ((find-call-stack-for-crumbs (component list-of-parents)
- (cond ((and (not (null component))
- (> trail-length count))
- (incf count)
- (find-call-stack-for-crumbs
- (when (slot-boundp component 'ucw::calling-component)
- (slot-value component 'ucw::calling-component))
- (cons component list-of-parents)))
- (t
- list-of-parents))))
- (loop
- :for c
- :on (find-call-stack-for-crumbs self nil)
- :do (let ((c c))
- (<:as-html " / ")
- (if (cdr c)
- (<ucw:a
- :action (answer-component (second c) nil)
- (<:as-html (breadcrumb-name (first c))))
- (<:as-html (breadcrumb-name (first c))))))))))
-
-(defcomponent crud ()
- ((instance :accessor instance :initarg :instance :initform nil))
- (:documentation "The base class for all standard crud components"))
-
-(defmethod render ((self crud))
- "Just to show off more of LOL, we'll use its display mechanism for UCW components.
-
-DISPLAY takes two required arguments,
-COMPONENT : The component to display FROM (not neccesarily 'in')
-OBJECT : The 'thing' we want to display... in this case it's the component,
-
-DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time.
-
-By default, the display method iterates through the ATTRIBUTES
-of the DESCRIPTION of the OBJECT. This will hopfully become clear.
-
-In this case, we are displaying the component from itself.
-"
-
- (display self self))
-
-(defun class-name-of (instance)
- (class-name (class-of instance)))
-
-;;;; We'll use this in a string attribute to display the title.
-(defgeneric find-title (crud)
- (:method (crud)
- (if (instance crud)
- (format nil "An instance of ~A" (class-name-of (instance crud)))
- "Welcome to Crud 1.0")))
-
-;;;; ** We define an attribute for the menu
-;;;; DEFATTRIBUTE is like defclass for attributes.
-(defattribute crud-menu ()
- ()
- (:default-properties
- :show-back-p t)
- (:documentation
- "A Custom menu attribute"))
-
-(defdisplay :wrapping ((menu crud-menu) object (component component))
- "Set up the menu with an optional back button
-
-In a DEFDISPLAY form, the variable SELF is bound to the component we are displaying.
-This allows it to work with UCW's CALL and ANSWER, and saves some typing as well.
-One can also provide a name (or a specializer) for the component as the third parameter
-in the defdisplay argument list, (as i did above) but this is optional.
-
-DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION,
-which does the real work. Macroexpand if you're interested."
- (<:ul
- (when (show-back-p menu)
- (<:li (<ucw:a :action (answer nil)
- (<:as-html "Go Back"))))
- (call-next-method)))
-
-(defdisplay ((menu crud-menu) object)
- "Do nothing beyond the defalt for our standard menu
-
-note the omitted COMPONENT argument. sugar is all."
- t)
-
-;;;; create a new layer for some customisations.
-(deflayer crud)
-
-;;;; we don't really _have_ to do this in our own layer,
-;;;; but it does give us the ability to turn the behaviour off.
-(defdisplay :in-layer crud
- :wrap-around ((attribute standard-attribute) (object crud))
- "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))))
- (call-next-method)))
-
-;;;; A description contains attributes.
-;;;; ATTRIBUTES are the various pieces that come together to make a display
-;;;; In this case, we define parts of the 'page'.
-
-(defdescription crud ()
- (;; use a generic function for the title attribute
- (title
- ;; attributes have types.
- ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list.
- :type 'string
- ;; almost all attributes have a getter and/or setter function
- ;; which is passed the object being displayed.
- ;; You can also use :SLOT-NAME
- ;; see ATTRIBUTE-VALUE for details.
- :getter #'find-title)
-
- ;; our breadcrumb function renders itself,
- ;; and does not return a value.
- (breadcrumb
- ;; the FUNCTION type calls a function
- ;; again, passing the object.
- :type 'function
- :function #'render-breadcrumb
- ;; We need to specify IDENTITY here,
- ;; as the default :GETTER calls
- ;; SLOT-VALUE on the name of the attribute.
- :getter #'identity)
- ;; So we don't need a getter in INSTANCE.
- (instance
- ;; the DISPLAY type calls DISPLAY
- ;; passing the component and the object
- ;; along with any arguments specified using the
- ;; :DISPLAY property
- :type 'display
- :display '(:layers (+ show-attribute-labels)))
- ;; this is our menu, a custom attribute
- (menu
- :type 'crud-menu))
- (;; now we create a LINE in the default layer.
- ;; LINES describe how an object is displayed
- ;; when that layer is active.
- :in-layer
- t
- :attributes '(breadcrumb title menu instance)
- :layers '(- show-attribute-labels + crud)))
-
-
-;;;; That's the basic outline of our app, now we fill in the blanks.
-
-;;;; ** Viewer
-(defcomponent crud-viewer (crud)
- ()
- (:documentation "A component for viewing objects"))
-
-(defdisplay ((menu crud-menu) (crud crud-viewer))
- "Allow the user to edit and delete the object"
- (<:li (<ucw:a :action (delete-instance crud (instance crud))
- (<:as-html "DELETE this object.")))
- (<:li (<ucw:a :action (update-instance crud (instance crud))
- (<:as-html "EDIT this object."))))
-
-;;;; ** Editor
-;;;; (use the same component for creating and editing,
-;;;; with a little magic to make it all work.
-(defcomponent crud-editor (crud validation-mixin)
- ())
-
-(defmethod/cc ensure-instance ((self crud-editor))
- "This one does a little magic, see SYNC-INSTANCE"
- (meta-model::sync-instance (instance self)))
-
-(defmethod find-title ((crud crud-editor))
- (<:as-html "Editing a "
- (class-name (class-of (instance crud)))
- " ")
- (unless (meta-model:persistentp (instance crud))
- (<:as-html "(new)")))
-
-(defattribute crud-editor-attribute (display-attribute)
- ()
- (:type-name crud-editor))
-
-(defdisplay :around ((ed crud-editor-attribute) object)
- (with-active-layers (editor show-attribute-labels wrap-form)
- (call-next-method)))
-
-
-(defdescription crud-editor ()
- ((instance :type 'crud-editor))
- (:in-layer
- t
- :default-attributes
- `((instance
- :display
- (:form-buttons
- ((:value ,(if (meta-model:persistentp (instance self))
- "Save"
- "Create")
- :action ,(action (self object)
- (ensure-instance self)
- (answer (instance self))))
- (:value
- "Cancel"
- :action
- ,(action (self object)
- (setf (instance self) nil)
- (answer nil)))))))))
-
-;;;; ** Summary
-(defcomponent crud-summary (crud)
- ((class :accessor db-class :initarg :class)
- (limit :accessor row-limit :initform 25)
- (offset :accessor row-offset :initform 0)))
-
-(defmethod find-title ((crud crud-summary))
- (format nil "Viewing Summary of ~A" (db-class crud)))
-
-(defun find-some (class limit offset)
- (clsql:select class :limit limit :offset offset :flatp t))
-
-(defmethod find-summary ((crud crud-summary))
- (find-some (db-class crud)
- (row-limit crud)
- (row-offset crud)))
-
-(defdescription crud-summary ()
- ()
- (:in-layer t
- ;;; here we show :default-attributes
- ;;; the attributes themselves can vary by layer
- ;;; the same syntax is supported in an :ATTRIBUTES form
- ;;; but that also specifies which attributes to display
- :default-attributes
- `((instance
- :getter ,#'find-summary
- :display
- (:layers (+ one-line)
- :list-item
- (:layers (+ lol::wrap-link + lol::show-attribute-labels)
- :link-action ,(action (self obj)
- (call 'crud-viewer :instance obj))))))))
-
-(defdisplay ((menu crud-menu) (object crud-summary))
- (<:li (<ucw:a
- :action (create-instance object (db-class object))
- (<:as-html "(Create New " (db-class object) ")"))))
-
-(defmethod/cc call-crud-summary ((self component) class)
- (call 'crud-summary :class class))
-
-
-(defcomponent crud-database (crud)
- ())
-
-(defdescription crud-database ()
- ((instructions
- :type 'string
- :getter (constantly "View Object Summary: "))
- (instance
- :type 'display
- :getter #'(lambda (obj)
- (declare (ignore obj))
- (meta-model::list-base-classes :clsql))
- :display `(:layers (+ one-line)
- :list-item
- (:layers (+ lol::wrap-link )
- :link-action ,(action (self class)
- (call-crud-summary self class))))))
- (:in-layer
- t
- :attributes '(title menu instructions instance)))
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / blobdiff