node.ml

module type NAME = 
sig
  type t

  val fresh : unit -> t
end

module type STORAGE = functor (Name : NAME) ->
sig
  type 'a t
  type name = Name.t
  
  val make : unit -> 'a t
  
  val add   : 'a t ->  'a          -> Name.t
  val del   : 'a t ->   Name.t     -> unit
  val iter  : 'a t -> ('a -> unit) -> unit
  val empty : 'a t ->                 bool
end

module type EVENT = 
sig
  type 'a t
  
  val make   : unit -> ('a t * ('a -> unit))
  val map    : ('a -> 'b)             -> ('a t -> 'b t)
  val fold   : ('a -> 'b -> 'b) -> 'b -> ('a t -> 'b t)
  val filter : ('a ->  bool)          -> ('a t -> 'a t)
  val take   :   int                  -> ('a t -> 'a t)
  val drop   :   int                  -> ('a t -> 'a t) 
  
  val merge  : 'a t -> 'a t -> 'a t
  
  val mount  : ('a -> unit) -> 'a t -> unit
  
  val del    : 'a t -> unit
end

module Event (Name : NAME) (Storage : STORAGE) : EVENT =
struct
  module Store = Storage(Name)
  
  type name = Store.name
  
  type 'a t =
    { subscribers : ('a   -> unit) Store.t
    ; scrap       : (unit -> unit) ref
    }

  let skip () = ()
    
  let void () =
    { subscribers = Store.make()
    ; scrap       = ref skip
    }
    
  let make () =
       let event  = void ()
    in let fire a =
      Store.iter event.subscribers @@ fun f -> f a
    in
      (event, fire)
   
  let del node = 
    let f = node.scrap
    in  (!f)()
      
  let tryScrap node =
    if   Store.empty node.subscribers
    then del node
    else ()

  let flip f x y = f y x
  
  let rec zipWith xs ys f =
    match xs, ys with
    | x :: xs, y :: ys -> f x y :: zipWith xs ys f
    | _                -> []
    
  let subscribeTo nodes firer =
       let (event, fire) = make()
    in let names = 
            flip List.map nodes @@ fun node ->
              Store.add node.subscribers @@ firer fire
    in ()
      ; event.scrap := (fun () -> ()
        ; ignore @@
          zipWith nodes names @@ (fun node name -> ()
            ; Store.del node.subscribers name
            ; tryScrap node
          )
      )
      ; event 

  let map f node =
    subscribeTo [node] @@ fun fire a -> fire (f a)

  let fold op accum node =
    let point = ref accum
    in subscribeTo [node] @@ fun fire a -> ()
        ; point := op a !point
        ; fire (!point)
       
  let filter pred node =
    subscribeTo [node] @@ fun fire a ->
      if   pred a 
      then fire a
      else () 

  let merge left right =
    subscribeTo [left; right] @@ (@@)
       
  let take n node =
    let counter = ref n
    in subscribeTo [node] @@ fun fire a ->
      if !counter > 0
      then ()
        ; fire a
        ; counter := !counter - 1
       
  let drop n node =
    let counter = ref n
    in subscribeTo [node] @@ fun fire a ->
      if !counter > 0
      then counter := !counter - 1
      else fire a        
              
  let mount sink node =
    ignore @@ Store.add node.subscribers sink
end

module type Behaviour =
sig
  
end