greedy.lisp

(in-package :parser-combinators)

;;; greedy version of repetition combinators

(defun seq-list* (&rest parsers)
  "Non-backtracking parser: Return a list of result of PARSERS."
  (assert parsers)
  (let ((parsers (map 'vector #'ensure-parser parsers)))
    (define-oneshot-result inp is-unread
      (iter (for parser in-vector parsers)
            (for inp-prime initially inp then (suffix-of result))
            (for result = (funcall (funcall parser inp-prime)))
            (while result)
            (collect result into results)
            (finally (return
                       (when result
                         (make-instance 'parser-possibility
                                        :tree (mapcar #'tree-of results)
                                        :suffix (suffix-of result)))))))))

(defmacro named-seq* (&rest parser-descriptions)
  "Non-backtracking parser: This is similar to MDO, except that constructed parsers cannot depend on
the results of previous ones and the final form is not used as a parser, but is automatically used
to construct the result. All names bound using the (<- name parser) construct are only available in
that final form.

This parser generator is useful when full generality of MDO is not necessary, as it is implemented
non-recursively and has better memory performance."
  `(%named-seq? seq-list* ,@parser-descriptions))

(defmacro mdo* (&body spec)
  "Like NAMED-SEQ*, but with MDO syntax: the last element must be a parser."
  (with-gensyms (ret)
    `(named-seq*
      ,@(butlast spec)
      (<- ,ret ,(lastcar spec))
      ,ret)))

(defun between* (parser min max &optional (result-type 'list))
  "Non-backtracking parser: find the first, longest chain of expression accepted by parser of length between min and max"
  (assert (or (null min)
              (null max)
              (>= max min)))
  ;; min=zero or nil means accept zero width results
  (assert (or (null min)
              (zerop min)
              (plusp min)))
  ;; can't have 0-0 parser
  (assert (or (null max)
              (plusp max)))
  (with-parsers (parser)
    (define-oneshot-result inp is-unread
      (iter (for count from 0)
            (for result next (funcall (funcall parser inp-prime)))
            (while (and result
                        (or (null max)
                            (< count max))))
            (for inp-prime initially inp then
                 (if (eql inp-prime (suffix-of result))
                     (error "Subparser in repetition parser didn't advance the input.")
                     (suffix-of result)))
            (collect result into results)
            (finally (return
                       (when (or (null min)
                                 (>= count min))
                         (make-instance 'parser-possibility
                                        :tree (map result-type #'tree-of results)
                                        :suffix inp-prime))))))))

(defun many* (parser)
  "Non-backtracking parser: collect as many of first result of parser as possible"
  (between* parser nil nil))

(defun many1* (parser)
  "Non-backtracking parser: accept as many as possible, and at least one, of parser"
  (between* parser 1 nil))

(defun atleast* (parser count)
  "Non-backtracking parser: accept as many as possible and at least count of parser"
  (between* parser count nil))

(defun atmost* (parser count)
  "Non-backtracking parser: accept as many as possible but at most count of parser"
  (between* parser nil count))

(defun sepby1* (parser-item parser-separator)
  "Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator, but at least one."
  (named-seq* (<- x parser-item)
              (<- xs (many* (named-seq* parser-separator
                                        (<- y parser-item)
                                        y)))
              (cons x xs)))

(defun sepby* (parser-item parser-separator)
  "Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator."
  (choice1 (sepby1* parser-item parser-separator)
           (result nil)))

(defun chainl1* (p op)
  "Non-backtracking parser: accept as many as possible, but at least one of p, reduced by result of op with left associativity"
  (with-parsers (p op)
    (labels ((rest-chain (init-x)
               (define-oneshot-result inp is-unread
                 (let ((final-result (iter (for f-result next (funcall (funcall op p-inp)))
                                           (while f-result)
                                           (for f-inp next (suffix-of f-result))
                                           (for p-result next (funcall (funcall p f-inp)))
                                           (while p-result)
                                           (for p-inp initially inp then (suffix-of p-result))
                                           (for f = (tree-of f-result))
                                           (for x initially init-x then tree)
                                           (for y = (tree-of p-result))
                                           (for tree next (funcall f x y))
                                           (finally (return (list tree p-inp))))))
                   (if (car final-result)
                       (make-instance 'parser-possibility
                                      :tree (car final-result)
                                      :suffix (cadr final-result))
                       (make-instance 'parser-possibility
                                      :tree init-x :suffix inp))))))
      (bind p #'rest-chain))))

(def-cached-arg-parser whitespace* (&key (result-type nil) (accept-empty nil))
  "Non-backtracking parser: accept a sequence of whitespace characters."
  (gather-if* (rcurry #'member '(#\Space #\Newline #\	))
              :result-type result-type
              :accept-empty accept-empty))

(def-cached-parser word*
  "Parser: accept a string of alphanumeric characters"
  (gather-if* #'alphanumericp :result-type 'string))

(def-cached-parser pure-word*
  "Parser: accept a string of alphabetic characters"
  (gather-if* #'alpha-char-p :result-type 'string))

(defun nat* (&optional (radix 10))
  "Non-backtracking parser: accept natural number, consuming as many digits as possible"
  (named-seq* (<- number (gather-if* (rcurry #'digit-char-p radix) :result-type 'string))
   (parse-integer number :radix radix)))

(defun int* (&optional (radix 10))
  "Non-backtracking parser: accept integer, consuming as many digits as possible"
  (named-seq* (<- sign (choices1 #\+ #\- (result #\+)))
              (<- n (nat* radix))
              (* (if (eql sign #\+) 1 -1) n)))

(defun chainr1* (p op)
  "Non-backtracking parser: accept as many as possible, but at least one of p, reduced by result of op with right associativity"
  (with-parsers (p op)
    (bind p
      #'(lambda (init-x)
          (define-oneshot-result inp is-unread
            (let ((final-result
                   (iter (for f-result next (funcall (funcall op p-inp)))
                         (while f-result)
                         (for f-inp next (suffix-of f-result))
                         (for p-result next (funcall (funcall p f-inp)))
                         (while p-result)
                         (for p-inp initially inp then (suffix-of p-result))
                         (for f = (tree-of f-result))
                         (for y = (tree-of p-result))
                         (collect f into function-list)
                         (collect y into y-list)
                         (finally (let ((rev-y-list (nreverse (cons init-x y-list))))
                                    (return (list (iter (for x in (cdr rev-y-list))
                                                        (for f in function-list)
                                                        (for tree next (if (first-iteration-p)
                                                                           (funcall f x (car rev-y-list))
                                                                           (funcall f x tree)))
                                                        (finally (return tree)))
                                                  p-inp)))))))
              (if (car final-result)
                  (make-instance 'parser-possibility
                                 :tree (car final-result)
                                 :suffix (cadr final-result))
                  (make-instance 'parser-possibility
                                 :tree init-x :suffix inp))))))))

(defun chainl* (p op v)
  "Non-backtracking parser: like chainl1*, but will return v if no p can be parsed"
  (choice1
   (chainl1* p op)
   (result v)))

(defun chainr* (p op v)
  "Non-backtracking parser: like chainr1*, but will return v if no p can be parsed"
  (choice1
   (chainr1* p op)
   (result v)))

(def-cached-arg-parser times* (parser count)
    "Non-backtracking parser: accept exactly count expressions accepted by parser, without backtracking."
    (between* parser count count))

(defun find-after* (p q)
  "Non-backtracking parser: Find first q after some sequence of p."
  (with-parsers (p q)
    (define-oneshot-result inp is-unread
      (iter (for p-result next (funcall (funcall p inp-prime)))
            (for q-result next (funcall (funcall q inp-prime)))
            (while (and p-result (null q-result)))
            (for inp-prime initially inp then (suffix-of p-result))
            (finally (return
                       (when q-result
                         (make-instance 'parser-possibility
                                        :tree (tree-of q-result)
                                        :suffix (suffix-of q-result)))))))))

(defgeneric gather-if-not*-using-context (input predicate accept-end accept-empty)
  (:documentation "Parser gather-if-not* specialized on context type")
  (:method ((input end-context) predicate accept-end accept-empty)
    (if (and accept-end accept-empty)
        (values nil input)
        (values nil nil)))
  (:method ((input context) predicate accept-end accept-empty)
    (iter (until (or (end-context-p inp-prime)
                     (funcall predicate (context-peek inp-prime))))
          (for inp-prime initially input then (context-next inp-prime))
          (collect (context-peek inp-prime) into results)
          (finally (return
                     (when (and results
                                (or (and accept-end (end-context-p inp-prime))
                                    (funcall predicate (context-peek inp-prime))))
                       (values results inp-prime))))))
  (:method ((input vector-context) predicate accept-end accept-empty)
    (let ((input-vector (storage-of input)))
      (check-type input-vector vector)
      (let ((end-position (position-if predicate input-vector :start (position-of input))))
        (cond ((and accept-end (null end-position))
               (values (subseq input-vector (position-of input))
                       (make-context-at-position input (length input-vector))))
              ((and end-position (or accept-empty (> end-position (position-of input))))
               (values (subseq input-vector (position-of input) end-position)
                       (make-context-at-position input end-position)))
              (t (values nil nil)))))))

(defun gather-if-not* (predicate &key (result-type 'list) (accept-end nil) (accept-empty nil))
  "Non-backtracking parser: Find a sequence of tokens terminated by one for which predicate returns true, which is not consumed."
  (define-oneshot-result inp is-unread
    (multiple-value-bind (result new-input) (gather-if-not*-using-context inp predicate accept-end accept-empty)
      (when new-input
        (make-instance 'parser-possibility
                       :tree (when result-type (coerce result result-type))
                       :suffix new-input)))))

(defun gather-if* (predicate &key (result-type 'list) (accept-end t) (accept-empty nil))
  "Non-backtracking parser: Find a sequence of tokens for which predicate returns true."
  (gather-if-not* (complement predicate)
                  :result-type result-type
                  :accept-end accept-end
                  :accept-empty accept-empty))

(defun gather-before-token* (token &key (result-type 'list) (test #'eql) (accept-end nil) (accept-empty nil))
  "Non-backtracking parser: Find a sequence of tokens terminated by single token, which is not consumed."
  (gather-if-not* #'(lambda (input-token)
                      (funcall test input-token token))
                  :result-type result-type
                  :accept-end accept-end
                  :accept-empty accept-empty))

(defun find-before-token* (p token &key (result-type 'list) (test #'eql))
  "Non-backtracking parser: Find a sequence of p terminated by single token q, which is not consumed."
  (with-parsers (p)
    (define-oneshot-result inp is-unread
      (iter (for p-result next (funcall (funcall p inp-prime)))
            (while (and p-result (not (funcall test (context-peek inp-prime) token))))
            (for inp-prime initially inp then (suffix-of p-result))
            (collect (tree-of p-result) into p-results)
            (finally (return
                       (when (funcall test (context-peek inp-prime) token)
                         (make-instance 'parser-possibility
                                        :tree (coerce p-results result-type)
                                        :suffix inp-prime))))))))


(defun find-before* (p q &optional (result-type 'list))
  "Non-backtracking parser: Find a sequence of p terminated by q, doesn't consume q."
  (with-parsers (p q)
    (define-oneshot-result inp is-unread
      (iter (for p-result next (funcall (funcall p inp-prime)))
            (for q-result next (funcall (funcall q inp-prime)))
            (while (and p-result (null q-result)))
            (for inp-prime initially inp then (suffix-of p-result))
            (collect (tree-of p-result) into p-results)
            (finally (return
                       (when q-result
                         (make-instance 'parser-possibility
                                        :tree (coerce p-results result-type)
                                        :suffix inp-prime))))))))

(defun find-after-collect* (p q &optional (result-type 'list))
  "Non-backtracking parser: Find first q after some sequence of p. Return cons of list of p-results and q"
  (with-parsers (p q)
    (define-oneshot-result inp is-unread
      (iter (for p-result next (funcall (funcall p inp-prime)))
            (for q-result next (funcall (funcall q inp-prime)))
            (while (and p-result (null q-result)))
            (collect p-result into p-results)
            (for inp-prime initially inp then (suffix-of p-result))
            (finally (return
                       (when q-result
                         (make-instance 'parser-possibility
                                        :tree (cons (map result-type #'tree-of p-results)
                                                    (tree-of q-result))
                                        :suffix (suffix-of q-result)))))))))

(defun before* (p q)
  "Non-backtracking parser: Find a p before q, doesn't consume q."
  (with-parsers (p q)
    (define-oneshot-result inp is-unread
      (let ((p-result (funcall (funcall p inp))))
        (when p-result
          (let* ((p-suffix (suffix-of p-result))
                 (q-result (funcall (funcall q p-suffix))))
            (when (and p-result q-result)
              (make-instance 'parser-possibility :tree (tree-of p-result) :suffix p-suffix))))))))

(defun find* (q)
  "Non-backtracking parser: Find first q"
  (find-after* (item) q))

(defun opt* (p)
  "Non-backtracking parser: result of p or nil"
  (choice1 p (result nil)))

(defun expression* (term operators &optional (bracket-left nil) (bracket-right nil))
  "Non-backtracking parser: Reduce a sequence of terms with unary/binary operators with precedence.
 OPERATORS is a list of (op-parser :left/:right/:unary), where OP-PARSER is a parser consuming
 an operator and returning a reduction function. Highest precedence first."
  (with-parsers (term bracket-left bracket-right)
    (named? expr-parser
      (iter (for (op assoc) in operators)
            (for base initially (choice1 (bracket? bracket-left expr-parser bracket-right)
                                         term)
                 then (ecase assoc
                        (:left (chainl1* base op))
                        (:right (chainr1* base op))
                        (:unary (choice1
                                 (named-seq* (<- op-fun op)
                                             (<- subexpr base)
                                             (funcall op-fun subexpr))
                                base))))
            (finally (return base))))))