Commits

Anonymous committed ca07fc4

switch-servers: compiled, not tested

Comments (0)

Files changed (2)

       [ `Local f -> f v ]
     ;
 
+    value (dest_pre_map : ('a -> 'b) -> dest 'b -> dest 'a) m d =
+      match d with
+      [ `Local f -> `Local (fun x -> f (m x)) ]
+    ;
+
     value _notimpl msg = failwith
       (Printf.sprintf "function %S: not implemented" msg);
 
       () =
         create_server_group () >>= fun group ->
         create_process group
-          (fun _ctx ->
-             let ctx_for_serv = (ctx_for_proc :> server_context _ _) in
-             let disp_ctx = server_disp ctx_for_serv in
-
-              where rec server_loop (arg, dest) =
-               disp_ctx arg >>= fun res ->
-               dest_put dest res >>= fun () ->
-               ctx_for_proc#continue server_loop
-
+          (fun ctx ->
              let workers = ref (Map.empty key_cmp) in
-             fun
-             [ `Add_worker (k, w) ->
+             loop
+             where rec loop = fun
+             [ (`Add_worker (k, w), dest) ->
                  ( workers.val := Map.add k w workers.val
-                 ; IO.return `Worker_added
+                 ; dest_put dest `Worker_added >>= fun () ->
+                   ctx#continue loop
                  )
-             | `Call (k, i) ->
+             | (`Call (k, i), dest) ->
                  match Map.find_opt workers.val k with
-                 [ None -> IO.return `No_worker_found
-                 | Some w ->
-                     ,
+                 [ None ->
+                     dest_put dest `No_worker_for_key >>= fun () ->
+                     ctx#continue loop
+                 | Some w -> send w
+                     ( i
+                     , dest_pre_map (fun r -> `Ok r) dest
+                     ) >>= fun () ->
+                     ctx#continue loop
                  ]
              ]
           )
       IO.m (switch 'k 'i 'o)
     ;
 
-    value add_worker : switch 'k 'i 'o ->
-      'k -> server 'i 'o -> IO.m unit
+    value add_worker : switch 'k 'i 'o -> 'k -> server 'i 'o -> IO.m unit
     ;
 
     value call_switch : switch 'k 'i 'o -> 'k -> 'i -> IO.m 'o