Source file Promises.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
(** A minimal implementation of the Promise monad.

    It is an answer to an exercise question in
    {{:https://courses.cs.cornell.edu/cs3110/2021sp/textbook/adv/promises.ml}CS
     3110 - Functional Programming in OCaml - 12.7 Exercises}*)
module PromiseMinimal : sig
  include BuildConstraints.MONAD_PROMISE
  include BuildConstraints.PROMISE_IMPL with type 'a promise = 'a t

  val run_promise : 'a t -> 'a
end = struct
  type resolved_promise_state = unit
  type 'a detailed_state = Pending | Resolved of 'a | Rejected of exn

  type 'a handler = 'a detailed_state -> unit
  (** RI: the input may not be [Pending] *)

  type 'a t = {
    mutable state : 'a detailed_state;
    mutable handlers : 'a handler list;
  }
  (** RI: if [state <> Pending] then [handlers = []]. *)

  type 'a promise = 'a t

  let enqueue (handler : 'a detailed_state -> unit) (promise : 'a t) : unit =
    promise.handlers <- handler :: promise.handlers

  type 'a resolver = 'a t

  (** [write_once p s] changes the state of [p] to be [s]. If [p] and [s] are
      both pending, that has no effect. Raises: [Invalid_arg] if the state of
      [p] is not pending. *)
  let write_once p s =
    if p.state = Pending then p.state <- s else invalid_arg "cannot write twice"

  let make_promise () =
    let p = { state = Pending; handlers = [] } in
    (p, p)

  let return x = { state = Resolved x; handlers = [] }
  let pure = return
  let return_promise = return

  let promise_state (type a) ({ state; handlers = _ } : a t) :
      resolved_promise_state BuildConstraints.universal_promise_state =
    match state with
    | Pending -> Pending
    | Resolved _ -> Resolved ()
    | Rejected exn -> Rejected exn

  (** requires: [st] may not be [Pending] *)
  let resolve_or_reject (r : 'a resolver) (st : 'a detailed_state) =
    assert (st <> Pending);
    let handlers = r.handlers in
    r.handlers <- [];
    write_once r st;
    List.iter (fun f -> f st) handlers

  let reject r x = resolve_or_reject r (Rejected x)
  let resolve r x = resolve_or_reject r (Resolved x)

  let handler (resolver : 'a resolver) : 'a handler = function
    | Pending -> failwith "handler RI violated"
    | Rejected exc -> reject resolver exc
    | Resolved x -> resolve resolver x

  let handler_of_callback (callback : 'a -> 'b t) (resolver : 'b resolver) :
      'a handler = function
    | Pending -> failwith "handler RI violated"
    | Rejected exc -> reject resolver exc
    | Resolved x -> (
        let promise = callback x in
        match promise.state with
        | Resolved y -> resolve resolver y
        | Rejected exc -> reject resolver exc
        | Pending -> enqueue (handler resolver) promise)

  let bind (type a) (type b) (input_promise : a t) (callback : a -> b t) : b t =
    match input_promise.state with
    | Resolved x -> callback x
    | Rejected exc -> { state = Rejected exc; handlers = [] }
    | Pending ->
        let output_promise, output_resolver = make_promise () in
        enqueue (handler_of_callback callback output_resolver) input_promise;
        output_promise

  let bind_promise = bind
  let map f xs = bind xs (fun x -> pure (f x))

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    bind f (fun y -> map y x)

  (** This implemnetation runs sequentially. *)
  let parallel ps =
    let rec aux acc = function
      | [] -> return (List.rev acc)
      | p :: ps' ->
          bind p (fun x ->
              let acc' = x :: acc in
              aux acc' ps')
    in
    aux [] ps

  let run_promise (type a) (x : a t) : a =
    match x with
    | { state = Resolved a; _ } ->
        (* Promise is already resolved. *)
        a
    | { state = Rejected e; _ } ->
        (* TODO: Log the exception? *)
        raise e
    | { state = Pending; _ } -> (
        (* In Pending. Trigger the promise resolution cascade ... *)
        let result = ref None in
        let unit' = map (fun a -> result := Some a) x in
        resolve unit' ();
        (* Check if the resolution was rejected *)
        match (unit', !result) with
        | { state = Resolved (); _ }, Some a -> a
        | { state = Resolved (); _ }, None ->
            failwith "promised handler violation: missed promise resolution"
        | { state = Rejected e; _ }, _ -> raise e
        | { state = Pending; _ }, _ ->
            failwith "promised handler violation: resolution still pending")
end