Permalink
Browse files

Add :if/:then/:else and :cond to domonad syntax

  • Loading branch information...
1 parent 00bca0f commit d9b13dcc57be0d11934441c2dc7a9b287385f435 @roman roman committed with khinsen Feb 6, 2012
Showing with 169 additions and 53 deletions.
  1. +16 −9 pom.xml
  2. +105 −42 src/main/clojure/clojure/algo/monads.clj
  3. +48 −2 src/test/clojure/clojure/algo/test_monads.clj
View
25 pom.xml
@@ -1,21 +1,28 @@
-<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
- <modelVersion>4.0.0</modelVersion>
+<project xmlns="http://maven.apache.org/POM/4.0.0"
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
+
<artifactId>algo.monads</artifactId>
<version>0.1.1-SNAPSHOT</version>
- <name>${artifactId}</name>
-
- <parent>
- <groupId>org.clojure</groupId>
- <artifactId>pom.contrib</artifactId>
- <version>0.0.25</version>
- </parent>
+ <name>${project.artifactId}</name>
+ <modelVersion>4.0.0</modelVersion>
<developers>
<developer>
<name>Konrad Hinsen</name>
</developer>
+ <developer>
+ <name>Roman Gonzalez</name>
+ <email>romanandreg@gmail.com</email>
+ </developer>
</developers>
+ <parent>
+ <groupId>org.clojure</groupId>
+ <artifactId>pom.contrib</artifactId>
+ <version>0.0.25</version>
+ </parent>
+
<dependencies>
<dependency>
<groupId>org.clojure</groupId>
@@ -46,16 +46,16 @@
:m-plus ~'m-plus}))
(defmacro defmonad
- "Define a named monad by defining the monad operations. The definitions
- are written like bindings to the monad operations m-bind and
- m-result (required) and m-zero and m-plus (optional)."
+ "Define a named monad by defining the monad operations. The definitions
+ are written like bindings to the monad operations m-bind and
+ m-result (required) and m-zero and m-plus (optional)."
- ([name doc-string operations]
- (let [doc-name (with-meta name {:doc doc-string})]
- `(defmonad ~doc-name ~operations)))
+ ([name doc-string operations]
+ (let [doc-name (with-meta name {:doc doc-string})]
+ `(defmonad ~doc-name ~operations)))
- ([name operations]
- `(def ~name (monad ~operations))))
+ ([name operations]
+ `(def ~name (monad ~operations))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -64,14 +64,76 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn- ensure-items [n steps]
+ "Ensures there are at least n elements on a list, will fill up with nil
+ values when list is not big enough."
+ (take n (concat steps (repeat nil))))
+
+(defn- each3-steps [steps]
+ "Transforms a list in a list of triples following the form:
+ [a b c] => [[a b c] [b c nil] [c nil nil]]."
+ (let [n (count steps)]
+ (map vector (ensure-items n steps)
+ (ensure-items n (rest steps))
+ (ensure-items n (rest (rest steps))))))
+
+(def ^:private prepare-monadic-steps
+ #(->> % (partition 2) reverse each3-steps))
+
+(defn- if-then-else-statement
+ "Process an :if :then :else steps when adding a new
+ monadic step to the mexrp."
+ [[[_ else-mexpr]
+ [then-bform then-mexpr]
+ [if-bform if-conditional]] mexpr continuation]
+ (cond
+ (and (identical? then-bform :then)
+ (identical? if-bform :if))
+ `(if ~if-conditional
+ ~(reduce continuation
+ mexpr
+ (prepare-monadic-steps then-mexpr))
+ ~(reduce continuation
+ mexpr
+ (prepare-monadic-steps else-mexpr)))
+ :else
+ (throw (Exception. "invalid :if without :then and :else"))))
+
+(defn- merge-cond-branches [cond-branches]
+ (let [merger (fn [result cond-branch]
+ (-> result
+ (conj (first cond-branch))
+ (conj (second cond-branch))))]
+ (reduce merger [] cond-branches)))
+
+(defn cond-statement
+ "Process a :cond steps when adding a new monadic step to the mexrp."
+ [expr mexpr continuation]
+ (let [cond-sexps (partition 2 expr)
+ result (for [[cond-sexp monadic-sexp] cond-sexps]
+ (list cond-sexp
+ (reduce continuation
+ mexpr
+ (prepare-monadic-steps monadic-sexp))))]
+ `(cond ~@(merge-cond-branches result))))
+
(defn- add-monad-step
"Add a monad comprehension step before the already transformed
monad comprehension expression mexpr."
- [mexpr step]
- (let [[bform expr] step]
- (cond (identical? bform :when) `(if ~expr ~mexpr ~'m-zero)
- (identical? bform :let) `(let ~expr ~mexpr)
- :else (list 'm-bind expr (list 'fn [bform] mexpr)))))
+ [mexpr steps]
+ (let [[[bform expr :as step] & _] steps]
+ (cond
+ (identical? bform :when) `(if ~expr ~mexpr ~'m-zero)
+ (identical? bform :let) `(let ~expr ~mexpr)
+ (identical? bform :cond) (cond-statement expr mexpr add-monad-step)
+ (identical? bform :then) mexpr
+ ; ^ ignore :then step (processed on the :else step)
+ (identical? bform :if) mexpr
+ ; ^ ignore :if step (processed on the :else step)
+ (identical? bform :else)
+ (if-then-else-statement steps mexpr add-monad-step)
+ :else
+ (list 'm-bind expr (list 'fn [bform] mexpr)))))
(defn- monad-expr
"Transforms a monad comprehension, consisting of a list of steps
@@ -82,46 +144,47 @@
[steps expr]
(when (odd? (count steps))
(throw (Exception. "Odd number of elements in monad comprehension steps")))
- (let [rsteps (reverse (partition 2 steps))
- [lr ls] (first rsteps)]
+
+ (let [rsteps (prepare-monadic-steps steps)
+ [[lr ls] & _] (first rsteps)]
(if (= lr expr)
; Optimization: if the result expression is equal to the result
; of the last computation step, we can eliminate an m-bind to
; m-result.
(reduce add-monad-step
- ls
- (rest rsteps))
+ ls
+ (rest rsteps))
; The general case.
(reduce add-monad-step
- (list 'm-result expr)
- rsteps))))
+ (list 'm-result expr)
+ rsteps))))
(defmacro with-monad
- "Evaluates an expression after replacing the keywords defining the
- monad operations by the functions associated with these keywords
- in the monad definition given by name."
- [monad & exprs]
- `(let [name# ~monad
- ~'m-bind (:m-bind name#)
- ~'m-result (:m-result name#)
- ~'m-zero (:m-zero name#)
- ~'m-plus (:m-plus name#)]
- (with-symbol-macros ~@exprs)))
+ "Evaluates an expression after replacing the keywords defining the
+ monad operations by the functions associated with these keywords
+ in the monad definition given by name."
+ [monad & exprs]
+ `(let [name# ~monad
+ ~'m-bind (:m-bind name#)
+ ~'m-result (:m-result name#)
+ ~'m-zero (:m-zero name#)
+ ~'m-plus (:m-plus name#)]
+ (with-symbol-macros ~@exprs)))
(defmacro domonad
- "Monad comprehension. Takes the name of a monad, a vector of steps
- given as binding-form/monadic-expression pairs, and a result value
- specified by expr. The monadic-expression terms can use the binding
- variables of the previous steps.
- If the monad contains a definition of m-zero, the step list can also
- contain conditions of the form :when p, where the predicate p can
- contain the binding variables from all previous steps.
- A clause of the form :let [binding-form expr ...], where the bindings
- are given as a vector as for the use in let, establishes additional
- bindings that can be used in the following steps."
- ([steps expr]
+ "Monad comprehension. Takes the name of a monad, a vector of steps
+ given as binding-form/monadic-expression pairs, and a result value
+ specified by expr. The monadic-expression terms can use the binding
+ variables of the previous steps.
+ If the monad contains a definition of m-zero, the step list can also
+ contain conditions of the form :when p, where the predicate p can
+ contain the binding variables from all previous steps.
+ A clause of the form :let [binding-form expr ...], where the bindings
+ are given as a vector as for the use in let, establishes additional
+ bindings that can be used in the following steps."
+ ([steps expr]
(monad-expr steps expr))
- ([name steps expr]
+ ([name steps expr]
(let [mexpr (monad-expr steps expr)]
`(with-monad ~name ~mexpr))))
@@ -514,7 +577,7 @@
:m-zero (with-monad ~base ~'m-zero)
:m-plus (with-monad ~base ~'m-plus))
combined-monad#)))
-
+
(defn maybe-t
"Monad transformer that transforms a monad m into a monad in which
the base values can be invalid (represented by nothing, which defaults
@@ -11,8 +11,54 @@
(ns clojure.algo.test-monads
(:use [clojure.test :only (deftest is are run-tests)]
[clojure.algo.monads
- :only (with-monad domonad m-lift m-seq m-chain writer-m write
- sequence-m maybe-m state-m maybe-t sequence-t)]))
+ :only (with-monad domonad m-lift m-seq m-chain writer-m write
+ sequence-m maybe-m state-m maybe-t sequence-t)]))
+
+
+(deftest domonad-if-then
+ (let [monad-value (domonad maybe-m
+ [ a 5
+ :let [c 7]
+ :if (and (= a 5) (= c 7))
+ :then [
+ b 6
+ ]
+ :else [
+ b nil
+ ]]
+ [a b])]
+ (is (= monad-value [5 6]))))
+
+
+(deftest domonad-if-else
+ (let [monad-value (domonad maybe-m
+ [ a 5
+ :when (= a 5)
+ :if (= a 1)
+ :then [
+ b 6]
+ :else [
+ b nil]]
+ [a b])]
+ (is (= monad-value nil))))
+
+(deftest domonad-cond
+ (let [monad-value (domonad maybe-m
+ [ a 5
+ :when (= a 5)
+ :cond
+ [(< a 1)
+ [result "less than one"]
+ (< a 3)
+ [result "less than three"]
+ (< a 6)
+ [result "less than six"]
+ :else
+ [result "arbitrary number"]]
+ b 7
+ :let [some-val 12345]]
+ [result b some-val])]
+ (is (= monad-value ["less than six" 7 12345]))))
(deftest sequence-monad
(with-monad sequence-m

0 comments on commit d9b13dc

Please sign in to comment.