Commits

jhwoodyatt  committed f54d388

Allow subclasses [Cf_poll.file] to have more states. Changed the type
parameter of the [event] class to 'state, rather than 'event. Added the
rwx_t convenience type, i.e. type rwx_t = [ `R | `W | `X ]

  • Participants
  • Parent commits d765427

Comments (0)

Files changed (2)

File cf/cf_poll.ml

     | `Exception of exn
 ]
 
-class type ['a] event =
+class type ['s] event =
     object
         constraint 's = [> 'a state_t ]
         
         val mutable state_: 's
         val mutable put_: <get: 'a> Queue.t option
 
-        method private service_: t -> 's
+        method private service: t -> 's
         method private load_: t -> unit
         method private unload_: t -> unit
         
         method get: 'a
     end
 
-class virtual ['a] core =
+class virtual ['s] core =
     object(self:'self)
-        constraint 'self = 'a #event
+        constraint 'self = 's #event
         val mutable state_ = `Unloaded
         val mutable put_ = None
 
-        method virtual private load_: t -> unit
-        method virtual private unload_: t -> unit
-        method virtual private service_: t -> 'outcome
+        method private virtual load_: t -> unit
+        method private virtual unload_: t -> unit
+        method private virtual service: t -> 'outcome
         
         method private put_ =
             match put_ with
         method private callback_ p () =
             state_ <-
                 try
-                    match self#service_ p with
+                    match self#service p with
                     | (`Final _ as s) -> self#put_; self#unload_ p; s
                     | (`Exception _ as s) -> self#put_; s
                     | s -> s
             | _ -> failwith "Cf_poll.get: unknown intermediate state."
     end
 
+type 'a file_state_t = [ 'a state_t | `Working of t * 'a ]
+type rwx_t = [ `R | `W | `X ]
+
 let fd_aux_of_mode_ =
     let r p = p.p_fd_r_aux_ in
     let w p = p.p_fd_w_aux_ in
     let x p = p.p_fd_w_aux_ in
     function `R -> r | `W -> w | `X -> x
 
-class virtual ['a] file rwx fd =
+class virtual ['s] file rwx fd =
     let aux = fd_aux_of_mode_ rwx in
     object(self:'self)
-        constraint 'self = 'a #core
-        constraint 's = [ 'a state_t | `Working of t * 'a ]
-        inherit ['a] core as super
+        constraint 's = [> 'a file_state_t ]
+        inherit ['s] core as super
 
-        method virtual private service_: t -> 's
+        method private virtual service: t -> 's
                 
         method private callback_ p () =
             state_ <-
                 try
-                    let s = self#service_ p in
+                    let s = self#service p in
                     begin
                         match s with
                         | (`Final _ as s) -> self#put_; self#unload_ p
             | _ -> super#get
     end
 
-class virtual ['a] signal (n: int) =
+class virtual ['s] signal (n: int) =
     object(self:'self)
-        constraint 'self = 'a #core
-        inherit ['a] core as super
+        inherit ['s] core as super
 
         method private load_ p =
             sig_register_ p n (super#callback_ p)
             sig_unregister_ p n
     end
 
-class virtual ['a] time tm =
+class virtual ['s] time tm =
     object(self:'self)
-        constraint 'self = 'a #core
-        inherit ['a] core as super
+        inherit ['s] core as super
         
         val mutable epoch_: Cf_tai64n.t = tm
 
         method private callback_ p () =
-            state_ <- (try self#service_ p with e -> `Exception e);
+            state_ <- (try self#service p with e -> `Exception e);
             super#put_
 
         method private load_ p =
             p.p_tm_heap_ <- Tm_heap.filter f p.p_tm_heap_
     end
 
-class virtual ['a] idle =
+class virtual ['s] idle =
     object(self:'self)
-        constraint 'self = 'a #core
-        inherit ['a] core as super
+        inherit ['s] core as super
         
         val mutable epoch_: Cf_tai64n.t option = None
         
             state_ <- begin
                 try
                     epoch_ <- Some now;
-                    self#service_ p
+                    self#service p
                 with
                 | e ->
                     epoch_ <- None;

File cf/cf_poll.mli

 (** The type of objects representing an I/O events that produce results of
     type ['a].
 *)
-class type virtual ['a] event =
+class type virtual ['s] event =
     object
         constraint 's = [> 'a state_t ]
         
         *)
         val mutable put_: <get: 'a> Queue.t option
 
-        (** The [self#service_ p] method is invoked in the cycle for the
+        (** The [self#service p] method is invoked in the cycle for the
             polling mux [p] when the event is ready to be serviced.  The method
             is virtual to accomodate specializations with intermediate state
             and event handling functionality.
         *)
-        method virtual private service_: t -> 's
+        method private virtual service: t -> 's
 
         (** The [self#load_ p] method is invoked in the [load] method to load
             the specialized event into the polling mux [p].
 
 (** Use [cycle p] to wait until one or more of the I/O event objects loaded
     into the mux [p] is ready to be serviced, then service them (which includes
-    invoking their [obj#service_] method).  Returns [Last] if there are no more
+    invoking their [obj#service] method).  Returns [Last] if there are no more
     events loaded into the polling mux.  Otherwise, returns [More].
 *)
 val cycle: t -> more_t
 
+(** File events have a state that represents an intermediate result while the
+    event is still loaded in the mux.
+*)
+type 'a file_state_t = [ 'a state_t | `Working of t * 'a ]
+
+(** File events are associated with read, write or exception I/O events. *)
+type rwx_t = [ `R | `W | `X ]
+
 (** Use [inherit file rwx fd] to derive an I/O event object that waits for the
     file descriptor [fd] to be ready for reading, writing, or exception
     (according to the value of [rwx]).
 *)
-class virtual ['a] file:
-    [< `R | `W | `X ] -> Unix.file_descr ->
+class virtual ['s] file:
+    [< rwx_t ] -> Unix.file_descr ->
     object
-        inherit ['a] event
-        constraint 's = [ 'a state_t | `Working of t * 'a ]
+        inherit ['s] event
+        constraint 's = [> 'a file_state_t ]
         
         (** The method applied during the polling mux cycle whenever the file
             [fd] is ready for I/O.  If the value returned is [`Working
             return [true] and [self#get] will return [v], but the event will
             remain loaded in the polling mux waiting for further events on the
             file descriptor [fd].
+            
+            Note: this type of this method is less general than its declaration
+            in the {!event} class type.  Its return type is constrained by
+            also including the [`Working of t * 'a] variant.
         *)
-        method virtual private service_: t -> 's
+        method private virtual service: t -> 's
     end
 
 (** Use [inherit signal n] to derive an I/O event that is serviced when the
     system delivers the signal [n].
 *)
-class virtual ['a] signal: int -> ['a] event
+class virtual ['s] signal: int -> ['s] event
 
 (** Use [inherit time epoch] to derive an I/O event that is serviced when the
     system clock reaches the time [epoch].
 *)
-class virtual ['a] time:
+class virtual ['s] time:
     Cf_tai64n.t ->
     object
-        inherit ['a] event
+        inherit ['s] event
         
         (** The epoch when the event is to be serviced. *)
         val mutable epoch_: Cf_tai64n.t
 (** Use [inherit idle] to derive an I/O event that is serviced whenever a
     polling mux cycle would otherwise block for any non-zero length of time.
 *)
-class virtual ['a] idle:
+class virtual ['s] idle:
     object
-        inherit ['a] event
+        inherit ['s] event
 
         (** The epoch when the event is was serviced. *)
         val mutable epoch_: Cf_tai64n.t option