monadic parser combinators in emacs lisp

(defun ormap (predicate sequence)
  (if (null sequence)
      nil
    (or (funcall predicate (first sequence))
        (ormap   predicate (rest sequence)))))

(defun andmap (predicate sequence)
  (if (null sequence)
      nil
    (let ((value (predicate sequence)))
      (if (not (null (rest sequence)))
          (and value (andmap predicate (rest sequence)))
        value))))

(defun string-digit? (str)
  (not (null (string-match "^[[:digit:]]+$" str))))

(defun string-alnum? (str)
  (not (null (string-match "^[[:alnum:]]+$" str))))

(defun parse-value (parse-result)
  (car parse-result))

(defun parse-residue (parse-result)
  (cdr parse-result))

;; return :: a -> m a
;; return a = P (\s -> Just (a, s))
(defun parse-return (value)
  (lambda (input)
    (list (cons value input))))

;; >>= :: m a -> (a -> m b) -> m b
(defun parse->>= (parser constructor)
  (lambda (input)
    (reduce #'append
      (mapcar (lambda (result)
                (funcall (funcall constructor (parse-value result))
                         (parse-residue result)))
              (funcall parser input))
      :initial-value nil)))

;; mzero :: m a
(defun parse-zero (input)
  nil)

;; ++ :: [m a] -> m a
;; nondeterministic choice
(defun parse-++ (&rest parsers)
  (lambda (input)
    (reduce #'append
            (mapcar (lambda (parser)
                      (funcall parser input))
                    parsers)
            :initial-value nil)))

;; +++ :: [m a] -> m a
;; deterministic choice
(defun parse-+++ (&rest parsers)
  (lambda (input)
    (ormap (lambda (parser)
             (funcall parser input))
           parsers)))

;; monad comprehensions
(defmacro parse-let* (binding-forms &rest body)
  (if (null binding-forms)
      `(progn ,@body)
      (let* ((current-binding-form (car  binding-forms))
             (subsequent-binders   (cdr  binding-forms))
             (symbol               (car  current-binding-form))
             (expression           (cadr current-binding-form)))
        `(parse->>= ,expression
           (lambda (,symbol)
             (parse-let* ,subsequent-binders ,@body))))))

(defun parse-item (input)
  (unless (string-equal input "")
    (list (cons (substring input 0 1) (substring input 1)))))

(defun parse-sat (predicate)
  (parse-let* ((object #'parse-item))
              (if (funcall predicate object)
                  (parse-return object)
                #'parse-zero)))

(defun parse-match (str)
  (lambda (input)
    (and (string-prefix-p str input)
         (list (cons str (substring input (length str)))))))

(defun parse-any (parser)
  (parse-+++ (parse-some   parser)
             (parse-return nil)))

(defun parse-some (parser)
  (parse-let* ((first parser)
               (rest  (parse-any parser)))
              (parse-return (cons first rest))))

(defun parse-times (n parser)
  (if (zerop n)
      (parse-return nil)
    (parse-let* ((first parser)
                 (rest  (parse-times (- n 1) parser)))
                (parse-return (cons first rest)))))

(defconst parse-digit+
  (parse-let* ((digits (parse-some (parse-sat #'string-digit?))))
              (parse-return (string-to-number (reduce #'concat digits)))))

(defconst parse-alnum+
  (parse-let* ((chars (parse-some (parse-sat #'string-alnum?))))
              (parse-return (reduce #'concat chars))))

(provide 'parse)

;; (funcall (parse-let* ((first-value  #'parse-item)
;;                     (second-value #'parse-item))
;;           (parse-return (list first-value second-value)))
;;          "foobar")

;; (funcall (parse-+++ (parse-match "foo")
;;                     (parse-match "bar")) "barfoo")

;; (funcall parse-digit+ "500foo")
;; (funcall parse-alnum+ "barbaz")