copied from js_of_ocaml/toplevel/examples/lwt_toplevel

examples.ml

@@ -0,0 +1,231 @@
+(** Overview *)
+
+let x = 10 + 10
+
+let y = x * 3
+
+let c = String.make x 'a'
+
+let sin1 = sin 1.
+
+let rec fact n = if n = 0 then 1. else float n *. fact (n - 1)
+
+let _ = Printf.printf "fact 20 = %f\n" (fact 20)
+
+let _ = "abc" < "def"
+
+(** Mutually recursive function *)
+
+let rec even n =
+  match n with
+  | 0 -> true
+  | x -> odd (x - 1)
+
+and odd n =
+  match n with
+  | 0 -> false
+  | x -> even (x - 1)
+
+(** Mutually recursive module *)
+
+module rec Odd : sig
+  val odd : int -> bool
+end = struct
+  let odd x = if x = 0 then false else Even.even (pred x)
+end
+
+and Even : sig
+  val even : int -> bool
+end = struct
+  let even x = if x = 0 then true else Odd.odd (pred x)
+end
+
+(** Reactive dom *)
+
+open Js_of_ocaml
+open Js_of_ocaml_lwt
+open Js_of_ocaml_tyxml
+
+let display x =
+  Dom.appendChild (Dom_html.getElementById "output") (Tyxml_js.To_dom.of_element x)
+
+module RList = ReactiveData.RList
+
+let rl, rhandle = RList.create []
+
+let li_rl = RList.map (fun x -> Tyxml_js.Html.(li [ txt x ])) rl
+
+let ul_elt = Tyxml_js.R.Html.ul li_rl
+
+let init =
+  let _ = RList.snoc "# cons \"some string\"" rhandle in
+  let _ = RList.snoc "# snoc \"some other\"" rhandle in
+  let _ = RList.snoc "# insert \"anywhere\" 1" rhandle in
+  let _ = RList.snoc "# remove 1" rhandle in
+  ()
+
+let snoc s = RList.snoc s rhandle
+
+let cons s = RList.cons s rhandle
+
+let insert s pos = RList.insert s pos rhandle
+
+let remove pos = RList.remove pos rhandle
+
+let time_signal =
+  let s, set = React.S.create (Sys.time ()) in
+  let rec loop () : unit Lwt.t =
+    set (Sys.time ());
+    Lwt.bind (Lwt_js.sleep 1.) loop
+  in
+  Lwt.async loop;
+  s
+
+let div_elt =
+  Tyxml_js.(
+    Html.(
+      div
+        [ h4
+            [ txt "Uptime is "
+            ; R.Html.txt
+                (React.S.map (fun s -> string_of_int (int_of_float s)) time_signal)
+            ; txt " s"
+            ]
+        ; ul_elt
+        ]))
+
+let _ = display div_elt
+
+(** Graphics: Draw *)
+
+open Graphics_js
+
+let () =
+  loop [ Mouse_motion ] (function { mouse_x = x; mouse_y = y } -> fill_circle x y 5)
+
+(** Graphics: Draw chars*)
+
+open Graphics_js
+
+let () =
+  loop [ Mouse_motion; Key_pressed ] (function
+      | { key = '\000'; _ } -> ()
+      | { mouse_x = x; mouse_y = y; key } ->
+          moveto x y;
+          draw_char key)
+
+(** Graphics: PingPong *)
+
+open Js_of_ocaml_lwt
+open Graphics_js
+
+let c = 3
+
+let x0 = 0
+
+and x1 = size_x ()
+
+and y0 = 0
+
+and y1 = size_y ()
+
+let draw_ball x y =
+  set_color foreground;
+  fill_circle x y c
+
+let state = ref (Lwt.task ())
+
+let wait () = fst !state
+
+let rec pong_aux x y dx dy =
+  draw_ball x y;
+  let new_x = x + dx and new_y = y + dy in
+  let new_dx = if new_x - c <= x0 || new_x + c >= x1 then -dx else dx
+  and new_dy = if new_y - c <= y0 || new_y + c >= y1 then -dy else dy in
+  Lwt.bind (wait ()) (fun () -> pong_aux new_x new_y new_dx new_dy)
+
+let rec start () =
+  let t = Lwt.task () in
+  let _, w = !state in
+  state := t;
+  clear_graph ();
+  Lwt.wakeup w ();
+  Lwt.bind (Lwt_js.sleep (1. /. 60.)) start
+
+let pong x y dx dy = pong_aux x y dx dy
+
+let _ = pong 111 87 2 3
+
+let _ = pong 28 57 5 3
+
+let _ = start ()
+
+(** Effect handler *)
+
+module Txn : sig
+  type 'a t
+
+  val atomically : (unit -> unit) -> unit
+
+  val ref : 'a -> 'a t
+
+  val ( ! ) : 'a t -> 'a
+
+  val ( := ) : 'a t -> 'a -> unit
+end = struct
+  open Effect
+  open Effect.Deep
+
+  type 'a t = 'a ref
+
+  type _ Effect.t += Update : 'a t * 'a -> unit Effect.t
+
+  let atomically f =
+    let comp =
+      match_with
+        f
+        ()
+        { retc = (fun x _ -> x)
+        ; exnc =
+            (fun e rb ->
+              rb ();
+              raise e)
+        ; effc =
+            (fun (type a) (e : a Effect.t) ->
+              match e with
+              | Update (r, v) ->
+                  Some
+                    (fun (k : (a, _) continuation) rb ->
+                      let old_v = !r in
+                      r := v;
+                      continue k () (fun () ->
+                          r := old_v;
+                          rb ()))
+              | _ -> None)
+        }
+    in
+    comp (fun () -> ())
+
+  let ref = ref
+
+  let ( ! ) = ( ! )
+
+  let ( := ) r v = perform (Update (r, v))
+end
+
+let example () =
+  let open Txn in
+  let exception Res of int in
+  let r = ref 10 in
+  Printf.printf "T0: %d\n" !r;
+  try
+    atomically (fun () ->
+        r := 20;
+        r := 21;
+        Printf.printf "T1: Before abort %d\n" !r;
+        raise (Res !r) |> ignore;
+        Printf.printf "T1: After abort %d\n" !r;
+        r := 30)
+  with Res v ->
+    Printf.printf "T0: T1 aborted with %d\n" v;
+    Printf.printf "T0: %d\n" !r