Skip to content

Commit

Permalink
use vectors instead of lists for node children
Browse files Browse the repository at this point in the history
  • Loading branch information
@fstamour
fstamour committed Dec 23, 2024
1 parent 0ab4f25 commit 8ea5072
Show file tree
Hide file tree
Showing 5 changed files with 243 additions and 202 deletions.
55 changes: 44 additions & 11 deletions src/analysis.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,8 +79,9 @@ children nodes."
(and (null package)
(node-string-equal state symbol-node name)))
((qualified-symbol possibly-internal-symbol)
(destructuring-bind (package-name-node symbol-name-node)
(node-children symbol-node)
(let* ((nodes (node-children symbol-node))
(package-name-node (first-node nodes))
(symbol-name-node (second-node nodes)))
(and
(node-string-equal state symbol-name-node name)
(some (lambda (package-name)
Expand Down Expand Up @@ -193,13 +194,21 @@ N.B. This doesn't guarantee that it's a valid node."

(defun find-node (position nodes)
"Given a list of NODES, return which node contains the POSITION."
(when (listp nodes)
(loop :for node :in nodes
:for start = (node-start node)
:for end = (node-end node)
:for i :from 0
:when (and (<= start end) (< position end))
:do (return (cons node i)))))
(typecase nodes
(vector
(loop :for node :across nodes
:for start = (node-start node)
:for end = (node-end node)
:for i :from 0
:when (and (<= start end) (< position end))
:do (return (cons node i))))
(cons
(loop :for node :in nodes
:for start = (node-start node)
:for end = (node-end node)
:for i :from 0
:when (and (<= start end) (< position end))
:do (return (cons node i))))))

(defun find-path-to-position (state position)
"Given a list of NODES, return a path (list of cons (node . index))"
Expand Down Expand Up @@ -227,6 +236,7 @@ N.B. This doesn't guarantee that it's a valid node."
(list
(loop
:for i :from 0
:for firstp = (zerop i)
:for previous = nil :then (first rest)
:for rest :on tree
:for node = (car rest)
Expand All @@ -237,13 +247,36 @@ N.B. This doesn't guarantee that it's a valid node."
(cb node
:aroundp t
:nth i
:firstp (eq tree rest)
:lastp (null (cdr rest))
:firstp firstp
:lastp (null next)
:previous previous
:next next
:quotedp quotedp)
(1+ depth)
quotedp)))
(vector
(nodes
(loop
:for i :from 0
:for firstp = (zerop i)
:for lastp = (= (1- (length tree)) i)
:for previous = nil :then node
;; :for rest :on tree
:for node :across tree
:for next = (unless lastp (aref tree (1+ i)))
;; Recurse
:collect (%walk state
callback
(cb node
:aroundp t
:nth i
:firstp firstp
:lastp (null next)
:previous previous
:next next
:quotedp quotedp)
(1+ depth)
quotedp))))
(node
(case (node-type tree)
(parens
Expand Down
87 changes: 53 additions & 34 deletions src/lossless-reader.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,12 +25,17 @@ common lisp.")
#:node-end
#:node-type
#:node-children
#:ensure-nodes
#:append-nodes
#:nodes
#:copy-node
#:valid-node-p
#:node-content)
;; Node sequences
(:export #:ensure-nodes
#:append-nodes
#:nodes
#:nth-node
#:first-node
#:second-node
#:last-node)
;; Node constructors
(:export #:block-comment
#:parens
Expand Down Expand Up @@ -251,23 +256,43 @@ common lisp.")

(defun ensure-nodes (x)
"Ensure that that X is a sequence of node."
(if (listp x)
x
(list x)))
(typecase x
(null nil)
(vector x)
(cons (coerce x 'vector))
(t (vector x))))

(defun append-nodes (nodes1 nodes2)
"Concatenate two sequences of nodes."
(append nodes1 nodes2))
(concatenate 'vector nodes1 nodes2))

;; (declaim (inline %nodes))
(defun %nodes (x y)
"Create a sequence of nodes. But less used-friendly."
(append-nodes (ensure-nodes x) (ensure-nodes y)))
(if x
(if y
(append-nodes (ensure-nodes x) (ensure-nodes y))
(ensure-nodes x))
(when y (ensure-nodes y))))

(defun nodes (&optional node &rest nodes)
"Create a sequence of nodes."
(%nodes node nodes))


(defun nth-node (nodes n)
(when nodes
(aref nodes n)))

(defun first-node (nodes)
(nth-node nodes 0))

(defun second-node (nodes)
(nth-node nodes 1))

(defun last-node (nodes)
(nth-node nodes (1- (length nodes))))

(defun node (type start end &optional child &rest children)
#++ (when (= +end+ end)
(break))
Expand Down Expand Up @@ -845,15 +870,7 @@ first node being whitespaces.)"
(when (read-char* state #\=)
(multiple-value-bind (end children)
(read-any* state)
;; TODO sharp-label would benefit from having it own data
;; structure, this is abusing the children
(node 'sharp-label start end
(append
(when (and (integerp number)
(<= 0 number))
(list :label number))
(when children
(list :form children)))))))
(node 'sharp-label start end (%nodes number children)))))

(defun read-sharpsign-sharpsign (state start number)
(when (read-char* state #\#)
Expand Down Expand Up @@ -1104,8 +1121,8 @@ Returns a new node with one of these types:
:when el
:collect el :into content
:unless (valid-node-p el)
:do (return (parens start +end+ content))
:finally (return (parens start (pos state) content)))))
:do (return (parens start +end+ (ensure-nodes content)))
:finally (return (parens start (pos state) (ensure-nodes content))))))

;; TODO add tests with skip-whitespaces-p set
(defun read-any (state &optional skip-whitespaces-p)
Expand Down Expand Up @@ -1220,21 +1237,23 @@ Returns a new node with one of these types:
(end node)))))

(defun %unparse (tree state stream depth transform)
(when tree
(if (listp tree)
(mapcar (lambda (node)
(%unparse (funcall transform node)
state stream (1+ depth)
transform))
tree)
(case (node-type tree)
(parens
(write-char #\( stream)
(%unparse (node-children tree) state stream depth transform)
(unless (no-end-p tree)
(write-char #\) stream)))
(t
(write-node (funcall transform tree) state stream))))))
(etypecase tree
(null)
((or vector cons)
(map nil (lambda (node)
(%unparse (funcall transform node)
state stream (1+ depth)
transform))
tree))
(node
(case (node-type tree)
(parens
(write-char #\( stream)
(%unparse (node-children tree) state stream depth transform)
(unless (no-end-p tree)
(write-char #\) stream)))
(t
(write-node (funcall transform tree) state stream))))))

(defun unparse (state &optional (stream t) (transform #'identity))
(if stream
Expand Down
102 changes: 30 additions & 72 deletions tests/analysis.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,10 @@
#'string<
:key #'car))))

(defun make-binding (term input)
(normalize-bindings
(breeze.pattern::make-binding term input)))

(defun test-match-parse (pattern string &optional skip-whitespaces-and-comments)
(let* ((state (parse string))
(*match-skip* (when skip-whitespaces-and-comments
Expand Down Expand Up @@ -174,29 +178,29 @@
(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)))
(make-binding :?x (list (token 0 1)))
(test-match-parse :?x "x"))
(is equalp
(list :?x (list (whitespace 0 1) (token 1 2)))
(make-binding :?x (list (whitespace 0 1) (token 1 2)))
(test-match-parse :?x " x"))
(is equalp
(list :?x (list (whitespace 0 1) (token 1 2)))
(make-binding :?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))
(make-binding :?x (token 0 1))
(test-match-parse '(:?x) "x"))
(false (test-match-parse '(:?x) " x"))
(is equalp
(list :?x (token 1 2))
(make-binding :?x (token 1 2))
(test-match-parse '(:?x) " x" t))
(is equalp
(list :?x (parens 0 4 (list (token 1 3))))
(make-binding :?x (parens 0 4 (nodes (token 1 3))))
(test-match-parse '(:?x) "(42)"))
(is equalp
(list :?x (token 1 3))
(make-binding :?x (token 1 3))
(test-match-parse '((:?x)) "(42)"))))

(define-test+run "match vector against parse trees"
Expand Down Expand Up @@ -263,7 +267,7 @@
:for path = (find-node i (tree state))
:collect (cons (node-type (car path)) (cdr path)))))

(define-test find-path-to-position
(define-test+run find-path-to-position
(is equalp
'((whitespace)
(parens whitespace)
Expand All @@ -285,56 +289,6 @@
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

Expand Down Expand Up @@ -457,7 +411,7 @@
diags))

(defun test-fix (input)
(multiple-value-list (fix :buffer-string input)))
(multiple-value-list (fix :buffer-string (format nil input))))

(define-test+run test-fix
(is equal '("()" nil) (test-fix "()"))
Expand All @@ -468,20 +422,24 @@
;; (is equal '("()" t) (test-fix "("))
;; (is equal '("((()))" t) (test-fix "((("))
(is equal '("()" t) (test-fix "( )"))
(is equal '("()" t) (test-fix "(
)"))
(is equal '("(a b)" t) (test-fix "(a b)"))
(is equal '("()" t) (test-fix "(~%)"))
(is equal '("() " t) (test-fix "( ) "))
(is equal '("() " t) (test-fix "( ) "))
(is equal '(" ()" t) (test-fix " ( )"))
(is equal '(" () " t) (test-fix " ( ) "))
(is equal '("(a)" t) (test-fix "( a)"))
(is equal '("(a)" t) (test-fix "(a )"))
(is equal '("(a)" t) (test-fix "( a )"))
(is equal '("((a))" t) (test-fix "(
(
a
)
)"))
(is equal '("((a))" t) (test-fix "((
a
))"))
(is equal '("(a b)" t) (test-fix "(a b)"))
(is equal '("((a))" t) (test-fix "(~% (~% a~% )~%)"))
(is equal '("((a))" t) (test-fix "((~%~% a~%~% ))"))
;; TODO handle indentation levels!
#++
(progn
(is equal '("(;;~% )" t) (test-fix "(;;~% )"))
(is equal '("(;;~% )" t) (test-fix "(;;~% ~%)"))
;; TODO This should be detected as "extraneous internal newlines"...
(is equal '("(;;~% )" t) (test-fix "(;;~% ~%)")))
#++ ;; TODO more whitespace fixes
(progn
(is equal '("#+(or)" t) (test-fix "#+ (or)"))
Expand Down
Loading

0 comments on commit 8ea5072

Please sign in to comment.