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.

  • Participants
  • Parent commits bc15454

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