monadic parser combinators

core.clj

(ns parser.core
  (:require
   [clojure.algo.monads :refer [defmonad with-monad state-t m-reduce]]))


(defmonad either-m
  [m-result (fn [[side value]] {:side side, :value value})
   m-bind   (fn [mv mf] (mf [(:side mv) (:value mv)]))])

(defn left [v]
  (with-monad either-m (m-result [:left v])))

(defn right [v]
  (with-monad either-m (m-result [:right v])))

(defn p-error [in]
  [in (left (str "Syntax Error: " (first in)))])

(defn p-error? [e]
  (= :left (:side e)))

(defn p-success [in val]
  [in (right val)])

(defmonad parser-m
  [m-result (fn [in]
              (fn [state] [in state]))
   m-bind (fn [mv f]
            (fn [s]
              (if-not (p-error? s)
                (let [[v ss] (mv s)
                      new-mv (f v)]
                  (new-mv ss))
                s)))])

(defn p-apply [in state mf]
  (with-monad parser-m
    (let [f (m-bind (m-result in) mf)]
      (f state))))


(defn elem [ch]
  (fn [in]
    (fn [state]
      (if (= ch (first in))
        (p-success (rest in) ch) 
        (p-error in)))))

(defn many [p]
  (fn [in]
    (fn [state]
      (let [[in res] (p-apply in state p)]
        (if (p-error? res)
          (p-success in '())
          (let [[in nres] (p-apply in state (many p))]
            (p-success in (conj (:value nres)
                                (:value res)))))))))


(defn all [str]
  (let [mfs (map elem str)]
    (fn [in]
      (with-monad parser-m
        (reduce m-bind (m-result in) mfs)))))

(defn alt [p1 p2]
  (fn [in]
    (fn [state]
      (let [[in1 res1] (p-apply in state p1)]
        (if (p-error? res1)
          (p-apply in state p2)
          [in1 res1])))))

(defn opt [p1]
  (fn [in]
    (fn [state]
      (let [[in1 res1] (p-apply in state p1)]
        (if (p-error? res1)
          (p-success in (:value state))
          (p-success in1 (:value res1)))))))

(defn build [& mfs]
  (fn [in]
    (with-monad parser-m
      (reduce m-bind (m-result in) mfs))))


(defn parse [parser in]
  (let [f (with-monad parser-m
            (m-bind (m-result in) parser))
        [in state] (f (p-success in :start))]
    (if (= [] in)
      state
      (p-error in))))


(let [a (elem \A)
      b (elem \B)
      get (all "GET")
      put (all "PUT")
      http-verb (alt get put)
      ma (many a)
      mb (many b)
      mamb (build ma mb)
      mab? (build ma (opt b))]
  (println (parse a "A"))
  (println (parse b "B"))
  (println (parse b "A"))
  (println (parse http-verb "GET"))
  (println (parse http-verb "PUT"))
  (println (parse mamb "AAABBB"))
  (println (parse mab? "AAAB"))
  (println (parse mab? "AAA")))