(in-package #:monparser)

(defparameter nothing
  (new nil))

(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))))
  `(lambda (start input)
     (declare (ignore start))
     (if (has-data? input)
       (let ((it (peek input)))
         (if ,predicate
           (make-parsing :tree it
                         :start input
                         :end (advance input))
           (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)))))

(defun one-of (first-parser second-parser &rest other-parsers)
  (lambda (start input)
    (declare (ignore start))
    (let ((parsers (cons first-parser (cons second-parser other-parsers)))
          (result (make-failure :place input)))
      (dolist (p parsers)
        (let ((r (funcall p input input)))
          (cond ((parsing-p r)
                 (when (or (not (parsing-p result))
                           (> (distance (parsing-end result)
                                               (parsing-end 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)))

(defun optional (p)
  (one-of p nothing))

(defun many (p &key all)
  (lambda (start input)
    (declare (ignore start))
    (let* ((result '()))
      (do ((r (funcall p input input)
              (funcall p (parsing-end r) (parsing-end r))))
        ((or (failure-p r)
             (= (index (parsing-start r))
                (index (parsing-end r))))
         nil)
        (push r result))
      (cond ((not result)
             (make-failure :place input
                           :message "No matches."))
            ((and all (has-data? (parsing-end (first result))))
             (make-failure :place (parsing-end (first result))
                           :message "Input not exausted."))
            (t (make-parsing :tree (reverse (mapcar (lambda (x) (parsing-tree x)) result))
                             :start input
                             :end (parsing-end (first result))))))))