free_monads_in_ocaml.ml

(* Free monads in OCaml 

Code for my talk:

https://www.youtube.com/live/KdMuSH9pGsw?si=wybc5UCBua-uIzBU

*)

(* Free monads are implemented with the help of these resourses: *)
(*http://rgrinberg.com/posts/free-monads-in-the-wild-ocaml/*)
(*https://gist.github.com/nvanderw/8995984*)


 (*programs as free monadic scripts*) 
module type Functor = sig
  type 'a t
  val fmap : ('a -> 'b) -> 'a t -> 'b t
end

module Free (F : Functor) = struct
  type 'a t =
    | Pure: 'a -> 'a t
    | Roll: ('a t) F.t -> 'a t
    
  let pure a = Pure a
    
  let rec fmap f = function
    | Pure a -> Pure (f a)
    | Roll a -> Roll (F.fmap (fmap f) a)

  let rec join = function
    | Pure a -> a
    | Roll f -> Roll (F.fmap join f)

  let rec bind m f = match m with
    | Pure a -> f a
    | Roll x -> Roll (F.fmap (fun m2 -> bind m2 f) x)

  let (>>=) = bind
  let (>>) m1 m2 = m1 >>= (fun _ -> m2)

  let void_m m = bind m (fun _ -> pure ())
   
  let rec map_m mF its = match its with
    | []      -> pure []
    | i::rest ->
      bind (mF i) (fun v -> 
          bind (map_m mF rest) (fun vals -> pure (v :: vals)
              )
          )
          
  let map_m_ mF its = void_m (map_m mF its)
       
  let rec replicate_m i m = match i with
    | x when x <= 0 -> pure []
    | x -> 
      bind m (fun v -> 
          bind (replicate_m (i - 1) m) (fun vals -> pure (v :: vals)
              )
          )
   
  let replicate_m_ i m = void_m (replicate_m i m)
end

module TerminalF = struct
  type 'a t =
    | GetLine: (string -> 'a) -> 'a t
    | PrintLine: (string * (unit -> 'a)) -> 'a t
    
  let fmap f = function
      | PrintLine (s, nxt) -> PrintLine (s, fun x -> f (nxt x))
      | GetLine nxt -> GetLine (fun x -> f (nxt x))
  
end

module Terminal = struct
  include Free(TerminalF)
  include TerminalF
  let print_line s = Roll (PrintLine (s, pure))
(*  let print_line s = Roll (PrintLine (s, fun i -> Pure i)) *)
  let get_line = Roll (GetLine pure)
(*  let get_line = Roll (GetLine (fun s -> Pure s))*)
end

module TerminalInterpreter = struct
  include Free(TerminalF)
  include TerminalF

  let rec run_terminal m = match m with
      | Pure a -> a
      | Roll f -> match f with
          | GetLine nxt -> 
              let s = "some input from user\n"
              in run_terminal (nxt s)
          | PrintLine (s, nxt) -> begin
            print_string s;
            run_terminal (nxt ())
            end
end

let program2 = 
    let open Terminal in
        void_m
            (map_m (fun v -> print_line ("\"{" ^ v ^ "}\""))
                   [ "abc"; "cde"; "efg" ]
            )

let program =
  let open Terminal in
    (
        replicate_m_ 3 (print_line "Hello world!\n")
    ) 
    >> (
        get_line >>= print_line
    
    )



let _ =  let open Terminal in begin
(*  TerminalInterpreter.run_terminal program;*)
  TerminalInterpreter.run_terminal program2;
(*  print_string "\n\n";*)
(*  TerminalInterpreter.run_terminal (replicate_m_ 4 program2);*)
end



(**)
 (* programs as values - GADT and continuations *) 
(*type 'a terminalF =*)
(*    | GetLine: (string -> (unit terminalF) list) -> unit terminalF*)
(*    | Print: string -> unit terminalF*)

(*let rec run_program : ((unit terminalF) list -> unit) = function*)
(*    | [] -> ()*)
(*    | GetLine nxt :: rest -> begin*)
(*        let s = "some input from user\n" in*)
(*        run_program (nxt s);*)
(*        run_program rest*)
(*        end*)
(*    | Print s :: rest -> begin*)
(*        print_string s;*)
(*        run_program rest*)
(*        end*)
(*    *)
(*let program =*)
(*    [ Print "Hello world!\n"*)
(*    ; GetLine (fun line ->*)
(*        [ Print ("You typed: " ^ line)*)
(*        ])*)
(*    ]*)
(*    *)
(*let _ = run_program program*)

(**)
(*(*simple programs as values*)*)
(*type terminalF =*)
(*    | GetLine of (string -> terminalF list)*)
(*    | Print of string*)
(**)
(*let rec run_simple_program = function *)
(*    | [] -> ()*)
(*    | GetLine nxt :: rest -> begin*)
(*        let s = "some input from user\n" in*)
(*        run_simple_program (nxt s);*)
(*        run_simple_program rest*)
(*        end*)
(*    | Print s :: rest -> begin*)
(*        print_string s;*)
(*        run_simple_program rest*)
(*        end*)
(**)
(*let simple_program : terminalF list =*)
(*  [ Print "Hello world!\n"*)
(*  ; GetLine (fun line ->*)
(*      [ Print ("You typed: " ^ line);*)
(*        GetLine (fun line ->*)
(*        [ Print ("You typed: " ^ line) ]*)
(*        )*)
(*        ]*)
(*      )*)
(*  ]*)
(**)
(*let _ = run_simple_program simple_program*)

(**)
(*(*Usual imperative programs*)*)
(*let _ = begin*)
(*  print_string "Hello world!\n";*)
(*  *)
(*  let strings = [ "abc"; "cde"; "efg" ] in*)
(*  let quoted_strings = List.map (fun s -> "\"" ^ s ^ "\"") strings in*)
(*  print_string (String.concat " " quoted_strings);*)
(*  end*)
(*  *)