(in-package #:monparser)

(defstruct result)

(defstruct (parsing (:include result))
  tree
  (start (make-instance 'cursor) :type cursor)
  (end (make-instance 'cursor) :type cursor))

(defstruct (failure (:include result))
  (place (make-instance 'cursor) :type cursor)
  (message "" :type string)
  (priority 0 :type integer))

(deftype parser ()
  `(function (cursor cursor) result))

(defun line-and-column (str index)
  (let ((line 1) (column 1))
    (dotimes (i index)
      (let ((c (char str i)))
        (case c
          (#\Newline
           (incf line)
           (setf column 1))
          (t (incf column)))))
    (cons line column)))

(defmethod print-object ((obj failure) stream)
  (let ((linecol (line-and-column (data (failure-place obj))
                                  (index (failure-place obj)))))
    (format stream "~a:~a: ~a~&~a~&"
            (car linecol) (cdr linecol) (failure-message obj) (failure-place obj))))

(declaim (ftype (function (t &key (:priority integer)) parser) fail))
(defun fail (message &key (priority 1))
  (lambda (start input)
    (declare (ignore start))
    (make-failure :place input :message message :priority priority)))

(declaim (ftype (function (t) parser) new))
(defun new (tree)
  (lambda (start input)
    (make-parsing :tree tree :start start :end input)))

(declaim (ftype (function (parser (function (result) parser)) parser) bind))
(defun bind (parser f)
  (lambda (start input)
    (let ((r (funcall parser input input)))
      (cond ((parsing-p r)
             (funcall (funcall f r) start (parsing-end r)))
            ((failure-p r) r)
            (t (error (format nil "Invalid return value: ~a" r)))))))

(defmacro comp (bindings &body body)
  (if (null bindings)
    `(new (progn ,@body))
    (let ((var (first (car bindings)))
          (parser (second (car bindings)))
          (unused (gensym)))
      (cond ((symbolp var)
             (if (string= (symbol-name var) "_")
               `(bind ,parser
                      (lambda (&rest ,unused)
                        (declare (ignore ,unused))
                        (comp ,(cdr bindings) ,@body)))
               `(bind ,parser
                      (lambda (,var &rest ,unused)
                        (let ((,var (parsing-tree ,var)))
                          (declare (ignore ,unused))
                          (comp ,(cdr bindings) ,@body))))))
            ((and (listp var) (= (length var) 1) (symbolp (car var)))
             `(bind ,parser
                    (lambda (,(first var) &rest ,unused)
                      (declare (ignore ,unused))
                      (comp ,(cdr bindings) ,@body))))
            (t (error "Binding must be either a symbol or a list of one symbol."))))))