Source

HH-Parse / tests.lisp

(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)