Implementation of Free Monads using bwo's Monads library

free.clj

(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))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;