freer_file_reader_and_writer.ml

type _ wit = ..

type (_, _, 'e) app = ..

let (%) f g x = f (g x)

module Freer : sig
  type ('a, 'e, 'h) t = private
    | Pure of 'a
    | Impure : 't wit * ('b, 't, 'e) app * ('b -> ('a, 'e, 'h) t) -> ('a, 'e, 'h) t

  val return : 'a -> ('a, [>], [>]) t

  val lift : 't wit -> ('a, 't, 'e) app -> ('a , 'e, [>]) t

  val bind : ('a, [>] as 'e, [>] as 'h) t -> ('a -> ('b, 'e, 'h) t) -> ('b, 'e, 'h) t

  val (>>=) : ('a, [>] as 'e, [>] as 'h) t -> ('a -> ('b, 'e, 'h) t) -> ('b, 'e, 'h) t

  val (>>|) : ('a, [>] as 'e, [>] as 'h) t -> ('a -> 'b) -> ('b, 'e, 'h) t

  module type Wit = sig type w type _ wit += W : w wit end

  type 't wit = (module Wit with type w = 't)

  type ('t, 'e, 'h) inj = { f : 'b. ('b, 't, 'e) app -> ('b, 't, 'h) app}

  type ('t, 'h, 'r) hdl = { f : 'b. ('b, 't, 'h) app -> ('b -> 'r) -> 'r }

  val handle : wit: 't wit
    -> inj: ('t, 'e, 'h) inj
    -> hdl: ('t, 'h, 'r) hdl
    -> dlg: (('r, 'e, 'h) t -> 'r)
    -> cnt: ('a -> 'r)
    -> ('a, [>] as 'e, [>] as 'h) t -> 'r

  val handle0 : wit: 't wit
    -> inj: ('t, 'e, 'h) inj
    -> hdl: ('t, 'h, ('a, 'e, 'h) t) hdl
    -> ('a, [>] as 'e, [>] as 'h) t -> ('a, 'e, 'h) t

  module Run (T : sig type t = private [>] end) : sig
    val run : ('a, T.t, T.t) t -> 'a
  end
end = struct

  type ('a, 'e, 'h) t =
    | Pure of 'a
    | Impure : 't wit * ('b, 't, 'e) app * ('b -> ('a, 'e, 'h) t) -> ('a, 'e, 'h) t

  let return x = Pure x

  let lift w m = Impure (w, m, return)

  let rec bind m f =
    match m with
    | Pure x            -> f x
    | Impure (w, m, f') -> Impure (w, m, fun x -> bind (f' x) f)

  let (>>=) = bind
  let (>>|) x f = x >>= return % f

  module type Wit = sig type w type _ wit += W : w wit end

  type 't wit = (module Wit with type w = 't)

  type ('t, 'e, 'h) inj = { f : 'b. ('b, 't, 'e) app -> ('b, 't, 'h) app}

  type ('t, 'h, 'r) hdl = { f : 'b. ('b, 't, 'h) app -> ('b -> 'r) -> 'r }

  let rec handle :
    type m. wit: m wit -> inj: (m, _, _) inj -> hdl: (m, _, _) hdl -> dlg: _ -> cnt: _ -> _ =
    fun ~wit:((module W) as wit) ~inj ~hdl ~dlg ~cnt ->
      let handle m = handle ~wit ~inj ~hdl ~dlg ~cnt m in
      function
      | Impure (W.W, m, f) -> hdl.f (inj.f m) (handle % f)
      | Impure (w, m, f)   -> dlg @@ Impure (w, m, fun x -> Pure (handle @@ f x))
      | Pure x             -> cnt x

  let rec handle0 :
    type m. wit: m wit -> inj: (m, _, _) inj -> hdl: (m, _, _) hdl -> _ =
    fun ~wit:((module W) as wit) ~inj ~hdl ->
      let handle0 m = handle0 ~wit ~inj ~hdl m in
      function
      | Impure (W.W, m, f) -> hdl.f (inj.f m) (handle0 % f)
      | Impure (w, m, f)   -> Impure (w, m, fun x -> handle0 @@ f x)
      | Pure _ as m        -> m

  module Run (T : sig type t = private [>] end) = struct
    let run = function Pure x -> x | Impure _ -> assert false
  end
end

module type T1 = sig type 'a t end

module Type1 (T : T1) () = struct
  module Wit = struct
    type w = W
    type _ wit += W : w wit
  end

  include Wit

  let wit : w Freer.wit = (module Wit)

  type ('a, 'w, 'e) app += App : 'a T.t -> ('a, w, [>]) app

  let inj0 o = App o

  let prj =
    function
    | App o -> o
    | _     -> assert false

  let inj : _ Freer.inj = { Freer.f = fun x -> inj0 @@ prj x }

  let lift x = Freer.lift W @@ inj0 x
end

module File_reader : sig
  type 'a t =
    | Read_line : string option t
    | Read_char : char option t

  type w

  val wit : w Freer.wit
  val inj0 : 'a t -> ('a, w, [> `Read]) app
  val prj : ('a, w, [> `Read]) app -> 'a t
  val inj : (w, [>], [> `Read]) Freer.inj

  val read_line : unit -> (string option, [> `Read], [>]) Freer.t
  val read_char : unit -> (char option, [> `Read], [>]) Freer.t
end = struct
  module T = struct
    type 'a t =
      | Read_line : string option t
      | Read_char : char option t
  end
  include T
  include Type1 (T) ()

  let read_line () = lift Read_line
  let read_char () = lift Read_char
end

module File_writer : sig
  type 'a t =
    | Write_line : string -> unit t
    | Write_char : char -> unit t

  type w

  val wit : w Freer.wit
  val inj0 : 'a t -> ('a, w, [> `Write]) app
  val prj : ('a, w, [> `Write]) app -> 'a t
  val inj : (w, [>], [> `Write]) Freer.inj

  val write_line : string -> (unit, [> `Write], [>]) Freer.t
  val write_char : char -> (unit, [> `Write], [>]) Freer.t
end = struct
  module T = struct
    type 'a t =
      | Write_line : string -> unit t
      | Write_char : char -> unit t
  end
  include T
  include Type1 (T) ()

  let write_line l = lift @@ Write_line l
  let write_char c = lift @@ Write_char c
end

module Read = struct
  let with_file in_ f =
    let open Freer in
    let open File_reader in
    try
      let ch = open_in in_ in
      let r =
        handle0
          ~wit
          ~inj
          ~hdl:{ f = fun (type r) (m : (r, _, _) app) (k : r -> _) ->
              try
                k @@ match prj m with Read_line -> Some (input_line ch) | Read_char -> Some (input_char ch)
              with
              | End_of_file -> k (match prj m with Read_line -> None | Read_char -> None)
              | _           -> return (Error "Unexpected error") }
          f
      in
      r >>| fun r -> close_in ch; r
    with
    | _ -> return (Error "Unexpected error")
end

module Write = struct
  let with_file out f =
    let open Freer in
    let open File_writer in
    try
      let ch = open_out out in
      let r =
        handle0
          ~wit
          ~inj
          ~hdl:{ f = fun (type r) (m : (r, _, _) app) (k : r -> _) ->
              try
                k @@ match prj m with Write_line l -> output_string ch l | Write_char c -> output_char ch c
              with
              | _ -> return (Error "Unexpected error") }
          f
      in
      r >>| fun r -> close_out ch; r
    with
    | _ -> return (Error "Unexpected error")
end

module Interact = struct
  let with_files ~in_ ~out f =
    let open Freer in
    try
      let in_ = open_in in_ in
      let out = open_out out in
      let read =
        let open File_reader in
        handle
          ~wit
          ~inj
          ~hdl:{ f = fun (type r) (m : (r, _, _) app) (k : r -> _) ->
              try
                k @@ match prj m with Read_line -> Some (input_line in_) | Read_char -> Some (input_char in_)
              with
              | End_of_file -> k (match prj m with Read_line -> None | Read_char -> None) }
          ~dlg:(fun _ -> assert false)
          ~cnt:(fun x -> x)
      in
      let write =
        let open File_writer in
        handle
          ~wit
          ~inj
          ~hdl:{ f = fun (type r) (m : (r, _, _) app) (k : r -> _) ->
              try
                k @@ match prj m with Write_line l -> output_string out l | Write_char c -> output_char out c
              with
              | _ -> Error "Unexpected error"
            }
          ~dlg:read
          ~cnt:(fun x -> Ok x)
      in
      let r = write f in
      close_in in_;
      close_out out;
      r
    with
    | _ -> Error "Unexpected error"
end

let write_default () = Freer.(File_writer.(write_line "Hello!\n"))
let write s i =
  Freer.(File_writer.(
      write_line @@ "Hello, " ^ s ^ " " >>= fun () -> write_char i >>= fun () -> write_char '\n'))
let read () =
  Freer.(File_reader.(read_line () >>= fun surname -> read_char () >>| fun initial -> Ok (surname, initial)))

let test0 =
  let open Freer in
  let module R = Run (struct type t = [`Read | `Write] end) in
  R.run @@
  Read.with_file "input0" @@
  Write.with_file "output0" begin
    read () >>=
    function
    | Ok (Some s, Some i) -> write s i >>| fun () -> Ok ()
    | Ok _ | Error _      -> write_default () >>| fun () -> Ok ()
  end

let test1 =
  let open Freer in
  Interact.with_files ~in_:"input1" ~out:"output1"
    (read () >>= function Ok (Some s, Some i) -> write s i | Ok _ | Error _ -> write_default ())