frp.mli

(* -*- mode: ocaml; -*- *)

module type NEXT =
sig
  type 'a t
  exception Timing_error of int * int 

  val delay  : (unit -> 'a) -> 'a t
  val map    : ('a -> 'b) -> 'a t -> 'b t
  val zip    : 'a t * 'b t -> ('a * 'b) t
  val unzip  : ('a * 'b) t -> 'a t * 'b t
  val ($)    : ('a -> 'b) t -> 'a t -> 'b t   (* This op is redundant but convenient *)
  val fix    : ('a t -> 'a) -> 'a

  (* Use these operations to implement an event loop *)

  module Runtime : sig
    val tick : unit -> unit
    val force : 'a t -> 'a
  end
end

module Next : NEXT = struct
  let time = ref 0

  type 'a t = {
    time : int;
    mutable code : 'a Lazy.t
  }

  type s = Hide : 'a t -> s 
  let thunks : s list ref = ref []

  exception Timing_error of int * int 

  let delay t =
    let t = { time = 1 + !time; code = Lazy.from_fun t} in
    thunks := (Hide t) :: !thunks;
    t

  let force t =
    if t.time != !time then
      raise (Timing_error(t.time, !time))
    else
      Lazy.force t.code

  let map f r = delay (fun () -> f (force r))
  let zip (r, r') = delay (fun () -> (force r, force r'))
  let unzip r = (map fst r, map snd r)
  let ($) f x = delay (fun () -> force f (force x))

  let rec fix f = f (delay (fun () -> fix f))

  module Runtime = struct
    let force = force

    let cleanup (Hide t) =
      let b = t.time < !time in
      (if b then t.code <- lazy (raise (assert false)));
      b

    let tick () =
      time := !time + 1;
      thunks := List.filter cleanup !thunks
  end
end

module Stream :
  sig
    type 'a stream = Cons of 'a * 'a stream Next.t
    val head : 'a stream -> 'a
    val tail : 'a stream -> 'a stream Next.t
    val unfold : ('a -> 'b * 'a Next.t) -> 'a -> 'b stream
    val map : ('a -> 'b) -> 'a stream -> 'b stream
    val zip : 'a stream * 'b stream -> ('a * 'b) stream
    val unzip : ('a * 'b) stream -> 'a stream * 'b stream
  end = 
struct
  open Next

  type 'a stream = Cons of 'a * 'a stream Next.t

  let head (Cons(x, xs)) = x
  let tail (Cons(x, xs)) = xs

  let map f = fix (fun loop (Cons(x, xs)) -> Cons(f x, loop $ xs))

  let unfold f = fix (fun loop seed ->
      let (x, seed) = f seed in
      Cons(x, loop $ seed))

  let zip pair =
    unfold (fun (Cons(x, xs), Cons(y, ys)) -> ((x, y), Next.zip (xs, ys)))
           pair

  let unzip xys = fix (fun loop (Cons((x,y), xys')) ->
                         let (xs', ys') = Next.unzip (loop $ xys') in
                         (Cons(x, xs'), Cons(y, ys')))
                      xys
end

module Event :
  sig
    type 'a event = Now of 'a | Wait of 'a event Next.t
    val map : ('a -> 'b) -> 'a event -> 'b event
    val return : 'a -> 'a event
    val bind : 'a event -> ('a -> 'b event) -> 'b event
    val select : 'a event -> 'a event -> 'a event
  end = 
struct
  open Next

  type 'a event = Now of 'a | Wait of 'a event Next.t

  let map f = fix (fun loop e ->
      match e with
      | Now x -> Now (f x)
      | Wait e' -> Wait (loop $ e'))

  let return x = Now x

  let bind m f =
    fix (fun bind m ->
        match m with 
        | Now v -> f v
        | Wait e' -> Wait (bind $ e'))
      m

  let select e1 e2 =
    fix (fun loop e1 e2 -> 
          match e1, e2 with 
          | Now a1, _ -> Now a1
          | _, Now a2 -> Now a2
          | Wait e1, Wait e2 -> Wait (loop $ e1 $ e2))
      e1
      e2
end
  
module Test =
struct
  open Next
  open Stream

  let ints n = unfold (fun i -> (i, delay(fun () -> i+1))) n 

  let rec run k xs =
    if k = 0
    then ()
    else
      let (x, xs) = (head xs, tail xs) in
      Printf.printf "%d\n" x;
      Runtime.tick();
      run (k-1) (Runtime.force xs)
end

Shouldn't this line be "lazy (assert false)" rather than "lazy (raise (assert false))"?