Source

HH-Parse / tests.lisp

Full commit
(defpackage :hh-parse-tests
  (:use :cl :asdf :lisp-unit :hh-utils :hh-parse))

(in-package :hh-parse-tests)

;; start fresh--remove any tests that no longer exist
(remove-all-tests)


;; ---------------------------------------------------------------------------------------------------------------------
;; Sample grammars

(defgrammar grammar-419 S
  (S () (^ (:i E :t S SP) :a))
  (SP () (:e (? S)))
  (E () (:b)))

(defgrammar grammar-420 s
  (s () (l eq r)
     (r))
  (l () (star r)
     (id))
  (r () (l)))

(defgrammar numbers-grammar number  
  ;; literals are digits, decimal, plus, minus
  (integer-term () (digit)
	   (integer-term digit))
  (numeric-value () ( (? (^ plus minus)) integer-term (? decimal integer-term)))
  (number-term () (numeric-value)))

(defgrammar html-grammar document
  ( tag-name ()   (= name identifier) )
  
  ( attribute-name ()  (identifier) )

  (integer-term () 
	   (digit)
	   (integer-term digit))
  (numeric-value () ( (? (^ plus minus)) integer-term (? decimal integer-term)))
  (number-term () (numeric-value))

  (es () (? ws))

  ( quantity-value ()  (^ number-term
		       ( number-term pct-symbol)
		       ( number-term pct)
		       ( number-term px) ) )

  ( attribute-value () (^ quantity-value
			string-value))

  ( attribute ()  (attribute-name es equal-sign es attribute-value))

  ( attribute-list ()  ( attribute (* ws attribute)))

  ( start-tag ()  (lt es tag-name (? ws attribute-list) es gt))

  ( end-tag (reduction #'ignore-terms)  (lt es forward-slash es tag-name  gt))

  ( single-tag ()  (lt es tag-name (? ws attribute-list) es forward-slash es gt))

  ( tag ()  (^ single-tag
	    (start-tag es (* (^ tag html-text)) es end-tag)))
  (document () (tag)))

(deflexer html-lexer (:text)
  (:tag #'digit-char-p digit)
  (:tag #'alpha-char-p identifier :accumulate #'(lambda (nc)
						  (and nc
						       (or (digit-char-p nc) 
							   (alpha-char-p nc)
							   (equal #\_ nc)))))
  (:text #\< lt :state :tag)
  (:tag #\> gt :state :text)
  (:tag #\+ plus)
  (:tag #\- minus)
  (:tag #\. decimal)
  (:tag #\/ forward-slash)
  (:tag #\% percent-symbol)
  (:tag #\= equal-sign)
  (:tag #'whitespace-p ws :accumulate #'whitespace-p)
  (:text t html-text :accumulate #'(lambda (nc) (char/= #\< nc))))

;; =====================================================================================================================
;;
;; Parsing tests
;;
;; =====================================================================================================================

(define-test source-text-tests 
  (let ((text "<foo bar=1>borp whaple</foo>"))

    (let ((lexer (make-instance 'html-lexer)))
      (setf (source-text lexer) text)

      (assert-equal (source-text (hh-parse::source lexer)) text))

    (let* ((grammar (html-grammar))
	   (lexer (make-instance 'html-lexer))
	   (parser (make-parser lexer grammar)))
      (setf (source-text parser) text)

      (assert-equal (source-text (hh-parse::source (hh-parse::lexer parser))) text))

    ))

(define-test html-parsing-tests
    (let* ((grammar (html-grammar))
	   (source (make-source "<foo bar=1>borp whaple</foo>"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :succeeded result)
	(assert-equal 'document (car value))))

    (let* ((grammar (html-grammar))
	   (source (make-source "<foo bar=1>borp whaple<p>fwoomer</p>gamp</foo>"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :succeeded result)
	(assert-equal 'document (car value))))

    (let* ((grammar (html-grammar))
	   (source (make-source "<foobar=1>borp whaple</foo>"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :failed result)
	(destructuring-bind (node-type node) value
	  (assert-equal 'identifier node-type)
	  (assert-true (string= "foobar" (ast-node-value node))))))

    (let* ((grammar (html-grammar))
	   (source (make-source "<foo bar=1>borp whaple</foo"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :failed result)
	(destructuring-bind (node-type node) value
	  (assert-equal 'identifier node-type)
	  (assert-true (string= "foo" (ast-node-value node))))))

    (let* ((grammar (html-grammar))
	   (source (make-source "<foo b ar=1>borp whaple</foo>"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :failed result)
	(destructuring-bind (node-type node) value
	  (assert-equal 'ws node-type)
	  (assert-true (string= " " (ast-node-value node))))))

    (let* ((grammar (html-grammar))
	   (source (make-source "<foo>"))
	   (lexer (make-instance 'html-lexer :source source))
	   (parser (make-parser lexer grammar)))
      (multiple-value-bind (result value) (parse-input parser)
	(assert-equal :failed result)
	(destructuring-bind (node-type node) value
	  (assert-equal 'gt node-type)
	  (assert-true (char= #\>) (ast-node-value node)))))

    )

;; =====================================================================================================================
;;
;; Source tests
;;
;; =====================================================================================================================
(define-test source-code-file-tests
  (let ((text "hello world!
")
	(src (make-instance 'source-code-file)))
    (setf (source-text src) text)
    (assert-equal text (source-text src) )
    (assert-true (hh-parse::positions-equal (current-position src)
					    (make-instance 'source-code-position :line 1 :column 0)))
    (assert-equal 2 (length (lines-of src)))))

(run-tests)