(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_poll.ml

  Copyright (c) 2003-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

(*
let jout = Cf_journal.stdout
*)

module Fd_order = struct
    type t = Unix.file_descr
    let compare = Pervasives.compare
end

module Fd_map = Cf_rbtree.Map(Fd_order)
    
module Tm_order = struct
    type t = Cf_tai64n.t
    let compare a b = - (Cf_tai64n.compare a b)
end

module Tm_heap = Cf_sbheap.PQueue(Tm_order)

module Sig_order = Cf_ordered.Int_order
module Sig_map = Cf_rbtree.Map(Sig_order)

type t = {
    p_fd_r_aux_: fd_aux_t;
    p_fd_w_aux_: fd_aux_t;
    p_fd_x_aux_: fd_aux_t;
    mutable p_tm_heap_: ((unit -> unit) * Obj.t) Tm_heap.t;
    mutable p_sig_map_: (Sys.signal_behavior * (unit -> unit)) Sig_map.t;
    mutable p_sig_zlist_: int list Lazy.t;
    mutable p_sig_stack_: int list;
    mutable p_idle_queue_: ((Cf_tai64n.t -> unit) * Obj.t) Cf_deque.t;
}
and fd_aux_t = {
    mutable fd_map_: (unit -> unit) Fd_map.t;
    mutable fd_zlist_: Unix.file_descr list Lazy.t
}

type more = More | Last

let fd_aux_create_ () = {
    fd_map_ = Fd_map.nil;
    fd_zlist_ = Lazy.lazy_from_val [];
}

let fd_aux_zlist_ m =
    lazy (Cf_seq.reverse (Cf_seq.first (Fd_map.to_seq_decr m)))

let fd_aux_modify_ f aux =
    let m = f aux.fd_map_ in
    aux.fd_map_ <- m;
    aux.fd_zlist_ <- fd_aux_zlist_ m

let rec fd_service_ aux = function
    | [] ->
        ()
    | hd :: tl ->
        (Fd_map.search hd aux.fd_map_) ();
        fd_service_ aux tl

let tm_compute_ now p =
    try
        let mark, _ = Tm_heap.head p.p_tm_heap_ in
        let dt = Cf_tai64n.sub mark now in
        if dt > 0.0 then dt else 0.0
    with
    | Not_found ->
        -1.0

let rec tm_service_ p now =
    match
        try
            let mark, (call, _) = Tm_heap.head p.p_tm_heap_ in
            let dt = Cf_tai64n.sub mark now in
            if dt > 0.0 then None else Some call
        with
        | Not_found ->
            None
    with
    | None ->
        ()
    | Some call ->
        p.p_tm_heap_ <- Tm_heap.tail p.p_tm_heap_;
        call ();
        tm_service_ p now

let sig_handler_ p n = p.p_sig_stack_ <- n :: p.p_sig_stack_

let sig_zlist_ m =
    lazy (Cf_seq.reverse (Cf_seq.first (Sig_map.to_seq_decr m)))

let sig_register_ p n call =
    let save = Sys.signal n (Sys.Signal_handle (sig_handler_ p)) in
    let m = Sig_map.replace (n, (save, call)) p.p_sig_map_ in
    p.p_sig_map_ <- m;
    p.p_sig_zlist_ <- sig_zlist_ m

let sig_unregister_ p n =
    let (save, _), m = Sig_map.extract n p.p_sig_map_ in
    let _ = Sys.signal n save in
    p.p_sig_map_ <- m;
    p.p_sig_zlist_ <- sig_zlist_ m

let sig_service_ p =
    let rec loop = function
        | hd :: tl ->
            let _, call = Sig_map.search hd p.p_sig_map_ in
            call ();
            loop tl
        | [] ->
            ()
    in
    let stack = p.p_sig_stack_ in
    p.p_sig_stack_ <- [];
    loop stack

let idle_service_ p now =
    match Cf_deque.B.pop p.p_idle_queue_ with
    | Some ((call, _), tl) -> p.p_idle_queue_ <- tl; call now
    | None -> ()

let create () = {
    p_fd_r_aux_ = fd_aux_create_ ();
    p_fd_w_aux_ = fd_aux_create_ ();
    p_fd_x_aux_ = fd_aux_create_ ();
    p_tm_heap_ = Tm_heap.nil;
    p_sig_map_ = Sig_map.nil;
    p_sig_zlist_ = Lazy.lazy_from_val [];
    p_sig_stack_ = [];
    p_idle_queue_ = Cf_deque.nil;
}

type select_t =
    | S_select of ((Unix.file_descr list as 'a) * 'a * 'a)
    | S_error of exn
    | S_interrupt

let cycle p =
    let now = Cf_tai64n.now () in
    let dt = tm_compute_ now p in
    let rlist = Lazy.force p.p_fd_r_aux_.fd_zlist_ in
    let wlist = Lazy.force p.p_fd_w_aux_.fd_zlist_ in
    let xlist = Lazy.force p.p_fd_x_aux_.fd_zlist_ in
    let sigs = Lazy.force p.p_sig_zlist_ in
    let idling = not (Cf_deque.empty p.p_idle_queue_) in
    match rlist, wlist, xlist with
    | [], [], [] when dt < 0.0 && sigs = [] && not idling ->
        (* assert (jout#debug "Cf_poll.cycle: done."); *)
        Last
    | _, _, _ when dt = 0.0 ->
        tm_service_ p now;
        More
    | _, _, _ ->
        if idling then idle_service_ p now;
        (*
        assert begin
            let buf = Buffer.create 32 in
            Buffer.add_char buf '[';
            List.iter begin fun n ->
                Buffer.add_string buf (Printf.sprintf " %d" n);
            end sigs;
            Buffer.add_string buf " ]";
            let sigstr = Buffer.contents buf in
            jout#debug "Cf_poll.cycle: dt=%f sigs=%s fdsetlen=(%d,%d,%d)"
                dt sigstr (List.length rlist) (List.length wlist)
                (List.length xlist)
        end;
        *)
        let save = Unix.sigprocmask Unix.SIG_UNBLOCK sigs in
        let event =
            try
                S_select (Unix.select rlist wlist xlist dt)
            with
            | Unix.Unix_error (e, _, _) when e = Unix.EINTR -> S_interrupt
            | x -> S_error x
        in
        let _ = Unix.sigprocmask Unix.SIG_SETMASK save in
        let now = Cf_tai64n.now () in
        match event with
        | S_select (rlist', wlist', xlist') ->
            fd_service_ p.p_fd_x_aux_ xlist';
            fd_service_ p.p_fd_w_aux_ wlist';
            fd_service_ p.p_fd_r_aux_ rlist';
            tm_service_ p now;
            More
        | S_interrupt ->
            sig_service_ p;
            More
        | S_error e ->
            raise e

exception Not_ready

type 'a state =
    | Unloaded
    | Loaded of t
    | Working of t * 'a
    | Final of 'a
    | Exception of exn

class type ['a] event =
    object        
        val mutable state_: 'a state
        val mutable put_: <get: 'a> Queue.t option

        method private service: t -> 'a state
        method private load_: t -> unit
        method private unload_: t -> unit
        
        method load: ?q:(<get: 'a> Queue.t) -> t -> unit
        method unload: unit
        method canget: bool
        method get: 'a
    end

class virtual ['a] core =
    object(self:'self)
        constraint 'self = 'a #event
        val mutable state_ = Unloaded
        val mutable put_ = None

        method private virtual load_: t -> unit
        method private virtual unload_: t -> unit
        method private virtual service: t -> 'outcome
        
        method private put_ =
            match put_ with
            | Some q -> Queue.add (self :> <get: 'a>) q
            | None -> ()
        
        method private callback_ p () =
            state_ <-
                try
                    match self#service p with
                    | Final _ as s -> self#put_; self#unload_ p; s
                    | (Exception _ | Working (_, _)) as s -> self#put_; s
                    | s -> s
                with
                | e ->
                    self#put_;
                    self#unload_ p;
                    Exception e
        
        method load ?q p =
            match state_ with
            | Loaded p0 when p0 == p->
                put_ <- q
            | Loaded p0 ->
                self#unload_ p0;
                state_ <- Loaded p;
                put_ <- q;
                self#load_ p
            | Working (p0, _) when p0 == p ->
                put_ <- q;
            | Working (p0, v) ->
                self#unload_ p0;
                state_ <- Working (p, v);
                put_ <- q;
                self#load_ p
            | Unloaded
            | Final _
            | Exception _ ->
                state_ <- Loaded p;
                put_ <- q;
                self#load_ p
        
        method unload =
            match state_ with
            | Loaded p ->
                self#unload_ p;
                put_ <- None;
                state_ <- Unloaded
            | Working (p, v) ->
                self#unload_ p;
                put_ <- None;
                state_ <- Final v
            | Unloaded
            | Final _
            | Exception _ ->
                put_ <- None;
                state_ <- Unloaded

        method canget =
            match state_ with
            | (Working _ | Final _ | Exception _) -> true
            | (Loaded _ | Unloaded) -> false

        method get =
            match state_ with
            | (Unloaded | Loaded _) -> raise Not_ready
            | (Working (_, v) | Final v) -> v
            | Exception e -> raise e
    end

type rwx = [ `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 =
    let aux = fd_aux_of_mode_ rwx in
    object(self:'self)
        inherit ['a] core as super

        method private virtual service: t -> 'a state
        
        method private load_ p =
            let aux = aux p in
            let pair = fd, (self#callback_ p) in
            let m, old = Fd_map.insert pair aux.fd_map_ in
            aux.fd_map_ <- m;
            if old = None then aux.fd_zlist_ <- fd_aux_zlist_ m
        
        method private unload_ p =
            let aux = aux p in
            try
                let _, m = Fd_map.extract fd aux.fd_map_ in
                aux.fd_map_ <- m;
                aux.fd_zlist_ <- fd_aux_zlist_ m;
            with
            | Not_found ->
                ()
    end

class virtual ['a] signal (n: int) =
    object
        inherit ['a] core as super

        method private load_ p =
            sig_register_ p n (super#callback_ p)
        
        method private unload_ p =
            sig_unregister_ p n
    end

class virtual ['a] time ?t0 interval =
    object(self:'self)
        inherit ['a] core as super
        
        val mutable epoch_ =
            match t0 with
            | Some epoch -> epoch
            | None -> Cf_tai64n.add (Cf_tai64n.now ()) interval

        method private callback_ p () =
            state_ <- (try self#service p with e -> Exception e);
            begin
                match state_ with
                | Loaded _
                | Working (_, _) ->
                    if interval > 0.0 then begin
                        epoch_ <- Cf_tai64n.add epoch_ interval;
                        self#load_ p
                    end
                | _ ->
                    ()
            end;
            super#put_

        method private load_ p =
            let v = epoch_, (self#callback_ p, Obj.repr self) in
            p.p_tm_heap_ <- Tm_heap.put v p.p_tm_heap_
        
        method private unload_ p =
            let f (_, (_, obj)) = Obj.repr self != obj in
            p.p_tm_heap_ <- Tm_heap.filter f p.p_tm_heap_
    end

class virtual ['a] idle =
    object(self:'self)
        inherit ['a] core as super
        
        val mutable epoch_: Cf_tai64n.t option = None
        
        method private callback_with_time_ p now =
            state_ <- begin
                try
                    epoch_ <- Some now;
                    self#service p
                with
                | e ->
                    epoch_ <- None;
                    Exception e
            end;
            begin
                match state_ with
                | Loaded _
                | Working (_, _) ->
                    self#load_ p
                | _ ->
                    ()
            end;
            super#put_

        method private load_ p =
            epoch_ <- None;
            let v = self#callback_with_time_ p, Obj.repr self in
            p.p_idle_queue_ <- Cf_deque.A.push v p.p_idle_queue_
        
        method private unload_ p =
            epoch_ <- None;
            let f (_, obj) = Obj.repr self != obj in
            p.p_idle_queue_ <- Cf_deque.filter f p.p_idle_queue_
        
        method get =
            let v = super#get in
            epoch_ <- None;
            v
    end

(*--- End of File [ cf_poll.ml ] ---*)