t/ref2test.lisp

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