Skip to content

Commit

Permalink
Add {TEXT,PUNCTUATION}-WAD and use them in MAKE-TEXT-WADS
Browse files Browse the repository at this point in the history
  • Loading branch information
@scymtym
scymtym committed Mar 19, 2024
1 parent 34a435b commit a57d404
Show file tree
Hide file tree
Showing 5 changed files with 62 additions and 38 deletions.
64 changes: 37 additions & 27 deletions code/client.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -126,33 +126,41 @@
,@extra-initargs)))
(make-children-relative-and-set-family-relations result))))

(defun make-word-wads (stream source
(defun make-text-wads (stream source
&key (start-column-offset 0)
(end-column-offset 0 end-column-offset-p))
(end-column-offset 0 end-column-offset-p)
(min-length 1))
(destructure-source (start-line start-column end-line end-column*) source
(let* ((cache (cache stream))
(word (make-array 0 :element-type 'character
(text (make-array 0 :element-type 'character
:adjustable t
:fill-pointer 0))
(word-start-column (+ start-column start-column-offset))
(words '()))
(text-start-column (+ start-column start-column-offset))
(wads '()))
(flet ((terminatingp (character)
(let ((spacep (whitespacep character))
(punctuationp (punctuationp character)))
(values (or spacep punctuationp) punctuationp)))
(commit (line column checkp)
(when (and (plusp (length word))
(notany #'digit-char-p word)
(notevery #'punctuationp word))
(let ((source (cons (cons line word-start-column)
(cons line column)))
(misspelledp (and checkp
(null (spell:english-lookup word)))))
(push (basic-wad 'word-wad stream source
:misspelled misspelledp)
words)))
(setf (fill-pointer word) 0
word-start-column column)))
(let ((length (length text))
(source (cons (cons line text-start-column)
(cons line column))))
(cond ((zerop length)) ; do not collect empty wads
((every #'punctuationp text)
(push (basic-wad 'punctuation-wad stream source)
wads))
((and (>= length min-length)
(notany #'digit-char-p text))
(let ((misspelledp (and checkp
(null (spell:english-lookup text)))))
(push (basic-wad 'word-wad stream source
:misspelled misspelledp)
wads)))
(t
(push (basic-wad 'text-wad stream source)
wads))))
(setf (fill-pointer text) 0
text-start-column column)))
(loop for line from start-line to (if (zerop end-column*)
(1- end-line)
end-line)
Expand All @@ -163,22 +171,22 @@
end-column-offset
0))
(length contents))
for column from word-start-column below end-column
for column from text-start-column below end-column
for character = (aref contents column)
for (terminatingp punctuationp)
= (multiple-value-list (terminatingp character))
do (cond ((not terminatingp)
(vector-push-extend character word))
(vector-push-extend character text))
(punctuationp
(commit line column t)
(vector-push-extend character word)
(vector-push-extend character text)
(commit line (1+ column) nil))
(t
(commit line column t)
(incf word-start-column)))
(incf text-start-column)))
finally (commit line column t))
(setf word-start-column 0))
(nreverse words)))))
(setf text-start-column 0))
(nreverse wads)))))

(defmethod eclector.parse-result:make-skipped-input-result
((client client) (stream t) (reason t) (source t))
Expand All @@ -188,13 +196,13 @@
;; end of the comment. But we want it to be the end of the
;; same line. But I don't know how to do it correctly (yet).
(let* ((semicolon-count (cdr reason))
(words (make-word-wads
(words (make-text-wads
stream source
:start-column-offset semicolon-count)))
(wad-with-children 'semicolon-comment-wad stream source words
:semicolon-count semicolon-count)))
((eql :block-comment)
(let ((words (make-word-wads stream source :start-column-offset 2
(let ((words (make-text-wads stream source :start-column-offset 2
:end-column-offset -2)))
(wad-with-children 'block-comment-wad stream source words)))
((eql :reader-macro)
Expand All @@ -210,7 +218,7 @@
((client client) (result symbol-token) (children t) (source t))
(if (and (null children)
(not (eq (package-name result) **common-lisp-package-name**)))
(let ((words (make-word-wads (stream* client) source)))
(let ((words (make-text-wads (stream* client) source :min-length 2)))
(if (null words)
(call-next-method)
(wad-with-children
Expand All @@ -220,7 +228,9 @@
(defmethod eclector.parse-result:make-expression-result
((client client) (result string) (children t) (source t))
(if (null children)
(let ((words (make-word-wads (stream* client) source)))
(let ((words (make-text-wads (stream* client) source
:start-column-offset 1
:end-column-offset -1)))
(if (null words)
(call-next-method)
(wad-with-children
Expand Down
2 changes: 2 additions & 0 deletions code/package.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,6 +71,8 @@
#:read-suppress-wad
#:reader-macro-wad

#:text-wad
#:punctuation-wad
#:word-wad
#:misspelled ; reader

Expand Down
20 changes: 13 additions & 7 deletions code/wad.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -477,16 +477,22 @@
(defclass reader-macro-wad (ignored-wad)
())

;;; `word-wad'
;;; `text-wad'
;;;
;;; A wad that represents a word within some atom (for example a
;;; symbol or a string) or skipped material (for example a semicolon
;;; comment or a block comment). A `word-wad' does not have any
;;; children.
;;; A wad that represents a piece of text such as word or punctuation
;;; within some atom (for example a symbol or a string) or skipped
;;; material (for example a semicolon comment or a block comment). A
;;; `text-wad' does not have any children.

(defclass word-wad (no-children-mixin
(defclass text-wad (no-children-mixin
non-cst-wad
wad) ; TODO should not inherit indentation; should use errors slot for misspelled information
wad) ; TODO should not inherit indentation
())

(defclass punctuation-wad (text-wad)
())

(defclass word-wad (text-wad) ; TODO should use errors slot for misspelled information
((%misspelled :initarg :misspelled
:reader misspelled)))

Expand Down
5 changes: 4 additions & 1 deletion test/test.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,11 +14,14 @@
'((inc:atom-wad ((0 0) (0 5)) (:raw "foo")
(inc:word-wad ((0 1) (0 4))))))
("\".\""
'((inc:atom-wad ((0 0) (0 3)) (:raw "."))))
'((inc:atom-wad ((0 0) (0 3)) (:raw ".")
(inc:text-wad ((0 1) (0 2))))))
("foo::bar"
'((inc:atom-wad ((0 0) (0 8))
(:raw (inc:symbol-token :symbol ("FOO" "BAR")))
(inc:word-wad ((0 0) (0 3)))
(inc:punctuation-wad ((0 3) (0 4)))
(inc:punctuation-wad ((0 4) (0 5)))
(inc:word-wad ((0 5) (0 8))))))
("#'foo"
`((inc:cons-wad ((0 0) (0 5)) ()
Expand Down
9 changes: 6 additions & 3 deletions test/utilities.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -228,9 +228,12 @@
(location symbol-name
&key (package-name "INCREMENTALIST.TEST.TEST-PACKAGE")
(token-class 'inc:non-existing-symbol-token)
(words (if (equal package-name "COMMON-LISP")
'()
`((inc:word-wad ,location)))))
(words (cond ((equal package-name "COMMON-LISP")
'())
((> (length symbol-name) 1)
`((inc:word-wad ,location)))
(t
`((inc:text-wad ,location))))))
`(inc:atom-wad ,location
(:raw (,token-class :symbol (,package-name ,symbol-name)))
,@words))
Expand Down

0 comments on commit a57d404

Please sign in to comment.