[clinton/parenscript.git] / ref2test.lisp

(in-package :js-test) 
;;Generates automatic tests from the reference

(defparameter +reference-file+ (make-pathname :name "reference"
                                              :type "lisp"
                                              :defaults *load-truename*))
(defparameter +generate-file+ (make-pathname :name "reference-tests"
                                              :type "lisp"
                                              :defaults *load-truename*))

(defparameter +head+ "(in-package :js-test)
;; Tests of everything in the reference.
;; File is generated automatically from the text in reference.lisp by
;; the function make-reference-tests-dot-lisp in ref2test.lisp
;; so do not edit this file.
(def-suite ref-tests)
(in-suite ref-tests)~%~%") ; a double-quote for emacs: "
  
(defun make-reference-tests-dot-lisp()
  (let ((built "")
        heading
        heading-count)
    (with-open-file (out-stream +generate-file+
                                :direction :output
                                :if-exists :supersede)
      (labels 
          ((empty-p (str)
             (zerop (length str)))
           (trim-whitespace (str)
             (string-trim '(#\Space #\Tab #\Newline) str))
           (left (str count)
             (subseq str 0 (min count (length str))))
           (lispify-heading (heading)
             (remove-if (lambda (ch) (or (char= ch #\`)(char= ch #\')))
                        (substitute  #\- #\Space (string-downcase (trim-whitespace heading))
                                     :test #'char=)))
           (clean-quotes (str)
             (substitute  #\' #\"  str :test #'char=))
           (strip-indentation (str indentation)
             (if indentation
                 (js::string-join (mapcar #'(lambda (str)
                                          (if (> (length str) indentation)
                                              (subseq str indentation)
                                              str))
                                      (js::string-split str (list #\Newline)))
                              (string #\Newline))
                 str))

           (make-test ()
             (let* ((sep-pos (search "=>" built))
                    (cr-before-sep  (when sep-pos
                                      (or (position #\Newline
                                                    (left built sep-pos)
                                                    :from-end t
                                                    :test #'char=)
                                          0)))
                    (js-indent-width (when cr-before-sep
                                       (+ 2 (- sep-pos cr-before-sep))))
                    (lisp-part (and sep-pos (left built sep-pos)))
                    (javascript-part (when cr-before-sep
                                       (subseq built (+ 1 cr-before-sep)))))
               (cond
                 ((null sep-pos)
                  (print "Warning, separator not found"))
                 ((search "=>" (subseq built (+ 1 sep-pos)))
                  (print "Error , two separators found"))
                 ((and (string= heading "regular-expression-literals")
                       (= 2 heading-count)) ;requires cl-interpol reader
                  (print "Skipping regex-test two"))
                 ((and lisp-part javascript-part)
                  (format out-stream "(test-ps-js ~a-~a ~%  ~a ~%  ~S)~%~%"
                          heading heading-count
                          (trim-whitespace lisp-part)
                          (clean-quotes (strip-indentation javascript-part js-indent-width))))
                 (t (print "Error, should not be here"))))))
        (format out-stream +head+)
        (with-open-file (stream +reference-file+ :direction :input)
          (loop for line = (read-line stream nil nil)
                with is-collecting
                while line do
                (cond
                  ((string= (left line 4) ";;;#")
                   (setf heading (lispify-heading (subseq line 5)))
                   (setf heading-count 0)
                   (when (string= (trim-whitespace heading)
                                  "the-parenscript-compiler")
                     (return)))
                  ((string= (left line 1) ";") 'skip-comment)
                  ((empty-p (trim-whitespace line))
                   (when is-collecting
                     (setf is-collecting nil)
                     (incf heading-count)
                     (make-test)
                     (setf built "")))
                  (t
                   (setf is-collecting t
                         built (concatenate 'string built
                                            (when (not (empty-p built))
                                              (list #\Newline))
                                            line))))))
        (format out-stream "~%(run! 'ref-tests)~%")))))
Commit	Line	Data
eb17f15c HH	1	(in-package :js-test)
	2	;;Generates automatic tests from the reference
	3
	4	(defparameter +reference-file+ (make-pathname :name "reference"
	5	:type "lisp"
	6	:defaults load-truename))
	7	(defparameter +generate-file+ (make-pathname :name "reference-tests"
	8	:type "lisp"
	9	:defaults load-truename))
	10
	11	(defparameter +head+ "(in-package :js-test)
	12	;; Tests of everything in the reference.
	13	;; File is generated automatically from the text in reference.lisp by
	14	;; the function make-reference-tests-dot-lisp in ref2test.lisp
	15	;; so do not edit this file.
	16	(def-suite ref-tests)
	17	(in-suite ref-tests)~%~%") ; a double-quote for emacs: "
	18
	19	(defun make-reference-tests-dot-lisp()
	20	(let ((built "")
	21	heading
	22	heading-count)
	23	(with-open-file (out-stream +generate-file+
	24	:direction :output
	25	:if-exists :supersede)
	26	(labels
	27	((empty-p (str)
	28	(zerop (length str)))
	29	(trim-whitespace (str)
	30	(string-trim '(#\Space #\Tab #\Newline) str))
	31	(left (str count)
	32	(subseq str 0 (min count (length str))))
	33	(lispify-heading (heading)
	34	(remove-if (lambda (ch) (or (char= ch #\`)(char= ch #\')))
	35	(substitute #\- #\Space (string-downcase (trim-whitespace heading))
	36	:test #'char=)))
	37	(clean-quotes (str)
	38	(substitute #\' #\" str :test #'char=))
	39	(strip-indentation (str indentation)
	40	(if indentation
	41	(js::string-join (mapcar #'(lambda (str)
	42	(if (> (length str) indentation)
	43	(subseq str indentation)
	44	str))
	45	(js::string-split str (list #\Newline)))
	46	(string #\Newline))
	47	str))
	48
	49	(make-test ()
	50	(let* ((sep-pos (search "=>" built))
	51	(cr-before-sep (when sep-pos
	52	(or (position #\Newline
	53	(left built sep-pos)
	54	:from-end t
	55	:test #'char=)
	56	0)))
	57	(js-indent-width (when cr-before-sep
	58	(+ 2 (- sep-pos cr-before-sep))))
	59	(lisp-part (and sep-pos (left built sep-pos)))
	60	(javascript-part (when cr-before-sep
	61	(subseq built (+ 1 cr-before-sep)))))
	62	(cond
	63	((null sep-pos)
	64	(print "Warning, separator not found"))
65	((search "=>" (subseq built (+ 1 sep-pos)))
66	(print "Error , two separators found"))
67	((and (string= heading "regular-expression-literals")
68	(= 2 heading-count)) ;requires cl-interpol reader
69	(print "Skipping regex-test two"))
70	((and lisp-part javascript-part)
71	(format out-stream "(test-ps-js ~a-~a ~% ~a ~% ~S)~%~%"
72	heading heading-count
73	(trim-whitespace lisp-part)
74	(clean-quotes (strip-indentation javascript-part js-indent-width))))
75	(t (print "Error, should not be here"))))))
76	(format out-stream +head+)
77	(with-open-file (stream +reference-file+ :direction :input)
78	(loop for line = (read-line stream nil nil)
79	with is-collecting
80	while line do
81	(cond
82	((string= (left line 4) ";;;#")
83	(setf heading (lispify-heading (subseq line 5)))
84	(setf heading-count 0)
85	(when (string= (trim-whitespace heading)
86	"the-parenscript-compiler")
87	(return)))
88	((string= (left line 1) ";") 'skip-comment)
89	((empty-p (trim-whitespace line))
90	(when is-collecting
91	(setf is-collecting nil)
92	(incf heading-count)
93	(make-test)
94	(setf built "")))
95	(t
96	(setf is-collecting t
97	built (concatenate 'string built
98	(when (not (empty-p built))
99	(list #\Newline))
100	line))))))
101	(format out-stream "~%(run! 'ref-tests)~%")))))