From a57d40439ef49703ea7b3c5a5110c69abb61cd72 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Tue, 19 Mar 2024 17:33:22 +0100 Subject: [PATCH] Add {TEXT,PUNCTUATION}-WAD and use them in MAKE-TEXT-WADS --- code/client.lisp | 64 ++++++++++++++++++++++++++------------------- code/package.lisp | 2 ++ code/wad.lisp | 20 +++++++++----- test/test.lisp | 5 +++- test/utilities.lisp | 9 ++++--- 5 files changed, 62 insertions(+), 38 deletions(-) diff --git a/code/client.lisp b/code/client.lisp index 7a3ebf7..4319de0 100644 --- a/code/client.lisp +++ b/code/client.lisp @@ -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) @@ -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)) @@ -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) @@ -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 @@ -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 diff --git a/code/package.lisp b/code/package.lisp index 301ce04..c3770d7 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -71,6 +71,8 @@ #:read-suppress-wad #:reader-macro-wad + #:text-wad + #:punctuation-wad #:word-wad #:misspelled ; reader diff --git a/code/wad.lisp b/code/wad.lisp index fdbf0e5..848ba0d 100644 --- a/code/wad.lisp +++ b/code/wad.lisp @@ -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))) diff --git a/test/test.lisp b/test/test.lisp index 6765250..d44a9d2 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -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)) () diff --git a/test/utilities.lisp b/test/utilities.lisp index 5e05199..3bd4fce 100644 --- a/test/utilities.lisp +++ b/test/utilities.lisp @@ -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))