branch: elpa/parseclj
commit 87953e44ba1b8c3582e8664507bdf91c948cf100
Author: Arne Brasseur <[email protected]>
Commit: Arne Brasseur <[email protected]>
Parse options on to the reducers
This changes the signature of the reducers to also receive a final `options`
argument. This is currently only used by parseedn to pass through the
:tag-readers, but it could also be used by `parseedn` to bail on non-edn
features when `:fail-fast` is enabled.
---
parseclj-ast.el | 12 ++++++------
parseclj.el | 9 +++++----
parseedn.el | 51 ++++++++++++++++++++++++++-------------------------
3 files changed, 37 insertions(+), 35 deletions(-)
diff --git a/parseclj-ast.el b/parseclj-ast.el
index 2b53cf3ec8..7326471af1 100644
--- a/parseclj-ast.el
+++ b/parseclj-ast.el
@@ -51,7 +51,7 @@ Other ATTRIBUTES can be given as a flat list of key-value
pairs. "
;; Parse/reduce strategy functions
-(defun parseclj-ast--reduce-leaf (stack token)
+(defun parseclj-ast--reduce-leaf (stack token options)
(if (member (parseclj-lex-token-type token) '(:whitespace :comment))
stack
(cons
@@ -61,7 +61,7 @@ Other ATTRIBUTES can be given as a flat list of key-value
pairs. "
:value (parseclj--leaf-token-value token))
stack)))
-(defun parseclj-ast--reduce-leaf-with-lexical-preservation (stack token)
+(defun parseclj-ast--reduce-leaf-with-lexical-preservation (stack token
options)
(let ((token-type (parseclj-lex-token-type token))
(top (car stack)))
(if (member token-type '(:whitespace :comment))
@@ -73,9 +73,9 @@ Other ATTRIBUTES can be given as a flat list of key-value
pairs. "
(a-get token :pos)
:form (a-get token :form))
stack))
- (parseclj-ast--reduce-leaf stack token))))
+ (parseclj-ast--reduce-leaf stack token options))))
-(defun parseclj-ast--reduce-branch (stack opening-token children)
+(defun parseclj-ast--reduce-branch (stack opening-token children options)
(let* ((pos (a-get opening-token :pos))
(type (parseclj-lex-token-type opening-token))
(type (cl-case type
@@ -94,10 +94,10 @@ Other ATTRIBUTES can be given as a flat list of key-value
pairs. "
(parseclj-ast-node type pos :children children)
stack)))))
-(defun parseclj-ast--reduce-branch-with-lexical-preservation (stack
opening-token children)
+(defun parseclj-ast--reduce-branch-with-lexical-preservation (stack
opening-token children options)
(if (eq :discard (parseclj-lex-token-type opening-token))
(cons (parseclj-ast-node :discard (a-get opening-token :pos) :children
children) stack)
- (let* ((stack (funcall #'parseclj-ast--reduce-branch stack opening-token
children))
+ (let* ((stack (funcall #'parseclj-ast--reduce-branch stack opening-token
children options))
(top (car stack)))
(if (parseclj-ast-node? top)
(cons (cl-list* (car top) ;; make sure :node-type remains the first
element in the list
diff --git a/parseclj.el b/parseclj.el
index 7f0e662e44..8cd83f8902 100644
--- a/parseclj.el
+++ b/parseclj.el
@@ -149,7 +149,7 @@ can be handled with `condition-case'."
;; all good, call the reducer so it can return an updated stack with
a
;; new node at the top.
(let ((opening-token (pop stack)))
- (funcall reduce-branch stack opening-token collection)))
+ (funcall reduce-branch stack opening-token collection options)))
;; Unwound the stack without finding a matching paren: either bail early
;; or return the original stack and continue parsing
@@ -257,7 +257,7 @@ functions. Additionally the following options are recognized
;; Reduce based on the top item on the stack (collections)
(cond
((parseclj-lex-leaf-token? token)
- (setf stack (funcall reduce-leaf stack token)))
+ (setf stack (funcall reduce-leaf stack token options)))
((parseclj-lex-closing-token? token)
(setf stack (parseclj--reduce-coll stack token reduce-branch options)))
@@ -273,7 +273,7 @@ functions. Additionally the following options are recognized
;; (message " - STACK %S" stack)
;; (message " - OPENING_TOKEN %S" opening-token)
;; (message " - TOP_VALUE %S\n" top-value)
- (setq stack (funcall reduce-branch new-stack (car opening-token)
(append (cdr opening-token) top-value)))))
+ (setq stack (funcall reduce-branch new-stack (car opening-token)
(append (cdr opening-token) top-value) options))))
(setq token (parseclj-lex-next)))
@@ -285,7 +285,8 @@ functions. Additionally the following options are recognized
(parseclj-lex-token-type token))))
(car (funcall reduce-branch nil (parseclj-lex-token :root "" 1)
- (reverse stack)))))
+ (reverse stack)
+ options))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Top level API
diff --git a/parseedn.el b/parseedn.el
index 863671d35a..9eaa9fd38e 100644
--- a/parseedn.el
+++ b/parseedn.el
@@ -41,38 +41,39 @@ 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 parseedn-reduce-leaf (stack token)
+(defun parseedn-reduce-leaf (stack token options)
(if (member (parseclj-lex-token-type token) (list :whitespace :comment))
stack
(cons (parseclj--leaf-token-value token) stack)))
-(defun parseedn-reduce-branch (tag-readers)
- (lambda (stack opening-token children)
- (let ((token-type (parseclj-lex-token-type opening-token)))
- (if (eq token-type :discard)
- stack
- (cons
- (cl-case token-type
- (:root children)
- (: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 opening-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)))))
+(defun parseedn-reduce-branch (stack opening-token children options)
+ (let ((tag-readers (a-merge parseedn-default-tag-readers (a-get options
:tag-readers)))
+ (token-type (parseclj-lex-token-type opening-token)))
+ (if (eq token-type :discard)
+ stack
+ (cons
+ (cl-case token-type
+ (:root children)
+ (: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 opening-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))))
(defun parseedn-read (&optional tag-readers)
(parseclj-parse #'parseedn-reduce-leaf
- (parseedn-reduce-branch (a-merge
parseedn-default-tag-readers tag-readers))))
+ #'parseedn-reduce-branch
+ (a-list :tag-readers tag-readers)))
(defun parseedn-read-str (s &optional tag-readers)
(with-temp-buffer
