Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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 ())
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment