(in-package #:parser)

(defun run (p input)
  (let ((r (funcall p input)))
    (if (parsing-p r)
      (parsing-tree r)
      (input::generate-report (failure-place r) (failure-message r)))))

(defstruct parsing
  tree
  left)

(defstruct failure
  place
  message)

(defstruct (normal-failure (:include failure)))

(defstruct (critical-failure (:include failure)))

(defun new (tree)
  (lambda (input)
    (make-parsing :tree tree :left input)))

(defun bind (p f)
  (lambda (input)
    (let ((r (funcall p input)))
      (if (parsing-p r)
        (funcall (funcall f (parsing-tree r)) (parsing-left r))
        r))))

(defun discarding-bind (p q)
  (lambda (input)
    (let ((r (funcall p input)))
      (if (parsing-p r)
        (funcall q (parsing-left r))
        r))))

(defun fail (&optional (message "Unknown error."))
  (lambda (input)
    (make-critical-failure :place input :message message)))

(defun either (first-parser second-parser &rest other-parsers)
  (lambda (input)
    (labels ((either-rec (body)
                         (if (cdr body)
                           (let ((r (funcall (car body) input)))
                             (if (normal-failure-p r)
                               (either-rec (cdr body))
                               r))
                           (funcall (car body) input))))
      (either-rec (cons first-parser (cons second-parser other-parsers))))))

(defun unit (predicate)
  (lambda (input)
    (if (input::has-data? input)
      (let ((c (input::peek-1 input)))
        (if (char= c predicate)
          (make-parsing :tree c :left (input::advance input))
          (make-normal-failure :place input :message "Predicate not satisfied.")))
      (make-normal-failure :place input :message "Reached end of input."))))

(defun not-unit (predicate)
  (lambda (input)
    (if (input::has-data? input)
      (let ((c (input::peek-1 input)))
        (if (char/= c predicate)
          (make-parsing :tree c :left (input::advance input))
          (make-normal-failure :place input :message "Predicate not satisfied.")))
      (make-normal-failure :place input :message "Reached end of input."))))

(defun unit-if (&optional (predicate #'characterp))
  (lambda (input)
    (if (input::has-data? input)
      (let ((c (input::peek-1 input)))
        (if (funcall predicate c)
          (make-parsing :tree c :left (input::advance input))
          (make-normal-failure :place input :message "Predicate not satisfied.")))
      (make-normal-failure :place input :message "Reached end of input."))))

(defun literal (predicate)
  (lambda (input)
    (if (input::has-data? input (length predicate))
      (let ((c (input::peek-n input (length predicate))))
        (if (string= predicate c)
          (make-parsing :tree c :left (input::advance input (length c)))
          (make-normal-failure :place input :message "Predicate not satisfied.")))
      (make-normal-failure :place input :message "Reached end of input."))))

(defun until-literal (predicate)
  (lambda (input)
    (let ((c (search predicate (input::input-data input) :start2 (input::input-cursor input))))
      (if c
        (let ((window (- c (input::input-cursor input))))
          (if (> window 0)
            (make-parsing :tree (input::peek-n input window) :left (input::advance input window))
            (make-failure :place input :message "Predicate not satisfied.")))
        (make-parsing :tree (input::peek-rest input) :left (input::advance-to-end input))))))

(defmacro comp (bindings &body body)
  (if (null bindings)
    `(new (progn ,@body))
    (let ((v (first (car bindings)))
          (p (second (car bindings))))
      (if (eq v '_)
        `(discarding-bind ,p (comp ,(cdr bindings) ,@body))
        `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body)))))))

(defparameter nothing
  (new nil))

(defun optional (p)
  (either p nothing))

(defun many (p)
  (comp ((x p)
         (xs (optional (many p))))
    (cons x xs)))

(defun separated-list (p separator &key (include-separator nil))
  (comp ((v p)
         (sep (optional separator))
         (vn (if sep
               (either (separated-list p separator)
                       (fail "Value expected."))
               nothing)))
    (if include-separator
      (cons v (cons sep vn))
      (cons v vn))))