:components
((:module :ucw
:components ((:file "packages")
- (:file "lol-tags")
+
(:file "standard-components")
(:file "contextl-components")
(:file "html-description")
(defun display (display object &rest args &key deactivate activate &allow-other-keys)
+
(funcall-with-layer-context
(modify-layer-context (current-layer-context)
:activate activate
(define-layered-method display-using-description
:around (description display object &rest args)
(declare (ignorable args))
+#+nil (break "Entering DISPLAY for ~A on ~A using ~A" object display description)
(let ((*display* display))
(apply #'funcall-with-described-object
(lambda ()
(define-layered-method display-attribute-value
((attribute list-attribute))
- (arnesi:dolist* (item (attribute-value attribute))
- (apply #'display *display* item (slot-value attribute 'item-args))))
+ (generic-format *display* "(")
+ (let ((list (attribute-value attribute)))
+
+ (loop
+ :for cons :on list
+ :do (let ((item (first cons
+)))
+ (break "Display T ~A" item)
+ (dletf (((attribute-object attribute) item))
+ (apply #'display *display* item (slot-value attribute 'item-args))
+ (unless (endp (cdr cons))
+ (generic-format *display* " "))))))
+ (generic-format *display* ")"))
+
+
+
+
+
(define-description list ()
((list :attribute-class list-attribute
:activate (attribute-active-descriptions attribute)
:deactivate (attribute-inactive-descriptions attribute)
args)))
-
+
+
(let ((val (attribute-value attribute)))
+#+nil (break "display Attribute value: ~A with object ~A ~% Description ~A att-d ~A ~% VALUE ~A display on ~A"
+ attribute
+ (attribute-object attribute)
+ *description*
+ (attribute-description attribute)
+ val
+ *display*
+ )
(if (and (not (slot-boundp attribute 'active-attributes))
- (eql val (attribute-object attribute)))
- (generic-format *display* (funcall (attribute-value-formatter attribute) val))
+ (equal val (attribute-object attribute)))
+ (progn (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val))
+ #+nil(break "using generic format because val is object and there is no active attributes."))
+
(with-active-descriptions (inline)
(cond ((slot-value attribute 'value-formatter)
- (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
+ (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val)))
((slot-boundp attribute 'active-attributes)
(disp val :attributes (slot-value attribute 'active-attributes)))
(t
(define-layered-method display-attribute :before
((attribute standard-attribute))
-)
+#+nil (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
+ attribute
+ (attribute-object attribute)
+ *description*
+ (attribute-description attribute)
+))
(define-display ((description t))
(let ((attributes (attributes description)))
(setf (gethash name *validators*) fn))
(defun find-validator (name)
- (gethash name *validators*))
+ (gethash name *validators*))
(register-validator 'boundp
(lambda (a v)
:object (attribute-object a))))
t)))
-(defun validp (object)
+
+(defun validp (object)
(with-described-object (object nil)
(every #'identity (mapcar (lambda (attribute)
- (validate-attribute-value attribute (attribute-value attribute)))
- (attributes (description-of object))))))
+ (validate-attribute-value attribute (attribute-value attribute)))
+ (attributes (description-of object))))))
(define-layered-method lol::display-attribute-editor
:in-layer #.(defining-description 'validate)
:after (attribute)
- (let ((conditions (remove-if-not (lambda (a)
- (eq a attribute))
- (gethash
- (attribute-object attribute)
- lol::*invalid-objects*)
- :key #'car)))
+ (let ((conditions (remove-if-not
+ (lambda (a)
+ (eq a attribute))
+ (gethash
+ (attribute-object attribute)
+ lol::*invalid-objects*)
+ :key #'car)))
(dolist (c conditions)
(<:div :style "color:red"
(<:as-html
(defvar *escape-html* t)
-(defmethod generic-format ((display lol-ucw:component) string &rest args)
+(defmethod generic-format ((display ucw-core:component) string &rest args)
(<:as-html (with-output-to-string (stream)
(apply #'call-next-method stream string args))))
-
(define-description html-description ()
())
val)))
(defmethod display-html-attribute-editor (attribute editor)
- (<lol:input :type "text"
+ (<ucw:input :type "text"
:reader (html-attribute-value attribute)
:writer (make-attribute-value-writer attribute)))
(call-next-method))
(defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
- (<lol:input :type "password"
+ (<ucw:input :type "password"
:reader (html-attribute-value attribute)
:writer (make-attribute-value-writer attribute)))
(define-display
:in-description html-description ((description t)
- (display lol-ucw:component)
+ (display ucw-core:component)
object)
(display-html-description description display object (lambda ()
(call-next-method))))
(when (listp val)
(<:ul
(arnesi:dolist* (item (attribute-value attribute))
- (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))))
\ No newline at end of file
+
+ (dletf (((attribute-object attribute) item))
+ (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))
\ No newline at end of file
(in-package :lol-ucw)
-(defcomponent lol-component ()
- ())
+(defclass lol-component ()
+ ()
+ (:metaclass standard-component-class))
(defmethod output-component ((self lol-component))
self)
-
-(defpackage lisp-on-lines-ucw
- (:documentation "An LoL Layer over ucw.basic")
- (:nicknames #:lol-ucw)
- (:use #:lisp-on-lines #:ucw-core :common-lisp :arnesi :yaclml :js :contextl)
-
- (:shadowing-import-from :js
- #:new)
- (:shadowing-import-from :ucw-core
- #:parent )
- (:import-from :ucw-standard
- #:call #:answer #:defaction #:*source-component*)
-
-
-
- (:export
-
- ;;; First, LOL-UCW exports. The rest are from UCW.
- #:lol-component
- #:*source-component*
- #:defcomponent
-
- #:uri.query
-
- ;; Standard Server
- #:standard-server
- #:startup-server
- #:shutdown-server
-
-
- ;; Sessions
- #:get-session-value
- ;; Standard Application
- #:standard-application
- #:register-application
- #:service
-
- ;; Standard Request Context
- #:*context*
- #:context.current-frame
- #:context.window-component
- #:*current-component*
-
- ;; Actions
- #:call
- #:answer
- #:make-action
- #:find-action
- #:defaction
- #:defmethod/cc
-
- #:call-component
- #:answer-component
-
- ;; Entry Points
- #:defentry-point
-
- ;; Standard Components
- #:render
- #:render-html-body
- #:component
-
- #:standard-component-class
- #:described-component-class
-
- #:container
- #:find-component
-
- #:standard-window-component ;*
- #:window-body
- #:info-message
-
- ))
-
-(defpackage :lisp-on-lines-tags
- (:documentation "LoL convience yaclml tags.")
- (:use)
- (:nicknames #:<lol)
- (:export
- #:component-body
- #:render-component
- #:a
- #:area
- #:form
- #:input
- #:button
- #:simple-select
- #:select
- #:option
- #:textarea
-
- #:integer-range-select
- #:month-day-select
- #:month-select
-
- #:text
- #:password
- #:submit
- #:simple-form
- #:simple-submit
-
- #:localized
- #:script))
\ No newline at end of file
+
+(defpackage lisp-on-lines-ucw
+ (:documentation "An LoL Layer over ucw.basic")
+ (:nicknames #:lol-ucw)
+ (:use #:lisp-on-lines #:ucw :ucw-core :common-lisp :arnesi)
+
+ (:shadowing-import-from :js
+ #:new)
+ (:shadowing-import-from :ucw-core
+ #:parent )
+ (:import-from :ucw-standard
+ #:call #:answer #:defaction #:*source-component*)
+
+
+
+ (:export
+
+ ;;; First, LOL-UCW exports. The rest are from UCW.
+ #:lol-component
+
+ #:described-component-class))
+
(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
-
(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
(let ((next-method (lambda ()
(layered-call-action
(call-next-method))))))
(let ((layer-context (action-layer-context action)))
(if layer-context
- (funcall-with-layer-context layer-context next-method)
+ (contextl:funcall-with-layer-context layer-context next-method)
(funcall next-method)))
))
(call-next-method))))
-(define-layered-function layered-call-action (action application session frame next-method)
+(contextl:define-layered-function layered-call-action (action application session frame next-method)
(:method (action application session frame next-method)
(funcall next-method)))
-(defcomponent standard-window-component
- (ucw-standard::basic-window-component)
- ((body
- :initform nil
- :accessor window-body
- :component t
- :initarg :body)))
-
-(defmethod render-html-head ((window standard-window-component))
- (let* ((app (context.application *context*))
- (url-prefix (application.url-prefix app)))
- (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
- (awhen (window-component.title window)
- (<:title (if (functionp it)
- (funcall it window)
- (<:as-html it))))
- (awhen (window-component.icon window)
- (<:link :rel "icon"
- :type "image/x-icon"
- :href (concatenate 'string url-prefix it)))
- (dolist (stylesheet (effective-window-stylesheets window))
- (<:link :rel "stylesheet"
- :href stylesheet
- :type "text/css"))))
-
-(defmethod render-html-body ((window standard-window-component))
- (render (window-body window)))
-
-(defcomponent info-message ()
- ((message :accessor message :initarg :message)))
-
-(defmethod render ((m info-message))
- (<:div
- :class "info-mssage"
- (<:as-html (message m)))
- (<lol:a :action (answer-component m nil) "Ok"))
+;; (defcomponent standard-window-component
+;; (ucw-standard::basic-window-component)
+;; ((body
+;; :initform nil
+;; :accessor window-body
+;; :component t
+;; :initarg :body)))
+
+;; (defmethod render-html-head ((window standard-window-component))
+;; (let* ((app (context.application *context*))
+;; (url-prefix (application.url-prefix app)))
+;; (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
+;; (awhen (window-component.title window)
+;; (<:title (if (functionp it)
+;; (funcall it window)
+;; (<:as-html it))))
+;; (awhen (window-component.icon window)
+;; (<:link :rel "icon"
+;; :type "image/x-icon"
+;; :href (concatenate 'string url-prefix it)))
+;; (dolist (stylesheet (effective-window-stylesheets window))
+;; (<:link :rel "stylesheet"
+;; :href stylesheet
+;; :type "text/css"))))
+
+;; (defmethod render-html-body ((window standard-window-component))
+;; (render (window-body window)))
+
+;; (defcomponent info-message ()
+;; ((message :accessor message :initarg :message)))
+
+;; (defmethod render ((m info-message))
+;; (<:div
+;; :class "info-mssage"
+;; (<:as-html (message m)))
+;; (<ucw:a :action (answer-component m nil) "Ok"))
HCoop / clinton / lisp-on-lines.git / commitdiff