(ns parsing)

;; http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf

(defn parse
  [p input]
  (p (seq input)))

(defn result
  [v]
  (fn [input]
    (list [v input])))

(defn zero
  []
  (fn [input]
    ()))

(defn item
  []
  (fn [input]
    (if (seq input)
      (list ((juxt first rest) input))
      ())))

(defn bind
  [p f]
  (fn [input]
    (apply concat (for [[v input*] (p input)]
                    ((f v) input*)))))

(defn seq*
  [p q]
  (bind p (fn [x]
            (bind q (fn [y]
                      (result (list x y)))))))

(defn sat
  [pred]
  (bind (item) (fn [x]
                  (if (pred x)
                    (result x)
                    (zero)))))

(defn char*
  [c]
  (sat (fn [x] (= c x))))

(defn digit
  []
  (sat (fn [x] (<= (int \0) (int x) (int \9)))))

(defn lower
  []
  (sat (fn [x] (<= (int \a) (int x) (int \z)))))

(defn upper
  []
  (sat (fn [x] (<= (int \A) (int x) (int \Z)))))

(defn plus
  [p q]
  (fn [input]
    (concat (p input) (q input))))

(defn letter
  []
  (plus (lower) (upper)))

(defn alphanum
  []
  (plus (letter) (digit)))

(defn word
  []
  (plus (bind (letter) (fn [x]
                         (bind (word) (fn [xs]
                                        (result (cons x xs))))))
        (result "")))

(defmacro mlet
  [[binding-sym binding-form & bindings] & body]
  (if (and binding-sym binding-form)
    (if (vector? binding-form)
      (let [[binding-expr modifier modifier-expr] binding-form]
        (if (= :when modifier)
          `(bind ~binding-expr (fn [~binding-sym]
                                 (if ~modifier-expr
                                   (mlet ~bindings ~@body)
                                   (zero))))
          (throw (Exception. (str "Unknown modifier ") modifier))))
      `(bind ~binding-form (fn [~binding-sym]
                             (mlet ~bindings ~@body))))
    `(result (do ~@body))))

(mlet [x (item)
       y (item)
       z (item)]         
      (str x y z))

(defn string
  [s]
  (if (empty? s)
    (result "")
    (mlet [_ (char* (first s))
           _ (string (rest s))]
      s)))

(defn sat3
  [pred]
  (mlet [x [(item) :when (pred x)]]
        x))

(defmacro mlet-2
  [[sym-or-op form & bindings] & body]
  (if sym-or-op
    (cond (symbol? sym-or-op)
          `(bind ~form (fn [~sym-or-op] (mlet-2 ~bindings ~@body)))
          (= :when sym-or-op)
          `(if ~form
             (mlet-2 ~bindings ~@body)
             (zero))
          :else
          (throw (Exception. (str "Unknown modifier " sym-or-op))))
    `(result (do ~@body))))

(defn sat3
  [pred]
  (mlet-2 [x (item)
           :when (pred x)]
          x))

(defmacro mdo
  [& [form & forms]]
  (when form
    (cond (vector? form)
          (cond (symbol? (first form))
                `(bind ~(second form) (fn [~(first form)] (mdo ~@forms)))
                (= :when (first form))
                `(if ~(second form) (mdo ~@forms) (zero))
                :else
                (throw (Exception. (str "Unknown modifier " (first form)))))
          (seq forms) ;; if there's any more forms to process
          `(bind ~form (fn [_#] (mdo ~@forms)))
          :else
          form)))

(defn string-do
  [s]
  (if (seq s)
    (mdo
     (char* (first s))
     (string-do (rest s))
     (result s))
    (mdo
     (result ""))))

(defn sat-do
  [pred]
  (mdo
   [x (item)]
   [:when (pred x)]
   (result x)))