crude-haskell-like-matching.clj

(defprotocol Matchable (match [me matcher]))

(defmacro data [name & constructors]
  `(do
     (defprotocol ~name)
     (defprotocol ~(symbol (str "match-"name))
	 ~@(for [[const & args] constructors]
	    `(~(symbol (str "match-"const)) [_# ~@args])))
       
	 ~@(for [[const & args] constructors]
	    (if (seq args)
	      `(defn ~const [~@args]
		 (reify [Matchable ~name] 
			(match [me# matcher#]
			       (~(symbol (str "match-"const)) matcher# ~@args))))
	      `(def ~const
		 (reify [Matchable ~name] 
			(match [me# matcher#]
			       (~(symbol (str "match-"const)) matcher# ~@args))))))))

(defmacro match* [type val & paths]
  `(match ~val
	 (reify [~(symbol (str "match-"type))]
		~@(for [[const args & code] paths]
		   `(~(symbol (str "match-" const)) [_ ~@args] ~@code)))))
		     
(data List [Nil] [Cons car cdr])

(defn my-map [fun aList]
  (match* List aList
	  (Nil [] Nil)
	  (Cons [car cdr] (Cons (fun car) (my-map fun cdr)))))

(defn my-foldr [fun val aList]
  (match* List aList
	  (Nil [] val)
	  (Cons [car cdr] (fun car (my-foldr fun val cdr)))))

(defn print-List [aList]
  (print "(")
  (my-map #(do (print %) (print " ")) aList)
  (print ")"))

(print-List (Cons 2 (Cons 3 Nil)))
(my-foldr + 0 (Cons 2 (Cons 3 Nil)))