-(in-package :lisp-on-lines-ucw)
-
-(defclass lisp-on-lines-action (ucw-standard::standard-action)
- ((layer-context :accessor action-layer-context
- :initform nil
- :initarg :layer-context))
- (:metaclass closer-mop:funcallable-standard-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
- action application session frame
- (lambda ()
- (call-next-method))))))
- (let ((layer-context (action-layer-context action)))
- (if layer-context
- (funcall-with-layer-context layer-context next-method)
- (funcall next-method)))
- ))
-
-(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
- (let ((lol::*invalid-objects* (make-hash-table)))
- (handler-bind ((lol::validation-condition
- (lambda (c)
- (let ((object (lol::validation-condition-object c))
- (attribute (lol::validation-condition-attribute c)))
-
-
- (setf (gethash object lol::*invalid-objects*)
- (cons (cons attribute c)
- (gethash object lol::*invalid-objects*)))))))
- (call-next-method))))
-
-
-(define-layered-function layered-call-action (action application session frame next-method)
- (:method (action application session frame next-method)
- (funcall next-method)))
-
-
-(contextl:define-layered-method layered-call-action
- :in-layer #.(lol::defining-description 'lol::validate)
- :around ((action lisp-on-lines-action) application session frame next-method)
- (call-next-method)
-
- )
-
-
-
-(defclass described-component-class (described-class standard-component-class )
- ())
-
-
-
-(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"))
-
-
+(in-package :lisp-on-lines-ucw)
+
+(defclass lisp-on-lines-application (contextl-application)
+ ()
+ (:default-initargs :action-class 'lisp-on-lines-action))
+
+(defclass lisp-on-lines-action (contextl-action)
+ ()
+ (:metaclass closer-mop:funcallable-standard-class))
+
+(defclass lisp-on-lines-component (contextl-component)
+ ()
+ (:metaclass standard-component-class))
+
+(defclass lisp-on-lines-component-class (standard-component-class)
+ ())
+
+
+(defmethod initialize-instance :around ((class lisp-on-lines-component-class)
+ &rest initargs &key (direct-superclasses '()))
+ (declare (dynamic-extent initargs))
+ (if (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component)))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (find-class 'lisp-on-lines-component)))
+ initargs)))
+
+
+(defmethod reinitialize-instance :around ((class lisp-on-lines-component-class)
+ &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs))
+ (if (or (not direct-superclasses-p)
+ (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (find-class 'lisp-on-lines-component)))
+ initargs)))
+
+(defclass described-component-class (described-class standard-component-class )
+ ())
+
+
+
+
+(defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
+ (let ((lol::*invalid-objects* (make-hash-table)))
+ (handler-bind ((lol::validation-condition
+ (lambda (c)
+ (let ((object (lol::validation-condition-object c))
+ (attribute (lol::validation-condition-attribute c)))
+
+
+ (setf (gethash object lol::*invalid-objects*)
+ (cons (cons attribute c)
+ (gethash object lol::*invalid-objects*)))))))
+ (call-next-method))))
+
+
+
+
+
+
+
+
+(defclass described-component-class (described-class standard-component-class )
+ ())
+
+
+
+;; (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 / blobdiff