Commits

Anonymous committed 1ea7ae0

Renamed to hh-code-lang to hh-parse and removed obsolete files (including dependenices on external systems, although systems such as cl-ppcre and yacc are still present in ext tree)

Comments (0)

Files changed (5)

+;;;; Created on 2008-10-31 06:51:40
+
+(defpackage #:hh-parse-asd
+  (:use :cl :asdf))
+
+(in-package :hh-parse-asd)
+
+(defsystem hh-parse
+  :name "hh-parse"
+  :version "0.1"
+  :serial t
+  :components (
+               (:file "package-hh-parse")
+	       (:file "parser")
+	       (:file "source")
+	       )
+  :depends-on (
+	       ; external packages
+	       "cl-fad"
+
+	       ; project packages
+	       "hh-utils"
+
+               )
+  )
+
+(defsystem hh-parse-tests
+  :name "hh-parse-tests"
+  :version "0.1"
+  :serial t
+  :components (
+               (:file "tests")
+               	)
+  :depends-on (
+	       ;; external packages
+	       "lisp-unit"
+
+	       ;; project packages
+               "hh-parse"
+        )
+  )

package-hh-parse.lisp

+(defpackage #:hh-parse-asd
+  (:use :cl :asdf))
+
+(in-package :hh-parse-asd)
+
+(defpackage :hh-parse
+  (:nicknames :hh-parse)
+  (:use :cl 
+	;; external
+	:cl-fad
+
+	;; project
+	:hh-utils 
+
+	)
+  (:export
+    
+    ;; Exported symbols go here
+    
+    )
+  )
+(in-package :hh-parse)
+
+(export
+ (list
+
+  'parse
+
+  'seq
+  'alt
+  'rep
+  'opt
+  'lit
+  'rule
+  'ws
+  'es
+  'cc
+  's
+
+  'node-equal
+
+  )
+ )
+
+;; =====================================================================================================================
+;;
+;; Types
+;;
+;; =====================================================================================================================
+
+(defclass parser ()
+  (
+   (code :initarg :code :accessor code)
+   (threads :initform () :accessor threads-of)
+   (thread-counter :initform 0 :accessor thread-count)
+   (results :initform () ::accessor results-of)
+   (ready-for-character :initform t :accessor ready-for-character)
+   (last-character-read-successfully :initform t :accessor last-character-read-successfully)
+   )
+  )
+
+(defclass parse-stream ()
+  (
+   )
+  (:documentation "A marker type for indicating streams supporting a parsing position interface")
+  )
+
+(defclass parse-frame ()
+  (
+   (position :initarg :position :accessor position-for)
+   (node :initarg :node :accessor node-in)
+   )
+  )
+
+(deftype thread-completion-status ()
+  `(or (eql :failed)
+       (eql :succeeded)
+       )
+  )
+
+(deftype thread-status ()
+  `(or thread-completion-status
+       (eql :continuing)
+       )
+  )
+
+(defclass parse-thread ()
+  (
+   (id :initarg :id :accessor id-of)
+   (node-results :initform () :accessor node-results-in)
+   (status :initform :continuing :type thread-status :accessor status-of)
+   (stack :initform () :accessor stack-of)
+   (value :initform nil :accessor value-of)
+   )
+  )
+
+(defclass parse-node ()
+  (
+   (called :initform nil)
+   )
+  )
+
+(defclass literal-node (parse-node)
+  (
+   (index :initform 0 :accessor index-of)
+   (literal :initarg :literal :accessor literal)
+   (wants-character :initform nil)
+   )
+  )
+
+(defclass sequence-node (parse-node)
+  (
+   (index :initform 0 :accessor index-of)
+   (elements :initform () :initarg :elements :accessor elements-of)
+   )
+  )
+
+(defclass alternatives-node (parse-node)
+  (
+   (succeeded :initform () )
+   (alternatives :initform () :initarg :alternatives :accessor alternatives-of)
+   )
+  )
+
+(defclass repeat-node (parse-node)
+  (
+   ;; element is actually a factory function, so that
+   ;; each time it used a fresh set of element node can be obtained
+   (element :initarg :element :accessor element-of)
+   (seen :initform nil)
+   )
+  )
+
+(defclass empty-node (parse-node)
+  (
+   )
+  (:documentation "Placeholder node returned in cases of a successful optional parse")
+  )
+
+(defclass optional-node (parse-node)
+  (
+   (element :initarg :element :accessor element-of)
+   )
+  )
+
+(defclass character-class-node (parse-node)
+  (
+   (test :initarg :test)
+   )
+  )
+
+(defclass capture-node (parse-node)
+  (
+   (target :initarg :target)
+   (slot :initarg :slot)
+   (value :initarg :value)
+   (transform :initarg :transform)
+   )
+  )
+
+(defclass rule-node (parse-node)
+  (
+   (value :initform () :initarg :value :accessor value-of)
+   )
+  )
+
+;; =====================================================================================================================
+;;
+;; Constants + globals
+;;
+;; =====================================================================================================================
+
+(defvar *trace-parser* nil
+  "If true, then parse routines will print tracing information to *trace-output*"
+  )
+
+;; =====================================================================================================================
+;;
+;; Generics
+;;
+;; =====================================================================================================================
+
+(defgeneric parse-code (parser)
+  )
+
+(defgeneric parse-result (parser)
+  )
+
+(defgeneric start-thread (parser node &optional base-thread)
+  )
+
+(defgeneric thread-completed-p (thread)
+  )
+
+(defgeneric call-node (parser thread node)
+  )
+
+(defgeneric return-from-node (parser thread value)
+  )
+
+(defgeneric abort-thread (parser thread)
+  )
+
+(defgeneric node-equal (left right)
+  )
+
+(defgeneric assimilate-result (thread node result)
+  )
+
+(defgeneric consolidated-results (thread node)
+  )
+
+(defgeneric empty-node-p (node)
+  )
+
+(defgeneric parse-position ( code )
+  )
+
+(defgeneric (setf parse-position ) ( code position )
+  )
+
+(defgeneric wants-character-p (node)
+  )
+
+(defgeneric next-parse-character ( code )
+  )
+
+(defgeneric end-parse-characters-p ( code )
+  )
+
+(defgeneric continue-parse (parser thread node)
+  )
+
+(defgeneric next-character ( parser )
+  )
+
+(defgeneric end-p ( parser )
+  )
+
+;; =====================================================================================================================
+;;
+;; Implementations
+;;
+;; =====================================================================================================================
+
+;; macro object factories
+
+(defmacro seq (&rest body)
+  `(make-instance 'sequence-node
+		  :elements (list ,@body)
+		  )
+  )
+
+(defmacro alt (&rest body)
+  `(make-instance 'alternatives-node
+		  :alternatives (list ,@body)
+		  )
+  )
+
+(defmacro opt (&rest body)
+  `(make-instance 'optional-node
+		  :element (seq ,@body)
+		  )
+  )
+
+(defmacro rep (&rest body)
+  `(make-instance 'repeat-node
+		  ;; :element (seq ,@body)
+		  :element (lambda () (seq ,@body) )
+		  )
+  )
+
+(defmacro lit (literal)
+  `(make-instance 'literal-node :literal ,literal)
+  )
+
+(defmacro ws (&rest characters)
+  "Represents whitespace that must be present (can be any size other than zero)"
+  `(rep (alt ,@(mapcar (lambda (c)
+			 `(lit (string ,c) )
+			 )
+		       (or characters `(#\Newline #\Return #\Tab #\Space #\Page) )
+		)
+	     )
+	)
+  )
+
+(defmacro cc ( test )
+  "Tests for whether a character belongs to a specific character class; test should
+   evaluate to a funcallable"
+  `(make-instance 'character-class-node :test ,test)
+  )
+
+(defmacro es (&rest characters)
+  "Represents optional whitespace; useful for showing that space between nodes is allowed but not required"
+  `(opt (ws ,@characters))
+  )
+
+;; tracing
+
+(defmacro trace-parser (&rest args)
+  `(when *trace-parser*
+     (format *trace-output* ,@args)
+     )
+  )
+
+;; results
+
+(defmacro getf-result (thread node)
+  `(getf (node-results-in ,thread) ,node)
+  )
+
+(defmacro setf-result (thread node result)
+  `(setf (getf-result ,thread ,node) ,result)
+  )
+
+;; top-level algorithm
+(defun parse ( code top-node &optional *trace-parser*)
+  (let* (
+	 (parser (make-instance 'parser :code code) )
+	 )
+    (start-thread parser top-node)
+    (parse-code parser)
+    )
+  )
+
+(defmethod parse-code ( (parser parser) )
+  (loop while (threads-of parser)
+     do (progn
+	  ;; get ready for character
+	  (trace-parser "P: Getting ready for character~%")
+	  (loop while (threads-of parser)
+	     do (setf (ready-for-character parser) t)
+	       (loop for thread in (threads-of parser)
+		  do (loop while (and (not (thread-completed-p thread)) (stack-of thread) )
+			;; TODO yeah, still don't have this cleaned up
+			for stack = (stack-of thread)
+			for frame = (first stack)
+			for node = (node-in frame)
+			;; until ready for character
+			until (wants-character-p node)
+			do (continue-parse parser thread node)
+			  )
+		    )
+	     until (ready-for-character parser)
+	       )
+
+	  ;; handle next character, if any remaining
+	  (loop for thread in (threads-of parser)
+	     ;; theoretically, the nil will cause nodes to start failing
+	     ;; and eventually cause threads to flush, thus exiting the outer loop
+	     with character = (if (end-p parser) nil (next-character parser) )
+	     do (trace-parser "P: Reading character ~a~%" character)
+	     do (when character
+		  (setf (last-character-read-successfully parser) nil)
+		  ) 
+	     do (when (stack-of thread)
+		  (let*(
+			(stack (stack-of thread) )
+			(frame (first stack))
+			(node (node-in frame))
+			)
+		    (setf (value-of thread) character)
+		    (continue-parse parser thread node)
+		    )
+		  )
+	       )
+	  )
+     finally (return (parse-result parser) )
+       )
+  )
+
+(defmethod continue-parse :around ( parser thread node )
+  "Protect parser from any errors in a single node"
+  (handler-case (call-next-method)
+    (error (c) (progn
+		 (format *standard-output* "Error encountered during parsing: ~a~%" c)
+		 (format *standard-output* "~t~tParse stack at error: ~{~a~%~}" 
+			 (loop for frame in (stack-of thread)
+			    collect (node-in frame)
+			      )
+			 )
+		 (abort-thread parser thread)
+		 )
+	   )
+    )
+  )
+
+(defmethod parse-result ( (parser parser) )
+  (if (and (end-p parser) (results-of parser) (last-character-read-successfully parser) )
+      (let (
+	    (results (results-of parser))
+	    )
+	(if (> (length results) 1)
+	    results
+	    (car results)
+	    )
+	)
+      (progn
+	(trace-parser "Parser state: ~a~%" parser)
+	nil
+	)
+      )
+  )
+
+(defmethod start-thread (parser node &optional (base-thread nil) )
+  (let (
+	(thread (make-instance 'parse-thread :id (thread-count parser)))
+	)
+    (incf (thread-count parser))
+    (setf (stack-of thread)
+	  (append (list (make-instance 'parse-frame
+				       :node node
+				       :position (parse-position (code parser))
+				       )
+			)
+		  (or (and base-thread (stack-of base-thread) )
+		      nil
+		      )
+		  )
+	  )
+    ;; copy results from the base thread, if available
+    (when base-thread
+      (setf (node-results-in thread)
+	    (copy-list (node-results-in base-thread) )
+	    )
+      )
+    (setf (threads-of parser)
+	  (append (threads-of parser)
+		  (list thread)
+		  )
+	  )
+    ;; reset readiness for characters; new thread needs a chance to continue
+    (setf (ready-for-character parser) nil) 
+    thread
+    )
+  )
+
+(defmethod thread-completed-p ( (thread parse-thread) )
+  (typep (status-of thread) 'thread-completion-status)
+  )
+
+(defmethod continue-parse ( parser thread (node literal-node))
+  (with-slots (called literal index) node
+    (if called
+	;; handle a character
+	(let (
+	      (parse-character (value-of thread) )
+	      (literal-character (elt literal index) )
+	      )
+	  (if (or (not (characterp (value-of thread))) 
+		  (char/= parse-character literal-character) 
+		  )
+	      (return-from-node parser thread nil)
+	      (progn
+		(incf index)
+		(when (>= index (length literal) )
+		  ;; succeeded
+		  (return-from-node parser thread (lit literal) )
+		  )
+		)
+	      )
+	  )
+	;; prepare
+	(setf called t)
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node sequence-node) )
+  (with-slots (called index elements results) node
+    (if called
+	(progn
+	  (if (value-of thread)
+	      (progn
+		(assimilate-result thread node (value-of thread))
+		(incf index)
+		(if (< index (length elements) )
+		    ;; not done
+		    (call-node parser thread (elt elements index))
+		    ;; must have succeeded
+		    (return-from-node parser thread (consolidated-results thread node) )
+		    )
+		)
+	      ;; no value--must have failed
+	      (return-from-node parser thread nil)
+	      )
+	  )
+	;; prepare to be called
+	(progn
+	  (setf called t)
+	  (call-node parser thread (elt elements index))
+	  )
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node alternatives-node) )
+  (with-slots (called alternatives succeeded) node
+    (if called
+	;; return whatever worked
+	;; note: if both threads succeed, will this be a problem?
+	;; ambiguous grammars could cause issues here
+	(return-from-node parser thread (value-of thread) )
+	;; try each alternative
+	(progn
+	  (setf called t)
+	  (loop for alternative in alternatives
+	     ;; we give the alternatives the same stack as this node
+	     do (start-thread parser alternative thread)
+	       )
+	  ;; we abort the original thread, because
+	  ;; all of its alternatives will continue its action
+	  (abort-thread parser thread)
+	  )
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node optional-node) )
+  (with-slots (called element) node
+    (if called
+	;; finish
+	(if (value-of thread)
+	    ;; use the value returned by element
+	    (return-from-node parser thread (value-of thread))
+	    ;; otherwise, return an empty node -- it's ok
+	    (return-from-node parser thread (make-instance 'empty-node))
+	    )
+	;; prepare
+	(progn
+	  (setf called t)
+	  ;; check for element
+	  (call-node parser thread element)
+	  )
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node empty-node) )
+  (with-slots (called) node
+    (if called
+	(return-from-node parser thread (make-instance 'empty-node))
+	(setf called t)
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node repeat-node) )
+  (with-slots (called element results) node
+    (if called
+	(progn
+	  (if (value-of thread)
+	      (progn
+		(assimilate-result thread node (value-of thread))
+		;; and in another thread, try to keep going
+		(start-thread parser (funcall element) thread )
+		;; in this thread, just return what we've got
+		(return-from-node parser thread (consolidated-results thread node) )
+		)
+	      ;; (return-from-node parser thread (consolidated-results thread node) )
+	      (return-from-node parser thread nil )
+	      )
+	  )
+	;; prepare to be called
+	(progn
+	  (setf called t)
+	  (call-node parser thread (funcall element) )
+	  )
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node character-class-node))
+  (with-slots (called test) node
+    (if called
+	(if (value-of thread) ;; skip nil
+	    ;; test characer
+	    (if (funcall test (value-of thread))
+		(return-from-node parser thread (value-of thread))
+		;; (abort-thread parser thread)
+		(return-from-node parser thread nil )
+		)
+	    ;; failed
+	    (return-from-node parser thread nil )
+	    )
+	;; prepare
+	(setf called t)
+	)
+    )
+  )
+
+(defmethod continue-parse ( parser thread (node capture-node))
+  (with-slots (called target slot value) node
+      (if called
+	  ;; capture
+	  (if (value-of thread)
+	      ;; succeeded
+	      (progn
+		;; treat node result as a property list, and save value
+		;; there as a property
+		(setf (getf (getf-result thread target) slot) 
+		      ;; apply transform--defaults to #'identity
+		      (funcall (slot-value node 'transform) (value-of thread))
+		      )
+		(trace-parser "#~a: captured ~a in slot ~a for ~a~%"
+			      (id-of thread)
+			      (value-of thread)
+			      slot
+			      target
+			      )
+		(return-from-node parser thread (value-of thread))
+		)
+	      ;; failed
+	      (return-from-node parser thread nil)
+	      )
+	  ;; prepare
+	  (progn
+	    (setf called t)
+	    (call-node parser thread value)
+	    )
+	  )
+      )
+  )
+
+(defmethod next-character ( (parser parser) )
+  (next-parse-character (code parser) )
+  )
+
+(defmethod end-p ( (parser parser) )
+  (end-parse-characters-p (code parser) )
+  )
+
+(defmethod alternatives-p ( (node parse-node) )
+  nil
+  )
+
+(defmethod alternatives-p ( (node alternatives-node) )
+  (< (index-of node) (length (alternatives-of node) ) )
+  )
+
+(defmethod call-node (parser thread node)
+  ;; clear before calling, because the value is no longer valid
+  (setf (value-of thread) nil) 
+  (push (make-instance 'parse-frame
+		       :node node
+		       :position (parse-position (code parser) )
+		       )
+	(stack-of thread)
+	)
+  )
+
+(defmethod return-from-node (parser thread value)
+  (setf (value-of thread) value)
+  (setf (last-character-read-successfully parser) 
+	(or (last-character-read-successfully parser)
+	    value
+	    )
+	)
+  (pop (stack-of thread) )
+  (when (null (stack-of thread) )
+    ;; It's possible we do not want this check for empty value,
+    ;; because that implies that grammars that allow empty input
+    ;; should still succeed--but that seems like an uninteresting
+    ;; set to support
+    (if (and (end-p parser) value (not (empty-node-p value) ) )
+	;; succeeded
+	;; hmmm....note that an empty-node is a failure
+	(progn
+	  (setf (status-of thread) :succeeded)
+	  (setf (results-of parser)
+		(append (results-of parser)
+			(list value)
+			)
+		)
+	  )
+	;; failed
+	(setf (status-of thread) :failed)
+	)
+    (setf (threads-of parser) (delete thread (threads-of parser)) )
+    )
+  )
+
+(defmethod abort-thread ( (parser parser) (thread parse-thread) )
+  (setf (status-of thread) :failed)
+  (setf (threads-of parser) (delete thread (threads-of parser)) )
+  )
+
+;; equality
+(defmethod node-equal ( (left sequence-node) (right sequence-node) )
+  (node-equal (elements-of left) (elements-of right) )
+  )
+
+(defmethod node-equal ( (left literal-node) (right literal-node) )
+  (equal (literal left) (literal right) )
+  )
+
+;; assimilation
+
+(defmethod assimilate-result ( thread (node parse-node) result)
+  (declare (ignorable thread))
+  (setf-result thread node
+	       (append (getf-result thread node)
+		       (list result)
+		       )
+	       )
+  node
+  )
+
+(defmethod assimilate-result ( thread (node parse-node) (result empty-node) )
+  ;; we do nothing
+  node
+  )
+
+(defmethod assimilate-result ( thread (node parse-node) (result list) )
+  (with-slots (results) node
+    (loop for item in result
+	 do (assimilate-result thread node item)
+	 )
+    )
+  node
+  )
+
+(defmethod assimilate-result ( thread (node parse-node) (result sequence-node) )
+  (with-slots (results) node
+    (assimilate-result thread node (elements-of result))
+    )
+  node
+  )
+
+(defmethod assimilate-result ( thread (node parse-node) (result character) )
+  (assimilate-result thread node (lit (string result)) )
+  )
+
+(defmethod assimilate-result ( thread (node parse-node) (result literal-node) )
+  (symbol-macrolet (
+  		    (results (getf-result thread node) )
+  		    )
+    (let (
+  	  (last-node (car (last results)) )
+  	  )
+      (if (typep last-node 'literal-node)
+  	  ;; append literals together
+  	  (setf (car (last results) )
+  		(lit (concatenate 'string (literal last-node) (literal result)) )
+  		)
+  	  ;; otherwise just add this new result as-is
+  	  (call-next-method)
+  	  )
+      )
+    )
+  node
+  )
+
+(defmethod consolidated-results (thread node)
+  (let (
+	(results (getf (node-results-in thread) node) )
+  	)
+    (when results
+      (if (= 1 (length results ) )
+	  (first results )
+	  (make-instance 'sequence-node :elements results )
+	  )
+      )
+    )
+  )
+
+(defmethod empty-node-p ( node )
+  nil
+  )
+
+(defmethod empty-node-p ( (node empty-node) )
+  t
+  )
+
+;; Implementation for stream-based code
+
+(defmethod parse-position ( (code stream) )
+  (file-position code)
+  )
+
+(defmethod (setf parse-position ) ( position code )
+  (file-position code position)
+  )
+
+(defmethod wants-character-p ( (node parse-node) )
+  nil
+  )
+
+(defmethod wants-character-p ( (node literal-node) )
+  (slot-value node 'called)
+  )
+
+(defmethod wants-character-p ( (node character-class-node) )
+  (slot-value node 'called)
+  )
+
+(defmethod next-parse-character ( (code stream) )
+  (read-char code nil nil)
+  )
+
+(defmethod end-parse-characters-p ( (code stream) )
+  (equal :eof (peek-char nil code nil :eof) )
+  )
+
+;; Print helpers
+
+(defmethod print-object ( (obj literal-node) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "CALLED=~a LITERAL=~s INDEX=~a" (slot-value obj 'called) (literal obj) (index-of obj))
+    )
+  )
+
+(defmethod print-object ( (obj sequence-node) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "CALLED=~a INDEX=~a ELEMENTS=(~{ ~a~})" (slot-value obj 'called) (index-of obj) (elements-of obj))
+    )
+  )
+
+(defmethod print-object ( (obj alternatives-node) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "CALLED=~a ALTERNATIVES=~a" (slot-value obj 'called) (alternatives-of obj))
+    )
+  )
+
+(defmethod print-object ( (obj parser) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "THREADS=~s" (threads-of obj) )
+    )
+  )
+
+(defmethod print-object ( (obj parse-thread) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "VALUE=~s STACK=~s" (value-of obj) (stack-of obj) )
+    )
+  )
+
+(defmethod print-object ( (obj parse-frame) stream)
+  (print-unreadable-object (obj stream :type t :identity t)
+    (format stream "NODE=~a" (node-in obj))
+    )
+  )
+
+(defmacro rule (name (&rest args) body
+		&key
+		(slots nil)
+		)
+  (let (
+	(node-class-name (intern (format nil "~a-NODE" 
+					 (symbol-name name)
+					 )
+				 (symbol-package name)
+				 )
+	  )
+	(slot-list (append args slots))
+	)
+    `(progn
+
+       (defclass ,node-class-name (rule-node)
+	 ,slot-list
+	 )
+
+       (defmethod node-equal ( (left ,node-class-name) (right ,node-class-name) )
+	 (loop for slot in (quote ,slot-list)
+	      with is-equal = t
+	      do (setf is-equal (let (
+				      (left-slot-value (slot-value left slot) )
+				      (right-slot-value (slot-value right slot) )
+				      )
+				  (and is-equal
+				       (if (typep left-slot-value 'parse-node)
+					   (node-equal left-slot-value right-slot-value)
+					   (equal left-slot-value right-slot-value)
+					   )
+				       )
+				  )
+		       )
+	      finally (return is-equal)
+	      )
+	 )
+
+       (defmethod print-object ( (obj ,node-class-name) stream)
+	 (print-unreadable-object (obj stream :type t :identity t)
+	   (format stream "VALUE=~a ~{ ~a=~s~}" 
+		   (if (slot-boundp obj 'value)
+		       (value-of obj)
+		       "<unbound>"
+		       )
+		   (loop for slot in (quote ,slot-list)
+		      collect slot
+		      if (slot-boundp obj slot)
+		      collect (slot-value obj slot)
+			else collect "<unbound>"
+			)
+		   )
+	   )
+	 )
+
+       (defmethod continue-parse ( parser thread (node ,node-class-name) )
+	 (macrolet (
+		    (s (slot value &optional (transform '#'identity))
+		      `(make-instance 'capture-node
+				      :target node
+				      :slot (quote ,slot)
+				      :value ,value
+				      :transform ,transform
+				      )
+		      )
+		    )
+	   (with-slots (called ,@args) node
+	     (if called
+		 ;; already called the rule's constructed node
+		 (if (value-of thread)
+		     (let (
+			   (new-node (make-instance (quote ,node-class-name) )
+			     )
+			   )
+		       (loop for slot in (quote ,slot-list)
+			  for value = (getf (getf-result thread node) slot)
+			  if value ;; skip it if set to nil
+			  do (progn 
+			       (setf (slot-value new-node slot)
+				     ;; get slot values from the property list in results
+				     (getf (getf-result thread node) slot)
+				     )
+			       )
+			    )
+		       (return-from-node parser thread new-node)
+		       )
+		     (return-from-node parser thread nil)
+		     )
+		 (progn
+		   (setf called t)
+		   (call-node parser thread (progn ,body) )
+		   )
+		 )
+	     )
+	   )
+	 )
+
+       (defmacro ,name ,args
+	 (let (
+	       (arg-list (quote ,args) )
+	       (val-list (list ,@args) )
+	       (node-class-name (quote ,node-class-name))
+	       )
+	   `(apply (lambda ()
+		     (let (
+			   (node (make-instance (quote ,node-class-name) ) )
+			   )
+		       ,@(mapcar (lambda (s v)
+				   `(setf (slot-value node (quote ,s)) ,v)
+				   )
+				 arg-list
+				 val-list
+				 )
+		       node
+		       )
+		     )
+		   nil
+		   )
+	   )     
+	 )
+
+       )
+    )
+  )
+
+;; Tracing routines
+
+(defmethod call-node :around (parser thread node)
+  (trace-parser "#~a: ~a calling ~a~%" 
+	  (id-of thread)
+	  (let* (
+		 (stack (stack-of thread))
+		 (frame (first stack) )
+		 (caller (node-in frame))
+		 )
+	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
+	    )
+	  (string-downcase (symbol-name (class-name (class-of node) ) ) )
+	  )
+  (call-next-method)
+  )
+
+(defmethod return-from-node :around (parser thread value)
+  (trace-parser "#~a: ~a returning ~a~%" 
+	  (id-of thread)
+	  (let* (
+		 (stack (stack-of thread))
+		 (frame (first stack) )
+		 (caller (node-in frame))
+		 )
+	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
+	    )
+	  value
+	  ) 
+  (call-next-method)
+  )
+
+(defmethod abort-thread :around (parser thread)	  (id-of thread)
+
+  (trace-parser "#~a: ~a aborting~%" 
+	  (id-of thread)
+	  (let* (
+		 (stack (stack-of thread))
+		 (frame (first stack) )
+		 (caller (node-in frame))
+		 )
+	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
+	    )
+	  )
+  (call-next-method)
+  )
+
+(defmethod start-thread :around (parser node &optional thread)
+  (let (
+	(new-thread (call-next-method))
+	)
+    (trace-parser "#~a: thread started by ~a~%"
+	    (id-of new-thread)
+	    (when (and thread (stack-of thread) )
+	      (let (
+		    (caller (node-in (car (stack-of thread) )) )
+		    )
+		(string-downcase (symbol-name (class-name (class-of caller) ) ) )
+		)
+	      )
+	    ;; stack
+	    )
+    new-thread
+    )
+  )
+
+(defmethod assimilate-result :around ( thread (node parse-node ) result)
+  (trace-parser "#~a: ~a assimilating result ~a~%" 
+	  (id-of thread)
+	  (let* (
+		 (stack (stack-of thread))
+		 (frame (first stack) )
+		 (caller (node-in frame))
+		 )
+	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
+	    )
+	  result
+	  )
+  (call-next-method)
+  )
+
+(defmethod continue-parse :around (parser thread node)
+  (trace-parser "#~a: continuing ~a with value ~a~%" 
+	  (id-of thread)
+	  (let* (
+		 (stack (stack-of thread))
+		 (frame (first stack) )
+		 (caller (node-in frame))
+		 )
+	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
+	    )
+	  (value-of thread)
+	  )
+  (call-next-method)
+  )
+
+(defmethod parse-result :around (parser)
+  (let (
+	(result (call-next-method) )
+	)
+    (trace-parser "P: Parse result ~a~%" result)
+    result
+    )
+  )
+(in-package :hh-parse)
+
+(export
+ (list
+
+  'source-code-line
+  'source-code-position
+  'source-code-file
+  
+  'source-text
+  'insert-line
+  'insert-text
+  'current-position
+  'current-line
+  'current-column
+  )
+ )
+
+;; =====================================================================================================================
+;;
+;; Types
+;;
+;; =====================================================================================================================
+
+(defclass source-code-line ()
+  (
+   (text
+    :initform ""
+    :initarg :text
+    :accessor text-of
+    )
+   )
+  )
+
+(defclass source-code-position ()
+  (
+   (line :initform 0 :initarg :line :accessor line-at)
+   (column :initform 0 :initarg :column :accessor column-at)
+   )
+  (:documentation "Represents a location within a file")
+  )
+
+(defclass source-code-file ()
+  (
+   (lines :initform (make-array 0 :element-type 'source-code-line :adjustable t) :accessor lines-of)
+   (parsers )
+   (position 
+    :initform (make-instance 'source-code-position)
+    :accessor current-position
+    )
+    )
+  (:documentation "Represents the state of a file being edited or parsed")
+  )
+
+;; =====================================================================================================================
+;;
+;; Constants + globals
+;;
+;; =====================================================================================================================
+
+
+;; =====================================================================================================================
+;;
+;; Generics
+;;
+;; =====================================================================================================================
+
+(defgeneric source-text (source)
+  (:documentation "Return the text of the lines of source code as raw text")
+  )
+
+(defgeneric insert-line ( source text)
+  (:documentation "Insert a line of text at the current position in code, and move the position to the next line after")
+  )
+
+(defgeneric insert-text ( source text)
+  (:documentation "Insert text into the file at its current position, adjusting lines as necessary, and
+    moving position to just after inserted text")
+  )
+
+(defgeneric insert-character ( source c )
+  (:documentation "Insert a character into the file at its current position, adjusting lines as necessary, and
+    moving position to just after inserted text")
+  )
+
+(defgeneric insert-into ( array element position)
+  (:documentation "General function to insert an element into a single-dimension array")
+  )
+
+(defgeneric split-line ( line column )
+  (:documentation "Split the line at the indicated column, returning as values the modified
+   old line and the following line created from split")
+  )
+
+(defgeneric current-line ( source )
+  )
+
+(defgeneric (setf current-line) ( source line)
+  )
+
+(defgeneric current-column ( source )
+  )
+
+(defgeneric (setf current-column) ( source column)
+  )
+
+(defgeneric next-column ( position )
+  (:documentation "Increment the column component of position")
+  )
+
+(defgeneric next-line ( position )
+  (:documentation "Increment the line component of position")
+  )
+
+;; =====================================================================================================================
+;;
+;; Implementations
+;;
+;; =====================================================================================================================
+
+(defmethod (setf current-position) :around ( (source source-code-file) (position source-code-position) )
+  ;; validate that the line and column are in bounds (<= # of lines, <= # of columns in line)
+  (let (
+	(new-position (call-next-method) )
+	)
+    new-position
+    )
+  )
+
+(defmethod source-text ( (source source-code-file) )
+  (with-output-to-string (text)
+    (loop for line across (lines-of source)
+	 do (write-string (text-of line) text)
+	 )
+    )
+  )
+
+(defmethod insert-line ( (source source-code-file) text)
+  (unless (char= (elt text (- (length text) 1) ) #\Newline)
+    (setf text (concatenate 'string text #(#\Newline) ) )
+    )
+  (insert-into (lines-of source) 
+	       (make-instance 'source-code-line :text text) 
+	       (line-at (current-position source))
+	       )
+  (next-line source)
+  )
+
+(defmethod insert-text ( (source source-code-file) (text string) )
+  (loop for c across text
+       do (insert-character source c)
+       )
+  )
+
+(defmethod insert-character ( (source source-code-file) (c character) )
+  (if (= (line-at (current-position source)) (length (lines-of source)) )
+      (insert-into (lines-of source) (make-instance 'source-code-line) (line-at (current-position source)) )
+      )
+  (setf (text-of (current-line source) ) 
+	(insert-into (text-of (current-line source)) c (column-at (current-position source) ) )
+	)
+  (next-column source )
+
+  (when (char= c #\Newline)
+      (multiple-value-bind (old-line new-line) 
+	  (split-line (current-line source) (column-at (current-position source) ) )
+	(setf (current-line source) old-line)
+	(next-line source)
+	(insert-into (lines-of source) new-line 
+		     (line-at (current-position source) )
+		     )
+	(setf (column-at (current-position source) ) 0)
+	)
+      )
+  )
+
+(defmethod insert-into ( array element position)
+  ;; TODO add some type-safety here
+  (unless (and (<= position (length array) ) (>= position 0) )
+    (error "Insert position not in the range of 0 to the length of the array")
+    )
+  (let (
+	(new-array (adjust-array array (+ 1 (length array) ) ) )
+	)
+    (when (> (length array) 1) ;; if was an empty array, nothing to move
+      (loop for point from (- (length new-array) 2) downto position
+	 do (setf (elt new-array (+ 1 point) ) (elt new-array point) )
+	   )
+      )
+    (setf (elt new-array position) element)
+    new-array
+    )
+  )
+
+(defmethod split-line ( (old-line source-code-line) column )
+  (unless (and (<= column (length (text-of old-line) ) ) (>= column 0) )
+    (error "Split position not in the range of 0 to the length of the line")
+    )
+  (let* (
+	 (old-text (subseq (text-of old-line) 0 column) )
+	 (new-text (subseq (text-of old-line) column) )
+	 (new-line (make-instance 'source-code-line :text new-text) )
+	 )
+    (setf (text-of old-line) old-text)
+    (values old-line new-line)
+    )
+  )
+
+(defmethod current-line ( (source source-code-file) )
+  (elt (lines-of source) (line-at (current-position source) ) )
+  )
+
+(defmethod (setf current-line) ( (line source-code-line) (source source-code-file)  )
+  (setf (elt (lines-of source) (line-at (current-position source) ) ) line)
+  )
+
+(defmethod (setf current-line) ( (line string) (source source-code-file) )
+  (setf (current-line source) (make-instance 'source-code-line :text line) )
+  )
+
+(defmethod current-column ( (source source-code-file) )
+  (elt (lines-of source) (column-at (current-position source) ) )
+  )
+
+(defmethod (setf current-column) ( source column)
+  (setf (column-at (current-position source) ) column)
+  )
+
+(defmethod next-column ( (position source-code-position) )
+  (incf (column-at position) )
+  )
+
+(defmethod next-line ( (position source-code-position) )
+  (incf (line-at position) )
+  )
+
+(defmethod next-column ( (source source-code-file) )
+  (next-column (current-position source) )
+  )
+
+(defmethod next-line ( (source source-code-file) )
+  (next-line (current-position source) )
+  )
+(defpackage :hh-parse-tests
+  (:use :cl :asdf :lisp-unit :hh-parse)
+   )
+
+(in-package :hh-parse-tests)
+
+;; start fresh--remove any tests that no longer exist
+(remove-all-tests)
+
+
+
+(define-test literal-test
+  (assert-true (node-equal (lit "foo")
+			   (with-input-from-string (is "foo")
+			     (parse is (lit "foo"))
+			     )
+			   )
+	       )
+  (assert-false (with-input-from-string (is "bar")
+		 (parse is (lit "foo"))
+		 )
+	       )
+  (assert-false (with-input-from-string (is "")
+		 (parse is (lit "foo"))
+		 )
+	       )
+  (assert-false (with-input-from-string (is "foo1")
+		 (parse is (lit "foo"))
+		 )
+	       )
+  (assert-false (with-input-from-string (is "1foo")
+		 (parse is (lit "foo"))
+		 )
+	       )
+    )
+
+(define-test alternative-test
+  (assert-true (node-equal (lit "foo")
+			   (with-input-from-string (is "foo")
+			     (parse is (alt (lit "foo")) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foo")
+			   (with-input-from-string (is "foo")
+			     (parse is (alt (lit "foo") (lit "bar") )
+				    )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "bar")
+			   (with-input-from-string (is "bar")
+			     (parse is (alt (lit "foo") (lit "bar") )
+				    )
+			     )
+			   )
+	       )
+  (assert-false (with-input-from-string (is "foob")
+		  (parse is (alt (lit "foo") (lit "bar") )
+			 )
+		  )
+		)
+  (assert-false (with-input-from-string (is "bfoo")
+		  (parse is (alt (lit "foo") (lit "bar") )
+			 )
+		  )
+		)
+  (assert-false (with-input-from-string (is "barfoo")
+		  (parse is (alt (lit "foo") (lit "bar") )
+			 )
+		  )
+		)
+  )
+
+(define-test sequence-test
+  (assert-true (node-equal (lit "foo") 
+			   (with-input-from-string (is "foo")
+			     (parse is (seq (lit "foo")) )
+			     )
+			   )
+	       )
+  (assert-false (with-input-from-string (is "bar")
+		 (parse is (seq (lit "foo")) )
+		 )
+	       )
+  (assert-false (with-input-from-string (is "")
+		 (parse is (seq (lit "foo")) )
+		 )
+	       )
+  (assert-false (with-input-from-string (is "foo1")
+		 (parse is (seq (lit "foo")) )
+		 )
+	       )
+  (assert-false (with-input-from-string (is "1foo")
+		 (parse is (seq (lit "foo")) )
+		 )
+	       )
+  )
+
+(define-test repeat-test
+  (assert-true (node-equal (lit "foo")
+			   (with-input-from-string (is "foo")
+			     (parse is (rep (lit "foo")) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foobar")
+			   (with-input-from-string (is "foobar")
+			     (parse is (seq (rep (lit "foo")) (lit "bar")) )
+			     )
+			   )
+	       )
+  (assert-false (with-input-from-string (is "foob")
+		  (parse is (rep (lit "foo")) )
+		  )
+		)
+  (assert-false (with-input-from-string (is "foof")
+		 (parse is (rep (lit "foo")))
+		 )
+		)
+  (assert-false (with-input-from-string (is "foofo")
+		 (parse is (rep (lit "foo")))
+		 )
+		)
+  (assert-true (node-equal (lit "foobar")
+			   (with-input-from-string (is "foobar")
+			     (parse is (seq (rep (lit "foo")) (rep (lit "bar"))) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foofoo")
+			   (with-input-from-string (is "foofoo")
+			     (parse is (rep (lit "foo")) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foobarfoobarbaz")
+			   (with-input-from-string (is "foobarfoobarbaz")
+			     (parse is (seq (rep (seq (lit "foo") (lit "bar")) ) (lit "foo") (lit "bar") (lit "baz")) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foo")
+			   (with-input-from-string (is "foo")
+			     (parse is (rep (seq (rep (lit "foo")))) )
+			     )
+			   )
+	       )
+  (assert-true (node-equal (lit "foofoo")
+			   (with-input-from-string (is "foofoo")
+			     (parse is (rep (lit "foo")) )
+			     )
+			   )
+	       )
+  )
+
+(rule simple-capture ()
+      (s slot1 (lit "foo") )
+      :slots (slot1)
+      )
+
+(rule simple-literal-capture ()
+      (s slot1 (lit "foo") (lambda (v) (hh-parse::literal v)) )
+      :slots (slot1)
+      )
+
+(define-test capture-test
+  (assert-true (with-input-from-string (is "foo")
+		 (parse is (simple-capture))
+		 )
+	       )
+  (assert-false (slot-value (with-input-from-string (is "foo")
+			      (parse is (simple-capture))
+			      )
+			    'hh-parse::value
+			    )
+		)
+  (assert-true (node-equal (lit "foo")
+			   (slot-value (with-input-from-string (is "foo")
+					 (parse is (simple-capture))
+					 )
+				       'slot1
+				       )
+			   )
+	       )
+  (assert-true (equal "foo"
+		      (slot-value (with-input-from-string (is "foo")
+				    (parse is (simple-literal-capture))
+				    )
+				  'slot1
+				  )
+		      )
+	       )
+  )
+
+;; Pseudo-HTML grammar for purposes of testing the parser
+(rule tag-name () (rep (cc #'alpha-char-p)) )
+(rule attribute-name () (rep (cc #'alpha-char-p)) )
+(rule number-value () (seq (rep (cc #'digit-char)) 
+			   (opt (seq (lit ".") 
+				     (rep (cc #'digit-char))
+				     ) 
+				)
+			   )
+      )
+
+(rule quantity-value () (alt (number-value)
+			     (seq (number-value) (lit "%"))
+			     (seq (number-value) (lit "pct"))
+			     (seq (number-value) (lit "px"))
+			     )
+      )
+
+(rule string-value () (alt (seq (lit "\"") (cc #'(lambda (c) (char/= c #\"))) (lit "\"") ) 
+			   (seq (lit "'") (cc #'(lambda (c) (char/= c #\'))) (lit "'") )
+			   )
+      )
+
+(rule attribute-value () (alt (number-value)
+			      (quantity-value)
+			      (string-value)
+			      )
+      )
+
+(rule attribute () (seq (attribute-name) (es) (lit "=") (es) (attribute-value)) )
+
+(rule attribute-list () (seq (attribute) (opt (rep (ws) (attribute)) ) ) )
+
+(rule start-tag () (seq (lit "<") (es) (tag-name) (opt (ws) (attribute-list) ) (es) (lit ">") ) )
+(rule end-tag () (seq (lit "<") (es) (lit "/") (es) (tag-name)  (lit ">") ) )
+
+(rule single-tag () (seq (lit "<") (es) (tag-name) (opt (ws) (attribute-list)) (es) (lit "/") (es) (lit ">") ) )
+
+(rule html-text () (rep (cc #'(lambda (c) (char/= c #\<)))) )
+
+(rule tag () (alt (start-tag)
+	       (single-tag)
+	       (start-tag) (es) (html-text) (es) (end-tag)
+	       )
+      )
+
+(define-test tag-parsing-test
+  (assert-true (with-input-from-string (is "foo")
+		 (parse is (rep (cc #'alpha-char-p)))
+		 )
+	       )
+  (assert-true (with-input-from-string (is "foo")
+		 (parse is (tag-name))
+		 )
+	       )
+  )
+
+(run-tests)