Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft: Implement genserver callbacks #18

Closed
wants to merge 2 commits into from
Closed

Draft: Implement genserver callbacks #18

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
29677f9
Implement more genserver callbacks
dangdennis Dec 19, 2023
7bee446
make handle_cast req polymorphic
dangdennis Dec 19, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 10 additions & 0 deletions riot/lib/gen_server.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@ type 'res req = ..

type Message.t +=
| Call : Pid.t * 'res Ref.t * 'res req -> Message.t
| Cast : 'res req -> Message.t
| Reply : 'res Ref.t * 'res -> Message.t

type 'state init_result = Ok of 'state | Error | Ignore
Expand All @@ -15,6 +16,7 @@ module type Impl = sig
val init : args -> state init_result
val handle_call : 'res. 'res req -> Pid.t -> state -> 'res
val handle_info : Message.t -> state -> unit
val handle_cast : 'res. 'res req -> state -> unit
end

type ('args, 'state) impl =
Expand All @@ -31,6 +33,11 @@ let call : type res. Pid.t -> res req -> res =
| None -> failwith "bad message")
| _ -> failwith "unexpected message"

let cast : type res. Pid.t -> res req -> unit =
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

suggestion. I think we can write this without a locally abstract type since the Cast constructor would already take any type as input.

fun pid req ->
send pid (Cast req);
()

let rec loop : type args state. (args, state) impl -> state -> unit =
fun impl state ->
let (module I : Impl with type args = args and type state = state) = impl in
Expand All @@ -39,6 +46,9 @@ let rec loop : type args state. (args, state) impl -> state -> unit =
let res = I.handle_call req pid state in
send pid (Reply (ref, res));
loop impl state
| Cast req ->
I.handle_cast req state;
loop impl state
| msg ->
let _res = I.handle_info msg state in
loop impl state
Expand Down
2 changes: 2 additions & 0 deletions riot/lib/gen_server.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,10 +10,12 @@ module type Impl = sig
val init : args -> state init_result
val handle_call : 'res req -> Pid.t -> state -> 'res
val handle_info : Message.t -> state -> unit
val handle_cast : 'res req -> state -> unit
end

type ('args, 'state) impl =
(module Impl with type args = 'args and type state = 'state)

val call : Pid.t -> 'res req -> 'res
val cast : Pid.t -> 'res req -> unit
val start_link : ('args, 'state) impl -> 'args -> (Pid.t, exn) result
1 change: 1 addition & 0 deletions riot/riot.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -283,6 +283,7 @@ module Gen_server : sig
val init : args -> state init_result
val handle_call : 'res. 'res req -> Pid.t -> state -> 'res
val handle_info : Message.t -> state -> unit
val handle_cast : 'res. 'res req -> state -> unit
end

type ('args, 'state) impl =
Expand Down
3 changes: 3 additions & 0 deletions test/gen-servers/main.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,6 +38,9 @@ module Twitch = struct
Ok { name = "Jonathan Archer"; email = "[email protected]" }

let handle_info _msg _state = ()

let handle_cast : type res. res Gen_server.req -> state -> unit =
fun req _state -> match req with Profile _ -> ()
end

let start_link ?(verbose = false) () =
Expand Down
Loading