(in-package #:monparser)

(defparameter nothing
  (new nil))

(declaim (ftype (function (symbol list) list) normalize))
(defun normalize (sym expression)
  (nsubst-if sym
             (lambda (x)
               (and (symbolp x)
                    (string-equal (symbol-name x)
                                  (symbol-name sym))))
             expression))

(defmacro unit (&optional predicate)
  (cond ((null predicate)
         (setf predicate 't))
        ((symbolp predicate)
         (setf predicate `(,predicate it)))
        ((characterp predicate)
         (setf predicate `(char-equal ,predicate it)))
        ((listp predicate)
         (if (eq (car predicate) 'function)
           (setf predicate `(funcall ,predicate it))
           (setf predicate
                 (normalize 'it predicate))))
        (t (error (format nil "Invalid predicate: ~a." predicate))))
  (let ((start (gensym))
        (input (gensym)))
    `(the parser
          (lambda (,input)
            (if (cursor-has-data? ,input)
              (let ((it (cursor-peek ,input)))
                (if ,predicate
                  (make-parsing :place (cursor-advance ,input)
                                :tree it)
                  (make-failure :place ,input
                                :message (format nil "Expected: ~a, Got: ~:c." ',predicate it))))
              (make-failure :place ,input
                            :message (format nil "Reached end of input. Expected: ~a." ',predicate)))))))

(declaim (ftype (function (parser parser &rest parser) parser) one-of))
(defun one-of (first-parser second-parser &rest other-parsers)
  (lambda (input)
    (let ((parsers (cons first-parser (cons second-parser other-parsers)))
          (result (make-failure :place input)))
      (dolist (p parsers)
        (let ((r (funcall p (cursor-rebase input))))
          (cond ((parsing-p r)
                 (when (or (not (parsing-p result))
                           (> (distance (result-place result)
                                        (result-place r))
                              0))
                   (setf result r)))
                ((failure-p r)
                 (when (failure-p result)
                   (let ((priority-cmp (- (failure-priority r)
                                          (failure-priority result))))
                     (when (or (> priority-cmp 0)
                               (and (= priority-cmp 0)
                                    (>= (distance (failure-place result)
                                                  (failure-place r))
                                        0)))
                       (setf result r)))))
                (t (error (format nil "Invalid return value: ~a." r))))))
      result)))

(declaim (ftype (function (parser) parser) optional))
(defun optional (p)
  (one-of p nothing))

(declaim (ftype (function (parser &key (:all t)) parser) many))
(defun many (p &key all)
  (lambda (input)
    (let* ((result '()))
      (do ((r (funcall p (cursor-rebase input))
              (funcall p (cursor-rebase (result-place r)))))
        ((or (failure-p r)
             (cursor-at-start? (result-place r)))
         nil)
        (push r result))
      (cond ((not result)
             (make-failure :place input
                           :message "No matches."))
            ((and all (cursor-has-data? (result-place (first result))))
             (make-failure :place (result-place (first result))
                           :message "Input not exausted."))
            (t (make-parsing :place (result-place (first result))
                             :tree (reverse (mapcar (lambda (x) (parsing-tree x)) result))))))))