0 new freer.ml

open Core_kernel

module Free (F : sig type 'a t end) = struct
  type 'a t =
    | Pure : 'a -> 'a t
    | Free : 'x F.t * ('x -> 'a t) -> 'a t 

  type alg = { apply : 'x. 'x F.t -> 'x }

  let pure x = Pure x

  let rec map ~f = function
    | Pure x -> Pure (f x)
    | Free (x, c) -> Free (x, (fun x -> c x |> map ~f))

  let rec bind ~f = function
    | Pure x -> f x
    | Free (x, c) -> Free (x, (fun x -> c x |> bind ~f))

  let rec run alg = function
    | Pure x -> x
    | Free (x, c) -> alg.apply x |> c |> run alg

  let inject cmd = Free (cmd, fun x -> Pure x)

  module Let_syntax = struct
    let map = map
    let return = pure
    let bind = bind
  end

  let for_ xs f =
    List.fold_right xs
      ~init:(pure ())
      ~f:(fun x xs ->
          let%bind _ = f x in
          let%bind _ = xs in
          pure ())

  let when_ cond action =
    if cond then action else pure ()
end



(* --------- *)
(* Example 1 *)

type user_id = int
type balance = int
type email = string

module AppF = struct
  type 'a t =
    | GetUsersIds : user_id list t 
    | GetBalance : user_id -> balance t
    | SendEmail : user_id * email -> unit t
end

module App = struct
  include Free(AppF)

  let get_users_ids = inject GetUsersIds
  let get_balance uid = inject (GetBalance uid)
  let send_email uid email = inject (SendEmail (uid, email))
end

open App

let notify_users_on_empty_balance =
  let%bind users_ids = get_users_ids in
  for_ users_ids (fun user_id ->
      let%bind balance = get_balance user_id in
      when_ (balance <= 0)
        (send_email user_id "Empty balance"))

let fake_app : type a. a AppF.t -> a = function
  | GetUsersIds -> [1; 2; 3]
  | GetBalance 1 -> 100
  | GetBalance _ -> 0
  | SendEmail (user_id, email) ->
    Out_channel.output_lines Out_channel.stdout
      [ "##########################"
      ; "## Message for " ^ Int.to_string user_id
      ; email
      ]

let () = run { apply = fake_app } notify_users_on_empty_balance



(* --------- *)
(* Example 2 *)

module IOF = struct
  type 'a t =
    | Print : string -> unit t
    | Flush : unit t
    | GetLine : string t
end

module IO = struct
  include Free(IOF)

  let print s = inject (Print s)
  let flush = inject Flush
  let get_line = inject GetLine
end

open IO

let prompt msg =
  let%bind _ = print (msg ^ ": ") in
  let%bind _ = flush in
  let%bind value = get_line in
  pure value

let program =
  let%bind name = prompt "name" in
  print ("Hello, " ^ name ^ "!!!\n")

let channels_io : type a. a IOF.t -> a = function
  | Print s -> Out_channel.output_string Out_channel.stdout s
  | Flush -> Out_channel.flush Out_channel.stdout
  | GetLine -> In_channel.input_line_exn In_channel.stdin

let () = run { apply = channels_io } program

1 new freer.re

open Core_kernel;

module Free = (F: {type t('a);}) => {
  type t('a) =
    | Pure('a): t('a)
    | Free(F.t('x), 'x => t('a)): t('a);

  type alg = {apply: 'x. F.t('x) => 'x};

  let pure = x => Pure(x);

  let rec map = (~f, x) =>
    switch (x) {
    | Pure(x) => Pure(f(x))
    | Free(x, c) => Free(x, (x => c(x) |> map(~f)))
    };

  let rec bind = (~f, x) =>
    switch (x) {
    | Pure(x) => f(x)
    | Free(x, c) => Free(x, (x => c(x) |> bind(~f)))
    };

  let rec run = (alg, x) =>
    switch (x) {
    | Pure(x) => x
    | Free(x, c) => c(alg.apply(x)) |> run(alg)
    };

  let inject = cmd => Free(cmd, x => Pure(x));

  module Let_syntax = {
    let map = map;
    let return = pure;
    let bind = bind;
  };
};

/* ------- */
/* Example */

module IOF = {
  type t('a) =
    | Print(string): t(unit)
    | Flush: t(unit)
    | GetLine: t(string);
};

module IO = {
  include Free(IOF);

  let print = s => inject(Print(s));
  let flush = inject(Flush);
  let get_line = inject(GetLine);
};

open IO;

let prompt = msg => {
  let%bind _ = print(msg ++ ": ");
  let%bind _ = flush;
  let%bind value = get_line;
  pure(value);
};

let program = {
  let%bind name = prompt("name");
  print("Hello, " ++ name ++ "!!!\n");
};

let channels_io = (type a, cmd: IOF.t(a)): a =>
  switch (cmd) {
  | Print(s) => Out_channel.output_string(Out_channel.stdout, s)
  | Flush => Out_channel.flush(Out_channel.stdout)
  | GetLine => In_channel.input_line_exn(In_channel.stdin)
  };

run({apply: channels_io}, program);

2 old free-monads-ocaml.re

open Core;

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

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

    let lift: F.t('a) => t('a);

    type alg = {apply: 'x. F.t('x) => 'x};
    let run: (~alg: alg, t('a)) => 'a;

    module Let_syntax: {
      let return: 'a => t('a);
      let bind: (t('a), ~f: 'a => t('b)) => t('b);
    };

    include (module type of Let_syntax);
  };

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

    let lift = m => Free(F.map(~f=x => Pure(x), m));

    type alg = {apply: 'x. F.t('x) => 'x};
    let rec run = (~alg) =>
      fun
      | Pure(x) => x
      | Free(x) => run(~alg, alg.apply(x));

    module Let_syntax = {
      let return = x => Pure(x);
      let rec bind = (m, ~f) =>
        switch (m) {
        | Pure(x) => f(x)
        | Free(m) => Free(F.map(~f=bind(~f), m))
        };
    };

    include Let_syntax;
  };

module IOF = {
  type t('next) =
    | Print(string, 'next)
    | Flush('next)
    | GetLine(string => 'next);

  let map = (~f) =>
    fun
    | Print(s, next) => Print(s, f(next))
    | Flush(next) => Flush(f(next))
    | GetLine(next) => GetLine((s => f(next(s))));
};

module IO = {
  include Free(IOF);

  let print = s => lift(IOF.Print(s, ()));
  let flush = lift(Flush());
  let getLine = lift(IOF.GetLine(ident));
};

open IO;

let prompt: string => IO.t(string) =
  greet => {
    let%bind _ = print(greet ++ ": ");
    let%bind _ = flush;
    /* we can just getLine;, but for more beauty */
    let%bind value = getLine;
    return(value);
  };

let program: IO.t(unit) = {
  let%bind name = prompt("name");
  print("Hello, " ++ name ++ "!!!\n");
};

let eff_io = {
  apply: x =>
    switch (x) {
    | Print(s, next) =>
      Out_channel.output_string(Out_channel.stdout, s);
      next;
    | Flush(next) =>
      Out_channel.flush(Out_channel.stdout);
      next;
    | GetLine(next) => next(In_channel.input_line_exn(In_channel.stdin))
    },
};

run(~alg=eff_io, program);