From 0f1fd67e8aaee14d45fc4b22a213183cdcd3fd1f Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 10 Feb 2024 16:52:36 -0600 Subject: [PATCH] copied from js_of_ocaml/toplevel/examples/lwt_toplevel --- b64.ml | 82 ++++++ b64.mli | 40 +++ colorize.fake.ml | 28 ++ colorize.higlo.ml | 39 +++ colorize.mli | 9 + dune | 150 +++++++++++ dune-project | 2 + effects_flags.ml | 15 ++ examples.ml | 231 ++++++++++++++++ graphics_support.disabled.ml | 1 + graphics_support.enabled.ml | 1 + indent.ml | 43 +++ indent.mli | 3 + index.html | 233 +++++++++++++++++ ocp_indent.fake.ml | 3 + ocp_indent.ok.ml | 14 + ppx_support.disabled.ml | 1 + ppx_support.enabled.ml | 1 + test_dynlink.ml | 3 + toplevel.ml | 492 +++++++++++++++++++++++++++++++++++ 20 files changed, 1391 insertions(+) create mode 100644 b64.ml create mode 100644 b64.mli create mode 100644 colorize.fake.ml create mode 100644 colorize.higlo.ml create mode 100644 colorize.mli create mode 100644 dune create mode 100644 dune-project create mode 100644 effects_flags.ml create mode 100644 examples.ml create mode 100644 graphics_support.disabled.ml create mode 100644 graphics_support.enabled.ml create mode 100644 indent.ml create mode 100644 indent.mli create mode 100644 index.html create mode 100644 ocp_indent.fake.ml create mode 100644 ocp_indent.ok.ml create mode 100644 ppx_support.disabled.ml create mode 100644 ppx_support.enabled.ml create mode 100644 test_dynlink.ml create mode 100644 toplevel.ml diff --git a/b64.ml b/b64.ml new file mode 100644 index 0000000..5350ace --- /dev/null +++ b/b64.ml @@ -0,0 +1,82 @@ +(* + * Copyright (c) 2006-2009 Citrix Systems Inc. + * Copyright (c) 2010 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + *) + +let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +let uri_safe_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" + +let padding = '=' + +let of_char ?(alphabet = default_alphabet) x = + if x = padding then 0 else String.index alphabet x + +let to_char ?(alphabet = default_alphabet) x = alphabet.[x] + +let decode ?alphabet input = + let length = String.length input in + let input = + if length mod 4 = 0 then input else input ^ String.make (4 - (length mod 4)) padding + in + let length = String.length input in + let words = length / 4 in + let padding = + match length with + | 0 -> 0 + | _ when input.[length - 2] = padding -> 2 + | _ when input.[length - 1] = padding -> 1 + | _ -> 0 + in + let output = Bytes.make ((words * 3) - padding) '\000' in + for i = 0 to words - 1 do + let a = of_char ?alphabet input.[(4 * i) + 0] + and b = of_char ?alphabet input.[(4 * i) + 1] + and c = of_char ?alphabet input.[(4 * i) + 2] + and d = of_char ?alphabet input.[(4 * i) + 3] in + let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in + let x = (n lsr 16) land 255 and y = (n lsr 8) land 255 and z = n land 255 in + Bytes.set output ((3 * i) + 0) (char_of_int x); + if i <> words - 1 || padding < 2 then Bytes.set output ((3 * i) + 1) (char_of_int y); + if i <> words - 1 || padding < 1 then Bytes.set output ((3 * i) + 2) (char_of_int z) + done; + Bytes.unsafe_to_string output + +let encode ?(pad = true) ?alphabet input = + let length = String.length input in + let words = (length + 2) / 3 in + (* rounded up *) + let padding_len = if length mod 3 = 0 then 0 else 3 - (length mod 3) in + let output = Bytes.make (words * 4) '\000' in + let get i = if i >= length then 0 else int_of_char input.[i] in + for i = 0 to words - 1 do + let x = get ((3 * i) + 0) and y = get ((3 * i) + 1) and z = get ((3 * i) + 2) in + let n = (x lsl 16) lor (y lsl 8) lor z in + let a = (n lsr 18) land 63 + and b = (n lsr 12) land 63 + and c = (n lsr 6) land 63 + and d = n land 63 in + Bytes.set output ((4 * i) + 0) (to_char ?alphabet a); + Bytes.set output ((4 * i) + 1) (to_char ?alphabet b); + Bytes.set output ((4 * i) + 2) (to_char ?alphabet c); + Bytes.set output ((4 * i) + 3) (to_char ?alphabet d) + done; + for i = 1 to padding_len do + Bytes.set output (Bytes.length output - i) padding + done; + if pad + then Bytes.unsafe_to_string output + else Bytes.sub_string output 0 (Bytes.length output - padding_len) diff --git a/b64.mli b/b64.mli new file mode 100644 index 0000000..5210809 --- /dev/null +++ b/b64.mli @@ -0,0 +1,40 @@ +(* + * Copyright (c) 2006-2009 Citrix Systems Inc. + * Copyright (c) 2010 Thomas Gazagnaire + * Copyright (c) 2014-2016 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + *) + +(** Base64 RFC4648 implementation. + + Base64 is a group of similar binary-to-text encoding schemes that represent binary + data in an ASCII string format by translating it into a radix-64 representation. It + is specified in RFC 4648. *) + +val default_alphabet : string +(** A 64-character string specifying the regular Base64 alphabet. *) + +val uri_safe_alphabet : string +(** A 64-character string specifying the URI- and filename-safe Base64 alphabet. *) + +val decode : ?alphabet:string -> string -> string +(** [decode s] decodes the string [s] that is encoded in Base64 format. Will leave + trailing NULLs on the string, padding it out to a multiple of 3 characters. + [alphabet] defaults to {!default_alphabet}. + @raise Not_found if [s] is not a valid Base64 string. *) + +val encode : ?pad:bool -> ?alphabet:string -> string -> string +(** [encode s] encodes the string [s] into base64. If [pad] is false, no trailing padding + is added. [pad] defaults to [true], and [alphabet] to {!default_alphabet}. *) diff --git a/colorize.fake.ml b/colorize.fake.ml new file mode 100644 index 0000000..3110ef4 --- /dev/null +++ b/colorize.fake.ml @@ -0,0 +1,28 @@ +open Js_of_ocaml +open Js_of_ocaml_tyxml + +let text ~a_class:cl s = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) + +let ocaml = text + +let highlight from_ to_ e = + match Js.Opt.to_option e##.textContent with + | None -> assert false + | Some x -> + let x = Js.to_string x in + let (`Pos from_) = from_ in + let to_ = + match to_ with + | `Pos n -> n + | `Last -> String.length x - 1 + in + e##.innerHTML := Js.string ""; + let span kind s = + if s <> "" + then + let span = Tyxml_js.Html.(span ~a:[ a_class [ kind ] ] [ txt s ]) in + Dom.appendChild e (Tyxml_js.To_dom.of_element span) + in + span "normal" (String.sub x 0 from_); + span "errorloc" (String.sub x from_ (to_ - from_)); + span "normal" (String.sub x to_ (String.length x - to_)) diff --git a/colorize.higlo.ml b/colorize.higlo.ml new file mode 100644 index 0000000..09eccea --- /dev/null +++ b/colorize.higlo.ml @@ -0,0 +1,39 @@ +open Js_of_ocaml +open Js_of_ocaml_tyxml + +let text ~a_class:cl s = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) + +let ocaml ~a_class:cl s = + let tks = Higlo.Lang.parse ~lang:"ocaml" s in + let span' cl (s, _) = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) in + let make_span = function + | Higlo.Lang.Bcomment s -> span' "comment" s + | Higlo.Lang.Constant s -> span' "constant" s + | Higlo.Lang.Directive s -> span' "directive" s + | Higlo.Lang.Escape s -> span' "escape" s + | Higlo.Lang.Id s -> span' "id" s + | Higlo.Lang.Keyword (level, s) -> span' (Printf.sprintf "kw%d" level) s + | Higlo.Lang.Lcomment s -> span' "comment" s + | Higlo.Lang.Numeric s -> span' "numeric" s + | Higlo.Lang.String s -> span' "string" s + | Higlo.Lang.Symbol (level, s) -> span' (Printf.sprintf "sym%d" level) s + | Higlo.Lang.Text s -> span' "text" s + | Higlo.Lang.Title (_, s) -> span' "text" s + in + Tyxml_js.Html.(div ~a:[ a_class [ cl ] ] (List.map make_span tks)) + +let highlight (`Pos from_) to_ e = + let _ = + List.fold_left + (fun pos e -> + match Js.Opt.to_option (Dom_html.CoerceTo.element e) with + | None -> pos + | Some e -> + let size = Js.Opt.case e##.textContent (fun () -> 0) (fun t -> t##.length) in + if pos + size > from_ && (to_ = `Last || `Pos pos < to_) + then e##.classList##add (Js.string "errorloc"); + pos + size) + 0 + (Dom.list_of_nodeList e##.childNodes) + in + () diff --git a/colorize.mli b/colorize.mli new file mode 100644 index 0000000..b274e9b --- /dev/null +++ b/colorize.mli @@ -0,0 +1,9 @@ +open Js_of_ocaml +open Js_of_ocaml_tyxml + +val text : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt + +val ocaml : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt + +val highlight : + [ `Pos of int ] -> [ `Last | `Pos of int ] -> Dom_html.element Js.t -> unit diff --git a/dune b/dune new file mode 100644 index 0000000..d296456 --- /dev/null +++ b/dune @@ -0,0 +1,150 @@ +(executables + (names toplevel) + (libraries + js_of_ocaml-compiler + js_of_ocaml-tyxml + js_of_ocaml-toplevel + lwt + js_of_ocaml-lwt + ;; not used directly + graphics + js_of_ocaml.deriving + react + reactiveData + str + dynlink + (select + ocp_indent.ml + from + (ocp-indent.lib -> ocp_indent.ok.ml) + (-> ocp_indent.fake.ml)) + (select + colorize.ml + from + (higlo -> colorize.higlo.ml) + (!higlo -> colorize.fake.ml)) + (select + graphics_support.ml + from + (js_of_ocaml-lwt.graphics -> graphics_support.enabled.ml) + (-> graphics_support.disabled.ml)) + (select + ppx_support.ml + from + (js_of_ocaml-ppx -> ppx_support.enabled.ml) + (-> ppx_support.disabled.ml))) + (flags + (:standard -rectypes)) + (link_flags + (:standard -linkall)) + (modes byte js) + (js_of_ocaml + (link_flags (:standard)) + (build_runtime_flags + (:standard + +toplevel.js + +dynlink.js + --file + %{dep:examples.ml} + --file + %{dep:test_dynlink.cmo} + --file + %{dep:test_dynlink.js})) + (flags + (:standard + --toplevel + (:include effects_flags.sexp)))) + (modules + (:standard \ test_dynlink examples effects_flags)) + (preprocess + (pps js_of_ocaml-ppx))) + +(rule + (targets test_dynlink.cmo test_dynlink.cmi) + (action + (run ocamlc -c %{dep:test_dynlink.ml}))) + +(rule + (targets test_dynlink.js) + (action + (run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo}))) + +(rule + (targets export.txt) + (deps + (package js_of_ocaml-ppx) + (package js_of_ocaml) + (package js_of_ocaml-compiler) + (package js_of_ocaml-lwt) + (package js_of_ocaml-tyxml) + (package js_of_ocaml-toplevel)) + (action + (run + jsoo_listunits + -o + %{targets} + stdlib + graphics + str + dynlink + js_of_ocaml-compiler.runtime + js_of_ocaml-lwt.graphics + js_of_ocaml-ppx.as-lib + js_of_ocaml.deriving + lwt + tyxml.functor + tyxml.functor:html_types.cmi + react + reactiveData + js_of_ocaml + js_of_ocaml-lwt + js_of_ocaml-tyxml + js_of_ocaml-toplevel))) + +(executable + (name effects_flags) + (modules effects_flags)) + +(rule + (target effects_flags.sexp) + (action + (with-stdout-to + %{target} + (run ./effects_flags.exe sexp)))) + +(rule + (target effects_flags.txt) + (action + (with-stdout-to + %{target} + (run ./effects_flags.exe txt)))) + +(rule + (targets toplevel.js) + (action + (run + %{bin:js_of_ocaml} + compile + --pretty + %{read-strings:effects_flags.txt} + --Werror + --target-env + browser + --file + %{dep:examples.ml} + --file + %{dep:test_dynlink.cmo} + --file + %{dep:test_dynlink.js} + --export + %{dep:export.txt} + --toplevel + --disable + shortvar + %{dep:toplevel.bc} + -o + %{targets}))) + +(alias + (name default) + (deps toplevel.js toplevel.bc.js index.html)) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..fb9ead4 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 3.4) +(name oplevel) diff --git a/effects_flags.ml b/effects_flags.ml new file mode 100644 index 0000000..4bbf57d --- /dev/null +++ b/effects_flags.ml @@ -0,0 +1,15 @@ +let enable b n = + let f = if b then "--enable" else "--disable" in + [ f; n ] + +let () = + let major = String.split_on_char '.' Sys.ocaml_version |> List.hd |> int_of_string in + let has_effect = major >= 5 in + let l = enable has_effect "effects" in + match Sys.argv |> Array.to_list |> List.tl with + | "txt" :: [] -> List.iter print_endline l + | "sexp" :: [] -> + print_endline "("; + List.iter print_endline l; + print_endline ")" + | _ -> assert false diff --git a/examples.ml b/examples.ml new file mode 100644 index 0000000..37dbbb2 --- /dev/null +++ b/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 diff --git a/graphics_support.disabled.ml b/graphics_support.disabled.ml new file mode 100644 index 0000000..c12db60 --- /dev/null +++ b/graphics_support.disabled.ml @@ -0,0 +1 @@ +let init _ = () diff --git a/graphics_support.enabled.ml b/graphics_support.enabled.ml new file mode 100644 index 0000000..331e98c --- /dev/null +++ b/graphics_support.enabled.ml @@ -0,0 +1 @@ +let init elt = Graphics_js.open_canvas elt diff --git a/indent.ml b/indent.ml new file mode 100644 index 0000000..469907f --- /dev/null +++ b/indent.ml @@ -0,0 +1,43 @@ +open Js_of_ocaml + +let textarea (textbox : Dom_html.textAreaElement Js.t) : unit = + let rec loop s acc (i, pos') = + try + let pos = String.index_from s pos' '\n' in + loop s ((i, (pos', pos)) :: acc) (succ i, succ pos) + with _ -> List.rev ((i, (pos', String.length s)) :: acc) + in + let rec find (l : (int * (int * int)) list) c = + match l with + | [] -> assert false + | (i, (lo, up)) :: _ when up >= c -> c, i, lo, up + | (_, (_lo, _up)) :: rem -> find rem c + in + let v = textbox##.value in + let pos = + let c1 = textbox##.selectionStart and c2 = textbox##.selectionEnd in + if Js.Opt.test (Js.Opt.return c1) && Js.Opt.test (Js.Opt.return c2) + then + let l = loop (Js.to_string v) [] (0, 0) in + Some (find l c1, find l c2) + else None + in + let f = + match pos with + | None -> fun _ -> true + | Some ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) -> + fun l -> l >= line1 + 1 && l <= line2 + 1 + in + let v = Ocp_indent.indent (Js.to_string v) f in + textbox##.value := Js.string v; + match pos with + | Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, up2)) -> + let l = loop v [] (0, 0) in + let lo1'', up1'' = List.assoc line1 l in + let lo2'', up2'' = List.assoc line2 l in + let n1 = max (c1 + up1'' - up1) lo1'' in + let n2 = max (c2 + up2'' - up2) lo2'' in + let () = (Obj.magic textbox)##setSelectionRange n1 n2 in + textbox##focus; + () + | None -> () diff --git a/indent.mli b/indent.mli new file mode 100644 index 0000000..6a8532b --- /dev/null +++ b/indent.mli @@ -0,0 +1,3 @@ +open Js_of_ocaml + +val textarea : Dom_html.textAreaElement Js.t -> unit diff --git a/index.html b/index.html new file mode 100644 index 0000000..09fa9b7 --- /dev/null +++ b/index.html @@ -0,0 +1,233 @@ + + + + + OCaml toplevel + + + + + + + +
+ 

+      

+        

+        
+        
+      

+    

+    

+      
Js_of_ocaml

+      
A compiler from OCaml bytecode to Javascript.

+      
It makes OCaml programs that run on Web browsers. It is
+        easy to install as it works with an existing installation of OCaml,
+        with no need to recompile any library. It comes with bindings for a
+        large part of the browser APIs.

+      
This web-based OCaml toplevel is compiled using Js_of_ocaml.

+      
Command

+      
+        
+          
+            
+            
+          
+          
+            
+            
+          
+          
+            
+            
+          
+          
+            
+            
+          
+          
+            
+            
+          
+          
+            
+            
+          
+
+        
+      
Enter/ReturnSubmit code
Ctrl + EnterNewline
Up / DownBrowse history
Ctrl + lClear display
Ctrl + kReset toplevel
TabIndent code

+      
Try to execute samples

+      

+      
+      
See the generated javascript code

+      
+      

+    

+  
+
diff --git a/ocp_indent.fake.ml b/ocp_indent.fake.ml
new file mode 100644
index 0000000..e598dbd
--- /dev/null
+++ b/ocp_indent.fake.ml
@@ -0,0 +1,3 @@
+let indent s _in_lines = s
+
+(* ocp-indent not available *)
diff --git a/ocp_indent.ok.ml b/ocp_indent.ok.ml
new file mode 100644
index 0000000..d2a23f6
--- /dev/null
+++ b/ocp_indent.ok.ml
@@ -0,0 +1,14 @@
+let _ = Approx_lexer.enable_extension "lwt"
+
+let indent s in_lines =
+  let output =
+    { IndentPrinter.debug = false
+    ; config = IndentConfig.default
+    ; in_lines
+    ; indent_empty = true
+    ; adaptive = true
+    ; kind = IndentPrinter.Print (fun s acc -> acc ^ s)
+    }
+  in
+  let stream = Nstream.of_string s in
+  IndentPrinter.proceed output stream IndentBlock.empty ""
diff --git a/ppx_support.disabled.ml b/ppx_support.disabled.ml
new file mode 100644
index 0000000..485f5bc
--- /dev/null
+++ b/ppx_support.disabled.ml
@@ -0,0 +1 @@
+let init () = ()
diff --git a/ppx_support.enabled.ml b/ppx_support.enabled.ml
new file mode 100644
index 0000000..3447ab1
--- /dev/null
+++ b/ppx_support.enabled.ml
@@ -0,0 +1 @@
+let init () = Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)
diff --git a/test_dynlink.ml b/test_dynlink.ml
new file mode 100644
index 0000000..c371708
--- /dev/null
+++ b/test_dynlink.ml
@@ -0,0 +1,3 @@
+let _ = print_endline "Dynlink OK"
+
+let f () = print_endline "Test_dynlink.f Ok"
diff --git a/toplevel.ml b/toplevel.ml
new file mode 100644
index 0000000..0999f2e
--- /dev/null
+++ b/toplevel.ml
@@ -0,0 +1,492 @@
+(* Js_of_ocaml toplevel
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2011 Jérôme Vouillon
+ * Laboratoire PPS - CNRS Université Paris Diderot
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+open Js_of_ocaml
+open Js_of_ocaml_lwt
+open Js_of_ocaml_tyxml
+open Js_of_ocaml_toplevel
+open Lwt
+
+let compiler_name = "OCaml"
+
+let by_id s = Dom_html.getElementById s
+
+let by_id_coerce s f =
+  Js.Opt.get (f (Dom_html.getElementById s)) (fun () -> raise Not_found)
+
+let do_by_id s f = try f (Dom_html.getElementById s) with Not_found -> ()
+
+(* load file using a synchronous XMLHttpRequest *)
+let load_resource_aux filename url =
+  Js_of_ocaml_lwt.XmlHttpRequest.perform_raw ~response_type:XmlHttpRequest.ArrayBuffer url
+  >|= fun frame ->
+  if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200
+  then
+    Js.Opt.case
+      frame.Js_of_ocaml_lwt.XmlHttpRequest.content
+      (fun () -> Printf.eprintf "Could not load %s\n" filename)
+      (fun b ->
+        Sys_js.update_file ~name:filename ~content:(Typed_array.String.of_arrayBuffer b))
+  else ()
+
+let load_resource scheme ~prefix ~path:suffix =
+  let url = scheme ^ suffix in
+  let filename = Filename.concat prefix suffix in
+  Lwt.async (fun () -> load_resource_aux filename url);
+  Some ""
+
+let setup_pseudo_fs ~load_cmis_from_server =
+  Sys_js.mount ~path:"/dev/" (fun ~prefix:_ ~path:_ -> None);
+  Sys_js.mount ~path:"/http/" (load_resource "http://");
+  Sys_js.mount ~path:"/https/" (load_resource "https://");
+  Sys_js.mount ~path:"/ftp/" (load_resource "ftp://");
+  if load_cmis_from_server then Sys_js.mount ~path:"/home/" (load_resource "filesys/")
+
+let exec' s =
+  let res : bool = JsooTop.use Format.std_formatter s in
+  if not res then Format.eprintf "error while evaluating %s@." s
+
+module Version = struct
+  type t = int list
+
+  let split_char ~sep p =
+    let len = String.length p in
+    let rec split beg cur =
+      if cur >= len
+      then if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
+      else if sep p.[cur]
+      then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
+      else split beg (cur + 1)
+    in
+    split 0 0
+
+  let split v =
+    match
+      split_char
+        ~sep:(function
+          | '+' | '-' | '~' -> true
+          | _ -> false)
+        v
+    with
+    | [] -> assert false
+    | x :: _ ->
+        List.map
+          int_of_string
+          (split_char
+             ~sep:(function
+               | '.' -> true
+               | _ -> false)
+             x)
+
+  let current : t = split Sys.ocaml_version
+
+  let compint (a : int) b = compare a b
+
+  let rec compare v v' =
+    match v, v' with
+    | [ x ], [ y ] -> compint x y
+    | [], [] -> 0
+    | [], y :: _ -> compint 0 y
+    | x :: _, [] -> compint x 0
+    | x :: xs, y :: ys -> (
+        match compint x y with
+        | 0 -> compare xs ys
+        | n -> n)
+end
+
+let setup_toplevel () =
+  Clflags.debug := true;
+  JsooTop.initialize ();
+  Sys.interactive := false;
+  if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
+  exec'
+    "module Lwt_main = struct\n\
+    \  let run t = match Lwt.state t with\n\
+    \    | Lwt.Return x -> x\n\
+    \    | Lwt.Fail e -> raise e\n\
+    \    | Lwt.Sleep -> failwith \"Lwt_main.run: thread didn't return\"\n\
+    \ end";
+  let header1 = Printf.sprintf "        %s version %%s" compiler_name in
+  let header2 =
+    Printf.sprintf "     Compiled with Js_of_ocaml version %s" Sys_js.js_of_ocaml_version
+  in
+  exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
+  exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
+  exec' "#enable \"pretty\";;";
+  exec' "#disable \"shortvar\";;";
+  Ppx_support.init ();
+  Toploop.add_directive
+    "load_js"
+    (Toploop.Directive_string (fun name -> Js.Unsafe.global##load_script_ name))
+    { section = "js_of_ocaml-toplevel-example"; doc = "Load the given javascript file" };
+  Sys.interactive := true;
+  ()
+
+let resize ~container ~textbox () =
+  Lwt.pause ()
+  >>= fun () ->
+  textbox##.style##.height := Js.string "auto";
+  textbox##.style##.height
+  := Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
+  container##.scrollTop := container##.scrollHeight;
+  Lwt.return ()
+
+let setup_printers () =
+  exec'
+    "let _print_error fmt e = Format.pp_print_string fmt (Js_of_ocaml.Js_error.to_string \
+     e)";
+  Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_error");
+  exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
+  Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_unit")
+
+let setup_examples ~container ~textbox =
+  let r = Regexp.regexp "^\\(\\*+(.*)\\*+\\)$" in
+  let all = ref [] in
+  (try
+     let ic = open_in "/static/examples.ml" in
+     while true do
+       let line = input_line ic in
+       match Regexp.string_match r line 0 with
+       | Some res ->
+           let name =
+             match Regexp.matched_group res 1 with
+             | Some s -> s
+             | None -> assert false
+           in
+           all := `Title name :: !all
+       | None -> all := `Content line :: !all
+     done;
+     assert false
+   with _ -> ());
+  let example_container = by_id "toplevel-examples" in
+  let _ =
+    List.fold_left
+      (fun acc tok ->
+        match tok with
+        | `Content line -> line ^ "\n" ^ acc
+        | `Title name ->
+            let a =
+              Tyxml_js.Html.(
+                a
+                  ~a:
+                    [ a_class [ "list-group-item" ]
+                    ; a_onclick (fun _ ->
+                          textbox##.value := (Js.string acc)##trim;
+                          Lwt.async (fun () ->
+                              resize ~container ~textbox ()
+                              >>= fun () ->
+                              textbox##focus;
+                              Lwt.return_unit);
+                          true)
+                    ]
+                  [ txt name ])
+            in
+            Dom.appendChild example_container (Tyxml_js.To_dom.of_a a);
+            "")
+      ""
+      !all
+  in
+  ()
+
+(* we need to compute the hash form href to avoid different encoding behavior
+     across browser. see Url.get_fragment *)
+let parse_hash () =
+  let frag = Url.Current.get_fragment () in
+  Url.decode_arguments frag
+
+let rec iter_on_sharp ~f x =
+  Js.Opt.iter (Dom_html.CoerceTo.element x) (fun e ->
+      if Js.to_bool (e##.classList##contains (Js.string "sharp")) then f e);
+  match Js.Opt.to_option x##.nextSibling with
+  | None -> ()
+  | Some n -> iter_on_sharp ~f n
+
+let setup_share_button ~output =
+  do_by_id "btn-share" (fun e ->
+      e##.style##.display := Js.string "block";
+      e##.onclick :=
+        Dom_html.handler (fun _ ->
+            (* get all ocaml code *)
+            let code = ref [] in
+            Js.Opt.iter
+              output##.firstChild
+              (iter_on_sharp ~f:(fun e ->
+                   code :=
+                     Js.Opt.case e##.textContent (fun () -> "") Js.to_string :: !code));
+            let code_encoded = B64.encode (String.concat "" (List.rev !code)) in
+            let url, is_file =
+              match Url.Current.get () with
+              | Some (Url.Http url) -> Url.Http { url with Url.hu_fragment = "" }, false
+              | Some (Url.Https url) -> Url.Https { url with Url.hu_fragment = "" }, false
+              | Some (Url.File url) -> Url.File { url with Url.fu_fragment = "" }, true
+              | _ -> assert false
+            in
+            let frag =
+              let frags = parse_hash () in
+              let frags = List.remove_assoc "code" frags @ [ "code", code_encoded ] in
+              Url.encode_arguments frags
+            in
+            let uri = Url.string_of_url url ^ "#" ^ frag in
+            let append_url str =
+              let dom =
+                Tyxml_js.Html.(
+                  p [ txt "Share this url : "; a ~a:[ a_href str ] [ txt str ] ])
+              in
+              Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
+            in
+            Lwt.async (fun () ->
+                Lwt.catch
+                  (fun () ->
+                    if is_file
+                    then failwith "Cannot shorten url with file scheme"
+                    else
+                      let uri =
+                        Printf.sprintf
+                          "http://is.gd/create.php?format=json&url=%s"
+                          (Url.urlencode uri)
+                      in
+                      Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri) (fun o ->
+                          let str = Js.to_string o##.shorturl in
+                          append_url str;
+                          Lwt.return_unit))
+                  (fun exn ->
+                    Format.eprintf
+                      "Could not generate short url. reason: %s@."
+                      (Printexc.to_string exn);
+                    append_url uri;
+                    Lwt.return_unit));
+            Js._false))
+
+let setup_js_preview () =
+  let ph = by_id "last-js" in
+  let runcode : string -> 'a = Js.Unsafe.global##.toplevelEval in
+  Js.Unsafe.global##.toplevelEval
+  := fun bc ->
+  ph##.innerHTML := Js.string bc;
+  runcode bc
+
+let current_position = ref 0
+
+let highlight_location loc =
+  let x = ref 0 in
+  let output = by_id "output" in
+  let first =
+    Js.Opt.get (output##.childNodes##item !current_position) (fun _ -> assert false)
+  in
+  iter_on_sharp first ~f:(fun e ->
+      incr x;
+      let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
+      let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
+      if !x >= line1 && !x <= line2
+      then
+        let from_ = if !x = line1 then `Pos col1 else `Pos 0 in
+        let to_ = if !x = line2 then `Pos col2 else `Last in
+        Colorize.highlight from_ to_ e)
+
+let append colorize output cl s =
+  Dom.appendChild output (Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
+
+module History = struct
+  let data = ref [| "" |]
+
+  let idx = ref 0
+
+  let get_storage () =
+    match Js.Optdef.to_option Dom_html.window##.localStorage with
+    | exception _ -> raise Not_found
+    | None -> raise Not_found
+    | Some t -> t
+
+  let setup () =
+    try
+      let s = get_storage () in
+      match Js.Opt.to_option (s##getItem (Js.string "history")) with
+      | None -> raise Not_found
+      | Some s ->
+          let a = Json.unsafe_input s in
+          data := a;
+          idx := Array.length a - 1
+    with _ -> ()
+
+  let push text =
+    let l = Array.length !data in
+    let n = Array.make (l + 1) "" in
+    !data.(l - 1) <- text;
+    Array.blit !data 0 n 0 l;
+    data := n;
+    idx := l;
+    try
+      let s = get_storage () in
+      let str = Json.output !data in
+      s##setItem (Js.string "history") str
+    with Not_found -> ()
+
+  let current text = !data.(!idx) <- text
+
+  let previous textbox =
+    if !idx > 0
+    then (
+      decr idx;
+      textbox##.value := Js.string !data.(!idx))
+
+  let next textbox =
+    if !idx < Array.length !data - 1
+    then (
+      incr idx;
+      textbox##.value := Js.string !data.(!idx))
+end
+
+let run _ =
+  let container = by_id "toplevel-container" in
+  let output = by_id "output" in
+  let textbox : 'a Js.t = by_id_coerce "userinput" Dom_html.CoerceTo.textarea in
+  let sharp_chan = open_out "/dev/null0" in
+  let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
+  let caml_chan = open_out "/dev/null1" in
+  let caml_ppf = Format.formatter_of_out_channel caml_chan in
+  let execute () =
+    let content = Js.to_string textbox##.value##trim in
+    let content' =
+      let len = String.length content in
+      if try content <> "" && content.[len - 1] <> ';' && content.[len - 2] <> ';'
+         with _ -> true
+      then content ^ ";;"
+      else content
+    in
+    current_position := output##.childNodes##.length;
+    textbox##.value := Js.string "";
+    History.push content;
+    JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location caml_ppf content';
+    resize ~container ~textbox ()
+    >>= fun () ->
+    container##.scrollTop := container##.scrollHeight;
+    textbox##focus;
+    Lwt.return_unit
+  in
+  let history_down _e =
+    let txt = Js.to_string textbox##.value in
+    let pos = textbox##.selectionStart in
+    try
+      if String.length txt = pos then raise Not_found;
+      let _ = String.index_from txt pos '\n' in
+      Js._true
+    with Not_found ->
+      History.current txt;
+      History.next textbox;
+      Js._false
+  in
+  let history_up _e =
+    let txt = Js.to_string textbox##.value in
+    let pos = textbox##.selectionStart - 1 in
+    try
+      if pos < 0 then raise Not_found;
+      let _ = String.rindex_from txt pos '\n' in
+      Js._true
+    with Not_found ->
+      History.current txt;
+      History.previous textbox;
+      Js._false
+  in
+  let meta e =
+    let b = Js.to_bool in
+    b e##.ctrlKey || b e##.altKey || b e##.metaKey
+  in
+  let shift e = Js.to_bool e##.shiftKey in
+  (* setup handlers *)
+  textbox##.onkeyup :=
+    Dom_html.handler (fun _ ->
+        Lwt.async (resize ~container ~textbox);
+        Js._true);
+  textbox##.onchange :=
+    Dom_html.handler (fun _ ->
+        Lwt.async (resize ~container ~textbox);
+        Js._true);
+  textbox##.onkeydown :=
+    Dom_html.handler (fun e ->
+        match e##.keyCode with
+        | 13 when not (meta e || shift e) ->
+            Lwt.async execute;
+            Js._false
+        | 13 ->
+            Lwt.async (resize ~container ~textbox);
+            Js._true
+        | 09 ->
+            Indent.textarea textbox;
+            Js._false
+        | 76 when meta e ->
+            output##.innerHTML := Js.string "";
+            Js._true
+        | 75 when meta e ->
+            setup_toplevel ();
+            Js._false
+        | 38 -> history_up e
+        | 40 -> history_down e
+        | _ -> Js._true);
+  (Lwt.async_exception_hook :=
+     fun exc ->
+       Format.eprintf "exc during Lwt.async: %s@." (Printexc.to_string exc);
+       match exc with
+       | Js_error.Exn e ->
+           let e = Js_error.to_error e in
+           Firebug.console##log e##.stack
+       | _ -> ());
+  Lwt.async (fun () ->
+      resize ~container ~textbox ()
+      >>= fun () ->
+      textbox##focus;
+      Lwt.return_unit);
+  Graphics_support.init (by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
+  Sys_js.set_channel_flusher caml_chan (append Colorize.ocaml output "caml");
+  Sys_js.set_channel_flusher sharp_chan (append Colorize.ocaml output "sharp");
+  Sys_js.set_channel_flusher stdout (append Colorize.text output "stdout");
+  Sys_js.set_channel_flusher stderr (append Colorize.text output "stderr");
+  let readline () =
+    Js.Opt.case
+      (Dom_html.window##prompt (Js.string "The toplevel expects inputs:") (Js.string ""))
+      (fun () -> "")
+      (fun s -> Js.to_string s ^ "\n")
+  in
+  Sys_js.set_channel_filler stdin readline;
+  setup_share_button ~output;
+  setup_examples ~container ~textbox;
+  setup_pseudo_fs ~load_cmis_from_server:false;
+  setup_toplevel ();
+  setup_js_preview ();
+  setup_printers ();
+  History.setup ();
+  textbox##.value := Js.string "";
+  (* Run initial code if any *)
+  try
+    let code = List.assoc "code" (parse_hash ()) in
+    textbox##.value := Js.string (B64.decode code);
+    Lwt.async execute
+  with
+  | Not_found -> ()
+  | exc ->
+      Firebug.console##log_3
+        (Js.string "exception")
+        (Js.string (Printexc.to_string exc))
+        exc
+
+let _ =
+  Dom_html.window##.onload :=
+    Dom_html.handler (fun _ ->
+        run ();
+        Js._false)