; a combinator parser

; (load "utils")

(defpackage :parser
  (:nicknames :p)
  (:use :cl :utils)
  (:export :new :fail :many :many-till :satisfy :eof :other))
(in-package p)

(shadow 'char)
(export 'char)

(defconstant fail (gensym "FAIL"))

(defun skip-null-strs (row col strs)
  (cond ((null strs) (list row 0))
        ((>= col (length (car strs)))
         (skip-null-strs (1+ row) 0 (cdr strs)))
        (t (append (list row col) strs))))

(defun new (&rest strs)
  (skip-null-strs 0 0 strs))

(defun peek (input)
  (if (null (cddr input))
    'eof
    (cl:char (caddr input) (cadr input))))

(defun next (input)
  (skip-null-strs (car input)
                  (1+ (cadr input))
                  (cddr input)))

(defun satisfy (pred)
  (lambda (input)
    (let ((c (peek input)))
      (if (funcall pred c)
        (values c (next input))
        (values fail (format nil "satisfy ~A" pred))))))

(defun char (c) (satisfy (curry #'eql c)))

(defun other (p)
  (lambda (input)
    (mvbind (x rest) (funcall p input)
      (if (eql x fail)
        (values (peek input) (next input))
        (values fail (format nil "other ~A" p))))))

(defun many (p)
  (labels ((rec (acc input)
             (mvbind (x rest) (funcall p input)
               (if (eql x fail)
                 (values (nreverse acc) input)
                 (rec (cons x acc) rest)))))
    (curry #'rec nil)))

(defun many-till (p p-end)
  (labels ((rec (acc input)
             (mvbind (x rest) (funcall p-end input)
               (if (not (eql x fail))
                 (values (nreverse (cons x acc))
                         rest)
                 (mvbind (x rest) (funcall p input)
                   (if (eql x fail)
                     (values fail (format nil "many-till ~A ~A" p p-end))
                     (rec (cons x acc) rest)))))))
    (curry #'rec nil)))

(setq eof (satisfy (lambda (x) (eql x 'eof))))
