Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
145 lines (126 sloc) 4.29 KB
(ns monads.util
(:require [the.parsatron :as parsatron]
[macroparser.functions :as functions]
[monads.types :as types])
(:use [monads.core :only [mzero >>= mdo return mplus run-monad local catch-error]])
(:import [monads.types Returned]))
(defmacro curryfn
{:arglists (-> fn var meta :arglists)}
[& args]
(let [parsed (parsatron/run (functions/parse-fn-like) args)
arities (:arities parsed)
arity (:params (first arities))
name (or (:name parsed) (gensym))
parsed (assoc parsed :name name)
n (count (:bindings arity))]
(assert (== 1 (count arities)) "Can't curry multi-arity functions.")
(assert (nil? (-> arity :bindings :rest)) "Can't curry functions with rest args")
`(fn ~name
~@(for [now (range 1 n)]
(let [nows (repeatedly now #(gensym "now-"))]
(fn ~@(for [later-args (range 1 (- (inc n) now))]
(let [laters (repeatedly later-args #(gensym "later-"))]
`([~@laters] (~name ~@nows ~@laters))))))))
~(functions/unparse-arities arities))))
(defmacro defcurryfn
{:arglists (-> defn var meta :arglists first list)}
[& args]
(let [parsed (parsatron/run (functions/parse-defn-like) args)
attr-map (:attr-map parsed)
docstring (:docstring parsed)
arglists (->> parsed :arities first :params :bindings reverse
(iterate rest)
(take-while (comp not empty?))
(map reverse))
meta-map (merge (meta (:name parsed))
{:arglists (list 'quote (map vec arglists))}
(when docstring {:doc docstring}))
as-fn (functions/unparse-fn-like (assoc parsed :type 'fn))]
`(def ~(with-meta (:name parsed) meta-map) (curryfn ~@(rest as-fn)))))
(defn ecurry
"Curry the function f."
[arity f]
(fn [& args]
(let [argc (count args)]
(if (== arity argc)
(apply f args)
(ecurry (- arity argc) (fn [& more] (apply f (concat args more))))))))
(defmacro curry
"Curry the function f."
[arity f]
(if (number? arity)
(let [args (repeatedly arity gensym)]
`(curryfn [~@args] (~f ~@args)))
`(ecurry ~arity ~f)))
(defn mcat [f xs]
(if (not (seq xs))
(concat (f (first xs)) (mcat f (rest xs))))))
(defn sequence-m
"Transform a sequence of monadic values [m a] into a monadic value
which is a sequence, m [a]."
(reduce (fn [m-acc m]
(mdo mval <- m
ms <- m-acc
(return (conj ms mval))))
(return ())
(reverse ms)))
(defn map-m
"(a -> m b) -> [a] -> m [b]"
[f args]
(sequence-m (map f args)))
(defmacro deflift-m-n [n]
(let [nm (symbol (str "lift-m-" n))
m-args (map #(symbol (str "m-" %)) (range 1 (inc n)))
unwrapped-args (repeatedly n #(gensym))]
`(defcurryfn ~nm [~'f ~@m-args]
(mdo ~@(mapcat (fn [u m] [u '<- m]) unwrapped-args m-args)
(return (~'f ~@unwrapped-args))))))
(defmacro deflift-m-ns [lo hi]
(when-not (== lo hi)
`(do (deflift-m-n ~lo)
(deflift-m-ns ~(inc lo) ~hi))))
(defcurryfn lift-m-2
"As lift-m but for binary functions: transforms a -> b -> c into m a
-> m b -> m c. Likewise for lift-m-3, etc."
[f m1 m2]
(mdo a <- m1
b <- m2
(return (f a b))))
(deflift-m-ns 3 9)
(def ^{:doc "Lift function application."} ap (lift-m-2 (fn [a b] (a b))))
(defn lift-m*
([f] (fn [& m-args] (apply lift-m* f m-args)))
([f & m-args]
(mdo args <- (sequence-m m-args)
(return (apply f args)))))
(defn fold-m
"Analogous to reduce, except the result of f is in a monad: f is a -> b -> m a."
[f acc xs]
(if (empty? xs)
(return acc)
(mdo a <- (f acc (first xs))
(fold-m f a (rest xs)))))
(defn msum
"Add all the addends together using mplus."
(reduce #(mplus %2 %1) (reverse addends)))
(defmacro mwhen
"Execute the computation acc if p is truthy."
[p acc]
`(if ~p
~(return nil)))
(defn guard
"If p is truthy, return (return nil), otherwise mzero, halting the
current computation."
(if p
(return nil)
(defmacro lazy-pair [a b]
`(lazy-seq (cons ~a (lazy-seq (cons ~b '())))))