(in-package #:parser)

(defstruct parsing
  tree
  left)

(defmethod print-object ((obj parsing) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "~a" (parsing-tree obj))))

(defstruct failure
  place
  message)

(defmethod print-object ((obj failure) stream)
  (print-unreadable-object (obj stream :type t)
    (let ((file (input:file (failure-place obj))))
      (if file
        (multiple-value-bind (line column) (input:line-and-column (failure-place obj))
          (format stream "~a:~a:~a: ~a" line column file (failure-message obj)))
        (format stream "~a: ~a" (input:cursor (failure-place obj)) (failure-message obj))))))

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

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

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

(defun bind-with-input (p f)
  (declare (optimize (speed 3)))
  (declare (type function p f))
  (lambda (input)
    (let ((r (funcall p input)))
      (if (parsing-p r)
        (funcall (the function (funcall f (parsing-tree r) input))
                 (parsing-left r))
        r))))

(defun bind (p f)
  (declare (optimize (speed 3)))
  (declare (type function p f))
  (lambda (input)
    (let ((r (funcall p input)))
      (if (parsing-p r)
        (funcall (the function (funcall f (parsing-tree r)))
                 (parsing-left r))
        r))))

(defun discarding-bind (p f)
  (declare (optimize (speed 3)))
  (declare (type function p f))
  (lambda (input)
    (let ((r (funcall p input)))
      (if (parsing-p r)
        (funcall (the function (funcall f))
                 (parsing-left r))
        r))))

(defmacro comp (bindings &body body)
  (if (null bindings)
    `(new (progn ,@body))
    (let ((v (first (car bindings)))
          (p (second (car bindings))))
      (if (eq 'symbol (type-of v))
        (if (string= (symbol-name v) "_")
          `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body)))
          `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))
        (if (and (eq 'cons (type-of v))
                 (eq 'symbol (type-of (car v)))
                 (eq 'symbol (type-of (cdr v))))
          `(bind-with-input ,p (lambda (,(car v) ,(cdr v)) (comp ,(cdr bindings) ,@body)))
          (error "Binding name/(name,input) must be either a symbol or a cons of symbols."))))))

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

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

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

(defun negate (p)
  (lambda (input)
    (let ((r (funcall p input)))
      (cond ((parsing-p r)
             (make-normal-failure :place input :message "Negated parser result."))
            ((normal-failure-p r)
             (make-parsing :tree nil :left input))
            (t r)))))

(defun unit-if (&optional (predicate #'characterp))
  (lambda (input)
    (if (input:has-data? input)
      (let ((c (input:peek 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 unit (target)
  (unit-if (lambda (x) (char= x target))))

(defun not-unit (target)
  (unit-if (lambda (x) (char/= x target))))

(defun literal (target)
  (lambda (input)
    (if (input:has-data? input)
      (if (input:prefix? target input)
        (make-parsing :tree target :left (input:advance input (length target)))
        (make-normal-failure :place input :message "Predicate not satisfied."))
      (make-normal-failure :place input :message "Reached end of input."))))

(defun not-literal (target)
  (lambda (input)
    (if (input:has-data? input)
      (if (input:prefix? target input)
        (make-normal-failure :place input :message "Predicate not satisfied.")
        (make-parsing :tree (input:peek input) :left (input:advance input)))
      (make-normal-failure :place input :message "Reached end of input."))))

(defparameter nothing
  (new nil))

(defun optional (p)
  (one-of 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
               (one-of (separated-list p separator)
                       (fail "Value expected."))
               nothing)))
    (if include-separator
      (cons v (cons sep vn))
      (cons v vn))))