(This post will run long because of all the code. But it’s not very dense and you should be able to copy and paste the code into a repl.)
When I wrote my last post, I only had a rudimentary understanding of what Free Monads were and I had not internalized the concept at all. That post was just to get the mechanics written down. Now, I’d like to explain things in depth along with a motivating example
If you want to follow along with your own REPL, you need to get my effects repo from here. Once you’ve cloned it, do
lein repl
in the repo root directory and you should be good to go.
An XML tag has 3 parts; the tag name, some attributes and the tag contents. Here’s the simplest possible deftype that encodes this.
(deftype Tag [name attr contents]
Object
(toString [_]
(pr-str name attr contents)))
(Tag. "body" {} :contents)
=> #<Tag "body" {} :contents>
and a function to create functions to create tags.
(defn tag [name]
(fn [attr contents]
(Tag. name attr contents)))
(def html (tag "html"))
(def body (tag "body"))
(def p (tag "p"))
and a very simple HTML page.
(def page (html {}
(body {}
(p {} "first paragraph"))))
page
=> #<Tag "html" {} #<Tag "body" {} #<Tag "p" {} "first paragraph">>>
It’s very straight forward to define a protocol to convert page into an XML string.
(defprotocol XML
(xml [v]))
(extend-type Tag
XML
(xml [t]
(let [contents (xml (.contents t))]
(str "<" (.name t) ">\n" contents "\n</" (.name t) ">"))))
We have to extend the String type to implement the XML protocol
(extend-type java.lang.String
XML
(xml [ev] ev))
Then, test it out on our sample HTML
(println (xml page))
=>
<html>
<body>
<p>
first paragraph
</p>
</body>
</html>
But there are two problems with this. First, the nesting of the contents of each tag is unnatural. And second, the contents of XML tags can have more than one value. For many programmers, the first instinct is to use a list or a vector for the contents. But that throws another type in the mix and leads to a fair amount boiler plate code. There is a better way. We can give each tag a next item that holds the next value in the contents list of the parent tag. And use nil to signal the end of the list.
(deftype Tag [name attr contents next]
Object
(toString [_]
(pr-str name attr contents next)))
(defn tag [name]
(fn [attr contents next]
(Tag. name attr contents next)))
(def html (tag "html"))
(def head (tag "head"))
(def title (tag "title"))
(def body (tag "body"))
(def p (tag "p"))
(def page (html {}
(head {}
(title {} "This Is The Title" nil)
(body {}
(p {} "first paragraph"
(p {} "second paragraph" nil))
nil))
nil))
page
=> #<Tag "html" {} #<Tag "head" {} #<Tag "title" {} "This Is The Title" nil> #<Tag "body" {} #<Tag "p" {} "first paragraph" #<Tag "p" {} "second paragraph" nil>> nil>> nil>
And update the XML protocol function for Tag
(extend-type Tag
XML
(xml [t]
(let [contents (when (.contents t)
(xml (.contents t)))
next (when (.next t)
(str \newline (xml (.next t))))]
(str "<" (.name t) ">\n" contents "\n</" (.name t) ">" next))))
(println (xml page))
=>
<html>
<head>
<title>
This Is The Title
</title>
</head>
<body>
<p>
first paragraph
</p>
<p>
second paragraph
</p>
</body>
</html>
But we still have to write our HTML in that ugly nested form, so what can we do about that? Take a look at the latest definition of the Tag deftype. If you think of it as a container for the contents, with the name and attr fields to be part of the container itself and the next field to be whats contained, a solution begins to appear. Add a smidgen of Category Theory and realize that Tag describes an endofunctor type. That is, a function fmap can be defined for it that will apply a pure function to the contents to produce a new Tag value. It’s trivial to implement.
(require '[effects :refer :all])
(extend-type Tag
EndoFunctor
(fmap [t f]
(Tag. (.name t) (.attr t) (.contents t) (f (.next t)))))
And now, Tag is an endofunctor.
I can hear the “So what?”’s all the way over here.
Consider all the things we can do to the contents of a Tag now. In the simplest case, we can replace the contents with any other value we want. So if we had a list of Tags, we could nest them all together using a reduce.
(reduce (fn [t n] (fmap n (constantly t)))
[(p {} "first" nil)
(p {} "second" nil)
(p {} "third" nil)])
=> #<Tag "p" {} "third" #<Tag "p" {} "second" #<Tag "p" {} "first" nil>>>
Except that has the annoying problem of reversing the order. What we need is a way to go to the innermost Tag value and replace it’s next with the value we want to append to the end of the list. Recursion to the rescue.
(defn fmap-last [t f]
(if (nil? t)
(f nil)
(fmap t #(fmap-last % f))))
(reduce (fn [t n] (fmap-last t (constantly n)))
[(p {} "first" nil)
(p {} "second" nil)
(p {} "third" nil)])
=> #<Tag "p" {} "first" #<Tag "p" {} "second" #<Tag "p" {} "third" nil>>>
And just like that we’ve arrived at the Free Monad, where fmap-last just becomes flat-map. You can find this deftype in the effects.free namespace, so don’t paste it to the REPL.
(deftype Free [val]
Object
(toString [_]
(pr-str val))
Applicative
(wrap [_ v]
(Pure. v))
Monad
(flat-map [_ f]
(Free. (fmap val #(flat-map % f))))
Comonad
(extract [_]
val))
Now you can refer back to the previous post to read about how that works in detail. But the 2 sentence version is that Free takes values that implement fmap and converts them to monadic values that implement flat-map. This means that you can use all the monadic syntax help to compose those values. And for our purposes, we can do this.
(require '[effects.free :refer :all])
(import '[effects.free Free Pure])
(defn tag [name]
(fn [attr & contents]
(let [contents (reduce (fn [ev next]
(flat-map ev (fn [_] next)))
contents)]
(Free. (Tag. name attr contents (Pure. nil))))))
(def html (tag "html"))
(def head (tag "head"))
(def title (tag "title"))
(def body (tag "body"))
(def p (tag "p"))
(def page (html {}
(head {}
(title {} "This Is The Title"))
(body {}
(p {} "first paragraph")
(p {} "second paragraph")
(p {} "third paragraph"))))
So now we can write our HTML in a more natural form and everything gets nested properly. To generate an XML string, we need to implement the XML protocol for the Free and Pure deftypes.
(extend-type Pure
XML
(xml [ev]
(str (extract ev))))
(extend-type Free
XML
(xml [ev]
(xml (extract ev))))
(println (xml page))
=>
<html>
<head>
<title>
This Is The Title
</title>
</head>
<body>
<p>
first paragraph
</p>
<p>
second paragraph
</p>
<p>
third paragraph
</p>
</body>
</html>
Not too shabby, except for the blank lines.
So, to recap, this is what it takes to build a DSL for writing XML in Clojure using the Free Monad:
(require '[effects :refer :all]
'[effects.free :refer :all])
(import '[effects.free Free Pure])
(defprotocol XML
(xml [v]))
(deftype Tag [name attr contents next]
EndoFunctor
(fmap [t f]
(Tag. (.name t) (.attr t) (.contents t) (f (.next t))))
XML
(xml [t]
(let [contents (when (.contents t)
(xml (.contents t)))
next (when (.next t)
(str \newline (xml (.next t))))]
(str "<" (.name t) ">\n" contents "\n</" (.name t) ">" next))))
(extend-type java.lang.String
XML
(xml [ev] ev))
(extend-type Pure
XML
(xml [ev]
(str (extract ev))))
(extend-type Free
XML
(xml [ev]
(xml (extract ev))))
(defn tag [name]
(fn [attr & contents]
(let [contents (reduce (fn [ev next]
(flat-map ev (fn [_] next)))
contents)]
(Free. (Tag. name attr contents (Pure. nil))))))
And then to use it
(def html (tag "html"))
(def head (tag "head"))
(def title (tag "title"))
(def body (tag "body"))
(def p (tag "p"))
(def page (html {}
(head {}
(title {} "This Is The Title"))
(body {}
(p {} "first paragraph")
(p {} "second paragraph")
(p {} "third paragraph"))))
(println (xml page))
All that is kind of interesting, but it’s only the appetizer. The stuff that really amazed me was when I started looking at the Free Monad Transformer. And that’s the subject of the next post.
Jim Duey 02 May 2014