extensible in itself now

src/matchmaker/core.clj

@@ -34,3 +34,54 @@
 (defmacro define-ADT [name & specs]
   `(types/define-type ~name ~@specs))
 
+;;;; now the fun begins
+;;;; we can extend the matcher using the matcher
+
+(define (match-predicate args param yes no)
+  (match args
+    [p]   -> (match/choose `(~p ~param) yes no)
+    [p v] -> (match/choose `(~p ~param) `(let [~v ~param] ~yes) no)))
+
+(define (match-as args param yes no)
+  (match args
+    [a b] -> `(let [~a ~param]
+                ~(match/match-pattern param b yes no))
+    [a b & c] -> (match-as [a (cons b c)] param yes no)))
+
+(define (match-and args param yes no)
+  (match args
+    []       -> yes
+    [x & xs] -> (let [yes* (match-and xs param yes no)]
+                  (match/match-pattern x param yes* no))))
+
+(define (match-or args param yes no)
+  (match args
+    [] -> no
+    [x & xs] -> (let [no* (match-or xs param yes no)]
+                  (match/match-pattern x param yes no*))))
+
+(define (match-spy args param yes no)
+  (match args
+    [x] -> `(do (prn ~param)
+                ~(match/match-pattern param x yes no))))
+
+(defmethod match/match-special :?
+  [_] match-predicate)
+
+(defmethod match/match-special :as
+  [_] match-as)
+
+(defmethod match/match-special :or
+  [_] match-or)
+
+(defmethod match/match-special :and
+  [_] match-and)
+
+(defmethod match/match-special :spy
+  [_] match-spy)
+
+;;;; and maybe a more useful one
+;;;; an :as pattern
+
+
+

src/matchmaker/fun.clj

@@ -13,6 +13,28 @@
   (lazy-seq
    (when-let [y (f x)] (cons x (unfoldl f y)))))
 
+;;;; curried equals, not equals
+
 (define (eq? x y) (= x y))
 
-(define (not-eq? x y) (not= x y))
+(define (not-eq? x y) (not= x y))
+
+(define (not* p x) (not (p x)))
+
+;;;; predicates
+
+(defn conjoin [& predicates]
+  (fn [x]
+    (loop [preds predicates]
+      (if (empty? preds)
+        true
+        (let [[p & ps] preds]
+          (if (p x) (recur ps) false))))))
+
+(defn disjoin [& predicates]
+  (fn [x]
+    (loop [preds predicates]
+      (if (empty? preds)
+        false
+        (let [[p & ps] preds]
+          (or (p x) (recur ps)))))))

src/matchmaker/match.clj

@@ -25,13 +25,17 @@
 (defmulti match-special
   "extension point for adding syntax to the pattern matcher.
    dispatch value must be a keyword.
-   The multifn must be a function of four arguments:
-   1. the full form (dispatch keyword & arguments)
+   The multifn must return a curried function of four arguments:
+   1. the tail of the form 
    2. the current parameter
    3. the match-success continuation (yes).
    4. the match-failure continuation (no).
-   The return value will be inserted in tail position."
-  (fn [form target yes no] (first form)))
+   The result of applying the returned function to the above arguments
+   will be inserted in tail position."
+  identity)
+
+(defmethod match-special :default
+  [_] (raise! "unknown operator"))
 
 (deflambda eq? [x y] (= x y))
 
@@ -104,7 +108,7 @@
                       `(~head ~t)
                       `(let [~(first tail) ~t] ~yes)
                       no))
-      keyword?     (match-special head t tail yes no)
+      keyword?     (do ((match-special head) tail t yes no))
       (malformed-error p))))
 
 (deflambda match-nullary [t c yes no]
@@ -126,12 +130,13 @@
 (deflambda match-sequential [t p yes no]
   (let [[ps op len restpat] (parse-vector p)
         ps* (match-indexed t ps)]
-    (choose
-     `(and (sequential? ~t) (~op (count ~t) ~len))
-     (if restpat
-       (ps* (match-rest t restpat len yes no) no)
-       (ps* yes no))
-     no)))
+    (if (empty? p)
+      (choose `(empty? ~t) yes no)
+      (choose `(and (sequential? ~t) (~op (count ~t) ~len))
+       (if restpat
+         (ps* (match-rest t restpat len yes no) no)
+         (ps* yes no))
+       no))))
 
 (deflambda match-projection [accessor index t p yes no]
   (project (accessor t index) #(match-pattern % p yes no)))
@@ -220,16 +225,17 @@
   (let [ps* (map match-pattern ts ps)]
     (foldr #(%1 %2 no) (butlast ps*) ((last ps*) yes no))))
 
-(defn compile-yes [idx action guard]
-  (or action
-      `(cond ~@(apply concat guard)
-             :else (recur ~(inc idx)))))
+(defn compile-yes [idx map]
+  (if (contains? map :action)
+    (:action map)
+    `(cond ~@(apply concat (:guard map))
+           :else (recur ~(inc idx)))))
 
 (defn compile-case
-  [[idx {:keys [pattern guard action]}] ts]
-  (let [yes (compile-yes idx action guard)
+  [[idx map] ts]
+  (let [yes (compile-yes idx map)
         no  `(recur ~(inc idx))]
-    (compile-pattern pattern yes no ts)))
+    (compile-pattern (:pattern map) yes no ts)))
 
 ;;;; pretty error messages shoud be generated here
 (deflambda compile-cases*