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.