(in-package #:monparser)

(defun parse-string (p input)
  (let ((result (funcall p (from-string input))))
    (if (parsing-p result)
      (parsing-tree result)
      result)))

(defun parse-file (p input)
  (let ((result (funcall p (from-file input))))
    (if (parsing-p result)
      (parsing-tree result)
      result)))

(defstruct parsing
  tree
  left
  limit)

(defun lazy-parsing-p (r)
  (or (functionp r)
      (parsing-p r)))

(defstruct failure
  place
  message)

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

(defun new (tree)
  (lambda (input &key limit lazy)
    (declare (ignore lazy))
    (if (and limit (> limit 0))
      (make-failure :place input
                    :message (format nil "Didn't reach expected limit: ~a." limit))
      (make-parsing :tree tree :left input))))

(defun bind (p f &key (greedy t))
  (lambda (input &key limit lazy)
    (let (r)
      (if greedy
        (setf r (funcall p input :limit limit))
        (let ((next-parser (funcall f nil input))
              (limit -1))
          (do ((sweep-input input (advance sweep-input)))
            ((or (not (has-data? sweep-input))
                 (> limit -1)) nil)
            (when (lazy-parsing-p (funcall next-parser sweep-input :lazy t))
              (setf limit (input-sub sweep-input input))))
          (if (< limit 0)
            (setf r (make-failure :place input
                                  :message "Reached end of input while sweeping."))
            (setf r (funcall p input :limit limit)))))
      (if (parsing-p r)
        (if lazy
          (lambda (ignored-input &key lazy limit)
            (declare (ignore ignored-input limit))
            (funcall (funcall f (parsing-tree r) input)
                     (parsing-left r)
                     :lazy lazy
                     :limit (if greedy (parsing-limit r))))
          (funcall (funcall f (parsing-tree r) input)
                   (parsing-left r)
                   :limit (if greedy (parsing-limit r))))
      r))))

(defmacro comp (bindings &body body)
  (if (null bindings)
    `(new (progn ,@body))
    (let ((var (first (car bindings)))
          (parser (second (car bindings)))
          (lazy (third (car bindings)))
          (unused (gensym)))
      (if (symbolp var)
        (if (string= (symbol-name var) "_")
          `(bind ,parser
                 (lambda (&rest ,unused)
                   (declare (ignore ,unused))
                   (comp ,(cdr bindings) ,@body))
                 :greedy ,(not lazy))
          `(bind ,parser
                 (lambda (,var &rest ,unused)
                   (declare (ignore ,unused))
                   (comp ,(cdr bindings) ,@body))
                 :greedy ,(not lazy)))
        (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
          `(bind ,parser
                 (lambda (,(car var) ,(cdr var) &rest ,unused)
                   (declare (ignore ,unused))
                   (comp ,(cdr bindings) ,@body))
                 :greedy ,(not lazy))
          (error "Binding must be either a symbol or a cons of symbols."))))))

(defun one-of (first-parser second-parser &rest other-parsers)
  (lambda (input &key limit lazy)
    (declare (ignore lazy))
    (labels ((one-of-rec (parsers)
                         (let ((intermediate-parsers '())
                               (result nil))
                           (dolist (p parsers)
                             (let ((r (funcall p
                                               input
                                               :lazy (> (length parsers) 1)
                                               :limit limit)))
                               (cond ((functionp r)
                                      (push r intermediate-parsers))
                                     ((parsing-p r)
                                      (when (or (not (parsing-p result))
                                                (> (cursor (parsing-input r))
                                                   (cursor (parsing-input result))))
                                        (setf result r)))
                                     ((failure-p r)
                                      (when (or (failure-p result)
                                                 (= (length parsers) 1))
                                        (setf result r))))))
                           (if intermediate-parsers
                             (one-of-rec intermediate-parsers)
                             result))))
      (one-of-rec (cons first-parser (cons second-parser other-parsers))))))

(defmacro unit (&optional predicate)
  (cond ((null predicate)
         (setf predicate '(characterp it)))
        ((symbolp predicate)
         (setf predicate `(,predicate it)))
        ((characterp predicate)
         (setf predicate `(char-equal ,predicate it)))
        (t (setf predicate
                 (nsubst-if 'it
                            (lambda (x)
                              (and (symbolp x)
                                   (string-equal (symbol-name x) "IT"))) predicate))))
  `(lambda (input &key limit lazy)
     (declare (ignore lazy))
     (format t "unit limit ~a~&" limit)
     (if (and limit (<= limit 0))
       (make-failure :place input :message "Reached established limit.")
       (if (has-data? input)
         (let ((it (peek input)))
           (if ,predicate
             (make-parsing :tree it :left (advance input) :limit (if limit (1- limit)))
             (make-failure :place input
                           :message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
         (make-failure :place input :message "Reached end of input.")))))

(defun literal (target)
  (lambda (input &key limit lazy)
    (declare (ignore lazy limit))
    (if (has-data? input)
      (if (prefix? target input)
        (make-parsing :tree target :left (advance input (length target)))
        (make-failure :place input :message "Predicate not satisfied."))
      (make-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 repeat (p min &optional (max 0))
  (if (> min 0)
    (comp ((x p)
           (xs (repeat p (1- min) (1- max))))
          (cons x xs))
    (if (> max 0)
      (comp ((x (optional p))
             (xs (repeat p 0 (if x (1- max) 0))))
            (if x (cons x xs) x))
      nothing)))

(defun whitespace? (x)
  (some (lambda (y) (char= x y)) '(#\Space #\Newline #\Tab)))

(defparameter whitespace
  (comp ((_ (optional (many (unit whitespace?)))))
        nil))

(defun separated-list (p separator &key include-separator)
  (comp ((v p)
         (sep (optional separator))
         (vn (if sep
               (crit (separated-list p separator))
               nothing)))
        (if include-separator
          (cons v (cons sep vn))
          (cons v vn))))

(defun surrounded (left p right &key include-surrounding)
  (comp ((l left)
         (body p :lazy)
         (r right))
        (if include-surrounding
          (list l body r)
          body)))