[nongnu] elpa/parseclj 1eef0b62c8 034/185: Support #_discard forms

[ELPA Syncer]

branch: elpa/parseclj
commit 1eef0b62c85a95a175f98468b1146ca2819d9cee
Author: Arne Brasseur <arne@arnebrasseur.net>
Commit: Arne Brasseur <arne@arnebrasseur.net>

    Support #_discard forms
---
 clj-lex-test.el   | 21 ++++++++++++++++++++-
 clj-lex.el        | 15 ++++++++++++++-
 clj-parse-test.el |  7 ++++++-
 clj-parse.el      | 45 ++++++++++++++++++++++++++-------------------
 4 files changed, 66 insertions(+), 22 deletions(-)

diff --git a/clj-lex-test.el b/clj-lex-test.el
index 99cea11c28..405420afcb 100644
--- a/clj-lex-test.el
+++ b/clj-lex-test.el
@@ -132,7 +132,26 @@
     (goto-char 1)
     (should (equal (clj-lex-next) (clj-lex-token :set "#{" 1)))
     (should (equal (clj-lex-next) (clj-lex-token :keyword ":x" 3)))
-    (should (equal (clj-lex-next) (clj-lex-token :rbrace "}" 5)))))
+    (should (equal (clj-lex-next) (clj-lex-token :rbrace "}" 5))))
+
+  (with-temp-buffer
+    (insert "(10 #_11 12 #_#_ 13 14)")
+    (goto-char 1)
+    (should (equal (clj-lex-next) (clj-lex-token :lparen "(" 1)))
+    (should (equal (clj-lex-next) (clj-lex-token :number "10" 2)))
+    (should (equal (clj-lex-next) (clj-lex-token :whitespace " " 4)))
+    (should (equal (clj-lex-next) (clj-lex-token :discard "#_" 5)))
+    (should (equal (clj-lex-next) (clj-lex-token :number "11" 7)))
+    (should (equal (clj-lex-next) (clj-lex-token :whitespace " " 9)))
+    (should (equal (clj-lex-next) (clj-lex-token :number "12" 10)))
+    (should (equal (clj-lex-next) (clj-lex-token :whitespace " " 12)))
+    (should (equal (clj-lex-next) (clj-lex-token :discard "#_" 13)))
+    (should (equal (clj-lex-next) (clj-lex-token :discard "#_" 15)))
+    (should (equal (clj-lex-next) (clj-lex-token :whitespace " " 17)))
+    (should (equal (clj-lex-next) (clj-lex-token :number "13" 18)))
+    (should (equal (clj-lex-next) (clj-lex-token :whitespace " " 20)))
+    (should (equal (clj-lex-next) (clj-lex-token :number "14" 21)))
+    (should (equal (clj-lex-next) (clj-lex-token :rparen ")" 23)))))
 
 (ert-deftest clj-lex-test-at-number? ()
   (dolist (str '("123" ".9" "+1" "0" "-456"))
diff --git a/clj-lex.el b/clj-lex.el
index 4901667d3f..af6581ed01 100644
--- a/clj-lex.el
+++ b/clj-lex.el
@@ -30,6 +30,16 @@
                 (cons (car pair) (cadr pair)))
               (-partition 2 args))))
 
+(defun clj-lex-token-type (token)
+  (and (listp token)
+       (cdr (assq 'type token))))
+
+(defun clj-lex-token? (token)
+  (and (listp token)
+       (consp (car token))
+       (eq 'type (caar token))
+       (not (listp (cdar token)))))
+
 (defun clj-lex-at-whitespace? ()
   (let ((char (char-after (point))))
     (or (equal char ?\ )
@@ -214,7 +224,10 @@
           (cl-case char
             (?{
              (right-char)
-             (clj-lex-token :set "#{" pos)))))
+             (clj-lex-token :set "#{" pos))
+            (?_
+             (right-char)
+             (clj-lex-token :discard "#_" pos)))))
 
        ":("))))
 
diff --git a/clj-parse-test.el b/clj-parse-test.el
index ef06cb6d04..90e385fad7 100644
--- a/clj-parse-test.el
+++ b/clj-parse-test.el
@@ -94,7 +94,12 @@
   (with-temp-buffer
     (insert "#{:x}")
     (goto-char 1)
-    (should (equal (clj-parse) '((:x))))))
+    (should (equal (clj-parse) '((:x)))))
+
+  (with-temp-buffer
+    (insert "(10 #_11 12 #_#_ 13 14)")
+    (goto-char 1)
+    (should (equal (clj-parse) '((10 12))))))
 
 (provide 'clj-parse-test)
 
diff --git a/clj-parse.el b/clj-parse.el
index 85cfd7db66..37c724af0c 100644
--- a/clj-parse.el
+++ b/clj-parse.el
@@ -93,29 +93,31 @@
     (:character (cons (clj-parse-character (cdr (assq 'form token))) stack))))
 
 (defun clj-parse-edn-reduceN (stack type coll)
-  (cons
-   (cl-case type
-     (:whitespace :ws)
-     (:number coll)
-     (:list (-butlast (cdr coll)))
-     (:set (-butlast (cdr coll)))
-     (:vector (apply #'vector (-butlast (cdr coll))))
-     (:map (mapcar (lambda (pair)
-                     (cons (car pair) (cadr pair)))
-                   (-partition 2 (-butlast (cdr coll))))))
-   stack))
+  (if (eq :discard type)
+      stack
+    (cons
+     (cl-case type
+       (:whitespace :ws)
+       (:number coll)
+       (:list (-butlast (cdr coll)))
+       (:set (-butlast (cdr coll)))
+       (:vector (apply #'vector (-butlast (cdr coll))))
+       (:map (mapcar (lambda (pair)
+                       (cons (car pair) (cadr pair)))
+                     (-partition 2 (-butlast (cdr coll))))))
+     stack)))
 
 ;; TODO move this to clj-lex
-(defun clj-parse--token-type (token)
+(defun clj-lex-token-type (token)
   (and (listp token)
        (cdr (assq 'type token))))
 
 (defun clj-parse--reduce-coll (stack open-token coll-type reducN)
   (let ((coll nil))
     (while (and stack
-                (not (eq (clj-parse--token-type (car stack)) open-token)))
+                (not (eq (clj-lex-token-type (car stack)) open-token)))
       (push (pop stack) coll))
-    (if (eq (clj-parse--token-type (car stack)) open-token)
+    (if (eq (clj-lex-token-type (car stack)) open-token)
         (progn
           (push (pop stack) coll)
           (funcall reduceN stack coll-type coll))
@@ -126,30 +128,35 @@
   (let ((stack nil)
         (token (clj-lex-next)))
 
-    (while (not (eq (clj-parse--token-type token) :eof))
+    (while (not (eq (clj-lex-token-type token) :eof))
       (message "STACK: %S" stack)
       (message "TOKEN: %S\n" token)
 
       (setf stack
-            (if (member (clj-parse--token-type token)
+            (if (member (clj-lex-token-type token)
                         clj-parse--leaf-tokens)
                 (funcall reduce1 stack token)
               (cons token stack)))
 
-      (cl-case (clj-parse--token-type (car stack))
+      ;; Reduce based on the top item on the stack (collections)
+      (cl-case (clj-lex-token-type (car stack))
         (:rparen (setf stack (clj-parse--reduce-coll stack :lparen :list 
reduceN)))
         (:rbracket (setf stack (clj-parse--reduce-coll stack :lbracket :vector 
reduceN)))
         (:rbrace
          (let ((open-token (-find (lambda (token)
-                                    (member (clj-parse--token-type token) 
'(:lbrace :set)))
+                                    (member (clj-lex-token-type token) 
'(:lbrace :set)))
                                   stack)))
 
-           (cl-case (clj-parse--token-type open-token)
+           (cl-case (clj-lex-token-type open-token)
              (:lbrace
               (setf stack (clj-parse--reduce-coll stack :lbrace :map reduceN)))
              (:set
               (setf stack (clj-parse--reduce-coll stack :set :set 
reduceN)))))))
 
+      ;; Reduce based on top two items on the stack
+      (if (not (clj-lex-token? (car stack))) ;; top is fully reduced
+          (cl-case (clj-lex-token-type (second stack))
+            (:discard (setf stack (funcall reduceN (cddr stack) :discard 
(-take 2 stack))))))
 
       (setq token (clj-lex-next)))