+++ /dev/null
-;;; parseclj-ast.el --- Clojure parser/unparser -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2018 Arne Brasseur
-
-;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
-
-;; This file is not part of GNU Emacs.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; Parse Clojure code to an AST, and unparse back to code.
-
-;;; Code:
-
-(require 'a)
-(require 'seq)
-(require 'subr-x)
-(require 'parseclj-lex)
-
-;; AST helper functions
-
-(defun parseclj-ast-node (type position &rest attributes)
- "Create an AST node with given TYPE and POSITION.
-Other ATTRIBUTES can be given as a flat list of key-value pairs."
- (apply 'a-list :node-type type :position position attributes))
-
-(defun parseclj-ast-node-p (node)
- "Return t if the given NODE is a Clojure AST node."
- (and (consp node)
- (consp (car node))
- (eq :node-type (caar node))))
-
-(defun parseclj-ast-node-attr (node attr)
- "Return NODE's ATTR, or nil."
- (a-get node attr))
-
-(defun parseclj-ast-node-type (node)
- "Return the type of the AST node NODE."
- (a-get node :node-type))
-
-(defun parseclj-ast-children (node)
- "Return children for the AST NODE."
- (a-get node :children))
-
-(defun parseclj-ast-value (node)
- "Return the value of NODE as another AST node."
- (a-get node :value))
-
-(defun parseclj-ast-leaf-node-p (node)
- "Return t if the given ast NODE is a leaf node."
- (member (parseclj-ast-node-type node) parseclj-lex--leaf-tokens))
-
-(defun parseclj-ast-branch-node-p (node)
- "Return t if the given AST NODE is a branch node."
- (not (parseclj-ast-leaf-node-p node)))
-
-\f
-;; Parse/reduce strategy functions
-
-(defun parseclj-ast--reduce-leaf (stack token &optional _options)
- "Put into the STACK an AST leaf node based on TOKEN.
-Ignores white spaces and comments.
-
-OPTIONS is an association list. See `parseclj-parse' for more information
-on available options."
- (if (member (parseclj-lex-token-type token) '(:whitespace :comment))
- stack
- (cons
- (parseclj-ast-node (parseclj-lex-token-type token)
- (a-get token :pos)
- :form (a-get token :form)
- :value (parseclj-lex--leaf-token-value token))
- stack)))
-
-(defun parseclj-ast--reduce-leaf-with-lexical-preservation (stack token options)
- "Put into STACK an AST leaf node based on TOKEN.
-This function is very similar to `parseclj-ast--reduce-leaf', but unlike
-it, takes into account tokens representing white space or comments and
-saves them into the STACK. Nodes produced by this function have a
-`:lexical-preservation' key set to t.
-
-OPTIONS is an association list. See `parseclj-parse' for more information
-on available options."
- (let ((token-type (parseclj-lex-token-type token))
- (top (car stack)))
- (if (member token-type '(:whitespace :comment))
- ;; merge consecutive whitespace or comment tokens
- (if (eq token-type (a-get top :node-type))
- (cons (a-update top :form #'concat (a-get token :form))
- (cdr stack))
- (cons (parseclj-ast-node (parseclj-lex-token-type token)
- (a-get token :pos)
- :form (a-get token :form))
- stack))
- (parseclj-ast--reduce-leaf stack token options))))
-
-(defun parseclj-ast--reduce-branch (stack opening-token children _options)
- "Reduce STACK with an AST branch node representing a collection of elements.
-Ignores discard tokens.
-
-OPENING-TOKEN is a lex token representing an opening paren, bracket or
-brace.
-CHILDREN is the collection of nodes to be reduced into the AST branch node.
-OPTIONS is an association list. See `parseclj-parse' for more information
-on available options."
- (let* ((pos (a-get opening-token :pos))
- (type (parseclj-lex-token-type opening-token))
- (type (cl-case type
- (:lparen :list)
- (:lbracket :vector)
- (:lbrace :map)
- (t type))))
- (cl-case type
- (:root (cons (parseclj-ast-node :root pos :children children) stack))
- (:discard stack)
- (:tag (cons (parseclj-ast-node :tag
- pos
- :tag (intern (substring (a-get opening-token :form) 1))
- :children children)
- stack))
- (:metadata (cons (parseclj-ast-node :with-meta
- pos
- :children children)
- stack))
- (:map-prefix (cons (a-assoc (car children)
- :map-prefix opening-token)
- stack))
- (t (cons
- (parseclj-ast-node type pos :children children)
- stack)))))
-
-(defun parseclj-ast--reduce-branch-with-lexical-preservation (stack opening-token children options)
- "Reduce STACK with an AST branch node representing a collection of elements.
-Similar to `parseclj-ast--reduce-branch', but reduces discard tokens as
-well. Nodes produced by this function have a `:lexical-preservation'
-key set to t.
-
-OPENING-TOKEN is a lex token representing an opening paren, bracket or
-brace.
-CHILDREN is the collection of tokens to be reduced into the AST branch
-node.
-OPTIONS is an association list. See `parseclj-parse' for more information
-on available 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 options))
- (top (car stack)))
- (if (parseclj-ast-node-p top)
- (cons (cl-list* (car top) ;; make sure :node-type remains the first element in the list
- '(:lexical-preservation . t)
- (cdr top))
- (cdr stack))
- stack))))
-
-
-\f
-;; Unparse functions
-
-(declare-function parseclj-unparse-clojure "parseclj")
-
-(defun parseclj-ast--unparse-collection (node)
- "Insert a string representation of the given AST branch NODE into buffer."
- (let* ((token-type (parseclj-ast-node-type node))
- (delimiters (cl-case token-type
- (:root (cons "" ""))
- (:list (cons "(" ")"))
- (:vector (cons "[" "]"))
- (:set (cons "#{" "}"))
- (:map (cons "{" "}")))))
- (insert (car delimiters))
- (let ((nodes (alist-get ':children node)))
- (when-let (node (car nodes))
- (parseclj-unparse-clojure node))
- (seq-doseq (child (cdr nodes))
- (when (not (a-get node :lexical-preservation))
- (insert " "))
- (parseclj-unparse-clojure child)))
- (insert (cdr delimiters))))
-
-(defun parseclj-ast--unparse-tag (node)
- "Insert a string representation of the given AST tag NODE into buffer."
- (progn
- (insert "#")
- (insert (symbol-name (a-get node :tag)))
- (insert " ")
- (parseclj-unparse-clojure (car (a-get node :children)))))
-
-(provide 'parseclj-ast)
-
-;;; parseclj-ast.el ends here
+++ /dev/null
-;;; parseclj-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-
-(add-to-list 'load-path (directory-file-name
- (or (file-name-directory #$) (car load-path))))
-
-\f
-;;;### (autoloads nil "parseclj" "parseclj.el" (0 0 0 0))
-;;; Generated autoloads from parseclj.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "parseclj" '("parseclj-")))
-
-;;;***
-\f
-;;;### (autoloads nil "parseclj-ast" "parseclj-ast.el" (0 0 0 0))
-;;; Generated autoloads from parseclj-ast.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "parseclj-ast" '("parseclj-ast-")))
-
-;;;***
-\f
-;;;### (autoloads nil "parseclj-lex" "parseclj-lex.el" (0 0 0 0))
-;;; Generated autoloads from parseclj-lex.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "parseclj-lex" '("parseclj-lex-")))
-
-;;;***
-\f
-;;;### (autoloads nil "parseclj-parser" "parseclj-parser.el" (0 0
-;;;;;; 0 0))
-;;; Generated autoloads from parseclj-parser.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "parseclj-parser" '("parseclj-")))
-
-;;;***
-\f
-;;;### (autoloads nil nil ("parseclj-pkg.el") (0 0 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; coding: utf-8
-;; End:
-;;; parseclj-autoloads.el ends here
+++ /dev/null
-;;; parseclj-lex.el --- Clojure/EDN Lexer
-
-;; Copyright (C) 2017-2018 Arne Brasseur
-
-;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
-
-;; This file is not part of GNU Emacs.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; A reader for EDN data files and parser for Clojure source files.
-
-;;; Code:
-
-(defvar parseclj-lex--leaf-tokens '(:whitespace
- :comment
- :number
- :nil
- :true
- :false
- :symbol
- :keyword
- :string
- :regex
- :character)
- "Types of tokens that represent leaf nodes in the AST.")
-
-(defvar parseclj-lex--closing-tokens '(:rparen
- :rbracket
- :rbrace)
- "Types of tokens that mark the end of a non-atomic form.")
-
-(defvar parseclj-lex--prefix-tokens '(:quote
- :backquote
- :unquote
- :unquote-splice
- :discard
- :tag
- :reader-conditional
- :reader-conditional-splice
- :var
- :deref
- :map-prefix
- :eval)
- "Tokens that modify the form that follows.")
-
-(defvar parseclj-lex--prefix-2-tokens '(:metadata)
- "Tokens that modify the two forms that follow.")
-
-;; Token interface
-
-(defun parseclj-lex-token (type form pos &rest attributes)
- "Create a lexer token with the specified attributes.
-
-Tokens at a mimimum have these attributes
-- TYPE: the type of token, like :whitespace or :lparen
-- FORM: the source form, a string
-- POS: the position in the input, starts from 1 (like point)
-
-Other ATTRIBUTES can be given as a flat list of key-value pairs."
- (apply 'a-list :token-type type :form form :pos pos attributes))
-
-(defun parseclj-lex-error-token (pos &optional error-type)
- "Create a lexer error token starting at POS.
-ERROR-TYPE is an optional keyword to attach to the created token,
-as the means for providing more information on the error."
- (apply #'parseclj-lex-token
- :lex-error
- (buffer-substring-no-properties pos (point))
- pos
- (when error-type
- (list :error-type error-type))))
-
-(defun parseclj-lex-token-p (token)
- "Is the given TOKEN a parseclj-lex TOKEN.
-
-A token is an association list with :token-type as its first key."
- (and (consp token)
- (consp (car token))
- (eq :token-type (caar token))))
-
-(defun parseclj-lex-token-type (token)
- "Get the type of TOKEN."
- (and (consp token)
- (cdr (assq :token-type token))))
-
-(defun parseclj-lex-token-form (token)
- "Get the form of TOKEN."
- (and (consp token)
- (cdr (assq :form token))))
-
-(defun parseclj-lex-leaf-token-p (token)
- "Return t if the given AST TOKEN is a leaf node."
- (member (parseclj-lex-token-type token) parseclj-lex--leaf-tokens))
-
-(defun parseclj-lex-closing-token-p (token)
- "Return t if the given ast TOKEN is a closing token."
- (member (parseclj-lex-token-type token) parseclj-lex--closing-tokens))
-
-(defun parseclj-lex-error-p (token)
- "Return t if the TOKEN represents a lexing error token."
- (eq (parseclj-lex-token-type token) :lex-error))
-
-;; Elisp values from tokens
-
-(defun parseclj-lex--string-value (s)
- "Parse an EDN string S into a regular string.
-S goes through three transformations:
-- Escaped characters in S are transformed into Elisp escaped
- characters.
-- Unicode escaped characters are decoded into its corresponding
- unicode character counterpart.
-- Octal escaped characters are decoded into its corresponding
- character counterpart."
- (replace-regexp-in-string
- "\\\\o[0-8]\\{3\\}"
- (lambda (x)
- (make-string 1 (string-to-number (substring x 2) 8)))
- (replace-regexp-in-string
- "\\\\u[0-9a-fA-F]\\{4\\}"
- (lambda (x)
- (make-string 1 (string-to-number (substring x 2) 16)))
- (replace-regexp-in-string "\\\\[tbnrf'\"\\]"
- (lambda (x)
- (cl-case (elt x 1)
- (?t "\t")
- (?f "\f")
- (?\" "\"")
- (?r "\r")
- (?n "\n")
- (?\\ "\\\\")
- (t (substring x 1))))
- (substring s 1 -1)))))
-
-(defun parseclj-lex--character-value (c)
- "Parse an EDN character C into an Emacs Lisp character."
- (let ((first-char (elt c 1)))
- (cond
- ((equal c "\\newline") ?\n)
- ((equal c "\\return") ?\r)
- ((equal c "\\space") ?\ )
- ((equal c "\\tab") ?\t)
- ((eq first-char ?u) (string-to-number (substring c 2) 16))
- ((eq first-char ?o) (string-to-number (substring c 2) 8))
- (t first-char))))
-
-(defun parseclj-lex--leaf-token-value (token)
- "Parse the given leaf TOKEN to an Emacs Lisp value."
- (cl-case (parseclj-lex-token-type token)
- (:number (string-to-number (alist-get :form token)))
- (:nil nil)
- (:true t)
- (:false nil)
- (:symbol (intern (alist-get :form token)))
- (:keyword (intern (alist-get :form token)))
- (:string (parseclj-lex--string-value (alist-get :form token)))
- (:character (parseclj-lex--character-value (alist-get :form token)))))
-
-
-;; Stream tokenization
-
-(defun parseclj-lex-at-whitespace-p ()
- "Return t if char at point is white space."
- (let ((char (char-after (point))))
- (or (equal char ?\ )
- (equal char ?\t)
- (equal char ?\n)
- (equal char ?\r)
- (equal char ?,))))
-
-(defun parseclj-lex-at-eof-p ()
- "Return t if point is at the end of file."
- (eq (point) (point-max)))
-
-(defun parseclj-lex-whitespace ()
- "Consume all consecutive white space as possible and return an :whitespace token."
- (let ((pos (point)))
- (while (parseclj-lex-at-whitespace-p)
- (right-char))
- (parseclj-lex-token :whitespace
- (buffer-substring-no-properties pos (point))
- pos)))
-
-(defun parseclj-lex-skip-digits ()
- "Skip all consecutive digits after point."
- (while (and (char-after (point))
- (<= ?0 (char-after (point)))
- (<= (char-after (point)) ?9))
- (right-char)))
-
-(defun parseclj-lex-skip-hex ()
- "Skip all consecutive hex digits after point."
- (while (and (char-after (point))
- (or (<= ?0 (char-after (point)) ?9)
- (<= ?a (char-after (point)) ?f)
- (<= ?A (char-after (point)) ?F)))
- (right-char)))
-
-(defun parseclj-lex-skip-number ()
- "Skip a number at point."
- ;; [\+\-]?\d+\.\d+
- (if (and (eq ?0 (char-after (point)))
- (eq ?x (char-after (1+ (point)))))
- (progn
- (right-char 2)
- (parseclj-lex-skip-hex))
- (progn
- (when (member (char-after (point)) '(?+ ?-))
- (right-char))
-
- (parseclj-lex-skip-digits)
-
- (when (eq (char-after (point)) ?.)
- (right-char))
-
- (parseclj-lex-skip-digits))))
-
-(defun parseclj-lex-number ()
- "Consume a number and return a `:number' token representing it."
- (let ((pos (point)))
- (parseclj-lex-skip-number)
-
- ;; 10110r2 or 4.3e+22
- (when (member (char-after (point)) '(?E ?e ?r))
- (right-char))
-
- (parseclj-lex-skip-number)
-
- ;; trailing M
- (when (eq (char-after (point)) ?M)
- (right-char))
-
- (let ((char (char-after (point))))
- (if (and char (or (and (<= ?a char) (<= char ?z))
- (and (<= ?A char) (<= char ?Z))
- (and (member char '(?. ?* ?+ ?! ?- ?_ ?? ?$ ?& ?= ?< ?> ?/)))))
- (progn
- (right-char)
- (parseclj-lex-error-token pos :invalid-number-format))
- (parseclj-lex-token :number
- (buffer-substring-no-properties pos (point))
- pos)))))
-
-
-(defun parseclj-lex-digit-p (char)
- "Return t if CHAR is a digit."
- (and char (<= ?0 char) (<= char ?9)))
-
-(defun parseclj-lex-at-number-p ()
- "Return t if point is at a number."
- (let ((char (char-after (point))))
- (or (parseclj-lex-digit-p char)
- (and (member char '(?- ?+ ?.))
- (parseclj-lex-digit-p (char-after (1+ (point))))))))
-
-(defun parseclj-lex-symbol-start-p (char &optional alpha-only)
- "Return t if CHAR is a valid start for a symbol.
-
-Symbols begin with a non-numeric character and can contain alphanumeric
-characters and . * + ! - _ ? $ % & = < > '. If - + or . are the first
-character, the second character (if any) must be non-numeric.
-
-In some cases, like in tagged elements, symbols are required to start with
-alphabetic characters only. ALPHA-ONLY ensures this behavior."
- (not (not (and char
- (or (and (<= ?a char) (<= char ?z))
- (and (<= ?A char) (<= char ?Z))
- (and (not alpha-only) (member char '(?. ?* ?+ ?! ?- ?_ ?? ?$ ?% ?& ?= ?< ?> ?/ ?'))))))))
-
-(defun parseclj-lex-symbol-rest-p (char)
- "Return t if CHAR is a valid character in a symbol.
-For more information on what determines a valid symbol, see
-`parseclj-lex-symbol-start-p'"
- (or (parseclj-lex-symbol-start-p char)
- (parseclj-lex-digit-p char)
- (eq ?: char)
- (eq ?# char)))
-
-(defun parseclj-lex-get-symbol-at-point (pos)
- "Return the symbol at POS as a string."
- (while (parseclj-lex-symbol-rest-p (char-after (point)))
- (right-char))
- (buffer-substring-no-properties pos (point)))
-
-(defun parseclj-lex-symbol ()
- "Return a lex token representing a symbol.
-Because of their special meaning, symbols \"nil\", \"true\", and \"false\"
-are returned as their own lex tokens."
- (let ((pos (point)))
- (right-char)
- (let ((sym (parseclj-lex-get-symbol-at-point pos)))
- (cond
- ((equal sym "nil") (parseclj-lex-token :nil "nil" pos))
- ((equal sym "true") (parseclj-lex-token :true "true" pos))
- ((equal sym "false") (parseclj-lex-token :false "false" pos))
- (t (parseclj-lex-token :symbol sym pos))))))
-
-(defun parseclj-lex-string* ()
- "Helper for string/regex lexing.
-Returns either the string, or an error token"
- (let ((pos (point)))
- (right-char)
- (while (not (or (equal (char-after (point)) ?\") (parseclj-lex-at-eof-p)))
- (if (equal (char-after (point)) ?\\)
- (right-char 2)
- (right-char)))
- (when (equal (char-after (point)) ?\")
- (right-char)
- (buffer-substring-no-properties pos (point)))))
-
-(defun parseclj-lex-string ()
- "Return a lex token representing a string.
-If EOF is reached without finding a closing double quote, a :lex-error
-token is returned."
- (let ((pos (point))
- (str (parseclj-lex-string*)))
- (if str
- (parseclj-lex-token :string str pos)
- (parseclj-lex-error-token pos :invalid-string))))
-
-(defun parseclj-lex-regex ()
- "Return a lex token representing a regular expression.
-If EOF is reached without finding a closing double quote, a :lex-error
-token is returned."
- (let ((pos (1- (point)))
- (str (parseclj-lex-string*)))
- (if str
- (parseclj-lex-token :regex (concat "#" str) pos)
- (parseclj-lex-error-token pos :invalid-regex))))
-
-(defun parseclj-lex-lookahead (n)
- "Return a lookahead string of N characters after point."
- (buffer-substring-no-properties (point) (min (+ (point) n) (point-max))))
-
-(defun parseclj-lex-character ()
- "Return a lex token representing a character."
- (let ((pos (point)))
- (right-char)
- (cond
- ((equal (parseclj-lex-lookahead 3) "tab")
- (right-char 3)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- ((equal (parseclj-lex-lookahead 5) "space")
- (right-char 5)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- ((equal (parseclj-lex-lookahead 6) "return")
- (right-char 6)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- ((equal (parseclj-lex-lookahead 7) "newline")
- (right-char 7)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- ((string-match-p "^u[0-9a-fA-F]\\{4\\}" (parseclj-lex-lookahead 5))
- (right-char 5)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- ((string-match-p "^o[0-8]\\{3\\}" (parseclj-lex-lookahead 4))
- (right-char 4)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
-
- (t
- (right-char)
- (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos)))))
-
-(defun parseclj-lex-keyword ()
- "Return a lex token representing a keyword.
-Keywords follow the same rules as symbols, except they start with one or
-two colon characters.
-
-See `parseclj-lex-symbol', `parseclj-lex-symbol-start-p'."
- (let ((pos (point)))
- (right-char)
- (when (equal (char-after (point)) ?:) ;; same-namespace keyword
- (right-char))
- (if (equal (char-after (point)) ?:) ;; three colons in a row => lex-error
- (progn
- (right-char)
- (parseclj-lex-error-token pos :invalid-keyword))
- (progn
- (while (or (parseclj-lex-symbol-rest-p (char-after (point)))
- (equal (char-after (point)) ?#))
- (right-char))
- (parseclj-lex-token :keyword (buffer-substring-no-properties pos (point)) pos)))))
-
-(defun parseclj-lex-comment ()
- "Return a lex token representing a comment."
- (let ((pos (point)))
- (goto-char (line-end-position))
- (when (equal (char-after (point)) ?\n)
- (right-char))
- (parseclj-lex-token :comment (buffer-substring-no-properties pos (point)) pos)))
-
-(defun parseclj-lex-map-prefix ()
- "Return a lex token representing a map prefix."
- (let ((pos (1- (point))))
- (right-char)
- (when (equal (char-after (point)) ?:)
- (right-char))
- (while (parseclj-lex-symbol-rest-p (char-after (point)))
- (right-char))
- (parseclj-lex-token :map-prefix (buffer-substring-no-properties pos (point)) pos)))
-
-(defun parseclj-lex-next ()
- "Consume characters at point and return the next lexical token.
-
-See `parseclj-lex-token'."
- (if (parseclj-lex-at-eof-p)
- (parseclj-lex-token :eof nil (point))
- (let ((char (char-after (point)))
- (pos (point)))
- (cond
- ((parseclj-lex-at-whitespace-p)
- (parseclj-lex-whitespace))
-
- ((equal char ?\()
- (right-char)
- (parseclj-lex-token :lparen "(" pos))
-
- ((equal char ?\))
- (right-char)
- (parseclj-lex-token :rparen ")" pos))
-
- ((equal char ?\[)
- (right-char)
- (parseclj-lex-token :lbracket "[" pos))
-
- ((equal char ?\])
- (right-char)
- (parseclj-lex-token :rbracket "]" pos))
-
- ((equal char ?{)
- (right-char)
- (parseclj-lex-token :lbrace "{" pos))
-
- ((equal char ?})
- (right-char)
- (parseclj-lex-token :rbrace "}" pos))
-
- ((equal char ?')
- (right-char)
- (parseclj-lex-token :quote "'" pos))
-
- ((equal char ?`)
- (right-char)
- (parseclj-lex-token :backquote "`" pos))
-
- ((equal char ?~)
- (right-char)
- (if (eq ?@ (char-after (point)))
- (progn
- (right-char)
- (parseclj-lex-token :unquote-splice "~@" pos))
- (parseclj-lex-token :unquote "~" pos)))
-
- ((parseclj-lex-at-number-p)
- (parseclj-lex-number))
-
- ((parseclj-lex-symbol-start-p char)
- (parseclj-lex-symbol))
-
- ((equal char ?\")
- (parseclj-lex-string))
-
- ((equal char ?\\)
- (parseclj-lex-character))
-
- ((equal char ?:)
- (parseclj-lex-keyword))
-
- ((equal char ?\;)
- (parseclj-lex-comment))
-
- ((equal char ?^)
- (right-char)
- (parseclj-lex-token :metadata "^" pos))
-
- ((equal char ?@)
- (right-char)
- (parseclj-lex-token :deref "@" pos))
-
- ((equal char ?#)
- (right-char)
- (let ((char (char-after (point))))
- (cond
- ((equal char ?{)
- (right-char)
- (parseclj-lex-token :set "#{" pos))
- ((equal char ?_)
- (right-char)
- (parseclj-lex-token :discard "#_" pos))
- ((equal char ?\()
- (right-char)
- (parseclj-lex-token :lambda "#(" pos))
- ((equal char ?')
- (right-char)
- (parseclj-lex-token :var "#'" pos))
- ((equal char ?=)
- (right-char)
- (parseclj-lex-token :eval "#=" pos))
- ((equal char ?\")
- (parseclj-lex-regex))
- ((equal char ?:)
- (parseclj-lex-map-prefix))
- ((equal char ?\?)
- (right-char)
- (if (eq ?@ (char-after (point)))
- (progn
- (right-char)
- (parseclj-lex-token :reader-conditional-splice "#?@" pos))
- (parseclj-lex-token :reader-conditional "#?" pos)))
- ((parseclj-lex-symbol-start-p char t)
- (right-char)
- (parseclj-lex-token :tag (concat "#" (parseclj-lex-get-symbol-at-point (1+ pos))) pos))
- (t
- (while (not (or (parseclj-lex-at-whitespace-p)
- (parseclj-lex-at-eof-p)))
- (right-char))
- (parseclj-lex-error-token pos :invalid-hashtag-dispatcher)))))
-
- (t
- (progn
- (right-char)
- (parseclj-lex-error-token pos)))))))
-
-(provide 'parseclj-lex)
-
-;;; parseclj-lex.el ends here
+++ /dev/null
-;;; parseclj-parser.el --- Clojure/EDN parser -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2018 Arne Brasseur
-
-;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
-;; Keywords: lisp
-;; Package-Requires: ((emacs "25") (a "0.1.0alpha4"))
-;; Version: 0.1.0
-
-;; This file is not part of GNU Emacs.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; A shift/reduce parser for Clojure source.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'subr-x)
-(require 'a)
-(require 'parseclj-lex)
-
-(define-error 'parseclj-parser-error "parseclj: Syntax error")
-
-(defun parseclj--error (format &rest args)
- "Signal a parse error.
-Takes a FORMAT string and optional ARGS to be passed to
-`format-message'. Signals a 'parseclj-parser-error signal, which
-can be handled with `condition-case'."
- (signal 'parseclj-parser-error (list (apply #'format-message format args))))
-
-(defun parseclj--find-opening-token (stack closing-token)
- "Scan STACK for an opening-token matching CLOSING-TOKEN."
- (cl-case (parseclj-lex-token-type closing-token)
- (:rparen (parseclj-lex-token-type
- (seq-find (lambda (token)
- (member (parseclj-lex-token-type token)
- '(:lparen :lambda)))
- stack)))
- (:rbracket :lbracket)
- (:rbrace (parseclj-lex-token-type
- (seq-find (lambda (token)
- (member (parseclj-lex-token-type token)
- '(:lbrace :set)))
- stack)))))
-
-(defun parseclj--reduce-coll (stack closing-token reduce-branch options)
- "Reduce collection based on the top of the STACK and a CLOSING-TOKEN.
-
-REDUCE-BRANCH is a function to be applied to the collection of tokens found
-from the top of the stack until an opening token that matches
-CLOSING-TOKEN. This function should return an AST token representing such
-collection.
-
-OPTIONS is an association list. This list is also passed down to the
-REDUCE-BRANCH function. See `parseclj-parser' for more information on
-available options."
- (let ((opening-token-type (parseclj--find-opening-token stack closing-token))
- (fail-fast (a-get options :fail-fast t))
- (collection nil))
-
- ;; unwind the stack until opening-token-type is found, adding to collection
- (while (and stack (not (eq (parseclj-lex-token-type (car stack)) opening-token-type)))
- (push (pop stack) collection))
-
- ;; did we find the right token?
- (if (eq (parseclj-lex-token-type (car stack)) opening-token-type)
- (progn
- (when fail-fast
- ;; any unreduced tokens left: bail early
- (when-let ((token (seq-find #'parseclj-lex-token-p collection)))
- (parseclj--error "At position %s, unmatched %S"
- (a-get token :pos)
- (parseclj-lex-token-type token))))
-
- ;; 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 options)))
-
- ;; Unwound the stack without finding a matching paren: either bail early
- ;; or return the original stack and continue parsing
- (if fail-fast
- (parseclj--error "At position %s, unmatched %S"
- (a-get closing-token :pos)
- (parseclj-lex-token-type closing-token))
-
- (reverse collection)))))
-
-(defun parseclj--take-value (stack value-p)
- "Scan STACK until a value is found.
-Return everything up to the value in reversed order (meaning the value
-comes first in the result).
-
-STACK is the current parse stack to scan.
-
-VALUE-P a predicate to distinguish reduced values from non-values (tokens
-and whitespace)."
- (let ((result nil))
- (cl-block nil
- (while stack
- (cond
- ((parseclj-lex-token-p (car stack))
- (cl-return nil))
-
- ((funcall value-p (car stack))
- (cl-return (cons (car stack) result)))
-
- (t
- (push (pop stack) result)))))))
-
-(defun parseclj--take-token (stack value-p token-types)
- "Scan STACK until a token of a certain type is found.
-Returns nil if a value is encountered before a matching token is found.
-Return everything up to the token in reversed order (meaning the token
-comes first in the result).
-
-STACK is the current parse stack to scan.
-
-VALUE-P a predicate to distinguish reduced values from non-values (tokens
-and whitespace).
-
-TOKEN-TYPES are the token types to look for."
- (let ((result nil))
- (cl-block nil
- (while stack
- (cond
- ((member (parseclj-lex-token-type (car stack)) token-types)
- (cl-return (cons (car stack) result)))
- ((funcall value-p (car stack))
- (cl-return nil))
- ((parseclj-lex-token-p (car stack))
- (cl-return nil))
- (t
- (push (pop stack) result)))))))
-
-(defun parseclj-single-value-p (stack value-p)
- "Return t if STACK only has a single node for which VALUE-P is true.
-
-This checks if the stack contains a single, fully reduced value, and no
-dangling unmatched tokens. When parsing with `:read-one' this indicates a
-form can be returned."
- (and (not (cl-reduce (lambda (bool node)
- (or bool (parseclj-lex-token-p node)))
- stack
- :initial-value nil))
- (parseclj--take-value stack value-p)))
-
-(defun parseclj-parser (reduce-leaf reduce-branch &optional options)
- "Clojure/EDN stack-based shift-reduce parser.
-
-REDUCE-LEAF does reductions for leaf nodes. It is a function that takes
-the current value of the stack and a token, and either returns an updated
-stack, with a new leaf node at the top (front), or returns the stack
-unmodified.
-
-REDUCE-BRANCH does reductions for branch nodes. It is a function that
-takes the current value of the stack, the type of branch node to create,
-and a list of child nodes, and returns an updated stack, with the new node
-at the top (front).
-
-What \"node\" means in this case is up to the reducing functions, it could
-be AST nodes (as in the case of `parseclj-parser-clojure'), or plain
-values/sexps (as in the case of `parseedn-read'), or something else. The
-only requirement is that they should not put raw tokens back on the stack,
-as the parser relies on the presence or absence of these to detect parse
-errors.
-
-OPTIONS is an association list which is passed on to the reducing
-functions. Additionally the following options are recognized
-
-- `:fail-fast'
- Raise an error when a parse error is encountered, rather than continuing
- with a partial result.
-- `:value-p'
- A predicate function to differentiate values from tokens and
- whitespace. This is needed when scanning the stack to see if any
- reductions can be performed. By default anything that isn't a token is
- considered a value. This can be problematic when parsing with
- `:lexical-preservation', and which case you should provide an
- implementation that also returns falsy for :whitespace, :comment, and
- :discard AST nodes.
-- `:tag-readers'
- An association list that describes tag handler functions for any possible
- tag. This options in only available in `parseedn-read', for more
- information, please refer to its documentation.
-- `:read-one'
- Return as soon as a single complete value has been read."
- (let ((fail-fast (a-get options :fail-fast t))
- (read-one (a-get options :read-one))
- (value-p (a-get options :value-p (lambda (e) (not (parseclj-lex-token-p e)))))
- (stack nil)
- (token (parseclj-lex-next)))
-
- (while (not (or (and read-one (parseclj-single-value-p stack value-p))
- (eq (parseclj-lex-token-type token) :eof)))
- ;; (message "STACK: %S" stack)
- ;; (message "TOKEN: %S\n" token)
-
- (when (and fail-fast (parseclj-lex-error-p token))
- (parseclj--error "Invalid token at %s: %S"
- (a-get token :pos)
- (parseclj-lex-token-form token)))
-
- ;; Reduce based on the top item on the stack (collections)
- (cond
- ((parseclj-lex-leaf-token-p token)
- (setf stack (funcall reduce-leaf stack token options)))
-
- ((parseclj-lex-closing-token-p token)
- (setf stack (parseclj--reduce-coll stack token reduce-branch options)))
-
- (t (push token stack)))
-
- ;; Reduce based on top two items on the stack (special prefixed elements)
- (let* ((top-value (parseclj--take-value stack value-p))
- (opening-token (parseclj--take-token (nthcdr (length top-value) stack) value-p parseclj-lex--prefix-tokens))
- new-stack)
- (while (and top-value opening-token)
- ;; (message "Reducing...")
- ;; (message " - STACK %S" stack)
- ;; (message " - OPENING-TOKEN %S" opening-token)
- ;; (message " - TOP-VALUE %S" top-value)
- (setq new-stack (nthcdr (+ (length top-value) (length opening-token)) stack))
- (setq stack (funcall reduce-branch new-stack (car opening-token) (append (cdr opening-token) top-value) options))
-
- ;; recur
- (setq top-value (parseclj--take-value stack value-p))
- (setq opening-token (parseclj--take-token (nthcdr (length top-value) stack) value-p parseclj-lex--prefix-tokens))))
-
- ;; Reduce based on top three items on the stack (metadata, namespaced maps)
- (let* ((top-value-1 (parseclj--take-value stack value-p))
- (top-value-2 (parseclj--take-value (nthcdr (length top-value-1) stack) value-p))
- (opening-token (parseclj--take-token (nthcdr (+ (length top-value-1)
- (length top-value-2)) stack) value-p parseclj-lex--prefix-2-tokens))
- new-stack)
- (while (and top-value-1 top-value-2 opening-token)
- (setq new-stack (nthcdr (apply #'+ (mapcar #'length (list top-value-1 top-value-2 opening-token))) stack))
- (setq stack (funcall reduce-branch new-stack (car opening-token) (append (cdr opening-token) top-value-2 top-value-1) options))
-
- ;; recur
- (setq top-value-1 (parseclj--take-value stack value-p))
- (setq top-value-2 (parseclj--take-value (nthcdr (length top-value-1) stack) value-p))
- (setq opening-token (parseclj--take-token (nthcdr (+ (length top-value-1)
- (length top-value-2)) stack) value-p parseclj-lex--prefix-2-tokens))))
-
- (setq token (parseclj-lex-next)))
-
- ;; reduce root
- (when fail-fast
- (when-let ((token (seq-find #'parseclj-lex-token-p stack)))
- (parseclj--error "At position %s, unmatched %S"
- (a-get token :pos)
- (parseclj-lex-token-type token))))
-
- (if read-one
- (car (parseclj--take-value stack value-p))
- (car (funcall reduce-branch nil (parseclj-lex-token :root "" 1)
- (reverse stack)
- options)))))
-
-(provide 'parseclj-parser)
-;;; parseclj-parser.el ends here
+++ /dev/null
-(define-package "parseclj" "20190531.711" "Clojure/EDN parser"
- '((emacs "25")
- (a "0.1.0alpha4"))
- :keywords
- '("lisp" "clojure" "edn" "parser")
- :authors
- '(("Arne Brasseur" . "arneNOSPAMarnebrasseur.net"))
- :maintainer
- '("Arne Brasseur" . "arneNOSPAMarnebrasseur.net"))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; parseclj.el --- Clojure/EDN parser -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2018 Arne Brasseur
-
-;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
-;; Keywords: lisp clojure edn parser
-;; Package-Requires: ((emacs "25") (a "0.1.0alpha4"))
-;; Version: 0.1.0
-
-;; This file is not part of GNU Emacs.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; Top level API for the Clojure parser.
-
-;;; Code:
-
-(require 'parseclj-parser)
-(require 'parseclj-ast)
-
-(defun parseclj-parse-clojure (&rest string-and-options)
- "Parse Clojure source to AST.
-
-Reads either from the current buffer, starting from point, until
-`point-max', or reads from the optional string argument.
-
-STRING-AND-OPTIONS can be an optional string, followed by
-key-value pairs to specify parsing options.
-
-- `:lexical-preservation' Retain whitespace, comments, and
- discards. Defaults to nil.
-- `:fail-fast' Raise an error when encountering invalid syntax.
- Defaults to t.
-- `:read-one'
- Read a single form. Defaults to false: parse the complete input."
- (if (stringp (car string-and-options))
- (with-temp-buffer
- (insert (car string-and-options))
- (goto-char 1)
- (apply 'parseclj-parse-clojure (cdr string-and-options)))
- (let* ((value-p (lambda (e)
- (and (parseclj-ast-node-p e)
- (not (member (parseclj-ast-node-type e) '(:whitespace :comment :discard))))))
- (options (apply 'a-list :value-p value-p string-and-options))
- (lexical? (a-get options :lexical-preservation)))
- (parseclj-parser (if lexical?
- #'parseclj-ast--reduce-leaf-with-lexical-preservation
- #'parseclj-ast--reduce-leaf)
- (if lexical?
- #'parseclj-ast--reduce-branch-with-lexical-preservation
- #'parseclj-ast--reduce-branch)
- options))))
-
-(defun parseclj-unparse-clojure (ast)
- "Parse Clojure AST to source code.
-
-Given an abstract syntax tree AST (as returned by
-`parseclj-parse-clojure'), turn it back into source code, and
-insert it into the current buffer."
- (if (parseclj-ast-leaf-node-p ast)
- (insert (a-get ast :form))
- (if (eql (parseclj-ast-node-type ast) :tag)
- (parseclj-ast--unparse-tag ast)
- (parseclj-ast--unparse-collection ast))))
-
-(defun parseclj-unparse-clojure-to-string (ast)
- "Parse Clojure AST to a source code string.
-
-Given an abstract syntax tree AST (as returned by
-`parseclj-parse-clojure'), turn it back into source code, and
-return it as a string"
- (with-temp-buffer
- (parseclj-unparse-clojure ast)
- (buffer-substring-no-properties (point-min) (point-max))))
-
-(provide 'parseclj)
-
-;;; parseclj.el ends here
--- /dev/null
+;;; parseclj-alist.el --- Clojure/EDN parser -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 Arne Brasseur
+
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; A shift/reduce parser for Clojure source.
+
+;;; Code:
+
+(require 'map)
+
+(defun parseclj-alist (&rest kvs)
+ "Create an association list from the given keys and values KVS.
+Arguments are simply provided in sequence, rather than as lists or cons cells.
+For example: (parseclj-alist :foo 123 :bar 456)"
+ ;; Emacs 27:
+ ;; (map-into kvs 'alist)
+ (mapcar (lambda (kv) (cons (car kv) (cadr kv))) (seq-partition kvs 2)))
+
+(defun parseclj-alist-assoc (coll k v)
+ "Associate a key K with a value V in the association list COLL
+
+Returns a new alist (does not mutate its argument). If an entry
+with the same key is present it will be replaced, otherwise the
+new kv-pair is added to the head of the list."
+ (if (map-contains-key coll k)
+ (mapcar (lambda (entry)
+ (if (equal (car entry) k)
+ (cons k v)
+ entry))
+ coll)
+ (cons (cons k v) coll)))
+
+(defun parseclj-alist-update (coll key fn &rest args)
+ "In collection COLL, at location KEY, apply FN with extra args ARGS.
+'Updates' a value in an associative collection COLL, where KEY is
+a key and FN is a function that will take the old value and any
+supplied args and return the new value, and returns a new
+structure. If the key does not exist, nil is passed as the old
+value."
+ (parseclj-alist-assoc coll
+ key
+ (apply #'funcall fn (map-elt coll key) args)))
+
+(defun parseclj-hash-table (&rest kvs)
+ "Create a hash table from the given keys and values KVS.
+Arguments are simply provided in sequence, rather than as lists
+or cons cells. As \"test\" for the hash table, equal is used. The
+hash table is created without extra storage space, so with a size
+equal to amount of key-value pairs, since it is assumed to be
+treated as immutable.
+For example: (parseclj-hash-table :foo 123 :bar 456)"
+ ;; Emacs 27:
+ ;; (map-into kvs 'hash-table)
+ (let* ((kv-pairs (seq-partition kvs 2))
+ (hash-map (make-hash-table :test 'equal :size (length kv-pairs))))
+ (seq-do (lambda (pair)
+ (puthash (car pair) (cadr pair) hash-map))
+ kv-pairs)
+ hash-map))
+
+(defun parseclj-alist-merge (l1 l2)
+ "Merge two association lists."
+ ;; Emacs 27: (map-merge 'alist l1 l2)
+ (let ((keys (delete-dups (append (mapcar #'car l1) (mapcar #'car l2))))
+ (res '()))
+ (mapc
+ (lambda (key)
+ (push (or (assoc key l2)
+ (assoc key l1))
+ res))
+ keys)
+ (nreverse res)))
+
+(provide 'parseclj-alist)
+
+;;; parseclj-alist.el ends here
--- /dev/null
+;;; parseclj-ast.el --- Clojure parser/unparser -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 Arne Brasseur
+
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Parse Clojure code to an AST, and unparse back to code.
+
+;;; Code:
+
+(require 'seq)
+(require 'subr-x)
+(require 'parseclj-lex)
+(require 'parseclj-alist)
+
+;; AST helper functions
+
+(defun parseclj-ast-node (type position &rest attributes)
+ "Create an AST node with given TYPE and POSITION.
+Other ATTRIBUTES can be given as a flat list of key-value pairs."
+ (apply 'parseclj-alist :node-type type :position position attributes))
+
+(defun parseclj-ast-node-p (node)
+ "Return t if the given NODE is a Clojure AST node."
+ (and (consp node)
+ (consp (car node))
+ (eq :node-type (caar node))))
+
+(defun parseclj-ast-node-attr (node attr)
+ "Return NODE's ATTR, or nil."
+ (map-elt node attr))
+
+(defun parseclj-ast-node-type (node)
+ "Return the type of the AST node NODE."
+ (map-elt node :node-type))
+
+(defun parseclj-ast-children (node)
+ "Return children for the AST NODE."
+ (map-elt node :children))
+
+(defun parseclj-ast-value (node)
+ "Return the value of NODE as another AST node."
+ (map-elt node :value))
+
+(defun parseclj-ast-leaf-node-p (node)
+ "Return t if the given ast NODE is a leaf node."
+ (member (parseclj-ast-node-type node) parseclj-lex--leaf-tokens))
+
+(defun parseclj-ast-branch-node-p (node)
+ "Return t if the given AST NODE is a branch node."
+ (not (parseclj-ast-leaf-node-p node)))
+
+\f
+;; Parse/reduce strategy functions
+
+(defun parseclj-ast--reduce-leaf (stack token &optional _options)
+ "Put into the STACK an AST leaf node based on TOKEN.
+Ignores white spaces and comments.
+
+OPTIONS is an association list. See `parseclj-parse' for more information
+on available options."
+ (if (member (parseclj-lex-token-type token) '(:whitespace :comment))
+ stack
+ (cons
+ (parseclj-ast-node (parseclj-lex-token-type token)
+ (map-elt token :pos)
+ :form (map-elt token :form)
+ :value (parseclj-lex--leaf-token-value token))
+ stack)))
+
+(defun parseclj-ast--reduce-leaf-with-lexical-preservation (stack token options)
+ "Put into STACK an AST leaf node based on TOKEN.
+This function is very similar to `parseclj-ast--reduce-leaf', but unlike
+it, takes into account tokens representing white space or comments and
+saves them into the STACK. Nodes produced by this function have a
+`:lexical-preservation' key set to t.
+
+OPTIONS is an association list. See `parseclj-parse' for more information
+on available options."
+ (let ((token-type (parseclj-lex-token-type token))
+ (top (car stack)))
+ (if (member token-type '(:whitespace :comment))
+ ;; merge consecutive whitespace or comment tokens
+ (if (eq token-type (map-elt top :node-type))
+ (cons (parseclj-alist-update top :form #'concat (map-elt token :form))
+ (cdr stack))
+ (cons (parseclj-ast-node (parseclj-lex-token-type token)
+ (map-elt token :pos)
+ :form (map-elt token :form))
+ stack))
+ (parseclj-ast--reduce-leaf stack token options))))
+
+(defun parseclj-ast--reduce-branch (stack opening-token children _options)
+ "Reduce STACK with an AST branch node representing a collection of elements.
+Ignores discard tokens.
+
+OPENING-TOKEN is a lex token representing an opening paren, bracket or
+brace.
+CHILDREN is the collection of nodes to be reduced into the AST branch node.
+OPTIONS is an association list. See `parseclj-parse' for more information
+on available options."
+ (let* ((pos (map-elt opening-token :pos))
+ (type (parseclj-lex-token-type opening-token))
+ (type (cond
+ ((eq :lparen type) :list)
+ ((eq :lbracket type) :vector)
+ ((eq :lbrace type) :map)
+ (t type))))
+ (cond
+ ((eq :root type) (cons (parseclj-ast-node :root pos :children children) stack))
+ ((eq :discard type) stack)
+ ((eq :tag type) (cons (parseclj-ast-node :tag
+ pos
+ :tag (intern (substring (map-elt opening-token :form) 1))
+ :children children)
+ stack))
+ ((eq :metadata type) (cons (parseclj-ast-node :with-meta
+ pos
+ :children children)
+ stack))
+ ((eq :map-prefix type) (cons (parseclj-alist-assoc (car children)
+ :map-prefix opening-token)
+ stack))
+ (t (cons
+ (parseclj-ast-node type pos :children children)
+ stack)))))
+
+(defun parseclj-ast--reduce-branch-with-lexical-preservation (stack opening-token children options)
+ "Reduce STACK with an AST branch node representing a collection of elements.
+Similar to `parseclj-ast--reduce-branch', but reduces discard tokens as
+well. Nodes produced by this function have a `:lexical-preservation'
+key set to t.
+
+OPENING-TOKEN is a lex token representing an opening paren, bracket or
+brace.
+CHILDREN is the collection of tokens to be reduced into the AST branch
+node.
+OPTIONS is an association list. See `parseclj-parse' for more information
+on available options."
+ (if (eq :discard (parseclj-lex-token-type opening-token))
+ (cons (parseclj-ast-node :discard (map-elt opening-token :pos) :children children) stack)
+ (let* ((stack (funcall #'parseclj-ast--reduce-branch stack opening-token children options))
+ (top (car stack)))
+ (if (parseclj-ast-node-p top)
+ (cons (cl-list* (car top) ;; make sure :node-type remains the first element in the list
+ '(:lexical-preservation . t)
+ (cdr top))
+ (cdr stack))
+ stack))))
+
+
+\f
+;; Unparse functions
+
+(declare-function parseclj-unparse-clojure "parseclj")
+
+(defun parseclj-ast--unparse-collection (node)
+ "Insert a string representation of the given AST branch NODE into buffer."
+ (let* ((token-type (parseclj-ast-node-type node))
+ (delimiters (cond
+ ((eq :root token-type) (cons "" ""))
+ ((eq :list token-type) (cons "(" ")"))
+ ((eq :vector token-type) (cons "[" "]"))
+ ((eq :set token-type) (cons "#{" "}"))
+ ((eq :map token-type) (cons "{" "}")))))
+ (insert (car delimiters))
+ (let ((nodes (alist-get ':children node)))
+ (when-let (node (car nodes))
+ (parseclj-unparse-clojure node))
+ (seq-doseq (child (cdr nodes))
+ (when (not (map-elt node :lexical-preservation))
+ (insert " "))
+ (parseclj-unparse-clojure child)))
+ (insert (cdr delimiters))))
+
+(defun parseclj-ast--unparse-tag (node)
+ "Insert a string representation of the given AST tag NODE into buffer."
+ (progn
+ (insert "#")
+ (insert (symbol-name (map-elt node :tag)))
+ (insert " ")
+ (parseclj-unparse-clojure (car (map-elt node :children)))))
+
+(provide 'parseclj-ast)
+
+;;; parseclj-ast.el ends here
--- /dev/null
+;;; parseclj-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
+;;
+;;; Code:
+
+(add-to-list 'load-path (directory-file-name
+ (or (file-name-directory #$) (car load-path))))
+
+\f
+;;;### (autoloads nil "parseclj" "parseclj.el" (0 0 0 0))
+;;; Generated autoloads from parseclj.el
+
+(register-definition-prefixes "parseclj" '("parseclj-"))
+
+;;;***
+\f
+;;;### (autoloads nil "parseclj-alist" "parseclj-alist.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from parseclj-alist.el
+
+(register-definition-prefixes "parseclj-alist" '("parseclj-"))
+
+;;;***
+\f
+;;;### (autoloads nil "parseclj-ast" "parseclj-ast.el" (0 0 0 0))
+;;; Generated autoloads from parseclj-ast.el
+
+(register-definition-prefixes "parseclj-ast" '("parseclj-ast-"))
+
+;;;***
+\f
+;;;### (autoloads nil "parseclj-lex" "parseclj-lex.el" (0 0 0 0))
+;;; Generated autoloads from parseclj-lex.el
+
+(register-definition-prefixes "parseclj-lex" '("parseclj-lex-"))
+
+;;;***
+\f
+;;;### (autoloads nil "parseclj-parser" "parseclj-parser.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from parseclj-parser.el
+
+(register-definition-prefixes "parseclj-parser" '("parseclj-"))
+
+;;;***
+\f
+;;;### (autoloads nil nil ("parseclj-pkg.el") (0 0 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; coding: utf-8
+;; End:
+;;; parseclj-autoloads.el ends here
--- /dev/null
+;;; parseclj-lex.el --- Clojure/EDN Lexer
+
+;; Copyright (C) 2017-2021 Arne Brasseur
+
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; A reader for EDN data files and parser for Clojure source files.
+
+;;; Code:
+
+(require 'parseclj-alist)
+
+(defcustom parseclj-lex-symbol-special-chars
+ '(?. ?* ?+ ?! ?- ?_ ?? ?$ ?% ?& ?= ?< ?> ?/ ?')
+ "The list of characters that can consitute a symbol or keyword's name.
+
+Please note that Clojure might at runtime accept keywords with
+more constituent characters than those found in the default value
+of this variable (which is the officially supported list), but
+the end result should be treated as undefined. This could be the
+case for example when keywordized maps are created from external
+sources without keyword validation. Change this value at your
+own risk."
+ :type 'sexp
+ :group 'parseclj)
+
+(defvar parseclj-lex--leaf-tokens '(:whitespace
+ :comment
+ :symbolic-value
+ :number
+ :nil
+ :true
+ :false
+ :symbol
+ :keyword
+ :string
+ :regex
+ :character)
+ "Types of tokens that represent leaf nodes in the AST.")
+
+(defvar parseclj-lex--closing-tokens '(:rparen
+ :rbracket
+ :rbrace)
+ "Types of tokens that mark the end of a non-atomic form.")
+
+(defvar parseclj-lex--prefix-tokens '(:quote
+ :backquote
+ :unquote
+ :unquote-splice
+ :discard
+ :tag
+ :reader-conditional
+ :reader-conditional-splice
+ :var
+ :deref
+ :map-prefix
+ :eval)
+ "Tokens that modify the form that follows.")
+
+(defvar parseclj-lex--prefix-2-tokens '(:metadata)
+ "Tokens that modify the two forms that follow.")
+
+;; Token interface
+
+(defun parseclj-lex-token (type form pos &rest attributes)
+ "Create a lexer token with the specified attributes.
+
+Tokens at a mimimum have these attributes
+- TYPE: the type of token, like :whitespace or :lparen
+- FORM: the source form, a string
+- POS: the position in the input, starts from 1 (like point)
+
+Other ATTRIBUTES can be given as a flat list of key-value pairs."
+ (apply #'parseclj-alist :token-type type :form form :pos pos attributes))
+
+(defun parseclj-lex-error-token (pos &optional error-type)
+ "Create a lexer error token starting at POS.
+ERROR-TYPE is an optional keyword to attach to the created token,
+as the means for providing more information on the error."
+ (apply #'parseclj-lex-token
+ :lex-error
+ (buffer-substring-no-properties pos (point))
+ pos
+ (when error-type
+ (list :error-type error-type))))
+
+(defun parseclj-lex-token-p (token)
+ "Is the given TOKEN a parseclj-lex TOKEN.
+
+A token is an association list with :token-type as its first key."
+ (and (consp token)
+ (consp (car token))
+ (eq :token-type (caar token))))
+
+(defun parseclj-lex-token-type (token)
+ "Get the type of TOKEN."
+ (and (consp token)
+ (cdr (assq :token-type token))))
+
+(defun parseclj-lex-token-form (token)
+ "Get the form of TOKEN."
+ (and (consp token)
+ (cdr (assq :form token))))
+
+(defun parseclj-lex-leaf-token-p (token)
+ "Return t if the given AST TOKEN is a leaf node."
+ (member (parseclj-lex-token-type token) parseclj-lex--leaf-tokens))
+
+(defun parseclj-lex-closing-token-p (token)
+ "Return t if the given ast TOKEN is a closing token."
+ (member (parseclj-lex-token-type token) parseclj-lex--closing-tokens))
+
+(defun parseclj-lex-error-p (token)
+ "Return t if the TOKEN represents a lexing error token."
+ (eq (parseclj-lex-token-type token) :lex-error))
+
+;; Elisp values from tokens
+
+(defun parseclj-lex--string-value (s)
+ "Parse an EDN string S into a regular string.
+S goes through three transformations:
+- Escaped characters in S are transformed into Elisp escaped
+ characters.
+- Unicode escaped characters are decoded into its corresponding
+ unicode character counterpart.
+- Octal escaped characters are decoded into its corresponding
+ character counterpart."
+ (replace-regexp-in-string
+ "\\\\o[0-8]\\{3\\}"
+ (lambda (x)
+ (make-string 1 (string-to-number (substring x 2) 8)))
+ (replace-regexp-in-string
+ "\\\\u[0-9a-fA-F]\\{4\\}"
+ (lambda (x)
+ (make-string 1 (string-to-number (substring x 2) 16)))
+ (replace-regexp-in-string "\\\\[tbnrf'\"\\]"
+ (lambda (x)
+ (let ((ch (elt x 1)))
+ (cond
+ ((eq ?t ch) "\t")
+ ((eq ?f ch) "\f")
+ ((eq ?\" ch) "\"")
+ ((eq ?r ch) "\r")
+ ((eq ?n ch) "\n")
+ ((eq ?\\ ch) "\\\\")
+ (t (substring x 1)))))
+ (substring s 1 -1)))))
+
+(defun parseclj-lex--character-value (c)
+ "Parse an EDN character C into an Emacs Lisp character."
+ (let ((first-char (elt c 1)))
+ (cond
+ ((equal c "\\newline") ?\n)
+ ((equal c "\\return") ?\r)
+ ((equal c "\\space") ?\ )
+ ((equal c "\\tab") ?\t)
+ ((eq first-char ?u) (string-to-number (substring c 2) 16))
+ ((eq first-char ?o) (string-to-number (substring c 2) 8))
+ (t first-char))))
+
+(defun parseclj-lex--number-value (number-str)
+ "Parse the NUMBER-STR to an Elisp number."
+ (let ((ratio (split-string number-str "/")))
+ (if (= 2 (length ratio))
+ (let ((numerator (string-to-number (car ratio)))
+ (denominator (string-to-number (cadr ratio))))
+ (/ numerator (float denominator)))
+ (string-to-number number-str))))
+
+(defun parseclj-lex--leaf-token-value (token)
+ "Parse the given leaf TOKEN to an Emacs Lisp value."
+ (let ((token-type (parseclj-lex-token-type token)))
+ (cond
+ ((eq :number token-type) (parseclj-lex--number-value (alist-get :form token)))
+ ((eq :nil token-type) nil)
+ ((eq :true token-type) t)
+ ((eq :false token-type) nil)
+ ((eq :symbol token-type) (intern (alist-get :form token)))
+ ((eq :keyword token-type) (intern (alist-get :form token)))
+ ((eq :string token-type) (parseclj-lex--string-value (alist-get :form token)))
+ ((eq :character token-type) (parseclj-lex--character-value (alist-get :form token)))
+ ((eq :symbolic-value token-type) (intern (substring (alist-get :form token) 2))))))
+
+;; Stream tokenization
+
+(defun parseclj-lex-at-whitespace-p ()
+ "Return t if char at point is white space."
+ (let ((char (char-after (point))))
+ (or (equal char ?\ )
+ (equal char ?\t)
+ (equal char ?\n)
+ (equal char ?\r)
+ (equal char ?,))))
+
+(defun parseclj-lex-at-eof-p ()
+ "Return t if point is at the end of file."
+ (eq (point) (point-max)))
+
+(defun parseclj-lex-whitespace ()
+ "Consume all consecutive white space as possible and return an :whitespace token."
+ (let ((pos (point)))
+ (while (parseclj-lex-at-whitespace-p)
+ (right-char))
+ (parseclj-lex-token :whitespace
+ (buffer-substring-no-properties pos (point))
+ pos)))
+
+(defun parseclj-lex-skip-digits ()
+ "Skip all consecutive digits after point."
+ (while (and (char-after (point))
+ (<= ?0 (char-after (point)))
+ (<= (char-after (point)) ?9))
+ (right-char)))
+
+(defun parseclj-lex-skip-hex ()
+ "Skip all consecutive hex digits after point."
+ (while (and (char-after (point))
+ (or (<= ?0 (char-after (point)) ?9)
+ (<= ?a (char-after (point)) ?f)
+ (<= ?A (char-after (point)) ?F)))
+ (right-char)))
+
+(defun parseclj-lex-skip-number ()
+ "Skip a number at point."
+ ;; [\+\-]?\d+\.\d+
+ (if (and (eq ?0 (char-after (point)))
+ (eq ?x (char-after (1+ (point)))))
+ (progn
+ (right-char 2)
+ (parseclj-lex-skip-hex))
+ (progn
+ (when (member (char-after (point)) '(?+ ?-))
+ (right-char))
+
+ (parseclj-lex-skip-digits)
+
+ (when (eq (char-after (point)) ?.)
+ (right-char))
+
+ (parseclj-lex-skip-digits))))
+
+(defun parseclj-lex-number ()
+ "Consume a number and return a `:number' token representing it."
+ (let ((pos (point)))
+ (parseclj-lex-skip-number)
+
+ ;; 10110r2 or 4.3e+22
+ (when (member (char-after (point)) '(?E ?e ?r))
+ (right-char))
+
+ (parseclj-lex-skip-number)
+
+ ;; trailing M
+ (when (eq (char-after (point)) ?M)
+ (right-char))
+
+ ;; trailing N clojure.lang.BigInt
+ (when (eq (char-after (point)) ?N)
+ (right-char))
+
+ ;; clojure.lang.Ratio
+ (when (eq (char-after (point)) ?/)
+ (right-char)
+ (parseclj-lex-skip-number))
+
+ (let ((char (char-after (point))))
+ (if (and char (or (and (<= ?a char) (<= char ?z))
+ (and (<= ?A char) (<= char ?Z))
+ (and (member char '(?. ?* ?+ ?! ?- ?_ ?? ?$ ?& ?= ?< ?> ?/)))))
+ (progn
+ (right-char)
+ (parseclj-lex-error-token pos :invalid-number-format))
+ (parseclj-lex-token :number
+ (buffer-substring-no-properties pos (point))
+ pos)))))
+
+
+(defun parseclj-lex-digit-p (char)
+ "Return t if CHAR is a digit."
+ (and char (<= ?0 char) (<= char ?9)))
+
+(defun parseclj-lex-at-number-p ()
+ "Return t if point is at a number."
+ (let ((char (char-after (point))))
+ (or (parseclj-lex-digit-p char)
+ (and (member char '(?- ?+ ?.))
+ (parseclj-lex-digit-p (char-after (1+ (point))))))))
+
+(defun parseclj-lex-symbol-start-p (char &optional alpha-only)
+ "Return t if CHAR is a valid start for a symbol.
+
+Symbols begin with a non-numeric character and can contain alphanumeric
+characters and . * + ! - _ ? $ % & = < > '. If - + or . are the first
+character, the second character (if any) must be non-numeric.
+
+In some cases, like in tagged elements, symbols are required to start with
+alphabetic characters only. ALPHA-ONLY ensures this behavior."
+ (not (not (and char
+ (or (and (<= ?a char) (<= char ?z))
+ (and (<= ?A char) (<= char ?Z))
+ (and (not alpha-only) (member char parseclj-lex-symbol-special-chars)))))))
+
+(defun parseclj-lex-symbol-rest-p (char)
+ "Return t if CHAR is a valid character in a symbol.
+For more information on what determines a valid symbol, see
+`parseclj-lex-symbol-start-p'"
+ (or (parseclj-lex-symbol-start-p char)
+ (parseclj-lex-digit-p char)
+ (eq ?: char)
+ (eq ?# char)))
+
+(defun parseclj-lex-get-symbol-at-point (pos)
+ "Return the symbol at POS as a string."
+ (while (parseclj-lex-symbol-rest-p (char-after (point)))
+ (right-char))
+ (buffer-substring-no-properties pos (point)))
+
+(defun parseclj-lex-symbol ()
+ "Return a lex token representing a symbol.
+Because of their special meaning, symbols \"nil\", \"true\", and \"false\"
+are returned as their own lex tokens."
+ (let ((pos (point)))
+ (right-char)
+ (let ((sym (parseclj-lex-get-symbol-at-point pos)))
+ (cond
+ ((equal sym "nil") (parseclj-lex-token :nil "nil" pos))
+ ((equal sym "true") (parseclj-lex-token :true "true" pos))
+ ((equal sym "false") (parseclj-lex-token :false "false" pos))
+ (t (parseclj-lex-token :symbol sym pos))))))
+
+(defun parseclj-lex-string* ()
+ "Helper for string/regex lexing.
+Returns either the string, or an error token"
+ (let ((pos (point)))
+ (right-char)
+ (while (not (or (equal (char-after (point)) ?\") (parseclj-lex-at-eof-p)))
+ (if (equal (char-after (point)) ?\\)
+ (right-char 2)
+ (right-char)))
+ (when (equal (char-after (point)) ?\")
+ (right-char)
+ (buffer-substring-no-properties pos (point)))))
+
+(defun parseclj-lex-string ()
+ "Return a lex token representing a string.
+If EOF is reached without finding a closing double quote, a :lex-error
+token is returned."
+ (let ((pos (point))
+ (str (parseclj-lex-string*)))
+ (if str
+ (parseclj-lex-token :string str pos)
+ (parseclj-lex-error-token pos :invalid-string))))
+
+(defun parseclj-lex-regex ()
+ "Return a lex token representing a regular expression.
+If EOF is reached without finding a closing double quote, a :lex-error
+token is returned."
+ (let ((pos (1- (point)))
+ (str (parseclj-lex-string*)))
+ (if str
+ (parseclj-lex-token :regex (concat "#" str) pos)
+ (parseclj-lex-error-token pos :invalid-regex))))
+
+(defun parseclj-lex-lookahead (n)
+ "Return a lookahead string of N characters after point."
+ (buffer-substring-no-properties (point) (min (+ (point) n) (point-max))))
+
+(defun parseclj-lex-character ()
+ "Return a lex token representing a character."
+ (let ((pos (point)))
+ (right-char)
+ (cond
+ ((equal (parseclj-lex-lookahead 3) "tab")
+ (right-char 3)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ ((equal (parseclj-lex-lookahead 5) "space")
+ (right-char 5)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ ((equal (parseclj-lex-lookahead 6) "return")
+ (right-char 6)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ ((equal (parseclj-lex-lookahead 7) "newline")
+ (right-char 7)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ ((string-match-p "^u[0-9a-fA-F]\\{4\\}" (parseclj-lex-lookahead 5))
+ (right-char 5)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ ((string-match-p "^o[0-8]\\{3\\}" (parseclj-lex-lookahead 4))
+ (right-char 4)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos))
+
+ (t
+ (right-char)
+ (parseclj-lex-token :character (buffer-substring-no-properties pos (point)) pos)))))
+
+(defun parseclj-lex-keyword ()
+ "Return a lex token representing a keyword.
+Keywords follow the same rules as symbols, except they start with one or
+two colon characters.
+
+See `parseclj-lex-symbol', `parseclj-lex-symbol-start-p'."
+ (let ((pos (point)))
+ (right-char)
+ (when (equal (char-after (point)) ?:) ;; same-namespace keyword
+ (right-char))
+ (if (equal (char-after (point)) ?:) ;; three colons in a row => lex-error
+ (progn
+ (right-char)
+ (parseclj-lex-error-token pos :invalid-keyword))
+ (progn
+ (while (or (parseclj-lex-symbol-rest-p (char-after (point)))
+ (equal (char-after (point)) ?#))
+ (right-char))
+ (parseclj-lex-token :keyword (buffer-substring-no-properties pos (point)) pos)))))
+
+(defun parseclj-lex-comment ()
+ "Return a lex token representing a comment."
+ (let ((pos (point)))
+ (goto-char (line-end-position))
+ (when (equal (char-after (point)) ?\n)
+ (right-char))
+ (parseclj-lex-token :comment (buffer-substring-no-properties pos (point)) pos)))
+
+(defun parseclj-lex-map-prefix ()
+ "Return a lex token representing a map prefix."
+ (let ((pos (1- (point))))
+ (right-char)
+ (when (equal (char-after (point)) ?:)
+ (right-char))
+ (while (parseclj-lex-symbol-rest-p (char-after (point)))
+ (right-char))
+ (parseclj-lex-token :map-prefix (buffer-substring-no-properties pos (point)) pos)))
+
+(defun parseclj-lex-next ()
+ "Consume characters at point and return the next lexical token.
+
+See `parseclj-lex-token'."
+ (if (parseclj-lex-at-eof-p)
+ (parseclj-lex-token :eof nil (point))
+ (let ((char (char-after (point)))
+ (pos (point)))
+ (cond
+ ((parseclj-lex-at-whitespace-p)
+ (parseclj-lex-whitespace))
+
+ ((equal char ?\()
+ (right-char)
+ (parseclj-lex-token :lparen "(" pos))
+
+ ((equal char ?\))
+ (right-char)
+ (parseclj-lex-token :rparen ")" pos))
+
+ ((equal char ?\[)
+ (right-char)
+ (parseclj-lex-token :lbracket "[" pos))
+
+ ((equal char ?\])
+ (right-char)
+ (parseclj-lex-token :rbracket "]" pos))
+
+ ((equal char ?{)
+ (right-char)
+ (parseclj-lex-token :lbrace "{" pos))
+
+ ((equal char ?})
+ (right-char)
+ (parseclj-lex-token :rbrace "}" pos))
+
+ ((equal char ?')
+ (right-char)
+ (parseclj-lex-token :quote "'" pos))
+
+ ((equal char ?`)
+ (right-char)
+ (parseclj-lex-token :backquote "`" pos))
+
+ ((equal char ?~)
+ (right-char)
+ (if (eq ?@ (char-after (point)))
+ (progn
+ (right-char)
+ (parseclj-lex-token :unquote-splice "~@" pos))
+ (parseclj-lex-token :unquote "~" pos)))
+
+ ((parseclj-lex-at-number-p)
+ (parseclj-lex-number))
+
+ ((parseclj-lex-symbol-start-p char)
+ (parseclj-lex-symbol))
+
+ ((equal char ?\")
+ (parseclj-lex-string))
+
+ ((equal char ?\\)
+ (parseclj-lex-character))
+
+ ((equal char ?:)
+ (parseclj-lex-keyword))
+
+ ((equal char ?\;)
+ (parseclj-lex-comment))
+
+ ((equal char ?^)
+ (right-char)
+ (parseclj-lex-token :metadata "^" pos))
+
+ ((equal char ?@)
+ (right-char)
+ (parseclj-lex-token :deref "@" pos))
+
+ ((equal char ?#)
+ (right-char)
+ (let ((char (char-after (point))))
+ (cond
+ ((equal char ?{)
+ (right-char)
+ (parseclj-lex-token :set "#{" pos))
+ ((equal char ?_)
+ (right-char)
+ (parseclj-lex-token :discard "#_" pos))
+ ((equal char ?\()
+ (right-char)
+ (parseclj-lex-token :lambda "#(" pos))
+ ((equal char ?')
+ (right-char)
+ (parseclj-lex-token :var "#'" pos))
+ ((equal char ?=)
+ (right-char)
+ (parseclj-lex-token :eval "#=" pos))
+ ((equal char ?#)
+ (right-char)
+ (let ((sym (parseclj-lex-get-symbol-at-point (point))))
+ (parseclj-lex-token :symbolic-value (concat "##" sym) pos)))
+ ((equal char ?\")
+ (parseclj-lex-regex))
+ ((equal char ?:)
+ (parseclj-lex-map-prefix))
+ ((equal char ?\?)
+ (right-char)
+ (if (eq ?@ (char-after (point)))
+ (progn
+ (right-char)
+ (parseclj-lex-token :reader-conditional-splice "#?@" pos))
+ (parseclj-lex-token :reader-conditional "#?" pos)))
+ ((parseclj-lex-symbol-start-p char t)
+ (right-char)
+ (parseclj-lex-token :tag (concat "#" (parseclj-lex-get-symbol-at-point (1+ pos))) pos))
+ ((equal char ?!) ;; shebang
+ (left-char)
+ (parseclj-lex-comment))
+ (t
+ (while (not (or (parseclj-lex-at-whitespace-p)
+ (parseclj-lex-at-eof-p)))
+ (right-char))
+ (parseclj-lex-error-token pos :invalid-hashtag-dispatcher)))))
+
+ (t
+ (progn
+ (right-char)
+ (parseclj-lex-error-token pos)))))))
+
+(provide 'parseclj-lex)
+
+;;; parseclj-lex.el ends here
--- /dev/null
+;;; parseclj-parser.el --- Clojure/EDN parser -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 Arne Brasseur
+
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; A shift/reduce parser for Clojure source.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'subr-x)
+(require 'parseclj-lex)
+(require 'parseclj-alist)
+(require 'map)
+
+(define-error 'parseclj-parser-error "parseclj: Syntax error")
+
+(defun parseclj--error (format &rest args)
+ "Signal a parse error.
+Takes a FORMAT string and optional ARGS to be passed to
+`format-message'. Signals a 'parseclj-parser-error signal, which
+can be handled with `condition-case'."
+ (signal 'parseclj-parser-error (list (apply #'format-message format args))))
+
+(defun parseclj--find-opening-token (stack closing-token)
+ "Scan STACK for an opening-token matching CLOSING-TOKEN."
+ (let ((token-type (parseclj-lex-token-type closing-token)))
+ (cond
+ ((eq :rparen token-type) (parseclj-lex-token-type
+ (seq-find (lambda (token)
+ (member (parseclj-lex-token-type token)
+ '(:lparen :lambda)))
+ stack)))
+ ((eq :rbracket token-type) :lbracket)
+ ((eq :rbrace token-type) (parseclj-lex-token-type
+ (seq-find (lambda (token)
+ (member (parseclj-lex-token-type token)
+ '(:lbrace :set)))
+ stack))))))
+
+(defun parseclj--reduce-coll (stack closing-token reduce-branch options)
+ "Reduce collection based on the top of the STACK and a CLOSING-TOKEN.
+
+REDUCE-BRANCH is a function to be applied to the collection of tokens found
+from the top of the stack until an opening token that matches
+CLOSING-TOKEN. This function should return an AST token representing such
+collection.
+
+OPTIONS is an association list. This list is also passed down to the
+REDUCE-BRANCH function. See `parseclj-parser' for more information on
+available options."
+ (let ((opening-token-type (parseclj--find-opening-token stack closing-token))
+ (fail-fast (map-elt options :fail-fast t))
+ (collection nil))
+ (if (not opening-token-type)
+ (if fail-fast
+ (parseclj--error "At position %s, unmatched %S"
+ (map-elt closing-token :pos)
+ (parseclj-lex-token-type closing-token))
+
+ stack)
+
+ (progn
+ ;; unwind the stack until opening-token-type is found, adding to collection
+ (while (and stack (not (eq (parseclj-lex-token-type (car stack)) opening-token-type)))
+ (push (pop stack) collection))
+
+ ;; did we find the right token?
+ (if (eq (parseclj-lex-token-type (car stack)) opening-token-type)
+ (progn
+ (when fail-fast
+ ;; any unreduced tokens left: bail early
+ (when-let ((token (seq-find #'parseclj-lex-token-p collection)))
+ (parseclj--error "At position %s, unmatched %S"
+ (map-elt token :pos)
+ (parseclj-lex-token-type token))))
+
+ ;; 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 options)))
+
+ ;; Unwound the stack without finding a matching paren: either bail early
+ ;; or return the original stack and continue parsing
+ (if fail-fast
+ (parseclj--error "At position %s, unmatched %S"
+ (map-elt closing-token :pos)
+ (parseclj-lex-token-type closing-token))
+
+ (reverse collection)))))))
+
+(defun parseclj--take-value (stack value-p)
+ "Scan STACK until a value is found.
+Return everything up to the value in reversed order (meaning the value
+comes first in the result).
+
+STACK is the current parse stack to scan.
+
+VALUE-P a predicate to distinguish reduced values from non-values (tokens
+and whitespace)."
+ (let ((result nil))
+ (cl-block nil
+ (while stack
+ (cond
+ ((parseclj-lex-token-p (car stack))
+ (cl-return nil))
+
+ ((funcall value-p (car stack))
+ (cl-return (cons (car stack) result)))
+
+ (t
+ (push (pop stack) result)))))))
+
+(defun parseclj--take-token (stack value-p token-types)
+ "Scan STACK until a token of a certain type is found.
+Returns nil if a value is encountered before a matching token is found.
+Return everything up to the token in reversed order (meaning the token
+comes first in the result).
+
+STACK is the current parse stack to scan.
+
+VALUE-P a predicate to distinguish reduced values from non-values (tokens
+and whitespace).
+
+TOKEN-TYPES are the token types to look for."
+ (let ((result nil))
+ (cl-block nil
+ (while stack
+ (cond
+ ((member (parseclj-lex-token-type (car stack)) token-types)
+ (cl-return (cons (car stack) result)))
+ ((funcall value-p (car stack))
+ (cl-return nil))
+ ((parseclj-lex-token-p (car stack))
+ (cl-return nil))
+ (t
+ (push (pop stack) result)))))))
+
+(defun parseclj-single-value-p (stack value-p)
+ "Return t if STACK only has a single node for which VALUE-P is true.
+
+This checks if the stack contains a single, fully reduced value, and no
+dangling unmatched tokens. When parsing with `:read-one' this indicates a
+form can be returned."
+ (and (not (cl-reduce (lambda (bool node)
+ (or bool (parseclj-lex-token-p node)))
+ stack
+ :initial-value nil))
+ (parseclj--take-value stack value-p)))
+
+(defun parseclj-parser (reduce-leaf reduce-branch &optional options)
+ "Clojure/EDN stack-based shift-reduce parser.
+
+REDUCE-LEAF does reductions for leaf nodes. It is a function that takes
+the current value of the stack and a token, and either returns an updated
+stack, with a new leaf node at the top (front), or returns the stack
+unmodified.
+
+REDUCE-BRANCH does reductions for branch nodes. It is a function that
+takes the current value of the stack, the type of branch node to create,
+and a list of child nodes, and returns an updated stack, with the new node
+at the top (front).
+
+What \"node\" means in this case is up to the reducing functions, it could
+be AST nodes (as in the case of `parseclj-parser-clojure'), or plain
+values/sexps (as in the case of `parseedn-read'), or something else. The
+only requirement is that they should not put raw tokens back on the stack,
+as the parser relies on the presence or absence of these to detect parse
+errors.
+
+OPTIONS is an association list which is passed on to the reducing
+functions. Additionally the following options are recognized
+
+- `:fail-fast'
+ Raise an error when a parse error is encountered, rather than continuing
+ with a partial result.
+- `:value-p'
+ A predicate function to differentiate values from tokens and
+ whitespace. This is needed when scanning the stack to see if any
+ reductions can be performed. By default anything that isn't a token is
+ considered a value. This can be problematic when parsing with
+ `:lexical-preservation', and which case you should provide an
+ implementation that also returns falsy for :whitespace, :comment, and
+ :discard AST nodes.
+- `:tag-readers'
+ An association list that describes tag handler functions for any possible
+ tag. This options in only available in `parseedn-read', for more
+ information, please refer to its documentation.
+- `:read-one'
+ Return as soon as a single complete value has been read."
+ (let ((fail-fast (map-elt options :fail-fast t))
+ (read-one (map-elt options :read-one))
+ (value-p (map-elt options :value-p (lambda (e) (not (parseclj-lex-token-p e)))))
+ (stack nil)
+ (token (parseclj-lex-next)))
+
+ (while (not (or (and read-one (parseclj-single-value-p stack value-p))
+ (eq (parseclj-lex-token-type token) :eof)))
+ ;; (message "STACK: %S" stack)
+ ;; (message "TOKEN: %S\n" token)
+
+ (when (and fail-fast (parseclj-lex-error-p token))
+ (parseclj--error "Invalid token at %s: %S"
+ (map-elt token :pos)
+ (parseclj-lex-token-form token)))
+
+ ;; Reduce based on the top item on the stack (collections)
+ (cond
+ ((parseclj-lex-leaf-token-p token)
+ (setf stack (funcall reduce-leaf stack token options)))
+
+ ((parseclj-lex-closing-token-p token)
+ (setf stack (parseclj--reduce-coll stack token reduce-branch options)))
+
+ (t (push token stack)))
+
+ ;; Reduce based on top two items on the stack (special prefixed elements)
+ (let* ((top-value (parseclj--take-value stack value-p))
+ (opening-token (parseclj--take-token (nthcdr (length top-value) stack) value-p parseclj-lex--prefix-tokens))
+ new-stack)
+ (while (and top-value opening-token)
+ ;; (message "Reducing...")
+ ;; (message " - STACK %S" stack)
+ ;; (message " - OPENING-TOKEN %S" opening-token)
+ ;; (message " - TOP-VALUE %S" top-value)
+ (setq new-stack (nthcdr (+ (length top-value) (length opening-token)) stack))
+ (setq stack (funcall reduce-branch new-stack (car opening-token) (append (cdr opening-token) top-value) options))
+
+ ;; recur
+ (setq top-value (parseclj--take-value stack value-p))
+ (setq opening-token (parseclj--take-token (nthcdr (length top-value) stack) value-p parseclj-lex--prefix-tokens))))
+
+ ;; Reduce based on top three items on the stack (metadata, namespaced maps)
+ (let* ((top-value-1 (parseclj--take-value stack value-p))
+ (top-value-2 (parseclj--take-value (nthcdr (length top-value-1) stack) value-p))
+ (opening-token (parseclj--take-token (nthcdr (+ (length top-value-1)
+ (length top-value-2)) stack) value-p parseclj-lex--prefix-2-tokens))
+ new-stack)
+ (while (and top-value-1 top-value-2 opening-token)
+ (setq new-stack (nthcdr (apply #'+ (mapcar #'length (list top-value-1 top-value-2 opening-token))) stack))
+ (setq stack (funcall reduce-branch new-stack (car opening-token) (append (cdr opening-token) top-value-2 top-value-1) options))
+
+ ;; recur
+ (setq top-value-1 (parseclj--take-value stack value-p))
+ (setq top-value-2 (parseclj--take-value (nthcdr (length top-value-1) stack) value-p))
+ (setq opening-token (parseclj--take-token (nthcdr (+ (length top-value-1)
+ (length top-value-2)) stack) value-p parseclj-lex--prefix-2-tokens))))
+
+ (setq token (parseclj-lex-next)))
+
+ ;; reduce root
+ (when fail-fast
+ (when-let ((token (seq-find #'parseclj-lex-token-p stack)))
+ (parseclj--error "At position %s, unmatched %S"
+ (map-elt token :pos)
+ (parseclj-lex-token-type token))))
+
+ (if read-one
+ (car (parseclj--take-value stack value-p))
+ (car (funcall reduce-branch nil (parseclj-lex-token :root "" 1)
+ (reverse stack)
+ options)))))
+
+(provide 'parseclj-parser)
+;;; parseclj-parser.el ends here
--- /dev/null
+(define-package "parseclj" "20220422.936" "Clojure/EDN parser"
+ '((emacs "25"))
+ :commit "4d0e780e00f1828b00c43099e6eebc6582998f72" :authors
+ '(("Arne Brasseur" . "arneNOSPAMarnebrasseur.net"))
+ :maintainers
+ '(("Arne Brasseur" . "arneNOSPAMarnebrasseur.net"))
+ :maintainer
+ '("Arne Brasseur" . "arneNOSPAMarnebrasseur.net")
+ :keywords
+ '("lisp" "clojure" "edn" "parser"))
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; parseclj.el --- Clojure/EDN parser -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 Arne Brasseur
+
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+;; Keywords: lisp clojure edn parser
+;; Package-Requires: ((emacs "25"))
+;; Version: 1.1.0
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Top level API for the Clojure parser.
+
+;;; Code:
+
+(require 'map)
+(require 'seq)
+
+(require 'parseclj-parser)
+(require 'parseclj-ast)
+(require 'parseclj-alist)
+
+(defun parseclj-parse-clojure (&rest string-and-options)
+ "Parse Clojure source to AST.
+
+Reads either from the current buffer, starting from point, until
+`point-max', or reads from the optional string argument.
+
+STRING-AND-OPTIONS can be an optional string, followed by
+key-value pairs to specify parsing options.
+
+- `:lexical-preservation' Retain whitespace, comments, and
+ discards. Defaults to nil.
+- `:fail-fast' Raise an error when encountering invalid syntax.
+ Defaults to t.
+- `:read-one'
+ Read a single form. Defaults to false: parse the complete input."
+ (if (stringp (car string-and-options))
+ (with-temp-buffer
+ (insert (car string-and-options))
+ (goto-char 1)
+ (apply 'parseclj-parse-clojure (cdr string-and-options)))
+ (let* ((value-p (lambda (e)
+ (and (parseclj-ast-node-p e)
+ (not (member (parseclj-ast-node-type e) '(:whitespace :comment :discard))))))
+ (options (apply 'parseclj-alist :value-p value-p string-and-options))
+ (lexical? (map-elt options :lexical-preservation)))
+ (parseclj-parser (if lexical?
+ #'parseclj-ast--reduce-leaf-with-lexical-preservation
+ #'parseclj-ast--reduce-leaf)
+ (if lexical?
+ #'parseclj-ast--reduce-branch-with-lexical-preservation
+ #'parseclj-ast--reduce-branch)
+ options))))
+
+(defun parseclj-unparse-clojure (ast)
+ "Parse Clojure AST to source code.
+
+Given an abstract syntax tree AST (as returned by
+`parseclj-parse-clojure'), turn it back into source code, and
+insert it into the current buffer."
+ (if (parseclj-ast-leaf-node-p ast)
+ (insert (map-elt ast :form))
+ (if (eql (parseclj-ast-node-type ast) :tag)
+ (parseclj-ast--unparse-tag ast)
+ (parseclj-ast--unparse-collection ast))))
+
+(defun parseclj-unparse-clojure-to-string (ast)
+ "Parse Clojure AST to a source code string.
+
+Given an abstract syntax tree AST (as returned by
+`parseclj-parse-clojure'), turn it back into source code, and
+return it as a string"
+ (with-temp-buffer
+ (parseclj-unparse-clojure ast)
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+(provide 'parseclj)
+
+;;; parseclj.el ends here
projects / emacsconfig.git / commitdiff