jeremyheiler · February 10, 2016 22:37 · Feb 10, 2016 · Feb 10, 2016 · Feb 10, 2016 · Feb 10, 2016
diff --git a/parsing.clj b/parsing.clj
@@ -100,22 +100,17 @@
 
 (defn string
   [s]
-  (if (seq s)
-    (with-parse [_ (char* (first s))
-                 _ (string (rest s))]
-      s)
-    (result "")))
+  (if (empty? s)
+    (result "")
+    (mlet [_ (char* (first s))
+           _ (string (rest s))]
+      s)))
 
 (defn sat3
   [pred]
   (mlet [x [(item) :when (pred x)]]
         x))
 
-(comment (defn sat3
-           [pred]
-           (mlet [[x :when (pred x)] (item)]
-                 x)))
-
 (defmacro mlet-2
   [[sym-or-op form & bindings] & body]
   (if sym-or-op
@@ -126,7 +121,7 @@
              (mlet-2 ~bindings ~@body)
              (zero))
           :else
-          (throw (Exception. (str "Unknown modifier " (first form)))))
+          (throw (Exception. (str "Unknown modifier " sym-or-op))))
     `(result (do ~@body))))
 
 (defn sat3

diff --git a/parsing.clj b/parsing.clj
@@ -116,20 +116,36 @@
            (mlet [[x :when (pred x)] (item)]
                  x)))
 
-(comment (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 " (first form)))))
+    `(result (do ~@body))))
+
+(defn sat3
+  [pred]
+  (mlet-2 [x (item)
+           :when (pred x)]
+          x))
 
 (defmacro mdo
   [& [form & forms]]
   (when form
     (cond (vector? form)
-          `(bind ~(second form) (fn [~(first form)] (mdo ~@forms)))
-          (= 'mdo-if (first form))
-          `(if ~(second form) (mdo ~@forms) (zero))
-          (seq forms)
+          (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)))
@@ -148,5 +164,5 @@
   [pred]
   (mdo
    [x (item)]
-   (mdo-if (pred x))
+   [:when (pred x)]
    (result x)))
diff --git a/parsing.clj b/parsing.clj
@@ -127,7 +127,7 @@
   (when form
     (cond (vector? form)
           `(bind ~(second form) (fn [~(first form)] (mdo ~@forms)))
-          (= 'dmdo-if (first form))
+          (= 'mdo-if (first form))
           `(if ~(second form) (mdo ~@forms) (zero))
           (seq forms)
           `(bind ~form (fn [_#] (mdo ~@forms)))
@@ -148,5 +148,5 @@
   [pred]
   (mdo
    [x (item)]
-   (dmdo-if (pred x))
+   (mdo-if (pred x))
    (result x)))
diff --git a/parsing.clj b/parsing.clj
@@ -111,15 +111,26 @@
   (mlet [x [(item) :when (pred x)]]
         x))
 
+(comment (defn sat3
+           [pred]
+           (mlet [[x :when (pred x)] (item)]
+                 x)))
+
+(comment (defn sat3
+           [pred]
+           (mlet [x (item)
+                  :when (pred x)]
+                 x)))
+
 (defmacro mdo
   [& [form & forms]]
   (when form
     (cond (vector? form)
-          `(bind ~(second form) (fn [~(first form)] (mdo-2 ~@forms)))
-          (= 'mif (first form))
-          `(if ~(second form) (mdo-2 ~@forms) (zero))
+          `(bind ~(second form) (fn [~(first form)] (mdo ~@forms)))
+          (= 'dmdo-if (first form))
+          `(if ~(second form) (mdo ~@forms) (zero))
           (seq forms)
-          `(bind ~form (fn [_#] (mdo-2 ~@forms)))
+          `(bind ~form (fn [_#] (mdo ~@forms)))
           :else
           form)))
 
@@ -128,13 +139,14 @@
   (if (seq s)
     (mdo
      (char* (first s))
-     (string-do-2 (rest s))
+     (string-do (rest s))
      (result s))
-    (mdo (result ""))))
+    (mdo
+     (result ""))))
 
 (defn sat-do
   [pred]
   (mdo
    [x (item)]
-   (mif (pred x))
+   (dmdo-if (pred x))
    (result x)))
diff --git a/parsing.clj b/parsing.clj
@@ -1,5 +1,11 @@
+(ns parsing)
+
 ;; http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf
 
+(defn parse
+  [p input]
+  (p (seq input)))
+
 (defn result
   [v]
   (fn [input]
@@ -14,7 +20,8 @@
   []
   (fn [input]
     (if (seq input)
-      (list ((juxt first rest) input)))))
+      (list ((juxt first rest) input))
+      ())))
 
 (defn bind
   [p f]
@@ -71,29 +78,25 @@
                                         (result (cons x xs))))))
         (result "")))
 
-(defmacro with-parse
-  [bindings & body]
-  (assert (even? (count bindings)) "binding must have even number of items")
-  (loop [[pair & pairs] (reverse (partition 2 bindings))
-         r `(result (do ~@body))]
-    (if pair
-      (if (= :when (first pair))
-        (recur (rest pairs)
-               (if-let [next-pair (first pairs)]
-                 `(bind ~(second next-pair) (fn [~(first next-pair)]
-                                              (if ~(second pair)
-                                                ~r
-                                                (zero))))
-                 (throw (Exception. ":when must "))))
-        (recur pairs
-               `(bind ~(second pair) (fn [~(first pair)]
-                                       ~r))))
-      r)))
-
-(with-parse [x (item)
-             y (item)
-             z (item)]         
-  (str x y z))
+(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]
@@ -103,36 +106,29 @@
       s)
     (result "")))
 
-(defn parse
-  [p input]
-  (p (seq input)))
-
-(defn sat2
+(defn sat3
   [pred]
-  (with-parse [x (item) :when (pred x)]
-    x))
+  (mlet [x [(item) :when (pred x)]]
+        x))
 
 (defmacro mdo
-  [& exprs]
-  (loop [[e & es] (reverse (butlast exprs))
-         r (last exprs)]
-    (if e
-      (recur es (cond (vector? e)
-                      `(bind ~(second e) (fn [~(first e)] ~r))
-                      (= 'mif (first e))
-                      `(if ~(second e)
-                         ~r
-                         (zero))
-                      :else
-                      e))
-      r)))
+  [& [form & forms]]
+  (when form
+    (cond (vector? form)
+          `(bind ~(second form) (fn [~(first form)] (mdo-2 ~@forms)))
+          (= 'mif (first form))
+          `(if ~(second form) (mdo-2 ~@forms) (zero))
+          (seq forms)
+          `(bind ~form (fn [_#] (mdo-2 ~@forms)))
+          :else
+          form)))
 
 (defn string-do
   [s]
   (if (seq s)
     (mdo
      (char* (first s))
-     (string (rest s))
+     (string-do-2 (rest s))
      (result s))
     (mdo (result ""))))
 

diff --git a/parsing.clj b/parsing.clj
@@ -0,0 +1,144 @@
+;; http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf
+
+(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 with-parse
+  [bindings & body]
+  (assert (even? (count bindings)) "binding must have even number of items")
+  (loop [[pair & pairs] (reverse (partition 2 bindings))
+         r `(result (do ~@body))]
+    (if pair
+      (if (= :when (first pair))
+        (recur (rest pairs)
+               (if-let [next-pair (first pairs)]
+                 `(bind ~(second next-pair) (fn [~(first next-pair)]
+                                              (if ~(second pair)
+                                                ~r
+                                                (zero))))
+                 (throw (Exception. ":when must "))))
+        (recur pairs
+               `(bind ~(second pair) (fn [~(first pair)]
+                                       ~r))))
+      r)))
+
+(with-parse [x (item)
+             y (item)
+             z (item)]         
+  (str x y z))
+
+(defn string
+  [s]
+  (if (seq s)
+    (with-parse [_ (char* (first s))
+                 _ (string (rest s))]
+      s)
+    (result "")))
+
+(defn parse
+  [p input]
+  (p (seq input)))
+
+(defn sat2
+  [pred]
+  (with-parse [x (item) :when (pred x)]
+    x))
+
+(defmacro mdo
+  [& exprs]
+  (loop [[e & es] (reverse (butlast exprs))
+         r (last exprs)]
+    (if e
+      (recur es (cond (vector? e)
+                      `(bind ~(second e) (fn [~(first e)] ~r))
+                      (= 'mif (first e))
+                      `(if ~(second e)
+                         ~r
+                         (zero))
+                      :else
+                      e))
+      r)))
+
+(defn string-do
+  [s]
+  (if (seq s)
+    (mdo
+     (char* (first s))
+     (string (rest s))
+     (result s))
+    (mdo (result ""))))
+
+(defn sat-do
+  [pred]
+  (mdo
+   [x (item)]
+   (mif (pred x))
+   (result x)))