(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_state_gadget.ml

  Copyright (c) 2004-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. 
 *---------------------------------------------------------------------------*)

type ('i, 'o) kernel = {
    k_writeQ_: 'o Queue.t;
    k_workQ_: (('i, 'o) kernel -> unit) Queue.t;
    k_readQ_: ('i -> unit) Queue.t;
    mutable k_wireN_: int;
}

type ('x, 'i, 'o) rx0 = {
    rx0_txPtr_: ('x, 'i, 'o) tx0 Weak.t;
    rx0_pendQ_: 'x Queue.t;
}
and ('x, 'i, 'o) tx0 = {
    tx0_rxPtr_: ('x, 'i, 'o) rx0 Weak.t;
    tx0_gateQ_: ('x, 'i, 'o) guard0 Queue.t;
}
and ('x, 'i, 'o) guard0 = {
    x0_txLst_: (Obj.t, 'i, 'o) tx0 list;
    x0_getF_: 'x -> ('i, 'o) kernel -> unit;
}

type ('x, 'i, 'o) gate0 = {
    y0_rx_: ('x, 'i, 'o) rx0;
    y0_getF_: 'x -> ('i, 'o) kernel -> unit;    
}

type ('x, 'i, 'o) wire =
    (('x, 'i, 'o) rx0 * ('x, 'i, 'o) tx0) option * string Lazy.t

let kernel_ () = {
    k_writeQ_ = Queue.create ();
    k_workQ_ = Queue.create ();
    k_readQ_ = Queue.create ();
    k_wireN_ = 0;
}

let rx0_ () = {
    rx0_txPtr_ = Weak.create 1;
    rx0_pendQ_ = Queue.create ();
}

let tx0_ () = {
    tx0_rxPtr_ = Weak.create 1;
    tx0_gateQ_ = Queue.create ();
}

let null = None, (Lazy.lazy_from_val "wire[null]")

let rec scheduler_ k =
    if Queue.is_empty k.k_writeQ_ then
        if Queue.is_empty k.k_workQ_ then
            if Queue.is_empty k.k_readQ_ then
                Cf_flow.Z
            else
                let q = Queue.take k.k_readQ_ in
                Cf_flow.Q (fun i -> q i; scheduler_ k)
        else
            let () = Queue.take k.k_workQ_ k in
            scheduler_ k
    else
        Cf_flow.P (Queue.take k.k_writeQ_, lazy (scheduler_ k))

type ('s, 'i, 'o) work = ('i, 'o) kernel -> ('s -> unit) -> 's -> unit
type ('s, 'i, 'o) gate = ('s -> (Obj.t, 'i, 'o) gate0) Cf_seq.t

type ('s, 'i, 'o, 'a) guard = (('s, 'i, 'o) gate, 'a) Cf_cmonad.t
type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) work, 'a) Cf_cmonad.t

let work_ m s k = m (fun () _ f s -> f s) k (fun _ -> ()) s

let eval m s =
    let k = kernel_ () in
    work_ m s k;
    lazy (scheduler_ k)

let start m s c k =
    Queue.add (work_ m s) k.k_workQ_;
    c () k

let pushGuard_ txLst (tx0, getF) =
    Queue.add { x0_txLst_ = txLst; x0_getF_ = getF } tx0.tx0_gateQ_

let rec match1_ k txLst gLst z = 
    match Lazy.force z with
    | Cf_seq.Z ->
        List.iter (pushGuard_ txLst) gLst
    | Cf_seq.P (y0, z) ->
        let { y0_rx_ = rx0; y0_getF_ = getF } = y0 in
        match Weak.get rx0.rx0_txPtr_ 0 with
        | None ->
            match1_ k txLst gLst z
        | Some tx0 ->
            match
                try Some (Queue.take rx0.rx0_pendQ_)
                with Queue.Empty -> None
            with
            | Some obj ->
                Queue.add (getF obj) k.k_workQ_
            | None ->
                match1_ k (tx0 :: txLst) ((tx0, getF) :: gLst) z

let guard m _ k _ s =
    match1_ k [] [] (Cf_seq.map (fun g -> g s) (Cf_seq.evalC m))

let abort _ _ _ _ = ()

let id_ n = lazy (Printf.sprintf "%08u" n)

let wire c k =
    let n = succ k.k_wireN_ in
    k.k_wireN_ <- n;
    let id = id_ n in
    let rx = rx0_ () and tx = tx0_ () in
    Weak.set tx.tx0_rxPtr_ 0 (Some rx);
    Weak.set rx.rx0_txPtr_ 0 (Some tx);
    c (Some (rx, tx), id) k

let wirepair c k =
    let n0 = succ k.k_wireN_ in
    let n1 = succ n0 in
    k.k_wireN_ <- n1;
    let idA = id_ n0 and idB = id_ n1 in
    let rxA = rx0_ () and rxB = rx0_ () in
    let txA = tx0_ () and txB = tx0_ () in
    Weak.set rxA.rx0_txPtr_ 0 (Some txA);
    Weak.set rxB.rx0_txPtr_ 0 (Some txB);
    Weak.set txA.tx0_rxPtr_ 0 (Some rxA);
    Weak.set txB.tx0_rxPtr_ 0 (Some rxB);
    c ((Some (rxA, txA), idA), (Some (rxB, txB), idB)) k

class type connector =
    object
        method check: bool
        method id: string
    end

class ['x, 'i, 'o] rx (w, id : ('x, 'i, 'o) wire) =
    let rx0 =
        match w with
        | Some (rx0, _) -> rx0
        | None -> rx0_ ()
    in
    object        
        val rx0_ = rx0
        
        method id = Lazy.force id
        method check = Weak.check rx0_.rx0_txPtr_ 0

        method get:
            's. ('x -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard =
            fun f ->
                if Weak.check rx0_.rx0_txPtr_ 0 then begin
                    Cf_seq.writeC begin fun s ->
                        let g obj = work_ (f obj) s in
                        Obj.magic { y0_rx_ = rx0; y0_getF_ = g }
                    end
                end
                else begin
                    Queue.clear rx0_.rx0_pendQ_;
                    Cf_cmonad.nil
                end
    end

class ['x, 'i, 'o] tx (w, id : ('x, 'i, 'o) wire) =
    let tx0 =
        match w with
        | Some (_, tx0) -> tx0
        | None -> tx0_ ()
    in
    object        
        val tx0_ = tx0

        method id = Lazy.force id
        method check = Weak.check tx0_.tx0_rxPtr_ 0
        
        method put:
            's. 'x -> ('s, 'i, 'o, unit) t =
            fun obj c k f s ->
                begin
                    match
                        try Some (Queue.take tx0.tx0_gateQ_)
                        with Queue.Empty -> None
                    with
                    | Some x0 ->
                        let x0: (Obj.t, 'i, 'o) guard0 = Obj.magic x0 in
                        let obj = Obj.repr obj in
                        List.iter begin fun tx0 ->
                            let q = Queue.create () in
                            Queue.iter begin fun x0' ->
                                if x0'.x0_txLst_ != x0.x0_txLst_ then
                                    Queue.add x0' q
                            end tx0.tx0_gateQ_;
                            Queue.clear tx0.tx0_gateQ_;
                            Queue.transfer q tx0.tx0_gateQ_
                        end x0.x0_txLst_;
                        Queue.add (x0.x0_getF_ obj) k.k_workQ_
                    | None ->
                        match Weak.get tx0_.tx0_rxPtr_ 0 with
                        | None ->
                            Queue.clear tx0_.tx0_gateQ_
                        | Some rx0 ->
                            Queue.add obj rx0.rx0_pendQ_
                end;
                Queue.add (fun _ -> c () k f s) k.k_workQ_
    end

let simplex c = wire (fun w -> c (new rx w, new tx w))

type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx
type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx

let duplex c =
    wirepair (fun (a, b) -> c ((new rx a, new tx b), (new rx b, new tx a)))

let read c k f s =
    Queue.add (fun i -> c i k f s) k.k_readQ_

let write x c k f s =
    Queue.add x k.k_writeQ_;
    Queue.add (fun _ -> c () k f s) k.k_workQ_

let load c k f s = (c s) k f s
let store s c k f _ = c () k f s
let modify g c k f s = c () k f (g s)

open Cf_cmonad.Op

let wrap x y =
    let x = (x :> ('x, 'i, 'o) rx) in
    let y = (y :> ('y, 'i, 'o) tx) in
    let rec loop w =
        match Lazy.force w with
        | Cf_flow.Z ->
            Cf_cmonad.nil
        | Cf_flow.P (hd, tl) ->
            y#put hd >>= fun () ->
            loop tl
        | Cf_flow.Q f ->
            guard (x#get (fun obj -> loop (lazy (f obj))))
    in
    fun w ->
        start (loop w) ()

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