(in-package #:monparser)

(defstruct result
  (place (make-instance 'cursor) :type cursor))

(defstruct (parsing (:include result))
  tree)

(defstruct (failure (:include result))
  (message "" :type string)
  (priority 0 :type integer))

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

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

(defmacro lazy (parser &rest args)
  (let ((input (gensym)))
    `(the parser
          (lambda (,input)
            (funcall (,parser ,@args) ,input)))))

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

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

(deftype parser-continuation ()
  `(function (t) parser))

(declaim (ftype (function (parser parser-continuation) parser) bind))
(defun bind (parser f)
  (lambda (input)
    (let ((r (funcall parser (cursor-rebase input))))
      (cond ((parsing-p r)
             (funcall (funcall f r) (cursor-merge input (result-place 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))))
      (cond ((symbolp var)
             (if (string= (symbol-name var) "_")
               `(bind ,parser
                      (the parser-continuation
                           (lambda (,var)
                             (declare (ignore ,var))
                             (comp ,(cdr bindings) ,@body))))
               `(bind ,parser
                      (the parser-continuation
                           (lambda (,var)
                             (let ((,var (parsing-tree ,var)))
                               (comp ,(cdr bindings) ,@body)))))))
            ((and (listp var) (= (length var) 1) (symbolp (car var)))
             `(bind ,parser
                    (the parser-continuation
                         (lambda (,(first var))
                           (comp ,(cdr bindings) ,@body)))))
            (t (error "Binding must be either a symbol or a list of one symbol."))))))