Skip to content

Instantly share code, notes, and snippets.

@roman
Last active Aug 29, 2015
Embed
What would you like to do?
Implementation of Free Monads using bwo's Monads library
(ns util.monads.free
(:require [monads.core :refer :all]
[monads.types :as types]
[clojure.core.match :refer [match]]
[clojure.algo.generic.functor :refer [fmap]]))
(defrecord Free [type functor-value])
(defn pure [val]
(map->Free {:type :pure
:functor-value val}))
(defn free [val]
(map->Free {:type :free
:functor-value val}))
(defmethod fmap Free [f free-val]
(condp (:type free-val) =
:pure (pure (f (:functor-value free-val)))
:free (free (fmap f (:functor-value free-val)))))
(defn lift-f [command]
(free (fmap pure command)))
(defmonad free-m
(mreturn [self val] (pure val))
(bind [self mv mf]
(condp = (:type mv)
:pure (mf (:functor-value mv))
:free (free
(fmap (fn -foobar [lower-mv]
(types/bind self lower-mv mf))
(:functor-value mv))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defrecord ReadInput
[f ;; (input -> next)
])
(defrecord PrintOutput
[output next])
(defmethod fmap ReadInput [f read-input]
(ReadInput. (comp f (:f read-input))))
(defmethod fmap PrintOutput [f print-output]
(PrintOutput. (:output print-output)
(f (:next print-output))))
(defn read-input []
(lift-f (ReadInput. identity)))
(defn print-output [output]
(lift-f (PrintOutput. output nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def toy-example
(mdo
result <- (read-input)
(print-output result)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn pure-interpreter [mv]
(let [instr (run-monad free-m mv)]
(condp = (:type instr)
;;
:pure
(:functor-value instr)
;;
:free
(let [free-val (:functor-value instr)]
(pure-interpreter
(cond
(instance? ReadInput free-val)
(do
((:f free-val) "hola mundo"))
(instance? PrintOutput free-val)
(do
(println "output =>" (:output free-val))
(:next free-val))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn io-interpreter [mv]
(let [instr (run-monad free-m mv)]
(condp = (:type instr)
;;
:pure
(:functor-value instr)
;;
:free
(let [free-val (:functor-value instr)]
(pure-interpreter
(cond
(instance? ReadInput free-val)
(do
((:f free-val) (read-line)))
(instance? PrintOutput free-val)
(do
(println "output =>" (:output free-val))
(:next free-val))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment