lib/ax.ml

@@ -2,6 +2,7 @@ open Base
 
 include Unique_id.Ids
 
+module Dyn = Dyn
 module Src = Src
 module Behavior = Behavior
 module Event = Event
@@ -15,7 +16,7 @@ module State = struct
 
   type t =
     { src_vals : Src.values
-    ; conns : Sink_id.t list Src.map
+    ; conns : Sink_id.t list Src_id.map
     ; sinks : sink Sink_id.map }
   and state = t
 
@@ -27,21 +28,21 @@ module State = struct
 
   and to_add =
     [ `Sink of Sink_id.t * sink
-    | `Src of Src.t * Src.value
-    | `Conn of Src.t * Sink_id.t ]
+    | `Src of Src_id.t * Src.value
+    | `Conn of Src_id.t * Sink_id.t ]
 
   and to_del =
     [ `Sink of Sink_id.t
-    | `Src of Src.t ]
+    | `Src of Src_id.t ]
 
   let empty =
-    { src_vals = Src.empty_map
-    ; conns = Src.empty_map
+    { src_vals = Src.empty_values
+    ; conns = Src_id.empty_map
     ; sinks = Sink_id.empty_map }
 
   let of_sources al =
     { empty
-      with src_vals = Map.of_alist_exn (module Src) al }
+      with src_vals = Map.of_alist_exn (module Src_id) al }
 
   (* manipulating state *)
 
@@ -105,7 +106,7 @@ module State = struct
         (to_del', output)
 
       let create_source ctx ~init =
-        let src = Src.create () in
+        let src = Src_id.create () in
         let () = ctx.ctx_src_vals <- Map.set ctx.ctx_src_vals ~key:src ~data:init in
         let () = ctx.to_add <- `Src(src, init) :: ctx.to_add in
         let () = ctx.to_del <- `Src(src) :: ctx.to_del in
@@ -118,8 +119,8 @@ module State = struct
         let () = ctx.to_del <- `Sink(sink_id) :: ctx.to_del in
         sink_id
 
-      let connect ctx src ~sink_id =
-        ctx.to_add <- `Conn(src, sink_id) :: ctx.to_add
+      let connect ctx sink_id src_id =
+        ctx.to_add <- `Conn(src_id, sink_id) :: ctx.to_add
     end)
 
   let inst t env comp =
@@ -162,6 +163,6 @@ module State = struct
     (List.rev upds_rev, t)
 
   let update1 t src fn =
-    update t @@ Map.singleton (module Src) src fn
+    update t (Src.single_effect src fn)
 
 end

lib/behavior.ml

@@ -1,10 +1,13 @@
 open Base
 open Unique_id.Ids
 
+type vars = Src_id.t Var_id.map
+type deps = Src_id.set
+type 'a samp = Src.values -> 'a
+
 type +'a t =
-  { eval :  Src.t Var_id.map
-      -> Src.set * (Src.values -> 'a) } [@@ocaml.unboxed]
-and 'a behavior = 'a t
+  { eval : vars -> deps * 'a samp
+  } [@@ocaml.unboxed]
 
 let unbound_var v =
   Exn.create_s @@
@@ -12,10 +15,10 @@ let unbound_var v =
             ; Sexp.Atom(Var_id.to_string v) ]
 
 let sample_source s =
-  (Set.singleton (module Src) s,
+  (Set.singleton (module Src_id) s,
    fun m -> Map.find_exn m s)
 
-let of_src s =
+let of_src (s : Src_id.t) : Dyn.t t =
   let r = sample_source s in
   { eval = fun _ -> r }
 

lib/comp.ml

@@ -4,8 +4,8 @@ open Unique_id.Ids
 type t =
   | Tree of Tree.tag * t list
   | Dynamic of t Behavior.t
-  | Fold of Src.value * (Event.t -> Src.value -> Src.value) * (Src.t -> t)
-  | Bind of Var_id.t * Src.t * t
+  | Fold of Src.value * (Event.t -> Src.value -> Src.value) * (Src_id.t -> t)
+  | Bind of Var_id.t * Src_id.t * t
 and component = t
 
 let rect w h =
@@ -34,7 +34,7 @@ module type CONTEXT = sig
   val create_source
     :  t
     -> init:Src.value
-    -> Src.t
+    -> Src_id.t
 
   val create_sink
     :  t
@@ -46,8 +46,8 @@ module type CONTEXT = sig
 
   val connect
     :  t
-    -> Src.t
-    -> sink_id:Sink_id.t
+    -> Sink_id.t
+    -> Src_id.t
     -> unit
 
   val capture_deleter
@@ -79,13 +79,13 @@ struct
        let (del, tree) = Ctx.capture_deleter ctx
                            ~f:(fun () -> inst ctx env init_comp) in
        let sink_id = Ctx.create_sink ctx ~env ~tree ~render ~del in
-       let () = Set.iter deps ~f:(Ctx.connect ctx ~sink_id) in
+       let () = Set.iter deps ~f:(Ctx.connect ctx sink_id) in
        tree
 
     | Fold(init, f, make_comp) ->
        let src = Ctx.create_source ctx ~init in
        let env = Env.with_event_handler env
-                   ~f:(fun e -> Map.singleton (module Src) src (f e)) in
+                   ~f:(fun evt -> Src.single_effect src (f evt)) in
        inst ctx env (make_comp src)
 
     | Bind(var, src, comp) ->

lib/dyn.ml

@@ -0,0 +1,15 @@
+type t = ..
+
+class type ['a] rtti =  object
+  method to_dyn : 'a -> t
+  method of_dyn : t -> 'a option
+end
+
+let create_reified (type a) () : a rtti =
+  let module Tag = struct type t += V of a end in
+  object
+    method to_dyn x = Tag.V(x)
+    method of_dyn = function
+      | Tag.V(x) -> Some(x)
+      | _ -> None
+  end

lib/env.ml

@@ -3,7 +3,7 @@ open Unique_id.Ids
 
 type t =
   { event_handlers : Event.handler list
-  ; vars : Src.t Var_id.map }
+  ; vars : Behavior.vars }
 
 let empty =
   { event_handlers = []

lib/src.ml

@@ -1,4 +1,12 @@
-include Unique_id.Ids.Src_id
-type value = int
-type values = value map
-type effect = (value -> value) map
+open Base
+open Unique_id.Ids
+
+type value = Dyn.t
+type values = value Src_id.map
+type effect = (value -> value) Src_id.map
+
+let empty_values : values =
+  Src_id.empty_map
+
+let single_effect src f : effect =
+  Map.singleton (module Src_id) src f

test/test.ml

@@ -7,11 +7,20 @@ module To_del = struct
   type t = State.to_del
   let to_string = function
     | `Sink(id) -> Sink_id.to_string id
-    | `Src(src) -> Src.to_string src
+    | `Src(id) -> Src_id.to_string id
   let equal : t -> t -> bool =
     Polymorphic_compare.(=)
 end
 
+let int  : int  Dyn.rtti = Dyn.create_reified ()
+let bool : bool Dyn.rtti = Dyn.create_reified ()
+
+let to_int_exn x = Option.value_exn (int#of_dyn x)
+let to_bool_exn x = Option.value_exn (bool#of_dyn x)
+
+let lift_int f d = int#to_dyn (f (to_int_exn d))
+let lower_int f d = to_int_exn (f (int#to_dyn d))
+
 ;;
 run_test_tt_main @@
 test_list [
@@ -45,41 +54,45 @@ test_list [
   end;
 
   "Behavior">:::begin
-    let s1 = Src.create () in
-    let s2 = Src.create () in
-    let behav = Behavior.(both (of_src s1) (of_src s2)) in
+    let src_id1 = Src_id.create () in
+    let src_id2 = Src_id.create () in
+    let behav = Behavior.(
+        map (both (of_src src_id1) (of_src src_id2))
+          ~f:(fun (x, y) -> (to_int_exn x, to_bool_exn y))
+      ) in
     let (deps, sample) = behav.eval Var_id.empty_map in
     [
-      t "deps" (module ListUnordered_(Src))
-        [s1;s2]
+      t "deps" (module ListUnordered_(Src_id))
+        [ src_id1 ; src_id2 ]
         (Set.to_list deps);
-      t "sample" (module Pair_(Int)(Int))
-        (3, 4)
-        (sample (Map.of_alist_exn (module Src)
-                   [ s1, 3
-                   ; s2, 4 ]));
+      t "sample" (module Pair_(Int)(Bool))
+        (3, true)
+        (sample (Map.of_alist_exn (module Src_id)
+                   [ src_id1, int#to_dyn 3
+                   ; src_id2, bool#to_dyn true ]));
 
       "of_var">:::begin
-        let v = Var_id.create () in
-        let env_1 = Map.singleton (module Var_id) v s1 in
-        let env_2 = Map.singleton (module Var_id) v s2 in
-        let behav = Behavior.(both (of_src s2) (of_var v)) in
+        let var_id = Var_id.create () in
+        let env_1 = Map.singleton (module Var_id) var_id src_id1 in
+        let env_2 = Map.singleton (module Var_id) var_id src_id2 in
+        let behav = Behavior.(both (of_src src_id2) (of_var var_id)) in
         let (deps_1, sample)  = behav.eval env_1 in
         let (deps_2, _sample) = behav.eval env_2 in
         [
-          t "deps_1" (module ListUnordered_(Src))
-            [s1;s2]
+          t "deps_1" (module ListUnordered_(Src_id))
+            [ src_id1 ; src_id2 ]
             (Set.to_list deps_1);
-          t "deps_2" (module ListUnordered_(Src))
-            [s2]
+          t "deps_2" (module ListUnordered_(Src_id))
+            [ src_id2 ]
             (Set.to_list deps_2);
-          t "sample" (module Pair_(Int)(Int))
-            (3, 4)
-            (sample (Map.of_alist_exn (module Src)
-                       [ s1, 4
-                       ; s2, 3 ]));
+          t "sample" (module Option_(Pair_(Int)(Int)))
+            (Some(3, 4))
+            (sample (Map.of_alist_exn (module Src_id)
+                       [ src_id1, int#to_dyn 4
+                       ; src_id2, int#to_dyn 3 ])
+             |> fun (x, y) -> Option.both (int#of_dyn x) (int#of_dyn y));
           tfail "empty_env"
-            (Behavior.unbound_var v)
+            (Behavior.unbound_var var_id)
             (fun () -> behav.eval Var_id.empty_map);
         ]
       end;
@@ -87,12 +100,21 @@ test_list [
   end;
 
   "Comp">:::begin
-    let s1 = Src.create () in
-    let s2 = Src.create () in
-    let s3 = Src.create () in
-    let state = State.of_sources [ s1, 10 ; s2, 20 ; s3, 30 ] in
+    let s1 = Src_id.create () in
+    let s2 = Src_id.create () in
+    let s3 = Src_id.create () in
+    let state = State.of_sources
+                  [ s1, int#to_dyn 10
+                  ; s2, int#to_dyn 20
+                  ; s3, int#to_dyn 30 ] in
     let dyn_b behav ~f = Comp.Dynamic(Behavior.map behav ~f) in
-    let dyn_s s ~f = dyn_b (Behavior.of_src s) ~f in
+    let dyn_s s ~f = dyn_b (Behavior.(map (of_src s) ~f:to_int_exn)) ~f in
+    let fold ~init ~f g =
+      Comp.fold ~init:(int#to_dyn init) ~f:(fun e -> lift_int (f e))
+        (fun b -> g (Behavior.map b ~f:to_int_exn)) in
+    let fold_var ~init ~f v c =
+      Comp.fold_var ~init:(int#to_dyn init) ~f:(fun e -> lift_int (f e))
+        v c in
     [
       "static">:::(
         let (tree, state) =
@@ -122,8 +144,8 @@ test_list [
           t "sinks" (module ListUnordered_(Sink_id))
             [ sink_id ]
             (Map.keys state.sinks);
-          t "conns" (module MultiMap_(Src)(Sink_id))
-            (Map.of_alist_exn (module Src)
+          t "conns" (module MultiMap_(Src_id)(Sink_id))
+            (Map.of_alist_exn (module Src_id)
                [ s1, [ sink_id ] ])
             state.conns;
         ]);
@@ -144,8 +166,8 @@ test_list [
           t "tree" (module Tree)
             (Tree.rect 10 20)
             tree;
-          t "conns" (module MultiMap_(Src)(Sink_id))
-            (Map.of_alist_exn (module Src)
+          t "conns" (module MultiMap_(Src_id)(Sink_id))
+            (Map.of_alist_exn (module Src_id)
                [ s1, [ sink_id1 ; sink_id2 ] ])
             state.conns;
           t "sink_to_del" (module Map_(Sink_id)(List_(To_del)))
@@ -155,13 +177,13 @@ test_list [
             (Map.map state.sinks ~f:(fun sink -> sink.del))
         ] @
 
-        let (updates, state) = State.update1 state s1 Int.succ in
+        let (updates, state) = State.update1 state s1 (lift_int Int.succ) in
         [
           t "updates" (module List_(Tree))
             [ Tree.rect 11 22 ; Tree.rect 99 99 ]
             (List.map updates ~f:snd);
-          t "updated_conns" (module MultiMap_(Src)(Sink_id))
-            (Map.of_alist_exn (module Src)
+          t "updated_conns" (module MultiMap_(Src_id)(Sink_id))
+            (Map.of_alist_exn (module Src_id)
                [ s1, [ sink_id1 ] ])
             state.conns;
           t "updated_to_del" (module Map_(Sink_id)(List_(To_del)))
@@ -193,8 +215,8 @@ test_list [
           t "tree" (module Tree)
             (Tree.rect 40 50)
             tree;
-          t "conns" (module MultiMap_(Src)(Sink_id))
-            (Map.of_alist_exn (module Src)
+          t "conns" (module MultiMap_(Src_id)(Sink_id))
+            (Map.of_alist_exn (module Src_id)
                [ s1, [ sink_id1 ]
                ; s2, [ sink_id2 ]
                ; s3, [ sink_id3 ] ])
@@ -209,9 +231,9 @@ test_list [
         ] @
         let (updates, _) =
           State.update state @@
-          Map.of_alist_exn (module Src)
-            [ s1, Int.succ
-            ; s3, Int.pred ]
+          Map.of_alist_exn (module Src_id)
+            [ s1, lift_int Int.succ
+            ; s3, lift_int Int.pred ]
         in
         [
           t "updates" (module List_(Tree))
@@ -223,10 +245,11 @@ test_list [
       );
 
       "fold">:::(
-        let s_new = Src.Private.ahead 1 in
+        let s_new = Src_id.Private.ahead 1 in
         let (tree, state) =
           State.mount state @@
-          Comp.fold ~init:4 ~f:(fun (Click(x,y)) i -> i * x + y)
+          fold ~init:4
+            ~f:(fun (Click(x,y)) i -> i * x + y)
             (dyn_b ~f:(fun x -> Comp.rect x (x * 3)))
         in
         let eh = List.hd_exn tree.event_handlers in
@@ -234,17 +257,17 @@ test_list [
           t "tree" (module Tree)
             (Tree.rect 4 12)
             tree;
-          t "src_vals" (module Map_(Src)(Int))
-            (Map.of_alist_exn (module Src)
+          t "src_vals" (module Map_(Src_id)(Int))
+            (Map.of_alist_exn (module Src_id)
                [ s1,10 ; s2,20 ; s3,30 ; s_new,4 ])
-            state.src_vals;
+            (Map.map state.src_vals ~f:to_int_exn);
           t "num_event_handlers" (module Int)
             1 (List.length tree.event_handlers);
-          t "handler_effect" (module Map_(Src)(Int))
-            (Map.of_alist_exn (module Src)
+          t "handler_effect" (module Map_(Src_id)(Int))
+            (Map.of_alist_exn (module Src_id)
                [ s_new, 8899 ])
             (Map.map (eh (Click(100, 99)))
-               ~f:(fun f -> f 88));
+               ~f:(fun f -> to_int_exn (f (int#to_dyn 88))));
         ]
       );
 
@@ -252,8 +275,8 @@ test_list [
         let var = Var_id.create () in
         let (tree, state) =
           State.mount State.empty @@
-          Comp.fold_var var ~init:9 ~f:(fun _ i -> i+1) @@
-          dyn_b (Behavior.of_var var)
+          fold_var var ~init:9 ~f:(fun _ i -> i+1) @@
+          dyn_b (Behavior.(map (of_var var) ~f:to_int_exn))
             ~f:(fun i -> Comp.rect (i * 3) (i * 4))
         in
         [