)"))
+
(defun page-node-p (node)
"Is the node (from the lossless parser) a new-page (^L) character?"
@@ -82,7 +84,7 @@ breeze project (system)."
:with page = nil
:for node :in
(tree state)
- :when (page-node-p node)
+ :when (and page (page-node-p node))
:do (push (nreverse page) pages)
(setf page nil)
:do (push node page)
@@ -91,18 +93,28 @@ breeze project (system)."
(push (nreverse page) pages))
(return (nreverse pages))))
-;; TODO rename to parse-system-file, maybe (probably)?
+
+
+(defun enough-breeze (pathname)
+ "Given a pathname, return the relative pathname from the root of the
+breeze project (system)."
+ (uiop:enough-pathname
+ pathname
+ (asdf:system-source-directory 'breeze)))
+
+
(defun parse-system (&optional (system 'breeze))
"Parse (with lossless-reader) all files we want to include."
- ;; TODO include files from other systems in this project.
;; TODO include all files that are tracked under git...
(loop
- :for file :in (breeze.asdf:system-files
- system
- :include-asd (asdf:primary-system-p system))
+ :for file :in (sort (breeze.asdf:find-all-related-files system)
+ #'string<
+ :key #'namestring)
:for filename = (enough-breeze file)
:for content-str = (alexandria:read-file-into-string file)
- :for state = (parse content-str)
+ :for state = (progn
+ (format *trace-output* "~&Parsing file ~s..." file)
+ (parse content-str))
:collect (list filename state (pages state))))
#++
@@ -112,8 +124,8 @@ breeze project (system)."
;; TODO move to utils; add tests...
(defun nrun (list predicate)
- "If the first element of LIST satisfies PREDICATE, destructively
-extract the first run of elements that satisfies PREDICATE. Returns
+ "Destructively extract the first run of elements that satisfies
+PREDICATE, if the first element of LIST satisfies PREDICATE, . Returns
the run and update LIST's first cons to point to the last element of
the run."
(when (and list
@@ -156,6 +168,7 @@ the run."
list))
;; => (1 3), (3 4 5)
+
(defun line-comment-or-ws (node)
(and node
@@ -171,9 +184,6 @@ the run."
(let ((node-list (tree (parse (format nil "; c~% (+ 2 2) #| |#")))))
(group-line-comments node-list))
-;; (defun render-line-comments (nodes))
-
-
(defun page-title-node (page)
"Try to infer the page's title. (Reminder: page is a list of node)"
(loop
@@ -186,7 +196,63 @@ the run."
(defun render-line-comment (out comment)
(format out "~{~a
~%~}"
- (paragraphs comment)))
+ (paragraphs (escape-html comment))))
+
+#++
+(defun render-node (out state node)
+ (format out "~a"
+ (escape-html
+ (node-content state node))))
+
+
+;; This assumes the packages are loaded in the current image!
+(defun cl-token-p (string)
+ (multiple-value-bind
+ (value error)
+ (ignore-errors (read-from-string string))
+ (and (not (typep error 'error))
+ (eq #.(find-package "CL")
+ (symbol-package value)))))
+
+(defun token-style (state node)
+ (if (valid-node-p node)
+ (let ((content (node-content state node)))
+ (cond
+ ((char= #\: (char content 0)) 'keyword)
+ ((numberp (ignore-errors (read-from-string content))) 'number)
+ ((alexandria:starts-with-subseq "check-" content) 'special)
+ ((position #\: content) 'symbol)
+ ((cl-token-p content) 'symbol)))
+ 'syntaxerror))
+
+(defun render-escaped (out string)
+ (write-string (escape-html string) out))
+
+(defun escaped-node-content (state node)
+ (escape-html (node-content state node)))
+
+(defun render-node (out state node &optional (depth 0))
+ (case (node-type node)
+ (string
+ (format out "~a"
+ (escaped-node-content state node)))
+ (token
+ (alexandria:if-let ((style (token-style state node)))
+ (format out "~a"
+ (token-style state node)
+ (node-content state node))
+ (render-escaped out (node-content state node))))
+ (parens
+ (format out "("
+ (valid-node-p node)
+ (min (1+ depth) 6))
+ (map nil (lambda (node)
+ (render-node out state node (1+ depth)))
+ (node-children node))
+ (format out ")"))
+ (t (format out "~a"
+ (string-downcase (node-type node))
+ (escaped-node-content state node)))))
(defun render-page (out state page)
"Render 1 page as html, where PAGE is a list of nodes."
@@ -203,10 +269,11 @@ the run."
(render-line-comment out (remove-leading-semicolons
(source-substring state start end)))))
(;; don't print whitespace nodes
- (whitespace-node-p node))
+ (or (whitespace-node-p node) (page-node-p node)))
(t
- ;; TODO I should escape STRING
- (format out "~%~a
" (node-content state node))))))
+ (format out "~%")
+ (render-node out state node)
+ (format out "~%
")))))
(defmacro with-html-file ((stream-var filename) &body body)
`(alexandria:with-output-to-file (,stream-var
@@ -214,6 +281,7 @@ the run."
:if-exists :supersede)
(labels ((fmt (&rest rest)
(apply #'format out rest)))
+ (fmt "")
(fmt "")
;; https://github.com/emareg/classlesscss
(fmt "")
@@ -259,28 +327,32 @@ the run."
(format nil "docs/listing-~a.html"
(cl-ppcre:regex-replace-all "/" (asdf:coerce-name system) "--")))
+
+
(defun render (system &aux (pathname (system-listing-pathname system)))
- (with-html-file (system out pathname)
- ;; TODO "back to listings"
+ (format *debug-io* "~&Rendering listing for system ~s" system)
+ (with-system-listing (system out pathname)
+ ;; Table of content
(fmt "")
(loop
:for (filename state pages) :in files
:do
(fmt "- ")
(fmt "~a" (link-to-file filename))
- (when (breeze.utils:length>1? pages)
+ (progn ;;when (breeze.utils:length>1? pages)
(fmt "
")
(loop
:for page :in pages
:for i :from 1
:for page-title = (let ((node (page-title-node page)))
(when node
- (breeze.utils:summarize
+ (escape-html
(remove-leading-semicolons (node-content state node)))))
:do (fmt "- ~a
" (link-to-page filename i page-title)))
(fmt "
"))
(fmt " "))
(fmt "
")
+ ;; The actual content
(loop
:for (filename state pages) :in files
:for number-of-pages = (length pages)
@@ -290,41 +362,11 @@ the run."
:for page :in pages
:for i :from 1
:do
- (when (> number-of-pages 1)
- (fmt "Page ~d
" (page-id filename i) i))
+ (if (> number-of-pages 1)
+ (fmt "
" (page-id filename i))
+ (fmt "" (page-id filename i)))
(render-page out state page))))
pathname)
#++
(render 'breeze)
-
-#++
-(mapcar 'render (find-all-breeze-systems))
-
-(defun listings.html ()
- (with-html-file (out (breeze.utils:breeze-relative-pathname "docs/listings.html"))
- (fmt "")
- (loop
- :for system :in (find-all-breeze-systems)
- :for name = (asdf:coerce-name system)
- :for file = (file-namestring (system-listing-pathname system))
- :do (fmt "- ~a
" file name))
- (fmt "
")))
-
-#|
-
-FIXME I originally named this "report" because I wanted
-something "holistic", but now I started calling this "listing", which
-is not holistic.
-
-TODO In the same vein... I would like to have _all_ the listings in
-the same file (currently 1 file per system). I want this because it
-would be easier to convert to something else afterwards.
-
-TODO I _could_ generate objects instead of directly generating
-html... that way it _could_ be possible to generate something else
-than html.
-
-TODO Nice to haves: line numbers
-
-|#
diff --git a/src/string-utils.lisp b/src/string-utils.lisp
new file mode 100644
index 00000000..f7d6b978
--- /dev/null
+++ b/src/string-utils.lisp
@@ -0,0 +1,267 @@
+;;;; String manipulation utilities
+
+(in-package #:breeze.utils)
+
+(deftype string-designator () '(or string character symbol))
+
+(defun optimal-string-alignment-distance (vec-a vec-b)
+ "Compute an edit distance between two vector."
+ (let* ((m (length vec-a))
+ (n (length vec-b))
+ (diff-0 (make-array (list (1+ n)) :element-type 'integer))
+ (diff-1 (make-array (list (1+ n)) :element-type 'integer))
+ (diff-2 (make-array (list (1+ n)) :element-type 'integer)))
+
+ (loop :for i :upto n :do
+ (setf (aref diff-1 i) i))
+ (setf (aref diff-0 0) 1)
+
+ (flet ((a (index) (aref vec-a (1- index)))
+ (b (index) (aref vec-b (1- index)))
+ (diff-0 (index) (aref diff-0 index))
+ (diff-1 (index) (aref diff-1 index))
+ (diff-2 (index) (aref diff-2 index)))
+ (loop :for i :from 1 :upto m :do
+ (loop :for j :from 1 :upto n
+ :for cost = (if (eq (a i) (b j)) 0 1) ;; aka substitution-cost
+ :do
+ (setf (aref diff-0 j) (min
+ (1+ (diff-1 j)) ;; deletion
+ (1+ (diff-0 (1- j))) ;; insertion
+ (+ cost (diff-1 (1- j))) ;; substitution
+ ))
+ ;; transposition
+ (when (and (< 1 i) (< 1 j)
+ (eq (a i) (b (1- j)))
+ (eq (a (1- i)) (b j)))
+ (setf (aref diff-0 j) (min (diff-0 j)
+ (+ cost (diff-2 (- j 2)))))))
+ (when (/= m i)
+ (let ((tmp diff-2))
+ (setf diff-2 diff-1
+ diff-1 diff-0
+ diff-0 tmp
+ (aref diff-0 0) (1+ i)))))
+ (diff-0 n))))
+
+(defun optimal-string-alignment-distance* (vec-a vec-b max-distance)
+ "Compute an edit distance between two vector. Stops as soon as
+max-distance is reached, returns nil in that case."
+ (unless (> (abs (- (length vec-a)
+ (length vec-b)))
+ max-distance)
+ (let* ((m (length vec-a))
+ (n (length vec-b))
+ (diff-0 (make-array (list (1+ n)) :element-type 'integer))
+ (diff-1 (make-array (list (1+ n)) :element-type 'integer))
+ (diff-2 (make-array (list (1+ n)) :element-type 'integer)))
+
+ (loop :for i :upto n :do
+ (setf (aref diff-1 i) i))
+ (setf (aref diff-0 0) 1)
+
+ (flet ((a (index) (aref vec-a (1- index)))
+ (b (index) (aref vec-b (1- index)))
+ (diff-0 (index) (aref diff-0 index))
+ (diff-1 (index) (aref diff-1 index))
+ (diff-2 (index) (aref diff-2 index)))
+ (loop
+ :for min-distance = nil
+ :for i :from 1 :upto m :do
+ (loop :for j :from 1 :upto n
+ ;; aka substitution-cost
+ :for cost = (if (eq (a i) (b j)) 0 1)
+ :do
+ (setf (aref diff-0 j) (min
+ ;; deletion
+ (1+ (diff-1 j))
+ ;; insertion
+ (1+ (diff-0 (1- j)))
+ ;; substitution
+ (+ cost (diff-1 (1- j)))))
+ ;; transposition
+ (when (and (< 1 i) (< 1 j)
+ (eq (a i) (b (1- j)))
+ (eq (a (1- i)) (b j)))
+ (setf (aref diff-0 j) (min (diff-0 j)
+ (+ cost (diff-2 (- j 2))))))
+ (when (or (null min-distance)
+ (> min-distance (diff-0 j)))
+ ;; (format *debug-io* "~&new min-distance ~s" min-distance)
+ (setf min-distance (diff-0 j))))
+ ;; (format *debug-io* "~&~s ~s" i diff-0)
+ (when (and (> i 1)
+ (>= min-distance max-distance))
+ #+ (or)
+ (format *debug-io* "~&min-distance ~s > max-distance ~s"
+ min-distance max-distance)
+ (return-from optimal-string-alignment-distance*))
+ (when (/= m i)
+ (let ((tmp diff-2))
+ (setf diff-2 diff-1
+ diff-1 diff-0
+ diff-0 tmp
+ (aref diff-0 0) (1+ i)))))
+ (diff-0 n)))))
+
+
+
+(defun repeat-string (n string &optional stream)
+ (if stream
+ (loop :repeat n :do (write-string string stream))
+ (with-output-to-string (output)
+ (repeat-string n string output))))
+
+
+
+(defun split-by-newline (string)
+ (uiop:split-string string :separator '(#\Newline)))
+
+#++
+(split-by-newline "a
+b
+c")
+
+
+
+(defun indent-string (indentation string)
+ "Prepend INDENTATION spaces at the beginning of each line in STRING."
+ (check-type indentation (integer 0))
+ (with-input-from-string (input string)
+ (with-output-to-string (output)
+ (loop :for line = (read-line input nil nil)
+ :while line
+ :do
+ (repeat-string indentation " " output)
+ (write-string line output)
+ (terpri output)))))
+
+#|
+(indent-string 4 (format nil "a~%b"))
+" a
+b
+"
+|#
+
+(defun leading-whitespaces (string)
+ (with-input-from-string (input string)
+ ;; Skip the first line
+ (when (read-line input nil nil)
+ (loop :for line = (read-line input nil nil)
+ :while line
+ :for leading-whitespaces = (position-if-not #'whitespacep line)
+ :when leading-whitespaces
+ :minimize leading-whitespaces))))
+
+(defun remove-indentation (string)
+ (let ((indentation (leading-whitespaces string)))
+ (with-input-from-string (input string)
+ (with-output-to-string (output)
+ (loop :for line = (read-line input nil nil)
+ :while line
+ :for leading-whitespaces = (position-if-not #'whitespacep line)
+ :if (and leading-whitespaces
+ (>= leading-whitespaces indentation))
+ :do (write-string (subseq-displaced line indentation) output)
+ :else
+ :do (write-string line output)
+ :do (write-char #\newline output))))))
+
+;; TODO IIRC this function sucked, I think it might just need some
+;; *print- variables set to the right thing... TO TEST
+(defun print-comparison (stream string1 string2)
+ "Print two (close) string in a way that the difference are easier to see."
+ (let* ((mismatch (mismatch string1 string2)))
+ (format stream "~&~a~%~a|~%~a"
+ string1
+ (if (null mismatch)
+ ""
+ (repeat-string mismatch "="))
+ string2)))
+
+#|
+(print-comparison nil "abc" "adc")
+
+(print-comparison nil "abce" "abcd")
+
+(print-comparison nil
+(string-downcase 'system-files)
+(string-downcase 'sytsem-files))
+"system-files
+==|
+sytsem-files"
+|#
+
+
+;; all this to get rid of cl-ppcre xD
+(defun remove-parentheses (string)
+ "Return new string with the parts between parentheses removed, along
+with the spaces following the closing parentheses. Do not support
+nested parentheses."
+ (with-output-to-string (o)
+ (loop
+ :with skipping
+ :for c across string
+ :do (cond
+ ;; Opening paren
+ ((and (not skipping)
+ (char= #\( c))
+ (setf skipping c))
+ ;; Closing paren
+ ((and skipping
+ (char= #\) c))
+ (setf skipping c))
+ ;; Common case
+ ((not skipping) (write-char c o))
+ ;; Non-space char after closing paren
+ ((and skipping
+ (char= #\) skipping)
+ (char/= #\Space c))
+ (setf skipping nil)
+ (write-char c o))))))
+
+(defun summarize (string)
+ "Keep only the first sentence, remove parenthesis."
+ (remove-parentheses
+ (alexandria:if-let (position (position #\. string))
+ (subseq string 0 position)
+ string)))
+
+
+;; This is a good candidate for a funtion where the unit tests would
+;; provide great examples for the documentation.
+(defun around (string position &optional (around 10))
+ "Returns part of STRING, from POSITIONITION - AROUND to POSITIONITION +
+AROUND. Add elipseses before and after if necessary."
+ (let* ((min-size (1+ (* 2 around)))
+ (before (- position around))
+ (start (max 0 before))
+ (after (+ start min-size))
+ (end (min (length string) after))
+ (start (max 0 (min start (- end min-size))))
+ (ellipsis-left (max 0 (min 3 start)))
+ (ellipsis-right (max 0 (min 3 (- (length string) end)))))
+ (with-output-to-string (out)
+ (loop :for i :below ellipsis-left :do (write-char #\. out))
+ (write-string string out :start start :end end)
+ (loop :for i :below ellipsis-right :do (write-char #\. out)))))
+
+
+(alexandria:define-constant +whitespaces+
+ #. (coerce '(#\Space #\Newline #\Backspace #\Tab #\Linefeed #\Page #\Return
+ #\Rubout)
+ 'string)
+ :test 'equal)
+
+(defun whitespacep (char)
+ "Is CHAR a whitespace?"
+ (position char +whitespaces+ :test #'char=))
+
+(defun trim-whitespace (string)
+ (string-trim +whitespaces+ string))
+
+(defun symbol-package-qualified-name (symbol)
+ "Given a SYMBOL return a string of the form package:symbol."
+ (let ((*print-escape* t)
+ (*package* (find-package "KEYWORD")))
+ (prin1-to-string symbol)))
diff --git a/src/suggestion.lisp b/src/suggestion.lisp
new file mode 100644
index 00000000..885ebe94
--- /dev/null
+++ b/src/suggestion.lisp
@@ -0,0 +1,183 @@
+
+(in-package #:breeze.listener)
+
+
+;; TODO Use a heap to get the N smallest values!
+;; TODO Put that into utils?
+(defmacro minimizing ((var
+ &key
+ (score-var (gensym "score"))
+ tracep)
+ &body body)
+ "Creates both a variable (let) and a function (flet) to keep track
+of the instance of that had the smallest score."
+ (check-type var symbol)
+ `(let ((,var nil)
+ (,score-var))
+ (flet ((,var (new-candidate new-score)
+ ,@(when tracep
+ `((format *debug-io* "~&new-candidate: ~s new-score: ~s"
+ new-candidate new-score)))
+ (when (and new-score
+ (or
+ ;; if it wasn't initialized already
+ (null ,var)
+ ;; it is initialized, but score is better
+ (< new-score ,score-var)))
+ (setf ,var new-candidate
+ ,score-var new-score))))
+ ,@body
+ (values ,var ,score-var))))
+
+
+(defun find-most-similar-symbol (input)
+ (minimizing (candidate)
+ ;; TODO do-symbols only iterate on *package*
+ (do-symbols (sym)
+ (when (fboundp sym)
+ (candidate sym
+ (breeze.utils:optimal-string-alignment-distance*
+ input
+ (string-downcase sym)
+ 3))))))
+
+;; (find-most-similar-symbol "prin") ;; => princ, 1
+
+(defun find-most-similar-package (input)
+ (minimizing (candidate)
+ (loop :for package in (list-all-packages)
+ :for package-name = (package-name package) :do
+ (loop :for name in `(,package-name ,@(package-nicknames package)) :do
+ (candidate name
+ (breeze.utils:optimal-string-alignment-distance*
+ input
+ (string-downcase name)
+ 3))))))
+
+#+ (or)
+(progn
+ (find-most-similar-package "breeze.util")
+ ;; => breeze.utils, 1
+
+ (find-most-similar-package "commmon-lisp")
+ ;; => "COMMON-LISP", 1
+ )
+
+(defun find-most-similar-class (input)
+ (minimizing (candidate)
+ (do-symbols (sym)
+ (when (classp sym)
+ (candidate sym
+ (breeze.utils:optimal-string-alignment-distance*
+ input
+ (string-downcase sym)
+ 3))))))
+
+(defvar *last-invoked-restart* nil
+ "For debugging purposes only")
+
+(defun resignal-with-suggestion-restart (input candidate condition)
+ ;; Ok, this is messy as hell, but it works
+ (unless
+ ;; We install a new restart
+ (with-simple-restart (use-suggestion
+ "Use \"~a\" instead of \"~a\"."
+ candidate input)
+ ;; with-simple-restart returns the _last evaluated_ form
+ t
+ ;; Then we signal the condition again
+ (error condition))
+ ;; with-simple-restart will return nil and t if the restart was
+ ;; invoked
+ (let ((use-value (find-restart 'use-value condition)))
+ (setf *last-invoked-restart* (list candidate))
+ (format *debug-io* "~&About to invoke the restart ~s with the value ~s."
+ use-value
+ candidate)
+ (invoke-restart use-value candidate))))
+
+(defun suggest (input candidate condition)
+ (message "Did you mean \"~a\"?" candidate)
+ (when candidate
+ (let ((restart (find-restart 'use-value condition)))
+ (or
+ (and restart (resignal-with-suggestion-restart
+ input candidate condition))
+ (warn "Did you mean \"~a\"?~%~a"
+ candidate
+ (breeze.utils:indent-string
+ 2
+ (breeze.utils:print-comparison
+ nil
+ (string-downcase candidate)
+ input)))))))
+
+(defgeneric condition-suggestion-input (condition)
+ (:documentation "Get input for \"find-most-similar-*\" functions from a condition")
+ ;; Default implementation
+ (:method (condition)
+ (cell-error-name condition))
+ (:method ((condition undefined-function))
+ (format *debug-io* "~&1")
+ (cell-error-name condition))
+ (:method ((condition package-error))
+ (let ((package-designator
+ (package-error-package condition)))
+ (if (stringp package-designator)
+ package-designator
+ #+sbcl ;; only tested on sbcl
+ (car
+ (slot-value condition
+ 'sb-kernel::format-arguments)))))
+ #+sbcl
+ (:method ((condition sb-ext:package-does-not-exist))
+ (package-error-package condition))
+ #+sbcl
+ (:method ((condition sb-pcl:class-not-found-error))
+ (sb-kernel::cell-error-name condition)))
+
+;; (trace condition-suggestion-input)
+
+(defmacro defun-suggest (types)
+ `(progn
+ ,@(loop
+ :for type :in types
+ :collect
+ `(defun ,(symbolicate 'suggest- type) (condition)
+ (let* ((input (string-downcase (condition-suggestion-input condition)))
+ (candidate (,(symbolicate 'find-most-similar- type) input)))
+ #+ (or)
+ (format *debug-io*
+ ,(format nil
+ "~~&candidate ~(~a~): ~~s"
+ type)
+ candidate)
+ (if candidate
+ (suggest input candidate condition)
+ (error condition)))))))
+
+(defun-suggest
+ (symbol
+ package
+ class))
+
+(defvar *last-condition* nil
+ "For debugging purposose only.")
+
+
+(defun call-with-correction-suggestion (function)
+ "Funcall FUNCTION wrapped in a handler-bind form that suggest corrections."
+ (handler-bind
+ ((error #'(lambda (condition)
+ (setf *last-condition* condition)
+ (error condition))))
+ (handler-bind
+ ;; The order is important!!!
+ ((undefined-function #'suggest-symbol)
+ #+sbcl (sb-ext:package-does-not-exist #'suggest-package)
+ #+sbcl (sb-int:simple-reader-package-error #'suggest-symbol)
+ #+ (or)
+ (package-error #'suggest-package)
+ #+sbcl
+ (sb-pcl:class-not-found-error #'suggest-class))
+ (funcall function))))
diff --git a/src/test-file.lisp b/src/test-file.lisp
new file mode 100644
index 00000000..04800df8
--- /dev/null
+++ b/src/test-file.lisp
@@ -0,0 +1,135 @@
+
+(cl:in-package :cl-user)
+
+(defpackage #:breeze.test-file
+ (:documentation "Parsing test files inspired by emacs' ERT's .erts files.")
+ (:use #:cl)
+ (:import-from #:alexandria
+ #:symbolicate
+ #:when-let
+ #:make-keyword)
+ (:import-from #:breeze.utils
+ #:whitespacep
+ #:trim-whitespace
+ #:with-collectors
+ #:with)
+ (:export #:read-spec-file))
+
+(in-package #:breeze.test-file)
+
+(defun string-bool (string)
+ "If string is a representation of T or NIL, then coerce it."
+ (cond
+ ((string-equal string "nil") nil)
+ ((string-equal string "t") t)
+ (t string)))
+
+(defun part-delimiter-p (string)
+ (and string
+ (string= (trim-whitespace string) "=-=")))
+
+(defun end-delimiter-p (string)
+ (and string
+ (string= (trim-whitespace string) "=-=-=")))
+
+
+
+(defun read-spec-file (pathname)
+ (with
+ ((open-file (stream pathname))
+ (collectors (tests parts))
+ (let ((attributes (make-hash-table))
+ (eof (gensym "eof"))))
+ (macrolet
+ ((push-char () `(write-char c out))))
+ (labels
+ ((peek (&optional (peek-type t))
+ (peek-char peek-type stream nil eof))
+ (get-char () (read-char stream))
+ (eofp (x) (eq eof x))
+ (clean-attributes () (remhash :skip attributes))
+ (trim-last-newline (string)
+ (let* ((end (1- (length string))))
+ (if (char= #\Newline (char string end))
+ (subseq string 0 end)
+ string)))
+ (read-comment (c)
+ (when (char= #\; c)
+ (read-line stream nil t)))
+ (read-string (string)
+ (loop :for c :across string
+ :do (char= c (get-char))))
+ (read-test (c)
+ (when (char= #\= c)
+ (with-output-to-string (out)
+ (read-string #. (format nil "=-=~%"))
+ (loop :for line = (read-line stream)
+ :do (cond
+ ((part-delimiter-p line)
+ (push-parts (trim-last-newline (get-output-stream-string out))))
+ ((end-delimiter-p line)
+ (push-parts (trim-last-newline (get-output-stream-string out)))
+ (push-tests `(,@(alexandria:hash-table-plist attributes)
+ :parts ,(drain-parts)))
+ (peek) ;; skip whitespaces
+ (clean-attributes)
+ (return-from read-test t))
+ ((string= "\\=-=" line)
+ (write-string line out :start 1)
+ (write-char #\newline out))
+ (t (write-string line out)
+ (write-char #\newline out)))))))
+ (read-attribute-name ()
+ (make-keyword
+ (string-upcase
+ (with-output-to-string (out)
+ (loop :for c = (get-char)
+ :until (char= c #\:)
+ :do (write-char c out))))))
+ (read-attribute-value ()
+ (string-bool
+ (trim-whitespace
+ (with-output-to-string (out)
+ (loop
+ :for nl = nil :then (or (char= #\Linefeed c)
+ (char= #\Return c))
+ :for c = (peek nil)
+ :until (or (eofp c)
+ (and nl (not (whitespacep c))))
+ :do
+ ;; (format t "~%c = ~s nl = ~s" c nl)
+ (if (read-comment c)
+ (unread-char (setf c #\Return) stream)
+ (write-char (get-char) out)))))))
+ (read-attribute ()
+ (let ((name (read-attribute-name))
+ (value (read-attribute-value)))
+ (setf (gethash name attributes) value))))))
+ (loop
+ :for c = (peek)
+ :repeat 250 ;; guard
+ :until (eofp c)
+ :for part = (or
+ (whitespacep c)
+ (read-comment c)
+ (read-test c)
+ (read-attribute))
+ ;; :do (format t "~&~s" part)
+ )
+ ;; (format t "~&Final: ~% ~{~s~%~}" (tests))
+ (tests)))
+
+#++
+(defparameter *structural-editing-tests*
+ (read-spec-file
+ (asdf:system-relative-pathname
+ "breeze" "scratch-files/notes/strutural-editing.lisp")))
+
+
+#++
+(loop :for test :in *structural-editing-tests*
+ :do (format t "~&~a: ~a parts"
+ (getf test :name)
+ (length (getf test :parts)))
+ ;; :do (print )
+ )
diff --git a/src/thread.lisp b/src/thread.lisp
index 9e94d0db..3e6f3a48 100644
--- a/src/thread.lisp
+++ b/src/thread.lisp
@@ -25,6 +25,11 @@
t)))
(bt:all-threads))))
+(defun find-threads-by-prefix (prefix &key (exclude-self-p t))
+ (find-threads #'(lambda (thread)
+ (alexandria:starts-with-subseq prefix (bt:thread-name thread)))
+ exclude-self-p))
+
(defun find-threads-by-name (name &key (exclude-self-p t))
(find-threads #'(lambda (thread)
(string= (bt:thread-name thread) name))
diff --git a/src/utils.lisp b/src/utils.lisp
index 28ee22fb..954eae62 100644
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -2,35 +2,91 @@
(defpackage #:breeze.utils
(:use :cl)
(:documentation "Utilities")
+ (:import-from #:alexandria #:symbolicate)
(:export
+ #:string-designator
#:around
- #:package-apropos
#:optimal-string-alignment-distance
#:optimal-string-alignment-distance*
- #:walk
- #:walk-car
- #:walk-list
+ #:repeat-string
+ #:split-by-newline
#:indent-string
#:remove-indentation
#:print-comparison
#:summarize
- #:breeze-relative-pathname
#:+whitespaces+
+ #:trim-whitespace
#:whitespacep
- #:stream-size
- #:read-stream-range
- #:symbol-package-qualified-name
+ #:symbol-package-qualified-name)
+ (:export
+ #:walk
+ #:walk-car
+ #:walk-list
+ #:package-apropos)
+ (:export
#:before-last
- #:find-version-control-root
- #:find-asdf-in-parent-directories
#:subseq-displaced
- #:length>1?))
+ #:length>1?
+ #:with-collectors)
+ (:export
+ #:stream-size
+ #:read-stream-range)
+ (:export
+ #:breeze-relative-pathname
+ #:find-version-control-root
+ #:find-asdf-in-parent-directories))
(in-package #:breeze.utils)
;;; Other
+(defmacro with (clauses &body body)
+ (loop
+ :for clause :in (reverse clauses)
+ :for (first . rest) = (if (listp clause)
+ clause
+ (list clause))
+ :for symbol-package = (symbol-package first)
+ :for symbol-name = (if (or
+ (eq 'with first)
+ (string= "COMMON-LISP"
+ (package-name symbol-package)))
+ (symbol-name first)
+ (concatenate 'string "WITH-" (symbol-name first)))
+ :do
+ (multiple-value-bind (with status)
+ (find-symbol symbol-name symbol-package)
+ (cond
+ ((null with)
+ (error "Can't find symbol ~A:WITH-~A" (package-name symbol-package) symbol-name))
+ ((eq 'with first)
+ (setf body `((let ((,(first rest) ,@(when (rest rest)
+ `((with ,(rest rest))))))
+ ,@body))))
+ ((and (not (eq *package* symbol-package)) (eq :internal status))
+ (error "The symbol ~s is interal to ~s" with symbol-package))
+ (t (setf body `((,with ,@rest ,@body)))))))
+ (car body))
+
+
+;; TODO make tests
+#++
+(progn
+ (with
+ ((open-file (in "my-file")))
+ test)
+
+ (with
+ ((output-to-string (out)))
+ test)
+
+ (with
+ ((let ((y 42)))
+ (with x (output-to-string (out)
+ (format out "hello ~d" y))))
+ x))
+
;; TODO I don't think I use this
(defun walk (tree fn &optional (recurse-p (constantly t)))
"Walk a tree and call fn on every elements"
@@ -64,218 +120,6 @@
:test #'string-equal))
(list-all-packages)))
-
-;;; String stuff
-
-(defun optimal-string-alignment-distance (vec-a vec-b)
- "Compute an edit distance between two vector."
- (let* ((m (length vec-a))
- (n (length vec-b))
- (diff-0 (make-array (list (1+ n)) :element-type 'integer))
- (diff-1 (make-array (list (1+ n)) :element-type 'integer))
- (diff-2 (make-array (list (1+ n)) :element-type 'integer)))
-
- (loop :for i :upto n :do
- (setf (aref diff-1 i) i))
- (setf (aref diff-0 0) 1)
-
- (flet ((a (index) (aref vec-a (1- index)))
- (b (index) (aref vec-b (1- index)))
- (diff-0 (index) (aref diff-0 index))
- (diff-1 (index) (aref diff-1 index))
- (diff-2 (index) (aref diff-2 index)))
- (loop :for i :from 1 :upto m :do
- (loop :for j :from 1 :upto n
- :for cost = (if (eq (a i) (b j)) 0 1) ;; aka substitution-cost
- :do
- (setf (aref diff-0 j) (min
- (1+ (diff-1 j)) ;; deletion
- (1+ (diff-0 (1- j))) ;; insertion
- (+ cost (diff-1 (1- j))) ;; substitution
- ))
- ;; transposition
- (when (and (< 1 i) (< 1 j)
- (eq (a i) (b (1- j)))
- (eq (a (1- i)) (b j)))
- (setf (aref diff-0 j) (min (diff-0 j)
- (+ cost (diff-2 (- j 2)))))))
- (when (/= m i)
- (let ((tmp diff-2))
- (setf diff-2 diff-1
- diff-1 diff-0
- diff-0 tmp
- (aref diff-0 0) (1+ i)))))
- (diff-0 n))))
-
-(defun optimal-string-alignment-distance* (vec-a vec-b max-distance)
- "Compute an edit distance between two vector. Stops as soon as
-max-distance is reached, returns nil in that case."
- (unless (> (abs (- (length vec-a)
- (length vec-b)))
- max-distance)
- (let* ((m (length vec-a))
- (n (length vec-b))
- (diff-0 (make-array (list (1+ n)) :element-type 'integer))
- (diff-1 (make-array (list (1+ n)) :element-type 'integer))
- (diff-2 (make-array (list (1+ n)) :element-type 'integer)))
-
- (loop :for i :upto n :do
- (setf (aref diff-1 i) i))
- (setf (aref diff-0 0) 1)
-
- (flet ((a (index) (aref vec-a (1- index)))
- (b (index) (aref vec-b (1- index)))
- (diff-0 (index) (aref diff-0 index))
- (diff-1 (index) (aref diff-1 index))
- (diff-2 (index) (aref diff-2 index)))
- (loop
- :for min-distance = nil
- :for i :from 1 :upto m :do
- (loop :for j :from 1 :upto n
- ;; aka substitution-cost
- :for cost = (if (eq (a i) (b j)) 0 1)
- :do
- (setf (aref diff-0 j) (min
- ;; deletion
- (1+ (diff-1 j))
- ;; insertion
- (1+ (diff-0 (1- j)))
- ;; substitution
- (+ cost (diff-1 (1- j)))))
- ;; transposition
- (when (and (< 1 i) (< 1 j)
- (eq (a i) (b (1- j)))
- (eq (a (1- i)) (b j)))
- (setf (aref diff-0 j) (min (diff-0 j)
- (+ cost (diff-2 (- j 2))))))
- (when (or (null min-distance)
- (> min-distance (diff-0 j)))
- ;; (format *debug-io* "~&new min-distance ~s" min-distance)
- (setf min-distance (diff-0 j))))
- ;; (format *debug-io* "~&~s ~s" i diff-0)
- (when (and (> i 1)
- (>= min-distance max-distance))
- #+ (or)
- (format *debug-io* "~&min-distance ~s > max-distance ~s"
- min-distance max-distance)
- (return-from optimal-string-alignment-distance*))
- (when (/= m i)
- (let ((tmp diff-2))
- (setf diff-2 diff-1
- diff-1 diff-0
- diff-0 tmp
- (aref diff-0 0) (1+ i)))))
- (diff-0 n)))))
-
-(defun indent-string (indentation string)
- "Prepend INDENTATION spaces at the beginning of each line in STRING."
- (check-type indentation (integer 0))
- (with-input-from-string (input string)
- (with-output-to-string (output)
- (loop :for line = (read-line input nil nil)
- :while line
- :do (format output "~a~a~%" (str:repeat indentation " ") line)))))
-
-#|
-(indent-string 4 (format nil "a~%b"))
-" a
-b
-"
-|#
-
-(defun leading-whitespaces (string)
- (with-input-from-string (input string)
- ;; Skip the first line
- (when (read-line input nil nil)
- (loop :for line = (read-line input nil nil)
- :while line
- :for leading-whitespaces = (position-if-not #'whitespacep line)
- :when leading-whitespaces
- :minimize leading-whitespaces))))
-
-(defun remove-indentation (string)
- (let ((indentation (leading-whitespaces string)))
- (with-input-from-string (input string)
- (with-output-to-string (output)
- (loop :for line = (read-line input nil nil)
- :while line
- :for leading-whitespaces = (position-if-not #'whitespacep line)
- :if (and leading-whitespaces
- (>= leading-whitespaces indentation))
- :do (write-string (subseq-displaced line indentation) output)
- :else
- :do (write-string line output)
- :do (write-char #\newline output))))))
-
-;; TODO IIRC this function sucked, I think it might just need some
-;; *print- variables set to the right thing... TO TEST
-(defun print-comparison (stream string1 string2)
- "Print two (close) string in a way that the difference are easier to see."
- (let* ((mismatch (mismatch string1 string2)))
- (format stream "~&~a~%~a|~%~a"
- string1
- (if (null mismatch)
- ""
- (str:repeat mismatch "="))
- string2)))
-
-#|
-(print-comparison nil "abc" "adc")
-
-(print-comparison nil "abce" "abcd")
-
-(print-comparison nil
-(string-downcase 'system-files)
-(string-downcase 'sytsem-files))
-"system-files
-==|
-sytsem-files"
-|#
-
-
-(defun summarize (string)
- "Keep only the first sentence, remove parenthesis."
- (cl-ppcre:regex-replace-all
- "\\([^)]*\\) *"
- (alexandria:if-let (position (position #\. string))
- (subseq string 0 position)
- string)
- ""))
-
-
-(defun around (string position &optional (around 10))
- "Returns part of STRING, from POSITIONITION - AROUND to POSITIONITION + AROUND."
- (let* ((min-size (1+ (* 2 around)))
- (before (- position around))
- (start (max 0 before))
- (after (+ start min-size))
- (end (min (length string) after))
- (start (max 0 (min start (- end min-size))))
- (ellipsis-left (max 0 (min 3 start)))
- (ellipsis-right (max 0 (min 3 (- (length string) end)))))
- (with-output-to-string (out)
- (loop :for i :below ellipsis-left :do (write-char #\. out))
- (write-string string out :start start :end end)
- (loop :for i :below ellipsis-right :do (write-char #\. out)))))
-
-
-(alexandria:define-constant +whitespaces+
- #. (coerce '(#\Space #\Newline #\Backspace #\Tab #\Linefeed #\Page #\Return
- #\Rubout)
- 'string)
- :test 'equal)
-
-(defun whitespacep (char)
- "Is CHAR a whitespace?"
- (position char +whitespaces+ :test #'char=))
-
-
-(defun symbol-package-qualified-name (symbol)
- "Given a SYMBOL return a string of the form package:symbol."
- (let ((*print-escape* t)
- (*package* (find-package "KEYWORD")))
- (prin1-to-string symbol)))
-
;;; Stream stuff
@@ -305,10 +149,15 @@ sytsem-files"
(defun breeze-relative-pathname (pathname)
"Returns a pathname relative to breeze's location."
- (if (cl-fad:pathname-relative-p pathname)
+ (if (uiop:relative-pathname-p pathname)
(asdf:system-relative-pathname :breeze pathname)
pathname))
+;; TODO This is kinda like "locate-dominating-file" in emacs, it might
+;; be a better name?
+;;
+;; TODO FIXME I got the condition "Invalid use of :BACK after
+;; :ABSOLUTE." when I called this on breeze's directory
(defun find-witness-in-parent-directories (starting-path witness
&key (test #'uiop:probe-file*))
"Search for a directory called WITNESS in current and parent
@@ -365,3 +214,76 @@ should be easy to add."
:finally (return
(when (cdr rest)
(car rest)))))
+
+(defmacro with-collectors ((&rest collectors) &body body)
+ "Introduce a set of list with functions to push , get, set, etc those
+lists."
+ (let* ((variables (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
+ (labels (loop :for collector :in collectors
+ :for v :in variables
+ :for push = (symbolicate 'push- collector)
+ :for set = (symbolicate 'set- collector)
+ :for drain = (symbolicate 'drain- collector)
+ :append `((,push (x)
+ (unless (car ,v)
+ (setf ,v nil))
+ (let ((new-tail (cons x nil)))
+ (if ,v
+ (setf (cddr ,v) new-tail
+ (cdr ,v) new-tail)
+ (setf ,v (cons new-tail new-tail))))
+ x)
+ (,set (&optional x)
+ (unless ,v
+ (setf ,v (cons nil nil)))
+ (setf (car ,v) (copy-list x)
+ (cdr ,v) (last (car ,v)))
+ x)
+ ((setf ,collector) (new-value) (,set new-value))
+ (,drain () (,collector nil))
+ (,collector (&optional (new-value nil new-value-p))
+ (if new-value-p
+ (prog1 (when ,v (car ,v))
+ (,set new-value))
+ (when ,v (car ,v))))))))
+ `(let ,variables
+ (labels
+ ,labels
+ (declare (ignorable ,@(loop :for (label . rest) :in labels
+ :collect `(function ,label))))
+ ,@body))))
+
+;; TODO make tests
+#++
+(progn
+ (with-collectors (x)
+ (x '(32))
+ (x))
+
+ (with-collectors (x)
+ (x '(32)))
+
+ (with-collectors (x)
+ (push-x 0)
+ (push-x 1)
+ (push-x 3)
+ (x))
+
+ (with-collectors (x y)
+ (push-x 0)
+ (push-y (copy-list (x)))
+ (push-y 4)
+
+ (push-x 1)
+ (x '(a b c))
+ ;; == (setf (x) '(a b c))
+ ;; == (set-x '(a b c))
+
+ (push-x 2)
+ (push-x 3)
+
+ (list (x) (y))
+ ;; == (mapcar #'funcall (list #'x #'y))
+ )
+ ;; => ((A B C 2 3) ((0) 4))
+ )
diff --git a/src/xref.lisp b/src/xref.lisp
index 46aa47f9..da46a762 100644
--- a/src/xref.lisp
+++ b/src/xref.lisp
@@ -6,7 +6,6 @@
#:calls-who
;; Utilities
#:find-packages-by-prefix
- #:find-packages-by-regex
;; Symbol inspection
#:generic-method-p
#:specialp
@@ -28,17 +27,6 @@
(package-name package)))
:collect package))
-(defun find-packages-by-regex (regex &optional (case-insensitive-p t))
- "Find all packages whose name match the regex (case insensitive by default)."
- (loop
- :with scanner = (cl-ppcre:create-scanner regex :case-insensitive-mode
- case-insensitive-p)
- :for package :in (list-all-packages)
- :when (cl-ppcre:scan scanner
- (string-downcase
- (package-name package)))
- :collect package))
-
(defun generic-method-p (symbol)
"Returns T if SYMBOL designates a generic method"
(and (fboundp symbol)
diff --git a/tests/analysis.lisp b/tests/analysis.lisp
new file mode 100644
index 00000000..dd665c4f
--- /dev/null
+++ b/tests/analysis.lisp
@@ -0,0 +1,415 @@
+(defpackage #:breeze.test.analysis
+ (:documentation "Tests for the package breeze.analysis")
+ (:use #:cl #:breeze.analysis)
+ (:import-from #:parachute
+ #:define-test
+ #:define-test+run
+ #:is
+ #:true
+ #:false
+ #:of-type)
+ ;; importing unexported symbols
+ (:import-from #:breeze.pattern
+ #:termp
+ #:term-name)
+ ;; importing unexported symbols
+ (:import-from #:breeze.analysis
+ #:malformed-if-node-p))
+
+(in-package #:breeze.test.analysis)
+
+
+;;; Integrating pattern.lisp and lossless-parser.lisp
+
+(defun normalize-bindings (bindings)
+ "This is only to make it easier to compare the bindings in the tests."
+ (or (eq t bindings)
+ (alexandria:alist-plist
+ (sort (loop :for (key . value) :in bindings
+ :collect (cons (if (termp key)
+ (term-name key)
+ key)
+ value))
+ #'string<
+ :key #'car))))
+
+(defun test-match-parse (pattern string &optional skip-whitespaces-and-comments)
+ (let* ((state (parse string))
+ (*match-skip* (when skip-whitespaces-and-comments
+ #'whitespace-or-comment-node-p))
+ (bindings (match (compile-pattern pattern) state))
+ (bindings (normalize-bindings bindings)))
+ (values bindings state)))
+
+
+
+(define-test+run "match pattern nil and (nil) against parse trees"
+ ;; pattern nil
+ (loop
+ :for skip-p :in '(nil t)
+ :do (progn
+ ;; TODO I'm not sure what should be the right things
+ ;; - on one hand the parse tree _is_ nil
+ ;; - on the other hand, (read "") would error
+ ;; (false (test-match-parse nil ""))
+ (false (test-match-parse nil " " skip-p))
+ (false (test-match-parse nil "; hi" skip-p))
+ (false (test-match-parse nil "#| hi |#" skip-p))
+ (false (test-match-parse nil "nil" skip-p))
+ (false (test-match-parse nil "NIL" skip-p))
+ (false (test-match-parse nil "nIl" skip-p))
+ (false (test-match-parse nil "cl:nil" skip-p))
+ (false (test-match-parse nil "cl::nil" skip-p))
+ (false (test-match-parse nil "common-lisp:nil" skip-p))
+ (false (test-match-parse nil "common-lisp::nil" skip-p))
+ (false (test-match-parse nil "common-lisp-user::nil" skip-p))
+ (false (test-match-parse nil "common-lisp-user:nil" skip-p))))
+ (progn
+ (false (test-match-parse '(nil) ""))
+ (false (test-match-parse '(nil) " "))
+ (false (test-match-parse '(nil) "; hi"))
+ (false (test-match-parse '(nil) "#| hi |#"))
+ (true (test-match-parse '(nil) "nil"))
+ (true (test-match-parse '(nil) "NIL"))
+ (true (test-match-parse '(nil) "nIl"))
+ (true (test-match-parse '(nil) "cl:nil"))
+ (true (test-match-parse '(nil) "cl::nil"))
+ (true (test-match-parse '(nil) "common-lisp:nil"))
+ (true (test-match-parse '(nil) "common-lisp::nil"))
+ ;; TODO For now we don't check _all_ the package a symbol might be
+ ;; part of
+ (false (test-match-parse '(nil) "common-lisp-user::nil"))
+ (false (test-match-parse '(nil) "common-lisp-user:nil")))
+ (progn
+ (false (test-match-parse '(nil) "" t))
+ (false (test-match-parse '(nil) " " t))
+ (false (test-match-parse '(nil) "; hi" t))
+ (false (test-match-parse '(nil) "#| hi |#" t))
+
+ (true (test-match-parse '(nil) " nil " t))
+
+ (true (test-match-parse '(nil) " #| t |# NIL" t))
+ (true (test-match-parse '(nil) " nIl" t))
+ (true (test-match-parse '(nil) " ;; look ma!
+ cl:nil" t))
+ (true (test-match-parse '(nil) " #||# cl::nil" t))
+ (true (test-match-parse '(nil) " #|;;|# common-lisp:nil " t))
+ (true (test-match-parse '(nil) " common-lisp::nil " t))
+ ;; TODO For now we don't check _all_ the package a symbol might be
+ ;; part of
+ (false (test-match-parse '(nil) "common-lisp-user::nil" t))
+ (false (test-match-parse '(nil) "common-lisp-user:nil" t))))
+
+(define-test+run "match the patterns t and (t) against parse trees"
+ ;; These should return nil because we're trying to match 1 symbol
+ ;; against a list of nodes (even if that list is empty).
+ (loop
+ :for skip-p :in '(nil t)
+ :do (progn
+ (false (test-match-parse t "" skip-p))
+ (false (test-match-parse t " " skip-p))
+ (false (test-match-parse t "; hi" skip-p))
+ (false (test-match-parse t "#| hi |#" skip-p))
+ (false (test-match-parse t "t" skip-p))
+ (false (test-match-parse t "T" skip-p))
+ (false (test-match-parse t "t" skip-p))
+ (false (test-match-parse t "cl:t" skip-p))
+ (false (test-match-parse t "cl::t" skip-p))
+ (false (test-match-parse t "common-lisp:t" skip-p))
+ (false (test-match-parse t "common-lisp::t" skip-p))
+ ;; TODO For now we don't check _all_ the package a symbol might be
+ ;; part of
+ (false (test-match-parse t "common-lisp-user::t" skip-p))
+ (false (test-match-parse t "common-lisp-user:t" skip-p))
+ (progn
+ (false (test-match-parse t " t" skip-p))
+ (false (test-match-parse t "t " skip-p))
+ (false (test-match-parse t "t ; hi" skip-p))
+ (false (test-match-parse t "; t " skip-p))
+ (false (test-match-parse t "t #| hi |#" skip-p))
+ (false (test-match-parse t "#| t |#" skip-p))
+ (false (test-match-parse t "#| hi |# t" skip-p)))))
+ (progn
+ ;; These should return the same thing whether the match is
+ ;; skipping comments and whitespaces or not.
+ (loop
+ :for skip-p :in '(nil t)
+ :do (progn
+ (false (test-match-parse '(t) "" skip-p))
+ (false (test-match-parse '(t) " " skip-p))
+ (false (test-match-parse '(t) "; hi" skip-p))
+ (false (test-match-parse '(t) "#| hi |#" skip-p))
+ (true (test-match-parse '(t) "t" skip-p))
+ (true (test-match-parse '(t) "T" skip-p))
+ (true (test-match-parse '(t) "t" skip-p))
+ (true (test-match-parse '(t) "cl:t" skip-p))
+ (true (test-match-parse '(t) "cl::t" skip-p))
+ (true (test-match-parse '(t) "common-lisp:t" skip-p))
+ (true (test-match-parse '(t) "common-lisp::t" skip-p))
+ ;; TODO For now we don't check _all_ the package a symbol might be
+ ;; part of
+ (false (test-match-parse '(t) "common-lisp-user::t" skip-p))
+ (false (test-match-parse '(t) "common-lisp-user:t" skip-p))))
+ (progn
+ (false (test-match-parse '(t) "t ; hi"))
+ (false (test-match-parse '(t) "t "))
+ (false (test-match-parse '(t) "t #| hi |#"))
+ (true (test-match-parse '(t) "t ; hi" t))
+ (true (test-match-parse '(t) "t " t))
+ (true (test-match-parse '(t) "t #| hi |#" t))
+ (true (test-match-parse '(t) " t" t))
+ (false (test-match-parse '(t) "; '(t) " t))
+ (false (test-match-parse '(t) "#| t |#" t))
+ (true (test-match-parse '(t) "#| hi |# t" t)))
+ (true (test-match-parse '((t)) " (t) " t))))
+
+;; TODO test pattern 1
+;; TODO test pattern 'x
+;; TODO test pattern :x
+;; TODO test pattern "x"
+;; TODO test pattern "some-node" (I'll have to think about the syntax)
+
+(define-test+run "match terms against parse trees"
+ (progn
+ (is equalp (list :?x nil) (test-match-parse :?x ""))
+ (is equalp (list :?x nil) (test-match-parse :?x "" t))
+ (is equalp
+ (list :?x (list (token 0 1)))
+ (test-match-parse :?x "x"))
+ (is equalp
+ (list :?x (list (whitespace 0 1) (token 1 2)))
+ (test-match-parse :?x " x"))
+ (is equalp
+ (list :?x (list (whitespace 0 1) (token 1 2)))
+ (test-match-parse :?x " x" t)))
+ (progn
+ (false (test-match-parse '(:?x) ""))
+ (false (test-match-parse '(:?x) "" t))
+ (is equalp
+ (list :?x (token 0 1))
+ (test-match-parse '(:?x) "x"))
+ (false (test-match-parse '(:?x) " x"))
+ (is equalp
+ (list :?x (token 1 2))
+ (test-match-parse '(:?x) " x" t))
+ (is equalp
+ (list :?x (parens 0 4 (list (token 1 3))))
+ (test-match-parse '(:?x) "(42)"))
+ (is equalp
+ (list :?x (token 1 3))
+ (test-match-parse '((:?x)) "(42)"))))
+
+(define-test+run "match vector against parse trees"
+ (false (test-match-parse 'x "x"))
+ (true (test-match-parse #(x) "x"))
+ (true (test-match-parse '((x)) "(x)")))
+
+
+;;; Basic tree inspection
+
+#++ ;; Sanity-check
+(mapcar #'read-from-string
+ '("in-package"
+ "common-lisp:in-package"
+ "cl:in-package"
+ "cl-user::in-package"
+ "common-lisp-user::in-package"))
+
+(defun test-in-package-node-p (string)
+ (let* ((state (parse string))
+ (node (first (tree state))))
+ ;; The funky reader macro and quasiquote is to fuck with slime and
+ ;; sly's regex-based search for "(in-package". Without this the
+ ;; rest of the file is evaluated in cl-user by slime and sly.
+ (let ((package-designator-node
+ #.`(,'in-package-node-p state node)))
+ (when package-designator-node
+ (node-content state package-designator-node)))))
+
+(define-test+run in-package-node-p
+ (is equal "x" (test-in-package-node-p "(in-package x)"))
+ (is equal ":x" (test-in-package-node-p "(in-package :x)"))
+ (is equal "#:x" (test-in-package-node-p "(in-package #:x)"))
+ (is equal "\"x\"" (test-in-package-node-p "(in-package \"x\")"))
+ (is equal "x" (test-in-package-node-p "( in-package x )"))
+ (is equal "x" (test-in-package-node-p "( in-package #| ∿ |# x )"))
+ (is equal "x" (test-in-package-node-p "(cl:in-package x)"))
+ (is equal "x" (test-in-package-node-p "(cl::in-package x)"))
+ (is equal "42" (test-in-package-node-p "(cl::in-package 42)"))
+ ;; TODO ? Not sure it's worth it lol...
+ ;; (is equal "x" (test-in-package-node-p "('|CL|::|IN-PACKAGE| x)"))
+ (null (test-in-package-node-p "(cl:)")))
+
+(defun test-malformed-if-node-p (string)
+ (let* ((state (parse string))
+ (node (first (tree state))))
+ (malformed-if-node-p state node)))
+
+#++ ;; WIP
+(define-test+run malformed-if-node-p
+ (false (test-malformed-if-node-p "(if a b c)"))
+ (true (test-malformed-if-node-p "(if a b c d)")))
+
+
+
+(define-test find-node
+ (is equal
+ '((whitespace . 0) (parens . 1) (parens . 1) (parens . 1) (parens . 1)
+ (parens . 1) (parens . 1) (parens . 1) (parens . 1) (whitespace . 2))
+ (loop :with input = " ( loop ) "
+ :with state = (parse input)
+ :for i :from 0 :below (length input)
+ :for path = (find-node i (tree state))
+ :collect (cons (node-type (car path)) (cdr path)))))
+
+(define-test find-path-to-position
+ (is equalp
+ '((whitespace)
+ (parens whitespace)
+ (parens whitespace)
+ (parens token)
+ (parens token)
+ (parens token)
+ (parens token)
+ (parens whitespace)
+ (parens)
+ (whitespace))
+ (loop :with input = " ( loop ) "
+ :with state = (parse input)
+ :for i :from 0 :below (length input)
+ :for path = (find-path-to-position state i)
+ :collect
+ (mapcar (lambda (path)
+ (node-type (car path)))
+ path)
+ #++(list i (length path)))))
+
+
+;;; Fixing formatting issues...
+
+(defun parens-has-leading-whitespaces-p (node)
+ (and (parens-node-p node)
+ (whitespace-node-p (first (node-children node)))))
+
+(defun parens-has-trailing-whitespaces-p (node)
+ (and (parens-node-p node)
+ (whitespace-node-p (alexandria:lastcar (node-children node)))))
+
+(defun cdr-if (condition list)
+ (if condition (cdr list) list))
+
+(defun butlast-if (condition list)
+ (if condition (butlast list) list))
+
+(defun fix-trailing-whitespaces-inside-parens (node)
+ (let ((first-child (parens-has-leading-whitespaces-p node))
+ (last-child (parens-has-trailing-whitespaces-p node)))
+ (if (or first-child last-child)
+ (copy-parens
+ node
+ :children (butlast-if
+ last-child
+ (cdr-if first-child (node-children node))))
+ node)))
+
+
+(defun test-remove-whitespaces (input output)
+ (let* ((input (format nil input))
+ (output (format nil output))
+ (state (parse input)))
+ (breeze.kite:is
+ :comparator 'string=
+ :form `(unparse ,state nil 'fix-trailing-whitespaces-inside-parens)
+ :got (unparse state nil 'fix-trailing-whitespaces-inside-parens)
+ :expected output)))
+
+(define-test+run remove-whitespaces
+ (test-remove-whitespaces "( )" "()")
+ (test-remove-whitespaces "(~%~%~%)" "()")
+ (test-remove-whitespaces "( ) " "() ")
+ (test-remove-whitespaces " ( ) " " () ")
+ ;; TODO handle indentation levels!
+ ;; (test-remove-whitespaces "(;;~% )" "(;;~% )")
+ (test-remove-whitespaces "( x)" "(x)")
+ (test-remove-whitespaces "( x )" "(x)"))
+
+
+
+;;; Testing the linter
+
+(defun test-lint (buffer-string)
+ (lint :buffer-string buffer-string))
+
+
+(define-test+run lint
+ (false (test-lint ""))
+ (false (test-lint ";; "))
+ (is equal '((0 2 :error "Syntax error")) (test-lint "#+"))
+ (false (test-lint "(in-package :cl-user)"))
+ (false (test-lint "(in-package 42)"))
+ (is equal '((0 56 :warning
+ "Package PLEASE-DONT-DEFINE-A-PACKAGE-WITH-THIS-NAME is not currently defined."))
+ (test-lint "(in-package please-dont-define-a-package-with-this-name)"))
+ #++ ;; TODO check if "in-package" is NOT quoted
+ (progn
+ (false (test-lint "'(in-package :PLEASE-DONT-DEFINE-A-PACKAGE-WITH-THIS-NAME)"))
+ (false (test-lint "`(in-package :PLEASE-DONT-DEFINE-A-PACKAGE-WITH-THIS-NAME)")))
+ (is equalp
+ '((1 3 :warning "Extraneous whitespaces."))
+ (test-lint "( )"))
+ (is equalp
+ '((2 4 :warning "Extraneous internal whitespaces."))
+ (test-lint "(x y)"))
+ (is equalp
+ '((3 4 :warning "Extraneous trailing whitespaces.")
+ (1 2 :warning "Extraneous leading whitespaces."))
+ (test-lint "( x )")))
+
+#++ ;; Syntax errors
+(progn
+ (test-lint "(")
+ (test-lint "')")
+ (test-lint "'1")
+ (test-lint "..")
+ (test-lint "( . )")
+ (test-lint "( a . )")
+ (test-lint "( a . b . c )")
+ (test-lint "( a . b c )")
+ (test-lint "#1=")
+ (test-lint "#1=#1#")
+ (test-lint "(;;)")
+ (test-lint "::")
+ (test-lint "x::")
+ (test-lint "::x")
+ (test-lint "a:b:c")
+ (test-lint "a:::b")
+ (test-lint "b:")
+ (test-lint "b::")
+ (test-lint "\\")
+ (test-lint "\\\\") ;; Should be OK
+ (test-lint "|")
+ (test-lint "'")
+ (test-lint "(#++;;)")
+ (test-lint "(#+;;)")
+ (test-lint "(#)")
+ (test-lint ",")
+ (test-lint ",@")
+ (test-lint "`,@x")
+ (test-lint "`(a b . ,@x)") ; "has undefined consequences"
+ ;; TODO "unknown character name"
+ (test-lint "1/0")
+ ;; TODO check for invalid radix
+ (test-lint "#|")
+ (test-lint "#c(a b c d)"))
+
+;; Formatting Style
+#++
+(progn
+ (test-lint "#+ ()")
+ (test-lint " ; this is ok")
+ (test-lint ";I don't like this")
+ (test-lint "; not that"))
+
+#++ ;; Style warnings
+(progn
+ (test-lint "like::%really"))
diff --git a/tests/breeze-test.el b/tests/breeze-test.el
index 50d45e62..4b386d72 100644
--- a/tests/breeze-test.el
+++ b/tests/breeze-test.el
@@ -1,43 +1,87 @@
-;;; These are drafts of tests for breeze.el
+(require 'ert)
-(breeze-eval "(+ 1 2)")
-;; ("" "3 (2 bits, #x3, #o3, #b11)")
+(defun breeze--xor (a b)
+ (or (and a (not b))
+ (and (not a) b)))
-;; Should error
-;; (breeze-eval "")
+(ert-deftest test/breeze--xor ()
+ (should (equal '(nil t t nil)
+ (mapcar (lambda (args)
+ (apply 'breeze--xor args))
+ '((nil nil)
+ (nil t)
+ (t nil)
+ (t t))))))
-(breeze-eval "(error \"oups\")")
-
-(and
- (eq t (breeze-eval-predicate "t"))
- (eq t (breeze-eval-predicate "T"))
- (eq nil (breeze-eval-predicate "nil"))
- (eq nil (breeze-eval-predicate "NIL")))
-
-
-(breeze-interactive-eval "(read)")
+
-(breeze-interactive-eval "(error \"oupsie\")")
+(ert-deftest test/breeze-%symbolicate ()
+ (should (eq 'sly (breeze-%symbolicate2 "sly")))
+ (should (eq 'sly (breeze-%symbolicate2 'sly)))
+ (should (eq 'slime (breeze-%symbolicate2 "slime")))
+ (should (eq 'slime (breeze-%symbolicate2 'slime)))
+ (should (eq 'sly-eval (breeze-%symbolicate2 'sly "eval")))
+ (should (eq 'slime-eval (breeze-%symbolicate2 'slime "eval")))
+ (should (eq 'slime-connected-hook
+ (breeze-%symbolicate2 'slime "connected-hook"))))
-(breeze-check-if-connected-to-listener)
+;; TODO true only if connected!
+(ert-deftest test/breeze-connection ()
+ (should (breeze--xor
+ (breeze-sly-connected-p)
+ (breeze-slime-connected-p)))
+ (should (eq t (breeze-check-if-connected-to-listener))))
+
+(ert-deftest test/breeze-eval ()
+ ;; Integers
+ (should (= (breeze-eval "(+ 1 2)") 3))
+ ;; Strings
+
+ (should (string= (breeze-eval "\"hi\"") "hi"))
+ ;; Symbols
+ (should (eq (breeze-eval "cl:t") t))
+ (should (eq (breeze-eval "cl:nil") nil))
+ (should (eq t (breeze-eval-predicate "t")))
+ (should (eq t (breeze-eval-predicate "T")))
+ (should (eq nil (breeze-eval-predicate "nil")))
+ (should (eq nil (breeze-eval-predicate "NIL"))))
+
+;; TODO Figure out how to evaluate something without triggering the debugger when an error occurs
+;; (ert-deftest breeze-eval-empty-string ()
+;; :expected-result :failed
+;; (breeze-eval ""))
+
+;; (let ((slime-event-hooks (list (lambda (event)
+;; (message "Event: %S" (list (car event)
+;; (length (cdr event))))
+;; nil))))
+;; (breeze-eval "(error \"oups\")"))
+;; (breeze-eval "(read)")
-(breeze-ensure-breeze t)
-
-(breeze-init)
-(breeze-validate-if-package-exists "CL")
+(ert-deftest test/breeze-relative-path ()
+ (should (file-exists-p (breeze-relative-path)))
+ (should (file-exists-p (breeze-relative-path "src/")))
+ (should (file-exists-p (breeze-relative-path "src/breeze.el")))
+ (should (file-exists-p (breeze-relative-path "src/ensure-breeze.lisp"))))
+
+(ert-deftest test/breeze-init ()
+ (should (eq t (breeze-validate-if-package-exists "CL")))
+ (should (eq nil (breeze-validate-if-package-exists "this package probably doesn't exists"))))
;; t
-(breeze-validate-if-package-exists "this package probably doesn't exists")
-;; nil
-(breeze-validate-if-breeze-package-exists)
+;; TODO only after (breeze-ensure)
+;; (should (eq t (breeze-validate-if-breeze-package-exists)))
+
+;; (should (eq t (breeze-ensure)))
-(breeze-system-definition)
+(ert-deftest test/breeze-intergration ()
+ (ert-test-erts-file "breeze.erts"))
diff --git a/tests/breeze.erts b/tests/breeze.erts
new file mode 100644
index 00000000..0bacff5f
--- /dev/null
+++ b/tests/breeze.erts
@@ -0,0 +1,31 @@
+
+Point-Char: |
+
+Name: insert-in-package-cl-user
+Code: breeze-insert-in-package-cl-user
+
+=-=
+|
+=-=
+(cl:in-package #:cl-user)
+=-=-=
+
+
+;; WIP
+;; Name: insert-defun
+;; Code: breeze-insert-defun
+
+;; =-=
+;; |
+;; =-=
+;; (defun a (b c)
+;; )
+;; =-=-=
+
+
+;; Corrections of typos
+;; =-=
+;; |(lost 1 2 3)
+;; =-=
+;; |(list 1 2 3)
+;; =-=-=
diff --git a/tests/command.lisp b/tests/command.lisp
index 5d47f3fe..d5b92f9a 100644
--- a/tests/command.lisp
+++ b/tests/command.lisp
@@ -162,27 +162,27 @@ N.B. \"Requests\" are what the command returns. \"inputs\" are answers to those
;; TODO
(define-test message)
-(define-test context-buffer-string
+(define-test buffer-string
(is string=
"asdf"
- (context-buffer-string
+ (buffer-string
(alexandria:plist-hash-table
'(buffer-string "asdf")))))
;; TODO
-(define-test context-buffer-name)
+(define-test buffer-name)
;; TODO
-(define-test context-buffer-file-name)
+(define-test buffer-file-name)
;; TODO
-(define-test context-point)
+(define-test point)
;; TODO
-(define-test context-point-min)
+(define-test point-min)
;; TODO
-(define-test context-point-max)
+(define-test point-max)
;; TODO Test augment-context-by-parsing-the-buffer
#++
diff --git a/tests/documentation.lisp b/tests/documentation.lisp
index 591fa3a9..c6492179 100644
--- a/tests/documentation.lisp
+++ b/tests/documentation.lisp
@@ -51,4 +51,6 @@
(define-test generate-documentation
- (breeze.documentation::generate-documentation))
+ (with-output-to-string (*trace-output*)
+ (breeze.documentation::generate-documentation)
+ (breeze.report::render 'breeze)))
diff --git a/tests/egraph.lisp b/tests/egraph.lisp
new file mode 100644
index 00000000..a8142293
--- /dev/null
+++ b/tests/egraph.lisp
@@ -0,0 +1,755 @@
+(defpackage #:breeze.test.egraph
+ (:documentation "Tests for the package breeze.egraph.")
+ (:use #:cl #:breeze.egraph)
+ (:import-from #:parachute
+ #:define-test+run
+ #:define-test
+ #:is
+ #:true
+ #:false
+ #:fail)
+ (:import-from #:breeze.egraph
+ #:map-stream
+ #:map-egraph
+ #:stream-eclass
+ #:stream-equivalent-eclasses))
+
+(in-package #:breeze.test.egraph)
+
+(define-test+run eclass
+ (let ((eclass (make-eclass 42 '(x))))
+ (is = 42 (id eclass))
+ (is equalp #(x) (enodes eclass)))
+ (let ((eclass (make-eclass 43 '(a b c))))
+ (is = 43 (id eclass))
+ (is equalp #(a b c) (enodes eclass)))
+ (let ((eclass (make-eclass 44 '(x) 'y)))
+ (is = 44 (id eclass))
+ (is equalp #(x) (enodes eclass))
+ ;; N.B. we use the symbol Y, but really "parents" is supposed to
+ ;; be a hash-table.
+ (is eq 'y (parents eclass))))
+
+(define-test+run "add enode(s) to egraph"
+ (let* ((egraph (make-egraph))
+ (enode 'x)
+ ;; Adding the e-node to the e-graph
+ (id (egraph-add-enode egraph enode))
+ ;; Looking up the newly created e-class by the e-node
+ (eclass (eclass egraph id)))
+ ;; The first e-class we add should have the id 0
+ (is = 0 id)
+ ;; Verifying that the newly created e-class contains the e-node
+ (is eq enode (aref (enodes eclass) 0))
+ ;; Verifying the e-node's e-class
+ (is = id (eclass-id egraph enode)))
+ ;; Here, we add the e-node 'x to an e-graph that already contains it.
+ (let ((egraph (make-egraph)))
+ (egraph-add-enode egraph 'x)
+ (let ((id (egraph-add-enode egraph 'x)))
+ ;; The first e-class we add should have the id 0
+ (is = 0 id)
+ (is = 1 (length (union-find egraph)))
+ (is = 1 (hash-table-count (eclasses egraph)))
+ (is = 1 (hash-table-count (eclasses egraph)))))
+ ;; Here, we add the same _FORM_ twice
+ (let* ((egraph (make-egraph)))
+ (add-form egraph '(+ 1 2))
+ (add-form egraph '(+ 1 2))
+ (is = 3 (length (union-find egraph)))
+ (is = 3 (hash-table-count (eclasses egraph)))
+ (is = 3 (hash-table-count (eclasses egraph))))
+ (let* ((egraph (make-egraph)))
+ (add-form egraph '(+ x y))
+ (add-form egraph '(+ x 2))
+ (add-form egraph '(+ y y))
+ ;; 3 distinct forms + 3 disctinct atoms = 6
+ (is = 6 (length (union-find egraph)))
+ (is = 6 (hash-table-count (eclasses egraph)))
+ (is = 6 (hash-table-count (eclasses egraph)))))
+
+
+
+(define-test+run "enode<"
+ ;; eq
+ (progn
+ (false (enode< #1=#() #1#))
+ (false (enode< #2=1 #2#))
+ (false (enode< 'x 'x)))
+ ;; malformed enodes
+ (progn
+ (false (enode< #() #()))
+ (true (enode< #(x) #(y)))
+ (false (enode< #(x) #(x)))
+ (false (enode< #(y) #(x))))
+ ;; proper enodes with children
+ (progn
+ (false (enode< #() #()))
+ (true (enode< #(x 0) #(y 1)))
+ (false (enode< #(x 0) #(x 0)))
+ (false (enode< #(y 1) #(x 0))))
+ ;; symbols
+ (progn
+ (true (enode< 'x 'y))
+ (false (enode< 'y 'x)))
+ ;; symbols v.s. vectors
+ (progn
+ (true (enode< 'x #()))
+ (false (enode< #() 'x)))
+ ;; symbols v.s. numbers
+ (progn
+ (true (enode< 0 'x))
+ (false (enode< 'x 0)))
+ ;; vectors v.s. numbers
+ (progn
+ (true (enode< 0 #()))
+ (false (enode< #() 0)))
+ ;; numbers v.s. numbers
+ (progn
+ (true (enode< 0 1))
+ (false (enode< 0 0))))
+
+(defun sort-enodes-dump (enodes-dump)
+ (sort enodes-dump #'enode< :key #'second))
+
+(defun dump-enodes (egraph)
+ "Dump EGRAPH's enodes as a normalized list for inspection and
+comparison."
+ (sort-enodes-dump
+ (loop
+ :for enode :being :the :hash-key :of (enode-eclasses egraph)
+ :using (hash-value eclass-id)
+ :collect (list :enode (if (vectorp enode)
+ (copy-seq enode)
+ enode)
+ :eclass-id eclass-id))))
+
+(defun dump-eclass (egraph eclass &aux (eclass-id (id eclass)))
+ "Dump EGRAPH's ECLASS as a list for inspection and comparison."
+ `(:eclass-id ,eclass-id
+ :enodes ,(copy-seq (enodes eclass))
+ ,@(if (plusp (hash-table-count (parents eclass)))
+ (list :parents (sort (alexandria:hash-table-values (parents eclass))
+ #'enode<
+ #++ #'(lambda (a b)
+ (when (and (numberp a))) <)))
+ (list :root))
+ ,@(let ((canonical-id (eclass-find egraph eclass-id)))
+ (unless (= eclass-id canonical-id)
+ (list := canonical-id)))))
+
+(defun sort-eclasses-dump (eclasses-dump)
+ (sort eclasses-dump #'< :key #'second))
+
+(defun dump-eclasses (egraph)
+ "Dump EGRAPH's eclasses as a list for inspection and comparison."
+ (sort-eclasses-dump
+ (loop
+ :for eclass-id :being :the :hash-key :of (eclasses egraph)
+ :using (hash-value eclass)
+ :collect (dump-eclass egraph eclass))))
+
+(defun dump-egraph (egraph)
+ "Dump EGRPAH as a list for inspection and comparison."
+ `(,@(when (plusp (hash-table-count (eclasses egraph)))
+ (list :enodes (dump-enodes egraph)))
+ ,@(when (plusp (hash-table-count (eclasses egraph)))
+ (list :eclasses (dump-eclasses egraph)))
+ ,@(when (pending egraph)
+ (list :pending (pending egraph)))))
+
+(defun normalize-egraph-dump (egraph-dump)
+ (setf #1=(getf egraph-dump :enodes) (sort-enodes-dump #1#)
+ #2=(getf egraph-dump :eclasses) (sort-eclasses-dump #2#)
+ #| TODO maybe normalize "pending" |#))
+
+(defun egraph-dumps-equal-p (egraph-dump1 egraph-dump2)
+ (let ((egraph-dump1 (normalize-egraph-dump (copy-seq egraph-dump1)))
+ (egraph-dump2 (normalize-egraph-dump (copy-seq egraph-dump2))))
+ (equalp egraph-dump1 egraph-dump2)))
+
+
+
+(define-test+run "add enode(s) - snapshot tests"
+ (let* ((egraph (make-egraph)))
+ (is egraph-dumps-equal-p
+ '()
+ (dump-egraph egraph)))
+ (let* ((egraph (make-egraph)))
+ (egraph-add-enode egraph 'x)
+ (is egraph-dumps-equal-p
+ '(:enodes ((:enode x :eclass-id 0))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)))
+ (dump-egraph egraph)))
+ ;; Here, we add the e-node 'x twice
+ (let ((egraph (make-egraph)))
+ (egraph-add-enode egraph 'x)
+ (egraph-add-enode egraph 'x)
+ (is egraph-dumps-equal-p
+ '(:enodes ((:enode x :eclass-id 0))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)))
+ (dump-egraph egraph)))
+ ;; Here, we add the same _FORM_ twice
+ (let* ((egraph (make-egraph)))
+ (add-form egraph '(+ 1 2))
+ (add-form egraph '(+ 1 2))
+ (is egraph-dumps-equal-p
+ '(:enodes ((:enode 1 :eclass-id 0)
+ (:enode 2 :eclass-id 1)
+ (:enode #(+ 0 1) :eclass-id 2))
+ :eclasses ((:eclass-id 0 :enodes #(1) :parents (2))
+ (:eclass-id 1 :enodes #(2) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 0 1)) :root)))
+ (dump-egraph egraph)))
+ (let ((egraph (make-egraph)))
+ (add-form egraph '(+ x y))
+ (add-form egraph '(+ x 2))
+ (add-form egraph '(+ y y))
+ (is egraph-dumps-equal-p
+ '(:enodes ((:enode 2 :eclass-id 3)
+ (:enode x :eclass-id 0)
+ (:enode y :eclass-id 1)
+ (:enode #(+ 0 1) :eclass-id 2)
+ (:enode #(+ 0 3) :eclass-id 4)
+ (:enode #(+ 1 1) :eclass-id 5))
+ :eclasses ((:eclass-id 0 :enodes #(x) :parents (2 4))
+ (:eclass-id 1 :enodes #(y) :parents (2 5))
+ (:eclass-id 2 :enodes #(#(+ 0 1)) :root)
+ (:eclass-id 3 :enodes #(2) :parents (4))
+ (:eclass-id 4 :enodes #(#(+ 0 3)) :root)
+ (:eclass-id 5 :enodes #(#(+ 1 1)) :root)))
+ (dump-egraph egraph)))
+ (let ((egraph (make-egraph)))
+ (add-form egraph '(/ (* a 2) 2))
+ (is egraph-dumps-equal-p
+ '(:enodes ((:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2))
+ (:eclass-id 1 :enodes #(2) :parents (2 3))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root)))
+ (dump-egraph egraph))))
+
+(define-test+run "add enode(s) - snapshot tests - step by step - (+ x y)"
+ (let ((egraph (make-egraph)))
+ (macrolet ((check (when expected)
+ `(is egraph-dumps-equal-p ,expected (dump-egraph egraph)
+ ,when)))
+ (check "after initialization" '())
+ (add-form egraph 'x)
+ (check "after adding the form 'x"
+ '(:enodes ((:enode x :eclass-id 0))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root))))
+ (add-form egraph 'y)
+ (check "after adding the form 'y"
+ '(:enodes ((:enode x :eclass-id 0)
+ (:enode y :eclass-id 1))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)
+ (:eclass-id 1 :enodes #(y) :root))))
+ (add-form egraph '(+ x y))
+ (check
+ "after adding the form '(+ x y)"
+ '(:enodes ((:enode x :eclass-id 0)
+ (:enode y :eclass-id 1)
+ (:enode #(+ 0 1) :eclass-id 2))
+ :eclasses ((:eclass-id 0 :enodes #(x) :parents (2))
+ (:eclass-id 1 :enodes #(y) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 0 1)) :root)))))))
+
+(define-test+run "add enode(s) - snapshot tests - step by step - x is equivalent to y"
+ (let ((egraph (make-egraph)))
+ (macrolet ((check (when expected)
+ `(is egraph-dumps-equal-p ,expected (dump-egraph egraph)
+ ,when)))
+ (check "after initialization" '())
+ (add-form egraph 'x)
+ (check "after adding the form 'x"
+ '(:enodes ((:enode x :eclass-id 0))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root))))
+ (add-form egraph 'y)
+ (check "after adding the form 'y"
+ '(:enodes ((:enode x :eclass-id 0)
+ (:enode y :eclass-id 1))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)
+ (:eclass-id 1 :enodes #(y) :root))))
+ ;; TODO maybe add a convenience method "merge-forms"
+ (merge-eclass egraph
+ (eclass-id egraph 'x)
+ (eclass-id egraph 'y))
+ (check "after merging the e-classes for the enodes 'x and 'y"
+ '(:enodes ((:enode x :eclass-id 0)
+ (:enode y :eclass-id 1))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)
+ (:eclass-id 1 :enodes #(y) :root := 0))
+ :pending (0)))
+ (rebuild egraph)
+ (check "after rebuild"
+ ;; TODO This is technically correct (AFAIU), but it would
+ ;; be nice to catch the cases where we merge eclasses
+ ;; that represents only 1 form.
+ '(:enodes ((:enode x :eclass-id 0)
+ (:enode y :eclass-id 1))
+ :eclasses ((:eclass-id 0 :enodes #(x) :root)
+ (:eclass-id 1 :enodes #(y) :root := 0)))))))
+
+(define-test+run "add enode(s) - snapshot tests - 1 + 1 = 2"
+ (let ((egraph (make-egraph)))
+ (macrolet ((check (when expected)
+ `(is egraph-dumps-equal-p ,expected (dump-egraph egraph)
+ ,when)))
+ (merge-eclass egraph
+ (add-form egraph '2)
+ (prog1 (add-form egraph '(+ 1 1))
+ (check "before merging the e-classes for the enodes '2 and '(+ 1 1)"
+ '(:enodes ((:enode 1 :eclass-id 1)
+ (:enode 2 :eclass-id 0)
+ (:enode #(+ 1 1) :eclass-id 2))
+ :eclasses ((:eclass-id 0 :enodes #(2) :root)
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 1 1)) :root))))))
+ (check "after merging the e-classes for the enodes '2 and '(+ 1 1)"
+ '(:enodes ((:enode 1 :eclass-id 1)
+ (:enode 2 :eclass-id 0)
+ (:enode #(+ 1 1) :eclass-id 2))
+ :eclasses ((:eclass-id 0 :enodes #(2) :root)
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 1 1)) :root := 0))
+ :pending (0)))
+ (rebuild egraph)
+ (check "after rebuild"
+ '(:enodes ((:enode 1 :eclass-id 1)
+ (:enode 2 :eclass-id 0)
+ (:enode #(+ 1 1) :eclass-id 2))
+ :eclasses ((:eclass-id 0 :enodes #(2) :root)
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 1 1)) :root := 0)))))))
+
+
+;; TODO add 2; add (+ (+ 1 1) 1); assert 2 = (+ 1 1) then eclass for
+;; the value "2" should have the same parent all the equivalent
+;; classes. Perhaphs only keep track of the parents in the class
+;; representative?
+(define-test+run "add enode(s) - snapshot tests - 1 + 1 = 2 & 3 + (1 + 1)"
+ (let ((egraph (make-egraph)))
+ (macrolet ((check (when expected)
+ `(is egraph-dumps-equal-p ,expected (dump-egraph egraph)
+ ,when)))
+ (let* ((e2 (add-form egraph '2))
+ (e1+1 (add-form egraph '(+ 1 1)))
+ (e3+ (add-form egraph '(+ 3 (+ 1 1)))))
+ (declare (ignorable e3+))
+ (check "before merging the e-classes for the enodes '2 and '(+ 1 1)"
+ `(:enodes
+ ;; enodes for the value 1, 2 and 3 happen to have the
+ ;; eclass-id 1, 2 and 3.
+ #1=((:enode 1 :eclass-id 1)
+ (:enode 2 :eclass-id ,e2)
+ (:enode 3 :eclass-id 3)
+ (:enode #(+ 1 1) :eclass-id ,e1+1)
+ (:enode #(+ 3 2) :eclass-id ,e3+))
+ :eclasses
+ ((:eclass-id 0 :enodes #(2) :root)
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id 2 :enodes #(#(+ 1 1)) :parents (,e3+))
+ (:eclass-id 3 :enodes #(3) :parents (,e3+))
+ (:eclass-id 4 :enodes #(#(+ 3 2)) :root))))
+ (merge-eclass egraph e2 e1+1)
+ (check "after merging the e-classes for the enodes '2 and '(+ 1 1)"
+ `(:enodes #1#
+ :eclasses
+ ((:eclass-id ,e2 :enodes #(2) :parents (,e3+))
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id ,e1+1 :enodes #(#(+ 1 1)) :parents (,e3+) := ,e2)
+ (:eclass-id 3 :enodes #(3) :parents (,e3+))
+ (:eclass-id ,e3+ :enodes #(#(+ 3 2)) :root))
+ :pending (0)))
+ (rebuild egraph)
+ (check "after rebuild"
+ `(:enodes #1#
+ :eclasses
+ ((:eclass-id ,e2 :enodes #(2) :parents (,e3+))
+ (:eclass-id 1 :enodes #(1) :parents (2))
+ (:eclass-id ,e1+1 :enodes #(#(+ 1 1)) :parents (,e3+) := ,e2)
+ (:eclass-id 3 :enodes #(3) :parents (,e3+))
+ (:eclass-id ,e3+ :enodes #(#(+ 3 2)) :root))))))))
+
+(define-test+run "add enode(s) - snapshot tests - a = a * 2 /2"
+ (let ((egraph (make-egraph)))
+ (macrolet ((check (when expected)
+ `(is egraph-dumps-equal-p ,expected (dump-egraph egraph)
+ ,when))
+ (check-add (form expected)
+ `(progn
+ (add-form egraph ,form)
+ (check ,(format nil "after adding ~(~s~)" form)
+ ,expected)))
+ (check-merge (form1 form2 expected)
+ `(progn
+ (merge-eclass egraph
+ (add-form egraph ,form1)
+ (add-form egraph ,form2))
+ (check ,(format nil "after merging ~(~s and ~s~)"
+ form1 form2)
+ ,expected))))
+ (check-add
+ '(/ (* a 2) 2)
+ '(:enodes ((:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2))
+ (:eclass-id 1 :enodes #(2) :parents (2 3))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root))))
+ (check-merge
+ '(* a 2)
+ '(ash a 1)
+ '(:enodes ((:enode 1 :eclass-id 4)
+ (:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(ash 0 4) :eclass-id 5)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2 5))
+ (:eclass-id 1 :enodes #(2) :parents (2 3))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root)
+ (:eclass-id 4 :enodes #(1) :parents (5))
+ (:eclass-id 5 :enodes #(#(ash 0 4)) :parents (3) := 2))
+ :pending (2)))
+ (check-merge
+ '(/ (* a 2) 2)
+ '(* a (/ 2 2))
+ '(:enodes ((:enode 1 :eclass-id 4)
+ (:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(ash 0 4) :eclass-id 5)
+ (:enode #(* 0 6) :eclass-id 7)
+ (:enode #(/ 1 1) :eclass-id 6)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2 5 7))
+ (:eclass-id 1 :enodes #(2) :parents (2 3 6))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root)
+ (:eclass-id 4 :enodes #(1) :parents (5))
+ (:eclass-id 5 :enodes #(#(ash 0 4)) :parents (3) := 2)
+ (:eclass-id 6 :enodes #(#(/ 1 1)) :parents (7))
+ (:eclass-id 7 :enodes #(#(* 0 6)) :root := 3))
+ :pending (3 2)))
+ (check-merge
+ '(/ 2 2)
+ 1
+ '(:enodes ((:enode 1 :eclass-id 4)
+ (:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(ash 0 4) :eclass-id 5)
+ (:enode #(* 0 6) :eclass-id 7)
+ (:enode #(/ 1 1) :eclass-id 6)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2 5 7))
+ (:eclass-id 1 :enodes #(2) :parents (2 3 6))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root)
+ (:eclass-id 4 :enodes #(1) :parents (5 7) := 6)
+ (:eclass-id 5 :enodes #(#(ash 0 4)) :parents (3) := 2)
+ (:eclass-id 6 :enodes #(#(/ 1 1)) :parents (5 7))
+ (:eclass-id 7 :enodes #(#(* 0 6)) :root := 3))
+ :pending (6 3 2)))
+ (rebuild egraph)
+ (check "after rebuild"
+ '(:enodes ((:enode 1 :eclass-id 4)
+ (:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 0 1) :eclass-id 2)
+ (:enode #(ash 0 4) :eclass-id 5)
+ (:enode #(* 0 6) :eclass-id 3)
+ (:enode #(/ 1 1) :eclass-id 6)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses ((:eclass-id 0 :enodes #(a) :parents (2 5 7))
+ (:eclass-id 1 :enodes #(2) :parents (2 3 6))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :root)
+ (:eclass-id 4 :enodes #(1) :parents (5 7) := 6)
+ (:eclass-id 5 :enodes #(#(ash 0 4)) :parents (3) := 2)
+ (:eclass-id 6 :enodes #(#(/ 1 1)) :parents (2 3))
+ (:eclass-id 7 :enodes #(#(* 0 6)) :root := 3)))))))
+
+
+(define-test+run "can I extract something useful?"
+ (let ((egraph (make-egraph))
+ (input '(/ (* a 2) 2)))
+ (labels ((add* (form)
+ (add-form egraph form))
+ (merge* (form1 form2)
+ (merge-eclass egraph (add* form1) (add* form2)))
+ (dump-eclass* (eclass)
+ (dump-eclass egraph eclass)))
+ (add* input)
+ (merge* '(* a 2)
+ '(ash a 1))
+ (merge* '(/ (* a 2) 2)
+ '(* a (/ 2 2)))
+ (merge* '(/ 2 2)
+ 1)
+ (merge* '(* a 1)
+ 'a)
+ (rebuild egraph)
+ (is egraph-dumps-equal-p
+ '(:enodes
+ ((:enode 1 :eclass-id 4)
+ (:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 8 1) :eclass-id 2)
+ (:enode #(* 8 6) :eclass-id 8)
+ (:enode #(/ 1 1) :eclass-id 6)
+ (:enode #(/ 2 1) :eclass-id 8)
+ (:enode #(ash 8 6) :eclass-id 2))
+ :eclasses
+ ((:eclass-id 0 :enodes #(a) :parents (2 5 7 8) := 8)
+ (:eclass-id 1 :enodes #(2) :parents (2 3 6))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (8))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :parents (2 2 8) := 8)
+ (:eclass-id 4 :enodes #(1) :parents (5 7 8) := 6)
+ (:eclass-id 5 :enodes #(#(ash 0 4)) :parents (3) := 2)
+ (:eclass-id 6 :enodes #(#(/ 1 1)) :parents (2 8))
+ (:eclass-id 7 :enodes #(#(* 0 6)) :root := 8)
+ (:eclass-id 8 :enodes #(#(* 0 4)) :parents (2 2 8))))
+ ;; (add* input) = 3
+ (dump-egraph egraph))
+ ;; Finding the "root eclasses"
+ (is equalp
+ '((:eclass-id 7 :enodes #(#(* 0 6)) :root := 8))
+ (loop
+ :for eclass-id :being
+ :the :hash-key :of (eclasses egraph)
+ :using (hash-value eclass)
+ :when (zerop (hash-table-count (parents eclass)))
+ :collect (dump-eclass egraph eclass))
+ "when trying to find the roots")
+ ;; TODO The following next 2 tests were working because of a bug
+ ;; with how the parents when tracked.
+ #++
+ (is equalp
+ '((:eclass-id 0 :enodes #(a) :parents (2 5 7 8) := 8)
+ (:eclass-id 3 :enodes #(#(/ 2 1)))
+ (:eclass-id 7 :enodes #(#(* 0 6)) := 3)
+ (:eclass-id 8 :enodes #(#(* 0 4))))
+ (mapcar #'dump-eclass* (root-eclasses egraph))
+ "when trying to find the roots and their closure")
+ #++
+ ;; Victory!
+ (is equalp
+ #(a)
+ (smallest-enodes
+ (root-eclasses egraph))))))
+
+
+
+;;; Work in Progress - ematching!
+
+
+(defun make-egraph* (input &rest other-inputs)
+ (let ((egraph (make-egraph)))
+ (add-input egraph input)
+ (map nil (lambda (i) (add-form egraph i)) other-inputs)
+ (rebuild egraph)
+ egraph))
+
+#++
+(progn
+ (defun test-simple-rewrite (input pattern template)
+ (test-simple-rewrite* input (make-rewrite pattern template)))
+ (defun test-simple-rewrite* (input rewrite)
+ (format t "~%~%")
+ (let ((egraph (if (typep input 'egraph) input (make-egraph* input))))
+ (map-egraph #'print egraph :limit 100)
+ (format t "~%~%")
+ (let ((before (dump-egraph egraph))
+ (after (progn (apply-rewrite egraph rewrite)
+ (rebuild egraph)
+ (dump-egraph egraph))))
+ (progn
+ (format t "~%~%")
+ (format t "~&Applying the rewrite rule:~& ~s~& ~s"
+ (rewrite-pattern rewrite)
+ (rewrite-template rewrite))
+ (format t "~%~%")
+ (format t "~&Enodes before:~%~{ ~s~^~%~}" (second before))
+ (format t "~&Enodes after :~%~{ ~s~^~%~}" (second after))
+ (format t "~%~%")
+ (format t "~&Eclasses before:~%~{ ~s~^~%~}" (fourth before))
+ ;; (format t "~&Eclasses after :~%~{ ~s~^~%~}" (fourth after))
+ (format t "~&Eclasses after:")
+ (dolist (eclass-ish (fourth after))
+ (format t "~& ~s's forms:" eclass-ish)
+ (let ((eclass-id (second eclass-ish)))
+ (map-stream #'(lambda (form)
+ (format t "~& ~a" form))
+ (stream-eclass egraph (eclass egraph eclass-id)))))
+ (format t "~%~%")
+ (loop
+ :for input-eclass-id :in (input-eclasses egraph)
+ :do
+ (format t "~&Forms in input e-class ~d:" input-eclass-id)
+ (map-stream
+ (lambda (eclass-id)
+ (map-stream #'(lambda (form)
+ (format t "~&-> ~a" form))
+ (stream-eclass egraph (eclass egraph eclass-id))))
+ (stream-equivalent-eclasses egraph input-eclass-id)
+ :limit 100)
+ ;; (map-egraph #'print egraph :limit 100)
+ ))
+ egraph)))
+
+ #++
+ (let ((egraph (test-simple-rewrite '(/ a a) '(/ ?x ?x) 1)))
+ (test-simple-rewrite egraph 1 '(/ ?x ?x)))
+
+ #++
+ ((untrace)
+ (trace
+ ;; :wherein test-simple-rewrite
+ pattern-substitute
+ breeze.egraph::match-rewrite
+ breeze.egraph::match-eclass
+ breeze.egraph::match-enode
+ ;; merge-eclass
+ add-form
+ breeze.egraph::egraph-add-enode
+ breeze.egraph::form-to-enode
+ breeze.egraph::sequence-to-enode
+ breeze.egraph::atom-to-enode
+ ;; match
+ ;; add-parent
+ ))
+
+ ;; #++
+ (let ((egraph (test-simple-rewrite '(+ a b c) '(+ ?x ?y ?z) '(+ ?x (+ ?y ?z)))))
+ (test-simple-rewrite egraph '(+ ?x ?y ?z) '(+ (+ ?x ?y) ?z))
+ (test-simple-rewrite egraph '(+ ?x ?y) '(+ ?y ?x))
+ (setf *e* egraph))
+
+ #++
+ (let ((egraph (test-simple-rewrite '(* a 2) '(* ?x 2) '(ash ?x 1))))
+ ;; (test-simple-rewrite egraph '(+ ?x ?y ?z) '(+ (+ ?x ?y) ?z))
+ ;; (test-simple-rewrite egraph '(+ ?x ?y) '(+ ?y ?x))
+ (setf *e* egraph))
+
+ #++
+ (let ((egraph (test-simple-rewrite '(+ 1 (* a 2)) '(* ?x 2) '(ash ?x 1))))
+ (test-simple-rewrite egraph '(* ?x 2) '(ash ?x 1))
+ ;; (test-simple-rewrite egraph '(+ ?x ?y ?z) '(+ (+ ?x ?y) ?z))
+ ;; (test-simple-rewrite egraph '(+ ?x ?y) '(+ ?y ?x))
+ (setf *e* egraph))
+
+ #++
+ (let ((egraph (test-simple-rewrite '(/ (* a 2) 2) '(/ (* ?x ?y) ?y) '?x)))
+ (setf *e* egraph))
+
+ ;; '(/ (* a 2) 2)
+ ;; (untrace)
+ )
+
+#|
+Input:
+(+ a b c)
+
+Rewrites (applied in this order):
+'(+ ?x ?y ?z) '(+ ?x (+ ?y ?z))
+'(+ ?x ?y ?z) '(+ (+ ?x ?y) ?z)
+'(+ ?x ?y) '(+ ?y ?x)
+
+Forms represented by the egraph:
+(+ A B C)
+(+ A (+ B C))
+(+ (+ A B) C)
+(+ (+ B C) A)
+(+ C (+ A B))
+|#
+
+
+(define-test+run "apply 1 rewrite"
+ (is egraph-dumps-equal-p
+ '(:enodes
+ ((:enode 2 :eclass-id 1)
+ (:enode a :eclass-id 0)
+ (:enode #(* 3 1) :eclass-id 2)
+ (:enode #(/ 2 1) :eclass-id 3))
+ :eclasses
+ ((:eclass-id 0 :enodes #(a) :parents (2) := 3)
+ (:eclass-id 1 :enodes #(2) :parents (2 3))
+ (:eclass-id 2 :enodes #(#(* 0 1)) :parents (3))
+ (:eclass-id 3 :enodes #(#(/ 2 1)) :parents (2))))
+ (let ((egraph (make-egraph* '(/ (* a 2) 2)))
+ (rewrite (make-rewrite '(/ (* ?x ?y) ?y) '?x)))
+ (apply-rewrite egraph rewrite)
+ (dump-egraph (rebuild egraph))
+ #++ ;; TODO
+ (smallest-enodes
+ (root-eclasses egraph)))))
+
+#++ ;; TODO It would be nice to be able to add a form as a vector into
+;; an egraph. I think it could help with performance, because
+;; applying a rewrite and adding the resulting "substituted" form
+;; would not involve conversion between lists and vectors anymore.
+(let ((egraph (make-egraph)))
+ (add-form egraph #(/ #(* a 2) 2))
+ (dump-egraph egraph))
+
+#++
+(defparameter *e* nil)
+
+
+
+#++
+(let ((egraph (make-egraph* '(/ (* a 2) 2)))
+ (*print-readably* nil)
+ (*print-level* nil)
+ (*print-length* nil))
+ (format t "~&=========================================")
+ (format t "~&=========================================")
+ (format t "~&=========================================")
+ (let ((rewrites
+ (list
+ ;; These are not all sounds
+ (make-rewrite '(/ (* ?x ?y) ?y) '?x)
+ (make-rewrite '(* (/ ?x ?y) ?y) '?x)
+
+ (make-rewrite '(* ?x 2) '(ash ?x 1))
+
+ (make-rewrite '(/ ?x ?x) 1)
+
+ (make-rewrite '(/ (* ?x ?y) ?z) '(* ?x (/ ?y ?z)))
+
+ ;; (make-rewrite '(/ ?x 1) '?x)
+ ;; (make-rewrite '(* ?x 1) '?x)
+ ;; (make-rewrite '(* 1 ?x) '?x)
+ ;; (make-rewrite '(/ 0 ?x) 0)
+ )))
+ (loop :repeat 1
+ :do
+ (format t "~&=========================================")
+ (loop :for rewrite :in rewrites
+ :do (test-simple-rewrite* egraph rewrite)
+ #++ (progn (apply-rewrite egraph rewrite)
+ (rebuild egraph)
+ (map-egraph #'print egraph :limit 100)))))
+ egraph)
+
+;;
+
+#++
+(progn
+ (untrace)
+ (dump-egraph *e*)
+ (map-egraph #'print *e* :limit 100))
+
+
+;; (= 0 ?x) => (zerop x)
+;; (= x ?0) => (zerop x)
+;; (and (zerop ?x (= ?x ?y))) => (= 0 ?x ?y)
diff --git a/tests/listener.lisp b/tests/listener.lisp
new file mode 100644
index 00000000..9af91acf
--- /dev/null
+++ b/tests/listener.lisp
@@ -0,0 +1,7 @@
+
+
+;; TODO eval-last-expression
+'asdf
+'|asdf|
+'|CL|::|IN-PACKAGE|
+;; ^^^ Slime doesn't handle this one correctly
diff --git a/tests/lossless-reader.lisp b/tests/lossless-reader.lisp
index b9ec739b..169ee21b 100644
--- a/tests/lossless-reader.lisp
+++ b/tests/lossless-reader.lisp
@@ -1,69 +1,6 @@
(cl:in-package #:cl-user)
-(defpackage #:breeze.test.lossless-reader
- (:documentation "Test package for #:breeze.lossless-reader")
- (:use #:cl #:breeze.lossless-reader)
- (:import-from #:breeze.lossless-reader
- ;; state
- #:state
- #:source
- #:pos
- #:tree
- #:make-state
- ;; nodes
- #:+end+
- #:node
- #:valid-node-p
- ;; node constructors
- #:block-comment
- #:parens
- #:punctuation
- #:token
- #:whitespace
- #:line-comment
- ;; Symbols used in the returns
- #:quote ; this ones from cl actually
- #:quasiquote
- #:dot
- #:at
- #:comma
- #:sharp
- ;; state utilities
- #:at
- #:donep
- #:valid-position-p
- #:*state-control-string*
- #:state-context
- ;; parsing utilities
- #:read-char*
- #:find-all
- #:not-terminatingp
- #:read-string*
- #:read-while
- ;; sub parser
- #:read-line-comment
- #:read-parens
- #:read-punctuation
- #:read-quoted-string
- #:read-string
- #:read-token
- #:read-whitespaces
- #:read-block-comment
- ;; top-level parsing/unparsing
- #:parse
- #:parse*
- #:unparse)
- (:import-from #:parachute
- #:define-test
- #:define-test+run
- #:is
- #:true
- #:false
- #:of-type)
- (:import-from #:breeze.kite
- #:is-equalp))
-
(in-package #:breeze.test.lossless-reader)
#|
@@ -96,12 +33,6 @@ newline or +end+)
;;; testing helpers
-(defvar *test-strings* (make-hash-table :test 'equal))
-
-(defun register-test-string (string)
- (setf (gethash string *test-strings*) t)
- string)
-
(defmacro with-state ((string &optional more-labels) &body body)
(alexandria:once-only (string)
`(let ((state (make-state (register-test-string ,string))))
@@ -109,9 +40,12 @@ newline or +end+)
;; remainder: the input is only used (unless (equalp got expected))
;; the input is used to give
(labels ((test* (got &optional expected)
- (is-equalp ,string got expected
- *state-control-string*
- (state-context state)))
+ (is-equalp
+ :input ,string
+ :got got
+ :expected expected
+ :description *state-control-string*
+ :format-args (state-context state)))
,@more-labels)
(declare (ignorable (function test*)))
,@ (loop :for (label . _) :in more-labels
@@ -140,6 +74,22 @@ newline or +end+)
,@more-labels)
,@body))
+#++
+(with-state ("asdf")
+ (test* t t))
+
+
+
+#++
+(with-state ("asdf")
+ (format nil "This is a bug: read-any returned an invalid node, but we're not done reading the file...~%~?"
+ *state-control-string*
+ (state-context state)))
+
+#++
+(with-state ("asdf")
+ (state-context state))
+
;;; Reader position (in the source string)
@@ -167,25 +117,37 @@ newline or +end+)
(""
(test* (at state -1) nil)
(test* (at state 0) nil)
- (test* (at state 1) nil)
- (test* (at state -1 #\a) nil)
- (test* (at state 0 #\b) nil)
- (test* (at state 1 #\c) nil))
+ (test* (at state 1) nil))
("c"
(test* (at state -1) nil)
(test* (at state 0) #\c)
- (test* (at state 1) nil)
- (test* (at state -1 #\c) nil)
- (test* (at state 0 #\c) #\c)
- (test* (at state 0 #\a) nil)
- (test* (at state 1 #\c) nil))))
+ (test* (at state 1) nil))))
+
+(define-test+run at=
+ :depends-on (at)
+ (with-state* ()
+ (""
+ (test* (at= state -1 #\a) nil)
+ (test* (at= state 0 #\b) nil)
+ (test* (at= state 1 #\c) nil))
+ ("c"
+ (test* (at= state -1 #\c) nil)
+ (test* (at= state 0 #\c) #\c)
+ (test* (at= state 0 #\a) nil)
+ (test* (at= state 1 #\c) nil))))
;; TODO test "current-char"
(define-test+run current-char)
+;; TODO test "current-char="
+(define-test+run current-char=)
+
;; TODO test "next-char"
(define-test+run next-char)
+;; TODO test "next-char="
+(define-test+run next-char=)
+
;;; Low-level parsing helpers
@@ -233,7 +195,7 @@ newline or +end+)
(defun test-find-all (needle string expected)
(register-test-string string)
(register-test-string needle)
- (is-equalp
+ (is-equalp*
(list 'find-all needle string)
(find-all needle string)
expected))
@@ -263,9 +225,12 @@ newline or +end+)
(defun test-read-block-comment (input expected-end)
(with-state (input)
- (is-equalp input (read-block-comment state)
- (when expected-end
- (block-comment 0 expected-end)))))
+ (is-equalp
+ :input input
+ :got (read-block-comment state)
+ :form `(read-block-comment ,state)
+ :expected (when expected-end
+ (block-comment 0 expected-end)))))
(define-test+run read-block-comment
:depends-on (read-string*)
@@ -289,17 +254,419 @@ newline or +end+)
(when expected-end
(line-comment 0 expected-end)))))
-(define-test+run read-line-comment
+(define-test read-line-comment
(test-read-line-comment "" nil)
- (test-read-line-comment ";" +end+)
- (test-read-line-comment "; asdf~%" 7))
+ (test-read-line-comment ";" 1)
+ (test-read-line-comment "; asdf~%" 6))
+
+
+
+(defparameter *sharpsign-reader-test-cases* (make-hash-table :test 'equal))
+
+(defun test-read-sharpsign* (&key
+ sharpsing-reader-function
+ node-type
+ input
+ expected-end
+ expected-pos
+ expected-children
+ given-numeric-argument)
+ "Helps testing the read-sharpsign-* functions."
+ (let* ((starting-position (if (listp input) (length (first input)) 1))
+ (input (if (listp input) (apply 'concatenate 'string input) input))
+ (expected-end (or expected-end (length input)))
+ (expected-pos (or expected-pos expected-end)))
+ (with-state (input)
+ (setf (pos state) starting-position)
+ (let* ((expected (node node-type 0
+ expected-end
+ expected-children))
+ (got
+ (is-equalp
+ :input input
+ :got (funcall sharpsing-reader-function
+ state
+ ;; Assumes we started reading the
+ ;; # as the first character.
+ 0
+ given-numeric-argument)
+ :form (list sharpsing-reader-function
+ state 0 given-numeric-argument)
+ :expected expected)))
+ (setf (gethash input *sharpsign-reader-test-cases*) expected)
+ (when (and got (plusp expected-end))
+ (is-equalp
+ :input input
+ :expected expected-pos
+ :form `(pos ,state)
+ :got (pos state)
+ :description " the state's position after reading is wrong:"))
+ got))))
+
+
+;;; #\
+
+(defun test-read-sharpsign-backslash (input expected-end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-backslash
+ :node-type 'sharp-char
+ :input input
+ :expected-end expected-end
+ :expected-children (unless (= +end+ expected-end)
+ (token 1 expected-end))))
+
+(define-test+run read-sharpsign-backslash
+ (test-read-sharpsign-backslash "#\\" +end+)
+ (test-read-sharpsign-backslash "#\\ " 3)
+ (test-read-sharpsign-backslash "#\\ " 3)
+ (test-read-sharpsign-backslash "#\\Space" 7)
+ (test-read-sharpsign-backslash "#\\Space " 7)
+ (test-read-sharpsign-backslash "#\\ Space" 8)
+ (test-read-sharpsign-backslash "#\\bell" 6)
+ (test-read-sharpsign-backslash "#\\;" 3))
+
+
+
+;;; #'
+
+(defun test-read-sharpsign-quote (input child expected-end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function #'read-sharpsign-quote
+ :node-type 'sharp-function
+ :input input
+ :expected-end expected-end
+ :expected-children child))
+
+(define-test+run read-sharpsign-quote
+ (test-read-sharpsign-quote "#'" nil +end+)
+ (test-read-sharpsign-quote "#' " (list (whitespace 2 3)) +end+)
+ (test-read-sharpsign-quote "#'a" (list (token 2 3)) 3)
+ (test-read-sharpsign-quote "#' a" (list (whitespace 2 3)
+ (token 3 4))
+ 4)
+ (test-read-sharpsign-quote "#'(lambda...)" (list (parens 2 13
+ (list (token 3 12))))
+ 13))
+
+
+;;; #(
+
+(defun test-read-sharpsign-left-parens (input child expected-end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function #'read-sharpsign-left-parens
+ :node-type 'sharp-vector
+ :input input
+ :expected-end expected-end
+ :expected-children child))
+
+(define-test+run read-sharpsign-left-parens
+ (test-read-sharpsign-left-parens "#()" (parens 1 3) 3)
+ (test-read-sharpsign-left-parens "#( )" (parens 1 4 (whitespace 2 3)) 4)
+ (test-read-sharpsign-left-parens '("#1" "()") (parens 2 4) 4)
+ (test-read-sharpsign-left-parens '("#2" "( )") (parens 2 5 (whitespace 3 4)) 5))
+
+
+;;; #*
+
+(defun test-read-sharpsign-asterisk (input &key child end n)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-asterisk
+ :node-type 'sharp-bitvector
+ :input input
+ :expected-end end
+ :expected-children child
+ :given-numeric-argument n))
+
+(define-test+run read-sharpsign-asterisk
+ (test-read-sharpsign-asterisk '("#" "*"))
+ (test-read-sharpsign-asterisk '("#" "* ") :end 2)
+ (test-read-sharpsign-asterisk '("#" "*0") :child 0)
+ (test-read-sharpsign-asterisk '("#0" "*") :n 0)
+ (test-read-sharpsign-asterisk '("#2" "*0") :child 0)
+ (test-read-sharpsign-asterisk '("#2" "*0") :n 2 :child 0)
+ ;; TODO this is actually a syntax error, as "101" is longer than 2
+ (test-read-sharpsign-asterisk '("#2" "*101") :child 5 :n 2))
+
+
+;;; #:
+
+(defun test-read-sharpsign-colon (input child &optional expected-end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-colon
+ :node-type 'sharp-uninterned
+ :input input
+ :expected-end expected-end
+ :expected-children child))
+
+
+(define-test+run read-sharpsign-colon
+ (test-read-sharpsign-colon "#:" (token 2 2) 2)
+ (test-read-sharpsign-colon "#: " (token 2 2) 2)
+ (test-read-sharpsign-colon "#:||" (token 2 4) 4)
+ (test-read-sharpsign-colon "#:|| " (token 2 4) 4)
+ (test-read-sharpsign-colon "#: a" (token 2 2) 2)
+ (test-read-sharpsign-colon "#: a " (token 2 2) 2)
+ (test-read-sharpsign-colon "#:asdf" (token 2 6)))
+
+#++
+(progn
+ (read-from-string "#:")
+ (read-from-string "#: ")
+ (read-from-string "#: a")
+ ;; they all return => #:||
+ )
+
+
+;;; #.
+
+(defun test-read-sharpsign-dot (input child expected-end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-dot
+ :node-type 'sharp-eval
+ :input input
+ :expected-end expected-end
+ :expected-children child))
+
+(define-test+run read-sharpsign-dot
+ (test-read-sharpsign-dot "#." nil +end+)
+ (test-read-sharpsign-dot "#.a" (list (token 2 3)) 3)
+ (test-read-sharpsign-dot "#. a" (list (whitespace 2 3)
+ (token 3 4))
+ 4))
+
+
+;;; #c
+
+(defun test-read-sharpsign-c (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-c
+ :node-type 'sharp-complex
+ :input input
+ :expected-end end
+ :expected-children child))
+
+(define-test+run read-sharpsign-c
+ (test-read-sharpsign-c "#c" :end +end+)
+ (test-read-sharpsign-c "#C" :end +end+)
+ (test-read-sharpsign-c "#cx" :end +end+)
+ (test-read-sharpsign-c "#Cx" :end +end+)
+ (test-read-sharpsign-c "#c1" :end +end+)
+ (test-read-sharpsign-c "#C1" :end +end+)
+ ;; N.B. #c(1) is actually invalid
+ (test-read-sharpsign-c "#c(1)"
+ :child (node 'parens 2 5 (list (node 'token 3 4))))
+ (test-read-sharpsign-c "#C(1)"
+ :child (node 'parens 2 5 (list (node 'token 3 4))))
+ (test-read-sharpsign-c "#c(1 2) a"
+ :child (node 'parens 2 7
+ (list (node 'token 3 4)
+ (node 'whitespace 4 5)
+ (node 'token 5 6)))
+ :end 7)
+ (test-read-sharpsign-c "#C(1 2) a"
+ :child (node 'parens 2 7
+ (list (node 'token 3 4)
+ (node 'whitespace 4 5)
+ (node 'token 5 6)))
+ :end 7))
+
+
+;;; #a
+
+(defun test-read-sharpsign-a (input &key child end n)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-a
+ :node-type 'sharp-array
+ :input input
+ :expected-end end
+ :expected-children child
+ :given-numeric-argument n))
+
+(define-test+run read-sharpsign-a
+ (test-read-sharpsign-a '("#" "a") :end +end+)
+ (test-read-sharpsign-a '("#" "a ") :end +end+)
+ (test-read-sharpsign-a '("#" "a0") :end +end+)
+ (test-read-sharpsign-a '("#0" "a") :end +end+)
+ (test-read-sharpsign-a '("#2" "a0") :end +end+)
+ (test-read-sharpsign-a '("#2" "a0") :end +end+)
+ ;; TODO this is actually a syntax error, as "101" is longer than 2
+ (test-read-sharpsign-a '("#2" "a()") :child (parens 3 5))
+ (test-read-sharpsign-a '("#2" "a(1 2)")
+ :child (parens 3 8
+ (list (token 4 5)
+ (whitespace 5 6)
+ (token 6 7))))
+ (test-read-sharpsign-a '("#2" "A()") :child (parens 3 5)))
+
+
+;;; #s
+
+(defun test-read-sharpsign-s (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-s
+ :node-type 'sharp-structure
+ :input input
+ :expected-end end
+ :expected-children child))
+
+(define-test+run read-sharpsign-s
+ (test-read-sharpsign-s "#s" :end +end+)
+ (test-read-sharpsign-s "#S" :end +end+)
+ (test-read-sharpsign-s "#S(node)"
+ :child (list (parens 2 8 (list (token 3 7)))))
+ (test-read-sharpsign-s "#S(node) foo"
+ :child (list (parens 2 8 (list (token 3 7))))
+ :end 8))
+
+
+;;; #p
+
+(defun test-read-sharpsign-p (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-p
+ :node-type 'sharp-pathname
+ :input input
+ :expected-end end
+ :expected-children child))
+
+(define-test+run read-sharpsign-p
+ (test-read-sharpsign-p "#p" :end +end+)
+ (test-read-sharpsign-p "#P" :end +end+)
+ (test-read-sharpsign-p "#p\"/root/\""
+ :child (list (node 'string 2 10))
+ :end 10)
+ (test-read-sharpsign-p "#p\"/root/\" foo"
+ :child (list (node 'string 2 10))
+ :end 10))
+
+
+;;; #=n
+
+(defun test-read-sharpsign-equal (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-equal
+ :node-type 'sharp-label
+ :input input
+ :expected-end end
+ :expected-children child
+ :given-numeric-argument (getf child :label)))
+
+(define-test+run read-sharpsign-equal
+ (test-read-sharpsign-equal "#=" :end +end+)
+ (test-read-sharpsign-equal
+ '("#1" "=")
+ :child (list :label 1)
+ :end +end+)
+ (test-read-sharpsign-equal
+ '("#2" "= ")
+ :child (list :label 2
+ :form (list (whitespace 3 4)))
+ :end +end+)
+ (test-read-sharpsign-equal
+ '("#3" "=(foo)")
+ :child (list :label 3
+ :form (list (parens 3 8 (token 4 7))))))
+
+
+
+;;; #n#
+
+(defun test-read-sharpsign-sharpsign (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-sharpsign
+ :node-type 'sharp-reference
+ :input input
+ :expected-end end
+ :expected-children child
+ :given-numeric-argument child))
+
+(define-test+run read-sharpsign-sharpsign
+ (test-read-sharpsign-sharpsign "##" :end +end+)
+ (test-read-sharpsign-sharpsign '("#1" "#") :child 1)
+ (test-read-sharpsign-sharpsign '("#2" "# ") :child 2 :end 3))
+
+
+;;; #+
+
+(defun test-read-sharpsign-plus (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-plus
+ :node-type 'sharp-feature
+ :input input
+ :expected-end end
+ :expected-children child))
+
+(define-test+run read-sharpsign-plus
+ (test-read-sharpsign-plus "#+" :end +end+)
+ (test-read-sharpsign-plus "#++" :child (list (token 2 3)))
+ (test-read-sharpsign-plus
+ "#+ #+ x"
+ :child (list (whitespace 2 3)
+ (sharp-feature 3 7
+ (list (whitespace 5 6)
+ (token 6 7))))))
+
+
+;;; #-
+
+(defun test-read-sharpsign-minus (input &key child end)
+ (test-read-sharpsign*
+ :sharpsing-reader-function 'read-sharpsign-minus
+ :node-type 'sharp-feature-not
+ :input input
+ :expected-end end
+ :expected-children child))
+
+(define-test+run read-sharpsign-minus
+ (test-read-sharpsign-minus "#-" :end +end+)
+ (test-read-sharpsign-minus "#--" :child (list (token 2 3)))
+ (test-read-sharpsign-minus
+ "#- #- x"
+ :child (list (whitespace 2 3)
+ (sharp-feature-not 3 7
+ (list (whitespace 5 6)
+ (token 6 7))))))
+
+
+
+(defun test-read-sharpsign (input expected-type expected-end
+ &optional (expected-pos expected-end))
+ (with-state (input)
+ (let ((got (is-equalp* input
+ (read-sharpsign-dispatching-reader-macro state)
+ (node expected-type 0 expected-end))))
+ (when got
+ (is-equalp* input
+ expected-pos
+ (pos state))))))
+
+(define-test+run read-sharpsign-dispatching-reader-macro
+ (loop :for input :being
+ :the :hash-key :of *sharpsign-reader-test-cases*
+ :using (hash-value expected)
+ :do (with-state (input)
+ (is-equalp
+ :input input
+ :got (read-sharpsign-dispatching-reader-macro state)
+ :expected expected
+ :form `(read-sharpsign-dispatching-reader-macro ,state)
+ ;; :description description
+ ;; :format-args format-args
+ ))))
+
+
+;; (read-from-string "#\\ ") == (read-from-string "#\\Space")
+;; This is an error (there must be no space between "#s" and "("): (read-from-string "#s ()")
+
+
+
(defun test-read-punctuation (input expected-type)
(with-state (input)
- (is-equalp input
- (read-punctuation state)
- (when expected-type
- (punctuation expected-type 0)))))
+ (is-equalp* input
+ (read-punctuation state)
+ (when expected-type
+ (punctuation expected-type 0)))))
(define-test+run read-punctuation
:depends-on (current-char)
@@ -342,7 +709,8 @@ newline or +end+)
(test-read-string "" nil)
(test-read-string "\"" +end+)
(test-read-string "\"\"" 2)
- (test-read-string "\" \"" 3))
+ (test-read-string "\" \"" 3)
+ (test-read-string "\"~s\"" 4))
(define-test+run not-terminatingp
(mapcar #'(lambda (char)
@@ -350,13 +718,68 @@ newline or +end+)
"~c is supposed to be a terminating character." char))
'(#\; #\" #\' #\( #\) #\, #\`)))
+
+(defun tsn (string &optional (start 0) (end (length string)))
+ (%token-symbol-node string start end))
+
+(defun tsn-padded (string)
+ (let* ((prefix ": ")
+ (suffix " ")
+ (l (length string))
+ (p (length prefix)))
+ (tsn (concatenate 'string prefix string suffix)
+ p (+ p l))))
+
+(define-test token-symbol-node
+ (progn
+ (is equalp (node 'current-package-symbol 0 1) (tsn "x"))
+ (is equalp (node 'keyword 1 2) (tsn ":x"))
+ (is equalp (node 'uninterned-symbol 2 3) (tsn "#:x"))
+ (is equalp
+ (node 'qualified-symbol 0 3
+ (list (node 'package-name 0 1)
+ (node 'symbol-name 2 3)))
+ (tsn "p:x"))
+ (is equalp
+ (node 'possibly-internal-symbol 0 4
+ (list
+ (node 'package-name 0 1)
+ (node 'symbol-name 3 4)))
+ (tsn "p::x"))
+ (false (tsn ""))
+ (false (tsn "#:"))
+ (false (tsn "::"))
+ (false (tsn "p:::x"))
+ (false (tsn "p::"))
+ (false (tsn "::x"))
+ (false (tsn "a:a:x")))
+ (progn
+ (is equalp (node 'current-package-symbol 3 4) (tsn-padded "x"))
+ (is equalp (node 'keyword 4 5) (tsn-padded ":x"))
+ (is equalp (node 'uninterned-symbol 5 6) (tsn-padded "#:x"))
+ (is equalp (node 'qualified-symbol 3 6
+ (list (node 'package-name 3 4)
+ (node 'symbol-name 5 6)))
+ (tsn-padded "p:x"))
+ (is equalp (node 'possibly-internal-symbol 3 7
+ (list (node 'package-name 3 4)
+ (node 'symbol-name 6 7)))
+ (tsn-padded "p::x"))
+ (false (tsn-padded ""))
+ (false (tsn-padded "#:"))
+ (false (tsn-padded "::"))
+ (false (tsn-padded "p:::x"))
+ (false (tsn-padded "p::"))
+ (false (tsn-padded "::x"))
+ (false (tsn-padded "a:a:x"))))
+
+
(defun test-read-token (input expected-end)
(with-state (input)
(test* (read-token state)
(when expected-end
(token 0 expected-end)))))
-;; TODO Fix read-token
(define-test+run read-token
:depends-on (current-char
not-terminatingp
@@ -374,7 +797,11 @@ newline or +end+)
(test-read-token "arg| asdf |more|" +end+)
(test-read-token "arg| asdf |more|mmoooore|done" 29)
(test-read-token "arg| asdf |no |mmoooore|done" 13)
- (test-read-token "look|another\\| case\\| didn't think of| " 38))
+ (test-read-token "look|another\\| case\\| didn't think of| " 38)
+ (test-read-token "this.is.normal..." 17)
+ (test-read-token "\\asdf" 5)
+ (test-read-token "\\;" 2)
+ (test-read-token "a\\;" 3))
;; TODO read-extraneous-closing-parens
@@ -400,18 +827,16 @@ newline or +end+)
;; TODO read-any
(define-test read-any)
-
;;; Putting it all toghether
-;; TODO parse
(defun test-parse (input &rest expected)
(register-test-string input)
(let* ((state (parse input))
(tree (tree state)))
(if expected
- (is-equalp input tree expected)
- (is-equalp input tree))))
+ (is-equalp* input tree expected)
+ (is-equalp* input tree))))
(define-test+run "parse"
:depends-on (read-parens)
@@ -429,84 +854,94 @@ newline or +end+)
(test-parse "#| #||# |#" (block-comment 0 10))
(test-parse "'" (punctuation 'quote 0))
(test-parse "`" (punctuation 'quasiquote 0))
- (test-parse "#" (punctuation 'sharp 0))
+ ;; (test-parse "#" (punctuation 'sharp 0))
(test-parse "," (punctuation 'comma 0))
(test-parse "+-*/" (token 0 4))
(test-parse "123" (token 0 3))
- (test-parse "asdf#" (token 0 5))
+ ;; (test-parse "asdf#" (token 0 5))
(test-parse "| asdf |" (token 0 8))
(test-parse "arg| asdf | " (token 0 11) (whitespace 11 12))
(test-parse "arg| asdf |more" (token 0 15))
(test-parse "arg| asdf |more|" (token 0 +end+))
(test-parse "arg| asdf " (token 0 +end+))
- (test-parse ";" (line-comment 0 +end+))
+ (test-parse ";" (line-comment 0 1))
+ (test-parse "; " (line-comment 0 2))
+ (test-parse (format nil ";~%") (line-comment 0 1) (whitespace 1 2))
+ (test-parse (format nil ";~%;") (line-comment 0 1) (whitespace 1 2) (line-comment 2 3))
(test-parse "(12" (parens 0 +end+ (token 1 3)))
- (test-parse "\"" (node 'string 0 +end+)))
-
-(defun test-parse* (input &rest expected)
- (register-test-string input)
- (if expected
- (is-equalp input (parse* input) expected)
- (is-equalp input (parse* input))))
-
-#++
-(define-test+run "parse*"
- :depends-on (read-parens)
- (eq (parse "") nil)
- (test-parse* " " (whitespace 0 2))
- (test-parse* "#|" (block-comment 0 +end+))
- (test-parse* " #| "
- (whitespace 0 1)
- (block-comment 1 +end+)
- #++
- (whitespace 3 4))
- (test-parse* "#||#" (block-comment 0 4))
- (test-parse* "#|#||#" (block-comment 0 +end+))
- (test-parse* "#| #||# |#" (block-comment 0 10))
- (test-parse* "'" (punctuation 'quote 0))
- (test-parse* "`" (punctuation 'quasiquote 0))
- (test-parse* "#" (punctuation 'sharp 0))
- (test-parse* "," (punctuation 'comma 0))
- (test-parse* "+-*/" (token 0 4))
- (test-parse* "123" (token 0 3))
- (test-parse* "asdf#" (token 0 5))
- (test-parse* "| asdf |" (token 0 8))
- (test-parse* "arg| asdf | " (token 0 11) (whitespace 11 12))
- (test-parse* "arg| asdf |more" (token 0 15))
- (test-parse* "arg| asdf |more|" (token 0 +end+))
- (test-parse* ";" (line-comment 0 +end+))
- (test-parse* "(12" (parens 0 +end+ (token 1 3)))
- (test-parse* "\"" (node 'string 0 +end+)))
-
-
-#|
-
-
-(list
- (parse "#<>")
- (parse "#+"))
-
-http://www.lispworks.com/documentation/HyperSpec/Body/02_dh.htm
-
-(list of reader macros
- "\\'(*:boxrcasp=+-<")
-
-
-#) and # are **invalid**
-
-|#
-
-#++
-(multiple-value-bind (tree state)
- (parse "(foo)")
- (format nil "(~a ~a)"
- "ignore-errors"
- (node-content state (car tree))))
-
+ (test-parse "\"" (node 'string 0 +end+))
+ (test-parse "\"\"" (node 'string 0 2))
+ (test-parse "#:asdf"
+ (node 'sharp-uninterned 0 6
+ (node 'token 2 6)))
+ (test-parse "#2()"
+ (node 'sharp-vector 0 4
+ (node 'parens 2 4)))
+ (test-parse "#<>" (node 'sharp-unknown 0 +end+))
+ (test-parse "#+ x" (node 'sharp-feature 0 4
+ (list
+ (whitespace 2 3)
+ (token 3 4))))
+ (test-parse "(char= #\\; c)"
+ (parens 0 13
+ (list (token 1 6)
+ (whitespace 6 7)
+ (sharp-char 7 10 (token 8 10))
+ (whitespace 10 11)
+ (token 11 12))))
+ (test-parse "(#\\;)" (parens 0 5
+ (list (sharp-char 1 4 (token 2 4)))))
+ (test-parse "#\\; " (sharp-char 0 3 (token 1 3)) (whitespace 3 4))
+ (test-parse "`( asdf)" (node 'quasiquote 0 1)
+ (parens 1 8
+ (list
+ (whitespace 2 3)
+ (token 3 7))))
+ (test-parse "#\\Linefeed" (sharp-char 0 10 (token 1 10)))
+ (test-parse "#\\: asd" (sharp-char 0 3 (token 1 3)) (whitespace 3 4) (token 4 7))
+ (test-parse "((( )))" (parens 0 8 (list (parens 1 7 (list (parens 2 6 (list (whitespace 3 5))))))))
+ (test-parse "(#" (parens 0 +end+ (sharp-unknown 1 +end+)))
+ (test-parse "(#)" (parens 0 +end+ (sharp-unknown 1 +end+)))
+ (test-parse "(#) "
+ (parens 0 +end+ (sharp-unknown 1 +end+))
+ #++ (whitespace 3 4))
+ (test-parse "(#') "
+ (parens
+ 0 +end+
+ (sharp-function
+ 1 +end+
+ (list (node ':extraneous-closing-parens 3 +end+)))))
+ (test-parse "#1=#1#"
+ (sharp-label 0 6
+ (list :label 1 :form
+ (list (sharp-reference 3 6 1)))))
+ (test-parse "(;)" (parens 0 -1 (list (line-comment 1 3))))
+ ;; TODO This is wrong
+ (test-parse "#+;;" (sharp-feature 0 4 (list (line-comment 2 4))))
+ ;; TODO Is that what I want?
+ (test-parse "#++;;" (sharp-feature 0 3 (list (token 2 3))) (line-comment 3 5))
+ ;; TODO This is wrong... but _OMG_
+ (test-parse (format nil "cl-user::; wtf~%reaally?")
+ (token 0 9) (line-comment 9 14) (whitespace 14 15) (token 15 23))
+ ;; TODO This is silly
+ (test-parse ",@" (node 'comma 0 1) (node 'at 1 2))
+ ;; TODO This is silly
+ (test-parse ",." (node 'comma 0 1) (node 'dot 1 2)))
+
+#++ ;; this is cursed
+(read-from-string "cl-user::; wtf
+reaally?")
+
+#++ ;; this is an error
+(read-from-string "cl-user:; wtf
+:reaally?")
;; Slightly cursed syntax:
;; "#+#."
+;; e.g. "#+ #.(cl:quote x) 2" == "#+ x 2"
+#++
+(read-from-string ":\|")
;;; Unparse
@@ -516,7 +951,7 @@ http://www.lispworks.com/documentation/HyperSpec/Body/02_dh.htm
(let* ((state (parse string))
(result (unparse state nil))
(success (equalp string result)))
- (is-equalp (or context string) result string)
+ (is-equalp* (or context string) result string)
(when (and success check-for-error)
;; Would be nice to (signal ...), not error, just signal, when
;; there's a parsing failure, because right now it's pretty hard
@@ -531,20 +966,45 @@ http://www.lispworks.com/documentation/HyperSpec/Body/02_dh.htm
(state-context state))))))
success))
-(progn
- (define-test unparse
- (test-round-trip "#' () () ()")
- (test-round-trip " (")
- (loop :for string :being :the :hash-key :of *test-strings*
- :do (test-round-trip string)))
- #++
- (parachute:test 'unparse))
-
+(define-test+run unparse
+ (test-round-trip "#' () () ()")
+ (test-round-trip " (")
+ (loop :for string :being :the :hash-key :of *test-strings*
+ :do (test-round-trip string)))
+;; TODO make it easier to pin-point errors here...
(define-test+run round-trip-breeze
(loop :for file :in (breeze.asdf:system-files 'breeze)
:for content = (alexandria:read-file-into-string file)
- :do (test-round-trip content
- :context file
- ;; :check-for-error t
- )))
+ :do (let* ((state (parse content))
+ (last-node (alexandria:lastcar (tree state)))
+ (result (unparse state nil)))
+ (walk state (lambda (node &rest args
+ &key depth
+ aroundp beforep afterp
+ firstp lastp nth
+ &allow-other-keys)
+ (declare (ignorable
+ args
+ depth
+ aroundp beforep afterp
+ firstp lastp nth))
+ (unless (valid-node-p node)
+ ;; There's just too many nodes, this
+ ;; makes parachute completely choke if I
+ ;; don't filter the results...
+ (true (valid-node-p node)
+ "file: ~s node: ~s" file node))
+ #++ (when (parens-node-p node) (char= #\())
+ node))
+ (is = (length content) (node-end last-node)
+ "Failed to parse correctly the file ~s. The last node is: ~s"
+ file
+ last-node)
+ #++
+ (is = (length content) (length result)
+ "Round-tripping the file ~s didn't give the same length.")
+ (let ((mismatch (mismatch content result)))
+ (false mismatch "Failed to round-trip the file ~s. The first mismatch is at position: "
+ file
+ mismatch)))))
diff --git a/tests/lossless-reader.randmized.lisp b/tests/lossless-reader.randmized.lisp
new file mode 100644
index 00000000..c9656089
--- /dev/null
+++ b/tests/lossless-reader.randmized.lisp
@@ -0,0 +1,149 @@
+
+(cl:in-package #:cl-user)
+
+(defpackage #:breeze.test.lossless-reader
+ (:documentation "Test package for #:breeze.lossless-reader")
+ (:use #:cl #:breeze.lossless-reader)
+ (:import-from #:breeze.lossless-reader
+ #:*state-control-string*
+ #:state-context
+ #:read-sharpsign-backslash
+ #:read-sharpsign-quote
+ #:read-sharpsign-left-parens
+ #:read-sharpsign-asterisk
+ #:read-sharpsign-colon
+ #:read-sharpsign-dot
+ #:read-sharpsign-b
+ #:read-sharpsign-o
+ #:read-sharpsign-x
+ #:read-sharpsign-r
+ #:read-sharpsign-c
+ #:read-sharpsign-a
+ #:read-sharpsign-s
+ #:read-sharpsign-p
+ #:read-sharpsign-equal
+ #:read-sharpsign-sharpsign
+ #:read-sharpsign-plus
+ #:read-sharpsign-minus
+ #:%token-symbol-node)
+ (:import-from #:parachute
+ #:define-test
+ #:define-test+run
+ #:is
+ #:true
+ #:false
+ #:of-type)
+ (:import-from #:breeze.kite
+ #:is-equalp*
+ #:is-equalp))
+
+(in-package #:breeze.test.lossless-reader)
+
+(defvar *test-strings* (make-hash-table :test 'equal))
+
+(defun register-test-string (string &optional (origin (list t)) &aux (ht *test-strings*))
+ (let ((old-origin (gethash string ht)))
+ (unless (or (and (equal '(t) origin)
+ (member t old-origin))
+ (and old-origin
+ (equal origin (alexandria:lastcar old-origin))))
+ (setf (gethash string ht)
+ (append old-origin (alexandria:ensure-list origin)))))
+ string)
+
+
+
+;; Add _some_ randomized test strings
+(defun wrap-in-parens (s) (format nil "(~a)" s))
+(defun wrap-in-block-comment (s) (format nil "#|~a|#" s))
+(defun prefix-with-line-comment (s) (format nil ";~a" s))
+;; reverse
+
+(defun randomize-1 (fn s origin)
+ (unless (equal (alexandria:lastcar origin) fn)
+ (funcall fn s)))
+
+(defun randomize-test-strings (&aux (before (hash-table-count *test-strings*)))
+ (loop
+ :for randomizer :in (list
+ 'reverse
+ 'wrap-in-parens
+ 'wrap-in-block-comment
+ 'prefix-with-line-comment)
+ :do
+ (loop
+ :for s :being :the :hash-key :of (alexandria:copy-hash-table *test-strings*)
+ :using (hash-value origin)
+ :for r = (randomize-1 randomizer s origin)
+ :when r
+ :do (register-test-string r randomizer)))
+ (format nil "~d new test strings generated (was ~d, now ~d)"
+ (- (hash-table-count *test-strings*) before)
+ before (hash-table-count *test-strings*)))
+
+#++
+(randomize-test-strings)
+
+#++
+(maphash (lambda (k v)
+ (unless (equal '(t) v)
+ (remhash k *test-strings*)))
+ *test-strings*)
+
+#++
+(remove-duplicates
+ (loop
+ :for s :being :the :hash-key :of *test-strings*
+ :using (hash-value origin)
+ :collect (alexandria:lastcar origin)))
+
+#++
+(remove-duplicates
+ (alexandria:hash-table-values *test-strings*)
+ :test 'equal)
+
+#++
+(alexandria:hash-table-keys *test-strings*)
+
+(define-test+run parse-randomized
+ (parachute:finish
+ (loop :for input :being :the :hash-key :of *test-strings*
+ :do (restart-case
+ (parse input)
+ (continue ()
+ :report (lambda (stream)
+ (format stream "Continue to the next test.")))
+ (remove-and-continue ()
+ :report (lambda (stream)
+ (format stream "Remove ~s from *test-strings* and continue to the next test." string))
+ (remhash string *test-strings*))))))
+
+(defmacro ∀ ((n &rest vars) &body body)
+ (if vars
+ (alexandria:once-only (n)
+ `(loop :for ,(first vars) :below ,n :do (∀ (,n ,@(rest vars)) ,@body)))
+ `(progn ,@body)))
+
+;; Generate all possible strings of 1 charcater
+;; Generate all ASCII strings of length 2 and 3
+#++
+(define-test+run parse-exhaustive
+ (parachute:finish
+ (loop :for i :below char-code-limit
+ :do (parse (string (code-char i)))))
+ (parachute:finish
+ (∀ (256 x y)
+ (parse (map 'string 'code-char (list x y)))))
+ (let (input message)
+ (parachute:finish
+ (∀ (128 x y z)
+ (setf
+ ;; message (format nil "Failed with input x: ~s y: ~s z: ~s" x y z)
+ input (map 'string 'code-char (list x y z)))
+ (parse input))
+ ;; "~a" message
+ )))
+
+#++
+(∀ (128 x y z)
+ (map 'string 'code-char (list x y z)))
diff --git a/tests/main.lisp b/tests/main.lisp
index 3c9c4786..d3e4223d 100644
--- a/tests/main.lisp
+++ b/tests/main.lisp
@@ -7,14 +7,14 @@
(in-package #:breeze.test.main)
+(defparameter cl-user::*exit-on-test-failures* nil)
+
(defun run-breeze-tests (&optional exitp)
"Run breeze's tests."
(let ((packages (breeze.xref:find-packages-by-prefix "breeze.test")))
(format *trace-output*
- "~&About to run tests for the packages: ~{ - ~A~^~%~}"
+ "~&About to run tests for the packages:~%~{ - ~A~%~}"
packages)
(finish-output *trace-output*)
- (let ((report (parachute:test packages)))
- (if exitp
- (uiop:quit (if (eq :failed (parachute:status report)) 1 0))
- report))))
+ (let ((cl-user::*exit-on-test-failures* exitp))
+ (parachute:test packages :report 'parachute:largescale))))
diff --git a/tests/pattern.lisp b/tests/pattern.lisp
index ae9bebb4..a3061503 100644
--- a/tests/pattern.lisp
+++ b/tests/pattern.lisp
@@ -8,7 +8,8 @@
#:isnt
#:true
#:false
- #:of-type)
+ #:of-type
+ #:fail)
(:import-from #:breeze.pattern
;; Structures
#:ref
@@ -24,14 +25,14 @@
#:typed-term-name
#:typed-term-type
#:typed-term=
+ #:repetition
+ #:repetitionp
+ #:repetition=
+ #:repetition-pattern
+ #:repetition-min
+ #:repetition-max
#:maybe
- #:maybep
- #:maybe-pattern
- #:maybe=
#:zero-or-more
- #:zero-or-more-p
- #:zero-or-more-pattern
- #:zero-or-more=
#:alternation
#:alternationp
#:alternation-pattern
@@ -56,6 +57,8 @@
#:iterator-next
#:iterator-value
;; Match
+ #:make-binding
+ #:merge-bindings
#:match))
(in-package #:breeze.test.pattern)
@@ -100,19 +103,15 @@
(define-test maybe
(let ((maybe (maybe :x)))
- (of-type maybe maybe)
- (true (maybep maybe))
- (is eq :x (maybe-pattern maybe))))
-
-;; TODO maybe=
+ (of-type repetition maybe)
+ ;; TODO check repetition-{min,max}
+ (is eq :x (repetition-pattern maybe))))
(define-test zero-or-more
(let ((zero-or-more (zero-or-more :x)))
- (of-type zero-or-more zero-or-more)
- (true (zero-or-more-p zero-or-more))
- (is eq :x (zero-or-more-pattern zero-or-more))))
-
-;; TODO zero-or-more=
+ (of-type repetition zero-or-more)
+ ;; TODO check repetition-{min,max}
+ (is eq :x (repetition-pattern zero-or-more))))
(define-test alternation
(let ((alternation (alternation :x)))
@@ -158,11 +157,16 @@
(is pattern= (term :?x) (compile-pattern :?x))
(is pattern= (ref :x) (compile-pattern '(:ref :x)))
(is pattern= (maybe :x) (compile-pattern '(:maybe :x)))
- (is pattern= (maybe #(:x :y)) (compile-pattern '(:maybe :x :y)))
- (is pattern= (zero-or-more :x) (compile-pattern '(:zero-or-more :x)))
+ (is pattern= (maybe :x :?y) (compile-pattern '(:maybe :x :?y)))
+ (is pattern= (maybe #(:x :y)) (compile-pattern '(:maybe (:x :y))))
+ (is pattern= (zero-or-more #(:x)) (compile-pattern '(:zero-or-more :x)))
(is pattern= (zero-or-more #(:x :y)) (compile-pattern '(:zero-or-more :x :y)))
- (is pattern= (alternation :x) (compile-pattern '(:alternation :x)))
- (is pattern= (alternation #(:x :y)) (compile-pattern '(:alternation :x :y))))
+ (is pattern= (alternation #(:x)) (compile-pattern '(:alternation :x)))
+ (is pattern= (alternation #(:x :y)) (compile-pattern '(:alternation :x :y)))
+ (multiple-value-bind (p terms)
+ (compile-pattern '(?x ?x))
+ (is eq (aref p 0) (aref p 1))
+ (is eq (aref p 0) (gethash '?x terms))))
@@ -186,12 +190,23 @@
;; I _cannot_ iterate over both in at the same speed.
+(defun test-iterator (iterator vector
+ &key (pos 0) donep value)
+ (is eq vector (iterator-vector iterator)
+ "The iterator was not intialized with the right vector.")
+ (is = pos (iterator-position iterator)
+ "The iterator's position was not correctly initialized to ~s." pos)
+ (is = 1 (iterator-step iterator)
+ "The iterator's step was not correctly initialized to 1.")
+ (when donep
+ (true (iterator-done-p iterator)))
+ (when value
+ (is pattern= value (iterator-value iterator))))
+
(define-test make-iterator
(let* ((vector #(1 2 3))
(iterator (make-iterator :vector vector)))
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator))))
+ (test-iterator iterator vector)))
(define-test iterator-done-p
(true (iterator-done-p (make-iterator :vector #())))
@@ -201,112 +216,105 @@
(false (iterator-done-p (make-iterator :vector #(1 2 3))))
(true (iterator-done-p (make-iterator :vector #(1 2 3) :position 10))))
-#++
(define-test iterator-push
(let* ((vector1 #(1 2 3))
(vector2 #(a b c d e f))
(iterator (iterator-push
(make-iterator :vector vector1)
vector2)))
- (is eq vector2 (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator))))
+ (test-iterator iterator vector2)))
-#++
(define-test iterator-maybe-push
;; empty case, so the iterator is donep from the start
(let* ((vector #())
(iterator (iterator-maybe-push (make-iterator :vector vector))))
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
+ (test-iterator iterator vector))
;; non-empty, no ref
(let* ((vector #(1 2 3))
(iterator (iterator-maybe-push (make-iterator :vector vector))))
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
+ (test-iterator iterator vector))
;; starts with a ref
(let* ((ref (ref 'a))
(vector `#(,ref))
(root-iterator (make-iterator :vector vector))
(iterator (iterator-maybe-push root-iterator)))
(isnt eq root-iterator iterator)
- (is eq (ref-pattern ref) (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator))
+ (test-iterator iterator (ref-pattern ref))
(is pattern= 'a (iterator-value iterator))))
-#++
+;; This also tests iterator-maybe-{push,pop}
(define-test iterator-next
;; empty case, so the iterator is donep from the start
(let* ((vector #())
- (iterator (iterator-next (iterator-maybe-push (make-iterator :vector vector)))))
- ;; TODO check done-p
- ;; TODO check value
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
- ;; non-empty, no ref
- (let* ((vector #(1 2 3))
- (iterator (iterator-next (iterator-maybe-push (make-iterator :vector vector)))))
- ;; TODO
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
- ;; starts with a ref
- (let* ((ref (ref 'a))
- (vector `#(,ref))
- (root-iterator (make-iterator :vector vector))
- (iterator (iterator-next (iterator-maybe-push root-iterator))))
- ;; TODO
- (isnt eq root-iterator iterator)
- (is eq (ref-pattern ref) (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator))
- (is pattern= 'a (iterator-value iterator))))
-
-#++
-(define-test iterator-maybe-pop
- ;; empty case
- (let* ((vector #())
- (iterator (iterator-maybe-pop (iterator-maybe-push (make-iterator :vector vector)))))
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
+ (iterator (iterate vector)))
+ (test-iterator iterator vector :pos 0 :donep t)
+ (parachute:fail (iterator-value iterator))
+ (iterator-next iterator)
+ (test-iterator iterator vector :pos 1 :donep t)
+ (fail (iterator-value iterator)))
;; non-empty, no ref
(let* ((vector #(1 2 3))
- (iterator (iterator-maybe-pop (iterator-maybe-push (make-iterator :vector vector)))))
- (is eq vector (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator)))
-;;;; WIP
+ (iterator (iterate vector)))
+ (test-iterator iterator vector :pos 0 :value 1)
+ (iterator-next iterator)
+ (test-iterator iterator vector :pos 1 :value 2))
;; starts with a ref
(let* ((ref (ref 'a))
(vector `#(,ref))
(root-iterator (make-iterator :vector vector))
(iterator (iterator-maybe-push root-iterator)))
- (iterator-next)
(isnt eq root-iterator iterator)
- (is eq (ref-pattern ref) (iterator-vector iterator))
- (is = 0 (iterator-position iterator))
- (is = 1 (iterator-step iterator))
- (is pattern= 'a (iterator-value iterator)))
- )
-
-#++
-(defun test-iterator (vector)
+ (test-iterator root-iterator vector)
+ ;;; We're referencing the pattern '(a ?a)
+ ;; check the first value
+ (test-iterator iterator (ref-pattern ref) :pos 0 :value 'a)
+ ;; advance the iterator
+ (setf iterator (iterator-next iterator)) ; maybe a macro for this? (nextf iterator)
+ ;; check the second value
+ (test-iterator iterator (ref-pattern ref) :pos 1 :value #S(term :name ?a))
+ ;; (is pattern= #S(term :name ?a) (iterator-value iterator))
+ ;; advance the iterator
+ (let ((iterator2 (iterator-next iterator)))
+ (test-iterator iterator (ref-pattern ref) :pos 2 :donep t)
+ (isnt eq iterator iterator2 "iterator-next should have returned a different iterator.")
+ (is eq root-iterator iterator2 "iterator-next should have returned the root iterator.")
+ (test-iterator iterator2 vector :pos 1 :donep t)
+ (fail (iterator-value iterator2)))))
+
+;; TODO This _could_ be renamed "flatten pattern" ?
+(defun test-iterator* (vector)
(loop
+ :for i :from 0
:for iterator := (iterate vector) :then (iterator-next iterator)
- :until (iterator-done-p iterator)
+ :until (prog1 (iterator-done-p iterator)
+ ;; (format *debug-io* "~%~%~d: ~S" i iterator)
+ )
:for value = (iterator-value iterator)
- :do (format *debug-io* "~%~%~S~%~%" value)
+ ;; :do (format *debug-io* "~&~d: ~S~%~%" i value)
:collect value))
-#++
-(test-iterator `#(,(ref 'a)))
+
+(define-test iterator
+ (is equalp '(a #s(term :name ?a))
+ (test-iterator* `#(,(ref 'a))))
+ (is equalp '(a #s(term :name ?a) a #s(term :name ?a))
+ (test-iterator* `#(,(ref 'b)))))
+(define-test merge-bindings
+ (false (merge-bindings nil nil))
+ (false (merge-bindings nil t))
+ (false (merge-bindings t nil))
+ (true (merge-bindings t t))
+ (false (merge-bindings (make-binding :?x 'a) nil))
+ (false (merge-bindings nil (make-binding :?x 'a)))
+ (is equal '((:?x . a)) (merge-bindings (make-binding :?x 'a) t))
+ (is equal '((:?x . a)) (merge-bindings t (make-binding :?x 'a)))
+ (is equal '((:?x . a) (:?y . b)) (merge-bindings (make-binding :?x 'a) (make-binding :?y 'b)))
+ (let ((term (term 'a)))
+ (is equal `((,term . 42))
+ (merge-bindings `((,term . 42)) `((,term . 42))))))
+
(defun test-match (pattern input)
(match (compile-pattern pattern) input))
@@ -319,11 +327,9 @@
(false (match 1 2))
(true (match 'x 'x))
(true (match "x" "x"))
- (false (match 'x 'y))
- (true (match #(a) '(a)))
- ;; TODO add vectors (but not arrays)
- )
+ (false (match 'x 'y)))
+;;; TODO check the actual return values
(define-test "match terms"
(true (match (term :?x) nil))
(true (match (term :?x) 1))
@@ -333,6 +339,7 @@
(true (match (term :?x) (term :?x)))
(true (match `#(,(term :?x)) (list 42))))
+;;; TODO check the actual return values
(define-test "match typed-terms"
(true (match (typed-term 'null :?x) nil))
(false (match (typed-term 'null :?x) t))
@@ -346,6 +353,60 @@
(false (match (typed-term 'cons :?x) 'a)))
+;;; Sequences
+
+(define-test+run "match sequences"
+ (true (match #(a) '(a)))
+ (false (match #(a b) #(a)))
+ (true (match #(a b) #(a b)))
+ (false (match #(a b) #(a b a))))
+
+
+;;; test :maybe :zero-or-more and :alternation
+
+#++ ;; TODO
+(define-test "match maybe"
+ (is eq t (match (maybe 'a) 'a))
+ (is eq t (match (maybe 'a) nil))
+ (is eq t (match (maybe 'a :?x) nil))
+ (false (match (maybe 'a :?x) 'b))
+ (false (match (maybe 'a) 'b))
+ (is equalp `(,(maybe :name :?x :pattern a) a) (match (maybe 'a :?x) 'a))
+ (is equalp '(#(term :name '?x) a) (match (maybe (term '?x)) 'a))
+ (is equalp `(,(term :name '?x) nil) (match (maybe (term '?x)) nil)))
+
+#++ ;; TODO
+(define-test "match alternations"
+ (is eq t (test-match '(:alternation a b) 'a))
+ (is eq t (test-match '(:alternation a b) 'b))
+ (false (test-match '(:alternation a b) 'c))
+ (is equalp '(#s(term :name ?x) c) (test-match '(:alternation ?x b) 'c))
+ (let ((pat (compile-pattern '(:alternation (:maybe a ?x) b))))
+ (is equalp `(,(maybe :name ?x :pattern a) a) (test-match pat 'a))
+ (is eq t (test-match pat 'b))
+ (false (test-match pat 'c))))
+
+#++ ;; TODO
+(define-test+run "match zero-or-more"
+ (true (test-match '(:zero-or-more a) nil))
+ (false (test-match '(:zero-or-more a b) '(a)))
+ (is eq t (test-match '(:zero-or-more a b) '(a b)))
+ (false (test-match '(:zero-or-more a b) '(a b a)))
+ (is eq t (test-match '(:zero-or-more a b) '(a b a b)))
+ (false (test-match '(:zero-or-more a b) 'a)))
+
+#++ ;; TODO
+(progn
+ ;; I want this to be true
+ (test-match '(a (:zero-or-more a b)) '(a a b))
+ ;; Not this
+ (test-match '(a (:zero-or-more a b)) '(a (a b)))
+ ;; That one should be used instead of ^^^
+ (test-match '(a ((:zero-or-more a b))) '(a (a b))))
+
+
+
+;;; Testing patterns with references in them
(defpattern optional-parameters
&optional
@@ -354,6 +415,22 @@
((:the symbol ?var)
?init-form (:maybe (:the symbol ?supplied-p-parameter))))))
+#++
+(match (ref 'optional-parameters)
+ '(&optional))
+
+#++
+(match (ref 'optional-parameters)
+ '(&optional x))
+
+#++
+(list
+ '(&optional x)
+ '(&optional (x 1))
+ '(&optional (x 1 supplied-p))
+ '(&optional x y (z t)))
+
+
(defpattern rest-parameter &rest ?var)
(defpattern body-parameter &body ?var)
@@ -382,28 +459,56 @@
(defpattern defun
(defun (:the symbol ?name) $ordinary-lambda-list ?body))
-#++
-(match 'optional-parameters
- '(&optional))
-#++
-(list
- '(&optional x)
- '(&optional (x 1))
- '(&optional (x 1 supplied-p))
- '(&optional x y (z t)))
+
+
+
+(defun test-match-ref (pattern input &key bindings)
+ (let ((result (match pattern input)))
+ (if bindings
+ (is equalp bindings (if (listp result)
+ (mapcar (lambda (x)
+ (cons (term-name (car x)) (cdr x)))
+ result)
+ result)
+ "Matching the pattern ~s agains the input ~s should have created the bindings ~s but we got ~s instead."
+ pattern input bindings result)
+ (false result))))
+
+
+(define-test+run "match ref"
+ (test-match-ref (ref 'a) '(a 42) :bindings '((?a . 42)))
+ (test-match-ref (ref 'b) '(a 42 a 73))
+ ;; TODO What if we want to use the pattern 'a with independent bindings?
+ ;; Idea new syntax: (ref 'a ('?a ?a1)) or (ref 'a :prefix a1)
+ (test-match-ref (ref 'b) '(a 42 a 42) :bindings '((?a . 42)))
+ (test-match-ref (ref 'body-parameter) '(42))
+ (test-match-ref (ref 'body-parameter) '(&body 42)
+ :bindings '((?var . 42))))
+
+
+
+;;; Match substitution
+
+(defun test-pattern-substitute (pattern bindings)
+ (multiple-value-bind (compiled-pattern term-pool)
+ (breeze.pattern:compile-pattern pattern)
+ (let ((actual-bindings
+ (sublis (alexandria:hash-table-alist term-pool) bindings)))
+ (pattern-substitute compiled-pattern actual-bindings))))
+;;; Rules and rewrites
-;; (trace match :methods t)
#++
-(define-test "match ref"
- (true (match `#(,(ref 'a)) '(a 42)))
- (true (match `#(,(ref 'b)) '(a 42 a 73)))
- (false (match `#(,(ref 'body-parameter)) '(42)))
- (true (match `#(,(ref 'body-parameter)) '(&body 42))))
-
-;; TODO I tested if match return the right generalized boolean, but I
-;; haven't tested the actual value it returns when it's true. Which
-;; should be either t or a list of new bindings.
+(let ((r (make-rewrite '(/ ?x ?x) 1)))
+ (list (pattern= (rewrite-pattern r) #(/ (term :?x) (term :?x)))
+ (rewrite-template r)))
+
+#++
+(make-rewrite '(/ (* ?x ?y) ?z)
+ '(* ?x (/ ?y ?z)))
+
+#++
+(make-rewrite '(/ ?x 1) ?x)
diff --git a/tests/refactor.lisp b/tests/refactor.lisp
index caeb34ed..9b50fa88 100644
--- a/tests/refactor.lisp
+++ b/tests/refactor.lisp
@@ -1,7 +1,7 @@
(cl:in-package #:common-lisp-user)
(uiop:define-package #:breeze.test.refactor
- (:use :cl #:breeze.refactor)
+ (:use :cl #:breeze.refactor)
;; Importing non-exported symbols of the "package under test"
(:import-from #:breeze.refactor)
;; Things needed to "drive" a command
@@ -20,29 +20,9 @@
#:outer-node)
(:import-from #:breeze.test.command
#:drive-command)
- #++
- (:import-from #:breeze.reader
- #:node-content
- #:parse-string
- #:unparse-to-string
-
- ;; Types of node
- #:skipped-node
- #:symbol-node
- #:read-eval-node
- #:character-node
- #:list-node
- #:function-node
-
- ;; Type predicates
- #:skipped-node-p
- #:symbol-node-p
- #:read-eval-node-p
- #:character-node-p
- #:list-node-p
- #:function-node-p)
(:import-from #:breeze.utils
- #:remove-indentation)
+ #:remove-indentation
+ #:split-by-newline)
(:import-from #:parachute
#:define-test
#:define-test+run
@@ -84,6 +64,7 @@
commands)))
+
;;; Oh yiisss! In this "page", I create a command that can generate
;;; tests _interactively_ for a command.
;;;
@@ -98,19 +79,20 @@ newline in the expected result."
(progn
(insert "~% (is equal")
(insert "~% '(")
- (loop :for line :in (str:split #\Newline expected)
+ (loop :for line :in (split-by-newline expected)
:for i :from 0
:unless (zerop i)
:do (insert "~% ")
:do (insert "~s" line))
(insert ")")
- (insert "~% (str:split #\\Newline (~:R request)))" i))
+ (insert "~% (split-by-newline (~:R request)))" i))
(insert "~% (is string= ~s (~:R request))" expected i))
(insert "~% (false (~:R request))" i)))
;; TODO I sorely need something more declarative for those kinds of
;; snippets... Which is why I'm working so much on having good tests
;; for the snippets in the first place!
+#++
(define-command insert-test ()
"Insert a missing test!"
(augment-context-by-parsing-the-buffer (breeze.command:context*))
@@ -177,7 +159,7 @@ newline in the expected result."
;; This is emacs lisps to add a binding to the command "insert-test"
;; defined just above:
-#++
+#+elisp
(progn
(defun breeze--insert-test ()
(interactive)
@@ -225,7 +207,7 @@ newline in the expected result."
'("(cl:in-package #:cl)"
""
"")
- (str:split #\Newline (second request))))
+ (split-by-newline (second request))))
(destructuring-bind (input request) (fifth trace)
(false input)
(is string= "insert" (first request))
@@ -234,7 +216,7 @@ newline in the expected result."
" (:use :cl :asdf))"
""
"")
- (str:split #\Newline (second request))))
+ (split-by-newline (second request))))
(destructuring-bind (input request) (sixth trace)
(false input)
(is string= "insert" (first request))
@@ -242,7 +224,7 @@ newline in the expected result."
'("(in-package #:a.asd)"
""
"")
- (str:split #\Newline (second request))))
+ (split-by-newline (second request))))
(destructuring-bind (input request) (seventh trace)
(false input)
(is string= "insert" (first request))
@@ -258,7 +240,7 @@ newline in the expected result."
" :components"
" (#+(or) (:file \"todo\")))"
"")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test+run insert-breeze-define-command
(let* ((trace (drive-command #'insert-breeze-define-command
@@ -276,38 +258,35 @@ newline in the expected result."
'("(define-command rmrf ()"
" \"Rmrf.\""
" )")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test+run insert-defun
- (let* ((trace (drive-command #'insert-defun
- :inputs '("real-fun" "a &optional b")
- :context '())))
- (common-trace-asserts 'insert-defun trace 7)
- (destructuring-bind (input request) (first trace)
- (is string= "insert" (first request))
- (is string= "(defun " (second request)))
- (destructuring-bind (input request) (second trace)
- (is string= "read-string" (first request))
- (is string= "Name: " (second request))
- (is string= nil (third request)))
- (destructuring-bind (input request) (third trace)
- (is equal '"real-fun" input)
- (is string= "insert" (first request))
- (is string= "real-fun (" (second request)))
- (destructuring-bind (input request) (fourth trace)
- (is string= "read-string" (first request))
- (is string= "Enter the arguments: " (second request))
- (is string= nil (third request)))
- (destructuring-bind (input request) (fifth trace)
- (is equal '"a &optional b" input)
- (is string= "insert" (first request))
- (is equal
- '("a &optional b)"
- ")")
- (str:split #\Newline (second request))))
- (destructuring-bind (input request) (sixth trace)
- (is string= "backward-char" (first request))
- (is string= nil (second request)))))
+ (let* ((trace (drive-command #'insert-defun
+ :inputs '("real-fun" "a &optional b")
+ :context '())))
+ (common-trace-asserts 'insert-defun trace 6)
+ (destructuring-bind (input request) (first trace)
+ (is string= "insert" (first request))
+ (is string= "(defun " (second request)))
+ (destructuring-bind (input request) (second trace)
+ (is string= "read-string" (first request))
+ (is string= "Name: " (second request))
+ (is string= nil (third request)))
+ (destructuring-bind (input request) (third trace)
+ (is equal '"real-fun" input)
+ (is string= "insert" (first request))
+ (is string= "real-fun (" (second request)))
+ (destructuring-bind (input request) (fourth trace)
+ (is string= "read-string" (first request))
+ (is string= "Enter the arguments: " (second request))
+ (is string= nil (third request)))
+ (destructuring-bind (input request) (fifth trace)
+ (is equal '"a &optional b" input)
+ (is string= "insert" (first request))
+ (is equal
+ '("a &optional b)"
+ ")")
+ (split-by-newline (second request))))))
(define-test insert-defvar
@@ -336,7 +315,7 @@ newline in the expected result."
(is equal
'("42"
"")
- (str:split #\Newline (second request))))
+ (split-by-newline (second request))))
(destructuring-bind (input request) (sixth trace)
(is string= "read-string" (first request))
(is string= "Documentation string " (second request))
@@ -365,13 +344,13 @@ newline in the expected result."
" :initarg :slot"
" :accessor klass-slot))"
" (:documentation \"\"))")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test insert-defmacro
(let* ((trace (drive-command #'insert-defmacro
:inputs '("mac" "(x) &body body")
:context '())))
- (common-trace-asserts 'insert-defmacro trace 7)
+ (common-trace-asserts 'insert-defmacro trace 6)
(destructuring-bind (input request) (first trace)
(is string= "insert" (first request))
(is string= "(defmacro " (second request)))
@@ -393,29 +372,26 @@ newline in the expected result."
(is equal
'("(x) &body body)"
")")
- (str:split #\Newline (second request))))
- (destructuring-bind (input request) (sixth trace)
- (is string= "backward-char" (first request))
- (is string= nil (second request)))))
+ (split-by-newline (second request))))))
(define-test+run insert-defgeneric
- (let* ((trace (drive-command #'insert-defgeneric
- :inputs '("gen")
- :context '())))
- (common-trace-asserts 'insert-defgeneric trace 3)
- (destructuring-bind (input request) (first trace)
- (is string= "read-string" (first request))
- (is string= "Name of the generic function: " (second request))
- (is string= nil (third request)))
- (destructuring-bind (input request) (second trace)
- (is equal '"gen" input)
- (is string= "insert" (first request))
- (is equal
- '("(defgeneric gen ()"
- " (:documentation \"\")"
- " #++(:method-combination + #++ :most-specific-last)"
- " (:method () ()))")
- (str:split #\Newline (second request))))))
+ (let* ((trace (drive-command #'insert-defgeneric
+ :inputs '("gen")
+ :context '())))
+ (common-trace-asserts 'insert-defgeneric trace 3)
+ (destructuring-bind (input request) (first trace)
+ (is string= "read-string" (first request))
+ (is string= "Name of the generic function: " (second request))
+ (is string= nil (third request)))
+ (destructuring-bind (input request) (second trace)
+ (is equal '"gen" input)
+ (is string= "insert" (first request))
+ (is equal
+ '("(defgeneric gen ()"
+ " (:documentation \"\")"
+ " #++(:method-combination + #++ :most-specific-last)"
+ " (:method () ()))")
+ (split-by-newline (second request))))))
(define-test insert-defmethod
(let* ((trace (drive-command #'insert-defmethod
@@ -432,7 +408,7 @@ newline in the expected result."
(is equal
'("(defmethod frob ()"
" )")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
;; TODO Variants: *insert-defpackage/cl-user-prefix*
;; TODO infer-project-name
@@ -462,49 +438,49 @@ newline in the expected result."
" (:use #:cl))"
""
"(in-package #:pkg)")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test+run insert-defparameter
- (let* ((trace (drive-command #'insert-defparameter
- :inputs '("param" "\"meh\""
- "This is a meh variable")
- :context '())))
- (common-trace-asserts 'insert-defparameter trace 8)
- (destructuring-bind (input request) (first trace)
- (false input)
- (is string= "insert" (first request))
- (is string= "(defparameter " (second request)))
- (destructuring-bind (input request) (second trace)
- (false input)
- (is string= "read-string" (first request))
- (is string= "Name: " (second request))
- (false (third request)))
- (destructuring-bind (input request) (third trace)
- (is string= "param" input)
- (is string= "insert" (first request))
- (is string= "*param* " (second request)))
- (destructuring-bind (input request) (fourth trace)
- (false input)
- (is string= "read-string" (first request))
- (is string= "Initial value: " (second request))
- (false (third request)))
- (destructuring-bind (input request) (fifth trace)
- (is string= "\"meh\"" input)
- (is string= "insert" (first request))
- (is equal
- '("\"meh\""
- "")
- (str:split #\Newline (second request))))
- (destructuring-bind (input request) (sixth trace)
- (false input)
- (is string= "read-string" (first request))
- (is string= "Documentation string " (second request))
- (false (third request)))
- (destructuring-bind (input request) (seventh trace)
- (is string= "This is a meh variable" input)
- (is string= "insert" (first request))
- (is string= "\"This is a meh variable\")" (second request)))))
+ (let* ((trace (drive-command #'insert-defparameter
+ :inputs '("param" "\"meh\""
+ "This is a meh variable")
+ :context '())))
+ (common-trace-asserts 'insert-defparameter trace 8)
+ (destructuring-bind (input request) (first trace)
+ (false input)
+ (is string= "insert" (first request))
+ (is string= "(defparameter " (second request)))
+ (destructuring-bind (input request) (second trace)
+ (false input)
+ (is string= "read-string" (first request))
+ (is string= "Name: " (second request))
+ (false (third request)))
+ (destructuring-bind (input request) (third trace)
+ (is string= "param" input)
+ (is string= "insert" (first request))
+ (is string= "*param* " (second request)))
+ (destructuring-bind (input request) (fourth trace)
+ (false input)
+ (is string= "read-string" (first request))
+ (is string= "Initial value: " (second request))
+ (false (third request)))
+ (destructuring-bind (input request) (fifth trace)
+ (is string= "\"meh\"" input)
+ (is string= "insert" (first request))
+ (is equal
+ '("\"meh\""
+ "")
+ (split-by-newline (second request))))
+ (destructuring-bind (input request) (sixth trace)
+ (false input)
+ (is string= "read-string" (first request))
+ (is string= "Documentation string " (second request))
+ (false (third request)))
+ (destructuring-bind (input request) (seventh trace)
+ (is string= "This is a meh variable" input)
+ (is string= "insert" (first request))
+ (is string= "\"This is a meh variable\")" (second request)))))
(define-test insert-handler-bind-form
(let* ((trace (drive-command #'insert-handler-bind-form
@@ -519,7 +495,7 @@ newline in the expected result."
" ((error #'(lambda (condition)"
" (describe condition *debug-io*))))"
" (frobnicate))")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test insert-handler-case-form
(let* ((trace (drive-command #'insert-handler-case-form
@@ -534,7 +510,7 @@ newline in the expected result."
" (frobnicate)"
" (error (condition)"
" (describe condition *debug-io*)))")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
(define-test insert-in-package-cl-user
(let* ((trace (drive-command #'insert-in-package-cl-user
@@ -672,7 +648,7 @@ newline in the expected result."
" (print-unreadable-object"
" (node stream :type t :identity nil)"
" (format stream \"~s\" (node-something node))))")
- (str:split #\Newline (second request))))))
+ (split-by-newline (second request))))))
;; TODO
(define-test+run insert-parachute-define-test)
@@ -765,6 +741,6 @@ strings get concatenated."
#+ (or)
-(context-buffer-string
+(buffer-string
(alexandria:plist-hash-table
'(:buffer-string "asdf")))
diff --git a/tests/xref.lisp b/tests/xref.lisp
index bcc33658..3d43bb73 100644
--- a/tests/xref.lisp
+++ b/tests/xref.lisp
@@ -14,7 +14,7 @@
(define-test find-package
(is equal
(find-packages-by-prefix "breeze")
- (find-packages-by-regex "breeze.*")))
+ (find-packages-by-prefix "breeze.")))
(defparameter *symbols*
'(dum:*bound-variable*
@@ -79,7 +79,7 @@
(with-output-to-string (*standard-output*)
(loop :for symbol :being :the :external-symbol :of 'breeze.dummy.test
:for pass = (funcall fn symbol)
- :unless (str:containsp "undocumented" (string-downcase (symbol-name symbol)))
+ :unless (search "undocumented" (string-downcase (symbol-name symbol)))
:do
(format t "~&(is ")
(unless pass (format t "(not "))
diff --git a/workbench.el b/workbench.el
new file mode 100644
index 00000000..e8d9861d
--- /dev/null
+++ b/workbench.el
@@ -0,0 +1,72 @@
+
+(setf debug-on-error t)
+(setf debug-on-error nil)
+
+;; Useful for debugging whether slime or sly is running
+(process-list)
+
+
+;;; Reloading
+
+(breeze-eval "(asdf:load-system '#:breeze :force t)")
+(load breeze-breeze.el)
+
+
+;;; Listener
+
+(breeze-list-loaded-listeners)
+
+(breeze-choose-listener)
+
+(breeze-check-if-listener-connected)
+
+(completing-read "Choose a lisp listener to start: "
+ '(sly slime) nil t)
+
+
+;;; Eval
+
+(breeze-eval "1")
+(breeze-eval "'(a b c)")
+(breeze-eval "t")
+(breeze-eval "(not nil)")
+
+
+
+;;; Initialization
+
+(breeze-validate-if-package-exists "cl")
+
+(breeze-validate-if-package-exists "breeze")
+
+(breeze-validate-if-breeze-package-exists)
+
+
+;;; "Dynamic" emacs commands
+
+(breeze-translate-command-lambda-list '(a b c))
+
+(breeze-translate-command-lambda-list '(a::1 b:2 c::3))
+
+(breeze-refresh-commands)
+
+(symbol-function 'breeze-scaffold-project)
+
+
+;;; Trying to make breeze system load automatically... and
+;;; asynchronously if it make sense.
+
+(breeze-add-hooks 'slime)
+(breeze-add-hooks 'sly) ; not implemented yet
+
+
+;;; Other listener hooks
+
+slime-connected-hook
+slime-inferior-process-start-hook
+slime-net-process-close-hooks
+slime-cycle-connections-hook
+slime-connected-hook
+slime-event-hooks
+
+;; contribs (like slime-repl) defines even more hooks
diff --git a/workbench.lisp b/workbench.lisp
index ceb0563d..ef4d6cc5 100644
--- a/workbench.lisp
+++ b/workbench.lisp
@@ -25,6 +25,30 @@
;; Kill all currently running breeze-commands
(kill-threads-by-name "breeze command handler")
+
+(defvar *default-trace-report-default* sb-debug:*trace-report-default*)
+
+;; tracing is very very useful for debugging, but the default way sbcl
+;; often prints "way too much" stuff
+(defun trace-report (depth function event stack-frame values)
+ ;; (pprint-logical-block stream values :prefix ... :suffix ...)
+ (let ((*print-pretty* nil)
+ (stream *standard-output*))
+ (terpri stream)
+ (pprint-logical-block (stream values
+ :per-line-prefix (format nil "~v@{~A~:*~}" depth " |"))
+ ;; (loop :repeat depth :do (format stream " |"))
+ (pprint-indent :current depth stream)
+ (case event
+ (:enter
+ (format stream "~3d (~a ~{~a~^ ~})" depth function values))
+ (:exit
+ (format stream "~3d => ~{~a~^, ~}" depth values))
+ (t
+ (format stream "~3d ~s (~a ~{~a~^ ~})" depth event function values))))))
+
+(setf sb-debug:*trace-report-default* 'trace-report)
+
(setf *break-on-signals* 'error)
@@ -95,6 +119,26 @@
(context *a*)
+;;; Prototyping the request thingy...
+
+(request 'x)
+;; => nil
+
+(handler-bind
+ ((request #'(lambda (request)
+ ;; (format t "~%request: ~s" request)
+ (if (eq (what request) 'x)
+ (answer 42)
+ (signal request)))))
+ (mapcar (lambda (what)
+ (multiple-value-list (request what)))
+ '(x y)))
+;; => ((42 T) (NIL))
+
+(with-answers
+ ())
+
+
;; refactor.lisp
@@ -113,11 +157,11 @@
)
(let* ((*standard-output* *debug-io*)
- (nodes )
- (path )
- (outer-node )
- (parent-node )
- (inner-node ))
+ (nodes)
+ (path)
+ (outer-node)
+ (parent-node)
+ (inner-node))
(loop :for (node . index) :in path
:for i :from 0
:do (format t "~%=== Path part #~d, index ~d ===~%~s"
@@ -163,15 +207,125 @@
;;; lossless-reader.lisp
+(in-package #:breeze.lossless-reader)
+
(trace
read-string*
- read-char*)
+ read-char*
+ read-while)
(trace
- %read-whitespaces
- %read-block-comment
- %read-token
+ read-whitespaces
+ read-block-comment
+ read-line-comment
+ read-sharpsign-dispatching-reader-macro
+ read-punctuation
+ ;; read-quoted-string
+ read-string
+ read-token
read-parens
- read-extraneous-closing-parens)
+ read-extraneous-closing-parens
+ read-any
+ parse)
+
+(untrace)
+
+
+
+
+(in-package #:breeze.pattern)
+
+(trace iterator-next
+ iterator-maybe-push
+ iterator-maybe-pop)
+
+(trace merge-bindings)
+
+(trace match)
+
+(untrace)
+
+
+(in-package #:breeze.test.pattern)
+
+(test-match '(:zero-or-more a b) '(a b a b))
+
+(trace compile-pattern)
+
+(trace match :methods t)
+
+(trace :wherein test-match-ref
+ ;; match
+ merge-bindings)
+
+
+(in-package #:breeze.test.analysis)
+
+(trace in-package-node-p
+ :wherein test-in-package-node-p)
+
+(trace :wherein test-lint
+ in-package-node-p)
+
+(trace match
+ :wherein test-in-package-node-p)
+
+(trace
+ :wherein test-match-parse
+ match
+ breeze.analysis::match-symbol-to-token
+ breeze.analysis::match-node)
(untrace)
+
+
+(trace lint)
+
+
+
+(in-package #:breeze.listener)
+
+(trace suggest-symbol
+ suggest-package
+ suggest-class)
+
+
+
+(progn
+ ;; List the slot of a condition
+ (sb-kernel::condition-assigned-slots *condition*)
+
+ ;; Get the first element of a condition's format arguments
+ (car
+ (slot-value *condition*
+ 'sb-kernel::format-arguments)))
+
+
+
+(defparameter *condition* *last-condition*
+ "Just a quick way to save the last-condition.")
+
+
+
+#+ (or)
+(type-of *condition*)
+;; => SB-PCL::MISSING-SLOT
+
+
+
+(prin t)
+(commmon-lisp:print :oups)
+(cl:prin :oups)
+(call-with-correction-suggestion (lambda () (eval '(prin))))
+(make-instance 'typos)
+
+
+
+
+#|
+
+TODO Would be nice to have a "Shadow-import all" restart.
+
+|#
+
+