[nongnu] elpa/parseclj 7d70ee4c38 059/185: Add support for tagged literals

[ELPA Syncer]

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

    Add support for tagged literals
    
    Have the parse edn functions take an extra argument which is an alist of 
tagged
    reader literal handlers.
---
 DESIGN.md                  |  1 +
 clj-lex-test.el            | 11 ++++++++
 clj-parse.el               | 65 +++++++++++++++++++++++++++++-----------------
 tests/edn-el-test-suite.el | 63 ++++++++++++++++++++++----------------------
 4 files changed, 84 insertions(+), 56 deletions(-)

diff --git a/DESIGN.md b/DESIGN.md
index 1bc710156f..716c998624 100644
--- a/DESIGN.md
+++ b/DESIGN.md
@@ -33,6 +33,7 @@ The data structures available in Emacs are less rich than 
those used by Clojure.
 - Emacs has no "character" type (characters are represented as numbers)
 - Emacs does not support custom records/types (there is a Common Lisp inspired 
object system, but it implements types on top of regular lists and vectors).
 - Emacs does not support adding metadata to values
+- Emacs does not support bignums
 
 On the other hand Emacs supports strings/buffers with arbitrary encoding, on 
the JVM and on JavaScript strings are always UTF-16/UCS-2.
 
diff --git a/clj-lex-test.el b/clj-lex-test.el
index 44553571a4..d4bbad472b 100644
--- a/clj-lex-test.el
+++ b/clj-lex-test.el
@@ -267,6 +267,17 @@
     (goto-char 1)
     (should (equal (clj-lex-string) (clj-lex-token :string "\"abc\\\"\"" 1)))))
 
+(ert-deftest clj-lex-test-tag ()
+  (with-temp-buffer
+    (insert "#inst")
+    (goto-char 1)
+    (should (equal (clj-lex-next) (clj-lex-token :tag "#inst" 1))))
+
+  (with-temp-buffer
+    (insert "#foo/bar")
+    (goto-char 1)
+    (should (equal (clj-lex-next) (clj-lex-token :tag "#foo/bar" 1)))))
+
 (provide 'clj-lex-test)
 
 ;;; clj-lex-test.el ends here
diff --git a/clj-parse.el b/clj-parse.el
index e55a8ba379..3b53fc57ad 100644
--- a/clj-parse.el
+++ b/clj-parse.el
@@ -107,7 +107,6 @@
     (:string (clj-parse--string (alist-get 'form token)))
     (:character (clj-parse--character (alist-get 'form token)))))
 
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Shift-Reduce Parser
 
@@ -155,7 +154,7 @@
             (setf stack (funcall reduce-node (cddr stack) lookup (list 
top))))))
 
     ;; reduce root
-    (setf stack (funcall reduce-node stack '((type . :root) (pos . 0)) stack))
+    (setf stack (funcall reduce-node stack '((type . :root) (pos . 1)) stack))
     ;; (message "RESULT: %S" stack)
     stack))
 
@@ -204,31 +203,49 @@
       stack
     (push (clj-parse--leaf-token-value token) stack)))
 
-(defun clj-parse--edn-reduce-node (stack opener-token children)
-  (let ((type (clj-lex-token-type opener-token)))
-    (if (member type '(:root :discard))
-        stack
-      (push
-       (cl-case type
-         (:lparen children)
-         (:lbracket (apply #'vector children))
-         (:set (list 'edn-set children))
-         (:lbrace (let* ((kvs (seq-partition children 2))
-                         (hash-map (make-hash-table :test 'equal :size (length 
kvs))))
-                    (seq-do (lambda (pair)
-                              (puthash (car pair) (cadr pair) hash-map))
-                            kvs)
-                    hash-map)))
-       stack))))
-
-(defun clj-parse-edn ()
-  (clj-parse-reduce #'clj-parse--edn-reduce-leaf #'clj-parse--edn-reduce-node))
-
-(defun clj-parse-edn-str (s)
+(defun clj-parse--edn-reduce-node (tag-readers)
+  (lambda (stack opener-token children)
+    (let ((token-type (clj-lex-token-type opener-token)))
+      (if (member token-type '(:root :discard))
+          stack
+        (push
+         (cl-case token-type
+           (:lparen children)
+           (:lbracket (apply #'vector children))
+           (:set (list 'edn-set children))
+           (:lbrace (let* ((kvs (seq-partition children 2))
+                           (hash-map (make-hash-table :test 'equal :size 
(length kvs))))
+                      (seq-do (lambda (pair)
+                                (puthash (car pair) (cadr pair) hash-map))
+                              kvs)
+                      hash-map))
+           (:tag (let* ((tag (intern (substring (a-get opener-token 'form) 1)))
+                        (reader (a-get tag-readers tag :missing)))
+                   (when (eq :missing reader)
+                     (user-error "No reader for tag #%S in %S" tag (a-keys 
tag-readers)))
+                   (funcall reader (car children)))))
+         stack)))))
+
+(defvar clj-edn-default-tag-readers
+  (a-list 'inst (lambda (s)
+                  (list* 'edn-inst (date-to-time s)))
+          'uuid (lambda (s)
+                  (list 'edn-uuid s)))
+  "Default reader functions for handling tagged literals in EDN.
+These are the ones defined in the EDN spec, #inst and #uuid. It
+is not recommended you change this variable, as this globally
+changes the behavior of the EDN reader. Instead pass your own
+handlers as an optional argument to the reader functions.")
+
+(defun clj-parse-edn (&optional tag-readers)
+  (clj-parse-reduce #'clj-parse--edn-reduce-leaf
+                    (clj-parse--edn-reduce-node (a-merge 
clj-edn-default-tag-readers tag-readers))))
+
+(defun clj-parse-edn-str (s &optional tag-readers)
   (with-temp-buffer
     (insert s)
     (goto-char 1)
-    (car (clj-parse-reduce #'clj-parse--edn-reduce-leaf 
#'clj-parse--edn-reduce-node))))
+    (car (clj-parse-edn tag-readers))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Printer implementations
diff --git a/tests/edn-el-test-suite.el b/tests/edn-el-test-suite.el
index ba854a5b87..06f9ee4c36 100644
--- a/tests/edn-el-test-suite.el
+++ b/tests/edn-el-test-suite.el
@@ -166,20 +166,22 @@
  ;;comment in vector
  more vector items]"))))
 
-;; (defun test-val-passed-to-handler (val)
-;;   (should (listp val))
-;;   (should (= (length val) 2))
-;;   (should (= 1 (car val)))
-;;   1)
-
-;; (edn-add-reader "my/type" #'test-val-passed-to-handler)
-;; (edn-add-reader :my/other-type (lambda (val) 2))
-
-;; (ert-deftest tags ()
-;;   :tags '(edn tags)
-;;   (should-error (clj-parse-edn-str "#my/type value"))
-;;   (should (= 1 (clj-parse-edn-str "#my/type (1 2)")))
-;;   (should (= 2 (clj-parse-edn-str "#my/other-type {:foo :bar}"))))
+(defun test-val-passed-to-handler (val)
+  (should (listp val))
+  (should (= (length val) 2))
+  (should (= 1 (car val)))
+  1)
+
+(setq clj-edn-test-extra-handlers
+      (a-list
+       'my/type #'test-val-passed-to-handler
+       'my/other-type (lambda (val) 2)))
+
+(ert-deftest tags ()
+  :tags '(edn tags)
+  (should-error (clj-parse-edn-str "#my/type value" 
clj-edn-test-extra-handlers))
+  (should (= 1 (clj-parse-edn-str "#my/type (1 2)" 
clj-edn-test-extra-handlers)))
+  (should (= 2 (clj-parse-edn-str "#my/other-type {:foo :bar}" 
clj-edn-test-extra-handlers))))
 
 (ert-deftest roundtrip ()
   :tags '(edn roundtrip)
@@ -189,24 +191,21 @@
                        (clj-parse-edn-str (edn-print-string 
(make-seeded-hash-table :foo :bar)))))
     (should (equal (edn-list-to-set '(1 2 3 [3 1.11]))
                    (clj-parse-edn-str (edn-print-string (edn-list-to-set '(1 2 
3 [3 1.11]))))))
-    ;;(should-error (clj-parse-edn-str "#myapp/Person {:first \"Fred\" :last 
\"Mertz\"}"))
-    ))
-
-;; (ert-deftest inst ()
-;;   :tags '(edn inst)
-;;   (let* ((inst-str "#inst \"1985-04-12T23:20:50.52Z\"")
-;;          (inst (clj-parse-edn-str inst-str))
-;;          (time (date-to-time "1985-04-12T23:20:50.52Z")))
-;;     (should (edn-inst-p inst))
-;;     (should (equal time (edn-inst-to-time inst)))
-;;     (should (equal inst-str (edn-print-string inst)))))
-
-;; (ert-deftest uuid ()
-;;   :tags '(edn uuid)
-;;   (let* ((str "f81d4fae-7dec-11d0-a765-00a0c91e6bf6")
-;;          (uuid (clj-parse-edn-str (concat "#uuid \"" str "\""))))
-;;     (should (edn-uuid-p uuid))
-;;     (should (equal str (edn-uuid-to-string uuid)))))
+    (should-error (clj-parse-edn-str "#myapp/Person {:first \"Fred\" :last 
\"Mertz\"}"))))
+
+(ert-deftest inst ()
+  :tags '(edn inst)
+  (let* ((inst-str "#inst \"1985-04-12T23:20:50.52Z\"")
+         (inst (clj-parse-edn-str inst-str))
+         (time (date-to-time "1985-04-12T23:20:50.52Z")))
+    (should (edn-inst-p inst))
+    (should (equal time (edn-inst-to-time inst)))))
+
+(ert-deftest uuid ()
+  :tags '(edn uuid)
+  (let* ((str "f81d4fae-7dec-11d0-a765-00a0c91e6bf6")
+         (uuid (clj-parse-edn-str (concat "#uuid \"" str "\""))))
+    (should (edn-uuid-p uuid))))
 
 ;; (ert-deftest invalid-edn ()
 ;;   (should-error (clj-parse-edn-str "///"))