telist is lwd.var

.gitignore

@@ -1,3 +1,3 @@
 *~
 _build/
-gitkey.ml
+secrets.ml

.ocamlformat

@@ -0,0 +1,3 @@
+profile = default
+version = 0.26.2
+parse-toplevel-phrases=false

b64.ml

@@ -1,82 +0,0 @@
-(*
- * Copyright (c) 2006-2009 Citrix Systems Inc.
- * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *
- *)
-
-let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
-
-let uri_safe_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
-
-let padding = '='
-
-let of_char ?(alphabet = default_alphabet) x =
-  if x = padding then 0 else String.index alphabet x
-
-let to_char ?(alphabet = default_alphabet) x = alphabet.[x]
-
-let decode ?alphabet input =
-  let length = String.length input in
-  let input =
-    if length mod 4 = 0 then input else input ^ String.make (4 - (length mod 4)) padding
-  in
-  let length = String.length input in
-  let words = length / 4 in
-  let padding =
-    match length with
-    | 0 -> 0
-    | _ when input.[length - 2] = padding -> 2
-    | _ when input.[length - 1] = padding -> 1
-    | _ -> 0
-  in
-  let output = Bytes.make ((words * 3) - padding) '\000' in
-  for i = 0 to words - 1 do
-    let a = of_char ?alphabet input.[(4 * i) + 0]
-    and b = of_char ?alphabet input.[(4 * i) + 1]
-    and c = of_char ?alphabet input.[(4 * i) + 2]
-    and d = of_char ?alphabet input.[(4 * i) + 3] in
-    let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in
-    let x = (n lsr 16) land 255 and y = (n lsr 8) land 255 and z = n land 255 in
-    Bytes.set output ((3 * i) + 0) (char_of_int x);
-    if i <> words - 1 || padding < 2 then Bytes.set output ((3 * i) + 1) (char_of_int y);
-    if i <> words - 1 || padding < 1 then Bytes.set output ((3 * i) + 2) (char_of_int z)
-  done;
-  Bytes.unsafe_to_string output
-
-let encode ?(pad = true) ?alphabet input =
-  let length = String.length input in
-  let words = (length + 2) / 3 in
-  (* rounded up *)
-  let padding_len = if length mod 3 = 0 then 0 else 3 - (length mod 3) in
-  let output = Bytes.make (words * 4) '\000' in
-  let get i = if i >= length then 0 else int_of_char input.[i] in
-  for i = 0 to words - 1 do
-    let x = get ((3 * i) + 0) and y = get ((3 * i) + 1) and z = get ((3 * i) + 2) in
-    let n = (x lsl 16) lor (y lsl 8) lor z in
-    let a = (n lsr 18) land 63
-    and b = (n lsr 12) land 63
-    and c = (n lsr 6) land 63
-    and d = n land 63 in
-    Bytes.set output ((4 * i) + 0) (to_char ?alphabet a);
-    Bytes.set output ((4 * i) + 1) (to_char ?alphabet b);
-    Bytes.set output ((4 * i) + 2) (to_char ?alphabet c);
-    Bytes.set output ((4 * i) + 3) (to_char ?alphabet d)
-  done;
-  for i = 1 to padding_len do
-    Bytes.set output (Bytes.length output - i) padding
-  done;
-  if pad
-  then Bytes.unsafe_to_string output
-  else Bytes.sub_string output 0 (Bytes.length output - padding_len)

b64.mli

@@ -1,40 +0,0 @@
-(*
- * Copyright (c) 2006-2009 Citrix Systems Inc.
- * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
- * Copyright (c) 2014-2016 Anil Madhavapeddy <anil@recoil.org>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *
- *)
-
-(** Base64 RFC4648 implementation.
-
-    Base64 is a group of similar binary-to-text encoding schemes that represent binary
-    data in an ASCII string format by translating it into a radix-64 representation. It
-    is specified in RFC 4648. *)
-
-val default_alphabet : string
-(** A 64-character string specifying the regular Base64 alphabet. *)
-
-val uri_safe_alphabet : string
-(** A 64-character string specifying the URI- and filename-safe Base64 alphabet. *)
-
-val decode : ?alphabet:string -> string -> string
-(** [decode s] decodes the string [s] that is encoded in Base64 format. Will leave
-    trailing NULLs on the string, padding it out to a multiple of 3 characters.
-    [alphabet] defaults to {!default_alphabet}.
-    @raise Not_found if [s] is not a valid Base64 string. *)
-
-val encode : ?pad:bool -> ?alphabet:string -> string -> string
-(** [encode s] encodes the string [s] into base64. If [pad] is false, no trailing padding
-    is added. [pad] defaults to [true], and [alphabet] to {!default_alphabet}. *)

colorize.ml

@@ -1,39 +0,0 @@
-open Js_of_ocaml
-open Js_of_ocaml_tyxml
-
-let text ~a_class:cl s = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ])
-
-let ocaml ~a_class:cl s =
-  let tks = Higlo.Lang.parse ~lang:"ocaml" s in
-  let span' cl (s, _) = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) in
-  let make_span = function
-    | Higlo.Lang.Bcomment s -> span' "comment" s
-    | Higlo.Lang.Constant s -> span' "constant" s
-    | Higlo.Lang.Directive s -> span' "directive" s
-    | Higlo.Lang.Escape s -> span' "escape" s
-    | Higlo.Lang.Id s -> span' "id" s
-    | Higlo.Lang.Keyword (level, s) -> span' (Printf.sprintf "kw%d" level) s
-    | Higlo.Lang.Lcomment s -> span' "comment" s
-    | Higlo.Lang.Numeric s -> span' "numeric" s
-    | Higlo.Lang.String s -> span' "string" s
-    | Higlo.Lang.Symbol (level, s) -> span' (Printf.sprintf "sym%d" level) s
-    | Higlo.Lang.Text s -> span' "text" s
-    | Higlo.Lang.Title (_, s) -> span' "text" s
-  in
-  Tyxml_js.Html.(div ~a:[ a_class [ cl ] ] (List.map make_span tks))
-
-let highlight (`Pos from_) to_ e =
-  let _ =
-    List.fold_left
-      (fun pos e ->
-        match Js.Opt.to_option (Dom_html.CoerceTo.element e) with
-        | None -> pos
-        | Some e ->
-            let size = Js.Opt.case e##.textContent (fun () -> 0) (fun t -> t##.length) in
-            if pos + size > from_ && (to_ = `Last || `Pos pos < to_)
-            then e##.classList##add (Js.string "errorloc");
-            pos + size)
-      0
-      (Dom.list_of_nodeList e##.childNodes)
-  in
-  ()

colorize.mli

@@ -1,9 +0,0 @@
-open Js_of_ocaml
-open Js_of_ocaml_tyxml
-
-val text : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
-
-val ocaml : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
-
-val highlight :
-  [ `Pos of int ] -> [ `Last | `Pos of int ] -> Dom_html.element Js.t -> unit

cors_proxy.ml

@@ -1,217 +0,0 @@
-module Format = Stdlib.Format
-module Arg = Stdlib.Arg
-open Lwt.Infix
-open Httpaf
-
-module Server = struct
-  include Httpaf_lwt_unix.Server
-
-  let error_handler ?request:_ error start_response =
-    let response_body = start_response Headers.empty in
-    (match error with
-    | `Exn exn ->
-        Body.write_string response_body (Base.Exn.to_string exn);
-        Body.write_string response_body "\n"
-    | #Status.standard as error ->
-        Body.write_string response_body
-          (Status.default_reason_phrase error));
-    Body.close_writer response_body
-end
-
-let proxy_host = "gitea.departmentofinter.net"
-
-let file_response_headers =
-  [
-    ("accept-ranges", "bytes");
-    ("access-control-allow-origin", "*");
-    ( "access-control-allow-headers",
-      "Origin, X-Requested-With, Content-Type, Accept, Range" );
-    ("cache-control", "no-cache, no-store, must-revalidate");
-    ("etag", "W/\"6861266-5562-2024-02-11T19:05:04.733Z\"");
-    ("content-type", "text/html; charset=UTF-8");
-    ("connection", "close");
-  ]
-
-let proxy_handler reqd : unit =
-  match Reqd.request reqd with
-  | Request.{ meth; headers; target; _ } ->
-      Lwt.async (fun () ->
-          let filename = Fmt.str "./%s" target in
-          if
-            Sys.file_exists
-              filename (* && Sys.is_regular_file filename *)
-          then (
-            let file =
-              Lwt_io.open_file ~flags:[ O_RDONLY ] ~mode:Lwt_io.input
-                filename
-            in
-            let headers = Headers.of_list file_response_headers in
-            Lwt_io.file_length filename >>= fun file_len ->
-            let headers =
-              Headers.add_list headers
-                [ ("content-length", Int64.to_string file_len) ]
-            in
-            Format.printf ">>> Response with File:\nHeaders:\n%s\n %!"
-              (Headers.to_string headers);
-            let response = Response.create ~headers `OK in
-            let response_body =
-              Reqd.respond_with_streaming reqd response
-            in
-            file >>= fun file ->
-            let rec reader () =
-              if
-                Int64.compare
-                  (Int64.sub file_len (Lwt_io.position file))
-                  Int64.zero
-                > 0
-              then (
-                Lwt_io.read file >>= fun s ->
-                Format.printf ".%i\n%!" (String.length s);
-                Body.write_string response_body s;
-
-                reader ())
-              else Lwt.return_unit >>= fun () -> Lwt.return_unit
-            in
-
-            reader () >>= fun () ->
-            Body.close_writer response_body;
-            Lwt_io.close file >>= fun () ->
-            Format.printf "done%!";
-            Lwt.return_unit)
-          else
-            let uri = Fmt.str "https://%s%s" proxy_host target in
-            let proxy_finished, proxy_notify_finished = Lwt.wait () in
-            let proxy_response_handler _
-                (proxy_response_body_acc : Buffer.t)
-                proxy_response_body =
-              Format.printf ">>> proxy_response_body chunk: %i\n%!"
-                (String.length proxy_response_body);
-              Buffer.add_string proxy_response_body_acc
-                proxy_response_body;
-              Lwt.return proxy_response_body_acc
-            in
-            let request_headers =
-              Headers.replace headers "Host" proxy_host
-            in
-            let request_headers =
-              Headers.replace request_headers "origin"
-                (Fmt.str "https://%s" proxy_host)
-            in
-            let request_headers =
-              Headers.replace request_headers "content-type"
-                "application/x-git-upload-pack-request"
-            in
-
-            let proxy_request_headers =
-              Headers.of_list
-                [
-                  ("Accept-Language", "en-US, *;q=0.9");
-                  ("Accept", "application/x-git-upload-pack-result");
-                  ( "Content-Type",
-                    "application/x-git-receive-upload-request" );
-                  ("Accept-Encoding", "deflate, gzip, br, zstd");
-                  ("User-Agent", "git/2.43.0");
-                  ( "Authorization",
-                    "Basic \
-                     Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM="
-                  );
-                  ("Host", "gitea.departmentofinter.net");
-                  ( "Content-Length",
-                    Option.fold ~some:Fun.id ~none:"0"
-                      (Headers.get headers "content-length") );
-                ]
-            in
-
-            let request_body = Reqd.request_body reqd in
-            let request_body_buffer =
-              Bigstringaf.create
-                (Option.fold ~some:int_of_string ~none:4096
-                   (Headers.get headers "content-length"))
-            in
-            let response_body_buffer = Buffer.create 0 in
-            let rec on_read buffer ~off ~len =
-              Bigstringaf.blit buffer ~src_off:off request_body_buffer
-                ~dst_off:off ~len;
-              Body.schedule_read request_body ~on_eof ~on_read
-            and on_eof () = Body.close_reader request_body in
-            Body.schedule_read request_body ~on_eof ~on_read;
-            Format.printf
-              ">>> Proxy Request: Target:%s Headers:\n%s\n%!" target
-              (String.trim (Headers.to_string request_headers));
-            Format.printf ">>> Proxy Request Body length: %i\n%!"
-              (Bigstringaf.length request_body_buffer);
-            Http_lwt_client.request
-              ?config:(Some (`HTTP_1_1 Httpaf.Config.default))
-              ~meth
-              ~headers:(Headers.to_list request_headers)
-              ?body:(Some (Bigstringaf.to_string request_body_buffer))
-              ~follow_redirect:false uri proxy_response_handler
-              response_body_buffer
-            >>= function
-            | Ok
-                ( { version; status; reason; headers },
-                  proxy_response_body_acc ) ->
-                Format.printf
-                  ">>> Response Ok: Code: %i Reason: %s Headers:\n\
-                   %s\n\
-                   %!"
-                  (H2.Status.to_code status)
-                  reason
-                  (String.trim (H2.Headers.to_string headers));
-                let headers =
-                  Headers.of_list (H2.Headers.to_list headers)
-                in
-                let status =
-                  Status.of_code (H2.Status.to_code status)
-                in
-                let response =
-                  let content_type =
-                    match Headers.get headers "content-type" with
-                    | None -> "application/octet-stream"
-                    | Some x -> x
-                  in
-                  Response.create ~reason ~version
-                    ~headers:
-                      (Headers.replace headers "content-type"
-                         content_type)
-                    status
-                in
-                let response_body =
-                  Reqd.respond_with_streaming reqd response
-                in
-                Body.write_string response_body ~off:0
-                  ~len:(Buffer.length proxy_response_body_acc)
-                  (Buffer.contents proxy_response_body_acc);
-                Body.close_writer response_body;
-                Lwt.wakeup_later proxy_notify_finished ();
-                Lwt.return_unit
-            | Error (`Msg msg) ->
-                Format.printf "Request failed with %s%!" msg;
-                Lwt.return_unit >>= fun () -> proxy_finished)
-(* | _ ->
-     let headers = Headers.of_list [ ("connection", "close") ] in
-     Reqd.respond_with_string reqd
-       (Response.create ~headers `Method_not_allowed)
-       "" *)
-
-let request_handler (_ : Unix.sockaddr) = proxy_handler
-let error_handler (_ : Unix.sockaddr) = Server.error_handler
-
-let main port =
-  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
-  Lwt.async (fun () ->
-      Lwt_io.establish_server_with_client_socket listen_address
-        (Server.create_connection_handler ~request_handler
-           ~error_handler)
-      >|= fun _server ->
-      Stdio.printf
-        "Listening on localhost:%i and proxying requests via \
-         https://%s.\n\
-         %!"
-        port proxy_host);
-  let forever, _ = Lwt.wait () in
-  Lwt_main.run forever
-
-let () =
-  let port = ref 8080 in
-  main !port

cors_proxy.sh

@@ -1,17 +0,0 @@
-#!/bin/bash
-#if [ ! -f /tmp/key.pem ]; then
-#  echo Creating key
-#  openssl req -newkey rsa:2048 -new -nodes -x509 -days 3650 -keyout /tmp/key.pem -out /tmp/cert.pem -batch
-#fi
-
-npx http-server --cors -S -P https://gitea.departmentofinter.net --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem
-
-# HTTP/1.1 204 No Content
-# accept-ranges: bytes
-# access-control-allow-origin: *
-# access-control-allow-headers: Origin, X-Requested-With, Content-Type, Accept, Range
-# Date: Tue, 13 Feb 2024 00:42:59 GMT
-# Connection: keep-alive
-# Keep-Alive: timeout=5
-
-#mitmproxy --map-local="|localhost:8080/|$(pwd)" --map-remote="|localhost:8080/console|https://gitea.departmentofinter.#net/console" -H="|Access-Control-Allow-Origin|*" -H "|Access-Control-Allow-Credentials|true" -H "|Access-Control-Allow#-Methods|GET, POST, OPTIONS" -H "|Access-Control-Allow-Headers|*" -H "|Access-Control-Max-Age|86400" -H="|Authorizatio#n|Basic cqc:d9c2b491e70e31a760ce70bc431036c91325f683"

dune

@@ -1,160 +1,40 @@
 (env
  (dev (flags (:standard -warn-error -A))))
 
-(executables
- (names cors_proxy)
- (libraries httpaf httpaf-lwt-unix base stdio fmt http-lwt-client)
- (modules cors_proxy))
-
 (library (name store)
  (libraries
-  digestif.ocaml
+  fmt
-  checkseum.ocaml
+  irmin.unix
-  irmin.mem
+  irmin-git.unix
-  git 
+  irmin-graphql.unix
-  irmin-git
+  lwt
-  cohttp-lwt-jsoo
+  lwt.unix
-  mimic
+ )
- js_of_ocaml)
+ (modules store)
- (modules store gitkey)
+)
- (preprocess
+
-  (pps js_of_ocaml-ppx)))
 
 (executables
  (names oplevel)
+ (modules oplevel secrets perfgraph ogui glfw_types)
  (libraries
-  store
-  js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel
-  lwt js_of_ocaml-lwt
-  ;; not used directly
-  graphics
-  tyxml
-  tyxml.functor
-  js_of_ocaml.deriving
-  react reactiveData
-  str dynlink
-  ocp-indent.lib
-  higlo
-  js_of_ocaml-lwt.graphics
-  js_of_ocaml-ppx
-  js_of_ocaml-compiler.runtime
-  js_of_ocaml-compiler.dynlink
-  uucp
-  httpaf
-  tyxml-ppx
- tyxml-syntax)
- (flags
-  (:standard -rectypes -warn-error -A))
- (link_flags
-  (:standard -linkall -keep-docs -keep-locs ))
- (modes js byte )
- (js_of_ocaml
-  (link_flags (:standard))
-  (build_runtime_flags
-   (:standard
-    +toplevel.js
-    +dynlink.js
-    --file
-    %{dep:examples.ml}
-    --file
-    %{dep:test_dynlink.cmo}
-    --file
-    %{dep:test_dynlink.js}
-))
-
-  (flags
-   (:standard
-     --toplevel --linkall --target-env=browser 
-     (:include effects_flags.sexp)
- )))
- (modules
-  oplevel toplevel ppx_support graphics_support colorize ocp_indent indent b64 )
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(rule
- (targets test_dynlink.cmo test_dynlink.cmi)
- (action
-  (run ocamlc -c %{dep:test_dynlink.ml})))
-
-(rule
- (targets test_dynlink.js)
- (action
-  (run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
-
-(rule
- (targets export.txt)
- (deps
-  (package js_of_ocaml-ppx)
-  (package js_of_ocaml)
-  (package js_of_ocaml-compiler)
-  (package js_of_ocaml-lwt)
-  (package js_of_ocaml-tyxml)
-  (package js_of_ocaml-toplevel))
- (action
-  (run
-   jsoo_listunits
-   -o
-   %{targets}
-   stdlib
-   graphics
-   str
-   dynlink
-   js_of_ocaml-compiler.runtime
-   js_of_ocaml-lwt.graphics
-   js_of_ocaml-ppx.as-lib
-   js_of_ocaml.deriving
    lwt
-   tyxml.functor
+   store
-   tyxml.functor:html_types.cmi
+   ;;memtrace
-   react
+   glfw-ocaml
-   reactiveData
+   tgls
-   js_of_ocaml
+   tgls.tgles2
-   js_of_ocaml-lwt
+   graphv_gles2_native
-   js_of_ocaml-tyxml
+   gg
-   js_of_ocaml-toplevel)))
+   irmin-git
-
+   compiler-libs.toplevel
-(executable
+   re
- (name effects_flags)
+   lwd
- (modules effects_flags))
+ )
-
+ (link_flags (-linkall))
-(rule
+ (ocamlopt_flags (:standard -O3 -unboxed-types))
- (target effects_flags.sexp)
+ (ocamlc_flags (:standard -verbose))
- (action
+ (modes byte_complete)
-  (with-stdout-to
+ (preprocess
-   %{target}
+  (pps ppx_irmin))
-   (run ./effects_flags.exe sexp))))
+)
-
-(rule
- (target effects_flags.txt)
- (action
-  (with-stdout-to
-   %{target}
-   (run ./effects_flags.exe txt))))
-
-(rule
- (targets oplevel.js)
- (action
-  (run
-   %{bin:js_of_ocaml}
-   compile
-   --pretty
-   %{read-strings:effects_flags.txt}
-   --Werror
-   --target-env
-   browser
-   --file
-   %{dep:examples.ml}
-   --file
-   %{dep:test_dynlink.cmo}
-   --file
-   %{dep:test_dynlink.js}
-    --toplevel
-    --linkall
-   %{dep:oplevel.bc}
-   -o
-   %{targets})))
-
-(alias
- (name default)
- (deps  oplevel.bc.js index.html))

dune-project

@@ -1,2 +1,2 @@
-(lang dune 3.4)
+(lang dune 3.15)
 (name oplevel)

effects_flags.ml

@@ -1,15 +0,0 @@
-let enable b n =
-  let f = if b then "--enable" else "--disable" in
-  [ f; n ]
-
-let () =
-  let major = String.split_on_char '.' Sys.ocaml_version |> List.hd |> int_of_string in
-  let has_effect = major >= 5 in
-  let l = enable has_effect "effects" in
-  match Sys.argv |> Array.to_list |> List.tl with
-  | "txt" :: [] -> List.iter print_endline l
-  | "sexp" :: [] ->
-      print_endline "(";
-      List.iter print_endline l;
-      print_endline ")"
-  | _ -> assert false

glfw_types.ml

@@ -0,0 +1,149 @@
+open GLFW
+module F = Fmt
+
+let pp_key : key F.t =
+ fun ppf k ->
+  F.pf ppf
+    GLFW.(
+      match k with
+      | Unknown -> "Unknown"
+      | Space -> "Space"
+      | Apostrophe -> "Apostrophe"
+      | Comma -> "Comma"
+      | Minus -> "Minus"
+      | Period -> "Period"
+      | Slash -> "Slash"
+      | Num0 -> "Num0"
+      | Num1 -> "Num1"
+      | Num2 -> "Num2"
+      | Num3 -> "Num3"
+      | Num4 -> "Num4"
+      | Num5 -> "Num5"
+      | Num6 -> "Num6"
+      | Num7 -> "Num7"
+      | Num8 -> "Num8"
+      | Num9 -> "Num9"
+      | Semicolon -> "Semicolon"
+      | Equal -> "Equal"
+      | A -> "A"
+      | B -> "B"
+      | C -> "C"
+      | D -> "D"
+      | E -> "E"
+      | F -> "F"
+      | G -> "G"
+      | H -> "H"
+      | I -> "I"
+      | J -> "J"
+      | K -> "K"
+      | L -> "L"
+      | M -> "M"
+      | N -> "N"
+      | O -> "O"
+      | P -> "P"
+      | Q -> "Q"
+      | R -> "R"
+      | S -> "S"
+      | T -> "T"
+      | U -> "U"
+      | V -> "V"
+      | W -> "W"
+      | X -> "X"
+      | Y -> "Y"
+      | Z -> "Z"
+      | LeftBracket -> "LeftBracket"
+      | Backslash -> "Backslash"
+      | RightBracket -> "RightBracket"
+      | GraveAccent -> "GraveAccent"
+      | World1 -> "World1"
+      | World2 -> "World2"
+      | Escape -> "Escape"
+      | Enter -> "Enter"
+      | Tab -> "Tab"
+      | Backspace -> "Backspace"
+      | Insert -> "Insert"
+      | Delete -> "Delete"
+      | Right -> "Right"
+      | Left -> "Left"
+      | Down -> "Down"
+      | Up -> "Up"
+      | PageUp -> "PageUp"
+      | PageDown -> "PageDown"
+      | Home -> "Home"
+      | End -> "End"
+      | CapsLock -> "CapsLock"
+      | ScrollLock -> "ScrollLock"
+      | NumLock -> "NumLock"
+      | PrintScreen -> "PrintScreen"
+      | Pause -> "Pause"
+      | F1 -> "F1"
+      | F2 -> "F2"
+      | F3 -> "F3"
+      | F4 -> "F4"
+      | F5 -> "F5"
+      | F6 -> "F6"
+      | F7 -> "F7"
+      | F8 -> "F8"
+      | F9 -> "F9"
+      | F10 -> "F10"
+      | F11 -> "F11"
+      | F12 -> "F12"
+      | F13 -> "F13"
+      | F14 -> "F14"
+      | F15 -> "F15"
+      | F16 -> "F16"
+      | F17 -> "F17"
+      | F18 -> "F18"
+      | F19 -> "F19"
+      | F20 -> "F20"
+      | F21 -> "F21"
+      | F22 -> "F22"
+      | F23 -> "F23"
+      | F24 -> "F24"
+      | F25 -> "F25"
+      | Kp0 -> "Kp0"
+      | Kp1 -> "Kp1"
+      | Kp2 -> "Kp2"
+      | Kp3 -> "Kp3"
+      | Kp4 -> "Kp4"
+      | Kp5 -> "Kp5"
+      | Kp6 -> "Kp6"
+      | Kp7 -> "Kp7"
+      | Kp8 -> "Kp8"
+      | Kp9 -> "Kp9"
+      | KpDecimal -> "KpDecimal"
+      | KpDivide -> "KpDivide"
+      | KpMultiply -> "KpMultiply"
+      | KpSubtract -> "KpSubtract"
+      | KpAdd -> "KpAdd"
+      | KpEnter -> "KpEnter"
+      | KpEqual -> "KpEqual"
+      | LeftShift -> "LeftShift"
+      | LeftControl -> "LeftControl"
+      | LeftAlt -> "LeftAlt"
+      | LeftSuper -> "LeftSuper"
+      | RightShift -> "RightShift"
+      | RightControl -> "RightControl"
+      | RightAlt -> "RightAlt"
+      | RightSuper -> "RightSuper"
+      | Menu -> "Menu")
+
+let pp_key_action : GLFW.key_action F.t =
+ fun ppf s ->
+  F.pf ppf
+    GLFW.(
+      match s with
+      | Release -> "Release"
+      | Press -> "Press"
+      | Repeat -> "Repeat")
+
+let pp_mods =
+  F.(
+    list (fun ppf s ->
+        pf ppf
+          GLFW.(
+            match s with
+            | Shift -> "Shift"
+            | Control -> "Control"
+            | Alt -> "Alt"
+            | Super -> "Super")))

graphics_support.ml

@@ -1 +0,0 @@
-let init elt = Graphics_js.open_canvas elt

indent.ml

@@ -1,43 +0,0 @@
-open Js_of_ocaml
-
-let textarea (textbox : Dom_html.textAreaElement Js.t) : unit =
-  let rec loop s acc (i, pos') =
-    try
-      let pos = String.index_from s pos' '\n' in
-      loop s ((i, (pos', pos)) :: acc) (succ i, succ pos)
-    with _ -> List.rev ((i, (pos', String.length s)) :: acc)
-  in
-  let rec find (l : (int * (int * int)) list) c =
-    match l with
-    | [] -> assert false
-    | (i, (lo, up)) :: _ when up >= c -> c, i, lo, up
-    | (_, (_lo, _up)) :: rem -> find rem c
-  in
-  let v = textbox##.value in
-  let pos =
-    let c1 = textbox##.selectionStart and c2 = textbox##.selectionEnd in
-    if Js.Opt.test (Js.Opt.return c1) && Js.Opt.test (Js.Opt.return c2)
-    then
-      let l = loop (Js.to_string v) [] (0, 0) in
-      Some (find l c1, find l c2)
-    else None
-  in
-  let f =
-    match pos with
-    | None -> fun _ -> true
-    | Some ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) ->
-        fun l -> l >= line1 + 1 && l <= line2 + 1
-  in
-  let v = Ocp_indent.indent (Js.to_string v) f in
-  textbox##.value := Js.string v;
-  match pos with
-  | Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, up2)) ->
-      let l = loop v [] (0, 0) in
-      let lo1'', up1'' = List.assoc line1 l in
-      let lo2'', up2'' = List.assoc line2 l in
-      let n1 = max (c1 + up1'' - up1) lo1'' in
-      let n2 = max (c2 + up2'' - up2) lo2'' in
-      let () = (Obj.magic textbox)##setSelectionRange n1 n2 in
-      textbox##focus;
-      ()
-  | None -> ()

indent.mli

@@ -1,3 +0,0 @@
-open Js_of_ocaml
-
-val textarea : Dom_html.textAreaElement Js.t -> unit

index.html

@@ -1,188 +0,0 @@
-<?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 .statusv {
-      background-color:transparent;
-      color: #ccc;
-      border: none;
-      line-height:18px;
-      font-size: 12px;
-      margin-bottom: 0px;
-      }
-
-      #toplevel-container #output {
-      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 = "";
-      var main = "oplevel.bc.js";
-      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("exported-unit.cmis.js");
-      load_script(main);
-
-    </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>OpLevel</h3>
-      <h4>A programming system based on a compiler from OCaml bytecode to Javascript.</h4>
-      <div id="toplevel-storeview" 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>

ocp_indent.ml

@@ -1,14 +0,0 @@
-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 ""

oplevel.ml

@@ -1,133 +1,252 @@
-open Js_of_ocaml
+open Lwt.Infix
-open Js_of_ocaml_tyxml
+module F = Fmt
-open Lwt
+open Tgles2
-open Store
+module Gv = Graphv_gles2_native
+open Ogui
 
-let by_id s = Dom_html.getElementById s
+module GLFWExtras = struct
+  open Ctypes
+  open Foreign
 
-let by_id_coerce s f =
+  let glfwSetErrorCallback :
-  Js.Opt.get
+      (int -> string -> unit) -> int -> string -> unit =
-    (f (Dom_html.getElementById s))
+    let errorfun = int @-> string @-> returning void in
-    (fun () -> raise Not_found)
+    foreign "glfwSetErrorCallback"
+      (funptr errorfun @-> returning (funptr errorfun))
+end
 
-let resize ~container ~textbox () =
+let errorcb error desc =
-  Lwt.pause () >>= fun () ->
+  Printf.printf "GLFW error %d: %s\n%!" error desc
-  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 appendchild ~container html =
+let load_fonts vg =
-  Dom.appendChild container (Tyxml_js.To_dom.of_a html)
+  let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
+  let _ =
+    Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
+  in
+  let _ =
+    Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf"
+  in
+  let _ =
+    Gv.Text.create vg ~name:"sans-bold"
+      ~file:"./assets/Roboto-Bold.ttf"
+  in
+  let _ =
+    Gv.Text.create vg ~name:"emoji"
+      ~file:"./assets/NotoEmoji-Regular.ttf"
+  in
+  Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji";
+  Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
+  Gv.Text.set_font_face vg ~name:"mono"
 
-let _ =
+let main =
-  Dom_html.window##.onload
+  GLFW.init ();
-  := Dom_html.handler (fun _ ->
+  at_exit GLFW.terminate;
-         Lwt.async (fun () ->
+  let _res = GLFWExtras.glfwSetErrorCallback errorcb in
-             let output = by_id "output" in
+  GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi;
-             let container = by_id "toplevel-container" in
+  GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2;
-             appendchild ~container
+  GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0;
-               Tyxml_js.Html.(
-                 a
-                   ~a:[ a_class [ "window" ] ]
-                   [
-                     div
-                       ~a:[ a_class [ "status" ] ]
-                       [ txt "starting..." ];
-                   ]);
-             let textbox : 'a Js.t =
-               by_id_coerce "userinput" Dom_html.CoerceTo.textarea
-             in
-             let rootrepo = Store.test_pull () in
-             rootrepo >>= fun (_upstream, t) ->
-             Store.S.tree t >>= fun rootstore ->
-             (try
-                Store.S.Tree.get rootstore [ ".config"; "init.ml" ]
-              with
-             | Not_found | Invalid_argument _ ->
-                 Lwt.return
-                   "print_newline \"rootstore://.config/init.ml not \
-                    found\";;"
-             | exc ->
-                 Firebug.console##log_3
-                   (Js.string ".config/init.ml load exception")
-                   (Js.string (Printexc.to_string exc))
-                   exc;
-                 Lwt.return ";;")
-             >>= fun init ->
-             let execute = ref (Toplevel.run ~init ~output ()) 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
-                 Dom_html.Keyboard_code.(
-                   fun e ->
-                     match of_key_code e##.keyCode with
-                     | Enter when not (meta e || shift e) ->
-                         Lwt.async (fun () ->
-                             !execute
-                               (Js.to_string textbox##.value##trim)
-                               ());
-                         Js._false
-                     | Enter ->
-                         Lwt.async (resize ~container ~textbox);
-                         Js._true
-                     | Tab ->
-                         Indent.textarea textbox;
-                         Js._false
-                     | KeyL when meta e ->
-                         output##.innerHTML := Js.string "";
-                         Js._true
-                     | KeyK when meta e ->
-                         Lwt.async
-                           Store.S.(
-                             fun () ->
-                               rootrepo >>= fun (upstream, t) ->
-                               Sync.pull_exn t upstream `Set
-                               >>= fun _ ->
-                               Firebug.console##log
-                                 (Js.string
-                                    "re-pulling rootstore for init.ml\n");
-                               tree t >>= fun rs ->
-                               (try
-                                  Store.S.Tree.get rs
-                                    [ ".config"; "init.ml" ]
-                                with
-                               | Not_found | Invalid_argument _ ->
-                                   Lwt.return
-                                     "print_newline \
-                                      \"rootstore://.config/init.ml \
-                                      not found\";;"
-                               | exc ->
-                                   Firebug.console##log_3
-                                     (Js.string
-                                        ".config/init.ml load \
-                                         exception")
-                                     (Js.string
-                                        (Printexc.to_string exc))
-                                     exc;
-                                   Lwt.return ";;")
-                               >>= fun init ->
-                               Lwt.return
-                                 (execute :=
-                                    Toplevel.run ~init ~output ()));
-                         Js._false
-                     (* | ArrowUp -> history_up e
-                        | ArrowDown -> history_down e *)
-                     | _ -> Js._true);
-             Lwt.return_unit);
 
-         Js._false)
+  let window =
+    GLFW.createWindow ~width:1000 ~height:600 ~title:"window" ()
+  in
+  (* Make the window's context current *)
+  GLFW.makeContextCurrent ~window:(Some window);
+  GLFW.swapInterval ~interval:0;
+
+  Gl.clear_color 0.1 0.2 0.2 1.;
+
+  (*Memtrace.trace_if_requested (); *)
+  let ctx =
+    Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
+  in
+
+  let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
+  let min_fps = ref Float.max_float in
+  let max_fps = ref Float.min_float in
+
+  (* Thread which is woken up when the main window is closed. *)
+  let _waiter, _wakener = Lwt.wait () in
+
+  F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
+  Toploop.initialize_toplevel_env ();
+
+  let rootrepo =
+    Store.init_default
+      (F.str "%s/console/rootstore.git" Secrets.giturl)
+  in
+
+  let ui =
+    Ogui.Ui.window ctx ~window
+      (Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.)))
+  in
+
+  load_fonts ui.gv;
+
+  let event_stream, event_push = Lwt_stream.create () in
+  Ogui.Ui.process_events ui event_stream;
+  GLFW.setKeyCallback ~window
+    ~f:
+      (Some
+         (fun _window key _int state mods ->
+           (* ignore key releases and capslock *)
+           match (state, key, mods) with
+           | Release, _, _ | _, CapsLock, _ -> ()
+           | _ -> event_push (Some (`Key (state, key, mods)))
+           (*Lwt.async (fun () ->
+               Ogui.Ui.keycallback ui state key mods >>= fun _ ->
+               Lwt.return_unit) *)))
+  |> ignore;
+
+  GLFW.setCharCallback ~window
+    ~f:
+      (Some
+         (fun _window ch ->
+           event_push (Some (`Char ch))
+           (* Lwt.async (fun () -> Ogui.Ui.chrcallback ui ch) *)))
+  |> ignore;
+
+  GLFW.setWindowSizeCallback ~window
+    ~f:
+      (Some
+         Gg.(
+           fun _window x y ->
+             Lwd.set ui.rect
+               (Box2.v V2.zero (V2.v (float x) (float y)))))
+  |> ignore;
+
+  F.pr "oplevel.ml: building initial page@.";
+  let initial_path = [ ".config"; "init.ml" ] in
+  TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init ->
+  TextBuffer.of_string ~repo:rootrepo
+    ~path:
+      (List.fold_right
+         (fun a (acc : string list) ->
+           match acc with
+           | [] -> [ F.str "%s.output" a ]
+           | a' -> a :: a')
+         [] initial_path)
+    (F.str "(* --- output:%s --- *)\n\n"
+       (String.concat "/" initial_path))
+  |> Lwt.return
+  >>= fun to_init ->
+  let out_ppf =
+    let insert s =
+      Lwt.async (fun () ->
+          TextBuffer.length to_init >>= fun len ->
+          (* TKTK if buffer is modified here during yield from >>= it could be weird *)
+          TextBuffer.insert to_init len s)
+    in
+    Format.formatter_of_out_functions
+      Format.
+        {
+          out_string = (fun s _ _ -> insert s);
+          out_flush = (fun () -> ());
+          out_indent = (fun n -> insert (String.make (n * 2) ' '));
+          out_newline = (fun () -> insert "\n");
+          out_spaces = (fun n -> insert (String.make n ' '));
+        }
+  in
+
+  ignore
+    (Toploop.use_input out_ppf
+       (String "#use \"topfind\";;\n#list;;#require \"lwt\";;"));
+  (* toplevel execution binding *)
+  Ui.(
+    update_bindings ui
+      Event.(
+        fun a ->
+          a
+          |> adds
+               [
+                 [
+                   Key (Press, X, [ Control ]);
+                   Key (Press, E, [ Control ]);
+                 ];
+               ]
+               [
+                 Custom
+                   ( "toplevel_execute",
+                     fun () ->
+                       TextBuffer.peek tb_init >>= fun str ->
+                       Toploop.use_input out_ppf (String str)
+                       |> F.epr "Toploop.use_input=%b@.";
+                       Lwt.return_unit );
+               ]));
+
+  Layout.(
+    system ui `Y
+      ~style:
+        Style.{ default with margin = Margin.symmetric 10.0 10.0 }
+      (Lwd.var
+         [
+           TextEdit.multiline ui tb_init;
+           TextEdit.multiline ui to_init;
+         ]))
+  >>= fun page ->
+  let page_root = Lwd.observe page in
+
+  let open GLFW in
+  let open Event in
+  Ui.update_bindings ui
+    Ui.(
+      adds
+        [
+          [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
+        ]
+        [ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]);
+
+  let bindings =
+    ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample
+  in
+  F.epr "Bindings:@.%a" Ui.pp_bindings bindings;
+
+  F.pr "oplevel.ml: entering drawing loop@.";
+  let period_min = 1.0 /. 30. in
+  let t = GLFW.getTime () |> ref in
+
+  let rec draw_loop () =
+    let now = GLFW.getTime () in
+    let dt = now -. !t in
+    t := now;
+
+    Perfgraph.update graph dt;
+
+    if now > 2. then (
+      let avg = 1. /. Perfgraph.average graph in
+      min_fps := Float.min avg !min_fps;
+      max_fps := Float.max avg !max_fps);
+
+    let win_w, win_h = GLFW.getWindowSize ~window in
+    Gl.viewport 0 0 win_w win_h;
+    Gl.clear
+      (Gl.color_buffer_bit lor Gl.depth_buffer_bit
+     lor Gl.stencil_buffer_bit);
+    Gl.enable Gl.blend;
+    Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
+    Gl.enable Gl.cull_face_enum;
+    Gl.disable Gl.depth_test;
+    let page = Lwd.quick_sample page_root in
+    let win_w, win_h = GLFW.getWindowSize ~window in
+    let width, height = (float win_w, float win_h) in
+    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
+    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
+    Perfgraph.render graph ctx (width -. 205.) 5.;
+    (*F.epr "Painter.layout=%a@." Gg.Box2.pp box; *)
+    Painter.layout box ui page >>= fun _ ->
+    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
+    Gv.end_frame ctx;
+    Gc.major_slice 0 |> ignore;
+    GLFW.swapBuffers ~window;
+    GLFW.pollEvents ();
+    Lwt_unix.sleep
+      Float.(max 0. (period_min -. GLFW.getTime () +. !t))
+    >>= fun () ->
+    if not GLFW.(windowShouldClose ~window) then draw_loop ()
+    else Lwt.return_unit
+  in
+  draw_loop () >>= fun () ->
+  Printf.printf "MIN %.2f\n" !min_fps;
+  Printf.printf "MAX %.2f\n%!" !max_fps;
+  Lwt.return_unit
+
+let () = Lwt_main.run main

perfgraph.ml

@@ -0,0 +1,87 @@
+module NVG = Graphv_gles2_native
+
+type style = FPS | Ms | Percent
+
+type t = {
+  style : style;
+  name : string;
+  values : float array;
+  mutable head : int;
+  mutable last : float;
+}
+
+let init style name =
+  { name; style; values = Array.make 100 0.; head = 0; last = 0. }
+
+let average t =
+  let avg = ref 0. in
+  for i = 0 to Array.length t.values - 1 do
+    avg := !avg +. t.values.(i)
+  done;
+  !avg /. float (Array.length t.values)
+
+let update t dt =
+  t.head <- (t.head + 1) mod Array.length t.values;
+  t.values.(t.head) <- dt
+(*
+    t.last <- t.last +. dt;
+    if t.last > 1. then (
+        t.last <- 0.;
+        Printf.printf "FPS %.2f\n%!" (1. /. average t);
+    )
+    *)
+
+let render t (vg : NVG.t) x y =
+  let avg = average t in
+  let w = 200. in
+  let h = 35. in
+
+  let open NVG in
+  let open FloatOps in
+  Path.begin_ vg;
+  Path.rect vg ~x ~y ~w ~h;
+  set_fill_color vg ~color:(Color.rgba ~r:0 ~g:0 ~b:0 ~a:128);
+  fill vg;
+
+  Path.begin_ vg;
+  Path.move_to vg ~x ~y:(y + h);
+  let len = Array.length t.values in
+  (match t.style with
+  | FPS ->
+      for i = 0 to len -. 1 do
+        let v = 1. / (0.00001 + t.values.((t.head +. i) mod len)) in
+        let v = if v > 80. then 80. else v in
+        let vx = x + (float i / (float len - 1.) * w) in
+        let vy = y + h - (v / 80. * h) in
+        Path.line_to vg ~x:vx ~y:vy
+      done
+  | Percent -> ()
+  | Ms -> ());
+  Path.line_to vg ~x:(x + w) ~y:(y + h);
+  set_fill_color vg ~color:(Color.rgba ~r:255 ~g:192 ~b:0 ~a:128);
+  fill vg;
+
+  Text.set_font_face vg ~name:"mono";
+
+  Text.set_size vg ~size:12.;
+  Text.set_align vg ~align:Align.(left lor top);
+  set_fill_color vg ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:192);
+  Text.text vg ~x:(x + 3.) ~y:(y + 3.) t.name;
+
+  match t.style with
+  | FPS ->
+      Text.set_size vg ~size:15.;
+      Text.set_align vg ~align:Align.(right lor top);
+      set_fill_color vg
+        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:255);
+      let s = Printf.sprintf "%.2f FPS" (1. / avg) in
+      Text.text vg ~x:(x + w - 3.) ~y:(y + 3.) s;
+
+      Text.set_size vg ~size:13.;
+      Text.set_align vg ~align:Align.(right lor baseline);
+      set_fill_color vg
+        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:160);
+      let s = Printf.sprintf "%.2f ms" (avg * 1000.) in
+      Text.text vg ~x:(x + w - 3.) ~y:(y + h - 3.) s
+  | Percent -> ()
+  | Ms -> ()

ppx_support.ml

@@ -1 +0,0 @@
-let init () = Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)

store.ml

@@ -1,345 +1,6 @@
-open Js_of_ocaml
 open Lwt.Infix
 module F = Fmt
-module Cohttp_backend = Cohttp_lwt_jsoo
+module S = Irmin_git_unix.FS.KV (Irmin.Contents.String)
-
-module Git_af = struct
-  open Lwt.Infix
-
-  type error = |
-
-  let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value =
-    Mimic.make ~name:"git-af-scheme"
-
-  let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port"
-
-  let git_af_hostname : string Mimic.value =
-    Mimic.make ~name:"git-af-hostname"
-
-  let pp_error : error Fmt.t = fun _ppf -> function _ -> .
-
-  let with_redirects ?(max = 10) ~f uri =
-    if max < 10 then invalid_arg "with_redirects";
-    let tbl = Hashtbl.create 0x10 in
-    let rec go max uri =
-      f uri >>= fun (resp, body) ->
-      let status_code =
-        Cohttp.(Response.status resp |> Code.code_of_status)
-      in
-      if Cohttp.Code.is_redirection status_code then
-        match
-          Cohttp.(Response.headers resp |> Header.get_location)
-        with
-        | Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
-            Lwt.return (resp, body)
-        | Some uri' ->
-            Hashtbl.add tbl uri' ();
-            Cohttp_lwt.Body.drain_body body >>= fun () ->
-            go (pred max) uri'
-        | None -> Lwt.return (resp, body)
-      else Lwt.return (resp, body)
-    in
-    go max uri
-
-  let get ~ctx:_ ?(headers = []) uri =
-    Firebug.console##log (Js.string "Git_Cohttp_console.get()\n");
-    let headers = Cohttp.Header.of_list headers in
-    let f uri = Cohttp_backend.Client.get ~headers uri in
-    with_redirects ~f uri >>= fun (_resp, body) ->
-    Cohttp_lwt.Body.to_string body >>= fun body ->
-    Lwt.return_ok ((), body)
-
-  let post ~ctx:_ ?(headers = []) uri body =
-    let headers = Cohttp.Header.of_list headers in
-    let body = Cohttp_lwt.Body.of_string body in
-    let f uri =
-      Cohttp_backend.Client.post ~headers ~chunked:false ~body uri
-    in
-    with_redirects ~f uri >>= fun (_resp, body) ->
-    Cohttp_lwt.Body.to_string body >>= fun body ->
-    Lwt.return_ok ((), body)
-end
-
-module Git_console_http = struct
-  open Lwt.Infix
-
-  let context ctx =
-    (* HTTP *)
-    let edn = Mimic.make ~name:"af-http-endpoint" in
-    let k1 git_af_scheme git_af_hostname git_af_port =
-      match git_af_scheme with
-      | `HTTP -> Lwt.return_some (git_af_hostname, git_af_port)
-      | _ -> Lwt.return_none
-    in
-    let ctx =
-      Mimic.fold edn
-        Mimic.Fun.
-          [
-            req Git_af.git_af_scheme;
-            req Git_af.git_af_hostname;
-            dft Git_af.git_af_port 80;
-          ]
-        ~k:k1 ctx
-    in
-
-    (* HTTPS *)
-    let edn = Mimic.make ~name:"af-https-endpoint" in
-    let k1 git_af_scheme git_af_hostname git_af_port =
-      match git_af_scheme with
-      | `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port)
-      | _ -> Lwt.return_none
-    in
-
-    let ctx =
-      Mimic.fold edn
-        Mimic.Fun.
-          [
-            req Git_af.git_af_scheme;
-            req Git_af.git_af_hostname;
-            dft Git_af.git_af_port 443;
-          ]
-        ~k:k1 ctx
-    in
-
-    ctx
-
-  module HTTP = struct
-    type state =
-      | Handshake
-      | Get of {
-          advertised_refs : string;
-          uri : Uri.t;
-          headers : (string * string) list;
-          ctx : Mimic.ctx;
-        }
-      | Post of {
-          mutable output : string;
-          uri : Uri.t;
-          headers : (string * string) list;
-          ctx : Mimic.ctx;
-        }
-      | Error
-
-    type flow = { endpoint : Uri.t; mutable state : state }
-    type error = [ `Msg of string ]
-    type write_error = [ `Closed | `Msg of string ]
-
-    let pp_error ppf (`Msg err) = Fmt.string ppf err
-
-    let pp_write_error ppf = function
-      | `Closed -> Fmt.string ppf "Connection closed by peer"
-      | `Msg err -> Fmt.string ppf err
-
-    let write t cs =
-      match t.state with
-      | Handshake | Get _ ->
-          Lwt.return_error (`Msg "Handshake has not been done")
-      | Error -> Lwt.return_error (`Msg "Handshake got an error")
-      | Post ({ output; _ } as v) ->
-          let output = output ^ Cstruct.to_string cs in
-          v.output <- output;
-          Lwt.return_ok ()
-
-    let writev t css =
-      let rec go = function
-        | [] -> Lwt.return_ok ()
-        | x :: r -> (
-            write t x >>= function
-            | Ok () -> go r
-            | Error _ as err -> Lwt.return err)
-      in
-      go css
-
-    let read t =
-      match t.state with
-      | Handshake ->
-          Lwt.return_error (`Msg "Handshake has not been done")
-      | Error -> Lwt.return_error (`Msg "Handshake got an error")
-      | Get { advertised_refs; uri; headers; ctx } ->
-          t.state <- Post { output = ""; uri; headers; ctx };
-          Lwt.return_ok (`Data (Cstruct.of_string advertised_refs))
-      | Post { output; uri; headers; ctx } -> (
-          Git_af.post ~ctx ~headers uri output >>= function
-          | Ok (_resp, contents) ->
-              Lwt.return_ok (`Data (Cstruct.of_string contents))
-          | Error err ->
-              Lwt.return_error
-                (`Msg (Fmt.str "%a" Git_af.pp_error err)))
-
-    let close _ = Lwt.return_unit
-
-    type endpoint = Uri.t
-
-    let connect endpoint =
-      Firebug.console##log
-        (Js.string "Git_Console_http.HTTP.connect()\n");
-      Lwt.return_ok { endpoint; state = Handshake }
-  end
-
-  let http_endpoint, http_protocol =
-    Mimic.register ~name:"http" (module HTTP)
-
-  let connect (ctx : Mimic.ctx) =
-    Firebug.console##log (Js.string "Git_Console_http.connect()\n");
-    let module T = (val Mimic.repr http_protocol) in
-    let edn = Mimic.make ~name:"http-endpoint" in
-    let k0 uri = Lwt.return_some uri in
-    let k1 git_transmission git_scheme =
-      match (git_transmission, git_scheme) with
-      | `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri
-      | _ -> Lwt.return_none
-    in
-    let k2 git_scheme git_uri git_http_headers =
-      match git_scheme with
-      | `Git | `SSH | `Scheme _ -> Lwt.return_none
-      | `HTTP | `HTTPS ->
-          let headers =
-            ("content-type", "application/x-git-upload-pack-request")
-            :: git_http_headers
-          in
-          let handshake ~uri0 ~uri1 = function
-            | T.T flow -> (
-                Firebug.console##log
-                  (Js.string
-                     (F.str
-                        "Git_Console_http.connect.k2.handshake \
-                         uri0='%s' uri1='%s'\n"
-                        (Uri.to_string uri0) (Uri.to_string uri1)));
-                let ctx = context Mimic.empty in
-                Git_af.get ~ctx ~headers uri0 >>= function
-                | Ok (_resp, advertised_refs) ->
-                    flow.state <-
-                      HTTP.Get
-                        { advertised_refs; uri = uri1; headers; ctx };
-                    Lwt.return_unit
-                | Error _ ->
-                    flow.state <- Error;
-                    Lwt.return_unit)
-            | _ -> Lwt.return_unit
-          in
-          let git_transmission = `HTTP (git_uri, handshake) in
-          Lwt.return_some git_transmission
-    in
-    let ctx =
-      Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx
-    in
-    let ctx =
-      Mimic.fold edn
-        Mimic.Fun.
-          [ req Smart_git.git_transmission; req Smart_git.git_scheme ]
-        ~k:k1 ctx
-    in
-    let ctx =
-      Mimic.fold Smart_git.git_transmission
-        Mimic.Fun.
-          [
-            req Smart_git.git_scheme;
-            req Smart_git.git_uri;
-            dft Smart_git.git_http_headers List.[];
-          ]
-        ~k:k2 ctx
-    in
-    Lwt.return ctx
-end
-
-module Config = struct
-  open Irmin.Backend.Conf
-
-  let spec = Spec.v "console_js_git"
-
-  module Key = struct
-    let reference : Git.Reference.t Irmin.Type.t =
-      let of_string str =
-        Git.Reference.of_string str |> Result.get_ok
-      in
-      let to_string r = Git.Reference.to_string r in
-      Irmin.Type.(map string) of_string to_string
-
-    let head =
-      key ~spec ~doc:"The main branch of the Git repository." "head"
-        Irmin.Type.(option reference)
-        None
-
-    let bare =
-      key ~spec ~doc:"Do not expand the filesystem on the disk."
-        "bare" Irmin.Type.bool false
-
-    let level =
-      key ~spec ~doc:"The Zlib compression level." "level"
-        Irmin.Type.(option int)
-        None
-
-    let buffers =
-      key ~spec ~doc:"The number of 4K pre-allocated buffers."
-        "buffers"
-        Irmin.Type.(option int)
-        None
-  end
-
-  let init ?head ?level ?buffers _root =
-    let module C = Irmin.Backend.Conf in
-    let config = C.empty spec in
-
-    let config = C.add config Key.head head in
-    let config = C.add config Key.level level in
-    let config = C.add config Key.buffers buffers in
-    C.verify config
-end
-
-module S = struct
-  module Schema =
-    Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String)
-      (Irmin_git.Branch.Make (Irmin.Branch.String))
-
-  module Sync' = struct
-    module GitMemSync = Git.Mem.Sync (Git.Mem.Store)
-    include GitMemSync
-    (* This is where the fetch and push are broken *)
-  end
-
-  module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync')
-  module SMade = SMaker.Make (Schema)
-  include SMade
-
-  type endpoint = Mimic.ctx * Smart_git.Endpoint.t
-
-  let remote ?(ctx = Mimic.empty) ?headers uri =
-    E
-      (Firebug.console##log
-         (Js.string (F.str "Nav.S.remote(uri=%s)\n" uri));
-       let ( ! ) f a b = f b a in
-       match Smart_git.Endpoint.of_string uri with
-       | Ok edn ->
-           let edn =
-             Option.fold ~none:edn
-               ~some:(!Smart_git.Endpoint.with_headers_if_http edn)
-               headers
-           in
-           Firebug.console##log
-             (Js.string "Nav.S.remote() = (ctx, edn) \n");
-           (ctx, edn)
-       | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err)
-
-  module Backend = struct
-    include Backend
-    module R = Remote
-
-    module Remote = struct
-      include R
-
-      type endpoint = Mimic.ctx * Smart_git.Endpoint.t
-
-      let ctx e = fst e
-      let edn e = snd e
-
-      let fetch t ?depth endpoint branch =
-        Firebug.console##log
-          (Js.string "S.Backend.Remote.wrapped_fetch()\n");
-        R.fetch t ?depth endpoint branch
-    end
-  end
-end
-
 module Sync = Irmin.Sync.Make (S)
 
 type t = S.tree
@@ -348,6 +9,7 @@ type step = S.step
 type path = step list
 
 let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
+let info = Irmin_git_unix.info
 
 let test_populate () : t Lwt.t =
   let add p s t = S.Tree.add t p s in
@@ -355,22 +17,13 @@ let test_populate () : t Lwt.t =
   >>= add [ "hello"; "daddy" ] "ily"
   >>= add [ "beep"; "beep" ] "motherfucker"
 
-let test_pull () : (Irmin.remote * Sync.db) Lwt.t =
+let init_default upstream_url : Sync.db Lwt.t =
-  (* test_populate ()*)
+  S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
-  Firebug.console##log (Js.string "Nav.test_pull()\n");
+  S.of_branch repo "ogui" >>= fun t ->
-  S.Repo.v (Config.init "") >>= fun repo ->
+  S.remote upstream_url >>= fun upstream ->
-  Firebug.console##log (Js.string "Nav.test_pull(2)\n");
+  (* (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit
-  S.of_branch repo "current" >>= fun t ->
+      with Invalid_argument a ->
-  Firebug.console##log (Js.string "Nav.test_pull(3)\n");
+        F.epr "Sync.pull_exn raised Invalid_argument(%s)" a;
-  Git_console_http.connect Mimic.empty >>= fun ctx ->
+        Lwt.return_unit)
-  Firebug.console##log (Js.string "Nav.test_pull(4)\n");
+     >>= fun () -> *)
-  let upstream =
+  Lwt.return t
-    S.remote ~ctx
-      ~headers:[ ("Authorization", F.str "Basic %s" Gitkey.key) ]
-      "http://localhost:8080/console/rootstore.git"
-  in
-  Firebug.console##log (Js.string "Nav.test_pull(5)\n");
-  Sync.pull_exn t upstream `Set >>= fun _ ->
-  Firebug.console##log (Js.string "Nav.test_pull(6)\n");
-  Lwt.return (upstream, t)
-(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)

test_dynlink.ml

@@ -1,3 +0,0 @@
-let _ = print_endline "Dynlink OK"
-
-let f () = print_endline "Test_dynlink.f Ok"