(defsystem :lisp-on-lines
:components ((:static-file "lisp-on-lines.asd")
(:file "src/packages")
+ (:module :patches
+ :components ((:file "yaclml")))
(:module :src
:components ((:file "special-initargs")
(:file "properties")
(:file "standard-wrappers")
(:file "relational-attributes")
+ (:file "lines")
+
(:file "backwards-compat"))
:serial t)
(:module :attributes
--- /dev/null
+(in-package :yaclml)
+
+(defun funcall-with-tag (tag-spec thunk)
+ (let ((%yaclml-code% nil)
+ (%yaclml-indentation-depth% 0))
+ (declare (special %yaclml-code%))
+ ;; build tag's body
+ (dolist (i (fold-strings
+ (nreverse
+ (funcall (gethash (car (ensure-list tag-spec)) *expanders*)
+ (append (cdr tag-spec) (list
+ thunk))))))
+ (if (functionp i)
+ (funcall i)
+ (write-string i *yaclml-stream*)))))
\ No newline at end of file
(:type-name number))
;;;; INTEGER
-(defattribute integer-attribute (base-attribute)
+(defattribute integer-attribute (number-attribute)
()
(:type-name integer))
+
+(define-layered-method (setf attribute-value) ((value string) object (attribute integer-attribute))
+ (let ((*read-eval* nil))
+ (unless (string= "" value)
+ (let ((value (read-from-string value)))
+ (when (numberp value)
+ (setf (attribute-value object attribute) value))))))
+
;;;; REALS
-(defattribute real-attribute (base-attribute)
+(defattribute real-attribute (number-attribute)
()
(:type-name real))
+(define-layered-method (setf attribute-value) ((value string) object (attribute real-attribute))
+ (let ((*read-eval* nil))
+ (unless (string= "" value)
+ (let ((value (read-from-string value)))
+ (when (numberp value)
+ (setf (attribute-value object attribute) value))))))
+
;;;; Currency
-(defattribute currency-attribute (base-attribute)
+(defattribute currency-attribute (real-attribute)
()
(:type-name currency))
(defdisplay
((currency currency-attribute) object)
- (<:as-html (format nil "$~$" (attribute-value object currency))))
+ (<:as-html "$")
+ (call-next-method))
+
+(defdisplay :in-layer editor
+ ((currency currency-attribute) object)
+ (<:as-html "$")
+ (<:input
+ :type "text"
+ :id (id currency)
+ :name (callback currency)
+ :value (format nil "~$" (or (attribute-value object currency) ""))))
(in-package :lisp-on-lines)
(define-layered-function display-using-description (description object component)
+; (:argument-precedence-order )
(:documentation
"Render the object in component,
using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
(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
(funcall-with-layers
(description.layers description)
#'(lambda ()
- (funcall-with-special-initargs
- description properties
+ (contextl::funcall-with-special-initargs
+ (list (cons description properties))
#'(lambda ()
(apply function args))))))
(apply function args)))
(deflayer dojo)
(define-layered-class
- attribute :in-layer dojo ()
+ description :in-layer dojo ()
((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
-
-(defgeneric display-as-dojo-type (type attribute object component))
+(define-layered-function display-as-dojo-type (type description 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)))
+ :in-layer dojo :after (description object)
+ (when (dojo-type description)
+ (display-as-dojo-type (dojo-type description) description object self)))
-(defcomponent dojo-test (window-component)
- (
- (results :accessor results :initarg :results)))
+(defcomponent combo-results ()
+ ())
-(defmethod render ((self dojo-test))
+(defmethod render ((self combo-results))
(<: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))))))
+ (display self r :type 'as-string)))
+ ,n))))))
-(defmethod display-as-dojo-type ((type (eql 'combo-box)) attribute object component)
+(define-layered-method 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))))))
+ (select-callback (ucw::make-new-callback
+ (lambda (x)
+ (funcall select-function
+ (parse-integer x))))))
"The combo box widget"
(<ucw:script
`(dojo.require "dojo.*")
component
(call-component
(context.window-component *context*)
- (make-instance 'dojo-test
+ (make-instance 'combo-results
:results
(funcall search-function
(attribute-value object attribute)))))
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defmacro defline (name (specializer &rest layers-and-combination-keywords) &body docstring-and-body)
+ `(progn
+ ,(eval-when
+ (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp (contextl::get-layered-function-definer-name name))
+ `(define-layered-function ,name (arg)
+ (:method-combination append))))
+ (define-layered-method
+ ,name
+ ,@layers-and-combination-keywords
+ ,@(unless
+ (or (third layers-and-combination-keywords)
+ (and layers-and-combination-keywords
+ (null (cdr layers-and-combination-keywords))))
+ '(APPEND))
+ (,specializer)
+ ,(when (cdr docstring-and-body)
+ (car docstring-and-body))
+
+ ,(or (cdr docstring-and-body) (car docstring-and-body)))))
+
+
+(defun line-out (component object &key (line #'line-in) args)
+ (apply #'display component object (append args (funcall line object))))
+
+(defmacro call-line (from line &rest args)
+ (with-unique-names (lines object)
+ `(multiple-value-bind (,lines ,object)
+ (funcall ,line)
+ (call-display-with-context ,from ,object nil (append ,args ,lines)))))
+
(defmethod find-attribute-class-for-type ((type (eql ',type)))
',name))))
-
-
(define-layered-class
display-attribute (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-function (setf attribute-value) (value instance attribute))
(define-layered-method
(setf attribute-value) (value instance (attribute standard-attribute))
-
(with-slots (setter slot-name) attribute
(cond ((and (slot-boundp attribute 'setter) setter)
(error "Cannot set ~A in ~A" attribute instance)))))
+
;;;; ** Default Attributes
:time-difference
:make-time
:time-ymd
+ :date-ymd
:date
:get-time
:time-element
;;;; ** has-a
+;;;; Used for foreign keys, currently only works with clsql.
(defattribute has-a ()
()
(:default-properties
- :has-a nil))
+ :has-a nil
+ :test 'meta-model::generic-equal))
+;;
(define-layered-method attribute-value (object (attribute has-a))
(meta-model:explode-foreign-key object (slot-name attribute) :nilp 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)))))
+ (setf (attribute-value object attribute) val)))
+
+
+
+(define-layered-function find-all-foreign-objects (o a))
+
+(define-layered-method find-all-foreign-objects (object (attribute has-a))
+ (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
(defdisplay ((attribute has-a) object)
(let ((args (plist-union (description.properties attribute) (has-a attribute)))
args)))
+(defdisplay
+ :in-layer editor ((attribute has-a) object)
+ (<ucw:select
+ :accessor (attribute-value object attribute)
+
+ :test (test attribute)
+ (dolist* (obj (find-all-foreign-objects object attribute))
+ (<ucw:option
+ :value obj
+ (display* obj :type 'as-string)))))
+
+
;;;; ** Has-Many attribute
(defattribute has-many ()
(:default-initargs
:type 'lol::one-line))
-
(define-layered-method
attribute-value (object (has-many has-many))
- (slot-value object (slot-name has-many)))
+ (slot-value object (slot-name has-many)))
(defdisplay ((attribute has-many) object)
;
(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)
real value is +uninitialized+, since +uninitialized+ is a ucw
internal symbol this shouldn't be a problem.")
-(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."))
(defgeneric read-client-value (element)
(:method ((element form-element))
(defdisplay ((base base-attribute) object)
(<:as-html (attribute-value object base)))
-;;;; Strings
-(defattribute string-attribute (base-attribute)
+(defattribute base-attribute ()
()
+ (:in-layer editor)
+ (:default-properties
+ :callback nil))
+
+(defdisplay
+ :in-layer editor :around ((string base-attribute) object)
+ (dletf (((callback string) (ucw::make-new-callback
+ #'(lambda (val)
+ (setf (attribute-value object string) val)))))
+ (call-next-method)))
+;;;; Strings
+
+(defattribute string-attribute ()
+ ()
(:type-name string)
(:default-properties
:escape-html-p t
:size nil
:max-length nil))
+(defdisplay
+ :in-layer editor ((string base-attribute) object)
+ (<:input
+ :type "text"
+ :id (id string)
+ :name (callback string)
+ :value (or (attribute-value object string) "")))
+
+
(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)
+(defdisplay :in-layer viewer
+ ((string string-attribute) object)
(if (escape-html-p string)
(<:as-html (attribute-value object string))
(<:as-is (attribute-value object string))))
(: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
(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)))))
+ (<: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))
+ ()
+ (:type-name text))
(defdisplay :in-layer editor ((string text-attribute) object)
(<:textarea
:id (id string)
:name (callback string)
- (or (attribute-value object string) "")))
+ (or (attribute-value object string) "")))
(defattribute image ()
- ())
+ ()
+ (:default-properties
+ :css-class "lol-image"
+ :prefix "images/"))
(defdisplay ((buttons (eql 'image-editor-buttons)) object)
(<ucw:a :action (ok component object)
(defdisplay ((image image) object)
(<:img
- :class (or (.get :css-class) "lol-image")
+ :class (or (css-class image) "lol-image")
:src (arnesi:strcat
- (or (.get :prefix) "images/")
+ (or (prefix image) "images/")
(escape-as-uri
(attribute-value object image)))))
(<: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;"))))
+ (<:as-html "imagie")))
;;;; The Standard Layers
(deflayer viewer)
(deflayer editor)
+
+(defdisplay
+ :in-layer editor :around (description object)
+ "It is useful to remove the viewer layer when in the editing layer.
+This allows us to dispatch to a subclasses editor."
+ (with-inactive-layers (viewer)
+ (call-next-method)))
+
(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 " ")))
+ (with-inactive-layers (editor viewer creator one-line as-table label-attributes)
+ (do-attributes (a d)
+ (display-attribute a o)
+ (<:as-is " "))))
(defmethod list-slots (thing)
(list 'identity))
;;;; * 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 object)
(<:div
- :class "lol-display"
+ :class "lol-display"
+ (when (label description)
+ (<:span
+ :class "title"
+ (<:as-html (label description))))
(do-attributes (attribute description)
(<:div
- :class "lol-attribute-row"
+ :class "attribute"
(display-attribute attribute object)))))
;;;; ** One line
;;;;; Wrap a display in "back buttons"
(deflayer wrap-back-buttons)
+(defvar *back-buttons-wrapped-p* nil)
+
(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")))
+ :in-layer wrap-back-buttons :around
+ (description object)
+ (if *back-buttons-wrapped-p*
+ (call-next-method)
+ (let ((*back-buttons-wrapped-p* t))
+
+ (<ucw:a :class "wiz-button previous" :action (ok self t)
+ (<:as-html "Go Back"))
+ (<:div :style "clear:both;"
+ (call-next-method))
+ (<ucw:a :class "wiz-button previous" :action (ok self t)
+ (<:as-html "Go Back")))))
;;;; Wrap an object display in with a link to the object
(call-next-method)
;(display* 'standard-form-buttons)
- )))
\ No newline at end of file
+ )))
+
+;;;; wrap a DIV
+
+
+(deflayer wrap-div)
+
+(define-layered-class description
+ :in-layer wrap-div ()
+ ((div-attributes :accessor div-attributes :initarg :div :special t :initform nil)))
+
+(defdisplay :in-layer wrap-div :around (description object)
+ (let ((args (div-attributes description)))
+ (with-inactive-layers (wrap-div)
+ (yaclml::funcall-with-tag
+ (cons '<:div args)
+ (lambda ()
+ (call-next-method))))))
+
+
\ No newline at end of file
(in-package :lisp-on-lines)
-;;;; LoL CLOS Test Class
+;;;; LoL CLOS Tests
+;;;;
(defclass lol-test-class ()
- ((test-string :initform "test string"))
+ ((test-slot-value :initform "slot-value")
+ (test-string :initform "Test String"))
(:documentation "foo"))
-(set-default-attributes 'lol-test-class)
+(defvar *foo* nil)
+
+(defvar *standard-layers* '(viewer editor creator one-line as-string))
(define-attributes (lol-test-class)
- (test-string t :label "String :"))
+ (test-getter t
+ :label "Getter"
+ :getter (constantly "Hello World"))
+ (test-getter/setter t
+ :label "Getter/Setter:"
+ :getter (lambda ()
+ *foo*)
+ :setter #'(lambda (value)
+ (setf *foo* value)))
+ (test-slot-value t)
+ (test-string string :label "String" :documentation))
(defcomponent test-component ()
- ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
- (current-type :accessor current-type :initform 'viewer)
+ (current-layer :accessor current-type :initform 'viewer)
+ (layer-spec :accessor layer-spec :initform nil)
(instance :accessor instance :initform (make-instance 'test-class))))
(defmethod render ((self test-component))
(with-component (self)
(<ucw:form
:action (refresh-component self)
- (<ucw:select :accessor (current-type self)
+ (<ucw:select :accessor (current-layer self)
(dolist* (type (display-types self))
(<ucw:option :value type (<:as-html type))))
(<:input :type "Submit" :value "update")
(<:fieldset
(<:legend (<:as-html (current-type self)))
- (display test :type (current-type self)))))
-
- (<:div
- (<:h2
- (<:as-html "UCW Presentation based displays (the old school"))
- (dolist (type '(:viewer :editor :creator :one-line :as-string))
- (<:h3 (<:as-html type))
- (present-view (test type self))
- (<ucw:a :action (call-view (test type self))
- (<:as-html "Call to " type))))))
+ (display test :type (current-type self)))))))
(defcomponent standard-display-component ()
(not (< 0 (length value))))
(signal 'attribute-validation-condition
:message (format nil "You must enter a value for ~A."
- (getf (attribute.plist attribute) :label))
+ (getf (description.properties attribute) :label))
:attribute attribute))))
\ No newline at end of file
(defmethod find-validation-functions (instance (attribute standard-attribute))
- (getf (attribute.plist attribute) :validate-using))
+ (getf (description.properties attribute) :validate-using))
;;;; ** Instances
(not (< 0 (length value))))
(signal 'attribute-validation-condition
:message (format nil "You must enter a value for ~A."
- (getf (attribute.plist attribute) :label))
+ (getf (description.properties attribute) :label))
:attribute attribute))))
(signal 'attribute-validation-condition
:message (format nil "~A must be true."
- (getf (attribute.plist attribute) :label))
+ (getf (description.properties attribute) :label))
:attribute attribute))))
(when (not (and (equal start 0) (equal end (length value))))
(signal 'attribute-validation-condition
:message (format nil "~A must be a valid email address."
- (getf (attribute.plist attribute) :label))
+ (getf (description.properties attribute) :label))
:attribute attribute)))))
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / commitdiff