Skip to content

Instantly share code, notes, and snippets.

@jeremyheiler
Last active February 10, 2016 22:37
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jeremyheiler/c393ce753ff7bd43c31e to your computer and use it in GitHub Desktop.
Save jeremyheiler/c393ce753ff7bd43c31e to your computer and use it in GitHub Desktop.
(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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment