Free Monads in ReasonML

Free.re

module type Functor = {
  type t('a);
  let map: (t('a), 'a => 'b) => t('b);
};

module type Monad = {
  type t('a);
  let return: 'a => t('a);
  let flatMap: (t('a), 'a => t('b)) => t('b);
};

module MonadUtils = (M: Monad) => {
  module Functor = {
    type t('a) = M.t('a);
    let map = (fa, f) => fa->M.flatMap(a => M.return(f(a)));
  };
  module Bind = {
    let let_ = M.flatMap;
  };

  module Map = {
    let let_ = Functor.map;
  };
};

module Free = (F: Functor) => {
  type t('a) =
    | Return('a)
    | Wrap(F.t(t('a)));

  let return = x => Return(x);

  let rec flatMap = (x, f) =>
    switch (x) {
    | Return(x) => f(x)
    | Wrap(x) => Wrap(x->F.map(m => m->flatMap(f)))
    };
};

module IOOp = {
  type t('a) =
    | Print_string(string, 'a)
    | Read_string(string => 'a);
  let map = (x, f) =>
    switch (x) {
    | Print_string(s, cont) => Print_string(s, f(cont))
    | Read_string(cont) => Read_string(str => f(cont(str)))
    };
};

module FreeIO = Free(IOOp);
module IO = MonadUtils(FreeIO);

module IOInterp = {
  let rec unsafePerform = m =>
    switch (m) {
    | FreeIO.Return(x) => x
    | FreeIO.Wrap(x) =>
      switch (x) {
      | IOOp.Print_string(s, cont) =>
        Js.log(s);
        cont->unsafePerform;
      | IOOp.Read_string(cont) => cont("hey there")->unsafePerform
      }
    };
};

let main: FreeIO.t(int) = {
  let print_string = s => FreeIO.Wrap(IOOp.Print_string(s, FreeIO.Return()));
  let read_string =
    FreeIO.Wrap(IOOp.Read_string(str => FreeIO.Return(str)));

  let%IO.Bind () = print_string("What's your name?");
  let%IO.Bind name = read_string;
  let%IO.Bind () = print_string("Hello, " ++ name ++ "!");
  let%IO.Map () = print_string("\n");
  0;
};