;;; peg.el --- Parsing Expression Grammars in Emacs Lisp  -*- lexical-binding:t -*-

;; Copyright (C) 2008-2023  Free Software Foundation, Inc.
;;
;; Author: Helmut Eller <eller.helmut@gmail.com>
;; Maintainer: Stefan Monnier <monnier@iro.umontreal.ca>
;; Version: 1.0.1
;;
;; This program 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 of the License, or
;; (at your option) any later version.
;;
;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; This package implements Parsing Expression Grammars for Emacs Lisp.

;; Parsing Expression Grammars (PEG) are a formalism in the spirit of
;; Context Free Grammars (CFG) with some simplifications which makes
;; the implementation of PEGs as recursive descent parsers particularly
;; simple and easy to understand [Ford, Baker].
;; PEGs are more expressive than regexps and potentially easier to use.
;;
;; This file implements the macros `define-peg-rule', `with-peg-rules', and
;; `peg-parse' which parses the current buffer according to a PEG.
;; E.g. we can match integers with:
;;
;;     (with-peg-rules
;;         ((number sign digit (* digit))
;;          (sign   (or "+" "-" ""))
;;          (digit  [0-9]))
;;       (peg-run (peg number)))
;; or
;;     (define-peg-rule digit ()
;;       [0-9])
;;     (peg-parse (number sign digit (* digit))
;;                (sign   (or "+" "-" "")))
;;
;; In contrast to regexps, PEGs allow us to define recursive "rules".
;; A "grammar" is a set of rules.  A rule is written as (NAME PEX...)
;; E.g. (sign (or "+" "-" "")) is a rule with the name "sign".
;; The syntax for PEX (Parsing Expression) is a follows:
;;
;;     Description		Lisp		Traditional, as in Ford's paper
;;     ===========		====		===========
;;     Sequence			(and E1 E2)	e1 e2
;;     Prioritized Choice	(or E1 E2)	e1 / e2
;;     Not-predicate		(not E)		!e
;;     And-predicate		(if E)		&e
;;     Any character		(any)		.
;;     Literal string		"abc"		"abc"
;;     Character C		(char C)	'c'
;;     Zero-or-more		(* E)		e*
;;     One-or-more		(+ E)		e+
;;     Optional			(opt E)		e?
;;     Non-terminal             SYMBOL		A
;;     Character range		(range A B)	[a-b]
;;     Character set		[a-b "+*" ?x]	[a-b+*x]   ;Note: it's a vector
;;     Character classes	[ascii cntrl]
;;     Boolean-guard		(guard EXP)
;;     Syntax-Class		(syntax-class NAME)
;;     Local definitions	(with RULES PEX...)
;;     Indirect call            (funcall EXP ARGS...)
;; and
;;     Empty-string		(null)		ε
;;     Beginning-of-Buffer	(bob)
;;     End-of-Buffer		(eob)
;;     Beginning-of-Line	(bol)
;;     End-of-Line		(eol)
;;     Beginning-of-Word	(bow)
;;     End-of-Word		(eow)
;;     Beginning-of-Symbol	(bos)
;;     End-of-Symbol		(eos)
;;
;; Rules can refer to other rules, and a grammar is often structured
;; as a tree, with a root rule referring to one or more "branch
;; rules", all the way down to the "leaf rules" that deal with actual
;; buffer text.  Rules can be recursive or mutually referential,
;; though care must be taken not to create infinite loops.
;;
;;;; Named rulesets:
;;
;; You can define a set of rules for later use with:
;;
;;     (define-peg-ruleset myrules
;;       (sign  () (or "+" "-" ""))
;;       (digit () [0-9])
;;       (nat   () digit (* digit))
;;       (int   () sign digit (* digit))
;;       (float () int "." nat))
;;
;; and later refer to it:
;;
;;     (with-peg-rules
;;         (myrules
;;          (complex float "+i" float))
;;       ... (peg-parse nat "," nat "," complex) ...)
;;
;;;; Parsing actions:
;;
;; PEXs also support parsing actions, i.e. Lisp snippets which are
;; executed when a pex matches.  This can be used to construct syntax
;; trees or for similar tasks.  The most basic form of action is
;; written as:
;;
;;     (action FORM)          ; evaluate FORM for its side-effects
;;
;; Actions don't consume input, but are executed at the point of
;; match.  Another kind of action is called a "stack action", and
;; looks like this:
;;
;;     `(VAR... -- FORM...)   ; stack action
;;
;; A stack action takes VARs from the "value stack" and pushes the
;; results of evaluating FORMs to that stack.

;; The value stack is created during the course of parsing.  Certain
;; operators (see below) that match buffer text can push values onto
;; this stack.  "Upstream" rules can then draw values from the stack,
;; and optionally push new ones back.  For instance, consider this
;; very simple grammar:
;;
;; (with-peg-rules
;;     ((query (+ term) (eol))
;;      (term key ":" value (opt (+ [space]))
;; 	   `(k v -- (cons (intern k) v)))
;;      (key (substring (and (not ":") (+ [word]))))
;;      (value (or string-value number-value))
;;      (string-value (substring (+ [alpha])))
;;      (number-value (substring (+ [digit]))
;; 		   `(val -- (string-to-number val))))
;;   (peg-run (peg query)))
;;
;; This invocation of `peg-run' would parse this buffer text:
;;
;; name:Jane age:30
;;
;; And return this Elisp sexp:
;;
;; ((age . 30) (name . "Jane"))
;;
;; Note that, in complex grammars, some care must be taken to make
;; sure that the number and type of values drawn from the stack always
;; match those pushed.  In the example above, both `string-value' and
;; `number-value' push a single value to the stack.  Since the `value'
;; rule only includes these two sub-rules, any upstream rule that
;; makes use of `value' can be confident it will always and only push
;; a single value to the stack.
;;
;; Stack action forms are in a sense analogous to lambda forms: the
;; symbols before the "--" are the equivalent of lambda arguments,
;; while the forms after the "--" are return values.  The difference
;; being that a lambda form can only return a single value, while a
;; stack action can push multiple values onto the stack.  It's also
;; perfectly valid to use `(-- FORM...)' or `(VAR... --)': the former
;; pushes values to the stack without consuming any, and the latter
;; pops values from the stack and discards them.
;;
;;;; Derived Operators:
;;
;; The following operators are implemented as combinations of
;; primitive expressions:
;;
;;     (substring E)  ; Match E and push the substring for the matched region.
;;     (region E)     ; Match E and push the start and end positions.
;;     (replace E RPL); Match E and replace the matched region with RPL.
;;     (list E)       ; Match E and push a list of the items that E produced.
;;
;; See `peg-ex-parse-int' in `peg-tests.el' for further examples.
;;
;; Regexp equivalents:
;;
;; Here a some examples for regexps and how those could be written as pex.
;; [Most are taken from rx.el]
;;
;;     "^[a-z]*"
;;     (and (bol) (* [a-z]))
;;
;;     "\n[^ \t]"
;;     (and "\n" (not [" \t"]) (any))
;;
;;     "\\*\\*\\* EOOH \\*\\*\\*\n"
;;     "*** EOOH ***\n"
;;
;;     "\\<\\(catch\\|finally\\)\\>[^_]"
;;     (and (bow) (or "catch" "finally") (eow) (not "_") (any))
;;
;;     "[ \t\n]*:\\([^:]+\\|$\\)"
;;     (and (* [" \t\n"]) ":" (or (+ (not ":") (any)) (eol)))
;;
;;     "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
;;     (and (bol)
;;          "content-transfer-encoding:"
;;          (* (opt "\n") ["\t "])
;;          "quoted-printable"
;;          (* (opt "\n") ["\t "]))
;;
;;     "\\$[I]d: [^ ]+ \\([^ ]+\\) "
;;     (and "$Id: " (+ (not " ") (any)) " " (+ (not " ") (any)) " ")
;;
;;     "^;;\\s-*\n\\|^\n"
;;     (or (and (bol) ";;" (* (syntax-class whitespace)) "\n")
;;         (and (bol) "\n"))
;;
;;     "\\\\\\\\\\[\\w+"
;;     (and "\\\\[" (+ (syntax-class word)))
;;
;; See ";;; Examples" in `peg-tests.el' for other examples.
;;
;;;; Rule argument and indirect calls:
;;
;; Rules can take arguments and those arguments can themselves be PEGs.
;; For example:
;;
;;     (define-peg-rule 2-or-more (peg)
;;       (funcall peg)
;;       (funcall peg)
;;       (* (funcall peg)))
;;
;;     ... (peg-parse
;;          ...
;;          (2-or-more (peg foo))
;;          ...
;;          (2-or-more (peg bar))
;;          ...)
;;
;;;; References:
;;
;; [Ford] Bryan Ford. Parsing Expression Grammars: a Recognition-Based
;; Syntactic Foundation. In POPL'04: Proceedings of the 31st ACM
;; SIGPLAN-SIGACT symposium on Principles of Programming Languages,
;; pages 111-122, New York, NY, USA, 2004. ACM Press.
;; http://pdos.csail.mit.edu/~baford/packrat/
;;
;; [Baker] Baker, Henry G. "Pragmatic Parsing in Common Lisp".  ACM Lisp
;; Pointers 4(2), April--June 1991, pp. 3--15.
;; http://home.pipeline.com/~hbaker1/Prag-Parse.html
;;
;; Roman Redziejowski does good PEG related research
;; http://www.romanredz.se/pubs.htm

;;;; Todo:

;; - Fix the exponential blowup in `peg-translate-exp'.
;; - Add a proper debug-spec for PEXs.

;;; News:

;; Since 1.0.1:
;; - Use OClosures to represent PEG rules when available, and let cl-print
;;   display their source code.
;; - New PEX form (with RULES PEX...).
;; - Named rulesets.
;; - You can pass arguments to rules.
;; - New `funcall' rule to call rules indirectly (e.g. a peg you received
;;   as argument).

;; Version 1.0:
;; - New official entry points `peg` and `peg-run`.

;;; Code:

(eval-when-compile (require 'cl-lib))

(defvar peg--actions nil
  "Actions collected along the current parse.
Used at runtime for backtracking.  It's a list ((POS . THUNK)...).
Each THUNK is executed at the corresponding POS.  Thunks are
executed in a postprocessing step, not during parsing.")

(defvar peg--errors nil
  "Data keeping track of the rightmost parse failure location.
It's a pair (POSITION . EXPS ...).  POSITION is the buffer position and
EXPS is a list of rules/expressions that failed.")

;;;; Main entry points

(defmacro peg--when-fboundp (f &rest body)
  (declare (indent 1) (debug (sexp body)))
  (when (fboundp f)
    (macroexp-progn body)))

(peg--when-fboundp oclosure-define
  (oclosure-define peg-function
    "Parsing function built from PEG rule."
    pexs)

  (cl-defmethod cl-print-object ((peg peg-function) stream)
    (princ "#f<peg " stream)
    (let ((args (help-function-arglist peg 'preserve-names)))
      (if args
          (prin1 args stream)
        (princ "()" stream)))
    (princ " " stream)
    (prin1 (peg-function--pexs peg) stream)
    (princ ">" stream)))

(defmacro peg--lambda (pexs args &rest body)
  (declare (indent 2)
           (debug (&define form lambda-list def-body)))
  (if (fboundp 'oclosure-lambda)
      `(oclosure-lambda (peg-function (pexs ,pexs)) ,args . ,body)
    `(lambda ,args . ,body)))

;; Sometimes (with-peg-rules ... (peg-run (peg ...))) is too
;; longwinded for the task at hand, so `peg-parse' comes in handy.
(defmacro peg-parse (&rest pexs)
  "Match PEXS at point.
PEXS is a sequence of PEG expressions, implicitly combined with `and'.
Returns STACK if the match succeed and signals an error on failure,
moving point along the way.
PEXS can also be a list of PEG rules, in which case the first rule is used."
  (if (and (consp (car pexs))
           (symbolp (caar pexs))
           (not (ignore-errors (peg-normalize (car pexs)))))
      ;; `pexs' is a list of rules: use the first rule as entry point.
      `(with-peg-rules ,pexs (peg-run (peg ,(caar pexs)) #'peg-signal-failure))
    `(peg-run (peg ,@pexs) #'peg-signal-failure)))

(defmacro peg (&rest pexs)
  "Return a PEG-matcher that matches PEXS."
  (pcase (peg-normalize `(and . ,pexs))
    (`(call ,name) `#',(peg--rule-id name)) ;Optimize this case by η-reduction!
    (exp `(peg--lambda ',pexs () ,(peg-translate-exp exp)))))

;; There are several "infos we want to return" when parsing a given PEX:
;; 1- We want to return the success/failure of the parse.
;; 2- We want to return the data of the successful parse (the stack).
;; 3- We want to return the diagnostic of the failures.
;; 4- We want to perform the actions (upon parse success)!
;; `peg-parse' used an error signal to encode the (1) boolean, which
;; lets it return all the info conveniently but the error signal was sometimes
;; inconvenient.  Other times one wants to just know (1) maybe without even
;; performing (4).
;; `peg-run' lets you choose all that, and by default gives you
;; (1) as a simple boolean, while also doing (2), and (4).

(defun peg-run (peg-matcher &optional failure-function success-function)
  "Parse with PEG-MATCHER at point and run the success/failure function.
If a match was found, move to the end of the match and call SUCCESS-FUNCTION
with one argument: a function which will perform all the actions collected
during the parse and then return the resulting stack (or t if empty).
If no match was found, move to the (rightmost) point of parse failure and call
FAILURE-FUNCTION with one argument, which is a list of PEG expressions that
failed at this point.
SUCCESS-FUNCTION defaults to `funcall' and FAILURE-FUNCTION
defaults to `ignore'."
  (let ((peg--actions '()) (peg--errors '(-1)))
    (if (funcall peg-matcher)
        ;; Found a parse: run the actions collected along the way.
        (funcall (or success-function #'funcall)
                 (lambda ()
                   (save-excursion (peg-postprocess peg--actions))))
      (goto-char (car peg--errors))
      (when failure-function
        (funcall failure-function (peg-merge-errors (cdr peg--errors)))))))

(defmacro define-peg-rule (name args &rest pexs)
  "Define PEG rule NAME as equivalent to PEXS.
The PEG expressions in PEXS are implicitly combined with the
sequencing `and' operator of PEG grammars."
  (declare (indent 1))
  (let ((inline nil))
    (while (keywordp (car pexs))
      (pcase (pop pexs)
        (:inline (setq inline (car pexs))))
      (setq pexs (cdr pexs)))
    (let ((id (peg--rule-id name))
          (exp (peg-normalize `(and . ,pexs))))
      `(progn
         (defalias ',id
           (peg--lambda ',pexs ,args
             ,(if inline
                  ;; Short-circuit to peg--translate in order to skip
                  ;; the extra failure-recording of `peg-translate-exp'.
                  ;; It also skips the cycle detection of
                  ;; `peg--translate-rule-body', which is not the main
                  ;; purpose but we can live with it.
                  (apply #'peg--translate exp)
                (peg--translate-rule-body name exp))))
         (eval-and-compile
           ;; FIXME: We shouldn't need this any more since the info is now
           ;; stored in the function, but sadly we need to find a name's EXP
           ;; during compilation (i.e. before the `defalias' is executed)
           ;; as part of cycle-detection!
           (put ',id 'peg--rule-definition ',exp)
           ,@(when inline
               ;; FIXME: Copied from `defsubst'.
               `(;; Never native-compile defsubsts as we need the byte
                 ;; definition in `byte-compile-unfold-bcf' to perform the
                 ;; inlining (Bug#42664, Bug#43280, Bug#44209).
                 ,(byte-run--set-speed id nil -1)
                 (put ',id 'byte-optimizer #'byte-compile-inline-expand))))))))

(defmacro define-peg-ruleset (name &rest rules)
  "Define a set of PEG rules for later use, e.g., in `with-peg-rules'."
  (declare (indent 1))
  (let ((defs ())
        (aliases ()))
    (dolist (rule rules)
      (let* ((rname (car rule))
             (full-rname (format "%s %s" name rname)))
        (push `(define-peg-rule ,full-rname . ,(cdr rule)) defs)
        (push `(,(peg--rule-id rname) #',(peg--rule-id full-rname)) aliases)))
    `(cl-flet ,aliases
       ,@defs
       (eval-and-compile (put ',name 'peg--rules ',aliases)))))

(defmacro with-peg-rules (rules &rest body)
  "Make PEG rules RULES available within the scope of BODY.
RULES is a list of rules of the form (NAME . PEXS), where PEXS is a sequence
of PEG expressions, implicitly combined with `and'.
RULES can also contain symbols in which case these must name
rulesets defined previously with `define-peg-ruleset'."
  (declare (indent 1) (debug (sexp form))) ;FIXME: `sexp' is not good enough!
  (let* ((rulesets nil)
         (rules
          ;; First, macroexpand the rules.
          (delq nil
                (mapcar (lambda (rule)
                          (if (symbolp rule)
                              (progn (push rule rulesets) nil)
                            (cons (car rule) (peg-normalize `(and . ,(cdr rule))))))
                        rules)))
        (ctx (assq :peg-rules macroexpand-all-environment)))
    (macroexpand-all
     `(cl-labels
          ,(mapcar (lambda (rule)
		     ;; FIXME: Use `peg--lambda' as well.
		     `(,(peg--rule-id (car rule))
		       ()
		       ,(peg--translate-rule-body (car rule) (cdr rule))))
		   rules)
        ,@body)
     `((:peg-rules ,@(append rules (cdr ctx)))
       ,@macroexpand-all-environment))))

;;;;; Old entry points

(defmacro peg-parse-exp (exp)
  "Match the parsing expression EXP at point."
  (declare (obsolete peg-parse "peg-0.9"))
  `(peg-run (peg ,exp)))

;;;; The actual implementation

(defun peg--lookup-rule (name)
  (or (cdr (assq name (cdr (assq :peg-rules macroexpand-all-environment))))
      ;; With `peg-function' objects, we can recover the PEG from which it was
      ;; defined, but this info is not yet available at compile-time.  :-(
      ;;(let ((id (peg--rule-id name)))
      ;;  (peg-function--pexs (symbol-function id)))
      (get (peg--rule-id name) 'peg--rule-definition)))

(defun peg--rule-id (name)
  (intern (format "peg-rule %s" name)))

(define-error 'peg-search-failed "Parse error at %d (expecting %S)")

(defun peg-signal-failure (failures)
  (signal 'peg-search-failed (list (point) failures)))

(defun peg-parse-at-point (peg-matcher)
  "Parse text at point according to the PEG rule PEG-MATCHER."
  (declare (obsolete peg-run "peg-1.0"))
  (peg-run peg-matcher
           #'peg-signal-failure
           (lambda (f) (let ((r (funcall f))) (if (listp r) r)))))

;; Internally we use a regularized syntax, e.g. we only have binary OR
;; nodes.  Regularized nodes are lists of the form (OP ARGS...).
(cl-defgeneric peg-normalize (exp)
  "Return a \"normalized\" form of EXP."
  (error "Invalid parsing expression: %S" exp))

(cl-defmethod peg-normalize ((exp string))
  (let ((len (length exp)))
    (cond ((zerop len) '(guard t))
	  ((= len 1) `(char ,(aref exp 0)))
	  (t `(str ,exp)))))

(cl-defmethod peg-normalize ((exp symbol))
  ;; (peg--lookup-rule exp)
  `(call ,exp))

(cl-defmethod peg-normalize ((exp vector))
  (peg-normalize `(set . ,(append exp '()))))

(cl-defmethod peg-normalize ((exp cons))
  (apply #'peg--macroexpand exp))

(defconst peg-leaf-types '(any call action char range str set
			   guard syntax-class = funcall))

(cl-defgeneric peg--macroexpand (head &rest args)
  (cond
   ((memq head peg-leaf-types) (cons head args))
   (t `(call ,head ,@args))))

(cl-defmethod peg--macroexpand ((_ (eql or)) &rest args)
  (cond ((null args) '(guard nil))
	((null (cdr args)) (peg-normalize (car args)))
	(t `(or ,(peg-normalize (car args))
		,(peg-normalize `(or . ,(cdr args)))))))

(cl-defmethod peg--macroexpand ((_ (eql and)) &rest args)
  (cond ((null args) '(guard t))
	((null (cdr args)) (peg-normalize (car args)))
	(t `(and ,(peg-normalize (car args))
		 ,(peg-normalize `(and . ,(cdr args)))))))

(cl-defmethod peg--macroexpand ((_ (eql *)) &rest args)
  `(* ,(peg-normalize `(and . ,args))))

;; FIXME: this duplicates code; could use some loop to avoid that
(cl-defmethod peg--macroexpand ((_ (eql +)) &rest args)
  (let ((e (peg-normalize `(and . ,args))))
    `(and ,e (* ,e))))

(cl-defmethod peg--macroexpand ((_ (eql opt)) &rest args)
  (let ((e (peg-normalize `(and . ,args))))
    `(or ,e (guard t))))

(cl-defmethod peg--macroexpand ((_ (eql if)) &rest args)
  `(if ,(peg-normalize `(and . ,args))))

(cl-defmethod peg--macroexpand ((_ (eql not)) &rest args)
  `(not ,(peg-normalize `(and . ,args))))

(cl-defmethod peg--macroexpand ((_ (eql \`)) form)
  (peg-normalize `(stack-action ,form)))

(cl-defmethod peg--macroexpand ((_ (eql stack-action)) form)
  (unless (member '-- form)
    (error "Malformed stack action: %S" form))
  (let ((args (cdr (member '-- (reverse form))))
	(values (cdr (member '-- form))))
    (let ((form `(let ,(mapcar (lambda (var) `(,var (pop peg--stack))) args)
		   ,@(mapcar (lambda (val) `(push ,val peg--stack)) values))))
      `(action ,form))))

(defvar peg-char-classes
  '(ascii alnum alpha blank cntrl digit graph lower multibyte nonascii print
	  punct space unibyte upper word xdigit))

(cl-defmethod peg--macroexpand ((_ (eql set)) &rest specs)
  (cond ((null specs) '(guard nil))
	((and (null (cdr specs))
	      (let ((range (peg-range-designator (car specs))))
		(and range `(range ,(car range) ,(cdr range))))))
	(t
	 (let ((chars '()) (ranges '()) (classes '()))
	   (while specs
	     (let* ((spec (pop specs))
		    (range (peg-range-designator spec)))
	       (cond (range
		      (push range ranges))
		     ((peg-characterp spec)
		      (push spec chars))
		     ((stringp spec)
		      (setq chars (append (reverse (append spec ())) chars)))
		     ((memq spec peg-char-classes)
		      (push spec classes))
		     (t (error "Invalid set specifier: %S" spec)))))
	   (setq ranges (reverse ranges))
	   (setq chars (delete-dups (reverse chars)))
	   (setq classes (reverse classes))
	   (cond ((and (null ranges)
		       (null classes)
		       (cond ((null chars) '(guard nil))
			     ((null (cdr chars)) `(char ,(car chars))))))
		 (t `(set ,ranges ,chars ,classes)))))))

(defun peg-range-designator (x)
  (and (symbolp x)
       (let ((str (symbol-name x)))
	 (and (= (length str) 3)
	      (eq (aref str 1) ?-)
	      (< (aref str 0) (aref str 2))
	      (cons (aref str 0) (aref str 2))))))

;; characterp is new in Emacs 23.
(defun peg-characterp (x)
  (if (fboundp 'characterp)
      (characterp x)
    (integerp x)))

(cl-defmethod peg--macroexpand ((_ (eql list)) &rest args)
  (peg-normalize
   (let ((marker (make-symbol "magic-marker")))
     `(and (stack-action (-- ',marker))
	   ,@args
	   (stack-action (--
			  (let ((l '()))
			    (while
				(let ((e (pop peg--stack)))
				  (cond ((eq e ',marker) nil)
					((null peg--stack)
					 (error "No marker on stack"))
					(t (push e l) t))))
			    l)))))))

(cl-defmethod peg--macroexpand ((_ (eql substring)) &rest args)
  (peg-normalize
   `(and `(-- (point))
	 ,@args
	 `(start -- (buffer-substring-no-properties start (point))))))

(cl-defmethod peg--macroexpand ((_ (eql region)) &rest args)
  (peg-normalize
   `(and `(-- (point))
	 ,@args
	 `(-- (point)))))

(cl-defmethod peg--macroexpand ((_ (eql replace)) pe replacement)
  (peg-normalize
   `(and (stack-action (-- (point)))
	 ,pe
	 (stack-action (start -- (progn
				   (delete-region start (point))
				   (insert-before-markers ,replacement))))
	 (stack-action (_ --)))))

(cl-defmethod peg--macroexpand ((_ (eql quote)) _form)
  (error "quote is reserved for future use"))

(cl-defgeneric peg--translate (head &rest args)
  (error "No translator for: %S" (cons head args)))

(defun peg--translate-rule-body (name exp)
  (let ((msg (condition-case err
                 (progn (peg-detect-cycles exp (list name)) nil)
               (error (error-message-string err))))
        (code (peg-translate-exp exp)))
    (cond
     ((null msg) code)
     ((fboundp 'macroexp--warn-and-return)
      (macroexp--warn-and-return msg code))
     (t
      (message "%s" msg)
      code))))

;; This is the main translation function.
(defun peg-translate-exp (exp)
  "Return the ELisp code to match the PE EXP."
  ;; FIXME: This expansion basically duplicates `exp' in the output, which is
  ;; a serious problem because it's done recursively, so it makes the output
  ;; code's size exponentially larger than the input!
  `(or ,(apply #'peg--translate exp)
       (peg--record-failure ',exp))) ; for error reporting

(define-obsolete-function-alias 'peg-record-failure
  #'peg--record-failure "peg-1.0")
(defun peg--record-failure (exp)
  (cond ((= (point) (car peg--errors))
	 (setcdr peg--errors (cons exp (cdr peg--errors))))
	((> (point) (car peg--errors))
	 (setq peg--errors (list (point) exp))))
  nil)

(cl-defmethod peg--translate ((_ (eql and)) e1 e2)
  `(and ,(peg-translate-exp e1)
	,(peg-translate-exp e2)))

;; Choicepoints are used for backtracking.  At a choicepoint we save
;; enough state, so that we can continue from there if needed.
(defun peg--choicepoint-moved-p (choicepoint)
  `(/= ,(car choicepoint) (point)))

(defun peg--choicepoint-restore (choicepoint)
  `(progn
     (goto-char ,(car choicepoint))
     (setq peg--actions ,(cdr choicepoint))))

(defmacro peg--with-choicepoint (var &rest body)
  (declare (indent 1) (debug (symbolp form)))
  `(let ((,var (cons (make-symbol "point") (make-symbol "actions"))))
     `(let ((,(car ,var) (point))
	    (,(cdr ,var) peg--actions))
        ,@(list ,@body))))

(cl-defmethod peg--translate ((_ (eql or)) e1 e2)
  (peg--with-choicepoint cp
    `(or ,(peg-translate-exp e1)
	 (,@(peg--choicepoint-restore cp)
	  ,(peg-translate-exp e2)))))

(cl-defmethod peg--translate ((_ (eql with)) rules &rest exps)
  `(with-peg-rules ,rules ,(peg--translate `(and . ,exps))))

(cl-defmethod peg--translate ((_ (eql guard)) exp) exp)

(defvar peg-syntax-classes
  '((whitespace ?-) (word ?w) (symbol ?s) (punctuation ?.)
    (open ?\() (close ?\)) (string ?\") (escape ?\\) (charquote ?/)
    (math ?$) (prefix ?') (comment ?<) (endcomment ?>)
    (comment-fence ?!) (string-fence ?|)))

(cl-defmethod peg--translate ((_ (eql syntax-class)) class)
  (let ((probe (assoc class peg-syntax-classes)))
    (cond (probe `(when (looking-at ,(format "\\s%c" (cadr probe)))
                    (forward-char)
                    t))
	  (t (error "Invalid syntax class: %S\nMust be one of: %s" class
		    (mapcar #'car peg-syntax-classes))))))

(cl-defmethod peg--translate ((_ (eql =)) string)
  `(let ((str ,string))
     (when (zerop (length str))
       (error "Empty strings not allowed for ="))
     (search-forward str (+ (point) (length str)) t)))

(cl-defmethod peg--translate ((_ (eql *)) e)
  `(progn (while ,(peg--with-choicepoint cp
		    `(if ,(peg-translate-exp e)
                         ;; Just as regexps do for the `*' operator,
                         ;; we allow the body of `*' loops to match
                         ;; the empty string, but we don't repeat the loop if
                         ;; we haven't moved, to avoid inf-loops.
                         ,(peg--choicepoint-moved-p cp)
                       ,(peg--choicepoint-restore cp)
		       nil)))
	  t))

(cl-defmethod peg--translate ((_ (eql if)) e)
  (peg--with-choicepoint cp
    `(when ,(peg-translate-exp e)
       ,(peg--choicepoint-restore cp)
       t)))

(cl-defmethod peg--translate ((_ (eql not)) e)
  (peg--with-choicepoint cp
    `(unless ,(peg-translate-exp e)
       ,(peg--choicepoint-restore cp)
       t)))

(cl-defmethod peg--translate ((_ (eql any)) )
  '(when (not (eobp))
     (forward-char)
     t))

(cl-defmethod peg--translate ((_ (eql char)) c)
  `(when (eq (char-after) ',c)
     (forward-char)
     t))

(cl-defmethod peg--translate ((_ (eql set)) ranges chars classes)
  `(when (looking-at ',(peg-make-charset-regexp ranges chars classes))
     (forward-char)
     t))

(defun peg-make-charset-regexp (ranges chars classes)
  (when (and (not ranges) (not classes) (<= (length chars) 1))
    (error "Bug"))
  (let ((rbracket (member ?\] chars))
	(minus (member ?- chars))
	(hat (member ?^ chars)))
    (dolist (c '(?\] ?- ?^))
      (setq chars (remove c chars)))
    (format "[%s%s%s%s%s%s]"
	    (if rbracket "]" "")
	    (if minus "-" "")
	    (mapconcat (lambda (x) (format "%c-%c" (car x) (cdr x))) ranges "")
	    (mapconcat (lambda (c) (format "[:%s:]" c)) classes "")
	    (mapconcat (lambda (c) (format "%c" c)) chars "")
	    (if hat "^" ""))))

(cl-defmethod peg--translate ((_ (eql range)) from to)
  `(when (and (char-after)
	      (<= ',from (char-after))
	      (<= (char-after) ',to))
     (forward-char)
     t))

(cl-defmethod peg--translate ((_ (eql str)) str)
  `(when (looking-at ',(regexp-quote str))
     (goto-char (match-end 0))
     t))

(cl-defmethod peg--translate ((_ (eql call)) name &rest args)
  `(,(peg--rule-id name) ,@args))

(cl-defmethod peg--translate ((_ (eql funcall)) exp &rest args)
  `(funcall ,exp ,@args))

(cl-defmethod peg--translate ((_ (eql action)) form)
  `(progn
     (push (cons (point) (lambda () ,form)) peg--actions)
     t))

(defvar peg--stack nil)
(defun peg-postprocess (actions)
  "Execute \"actions\"."
  (let  ((peg--stack '())
         (forw-actions ()))
    (pcase-dolist (`(,pos . ,thunk) actions)
      (push (cons (copy-marker pos) thunk) forw-actions))
    (pcase-dolist (`(,pos . ,thunk) forw-actions)
      (goto-char pos)
      (funcall thunk))
    (or peg--stack t)))

;; Left recursion is presumably a common mistake when using PEGs.
;; Here we try to detect such mistakes.  Essentially we traverse the
;; graph as long as we can without consuming input.  When we find a
;; recursive call we signal an error.

(defun peg-detect-cycles (exp path)
  "Signal an error on a cycle.
Otherwise traverse EXP recursively and return T if EXP can match
without consuming input.  Return nil if EXP definitely consumes
input.  PATH is the list of rules that we have visited so far."
  (apply #'peg--detect-cycles path exp))

(cl-defgeneric peg--detect-cycles (head _path &rest args)
  (error "No detect-cycle method for: %S" (cons head args)))

(cl-defmethod peg--detect-cycles (path (_ (eql call)) name)
  (if (member name path)
      (error "Possible left recursion: %s"
	     (mapconcat (lambda (x) (format "%s" x))
			(reverse (cons name path)) " -> "))
    (let ((exp (peg--lookup-rule name)))
      (if (null exp)
          ;; If there's no rule by that name, either we'll fail at
          ;; run-time or it will be defined later.  In any case, at this
          ;; point there's no evidence of a cycle, and if a cycle appears
          ;; later we'll hopefully catch it when the rule gets defined.
          ;; FIXME: In practice, if `name' is part of the cycle, we will
          ;; indeed detect it when it gets defined, but OTOH if `name'
          ;; is not part of a cycle but it *enables* a cycle because
          ;; it matches the empty string (i.e. we should have returned t
          ;; here), then we may not catch the problem at all :-(
          nil
	(peg-detect-cycles exp (cons name path))))))

(cl-defmethod peg--detect-cycles (path (_ (eql and)) e1 e2)
  (and (peg-detect-cycles e1 path)
       (peg-detect-cycles e2 path)))

(cl-defmethod peg--detect-cycles (path (_ (eql or)) e1 e2)
  (or (peg-detect-cycles e1 path)
      (peg-detect-cycles e2 path)))

(cl-defmethod peg--detect-cycles (path (_ (eql *)) e)
  (peg-detect-cycles e path)
  t)

(cl-defmethod peg--detect-cycles (path (_ (eql if)) e)
  (peg-unary-nullable e path))
(cl-defmethod peg--detect-cycles (path (_ (eql not)) e)
  (peg-unary-nullable e path))

(defun peg-unary-nullable (exp path)
  (peg-detect-cycles exp path)
  t)

(cl-defmethod peg--detect-cycles (_path (_ (eql any)))           nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql char)) _c)       nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql set)) _r _c _k)  nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql range)) _c1 _c2) nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql str)) s)         (equal s ""))
(cl-defmethod peg--detect-cycles (_path (_ (eql guard)) _e)      t)
(cl-defmethod peg--detect-cycles (_path (_ (eql =)) _s)          nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql syntax-class)) _n) nil)
(cl-defmethod peg--detect-cycles (_path (_ (eql action)) _form)  t)

(defun peg-merge-errors (exps)
  "Build a more readable error message out of failed expression."
  (let ((merged '()))
    (dolist (exp exps)
      (setq merged (peg-merge-error exp merged)))
    merged))

(defun peg-merge-error (exp merged)
  (apply #'peg--merge-error merged exp))

(cl-defgeneric peg--merge-error (_merged head &rest args)
  (error "No merge-error method for: %S" (cons head args)))

(cl-defmethod peg--merge-error (merged (_ (eql or)) e1 e2)
  (peg-merge-error e2 (peg-merge-error e1 merged)))

(cl-defmethod peg--merge-error (merged (_ (eql and)) e1 _e2)
  ;; FIXME: Why is `e2' not used?
  (peg-merge-error e1 merged))

(cl-defmethod peg--merge-error (merged (_ (eql str)) str)
  ;;(add-to-list 'merged str)
  (cl-adjoin str merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql call)) rule)
  ;; (add-to-list 'merged rule)
  (cl-adjoin rule merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql char)) char)
  ;; (add-to-list 'merged (string char))
  (cl-adjoin (string char) merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql set)) r c k)
  ;; (add-to-list 'merged (peg-make-charset-regexp r c k))
  (cl-adjoin (peg-make-charset-regexp r c k) merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql range)) from to)
  ;; (add-to-list 'merged (format "[%c-%c]" from to))
  (cl-adjoin (format "[%c-%c]" from to) merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql *)) exp)
  (peg-merge-error exp merged))

(cl-defmethod peg--merge-error (merged (_ (eql any)))
  ;; (add-to-list 'merged '(any))
  (cl-adjoin '(any) merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql not)) x)
  ;; (add-to-list 'merged `(not ,x))
  (cl-adjoin `(not ,x) merged :test #'equal))

(cl-defmethod peg--merge-error (merged (_ (eql action)) _action) merged)
(cl-defmethod peg--merge-error (merged (_ (eql null))) merged)

(provide 'peg)
(require 'peg)

(define-peg-rule null () :inline t (guard t))
(define-peg-rule fail () :inline t (guard nil))
(define-peg-rule bob  () :inline t (guard (bobp)))
(define-peg-rule eob  () :inline t (guard (eobp)))
(define-peg-rule bol  () :inline t (guard (bolp)))
(define-peg-rule eol  () :inline t (guard (eolp)))
(define-peg-rule bow  () :inline t (guard (looking-at "\\<")))
(define-peg-rule eow  () :inline t (guard (looking-at "\\>")))
(define-peg-rule bos  () :inline t (guard (looking-at "\\_<")))
(define-peg-rule eos  () :inline t (guard (looking-at "\\_>")))

;;; peg.el ends here