who knows what was going on here

boot_js.ml

@@ -90,7 +90,7 @@ let _ =
   let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in
   let body = Lwd.var (Lwd.pure Ui.empty) in
   let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in
-  Nav.test_pull () >>= fun test_store ->
+  Nav.test_populate () >>= fun test_store ->
   let ui = Widgets.(h_node_area (test_store, [ [] ])) in
   let root =
     Lwd.set body
@@ -118,5 +118,6 @@ let _ =
         images);
   buffered_loop (make_event Dom_html.Event.keydown) Dom_html.document
     (fun ev _ ->
+      Dom.preventDefault ev;
       Lwt.return
-      @@ push_event (Some (`Key (Event_js.evt_of_jskey ev))))
+      @@ push_event (Some (`Keys [ Event_js.evt_of_jskey ev ])))

dune

@@ -1,20 +1,50 @@
 (env
  (dev (flags (:standard -warn-error -A))
-  (js_of_ocaml (flags --no-inline --pretty --source-map-inline --debug-info)
-   (build_runtime_flags --no-inline --pretty --source-map-inline --debug-info)
-   (link_flags --source-map-inline))))
+  (js_of_ocaml (flags :standard)
+   (build_runtime_flags :standard --no-inline --debug-info)
+   (compilation_mode whole_program)
+   (link_flags :standard))))
+
+(library
+ (name log_js)
+  (modes byte)
+ (preprocess (pps js_of_ocaml-ppx))
+ (flags (:standard -rectypes -linkall))
+ (modules log_js)
+ (libraries
+   logs))
+
+(library
+ (name graphast)
+ (modes byte)
+ (kind ppx_rewriter)
+ (modules graphast)
+ (libraries
+   logs
+   ppxlib
+   fmt
+   lwt
+   ))
+
+(executable
+ (name ppx_graph)
+ (modes byte)
+ (modules ppx_graph)
+ (libraries
+ graphast))
 
 (executable
  (name boot_js)
  (modes byte js)
  (preprocess (pps js_of_ocaml-ppx)) 
-
+ (flags (:standard -rectypes -linkall))
  (modules boot_js human)
  (libraries
    fmt
-   logs
    graphv_webgl
    js_of_ocaml-lwt
+   js_of_ocaml-compiler
+   js_of_ocaml-toplevel
    digestif.ocaml
    checkseum.ocaml
    irmin.mem
@@ -23,8 +53,131 @@
    cohttp-lwt-jsoo
    mimic
    uri
-   zed
    gg
    lwd
-))
+   log_js))
 
+(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 embedded_fs.js)
+ (action
+  (run %{bin:jsoo_fs}
+    ; lol hack?
+    -I .
+    -o %{targets}
+    %{dep:examples.ml}
+    %{dep:test_dynlink.js})))
+
+(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
+    dynlink
+    js_of_ocaml
+    js_of_ocaml-lwt
+    js_of_ocaml-tyxml
+    js_of_ocaml-toplevel
+    js_of_ocaml-compiler
+    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
+    ppxlib)))
+
+(executables
+ (names toplevel)
+ (modules toplevel)
+ (flags
+  (:standard -rectypes -linkall))
+ (modes js)
+ (js_of_ocaml
+  (flags
+   compile
+   --pretty
+   --Werror
+   --target-env browser
+   --export %{dep:export.txt}
+   --toplevel
+   --disable shortvar
+   +toplevel.js
+   +dynlink.js
+   %{dep:embedded_fs.js}))
+ (preprocess
+  (pps js_of_ocaml-ppx ppxlib.metaquot))
+ (libraries
+   fmt
+   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
+   js_of_ocaml-lwt.graphics
+   js_of_ocaml-ppx.as-lib
+   compiler-libs
+   compiler-libs.common
+   compiler-libs.bytecomp
+   js_of_ocaml-compiler.runtime
+   ocp-indent.lib
+   react
+   reactiveData
+   str
+   log_js
+   ppxlib))
+
+; (rule
+;  (targets toplevel.js)
+;  (deps examples.ml)
+;  (action
+;   (run
+;    %{bin:js_of_ocaml}
+;    compile
+;    --pretty
+;    --Werror
+;    --target-env
+;    browser
+;    --extern-fs
+;    "--file=%{dep:examples.ml}"
+;    --export
+;    %{dep:export.txt}
+;    --toplevel
+;    --disable
+;    shortvar
+;    +toplevel.js
+;    +dynlink.js
+;    %{dep:toplevel.bc}
+;    -o
+;    %{targets})))
+
+(alias
+  (name default)
+  (deps toplevel.bc.js index.html toplevel.html))

graphast.ml

@@ -0,0 +1,997 @@
+(* graph typed abstract syntax tree:
+
+   couple options for hooking into compilation:
+   - modify ocaml source
+   - reimplement toplevel functions to allow extracting tast
+     * needs multiple implementaitons for byte and js
+     * only accepts toplevel phrases
+   - ppx
+     * only gets ast, would need to parse for tast (could use merlin or ocamlcommon?)
+   - merlin
+     * need to understand protocol and whether current lib interfaces give enough control
+*)
+
+open Ppxlib
+open Lwt
+module F = Fmt
+module Log = Logs
+
+module Printast = struct
+  include Ocaml_common.Printast
+  open Asttypes
+  open Format
+  open Lexing
+  open Location
+  open Parsetree
+
+  let fmt_position with_name f l =
+    let fname = if with_name then l.pos_fname else "" in
+    if l.pos_lnum = -1 then fprintf f "%s[%d]" fname l.pos_cnum
+    else
+      fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+        (l.pos_cnum - l.pos_bol)
+
+  let fmt_location f loc =
+    if not !Ocaml_common.Clflags.locations then ()
+    else
+      let p_2nd_name =
+        loc.loc_start.pos_fname <> loc.loc_end.pos_fname
+      in
+      fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+        (fmt_position p_2nd_name)
+        loc.loc_end;
+      if loc.loc_ghost then fprintf f " ghost"
+
+  let rec fmt_longident_aux f x =
+    match x with
+    | Longident.Lident s -> fprintf f "%s" s
+    | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s
+    | Longident.Lapply (y, z) ->
+        fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z
+
+  let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x
+
+  let fmt_longident_loc f (x : Longident.t loc) =
+    fprintf f "%a" fmt_longident_aux x.txt
+
+  let fmt_string_loc f (x : string loc) = fprintf f "\"%s\"@ " x.txt
+
+  let fmt_str_opt_loc f (x : string option loc) =
+    fprintf f "\"%s\"@ " (Option.value x.txt ~default:"_")
+
+  let fmt_char_option f = function
+    | None -> fprintf f ""
+    | Some c -> fprintf f "%c" c
+
+  let fmt_constant f x =
+    match x with
+    | Pconst_integer (i, m) -> fprintf f "%s%a" i fmt_char_option m
+    | Pconst_char c -> fprintf f "'%02x'" (Char.code c)
+    | Pconst_string (s, _strloc, None) -> fprintf f "%S" s
+    | Pconst_string (s, _strloc, Some delim) ->
+        fprintf f "%S(%S)" s delim
+    | Pconst_float (s, _) -> fprintf f "%s" s
+
+  let str_longident_loc = F.to_to_string fmt_longident_loc
+  let str_constant = F.to_to_string fmt_constant
+
+  let fmt_mutable_flag f x =
+    match x with
+    | Immutable -> fprintf f "Immutable"
+    | Mutable -> fprintf f "Mutable"
+
+  let fmt_virtual_flag f x =
+    match x with
+    | Virtual -> fprintf f "Virtual"
+    | Concrete -> fprintf f "Concrete"
+
+  let fmt_override_flag f x =
+    match x with
+    | Override -> fprintf f "Override"
+    | Fresh -> fprintf f "Fresh"
+
+  let fmt_closed_flag f x =
+    match x with
+    | Closed -> fprintf f "Closed"
+    | Open -> fprintf f "Open"
+
+  let fmt_rec_flag f x =
+    match x with
+    | Nonrecursive -> fprintf f ""
+    | Recursive -> fprintf f "Rec "
+
+  let fmt_direction_flag f x =
+    match x with Upto -> fprintf f "Up" | Downto -> fprintf f "Down"
+
+  let fmt_private_flag f x =
+    match x with
+    | Public -> fprintf f "Public"
+    | Private -> fprintf f "Private"
+
+  let line = F.pf
+
+  let list f ppf l =
+    F.pf ppf "%a" (F.brackets @@ F.list ~sep:F.semi f) l
+
+  let option f = F.option ~none:(fun ppf () -> F.pf ppf "None") f
+  let longident_loc ppf li = line ppf "%a@ " fmt_longident_loc li
+  let string ppf s = line ppf "\"%s\"@ " s
+  let string_loc ppf s = line ppf "%a@ " fmt_string_loc s
+  let str_opt_loc ppf s = line ppf "%a@ " fmt_str_opt_loc s
+
+  let arg_label ppf = function
+    | Nolabel -> fprintf ppf "" (* "Nolabel\n" *)
+    | Optional s -> fprintf ppf "?:%s@ " s
+    | Labelled s -> fprintf ppf "~:%s@ " s
+
+  let rec core_type ppf x =
+    attributes ppf x.ptyp_attributes;
+    match x.ptyp_desc with
+    | Ptyp_any -> line ppf "Ptyp_any@ "
+    | Ptyp_var s -> line ppf "Ptyp_var %s@ " s
+    | Ptyp_arrow (l, ct1, ct2) ->
+        line ppf "Ptyp_arrow@ ";
+        arg_label ppf l;
+        core_type ppf ct1;
+        core_type ppf ct2
+    | Ptyp_tuple l ->
+        line ppf "Ptyp_tuple@ ";
+        list core_type ppf l
+    | Ptyp_constr (li, l) ->
+        line ppf "Ptyp_constr %a@ " fmt_longident_loc li;
+        list core_type ppf l
+    | Ptyp_variant (l, closed, low) ->
+        line ppf "Ptyp_variant closed=%a@ " fmt_closed_flag closed;
+        list label_x_bool_x_core_type_list ppf l;
+        option (list string) ppf low
+    | Ptyp_object (l, c) ->
+        line ppf "Ptyp_object %a@ " fmt_closed_flag c;
+        List.iter
+          (fun field ->
+            match field.pof_desc with
+            | Otag (l, t) ->
+                line ppf "method %s@ " l.txt;
+                attributes ppf field.pof_attributes;
+                core_type ppf t
+            | Oinherit ct ->
+                line ppf "Oinherit@ ";
+                core_type ppf ct)
+          l
+    | Ptyp_class (li, l) ->
+        line ppf "Ptyp_class %a@ " fmt_longident_loc li;
+        list core_type ppf l
+    | Ptyp_alias (ct, s) ->
+        line ppf "Ptyp_alias \"%s\"@ " s;
+        core_type ppf ct
+    | Ptyp_poly (sl, ct) ->
+        line ppf "Ptyp_poly%a@ "
+          (fun ppf ->
+            List.iter (fun x ->
+                fprintf ppf " %a" Ocaml_common.Pprintast.tyvar x.txt))
+          sl;
+        core_type ppf ct
+    | Ptyp_package (s, l) ->
+        line ppf "Ptyp_package %a@ " fmt_longident_loc s;
+        list package_with ppf l
+    | Ptyp_extension (s, arg) ->
+        line ppf "Ptyp_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and package_with ppf (s, t) =
+    line ppf "with type %a@ " fmt_longident_loc s;
+    core_type ppf t
+
+  and pattern ppf x =
+    (* line i ppf "pattern %a@ " fmt_location x.ppat_loc; *)
+    attributes ppf x.ppat_attributes;
+    match x.ppat_desc with
+    | Ppat_any -> line ppf "Ppat_any@ "
+    | Ppat_var s -> line ppf "<var> %a@ " fmt_string_loc s
+    | Ppat_alias (p, s) ->
+        line ppf "Ppat_alias %a@ " fmt_string_loc s;
+        pattern ppf p
+    | Ppat_constant c -> line ppf "Ppat %a@ " fmt_constant c
+    | Ppat_interval (c1, c2) ->
+        line ppf "Ppat_interval %a..%a@ " fmt_constant c1 fmt_constant
+          c2
+    | Ppat_tuple l ->
+        line ppf "Ppat_tuple@ ";
+        list pattern ppf l
+    | Ppat_construct (li, po) ->
+        line ppf "Ppat_construct %a@ " fmt_longident_loc li;
+        option pattern ppf (Option.map snd po)
+    | Ppat_variant (l, po) ->
+        line ppf "Ppat_variant \"%s\"@ " l;
+        option pattern ppf po
+    | Ppat_record (l, c) ->
+        line ppf "Ppat_record %a@ " fmt_closed_flag c;
+        list longident_x_pattern ppf l
+    | Ppat_array l ->
+        line ppf "Ppat_array@ ";
+        list pattern ppf l
+    | Ppat_or (p1, p2) ->
+        line ppf "Ppat_or@ ";
+        pattern ppf p1;
+        pattern ppf p2
+    | Ppat_lazy p ->
+        line ppf "Ppat_lazy@ ";
+        pattern ppf p
+    | Ppat_constraint (p, ct) ->
+        line ppf "Ppat_constraint@ ";
+        pattern ppf p;
+        core_type ppf ct
+    | Ppat_type li ->
+        line ppf "Ppat_type@ ";
+        longident_loc ppf li
+    | Ppat_unpack s -> line ppf "Ppat_unpack %a@ " fmt_str_opt_loc s
+    | Ppat_exception p ->
+        line ppf "Ppat_exception@ ";
+        pattern ppf p
+    | Ppat_open (m, p) ->
+        line ppf "Ppat_open \"%a\"@ " fmt_longident_loc m;
+        pattern ppf p
+    | Ppat_extension (s, arg) ->
+        line ppf "Ppat_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and expression ppf x : unit =
+    (* line ppf "expression %a@ " fmt_location x.pexp_loc; *)
+    attributes ppf x.pexp_attributes;
+
+    match x.pexp_desc with
+    | Pexp_ident _li ->
+        (* line ppf "Pexp_ident %a@ " fmt_longident_loc li; *)
+        (* str_longident_loc li *)
+        ()
+    | Pexp_constant _c ->
+        (*line ppf "Pexp %a@ " fmt_constant c;*)
+        (* str_constant c *)
+        ()
+    | Pexp_let (rf, l, e) ->
+        line ppf "Pexp_let %a@ " fmt_rec_flag rf;
+        list value_binding ppf l;
+        expression ppf e
+    | Pexp_function _l ->
+        line ppf "Pexp_function@ " (* ; list case ppf l *)
+    | Pexp_fun (l, eo, p, e) ->
+        line ppf "Pexp_fun@ ";
+        arg_label ppf l;
+        F.option (fun ppf -> F.pf ppf "=%a" expression) ppf eo;
+        F.pf ppf "%a@ ->@ %a" pattern p expression e
+    | Pexp_apply (e, l) ->
+        line ppf "Pexp_apply@ ";
+        expression ppf e;
+        let name = Pprintast.string_of_expression x in
+        list (graph_node name) ppf l
+    | Pexp_match (e, l) ->
+        line ppf "Pexp_match@ ";
+        expression ppf e;
+        list case ppf l
+    | Pexp_try (e, l) ->
+        line ppf "Pexp_try@ ";
+        expression ppf e;
+        list case ppf l
+    | Pexp_tuple l ->
+        line ppf "Pexp_tuple@ ";
+        list expression ppf l
+    | Pexp_construct (li, eo) ->
+        line ppf "Pexp_construct %a@ " fmt_longident_loc li;
+        option expression ppf eo
+    | Pexp_variant (l, eo) ->
+        line ppf "Pexp_variant \"%s\"@ " l;
+        option expression ppf eo
+    | Pexp_record (l, eo) ->
+        line ppf "Pexp_record@ ";
+        list longident_x_expression ppf l;
+        option expression ppf eo
+    | Pexp_field (e, li) ->
+        line ppf "Pexp_field@ ";
+        expression ppf e;
+        longident_loc ppf li
+    | Pexp_setfield (e1, li, e2) ->
+        line ppf "Pexp_setfield@ ";
+        expression ppf e1;
+        longident_loc ppf li;
+        expression ppf e2
+    | Pexp_array l ->
+        line ppf "Pexp_array@ ";
+        list expression ppf l
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        line ppf "Pexp_if@ ";
+        expression ppf e1;
+        line ppf "Pexp_then@ ";
+        expression ppf e2;
+        F.option
+          (fun ppf ->
+            line ppf "Pexp_else@ ";
+            expression ppf)
+          ppf eo
+    | Pexp_sequence (e1, e2) ->
+        line ppf "Pexp_sequence@ ";
+        expression ppf e1;
+        expression ppf e2
+    | Pexp_while (e1, e2) ->
+        line ppf "Pexp_while@ ";
+        expression ppf e1;
+        expression ppf e2
+    | Pexp_for (p, e1, e2, df, e3) ->
+        line ppf "Pexp_for %a@ " fmt_direction_flag df;
+        pattern ppf p;
+        expression ppf e1;
+        expression ppf e2;
+        expression ppf e3
+    | Pexp_constraint (e, ct) ->
+        line ppf "Pexp_constraint@ ";
+        expression ppf e;
+        core_type ppf ct
+    | Pexp_coerce (e, cto1, cto2) ->
+        line ppf "Pexp_coerce@ ";
+        expression ppf e;
+        option core_type ppf cto1;
+        core_type ppf cto2
+    | Pexp_send (e, s) ->
+        line ppf "Pexp_send \"%s\"@ " s.txt;
+        expression ppf e
+    | Pexp_new li -> line ppf "Pexp_new %a@ " fmt_longident_loc li
+    | Pexp_setinstvar (s, e) ->
+        line ppf "Pexp_setinstvar %a@ " fmt_string_loc s;
+        expression ppf e
+    | Pexp_override l ->
+        line ppf "Pexp_override@ ";
+        list string_x_expression ppf l
+    | Pexp_letmodule (s, me, e) ->
+        line ppf "Pexp_letmodule %a@ " fmt_str_opt_loc s;
+        module_expr ppf me;
+        expression ppf e
+    | Pexp_letexception (cd, e) ->
+        line ppf "Pexp_letexception@ ";
+        extension_constructor ppf cd;
+        expression ppf e
+    | Pexp_assert e ->
+        line ppf "Pexp_assert@ ";
+        expression ppf e
+    | Pexp_lazy e ->
+        line ppf "Pexp_lazy@ ";
+        expression ppf e
+    | Pexp_poly (e, cto) ->
+        line ppf "Pexp_poly@ ";
+        expression ppf e;
+        option core_type ppf cto
+    | Pexp_object s ->
+        line ppf "Pexp_object@ ";
+        class_structure ppf s
+    | Pexp_newtype (s, e) ->
+        line ppf "Pexp_newtype \"%s\"@ " s.txt;
+        expression ppf e
+    | Pexp_pack me ->
+        line ppf "Pexp_pack@ ";
+        module_expr ppf me
+    | Pexp_open (o, e) ->
+        line ppf "Pexp_open %a@ " fmt_override_flag o.popen_override;
+        module_expr ppf o.popen_expr;
+        expression ppf e
+    | Pexp_letop { let_; ands; body } ->
+        line ppf "Pexp_letop@ ";
+        binding_op ppf let_;
+        list binding_op ppf ands;
+        expression ppf body
+    | Pexp_extension (s, arg) ->
+        line ppf "Pexp_extension \"%s\"@ " s.txt;
+        payload ppf arg
+    | Pexp_unreachable -> line ppf "Pexp_unreachable"
+
+  and value_description ppf x =
+    line ppf "value_description %a %a@ " fmt_string_loc x.pval_name
+      fmt_location x.pval_loc;
+    attributes ppf x.pval_attributes;
+    core_type ppf x.pval_type;
+    list string ppf x.pval_prim
+
+  and type_parameter ppf (x, _variance) = core_type ppf x
+
+  and type_declaration ppf x =
+    line ppf "type_declaration %a %a@ " fmt_string_loc x.ptype_name
+      fmt_location x.ptype_loc;
+    attributes ppf x.ptype_attributes;
+
+    line ppf "ptype_params =@ ";
+    list type_parameter ppf x.ptype_params;
+    line ppf "ptype_cstrs =@ ";
+    list core_type_x_core_type_x_location ppf x.ptype_cstrs;
+    line ppf "ptype_kind =@ ";
+    type_kind ppf x.ptype_kind;
+    line ppf "ptype_private = %a@ " fmt_private_flag x.ptype_private;
+    line ppf "ptype_manifest =@ ";
+    option core_type ppf x.ptype_manifest
+
+  and attribute ppf k a =
+    line ppf "%s \"%s\"@ " k a.attr_name.txt;
+    payload ppf a.attr_payload
+
+  and attributes ppf l =
+    List.iter
+      (fun a ->
+        line ppf "attribute \"%s\"@ " a.attr_name.txt;
+        payload ppf a.attr_payload)
+      l
+
+  and payload ppf = function
+    | PStr x -> structure ppf x
+    | PSig x -> signature ppf x
+    | PTyp x -> core_type ppf x
+    | PPat (x, None) -> pattern ppf x
+    | PPat (x, Some g) ->
+        pattern ppf x;
+        line ppf "<when>@ ";
+        expression ppf g
+
+  and type_kind ppf x =
+    match x with
+    | Ptype_abstract -> line ppf "Ptype_abstract@ "
+    | Ptype_variant l ->
+        line ppf "Ptype_variant@ ";
+        list constructor_decl ppf l
+    | Ptype_record l ->
+        line ppf "Ptype_record@ ";
+        list label_decl ppf l
+    | Ptype_open -> line ppf "Ptype_open@ "
+
+  and type_extension ppf x =
+    line ppf "type_extension@ ";
+    attributes ppf x.ptyext_attributes;
+
+    line ppf "ptyext_path = %a@ " fmt_longident_loc x.ptyext_path;
+    line ppf "ptyext_params =@ ";
+    list type_parameter ppf x.ptyext_params;
+    line ppf "ptyext_constructors =@ ";
+    list extension_constructor ppf x.ptyext_constructors;
+    line ppf "ptyext_private = %a@ " fmt_private_flag x.ptyext_private
+
+  and type_exception ppf x =
+    line ppf "type_exception@ ";
+    attributes ppf x.ptyexn_attributes;
+    line ppf "ptyext_constructor =@ ";
+
+    extension_constructor ppf x.ptyexn_constructor
+
+  and extension_constructor ppf x =
+    line ppf "extension_constructor %a@ " fmt_location x.pext_loc;
+    attributes ppf x.pext_attributes;
+
+    line ppf "pext_name = \"%s\"@ " x.pext_name.txt;
+    line ppf "pext_kind =@ ";
+    extension_constructor_kind ppf x.pext_kind
+
+  and extension_constructor_kind ppf x =
+    match x with
+    | Pext_decl (_, a, r) ->
+        line ppf "Pext_decl@ ";
+        constructor_arguments ppf a;
+        option core_type ppf r
+    | Pext_rebind li ->
+        line ppf "Pext_rebind@ ";
+        line ppf "%a@ " fmt_longident_loc li
+
+  and class_type ppf x =
+    line ppf "class_type %a@ " fmt_location x.pcty_loc;
+    attributes ppf x.pcty_attributes;
+
+    match x.pcty_desc with
+    | Pcty_constr (li, l) ->
+        line ppf "Pcty_constr %a@ " fmt_longident_loc li;
+        list core_type ppf l
+    | Pcty_signature cs ->
+        line ppf "Pcty_signature@ ";
+        class_signature ppf cs
+    | Pcty_arrow (l, co, cl) ->
+        line ppf "Pcty_arrow@ ";
+        arg_label ppf l;
+        core_type ppf co;
+        class_type ppf cl
+    | Pcty_extension (s, arg) ->
+        line ppf "Pcty_extension \"%s\"@ " s.txt;
+        payload ppf arg
+    | Pcty_open (o, e) ->
+        line ppf "Pcty_open %a %a@ " fmt_override_flag
+          o.popen_override fmt_longident_loc o.popen_expr;
+        class_type ppf e
+
+  and class_signature ppf cs =
+    line ppf "class_signature@ ";
+    core_type ppf cs.pcsig_self;
+    list class_type_field ppf cs.pcsig_fields
+
+  and class_type_field ppf x =
+    line ppf "class_type_field %a@ " fmt_location x.pctf_loc;
+    attributes ppf x.pctf_attributes;
+    match x.pctf_desc with
+    | Pctf_inherit ct ->
+        line ppf "Pctf_inherit@ ";
+        class_type ppf ct
+    | Pctf_val (s, mf, vf, ct) ->
+        line ppf "Pctf_val \"%s\" %a %a@ " s.txt fmt_mutable_flag mf
+          fmt_virtual_flag vf;
+        core_type ppf ct
+    | Pctf_method (s, pf, vf, ct) ->
+        line ppf "Pctf_method \"%s\" %a %a@ " s.txt fmt_private_flag
+          pf fmt_virtual_flag vf;
+        core_type ppf ct
+    | Pctf_constraint (ct1, ct2) ->
+        line ppf "Pctf_constraint@ ";
+        core_type ppf ct1;
+        core_type ppf ct2
+    | Pctf_attribute a -> attribute ppf "Pctf_attribute" a
+    | Pctf_extension (s, arg) ->
+        line ppf "Pctf_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and class_description ppf x =
+    line ppf "class_description %a@ " fmt_location x.pci_loc;
+    attributes ppf x.pci_attributes;
+
+    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
+    line ppf "pci_params =@ ";
+    list type_parameter ppf x.pci_params;
+    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
+    line ppf "pci_expr =@ ";
+    class_type ppf x.pci_expr
+
+  and class_type_declaration ppf x =
+    line ppf "class_type_declaration %a@ " fmt_location x.pci_loc;
+    attributes ppf x.pci_attributes;
+    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
+    line ppf "pci_params =@ ";
+    list type_parameter ppf x.pci_params;
+    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
+    line ppf "pci_expr =@ ";
+    class_type ppf x.pci_expr
+
+  and class_expr ppf x =
+    line ppf "class_expr %a@ " fmt_location x.pcl_loc;
+    attributes ppf x.pcl_attributes;
+    match x.pcl_desc with
+    | Pcl_constr (li, l) ->
+        line ppf "Pcl_constr %a@ " fmt_longident_loc li;
+        list core_type ppf l
+    | Pcl_structure cs ->
+        line ppf "Pcl_structure@ ";
+        class_structure ppf cs
+    | Pcl_fun (l, eo, p, e) ->
+        line ppf "Pcl_fun@ ";
+        arg_label ppf l;
+        option expression ppf eo;
+        pattern ppf p;
+        class_expr ppf e
+    | Pcl_apply (ce, l) ->
+        line ppf "Pcl_apply@ ";
+        class_expr ppf ce;
+        list label_x_expression ppf l
+    | Pcl_let (rf, l, ce) ->
+        line ppf "Pcl_let %a@ " fmt_rec_flag rf;
+        list value_binding ppf l;
+        class_expr ppf ce
+    | Pcl_constraint (ce, ct) ->
+        line ppf "Pcl_constraint@ ";
+        class_expr ppf ce;
+        class_type ppf ct
+    | Pcl_extension (s, arg) ->
+        line ppf "Pcl_extension \"%s\"@ " s.txt;
+        payload ppf arg
+    | Pcl_open (o, e) ->
+        line ppf "Pcl_open %a %a@ " fmt_override_flag o.popen_override
+          fmt_longident_loc o.popen_expr;
+        class_expr ppf e
+
+  and class_structure ppf { pcstr_self = p; pcstr_fields = l } =
+    line ppf "class_structure@ ";
+    pattern ppf p;
+    list class_field ppf l
+
+  and class_field ppf x =
+    line ppf "class_field %a@ " fmt_location x.pcf_loc;
+    attributes ppf x.pcf_attributes;
+    match x.pcf_desc with
+    | Pcf_inherit (ovf, ce, so) ->
+        line ppf "Pcf_inherit %a@ " fmt_override_flag ovf;
+        class_expr ppf ce;
+        option string_loc ppf so
+    | Pcf_val (s, mf, k) ->
+        line ppf "Pcf_val %a@ " fmt_mutable_flag mf;
+        line ppf "%a@ " fmt_string_loc s;
+        class_field_kind ppf k
+    | Pcf_method (s, pf, k) ->
+        line ppf "Pcf_method %a@ " fmt_private_flag pf;
+        line ppf "%a@ " fmt_string_loc s;
+        class_field_kind ppf k
+    | Pcf_constraint (ct1, ct2) ->
+        line ppf "Pcf_constraint@ ";
+        core_type ppf ct1;
+        core_type ppf ct2
+    | Pcf_initializer e ->
+        line ppf "Pcf_initializer@ ";
+        expression ppf e
+    | Pcf_attribute a -> attribute ppf "Pcf_attribute" a
+    | Pcf_extension (s, arg) ->
+        line ppf "Pcf_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and class_field_kind ppf = function
+    | Cfk_concrete (o, e) ->
+        line ppf "Concrete %a@ " fmt_override_flag o;
+        expression ppf e
+    | Cfk_virtual t ->
+        line ppf "Virtual@ ";
+        core_type ppf t
+
+  and class_declaration ppf x =
+    line ppf "class_declaration %a@ " fmt_location x.pci_loc;
+    attributes ppf x.pci_attributes;
+    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
+    line ppf "pci_params =@ ";
+    list type_parameter ppf x.pci_params;
+    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
+    line ppf "pci_expr =@ ";
+    class_expr ppf x.pci_expr
+
+  and module_type ppf x =
+    line ppf "module_type %a@ " fmt_location x.pmty_loc;
+    attributes ppf x.pmty_attributes;
+
+    match x.pmty_desc with
+    | Pmty_ident li -> line ppf "Pmty_ident %a@ " fmt_longident_loc li
+    | Pmty_alias li -> line ppf "Pmty_alias %a@ " fmt_longident_loc li
+    | Pmty_signature s ->
+        line ppf "Pmty_signature@ ";
+        signature ppf s
+    | Pmty_functor (Unit, mt2) ->
+        line ppf "Pmty_functor ()@ ";
+        module_type ppf mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        line ppf "Pmty_functor %a@ " fmt_str_opt_loc s;
+        module_type ppf mt1;
+        module_type ppf mt2
+    | Pmty_with (mt, l) ->
+        line ppf "Pmty_with@ ";
+        module_type ppf mt;
+        list with_constraint ppf l
+    | Pmty_typeof m ->
+        line ppf "Pmty_typeof@ ";
+        module_expr ppf m
+    | Pmty_extension (s, arg) ->
+        line ppf "Pmod_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and signature ppf x = list signature_item ppf x
+
+  and signature_item ppf x =
+    line ppf "signature_item %a@ " fmt_location x.psig_loc;
+
+    match x.psig_desc with
+    | Psig_value vd ->
+        line ppf "Psig_value@ ";
+        value_description ppf vd
+    | Psig_type (rf, l) ->
+        line ppf "Psig_type %a@ " fmt_rec_flag rf;
+        list type_declaration ppf l
+    | Psig_typesubst l ->
+        line ppf "Psig_typesubst@ ";
+        list type_declaration ppf l
+    | Psig_typext te ->
+        line ppf "Psig_typext@ ";
+        type_extension ppf te
+    | Psig_exception te ->
+        line ppf "Psig_exception@ ";
+        type_exception ppf te
+    | Psig_module pmd ->
+        line ppf "Psig_module %a@ " fmt_str_opt_loc pmd.pmd_name;
+        attributes ppf pmd.pmd_attributes;
+        module_type ppf pmd.pmd_type
+    | Psig_modsubst pms ->
+        line ppf "Psig_modsubst %a = %a@ " fmt_string_loc pms.pms_name
+          fmt_longident_loc pms.pms_manifest;
+        attributes ppf pms.pms_attributes
+    | Psig_recmodule decls ->
+        line ppf "Psig_recmodule@ ";
+        list module_declaration ppf decls
+    | Psig_modtype x ->
+        line ppf "Psig_modtype %a@ " fmt_string_loc x.pmtd_name;
+        attributes ppf x.pmtd_attributes;
+        modtype_declaration ppf x.pmtd_type
+    | Psig_open od ->
+        line ppf "Psig_open %a %a@ " fmt_override_flag
+          od.popen_override fmt_longident_loc od.popen_expr;
+        attributes ppf od.popen_attributes
+    | Psig_include incl ->
+        line ppf "Psig_include@ ";
+        module_type ppf incl.pincl_mod;
+        attributes ppf incl.pincl_attributes
+    | Psig_class l ->
+        line ppf "Psig_class@ ";
+        list class_description ppf l
+    | Psig_class_type l ->
+        line ppf "Psig_class_type@ ";
+        list class_type_declaration ppf l
+    | Psig_extension ((s, arg), attrs) ->
+        line ppf "Psig_extension \"%s\"@ " s.txt;
+        attributes ppf attrs;
+        payload ppf arg
+    | Psig_attribute a -> attribute ppf "Psig_attribute" a
+    | _ ->
+        Log.err (fun m -> m "Printast signature_item not matched");
+        raise Not_found
+
+  and modtype_declaration ppf = function
+    | None -> line ppf "#abstract"
+    | Some mt -> module_type ppf mt
+
+  and with_constraint ppf x =
+    match x with
+    | Pwith_type (lid, td) ->
+        line ppf "Pwith_type %a@ " fmt_longident_loc lid;
+        type_declaration ppf td
+    | Pwith_typesubst (lid, td) ->
+        line ppf "Pwith_typesubst %a@ " fmt_longident_loc lid;
+        type_declaration ppf td
+    | Pwith_module (lid1, lid2) ->
+        line ppf "Pwith_module %a = %a@ " fmt_longident_loc lid1
+          fmt_longident_loc lid2
+    | Pwith_modsubst (lid1, lid2) ->
+        line ppf "Pwith_modsubst %a = %a@ " fmt_longident_loc lid1
+          fmt_longident_loc lid2
+    | _ ->
+        Log.err (fun m -> m "Printast with_constraint not matched");
+        raise Not_found
+
+  and module_expr ppf x =
+    line ppf "module_expr %a@ " fmt_location x.pmod_loc;
+    attributes ppf x.pmod_attributes;
+
+    match x.pmod_desc with
+    | Pmod_ident li -> line ppf "Pmod_ident %a@ " fmt_longident_loc li
+    | Pmod_structure s ->
+        line ppf "Pmod_structure@ ";
+        structure ppf s
+    | Pmod_functor (Unit, me) ->
+        line ppf "Pmod_functor ()@ ";
+        module_expr ppf me
+    | Pmod_functor (Named (s, mt), me) ->
+        line ppf "Pmod_functor %a@ " fmt_str_opt_loc s;
+        module_type ppf mt;
+        module_expr ppf me
+    | Pmod_apply (me1, me2) ->
+        line ppf "Pmod_apply@ ";
+        module_expr ppf me1;
+        module_expr ppf me2
+    | Pmod_constraint (me, mt) ->
+        line ppf "Pmod_constraint@ ";
+        module_expr ppf me;
+        module_type ppf mt
+    | Pmod_unpack e ->
+        line ppf "Pmod_unpack@ ";
+        expression ppf e
+    | Pmod_extension (s, arg) ->
+        line ppf "Pmod_extension \"%s\"@ " s.txt;
+        payload ppf arg
+
+  and structure ppf x =
+    line ppf "struct@ ";
+    list structure_item ppf x
+
+  and structure_item ppf x =
+    match x.pstr_desc with
+    | Pstr_eval (e, attrs) ->
+        line ppf "Pstr_eval ";
+        attributes ppf attrs;
+        expression ppf e
+    | Pstr_value (rf, l) ->
+        line ppf "%a" fmt_rec_flag rf;
+        list value_binding ppf l
+    | Pstr_primitive vd ->
+        line ppf "Pstr_primitive@ ";
+        value_description ppf vd
+    | Pstr_type (rf, l) ->
+        line ppf "Pstr_type %a@ " fmt_rec_flag rf;
+        list type_declaration ppf l
+    | Pstr_typext te ->
+        line ppf "Pstr_typext@ ";
+        type_extension ppf te
+    | Pstr_exception te ->
+        line ppf "Pstr_exception@ ";
+        type_exception ppf te
+    | Pstr_module x ->
+        line ppf "Pstr_module@ ";
+        module_binding ppf x
+    | Pstr_recmodule bindings ->
+        line ppf "Pstr_recmodule@ ";
+        list module_binding ppf bindings
+    | Pstr_modtype x ->
+        line ppf "Pstr_modtype %a@ " fmt_string_loc x.pmtd_name;
+        attributes ppf x.pmtd_attributes;
+        modtype_declaration ppf x.pmtd_type
+    | Pstr_open od ->
+        line ppf "Pstr_open %a@ " fmt_override_flag od.popen_override;
+        module_expr ppf od.popen_expr;
+        attributes ppf od.popen_attributes
+    | Pstr_class l ->
+        line ppf "Pstr_class@ ";
+        list class_declaration ppf l
+    | Pstr_class_type l ->
+        line ppf "Pstr_class_type@ ";
+        list class_type_declaration ppf l
+    | Pstr_include incl ->
+        line ppf "Pstr_include";
+        attributes ppf incl.pincl_attributes;
+        module_expr ppf incl.pincl_mod
+    | Pstr_extension ((s, arg), attrs) ->
+        line ppf "Pstr_extension \"%s\"@ " s.txt;
+        attributes ppf attrs;
+        payload ppf arg
+    | Pstr_attribute a -> attribute ppf "Pstr_attribute" a
+
+  and module_declaration ppf pmd =
+    str_opt_loc ppf pmd.pmd_name;
+    attributes ppf pmd.pmd_attributes;
+    module_type ppf pmd.pmd_type
+
+  and module_binding ppf x =
+    str_opt_loc ppf x.pmb_name;
+    attributes ppf x.pmb_attributes;
+    module_expr ppf x.pmb_expr
+
+  and core_type_x_core_type_x_location ppf (ct1, ct2, l) =
+    line ppf "<constraint> %a@ " fmt_location l;
+    core_type ppf ct1;
+    core_type ppf ct2
+
+  and constructor_decl ppf
+      { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes; _ } =
+    line ppf "%a@ " fmt_location pcd_loc;
+    line ppf "%a@ " fmt_string_loc pcd_name;
+    attributes ppf pcd_attributes;
+    constructor_arguments ppf pcd_args;
+    option core_type ppf pcd_res
+
+  and constructor_arguments ppf = function
+    | Pcstr_tuple l -> list core_type ppf l
+    | Pcstr_record l -> list label_decl ppf l
+
+  and label_decl ppf
+      { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } =
+    line ppf "%a@ " fmt_location pld_loc;
+    attributes ppf pld_attributes;
+    line ppf "%a@ " fmt_mutable_flag pld_mutable;
+    line ppf "%a" fmt_string_loc pld_name;
+    core_type ppf pld_type
+
+  and longident_x_pattern ppf (li, p) =
+    line ppf "%a@ " fmt_longident_loc li;
+    pattern ppf p
+
+  and case ppf { pc_lhs; pc_guard; pc_rhs } =
+    line ppf "<case>@ ";
+    pattern ppf pc_lhs;
+    (match pc_guard with
+    | None -> ()
+    | Some g ->
+        line ppf "<when>@ ";
+        expression ppf g);
+    expression ppf pc_rhs
+
+  and value_binding ppf x =
+    line ppf "<def> ";
+    attributes ppf x.pvb_attributes;
+    pattern ppf x.pvb_pat;
+    expression ppf x.pvb_expr
+
+  and binding_op ppf x =
+    line ppf "<binding_op> %a %a" fmt_string_loc x.pbop_op
+      fmt_location x.pbop_loc;
+    pattern ppf x.pbop_pat;
+    expression ppf x.pbop_exp
+
+  and string_x_expression ppf (s, e) =
+    line ppf "<override> %a " fmt_string_loc s;
+    expression ppf e
+
+  and longident_x_expression ppf (li, e) =
+    line ppf "%a@ " fmt_longident_loc li;
+    expression ppf e
+
+  and label_x_expression ppf (l, e) =
+    fprintf ppf "<arg> ";
+    arg_label ppf l;
+    expression ppf e
+
+  and graph_node (name : string) ppf (l, e) =
+    F.pf ppf "\"%s\"" name;
+    label_x_expression ppf (l, e)
+
+  and label_x_bool_x_core_type_list ppf x =
+    match x.prf_desc with
+    | Rtag (l, b, ctl) ->
+        line ppf "Rtag \"%s\" %s@ " l.txt (string_of_bool b);
+        attributes ppf x.prf_attributes;
+        list core_type ppf ctl
+    | Rinherit ct ->
+        line ppf "Rinherit@ ";
+        core_type ppf ct
+
+  let rec toplevel_phrase ppf x =
+    match x with
+    | Ptop_def s ->
+        line ppf "Ptop_def\n";
+        structure ppf s
+    | Ptop_dir { pdir_name; pdir_arg; _ } -> (
+        line ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+        match pdir_arg with
+        | None -> ()
+        | Some da -> directive_argument ppf da)
+
+  and directive_argument ppf x =
+    match x.pdira_desc with
+    | Pdir_string s -> line ppf "Pdir_string \"%s\"\n" s
+    | Pdir_int (n, None) -> line ppf "Pdir_int %s\n" n
+    | Pdir_int (n, Some m) -> line ppf "Pdir_int %s%c\n" n m
+    | Pdir_ident li -> line ppf "Pdir_ident %a\n" fmt_longident li
+    | Pdir_bool b -> line ppf "Pdir_bool %s\n" (string_of_bool b)
+
+  let interface = signature
+  let implementation = structure
+  let top_phrase = toplevel_phrase
+end
+
+let log_info pp exp = Log.info (fun m -> m "ppx_graph:@ %a" pp exp)
+
+let graph_structure str =
+  let string_constants_of =
+    object
+      inherit [string list] Ast_traverse.fold as super
+
+      (* sig
+         val interface : Format.formatter -> signature_item list -> unit
+         val implementation : Format.formatter -> structure_item list -> unit
+         val top_phrase : Format.formatter -> toplevel_phrase -> unit
+         val expression : int -> Format.formatter -> expression -> unit
+         val structure : int -> Format.formatter -> Parsetree.structure -> unit
+         val payload : int -> Format.formatter -> payload -> unit
+          end *)
+
+      method! expression e acc =
+        let acc = super#expression e acc in
+        F.str "%a" Printast.expression e :: acc
+
+      (* match e.pexp_desc with
+         | Pexp_constant (Pconst_string (s, _, _)) -> s :: acc
+         | Pexp_let (_, vb, exp) ->
+             F.str "\"%a\" -> \"%a\""
+               (F.parens
+                  (F.list
+                     ~sep:(fun ppf () -> F.string ppf "->")
+                     (F.pair Pprintast.pattern ppPprintast.expression)))
+               (List.map (fun vb -> (vb.pvb_pat, vb.pvb_expr)) vb)
+               Pprintast.expression exp
+             :: acc
+           | _ -> acc *)
+
+      (* method! pattern p acc =
+         let acc = super#pattern p acc in
+         match p.ppat_desc with
+         | Ppat_constant (Pconst_string (s, _, _)) -> s :: acc
+         | _ -> acc *)
+    end
+  in
+  Log.debug (fun m ->
+      m "graph_structure:@[<hov> %a@]"
+        (F.list ~sep:(fun ppf () -> F.pf ppf "\n") F.string)
+        (List.rev (string_constants_of#structure str [])))
+
+let init () =
+  Driver.register_transformation
+    ~impl:(fun str ->
+      log_info Ocaml_common.Pprintast.structure str;
+      (* log_info Ocaml_common.Printast.implementation str; *)
+      Ocaml_common.Clflags.locations := false;
+      log_info Printast.implementation str;
+      Ocaml_common.Clflags.locations := true;
+      str)
+    "ppx_graph"

human.ml

@@ -1,3 +1,40 @@
+(* ok it's monad time *)
+(*
+
+1. implement toplevel eval of git repo content
+1. eval `/init` on startup for now
+1. start looking under the hood of js_of_ocaml top level to see if
+   1. there are ways to display and allow easy manipulation of the values used when calling
+Irmin.S.Tree.fold on things.
+   1. Make sure js_of_ocaml toplevel and native top level of ocaml 5.0
+are reasonably compatible in this "under the hood" stuff
+   1. save all JSOOTOP input into a history file that gets committed for each command!!
+1. Build a text editor based on irmin-tree?
+   1. What you really want is a data structure that is easy for you to call commands on to manipulate the values of
+irmin stores
+   1. If you go by the default, a text file is split into a list of lines,
+which has a cursor which is an index into the list of lines, and an index into the specific line.
+   1. Various common cursor movement commands should be bound to the common keys
+   1. A display of the cursor data structure values
+1. these commands just mutate the cursor state, so the text editor is just the structure of the Lwd.vars which are Lwd.get'd and mapped against the Tree.watch ified stuff???
+ughhh
+
+1. but yea fold being
+
+
+1. fix fetching of `console/boot` so it doesn't crash and can deal!!!!
+    1. like just tell it to fetch teh latest commit or something
+
+
+
+
+
+
+
+
+
+*)
+
 (* why *)
 
 (*
@@ -441,6 +478,8 @@ module Nav = struct
   end
 
   module Sync = Irmin.Sync.Make (S)
+  (* owo *)
+  (* owo *)
 
   type t = S.tree
   type store = S.t
@@ -448,13 +487,24 @@ module Nav = struct
   type step = S.step
   type path = step list
 
-  let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
+  let empty_repo_main () = S.Repo.v (Irmin_mem.config ()) >>= S.main
 
-  let test_populate () : t Lwt.t =
+  let time_now () =
+    Int64.of_float ((new%js Js.date_now)##getTime /. 1000.)
+
+  let info_msg ?(time = time_now ()) message = S.Info.v ~message time
+
+  let test_populate () : store Lwt.t =
     let add p s t = S.Tree.add t p s in
+    let r' = empty_repo_main () in
     add [ "hello" ] "world" (S.Tree.empty ())
-    >>= add [ "hello"; "daddy" ] "ily"
+    >>= add [ "daddy" ] "ily"
     >>= add [ "beep"; "beep" ] "motherfucker"
+    >>= fun t ->
+    r' >>= fun r ->
+    S.set_tree ~info:(fun () -> info_msg "test_populate ()") r [] t
+    |> ignore;
+    r'
 
   let test_pull () : store Lwt.t =
     (* test_populate ()*)
@@ -492,8 +542,8 @@ module Input = struct
   (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
   let string_of_code = function
     | `Uchar ch ->
-        if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch)
-        else F.str "Char 0x%02x" (Uchar.to_int ch)
+        if Uchar.is_char ch then F.str "%c" (Uchar.to_char ch)
+        else F.str "0x%02x" (Uchar.to_int ch)
     | `Enter -> "Enter"
     | `Escape -> "Escape"
     | `Tab -> "Tab"
@@ -514,12 +564,13 @@ module Input = struct
 
   let pp_code ppf v = F.pf ppf "%s" (string_of_code v)
 
-  type mods = [ `Super | `Meta | `Ctrl | `Shift ] list
+  type mods = [ `Super | `Meta | `Ctrl | `Shift | `Alt ] list
 
   let pp_mods =
     F.(
       list ~sep:F.sp (fun ppf -> function
         | `Super -> pf ppf "`Super"
+        | `Alt -> pf ppf "`Alt"
         | `Meta -> pf ppf "`Meta"
         | `Ctrl -> pf ppf "`Ctrl"
         | `Shift -> pf ppf "`Shift"))
@@ -557,10 +608,10 @@ module Event_js = struct
               | Some s' -> `Uchar s'
               | None -> `Unknown s))
       | None -> `Unknown "keypress .key is None?"),
-      (if Js.to_bool evt##.altKey then [ `Meta ] else [])
+      (if Js.to_bool evt##.altKey then [ `Alt ] else [])
       @ (if Js.to_bool evt##.shiftKey then [ `Shift ] else [])
       @ (if Js.to_bool evt##.ctrlKey then [ `Ctrl ] else [])
-      @ if Js.to_bool evt##.metaKey then [ `Super ] else [] )
+      @ if Js.to_bool evt##.metaKey then [ `Meta ] else [] )
 end
 
 open Gg
@@ -572,7 +623,6 @@ module NVG = struct
     include Graphv_webgl.Color
 
     let none = Color.transparent
-    let rgbf = Color.rgbf
     let gray a = rgbf ~r:a ~g:a ~b:a
     let light = gray 0.8
     let dark = gray 0.2
@@ -1077,7 +1127,6 @@ module I = struct
       set_fill_color vg ~color;
       fill vg;
       NVG.restore vg;
-      (* Log.debug (fun m -> m "fill_box: %a" Box2.pp b); *)
       Box2.size b
 
     let path_box vg color ?(width = 0.) b =
@@ -1206,10 +1255,10 @@ module I = struct
             V2.(p1 - v 0. (top +. bottom))
       in
 
-      ignore
+      (* ignore
          (path_box vg
             (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
-           (Box2.v p b'));
+            (Box2.v p b')); *)
       b'
   end
 end
@@ -1260,7 +1309,7 @@ module Nottui = struct
     let request_var (v : var) =
       incr clock;
       Log.debug (fun m ->
-          m "Focus.request_var v=%d clock=%d" (Lwd.peek v) !clock);
+          m "Focus.request_var v=%d->%d" (Lwd.peek v) !clock);
       Lwd.set v !clock
 
     let request ((v, _) : handle) = request_var v
@@ -1359,7 +1408,7 @@ module Nottui = struct
   end
 
   module Ui = struct
-    type may_handle = [ `Unhandled | `Handled ]
+    type may_handle = [ `Unhandled | `Handled | `Moar ]
 
     let may_handle (type a) (v : a option) (f : a -> may_handle) :
         may_handle =
@@ -1368,6 +1417,7 @@ module Nottui = struct
     let pp_may_handle ppf = function
       | `Unhandled -> F.pf ppf "`Unhandled"
       | `Handled -> F.pf ppf "`Handled"
+      | `Moar -> F.pf ppf "`Moar"
 
     type mouse_handler =
       x:float ->
@@ -1391,6 +1441,8 @@ module Nottui = struct
       [ Input.special | `Uchar of Uchar.t | semantic_key ]
       * Input.mods
 
+    type keys = key list
+
     let pp_key =
       F.(
         pair ~sep:F.sp
@@ -1410,10 +1462,12 @@ module Nottui = struct
             | a -> pf ppf "%a" Input.pp_code a)
           Input.pp_mods)
 
+    let pp_keys = F.(list ~sep:F.semi pp_key)
+
     type mouse = Input.mouse
 
     type event =
-      [ `Key of key | `Mouse of mouse | `Paste of Input.paste ]
+      [ `Keys of keys | `Mouse of mouse | `Paste of Input.paste ]
 
     type layout_spec = {
       w : float;
@@ -1446,11 +1500,11 @@ module Nottui = struct
       | Permanent_sensor of 'a * frame_sensor
       | Resize of 'a * float option * float option * Gravity.t2
       | Mouse_handler of 'a * mouse_handler
-      | Focus_area of 'a * (key -> may_handle)
+      | Focus_area of 'a * (keys -> may_handle)
       | Pad of 'a * (float * float * float * float)
       | Shift_area of 'a * float * float
       | Event_filter of
-          'a * ([ `Key of key | `Mouse of mouse ] -> may_handle)
+          'a * ([ `Keys of keys | `Mouse of mouse ] -> may_handle)
       | X of 'a * 'a
       | Y of 'a * 'a
       | Z of 'a * 'a
@@ -1617,10 +1671,9 @@ module Nottui = struct
     let has_focus t = Focus.has_focus t.focus
 
     let rec pp ppf t =
-      if has_focus t then
-        F.pf ppf "@[<hov>%a %a@]" Focus.pp_status t.focus pp_desc
-          t.desc
-      else F.pf ppf "@[<hov> %a@]" pp_desc t.desc
+      (*  if has_focus t then*)
+      F.pf ppf "@[<hov>%a %a@]" Focus.pp_status t.focus pp_desc t.desc
+    (* else F.pf ppf "@[<hov> %a@]" pp_desc t.desc *)
 
     and pp_desc ppf = function
       | Atom a ->
@@ -1810,7 +1863,10 @@ module Nottui = struct
     let update_focus ui =
       match ui.focus with
       | Focus.Empty | Focus.Handle _ -> ()
-      | Focus.Conflict i -> solve_focus ui i
+      | Focus.Conflict i ->
+          Log.debug (fun m ->
+              m "update_focus Conflict %d -> solve_focus ()" i);
+          solve_focus ui i
 
     let rec t_size_desc_of_t vg (size : box2) (ui : Ui.t desc) =
       match ui with
@@ -1959,7 +2015,7 @@ module Nottui = struct
         | Event_filter (n, f) -> (
             match f (`Mouse (`Press btn, (x, y), [])) with
             | `Handled -> true
-            | `Unhandled -> aux ox oy sw sh n)
+            | `Unhandled | `Moar -> aux ox oy sw sh n)
       in
       aux 0. 0. w h t
 
@@ -2029,7 +2085,9 @@ module Nottui = struct
           | Atom image ->
               let image =
                 if Focus.has_focus t.focus then (
-                  Log.debug (fun m -> m "render_node Atom has_focus");
+                  Log.debug (fun m ->
+                      m "render_node Atom has_focus status=%a"
+                        Focus.pp_status t.focus);
                   I.attr A.clickable image)
                 else image
               in
@@ -2149,6 +2207,27 @@ module Nottui = struct
           | Event_filter (t, _f) ->
               render_node vg vx1 vy1 vx2 vy2 sw sh t
         in
+        let cache =
+          if Focus.has_focus t.focus then (
+            Log.debug (fun m ->
+                m "render_node has_focus %a" Focus.pp_status t.focus);
+            {
+              cache with
+              image =
+                I.attr
+                  A.(bg (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.1))
+                  cache.image;
+            })
+          else
+            {
+              cache with
+              image =
+                I.attr
+                  A.(bg Color.(rgbaf ~r:0. ~g:0. ~b:0. ~a:0.000001))
+                  (* TODO: HACK *)
+                  cache.image;
+            }
+        in
         t.cache <- cache;
         cache
 
@@ -2157,8 +2236,8 @@ module Nottui = struct
       Log.debug (fun m -> m "Renderer.image view=%a " Ui.pp view);
       (render_node vg 0. 0. w h w h view).image
 
-    let dispatch_raw_key st key =
-      let rec iter (st : ui list) : [> `Unhandled ] =
+    let dispatch_raw_key st keys =
+      let rec iter (st : ui list) : [> `Unhandled | `Moar ] =
         match st with
         | [] -> `Unhandled
         | ui :: tl -> (
@@ -2174,10 +2253,10 @@ module Nottui = struct
             | Focus_area (t, f) -> (
                 match iter [ t ] with
                 | `Handled -> `Handled
-                | `Unhandled -> (
-                    match f key with
+                | `Unhandled | `Moar -> (
+                    match f keys with
                     | `Handled -> `Handled
-                    | `Unhandled -> iter tl))
+                    | `Unhandled | `Moar -> iter tl))
             | Attr (t, _)
             | Mouse_handler (t, _)
             | Size_sensor (t, _)
@@ -2188,9 +2267,9 @@ module Nottui = struct
             | Resize (t, _, _, _) ->
                 iter (t :: tl)
             | Event_filter (t, f) -> (
-                match f (`Key key) with
+                match f (`Keys keys) with
                 | `Unhandled -> iter (t :: tl)
-                | `Handled -> `Handled))
+                | a -> a))
       in
       iter [ st.view ]
 
@@ -2278,27 +2357,30 @@ module Nottui = struct
           if Focus.has_focus a.focus then dispatch_focus a dir
           else dispatch_focus b dir || dispatch_focus a dir
 
-    let rec dispatch_key st key =
-      match (dispatch_raw_key st key, key) with
+    let rec dispatch_key st (keys : Ui.keys) =
+      match (dispatch_raw_key st keys, keys) with
       | `Handled, _ -> `Handled
-      | `Unhandled, (`Arrow dir, []) ->
+      | _, [ (`Arrow dir, []) ] ->
           let dir : [ `Down | `Left | `Right | `Up ] :>
               [ `Down | `Left | `Right | `Up | `Next | `Prev ] =
             dir
           in
-          dispatch_key st (`Focus dir, [ `Meta ])
-      | `Unhandled, (`Tab, mods) ->
-          let dir = if List.mem `Shift mods then `Prev else `Next in
-          dispatch_key st (`Focus dir, mods)
-      | `Unhandled, (`Focus dir, _) ->
+          dispatch_key st [ (`Focus dir, [ `Meta ]) ]
+      | _, [ (`Tab, mods) ] when mods == [] || mods = [ `Shift ] ->
+          dispatch_key st
+            [
+              ( `Focus (if List.mem `Shift mods then `Prev else `Next),
+                mods );
+            ]
+      | _, [ (`Focus dir, _) ] ->
           let r = dispatch_focus st.view dir in
           (if r then Log.debug else Log.warn) (fun m ->
-              m "Renderer.dispatch_focus key:%a -> %b" pp_key key r);
+              m "Renderer.dispatch_focus key:%a -> %b" pp_keys keys r);
           if r then `Handled else `Unhandled
-      | `Unhandled, _ -> `Unhandled
+      | a, _ -> a
 
     let dispatch_event t = function
-      | `Key key -> dispatch_key t key
+      | `Keys keys -> dispatch_key t keys
       | `Mouse mouse -> dispatch_mouse t mouse
       | `Paste _ -> `Unhandled
   end
@@ -2357,21 +2439,30 @@ module Nottui_lwt = struct
       push (Some (Renderer.image vg renderer))
     in
     refresh ();
+    let key_list = ref [] in
     let process_event e =
       match e with
-      | `Key (`Uchar c, [ `Meta ]) as event
+      | `Keys [ (`Uchar c, [ `Meta ]) ] as event
         when Uchar.(equal c (of_char 'q')) -> (
           match do_quit with
           | Some u -> Lwt.wakeup u ()
           | None -> ignore (Renderer.dispatch_event renderer event))
+      | `Keys [ (`Unknown _, _) ] -> ()
+      | `Keys k -> (
+          key_list := !key_list @ k;
+          match
+            Renderer.dispatch_event renderer (`Keys !key_list)
+          with
+          | `Handled | `Unhandled -> key_list := []
+          | `Moar -> ())
       | #Ui.event as event -> (
           match Renderer.dispatch_event renderer event with
           | `Handled -> ()
-          | `Unhandled ->
-              (* Log.warn (fun m ->
+          | `Moar | `Unhandled ->
+              Log.warn (fun m ->
                   m
                     "Nottui_lwt.render process_event #Ui.event -> \
-                     `Unhandled") *)
+                     `Unhandled");
               ())
       | `Resize size' ->
           size := size';
@@ -2407,6 +2498,7 @@ module Widgets = struct
   let float_ ?attr x = string ?attr (string_of_float x)
   let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt
   let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt
+  let eq_uc_c uc c = Uchar.(equal uc (of_char c))
 
   let kprintf k ?attr fmt =
     Printf.ksprintf (fun str -> k (string ?attr str)) fmt
@@ -2419,16 +2511,44 @@ module Widgets = struct
     view : ui Lwd.t;
   }
 
+  let display_keys (k : Ui.keys option Lwd.var) : Ui.t Lwd.t =
+    Lwd.map (Lwd.get k) ~f:(function
+      | Some k' -> string (F.str "%a" Ui.pp_keys k')
+      | None -> string "---")
+
   let window_manager base =
     let overlays = Lwd_table.make () in
     let composition =
       Lwd.join
         (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays)
     in
+    let keys = Lwd.var None in
     let view =
       Lwd.map2 base composition ~f:(fun base composite ->
-          Ui.join_z base
-            (Ui.resize_to (Ui.layout_spec base) composite))
+          Ui.event_filter
+            (function
+              | `Keys k' ->
+                  Log.debug (fun m ->
+                      m "event_filter: window_manager `Keys %a"
+                        Ui.pp_keys k');
+                  Lwd.set keys (Some k');
+                  if
+                    List.mem
+                      (`Uchar (Uchar.of_char 'g'), [ `Ctrl ])
+                      k'
+                    ||
+                    match k' with
+                    | [ (`Escape, []) ] -> true
+                    | _ -> false
+                  then `Handled
+                  else `Unhandled
+              | _ -> `Unhandled)
+            (Ui.join_z base
+               (Ui.resize_to (Ui.layout_spec base) composite)))
+    in
+    let view =
+      Lwd.map2 view (display_keys keys) ~f:(fun view extra ->
+          Ui.join_y view extra)
     in
     { overlays; view }
 
@@ -2545,12 +2665,13 @@ module Widgets = struct
                Log.debug (fun m ->
                    m "keyboard_area: scroll_area focus_handler");
                match e with
-               | `Arrow `Left, [] -> scroll (-.scroll_step) 0.
-               | `Arrow `Right, [] -> scroll (+.scroll_step) 0.
-               | `Arrow `Up, [] -> scroll 0. (-.scroll_step)
-               | `Arrow `Down, [] -> scroll 0. (+.scroll_step)
-               | `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
-               | `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
+               | [ (`Arrow `Left, []) ] -> scroll (-.scroll_step) 0.
+               | [ (`Arrow `Right, []) ] -> scroll (+.scroll_step) 0.
+               | [ (`Arrow `Up, []) ] -> scroll 0. (-.scroll_step)
+               | [ (`Arrow `Down, []) ] -> scroll 0. (+.scroll_step)
+               | [ (`Page `Up, []) ] -> scroll 0. (-.scroll_step *. 8.)
+               | [ (`Page `Down, []) ] ->
+                   scroll 0. (+.scroll_step *. 8.)
                | _ -> `Unhandled))
 
   let main_menu_item wm text f =
@@ -2695,8 +2816,6 @@ module Widgets = struct
     in
     Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot)
 
-  let eq_uc_c uc c = Uchar.(equal uc (of_char c))
-
   let edit_field ?(focus = Focus.make ()) ?(on_change = Fun.id) state
       =
     let update focus_h focus (text, pos) =
@@ -2724,14 +2843,21 @@ module Widgets = struct
           `Handled
         in
         (match k with
-        | `Uchar c, [ `Ctrl ] when Uchar.(equal c (of_char 'U')) ->
+        | [ (`Uchar c, [ `Ctrl ]) ] when Uchar.(equal c (of_char 'U'))
+          ->
             on_change ("", 0) (* clear *)
-        | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' ->
+        | [ (`End, []) ] -> on_change (text, String.length text)
+        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'e' ->
+            on_change (text, String.length text)
+        | [ (`Home, []) ] -> on_change (text, 0)
+        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'a' ->
+            on_change (text, String.length text)
+        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
             (* TODO put killed text into kill-ring *)
             if pos < String.length text then
               on_change (String.sub text 0 pos, pos)
             else `Unhandled (* kill *)
-        | `Backspace, [] ->
+        | [ (`Backspace, []) ] ->
             if pos > 0 then
               let text =
                 if pos < String.length text then
@@ -2744,7 +2870,7 @@ module Widgets = struct
               let pos = max 0 (pos - 1) in
               on_change (text, pos)
             else `Unhandled
-        | `Uchar k, [] ->
+        | [ (`Uchar k, []) ] ->
             let k = Uchar.unsafe_to_char k in
             let text =
               if pos < String.length text then
@@ -2753,19 +2879,19 @@ module Widgets = struct
               else text ^ String.make 1 k
             in
             on_change (text, pos + 1)
-        | `Escape, [] ->
+        | [ _; (`Escape, []) ] ->
             Focus.release focus_h;
             `Handled
-        | `Arrow `Left, [] ->
+        | [ (`Arrow `Left, []) ] ->
             if pos > 0 then on_change (text, pos - 1) else `Unhandled
-        | `Arrow `Right, [] ->
+        | [ (`Arrow `Right, []) ] ->
             let pos = pos + 1 in
             if pos <= String.length text then on_change (text, pos)
             else `Unhandled
         | _ -> `Unhandled)
         |> fun r ->
         Log.debug (fun m ->
-            m "edit_field keyboard_area handler %a -> %a" Ui.pp_key k
+            m "edit_field keyboard_area handler %a -> %a" Ui.pp_keys k
               Ui.pp_may_handle r);
         r
       in
@@ -2913,22 +3039,23 @@ module Widgets = struct
     |> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
            Ui.keyboard_area ~focus (fun k ->
                Log.debug (fun m ->
-                   m "keyboard_area: edit_area handler %a" Ui.pp_key k);
+                   m "keyboard_area: edit_area handler %a" Ui.pp_keys
+                     k);
                let cursor_move =
                  cursor_move ~update:copy_line_cursor cursor
                in
                match k with
-               | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
+               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                    cursor_move Lwd_table.next
-               | `Arrow `Down, _ -> cursor_move Lwd_table.next
-               | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
+               | [ (`Arrow `Down, _) ] -> cursor_move Lwd_table.next
+               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                    cursor_move Lwd_table.prev
-               | `Arrow `Up, _ -> cursor_move Lwd_table.prev
-               | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
+               | [ (`Arrow `Up, _) ] -> cursor_move Lwd_table.prev
+               | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '<' ->
                    cursor_move (fun _ -> Lwd_table.first table)
-               | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
+               | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '>' ->
                    cursor_move (fun _ -> Lwd_table.last table)
-               | `Enter, [] ->
+               | [ (`Enter, []) ] ->
                    line_of_cursor cursor (fun old_row old_line ->
                        let str, pos = Lwd.peek old_line.state in
                        let o_str = String.sub str 0 pos in
@@ -2942,7 +3069,7 @@ module Widgets = struct
                        Lwd.set cursor
                          (Some (Lwd_table.after old_row ~set:new_line));
                        `Handled)
-               | `Backspace, [] ->
+               | [ (`Backspace, []) ] ->
                    line_of_cursor cursor (fun row line ->
                        let str, pos = Lwd.peek line.state in
                        Ui.may_handle (Lwd_table.prev row)
@@ -2961,7 +3088,8 @@ module Widgets = struct
                                  Lwd_table.remove row;
                                  `Handled)
                            else `Unhandled))
-               | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
+               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
+                   `Handled
                | _ -> `Unhandled))
 
   (* TODO: view_metadata *)
@@ -2999,7 +3127,7 @@ module Widgets = struct
         |> Option.iter (fun r ->
                Lwd_table.get r
                |> Option.iter (fun l -> Focus.request l.focus));
-        (* Build view of table *)
+
         Lwt.return
           (Lwd_table.map_reduce
              (fun _ { ui; _ } -> ui)
@@ -3016,22 +3144,24 @@ module Widgets = struct
 
                  Ui.keyboard_area ~focus:focus' (fun k ->
                      Log.debug (fun m ->
-                         m "node_edit_area handler %a" Ui.pp_key k);
+                         m "node_edit_area handler %a" Ui.pp_keys k);
                      let cursor_move =
                        cursor_move ~update:copy_line_cursor cursor
                      in
                      match k with
-                     | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
+                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                          cursor_move Lwd_table.next
-                     | `Arrow `Down, _ -> cursor_move Lwd_table.next
-                     | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
+                     | [ (`Arrow `Down, _) ] ->
+                         cursor_move Lwd_table.next
+                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                          cursor_move Lwd_table.prev
-                     | `Arrow `Up, _ -> cursor_move Lwd_table.prev
-                     | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
+                     | [ (`Arrow `Up, _) ] ->
+                         cursor_move Lwd_table.prev
+                     | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '<' ->
                          cursor_move (fun _ -> Lwd_table.first table)
-                     | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
+                     | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '>' ->
                          cursor_move (fun _ -> Lwd_table.last table)
-                     | `Enter, [] ->
+                     | [ (`Enter, []) ] ->
                          line_of_cursor cursor
                            (fun old_row old_line ->
                              let str, pos = Lwd.peek old_line.state in
@@ -3048,7 +3178,7 @@ module Widgets = struct
                                   (Lwd_table.after old_row
                                      ~set:new_line));
                              `Handled)
-                     | `Backspace, [] ->
+                     | [ (`Backspace, []) ] ->
                          line_of_cursor cursor (fun row line ->
                              let str, pos = Lwd.peek line.state in
                              Ui.may_handle (Lwd_table.prev row)
@@ -3068,9 +3198,9 @@ module Widgets = struct
                                        Lwd_table.remove row;
                                        `Handled)
                                  else `Unhandled))
-                     | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' ->
+                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
                          `Handled
-                     | `Uchar u, [ `Ctrl ] when eq_uc_c u 'x' ->
+                     | [ (`Uchar s, [ `Ctrl ]) ] when eq_uc_c s 's' ->
                          let b = Buffer.create 1024 in
                          Lwd_table.iter
                            (fun line ->
@@ -3097,8 +3227,8 @@ module Widgets = struct
       Ui.may_handle (Lwd.peek cursor) (fun cursor_row ->
           Ui.may_handle (f cursor_row) (fun new_row ->
               Lwd_table.get new_row
-              |> Option.iter (fun (new_line_focus, new_line_sel) ->
-                     Lwd.set selection (Some new_line_sel);
+              |> Option.iter (fun ((new_line_focus, _) as new_line) ->
+                     Lwd.set selection (Some new_line);
                      Lwd_table.get cursor_row
                      |> Option.iter (fun (cursor_line_focus, _) ->
                             Focus.release cursor_line_focus);
@@ -3114,6 +3244,7 @@ module Widgets = struct
         Lwd_table.append' table (Focus.make (), step))
       treelist;
     let cursor = Lwd.var @@ Lwd_table.first table in
+    Log.debug (fun m -> m "tree_nav cursor focus.request");
     Lwd.peek cursor
     |> Option.iter (fun cursor ->
            Lwd_table.get cursor
@@ -3122,8 +3253,17 @@ module Widgets = struct
       (Lwd_table.map_reduce
          (fun _ (f, s) ->
            Lwd.map (Focus.status f) ~f:(fun focus_h ->
-               if Focus.has_focus focus_h then string ~attr:A.cursor s
-               else string s))
+               Ui.keyboard_area ~focus:focus_h
+                 (fun k ->
+                   Log.debug (fun m ->
+                       m
+                         "keyboard_area: tree_nav map_reduce \
+                          %a->`Unhandled"
+                         Ui.pp_keys k);
+                   `Unhandled)
+                 (if Focus.has_focus focus_h then
+                  string ~attr:A.cursor s
+                 else string s)))
          (Lwd_utils.lift_monoid Ui.pack_y)
          table
       |> Lwd.join
@@ -3132,155 +3272,94 @@ module Widgets = struct
                Lwd.peek cursor
                |> Option.iter (fun cursor ->
                       Lwd_table.get cursor
-                      |> Option.iter (fun (f, _) -> Focus.request f));
+                      |> Option.iter (fun (f, _) ->
+                             Log.debug (fun m ->
+                                 m "tree_nav has_focus request %a"
+                                   Focus.pp_status focus');
+                             Focus.request f));
              Ui.keyboard_area ~focus:focus' (fun k ->
                  Log.debug (fun m ->
-                     m "keyboard_area: tree_nav %a" Ui.pp_key k);
+                     m "keyboard_area: tree_nav %a" Ui.pp_keys k);
                  match k with
-                 | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
+                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                      cursor_move cursor Lwd_table.next |> ignore;
                      `Handled
-                 | `Arrow `Down, _ ->
+                 | [ (`Arrow `Down, _) ] ->
                      cursor_move cursor Lwd_table.next |> ignore;
                      `Handled
-                 | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
+                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                      cursor_move cursor Lwd_table.prev |> ignore;
                      `Handled
-                 | `Arrow `Up, _ ->
+                 | [ (`Arrow `Up, _) ] ->
                      cursor_move cursor Lwd_table.prev |> ignore;
                      `Handled
-                 | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
+                 | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '<' ->
                      cursor_move cursor (fun _ ->
                          Lwd_table.first table)
-                 | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
+                 | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '>' ->
                      cursor_move cursor (fun _ ->
                          Lwd_table.last table)
-                 | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
-                 | `Enter, [] -> `Unhandled
-                 | `Backspace, [] -> `Unhandled
+                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
+                     `Handled
+                 | [ (`Enter, []) ] -> `Unhandled
+                 | [ (`Backspace, []) ] -> `Unhandled
                  | _ -> `Unhandled)))
 
-  (* let cursorview =
-       Lwd.var @@ Lwd.pure @@ string "initializing..."
-     in
-     let cv, push_cv = Lwt_stream.create () in
-     let cvroot =
-       Lwd.observe ~on_invalidate:(fun _ ->
-           Log.info (fun m ->
-               m
-                 "tree_nav cursorviewroot on_invalidate push_cv \
-                  triggered??");
-           push_cv (Some ()))
-       @@ Lwd.map (Lwd.get cursor) ~f:(function
-            | Some cursor_row -> (
-                match Lwd_table.get cursor_row with
-                | Some (focus, step) -> (
-                    let path' = path @ [ step ] in
-                    Nav.S.kind store path' >>= function
-                    | Some `Node -> lwt_lwd_string "Sub-node??"
-                    | Some `Contents -> node_edit_area (store, path')
-                    | None ->
-                        lwt_lwd_string
-                          ("Nav.S.kind " ^ String.concat "/" path'
-                         ^ " -> None?"))
-                | None ->
-                    lwt_lwd_string "cursor table row doesn't exist")
-            | None -> lwt_lwd_string "cursor doesn't exist")
-     in
-     Lwt.async (fun () ->
-         Lwt_stream.iter_s
-           (fun _ ->
-             Lwd.quick_sample cvroot >>= fun cursorview'' ->
-             Log.info (fun m ->
-                 m "tree_nav Lwt.async (Lwd.set cursorview)");
-             Lwt.return (Lwd.set cursorview cursorview''))
-           cv);
-       push_cv (Some ()); *)
-  (*|> Lwd.map2
-       (Lwd.join @@ Lwd.get cursorview)
-       ~f:(fun cursorview' tree_view ->
-         Ui.join_x tree_view cursorview') *)
-
   open Lwt.Infix
 
   let rec node_ui ?(focus = Focus.make ()) store path
-      (f : Focus.handle * ui Lwd.t -> unit) : unit =
+      (f : ui Lwd.t -> unit) : unit =
     Lwt.async (fun () ->
         Nav.S.tree store >>= fun tree ->
         Nav.S.Tree.kind tree path >>= function
         | None ->
             f
-              ( focus,
-                Lwd.pure
+              (Lwd.pure
               @@ string
                    ("Nav.S.Tree.kind " ^ String.concat "/" path
-                    ^ " how'd you get here??") );
+                  ^ " how'd you get here??"));
             Lwt.return_unit
         | Some `Node ->
             let selection = Lwd.var None in
             tree_nav ~selection ~focus (store, path) >>= fun ui ->
             f
-              ( focus,
-                Lwd.map2
+              (Lwd.map2
                  (Lwd.pair (Focus.status focus) (Lwd.get selection))
                  ui
                  ~f:(fun (focus', selection) ui ->
                    Ui.keyboard_area ~focus:focus'
                      (fun k ->
                        Log.debug (fun m ->
-                            m "keyboard_area: node_ui %a" Ui.pp_key k);
-
+                           m "keyboard_area: node_ui %a" Ui.pp_keys k);
                        match k with
-                        | `Enter, [] -> (
-                            Focus.release focus;
+                       | [ (`Enter, []) ] -> (
                            match selection with
-                            | Some sel ->
-                                Log.info (fun m ->
-                                    m "node_ui selecting '%s'" sel);
-                                node_ui store (path @ [ sel ]) f;
-                                Log.info (fun m ->
-                                    m "node_ui done selecting '%s'"
-                                      sel);
-
+                           | Some (sel_focus, sel_str) ->
+                               node_ui store (path @ [ sel_str ]) f;
+                               Focus.release sel_focus;
                                `Handled
                            | None -> `Unhandled)
                        | _ -> `Unhandled)
-                      ui) );
+                     ui));
             Lwt.return_unit
         | Some `Contents ->
             node_edit_area ~focus (store, path) >>= fun ui ->
-            f (focus, ui);
+            f ui;
             Lwt.return_unit)
 
   let h_node_area ?(table = Lwd_table.make ())
-      ?(focus = Focus.make ())
       ((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t =
     List.iter
       (fun path ->
         node_ui store path (fun v -> Lwd_table.append' table v))
       paths;
-    let _cursor = Lwd.var @@ Lwd_table.first table in
     Lwd_table.map_reduce
-      (fun _row (focus, ui) ->
-        Lwd.map2 ui (Focus.status focus) ~f:(fun ui focus ->
-            Ui.pad
-              ?a:
-                (if Focus.has_focus focus then
-                 Some
-                   A.(bg (NVG.Color.rgbaf ~r:1. ~g:1. ~b:1. ~a:0.5))
-                else None)
-              ~l:5. ~r:10. ~t:15. ~b:20. ui))
+      (fun _row ui ->
+        Lwd.map ui ~f:(fun ui ->
+            Ui.pad ~l:10. ~r:10. ~t:10. ~b:10. ui))
       (Lwd_utils.lift_monoid Ui.pack_x)
       table
     |> Lwd.join
-    |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
-           Ui.keyboard_area ~focus:focus' (fun k ->
-               Log.debug (fun m ->
-                   m "keyboard_area: h_node_area_handler %a" Ui.pp_key
-                     k);
-               match k with
-               | `Enter, [] -> `Unhandled
-               | _ -> `Unhandled))
 
   (** Tab view, where exactly one element of [l] is shown at a time. *)
   let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t
@@ -3510,7 +3589,7 @@ module Widgets = struct
   let button_of ui f =
     Ui.keyboard_area
       (function
-        | `Enter, _ ->
+        | [ (`Enter, _) ] ->
             f ();
             `Handled
         | _ -> `Unhandled)

log_js.ml

@@ -0,0 +1,56 @@
+module Logs_reporter = struct
+  (* Console reporter *)
+
+  open Jsoo_runtime
+
+  let console : Logs.level -> string -> unit =
+   fun level s ->
+    let meth =
+      match level with
+      | Logs.Error -> "error"
+      | Logs.Warning -> "warn"
+      | Logs.Info -> "info"
+      | Logs.Debug -> "debug"
+      | Logs.App -> "log"
+    in
+    ignore
+      (Js.meth_call
+         (Js.pure_js_expr "console")
+         meth
+         [| Js.string s |])
+
+  let ppf, flush =
+    let b = Buffer.create 255 in
+    let flush () =
+      let s = Buffer.contents b in
+      Buffer.clear b;
+      s
+    in
+    (Format.formatter_of_buffer b, flush)
+
+  let hook =
+    ref (fun level s ->
+        ignore (Logs.level_to_string (Some level) ^ ": " ^ s))
+
+  let console_report _src level ~over k msgf =
+    let k _ =
+      let s = flush () in
+      console level s;
+      !hook level s;
+      over ();
+      k ()
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    let _tags = tags in
+    match header with
+    | None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
+    | Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h
+
+  let console_reporter () = { Logs.report = console_report }
+end
+
+let _ =
+  Logs.set_reporter (Logs_reporter.console_reporter ());
+  Logs.set_level (Some Debug)
+
+module Log = Logs

toplevel.html

@@ -0,0 +1,230 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+          "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+  <head>
+    <title>OCaml toplevel</title>
+    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+    <link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
+    <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
+    <style>
+
+      code, kbd, pre, samp {
+      font-family: Menlo,Monaco,Consolas,monospace;
+      }
+      body,html {
+      height: 100%;
+      background-color:#eee;
+      }
+
+      #toplevel-container {
+      width: 50%;
+      background-color: black;
+      color: #ccc;
+      overflow: auto;
+      overflow-x: hidden;
+      height: 100%;
+      float:left;
+      padding:10px;
+      padding-top: 20px;
+      }
+
+      #toplevel-container pre#output {
+      padding: 0px;
+      }
+
+      #toplevel-container #output {
+      background-color:transparent;
+      color: #ccc;
+      border: none;
+      line-height:18px;
+      font-size: 12px;
+      margin-bottom: 0px;
+      }
+
+      #toplevel-container textarea {
+      width:90%;
+      line-height:18px;
+      font-size: 12px;
+      background-color: transparent;
+      color: #fff;
+      border: 0;
+      resize: none;
+      outline: none;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      font-weight: bold;
+      float:left;
+      margin: 0px;
+      padding:0px;
+      }
+      #toplevel-container #sharp {
+      float: left;
+      line-height:18px;
+      font-size: 12px;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      white-space: pre;
+      }
+      .sharp:before{
+      content:"# ";
+      line-height:18px;
+      font-size: 12px;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      }
+      .caml{
+      color:rgb(110, 110, 201);
+      }
+      #toplevel-side{
+      position:relative;
+      width:45%;
+      height: 100%;
+      overflow: auto;
+      text-align:justify;
+      float:left;
+      margin-left:30px;
+      }
+      #toplevel-side ul{
+      padding: 0px;
+      list-style-type: none;
+      }
+
+      .stderr {
+      color: #d9534f;
+      }
+      .stdout {
+
+      }
+      .errorloc{
+      border-bottom-width: 3px;
+      border-bottom-style: solid;
+      border-bottom-color: red;
+      }
+      canvas {
+      border: 1px dashed black;
+      float: left;
+      margin: 7px;
+      }
+      #output canvas {
+      background-color: #464646;
+      float: none;
+      display: block;
+      border: 1px dashed while;
+      margin: 7px;
+      }
+      #output img {
+      display:block;
+      }
+      #toplevel-examples {
+      width: 270px;
+      float: left;
+      }
+      #toplevel-examples .list-group-item{
+      padding: 5px 15px;
+      }
+      #btn-share {
+      float:right;
+      margin-top:-20px;
+      background-color:rgb(92, 129, 184);
+      border-color: rgb(70, 75, 128);
+      padding: 1px 5px;
+      display:none;
+      }
+      .clear { clear:both; }
+
+      .sharp .id { color: #59B65C ; font-style: italic }
+      .sharp .kw0 { color: rgb(64, 75, 190); font-weight: bold ;}
+      .sharp .kw1 { color: rgb(150, 0, 108); font-weight: bold ;}
+      .sharp .kw2 { color: rgb(23, 100, 42); font-weight: bold ;}
+      .sharp .kw3 { color: #59B65C; font-weight: bold ;}
+      .sharp .kw4 { color: #59B65C; font-weight: bold ;}
+      .sharp .comment { color: green ; font-style: italic ; }
+      .sharp .string { color: #6B6B6B; font-weight: bold ; }
+      .sharp .text { }
+      .sharp .numeric { color: #729AAF; }
+      .sharp .directive { font-style: italic ; color : #EB00FF; } ;
+      .sharp .escape { color: #409290 ; }
+      .sharp .symbol0 { color: orange ; font-weight: bold ; }
+      .sharp .symbol1 { color: #993300 ; font-weight: bold ; }
+      .sharp .constant { color: rgb(0, 152, 255); }
+    </style>
+    <script type="text/javascript">
+
+      window.onhashchange = function() { window.location.reload() }
+      var hash = window.location.hash.replace(/^#/,"");
+      var fields = hash.split(/&/);
+      var prefix = "";
+      var version = "";
+      for(var f in fields){
+        var data = fields[f].split(/=/);
+        if(data[0] == "version"){
+          version = data[1].replace(/%20|%2B/g,"+");
+          break;
+        }
+      }
+      function load_script(url){
+        var fileref=document.createElement('script');
+        fileref.setAttribute("type","text/javascript");
+        fileref.setAttribute("src", prefix+(version==""?"":(version+"/"))+url);
+        document.getElementsByTagName("head")[0].appendChild(fileref);
+      }
+      load_script("_build/default/exported-unit.cmis.js");
+      load_script("_build/default/toplevel.bc.js");
+
+    </script>
+  </head>
+  <body>
+    <div id="toplevel-container">
+      <pre id="output"></pre>
+      <div>
+        <div id="sharp" class="sharp"></div>
+        <textarea id="userinput">Loading ...</textarea>
+        <button type="button" class="btn btn-default"
+                id="btn-share">Share</button>
+      </div>
+    </div>
+    <div id="toplevel-side">
+      <h3>Js_of_ocaml</h3>
+      <h4>A compiler from OCaml bytecode to Javascript.</h4>
+      <p>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.</p>
+      <p>This web-based OCaml toplevel is compiled using Js_of_ocaml.</p>
+      <h4>Command</h4>
+      <table class="table table-striped table-condensed">
+        <tbody class>
+          <tr>
+            <td>Enter/Return</td>
+            <td>Submit code</td>
+          </tr>
+          <tr>
+            <td>Ctrl + Enter</td>
+            <td>Newline</td>
+          </tr>
+          <tr>
+            <td>Up / Down</td>
+            <td>Browse history</td>
+          </tr>
+          <tr>
+            <td>Ctrl + l</td>
+            <td>Clear display</td>
+          </tr>
+          <tr>
+            <td>Ctrl + k</td>
+            <td>Reset toplevel</td>
+          </tr>
+          <tr>
+            <td>Tab</td>
+            <td>Indent code</td>
+          </tr>
+
+        </tbody>
+      </table>
+      <h4>Try to execute samples</h4>
+      <div id="toplevel-examples" class="list-group"></div>
+      <canvas width=200 height=200 id="test-canvas"></canvas>
+      <h4 class="clear">See the generated javascript code</h4>
+      <pre id="last-js">
+      </pre>
+    </div>
+  </body>
+</html>

toplevel.ml

@@ -0,0 +1,645 @@
+(* 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
+
+module Graphics_support = struct
+  let init elt = Graphics_js.open_canvas elt
+end
+
+module Log = Log_js.Log
+
+module Ppx_support = struct
+  let init () =
+    Ppx_graph.init ();
+    Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper);
+    Ast_mapper.register "ppxlib" (fun _ ->
+        Log.info (fun m -> m "Ppxlib.mapper");
+        {
+          Ast_mapper.default_mapper with
+          structure =
+            (fun _ ->
+              Log.info (fun m -> m "Ppxlib.Driver.map_structure");
+              Ppxlib.Driver.map_structure);
+          signature =
+            (fun _ ->
+              Log.info (fun m -> m "Ppxlib.Driver.map_signature");
+              Ppxlib.Driver.map_signature);
+        })
+end
+
+module Colorize = struct
+  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_))
+end
+
+module Indent : sig
+  val textarea : Dom_html.textAreaElement Js.t -> unit
+end = struct
+  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 ""
+
+  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 = 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 -> ()
+end
+
+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 () =
+  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://");
+  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 () =
+  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 ();
+  let[@alert "-deprecated"] new_directive n k =
+    Hashtbl.add Toploop.directive_table n k
+  in
+  new_directive "load_js"
+    (Toploop.Directive_string
+       (fun name -> Js.Unsafe.global##load_script_ name));
+  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 = 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;
+  Ppx_graph.setup_graph ~container ~textbox;
+  setup_examples ~container ~textbox;
+  setup_pseudo_fs ();
+  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 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)