osiire’s blog

ふしぎなそふとやさん

The FRP

FRPにも色々実装があるみたいだけど、私的にはこれ(http://conal.net/papers/simply-reactive/)がThe FRPのような気がしてきた。簡単さ、動作効率の両面で。実践にも即してるし。
[追記]
FutureをいんちきしてReactとEventを実装してみた(Eventの>>=がまだ)。だけど、ここまで書いて「で、どう使えばいいの?」で止まった :0

module type SigFuture = sig
  type 'a t
  val force : 'a t -> 'a
  val fmap : ('a -> 'b) -> 'a t -> 'b t
  val (<$>) : ('a -> 'b) -> 'a t -> 'b t (* alias of fmap *)
  val pure : 'a -> 'a t
  val zero : 'a t
  val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
  val return : 'a -> 'a t
  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
  val join : 'a t t -> 'a t
  val (<+>) : 'a t -> 'a t -> 'a t
  val of_event : 'a Ccell.Event.event -> 'a t
end

module Future : SigFuture = struct
  type 'a t = 'a Ccell.Event.event
  open Ccell.Event
  let force u = sync u
  let fmap f u = wrap u f
  let (<$>) = fmap
  let pure u = always u
  let zero = Obj.magic (never ())
  let (<*>) f u = wrap f (fun f -> sync (fmap f u))
  let return = pure
  let (>>=) u f = wrap u (fun a -> sync (f a))
  let join uu = wrap uu (fun u -> sync u)
  let (<+>) ua ub = choose [ua; ub]
  let of_event x = x
end

type 'a react = Stepper of 'a lazy_t * 'a event
and 'a event = Ev of 'a react Future.t

let (!$) = Lazy.force

module rec React : sig
  val fmap : ('a -> 'b) -> 'a react -> 'b react
  val (<$>) :  ('a -> 'b) -> 'a react -> 'b react (* alias of fmap *)
  val join : 'a react react -> 'a react
  val switcher : 'a react -> 'a react event -> 'a react
  val (>>=) : 'a react -> ('a -> 'b react) -> 'b react
  val pure : 'a -> 'a react
  val return : 'a -> 'a react
  val sink : ('a -> unit) -> 'a react -> unit
end = struct

  let fmap f (Stepper (a, e)) = Stepper (lazy (f !$a), Event.fmap f e)
  let (<$>) = fmap

  let rec join (Stepper (lazy (Stepper (a, Ev ur)), Ev urr)) =
    let u1 = 
      Future.(<$>) (fun r -> switcher r (Ev urr)) ur
    in
    let u2 =
      Future.(<$>) join urr
    in
    Stepper (a, Ev (Future.(<+>) u1 u2))

  and switcher r er = join (Stepper (lazy r, er))

  let pure x = Stepper (lazy x, Event.zero x)

  let return x = pure x

  let (>>=) r f = join (fmap f r)

  let sink snk (Stepper (lazy a, e)) = 
    snk a;
    Event.sink snk e

end
and Event : sig
  val fmap : ('a -> 'b) -> 'a event -> 'b event
  val zero : 'a -> 'a event
  val (<+>) : 'a event -> 'a event -> 'a event
  val sink : ('a -> unit) -> 'a event -> unit
  val return : 'a -> 'a event
  val of_event : 'a Ccell.Event.event -> 'a event
end = struct

  let fmap f (Ev u) = Ev (Future.fmap (React.fmap f) u)

  let zero x = Ev Future.zero

  let (<+>) (Ev u) (Ev v) = 
    let rec merge u v =
      let infutr f (Stepper (r, Ev u')) =
	Stepper (r, Ev (f u'))
      in
      let u1 =
	Future.(<$>) (infutr (fun v -> merge u v)) u
      in
      let u2 =
	Future.(<$>) (infutr (fun u -> merge u v)) v
      in
      Future.(<+>) u1 u2
    in
    Ev (merge u v)

  let return x =
    Ev (Future.return (React.return x))

  let sink snk (Ev u) = React.sink snk (Future.force u)

  let of_event e =
    Ev (Future.of_event (Ccell.Event.wrap e React.return))
end