Commits

Anonymous committed 4522301

Converted from having a class for each tag to having a tag-definition for each tag, with lambdas for major 'methods.' Should enable better memory usage (as unused tag definitions can flush completely out of memory) and local tags in the future.

Comments (0)

Files changed (6)

doctaglibraries/docs.lisp

     :content (em "hh-web-tags"))
 
 (defhtmltag symbol-reference
-    :attributes ((sym :initarg :sym)
-		 (type :initarg :type))
-    :content (with-slots (sym type) *current-tag*
-	       (let* ((name (string-downcase (symbol-name sym)))
-		      (anchor (format nil "_~a_~a" type name)))
-		 (a {:href anchor} (strong {:style "font-family:monospace" } 
-					   name)))))
+    :attributes (sym type)
+    :content (let* ((name (string-downcase (symbol-name sym)))
+		    (anchor (format nil "_~a_~a" type name)))
+	       (a {:href anchor} (strong {:style "font-family:monospace" } 
+					 name))))
 
 (defhtmltag package-symbol
-    :attributes ((sym :initarg :sym)
-		 (type :initarg :type))
-    :content (with-slots (sym type) *current-tag*
-	       (let* ((name (string-downcase (symbol-name sym)))
-		     (anchor (format nil "_~a_~a" type name)))
-		 (a {:name anchor} (strong {:style "font-family:monospace" } 
-			    name)))))
+    :attributes (sym type)
+    :content (let* ((name (string-downcase (symbol-name sym)))
+		    (anchor (format nil "_~a_~a" type name)))
+	       (a {:name anchor} (strong {:style "font-family:monospace" } name))))
 
 (defhtmltag literal
-    :content (hunchentoot:escape-for-html (with-slots (_body) *current-tag* 
-					     (html _body))))
+    :content (hunchentoot:escape-for-html (html _body)))
 
 (defhtmltag sidebar
     :noendtag t)
 (defhtmltag macro-docs
     :content (loop for sym being the external-symbols of :hh-web-tags
 		  when (is-macro-p sym)
-		  collect (list (p
-				   (package-symbol {:sym sym :type "macro" }))
-			       (p (documentation sym 'function)))))
+		  collect (list (p (package-symbol {:sym sym :type "macro" }))
+				(p (documentation sym 'function)))))
 
 (defhtmltag function-docs
     :content (loop for sym being the external-symbols of :hh-web-tags

package-hh-web-tags.lisp

    #:defentity
    #:hout
    #:*current-tag*
+   #:*this-tag*
    #:*tag-library-registry*
+   #:call-next-tag-method
 
    #:_body
    #:body-of

taglibraries.lisp

    (libraries :initform () :accessor tag-libraries-used
     :documentation "A list of symbols identifying other libraries upon 
     which this one depends")
-   (tags :initform () :accessor tag-library-tags
+   (tags :initform (make-hash-table) :accessor tag-library-tags
     :documentation "A list of symbols identifying tags defined by this library")))
 
 (defmethod initialize-instance :after ( (library tag-library) &key )
 	library))))
 
 
-
 ; -- Tag library support for rendering to html
 
 ;; generic function declared in tags.lisp, because tags need to invoke the function 
 ;; at point of tag declaration
 
-(defmethod add-tag-to-library ( (tag-name symbol) &optional (*tag-library* *tag-library*))
+(defmethod add-tag-to-library ( (tag-definition tag-definition) &optional (*tag-library* *tag-library*))
   (if *tag-library*
-      (putendnew tag-name (tag-library-tags *tag-library*) :test 'equal)))
+      (setf (gethash (tag-symbol tag-definition) (tag-library-tags *tag-library*))
+	    tag-definition)))
 
 (defmethod expand-expression-with-libraries (expr &optional (*available-tag-libraries* *available-tag-libraries*))
   `(macrolet (,@(tag-library-tag-expansions (loop for v being the hash-values of *available-tag-libraries* collect v)))
   (gethash name *available-tag-libraries*))
 
 (defmethod tag-library-tag-expansions ( (some-library tag-library) )
-  (mapcar (lambda (each-tag) (tag-expansion each-tag) )
-	  (tag-library-tags some-library)))
+  (loop for each-tag being the hash-keys of (tag-library-tags some-library)
+     collect (tag-expansion each-tag)))
 
 (defmethod tag-library-tag-expansions ( (some-library (eql 'nil) ) )
   nil)

taglibraries/html.lisp

 (defhtmltag span)
 
 (defhtmltag textarea
-    :attributes ((name :initform nil :initarg :name :accessor name-of)
-		 (cols :initform nil :initarg :cols :accessor cols-for)
-		 (rows :initform nil :initarg :rows :accessor rows-for)))
+    :attributes (name cols rows))
 
 (defhtmltag input
     :noendtag t
-    :attributes ((name :initform nil :initarg :name :accessor name-of)
-		 (type :initform "text" :initarg :type :accessor input-type-of)
-		 (value :initform nil :initarg :value :accessor value-of)))
+    :attributes (name type value))
 
 (defhtmltag submit
     :content (input (+@ :type "submit" :value "OK") ))
 
 (defhtmltag checkbox
     :bases (input)
-    :tag (call-next-method) ;; has same tag as parent (input)
-    :attributes ((_label :initarg :label :initform nil) ;; don't render label attribute
-		 (type :initform "checkbox") ;; have to override base attribute on input
-		 (checked :initarg :checked :initform nil))
-    :content (with-slots (id _label class style) *current-tag* 
-	       (list
-		(when _label
-		  (list _label +nbsp+))
-		(html
-		 (call-next-method)))))
+    :tag "input"
+    :attributes (_label checked)
+    :init (progn (setf type "checkbox"))
+    :content (list (when _label _label)
+		   (call-next-tag-method)))
 
 (defhtmltag text-field
     :bases (input)
-    :tag (call-next-method)
-    :attributes ((_label :initarg :label :initform nil))
-    :content (with-slots (id _label class style) *current-tag* 
-	       (list (when _label
-		       _label)
-		     (html
-		      (call-next-method)))))
+    :tag "input"
+    :attributes (_label)
+    :content (list (when _label _label)
+		   (call-next-tag-method)))
 
 (defhtmltag form
-    :attributes ((action :initform nil :initarg :action :accessor action-of ) 
-		 (method :initform "GET" :initarg :method :accessor method-of)))
+    :attributes (action method)
+    :init (progn (setf action "GET")))
 
 (defhtmltag img
     :noendtag t
-    :attributes ((src :initform nil :initarg :src)
-		 (usemap :initform nil :initarg :usemap)
-		 (alt :initform nil :initarg :alt)
-		 (width :initform nil :initarg :width) 
-		 (height :initform nil :initarg :height) 
-		 (border :initform nil :initarg :border)))
+    :attributes (src usemap alt width height border))
 
 (defhtmltag imgmap
     :tag "map"
-    :attributes ((name :initform nil :initarg :name)))
+    :attributes (name))
 
 (defhtmltag area
     :noendtag t
-    :attributes ((shape :initform nil :initarg :shape)
-		 (coords :initform nil :initarg :coords)
-		 (href :initform nil :initarg :href)))
+    :attributes (shape coords href))
 
 (defhtmltag table)
 
     :tag "thead")
 
 (defhtmltag td
-    :attributes ( (colspan :initform nil :initarg :colspan) ))
+    :attributes (colspan))
 
 (defhtmltag a
-    :attributes ((name :initform nil :initarg :name)
-		 (href :initform nil :initarg :href)))
+    :attributes (name href))
 
 (defhtmltag b)
 
     :noendtag t)
 
 (defhtmltag iframe
-    :attributes ((src :initform nil :initarg :src)
-		 (frameborder :initform nil :initarg :frameborder)
-		 (allowtransparency :initform nil :initarg :allowtransparency)
-		 (width :initform nil :initarg :width)
-		 (height :initform nil :initarg :height)))
+    :attributes (src frameborder allowtransparency width height))
 
 (defhtmltag script
-    :attributes ((type :initform "text/javascript" :initarg :type)
-		 (src :initform nil :initarg :src)))
+    :attributes (type src)
+    :init (progn (setf type "text/javascript")))
 ;;;------------------------------------------------------------------------------------
 
 (defvar *current-tag* nil
-  "The current tag under construction (if any)")
+  "The current tag under construction (if any), within the scope of a tag's body")
+
+(defvar *this-tag* nil
+  "The active tag in the scope of a tag method (e.g., while rendering); while rendering a custom tag,
+   *this-tag* will not change within the same method, but *current-tag* changes within the body of each
+   tag in the content")
+
+(defvar *default-tag-definition* nil
+  "Provides default implementation for tag methods")
 
 (defvar *tag-printing-level* 0
   "Used for pretty printing HTML, with proper indentation for nested tags")
 ;;;------------------------------------------------------------------------------------
 ;;; Types
 ;;;------------------------------------------------------------------------------------
+
+(defclass tag-definition ()
+  ((symbol :initarg :symbol :accessor tag-symbol :documentation "The tag symbol is the unique identifier for a tag definition")
+   (name :initarg :name :accessor tag-name :documentation "The tag name is the string used in the start tag when rendering to HTML")
+   (bases :initform nil :initarg :bases :accessor tag-bases)
+   (attributes :initform nil :initarg :attributes :accessor tag-attributes)
+   (init :initform nil :initarg :init :accessor tag-init)
+   (has-body :initform nil :initarg :has-body :accessor tag-has-body-p)
+   (has-end-tag :initform nil :initarg :has-end-tag :accessor tag-has-end-tag-p)
+   (scripts :initform nil :initarg :scripts :accessor tag-scripts)
+   (ready-scripts :initform nil :initarg :ready-scripts :accessor tag-ready-scripts)
+   (script-libraries :initform nil :initarg :script-libraries :accessor tag-script-libraries)
+   (styles :initform nil :initarg :styles :accessor tag-styles)
+   (style-sheets :initform nil :initarg :style-sheets :accessor tag-style-sheets)
+   (content :initform nil :initarg :content :accessor tag-content))
+  (:documentation "Holds the details of a particular type of tag. All slots are lambdas
+   (or funcallables) except for symbol, name, bases, and attributes"))
+
 (defclass htmltag ()
-  ((_body :initform () :initarg :body :accessor body-of)
-   ;; corresponds the id of the DOM element, if needed
-   (id :initform () :initarg :id :accessor html-id)
-   ;; corresponds to class attribute for CSS style information
-   (class :initform nil :initarg :class :accessor css-class)
-   (style :initform nil :initarg :style :accessor style-of)
-   (rel :initform nil :initarg :rel :accessor rel-of)))
+  ((_definition :initarg :definition :accessor tag-definition) 
+   (_attribute-map :initform (make-hash-table :test #'equal) :initarg :attribute-map :accessor tag-attribute-map)
+   (_body :initform () :initarg :body :accessor body-of)))
 
 ;;;------------------------------------------------------------------------------------
 ;;; Tag requirements of tag libraries
 (defvar *tag-library* nil
   "Current tag library to which new tag defintions will belong")
 
-(defgeneric add-tag-to-library (tag-name &optional tag-library)
+(defgeneric add-tag-to-library (tag-definition &optional tag-library)
   (:documentation "Called at the point of tag definition to add the tag to the library"))
 
 (defgeneric expand-expression-with-libraries (expr &optional *available-tag-libraries*)
 (defgeneric tag-attributes (*current-tag*)
   (:documentation "Return a list of attribute names for the tag"))
 
+(defgeneric tag-attribute-value (*current-tag* attribute)
+  (:documentation  "Return the value of attribute on tag"))
+
+(defgeneric (setf tag-attribute-value) (value *current-tag* attribute)
+    (:documentation "Set the value of attribute on the tag"))
+
 (defgeneric render-tag-scripts (*current-tag*)
   (:documentation
    "Return the script that should be shared by all instances
 
 
 ;;;------------------------------------------------------------------------------------
-;;; Methods
+;;; Methods and their helpers
 ;;;------------------------------------------------------------------------------------
 
+(defun find-tag-definition (tag-symbol)
+  "Given the symbol for a tag definition, locate that definition in any
+   available tag library"
+  ;; we check *tag-library* first, in case it's in the current library--
+  ;; which may also be the library under construction (and thus possibly
+  ;; not yet in *available-tag-libraries*
+  (or (when *tag-library* (gethash tag-symbol (tag-library-tags *tag-library*)))
+      (loop for library being the hash-values of *available-tag-libraries*
+	 ;; TODO we're using tag-library-tags, defined in taglibraries.lisp,
+	 ;; so that's a forward reference
+	 for definition = (gethash tag-symbol (tag-library-tags library))
+	 when definition return definition
+	 finally (return nil))))
+
+(defun find-next-tag-method (definition method-name &optional (visited-definitions nil))
+  (or
+   (loop for base in (tag-bases definition)
+      for base-definition = (find-tag-definition base)
+      for base-method = (when base-definition 
+			  (find-tag-method base-definition 
+					   method-name
+					   (cons definition visited-definitions)))
+      when base-method return base-method
+      finally (return nil))
+   (slot-value *default-tag-definition* method-name)))
+
+(defun find-tag-method (definition method-name &optional (visited-definitions nil))
+  (or
+   (slot-value definition method-name)
+   (find-next-tag-method definition method-name visited-definitions)))
+
+(defmethod tag-name ((*current-tag* htmltag))
+  (tag-name (tag-definition *current-tag*)))
+
 (defmethod tag-library-name-for-tag ( (*current-tag* htmltag) )
-  (intern (package-name (symbol-package (tag-name *current-tag*))) 'keyword))
+  (intern (package-name (symbol-package (tag-symbol (tag-definition *current-tag*)))) 'keyword))
 
-(defmethod tag-attributes ( (some-tag-name symbol) )
-  (loop for a in (mapcar (lambda (s) (slot-definition-name s))
-		 (class-slots (find-class some-tag-name)))
-       unless (equal a '_body)
-       collect a))
+(defun default-tag-attributes ()
+  "Return a list of default attributes common to all tags"
+  `(id class style))
 
 (defmethod tag-attributes ( (*current-tag* htmltag) )
-  (loop for a in (tag-attributes (type-of *current-tag*))
-       unless (equal (slot-value *current-tag* a) nil)
-       collect a))
+  ;; TODO add attributes for bases
+  (tag-attributes (tag-definition *current-tag*)))
+
+(defun find-tag-attributes (tag-symbol)
+  (let ((attributes (default-tag-attributes))
+	(visited-symbols ()))
+    (labels ((find-tag-symbol-attributes (a-symbol)
+	       (unless (member a-symbol visited-symbols)
+		 (let ((definition (find-tag-definition a-symbol)))
+		   (unless definition (error "No tag definition found for ~s" a-symbol))
+		   (loop for attribute in (tag-attributes definition)
+		      ;; TODO note that using string= is slightly out of sync with
+		      ;; with the actual hash test in tag-attribute-map--that also
+		      ;; does a string-downcase; this should unless work unless a symbol
+		      ;; is actually of mixed case
+		      do (pushnew attribute attributes :key #'symbol-name :test #'string=))
+		   (pushnew a-symbol visited-symbols)
+		   (loop for base in (tag-bases definition)
+		      do (find-tag-symbol-attributes base))))))
+      (find-tag-symbol-attributes tag-symbol))
+    attributes))
+
+(defun find-all-tag-attributes (tag-attributes bases)
+  (let ((attributes (default-tag-attributes))
+	(visited-symbols ()))
+    (labels ((push-attribute (attribute)
+	       (pushnew attribute attributes :key #'symbol-name :test #'string=))
+	     (find-tag-symbol-attributes (a-symbol)
+	       (unless (member a-symbol visited-symbols)
+		 (let ((definition (find-tag-definition a-symbol)))
+		   (unless definition (error "No tag definition found for ~s" a-symbol))
+		   (loop for attribute in (tag-attributes definition)
+		      ;; TODO note that using string= is slightly out of sync with
+		      ;; with the actual hash test in tag-attribute-map--that also
+		      ;; does a string-downcase; this should unless work unless a symbol
+		      ;; is actually of mixed case
+		      ;; do (pushnew attribute attributes :key #'symbol-name :test #'string=)
+		      do (push-attribute attribute))
+		   (pushnew a-symbol visited-symbols)
+		   (loop for base in (tag-bases definition)
+		      do (find-tag-symbol-attributes base))))))
+      (loop for base in bases
+	 do (find-tag-symbol-attributes base))
+      (loop for attribute in tag-attributes
+	 do (push-attribute attribute)))
+    attributes))
+
+(defmethod tag-attribute-value ((*current-tag* htmltag) ( attribute symbol))
+  (tag-attribute-value *current-tag* (symbol-name attribute)))
+
+(defmethod tag-attribute-value ((*current-tag* htmltag) ( attribute string))
+  (gethash (string-downcase attribute) (tag-attribute-map *current-tag*)))
+
+(defmethod (setf tag-attribute-value) (value (*current-tag* htmltag) (attribute symbol))
+    (setf (tag-attribute-value *current-tag* (symbol-name attribute)) value))
+
+(defmethod (setf tag-attribute-value) (value (*current-tag* htmltag) (attribute string))
+    (setf (gethash (string-downcase attribute) (tag-attribute-map *current-tag*)) value))
 
 (defmethod render-tag-scripts ((some-tag-name symbol))
-    nil)
+  nil)
 
 (defmethod render-tag-scripts ((*current-tag* htmltag))
-    nil)
+    (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'scripts)))
+      (when tag-method
+	(funcall tag-method *current-tag*))))
 
 (defmethod render-tag-ready-scripts((some-tag-name symbol))
     nil)
 
 (defmethod render-tag-ready-scripts((*current-tag* htmltag))
-    nil)
+  (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'ready-scripts)))
+    (when tag-method
+      (funcall tag-method *current-tag*))))
 
 (defmethod render-tag-script-libraries((some-tag-name symbol))
     nil)
 
 (defmethod render-tag-script-libraries ((*current-tag* htmltag))
-    nil)
+  (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'script-libraries)))
+    (when tag-method
+      (funcall tag-method *current-tag*))))
 
 (defmethod render-tag-styles ((some-tag-name symbol))
     nil)
 
 (defmethod render-tag-styles ((*current-tag* htmltag))
-    nil)
+  (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'styles)))
+    (when tag-method
+      (funcall tag-method *current-tag*))))
 
 (defmethod render-tag-style-sheets ((some-tag-name symbol))
     nil)
 
 (defmethod render-tag-style-sheets ((*current-tag* htmltag))
-  nil)
+  (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'style-sheets)))
+    (when tag-method
+      (funcall tag-method *current-tag*))))
+
+(defmacro initialize-tag (tag-var &rest attribute-key-values)
+  `(progn
+     ,@(loop for attribute in attribute-key-values by #'cddr
+	for value in (cdr attribute-key-values) by #'cddr
+	collect `(setf (tag-attribute-value ,tag-var ',attribute) ,value))
+     (let ((init-method (find-tag-method (tag-definition *current-tag*) 'init)))
+       (when init-method
+	 (funcall init-method *current-tag*)))))
 
 (defmethod tag-expansion ( (name symbol) )
   `(,name (&rest content)
 	  (let ((name (quote ,name)))
 	    (multiple-value-bind (initializer body) (tag-separate-initializer-and-body (quote ,name) content)
-	      `(let ((*current-tag* (make-instance (quote ,name) ,@initializer)))
+	      `(let ((*current-tag* (make-instance 'htmltag :definition (find-tag-definition ',name))))
+		 (initialize-tag *current-tag* ,@initializer)
 		 (setf (body-of *current-tag*) (list ,@body)) *current-tag*)))))
 
 (defmethod tag-has-body-p ( (some-tag-symbol symbol) )
       (values raw-body nil)))
 
 (defmethod render-as-html ( (*current-tag* htmltag) )
-
   (render-tag-script-libraries *current-tag* )
   (render-tag-scripts *current-tag* )
   (render-tag-styles *current-tag* )
   (render-tag-style-sheets *current-tag* )
   (render-tag-ready-scripts *current-tag* )
-
   (render-tag-content *current-tag* ))
 
 (defmethod render-as-html ( (some-expr string))
 
 (defmethod render-tag-attributes ( (*current-tag* htmltag) )
   (hout "~:{ ~a='~a'~}" 
-	  (mapcar (lambda (a)
-		    (list (string-downcase (symbol-name a)) (slot-value *current-tag* a)))
-		  (tag-attributes *current-tag*))))
+	(loop for attribute in (find-tag-attributes (tag-symbol (tag-definition *current-tag*)))
+	     for value = (tag-attribute-value *current-tag* attribute)
+	     when value 
+	   collect (list (string-downcase (symbol-name attribute)) value))))
 
 (defmethod render-tag-body ( (*current-tag* htmltag) )
   (dolist (some-expr (body-of *current-tag*) )
 	  (string-downcase name) )))
 
 (defmethod render-tag-content ( (*current-tag* htmltag) )
-  (render-tag-start *current-tag* )
-  (let ((*tag-printing-level* (1+ *tag-printing-level*)))
-    (render-tag-body *current-tag* ))
-  (if (tag-has-end-tag-p *current-tag*)
-      (render-tag-end *current-tag* )))
+  (let ((tag-method (find-tag-method (tag-definition *current-tag*) 'content)))
+    (when tag-method
+      (funcall tag-method *current-tag*))))
 
 ;;;------------------------------------------------------------------------------------
 ;;; Functions
 		,some-place
 		:test 'equal)))
 
+(setf *default-tag-definition* 
+      (make-instance 'tag-definition 
+		     :init (lambda (*current-tag*) )
+		     :has-body (lambda (*current-tag*) t)
+		     :has-end-tag (lambda (*current-tag*) t)
+		     :scripts (lambda (*current-tag*) "")
+		     :ready-scripts (lambda (*current-tag*) "")
+		     :script-libraries (lambda (*current-tag*) ())
+		     :styles (lambda (*current-tag*) ())
+		     :style-sheets (lambda (*current-tag*) ())
+		     :content (lambda (*current-tag*)	
+				(render-tag-start *current-tag* )
+				(let ((*tag-printing-level* (1+ *tag-printing-level*)))
+				  (render-tag-body *current-tag* ))
+				(if (tag-has-end-tag-p *current-tag*)
+				    (render-tag-end *current-tag* )))))
+
 (defmacro defhtmltag (name
 		      &key
 		      ((:tag tag) nil)
 		      ((:bases bases) nil) ; other base classes here
 		      ((:attributes attributes) nil)
+		      ((:init init) nil)
 		      ((:hasbody hasbody) t)
 		      ((:noendtag noendtag) nil)
 		      ((:content content) nil)
   "Define a new tag renderable as HTML."
   (declare 
    (type (or null list) style-sheets script-libraries))
-  `(progn
+  (let ((all-attributes (let ((unique-attributes ()))
+			  (loop for attribute in (append (default-tag-attributes)
+							 attributes
+							 (loop for base in bases
+							    append (tag-attributes (find-tag-definition base))))
+			     do (pushnew attribute unique-attributes :key #'symbol-name :test #'string=))
+			  unique-attributes)))
+    `(let ((definition (make-instance 'tag-definition :name ',name)))
+       	 (setf (tag-name definition) 
+	       ,(if tag
+		    tag	    
+		    `(quote ,name)))
 
-     (add-tag-to-library (quote ,name) *tag-library*)
+	 (setf (tag-symbol definition) ',name)
 
-     (export (list
-	      (quote ,name)))
+	 (add-tag-to-library definition *tag-library*)
 
-     (defclass ,name (,@bases htmltag)
-       (,@attributes))
+	 (export (list
+		  (quote ,name)))
 
-     ;; TODO should consider undefining some of these methods, 
-     ;; to avoid lingering effects when tags redefined (e.g, 
-     ;; define scripts, then redefine without scripts, method
-     ;; for scripts still exists)
+	 (setf (tag-bases definition) ',bases)
 
-     (defmethod tag-name ( (*current-tag* ,name) )
-       ,(if tag
-	    tag	    
-	    `(quote ,name)))
+	 ;; (setf (tag-attributes definition) ',attributes)
+	 ;; TODO consider using the default attributes in the tag-attributes method,
+	 ;; as this will create a copy of the defaults in every definition in an inheritance
+	 ;; chain--not huge, as its just references to symbols, but nonetheless, does not adequately
+	 ;; implement the intent
+	 (setf (tag-attributes definition) ',attributes)
 
-     ,(unless hasbody
-	      `(defmethod tag-has-body-p ( (some-tag-symbol (eql (quote ,name) ) ) )
-		 nil))
+       (macrolet ((with-tag-attributes (() &rest body)
+		    (let ((attributes (find-all-tag-attributes ',attributes ',bases)))
+		      ;; Okay, challenge here is that this macro is expanded *before* the current tag's
+		      ;; definition has made it into the library (see a few lines down where the add-tag-to-library
+		      ;; call happens); so...we need to collect the attributes from the tag's bases, add in
+		      ;; any defined here in the call to the macro, and then should be good.
+		      `(symbol-macrolet (,@(loop for attribute in attributes ;; attributes
+					      collect `(,attribute (tag-attribute-value *this-tag* ',attribute))))
+			 (with-slots (_body) *this-tag*
+			   ,@body))))
+		  (define-tag-method ((method-name) &rest body)
+		    `(lambda (*current-tag*)
+		       (flet ((call-next-tag-method (&optional (*current-tag* *current-tag*))
+				(let ((next-tag-method (find-next-tag-method definition ',method-name)))
+				  (when next-tag-method
+				    ;; TODO consider whether it's an error if there is no
+				    ;; tag method found...at the moment we just silently
+				    ;; evaluate to nil
+				    (funcall next-tag-method *current-tag*)))))
+			 (let* ((*this-tag* *current-tag*) 
+				(*tag-library* (gethash (tag-library-name-for-tag *this-tag*) 
+							*available-tag-libraries*))
+				;; TODO this part is a bit of a forward reference, as we're
+				;; using an accessor on a tag library object
+				(*package* (tag-library-package *tag-library*)))
+			   ;; render the content expression instead of the usual content rendering
+			   (with-tag-attributes () 
+			     ,@body))))))
 
-     ,(when noendtag
-	      `(defmethod tag-has-end-tag-p ( (some-tag  ,name) )
-		 nil))
+	 ,(when init
+		`(setf (tag-init definition) 
+		       (define-tag-method (init)
+			   ,init)))
 
-     ,(when script
-	    `(defmethod render-tag-scripts ( (*current-tag* ,name) )
-	         (union-ordered (list (format nil "/* --------- Script for tag ~a:~a ------------- */~%"
-					      (tag-library-name-for-tag *current-tag*)
-					      (tag-name *current-tag*))
-				      ,script)
-				*page-scripts* )))
+	 ,(when hasbody
+		`(setf (tag-has-body-p definition)
+		       (define-tag-method (has-body)
+			   ,hasbody)))
 
-     ,(when ready
-	    `(defmethod render-tag-ready-scripts ( (*current-tag* ,name) )
-	       (union-ordered (list (format nil "/* --------- Initialization for tag ~a:~a ------------- */~%"
-					      (tag-library-name-for-tag *current-tag*)
-					      (tag-name *current-tag*))
-			       ,ready)
-			      *page-ready-scripts*)))
-	    
-     ,(when script-libraries
-	    `(defmethod render-tag-script-libraries ( (*current-tag* ,name) )
-	       (union-ordered ,script-libraries *page-script-libraries*)))
+	 ,(when noendtag 
+		`(setf (tag-has-end-tag-p definition)
+		       (define-tag-method (has-end-tag)
+			   nil)))
 
-     ,(when style
-	    `(defmethod render-tag-styles ( (*current-tag* ,name) )
-	       (union-ordered (list (format nil "/* --------- Styles for tag ~a:~a ------------- */~%"
-					    (tag-library-name-for-tag *current-tag*)
-					    (tag-name *current-tag*))
-				    ,style)
-			      *page-styles*)))
+	 ,(when script
+		`(setf (tag-scripts definition)
+		       (define-tag-method (scripts)
+			   (union-ordered (list (format nil "/* --------- Script for tag ~a:~a ------------- */~%"
+							(tag-library-name-for-tag *current-tag*)
+							(tag-name *current-tag*))
+						,script)
+					  *page-scripts* ))))
 
-     ,(when style-sheets
-	    `(defmethod render-tag-style-sheets ( (*current-tag* ,name) )
-	       (union-ordered ,style-sheets *page-style-sheets*)))
+	 ,(when ready
+		`(setf (tag-ready-scripts definition)
+		       (define-tag-method (ready-scripts)
+			   (union-ordered (list (format nil "/* --------- Initialization for tag ~a:~a ------------- */~%"
+							(tag-library-name-for-tag *current-tag*)
+							(tag-name *current-tag*))
+						,ready)
+					  *page-ready-scripts*))))
 
-     ,(when content
-	    `(defmethod render-tag-content ( (*current-tag* ,name) )
-	       ;; setup appropriate globals 
-	       ;; getting the tag library here does not involve a "forward reference"
-	       ;; as everything has already been defined above
-	       (let* ((*tag-library* (gethash (tag-library-name-for-tag *current-tag*) 
-					      *available-tag-libraries*))
-		      ;; this part is a bit of a forward reference, as we're
-		      ;; using an accessor on a tag library object
-		      (*package* (tag-library-package *tag-library*)))
-		 ;; render the content expression instead of the usual content rendering
-		 (render-as-html (tags ,content) ))))))
+	 ,(when script-libraries
+		`(setf (tag-script-libraries definition)
+		       (define-tag-method (script-libraries)
+			   (union-ordered ,script-libraries *page-script-libraries*))))
+
+	 ,(when style
+		`(setf (tag-styles definition)
+		       (define-tag-method (styles)
+			   (union-ordered (list (format nil "/* --------- Styles for tag ~a:~a ------------- */~%"
+							(tag-library-name-for-tag *current-tag*)
+							(tag-name *current-tag*))
+						,style)
+					  *page-styles*))))
+
+	 ,(when style-sheets
+		`(setf (tag-style-sheets definition)
+		       (define-tag-method (style-sheets)
+			   (union-ordered ,style-sheets *page-style-sheets*))))
+
+	 ,(when content
+		`(setf (tag-content definition)
+		       (define-tag-method (content)
+			   (render-as-html (tags ,content) ))))))))
+
 
 (defmacro defentity (name text &optional documentation)
   "Defines an entity usable in HTML"
 		   (hout "</html>~%"))
 		 "text/html")
 	 (values nil nil))))
+
+
+;;;------------------------------------------------------------------------------------
+;;; Printing
+;;;------------------------------------------------------------------------------------
+
+(defmethod print-object ((object htmltag) stream)
+  (print-unreadable-object (object stream :type t)
+    (format stream "Name=~s Body=~s" (tag-name object) (slot-value object '_body))))
+
+(defmethod print-object ((object tag-definition) stream)
+  (print-unreadable-object (object stream :type t)
+    (format stream "Symbol=~s" (tag-symbol object) )))
 (deftemplates :tag-library-packages ( "hh-web-tags" )
   :template-packages ( "hh-web-tags")
   :templates ((test-page1 "test-page1.lisp")
-	      (test-html1 "test-html1.lisp"))
+	      (test-html1 "test-html1.lisp")
+	      (test-html2 "test-html2.lisp")
+	      (test-html3 "test-html3.lisp")
+	      (test-html-text-field "test-html-text-field.lisp"))
+  :tag-library-folder "testtaglibraries"
   :template-folder "testtemplates")
 
 ;;----------------------------------------
 ;; Tests
 
 (define-test template-tests
-  (assert-true (string= (test-page1) "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">
+  (assert-equal "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">
 <html xmlns=\"http://www.w3.org/1999/xhtml\">
 <head>
 </head>
 hello
 </body>
 </html>
-")))
+" (nth-value 0 (test-page1))))
 
 (define-test html-tests
-  (assert-true (string= (test-html1) "
+  ;; (format *standard-output* "html 1 : ~s~%" (test-html1))
+   
+  (assert-equal "
 <p>hello
-</p>")))
+</p>" (nth-value 0 (test-html1)))
+
+  ;; (format *standard-output* "html 2 : ~s~%" (test-html2))
+    
+  (assert-equal "
+<a href='bar'>bwirp
+</a>" (nth-value 0  (test-html2)))
+
+  ;; (format *standard-output* "html 3 : ~s~%" (test-html3))
+  ;; (format *standard-output* "html for text-field : ~s~%" (test-html-text-field))
+  )
 
 ;;----------------------------------------
 ;; Run