When I wrote about the Free Monad (here), there was something that bugged me. I had to use extend-type
on the Free
and Pure
types to get show
to work properly.
(extend-type Pure
ShowProg
(show [ev]
(str "return" (extract ev) \newline)))
(extend-type Free
ShowProg
(show [ev]
(show (extract ev))))
This problem showed up again in my follow-on post as this:
(extend-type Pure
XML
(xml [ev]
(str (extract ev))))
(extend-type Free
XML
(xml [ev]
(xml (extract ev))))
In addition to having to extend Pure
and Free
, it required the addition of the Comonad
protocol function extract
which I’m still not sure is correct. This was a shortcut I took because I wanted to move on to learning about the Free Applicative Functor (the planned subject of my next post). I figured there was a slick way of dealing with that issue and I found it as a result of this blog post about the Free Applicative.
In both cases, what we want is to evaluate a Free
value created as a result of using the Free Monad. And there’s a common pattern in that the protocol function we’re extending is just recursively descending to the next level in the Free
case and bottoming out in the Pure
case. We can generalize this pattern like this:
(defprotocol FreeProto
(evaluate [_ pure-eval endo-eval]))
(deftype Pure [v]
;; ... rest of Pure's definition
FreeProto
(evaluate [_ pure-eval _]
(pure v)))
(deftype Free [v]
;; ... rest of Free's definition
FreeProto
(evaluate [_ _ endo-eval]
(endo-eval v)))
What the evaluate
function does is takes a free value (of type either Pure
or Free
) along with two functions and returns the result of evaluating it. The pure-eval
function just evaluates whatever value is wrapped in the Pure
type.
The Free
case takes a little explaining. Remember that to use the Free monad, you use the Free
type to wrap a value of an Endofunctor type. That is, a value that has fmap
defined for it. As a result of calling flat-map
on the Free value, the wrapped value actually contains another Free
value.
To show this, remember the definition of our little side-effecting language we looked at earlier:
(deftype Output [b next]
Object
(toString [_]
(pr-str b next))
EndoFunctor
(fmap [_ f]
(Output. b (f next))))
(deftype Bell [next]
Object
(toString [_]
(pr-str next))
EndoFunctor
(fmap [_ f]
(Bell. (f next))))
(deftype Done []
Object
(toString [_]
"")
EndoFunctor
(fmap [_ _]
(Done.)))
(defn output [x] (liftF (Output. x nil)))
(def bell (liftF (Bell. nil)))
(def done (liftF (Done.)))
(I’ve added implementations of toString
so we can print the raw values out.)
And now, if you use flat-map
to write a little program that rings a bell and then is finished, you get this.
(prn (flat-map bell (fn [_] done)))
=> #<Free #<Bell #<Free #<Done >>>>
See how there’s an outer Free
that wraps a Bell
which wraps an inner Free
that contains the Done
? That’s what flat-map
on the Free monad does. It recursively nests wrappings of Free
around endofunctor values.
So now back to evaluate
. The third parameter is a function that takes an endofunctor value and evaluates it, recursing down as needed. Let’s see how that works. First, we have to extend our language to include show
.
(defprotocol ShowProg
(show [_]))
(extend-type Output
ShowProg
(show [ev]
(let [[v x] (extract ev)]
(str "output " v \newline (evaluate x str show)))))
(extend-type Bell
ShowProg
(show [ev]
(let [x (extract ev)]
(str "bell" \newline (evaluate x str show)))))
(extend-type Done
ShowProg
(show [ev]
(str "done" \newline)))
Notice that we use a recursive call to evaluate
to unwrap the next Free
layer. If we bottom out at a Pure
value, we just convert it to string. And that’s all there is to it!
A final outer call to evaluate:
(print (evaluate prog identity show))
=> output :a
output :b
bell
done
Let’s see how this works for the XML language we looked at.
(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 (evaluate (.contents t) str xml)
next (evaluate (.next t) str xml)]
(str "<" (.name t) ">\n" contents "\n</" (.name t) ">"
(str \newline next)))))
(defn tag [name]
(fn [attr & contents]
(let [contents (reduce (fn [ev next]
(flat-map ev (fn [_] next)))
contents)
contents (if (= Free (type contents))
contents
(pure contents))]
(free (Tag. name attr contents (pure nil))))))
Well, that was easy. Now 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"))))
And see what we get
(print (evaluate page str xml))
=>
<html>
<head>
<title>
This Is The Title
</title>
</head>
<body>
<p>
first paragraph
</p>
<p>
second paragraph
</p>
<p>
third paragraph
</p>
</body>
</html>
Looks like it works. No more extending Free
and Pure
.