:serial t
:depends-on (:contextl :arnesi :alexandria :parse-number
;;for rofl:
- :simple-date :postmodern))
+ :cl-postgres :simple-date :postmodern))
(in-package :lisp-on-lines)
+(defvar *object* nil)
+(defvar *description*)
+
(define-layered-function description-of (thing)
(:method (thing)
(find-description 't)))
(defun description-attributes (description)
(description-class-attributes (class-of description)))
+(defun description-current-attributes (description)
+ (remove-if-not
+ (lambda (attribute)
+ (and
+ (some #'layer-active-p
+ (mapcar #'find-layer
+ (slot-definition-layers
+ (attribute-effective-attribute-definition attribute))))))
+ (description-attributes description)))
+
+(defun description-active-attributes (description)
+ (remove-if-not
+ #'attribute-active-p
+ (description-attributes description)))
+
(defun find-attribute (description attribute-name)
(find attribute-name (description-attributes description)
:key #'attribute-name))
(let* ((active-attributes
(find-attribute description 'active-attributes))
(attributes (when active-attributes
- (attribute-value active-attributes))))
+ (ignore-errors (attribute-value active-attributes)))))
(if attributes
(mapcar (lambda (spec)
(find-attribute
(description-attributes description))))))
-
-
-
-
-;;; A handy macro.
+(defun funcall-with-described-object (function object description &rest args)
+ (setf description (or description (description-of object)))
+ (let ((*description* description)
+ (*object* object))
+ (dletf (((described-object *description*) object))
+ (funcall-with-layer-context
+ (modify-layer-context
+ (if (standard-description-p *description*)
+ (adjoin-layer *description* (current-layer-context))
+ (current-layer-context))
+ :activate (description-active-descriptions *description*)
+ :deactivate (description-inactive-descriptions *description*))
+ (lambda () (contextl::funcall-with-special-initargs
+ (loop
+ :for (key val) :on args :by #'cddr
+ :collect (list (find key (description-attributes *description*)
+ :key #'attribute-keyword)
+ :value val))
+ (lambda ()
+ (contextl::funcall-with-special-initargs
+ (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))
+ (when attribute
+ (loop for spec in (attribute-value attribute)
+ if (listp spec)
+ collect (cons (or
+ (find-attribute *description* (car spec))
+ (error "No attribute matching ~A" (car spec)))
+ (cdr spec)))))
+ function))))))))
+
+
+(defmacro with-described-object ((object description &rest args)
+ &body body)
+ `(funcall-with-described-object
+ (lambda () ,@body)
+ ,object
+ ,description
+ ,@args))
+
(defmacro define-description (name &optional superdescriptions &body options)
(let ((description-name (defining-description name)))
(destructuring-bind (&optional slots &rest options) options
(in-package :lisp-on-lines)
-(defvar *description*)
+
(defvar *display*)
-(defvar *object* nil)
+
(define-layered-function display-using-description (description display object &rest args)
(:documentation
(define-layered-method display-using-description
:around (description display object &rest args)
(declare (ignorable args))
- (let ((*description* description)
- (*display* display)
- (*object* object))
-; (<:as-html " " description "Layer Active?: " (layer-active-p (defining-description 'maxclaims::link-to-viewer)))
- (dletf (((described-object description) object))
- (flet ((do-display ()
- (contextl::funcall-with-special-initargs
- (loop
- :for (key val) :on args :by #'cddr
- :collect (list (find key (description-attributes description)
- :key #'attribute-keyword)
- :value val))
- (lambda ()
- (contextl::funcall-with-special-initargs
- (let ((attribute (ignore-errors (find-attribute description 'active-attributes))))
- (when attribute
- (loop for spec in (attribute-value attribute)
- if (listp spec)
- collect (cons (or
- (find-attribute description (car spec))
- (error "No attribute matching ~A" (car spec)))
- (cdr spec)))))
- (lambda () (call-next-method)))))))
- (funcall-with-layer-context
- (modify-layer-context
- (if (standard-description-p description)
- (adjoin-layer description (current-layer-context))
- (current-layer-context))
- :activate (description-active-descriptions description)
- :deactivate (description-inactive-descriptions description))
- (function do-display))))))
+ (let ((*display* display))
+ (apply #'funcall-with-described-object
+ (lambda ()
+ (call-next-method))
+ object description args)))
(return
(destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym)))
(car tail)
- `(define-layered-method
+ `(define-layered-method
display-using-description
:in-layer ,(if (eq t description)
t
((identity :label nil)
(name
:function #'symbol-name
- :label "Name:")
+ :label "Name")
(value
- :label "Value:"
+ :label "Value"
:function
(lambda (symbol)
(if (boundp symbol)
(symbol-value symbol)
"<UNBOUND>")))
(package :function #'symbol-package
- :label "Package:")
- (function :label "Function:"
+ :label "Package")
+ (function :label "Function"
:function
(lambda (symbol)
(if (fboundp symbol)
(define-description T ()
((identity :label nil :function #'identity)
- (type :label "Type of" :function #'type-of)
+ (type :label "Type" :function #'type-of)
(class :label "Class" :function #'class-of)
(active-attributes :label "Attributes"
:value nil
:activep nil
:keyword :deactivate)
(label-formatter :value (lambda (label)
- (generic-format *display* "~A " label))
+ (generic-format *display* "~A:" label))
:activep nil)
(value-formatter :value (curry #'format nil "~A")
:activep nil)))
(define-display :around ((description t) (display null) object)
(with-output-to-string (*standard-output*)
- (call-next-layered-method description t object)))
+ (call-next-layered-method description t object))
+)
#:*context*
#:context.current-frame
#:context.window-component
-
+ #:*current-component*
;; Actions
#:call
: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))
(ucw:render (window-body window)))