console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Irmin_git.KV (Irmin_git.Mem) (Git.Mem.Sync (Irmin_git.Mem)) results in a.caml_thread_initialize is not a function

Browse Source
This commit is contained in:
cqc
2022-10-06 12:18:32 -05:00
parent fec4249d9f
commit 281351371d
4 changed files with 469 additions and 365 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.ocamlformat
View File

@ -1 +0,0 @@
profile = compact

46
boot_js.ml
View File

@ -1,4 +1,5 @@
open Js_of_ocaml
open Lwt.Infix
module NVG = Graphv_webgl
(* This scales the canvas to match the DPI of the window,
@ -11,15 +12,18 @@ let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
canvas##.width := width *. dpr |> int_of_float;
canvas##.height := height *. dpr |> int_of_float;
let width =
Printf.sprintf "%dpx" (int_of_float width) |> Js.string in
Printf.sprintf "%dpx" (int_of_float width) |> Js.string
in
let height =
Printf.sprintf "%dpx" (int_of_float height) |> Js.string in
Printf.sprintf "%dpx" (int_of_float height) |> Js.string
in
canvas##.style##.width := width;
canvas##.style##.height := height
let _ =
let canvas =
Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas") in
Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
in
scale_canvas canvas;
let webgl_ctx =
(* Graphv requires a stencil buffer to work properly *)
@ -31,15 +35,19 @@ let _ =
| None ->
print_endline "Sorry your browser does not support WebGL";
raise Exit
| Some ctx -> ctx in
| Some ctx -> ctx
in
let open NVG in
let vg =
create
~flags:CreateFlags.(antialias lor stencil_strokes)
webgl_ctx in
webgl_ctx
in
(* File in this case is actually the CSS font name *)
Text.create vg ~name:"sans" ~file:"sans" |> ignore;
webgl_ctx##clearColor 0.3 0.3 0.32 1.;
(*
let render ev =
webgl_ctx##clear
(webgl_ctx##._COLOR_BUFFER_BIT_
@ -62,11 +70,31 @@ let _ =
Text.set_align vg ~align:Align.(center lor middle) ;
set_fill_color vg ~color:Color.white ;
Text.text vg ~x:0. ~y:0. "Hello World!" ; *)
NVG.end_frame vg in
NVG.end_frame vg
in
Dom_html.window##requestAnimationFrame
(Js.wrap_callback (fun _ -> render Human.Event.empty))
|> ignore ;
Dom_html.document##.onkeydown
|> ignore;*)
let open Js_of_ocaml_lwt.Lwt_js_events in
async (fun () ->
buffered_loop (make_event Dom_html.Event.keydown)
Dom_html.document (fun ev _ ->
webgl_ctx##clear
(webgl_ctx##._COLOR_BUFFER_BIT_
lor webgl_ctx##._DEPTH_BUFFER_BIT_
lor webgl_ctx##._STENCIL_BUFFER_BIT_);
let device_ratio = Dom_html.window##.devicePixelRatio in
begin_frame vg ~width:canvas##.width ~height:canvas##.height
~device_ratio;
Transform.scale vg ~x:device_ratio ~y:device_ratio;
Human.Panel.Ui.(
render_lwt vg Gg.P2.o
(Human.Event_js.evt_of_jskey `Press ev))
>>= fun () ->
NVG.end_frame vg;
Lwt.return_unit))
(* Dom_html.document##.onkeydown
:= Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) ->
render (Human.Event_js.evt_of_jskey `Press evt) ;
Js._false )
Js._false ) *)

8
dune
View File

@ -11,10 +11,10 @@
(libraries
fmt
graphv_webgl
js_of_ocaml
lwt
irmin
irmin-git
js_of_ocaml-lwt
digestif.ocaml
irmin.mem
irmin-git.unix
zed
gg

295
human.ml
View File

@ -35,19 +35,27 @@ module NVG = Graphv_webgl
module Nav = struct
open Lwt.Infix
module S = Irmin_mem.KV.Make(Irmin.Contents.String)
module Maker =
Irmin_git.KV (Irmin_git.Mem) (Git.Mem.Sync (Irmin_git.Mem))
module S = Maker.Make (Irmin.Contents.String)
module Sync = Irmin.Sync.Make (S)
type t = S.tree
let init () : t Lwt.t =
S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
let test_populate () : t Lwt.t =
let add p s t = S.Tree.add t p s in
add ["hello"] "world" (S.Tree.empty ()) >>=
add ["hello";"daddy"] "ily" >>=
add ["beep";"beep"] "motherfucker"
add [ "hello" ] "world" (S.Tree.empty ())
>>= add [ "hello"; "daddy" ] "ily"
>>= add [ "beep"; "beep" ] "motherfucker"
let test_pull () : t Lwt.t = test_populate ()
(* S.Repo.v (Irmin_git.config "") >>= fun repo ->
S.of_branch repo "master" >>= fun t ->
let upstream = Irmin.Sync.remote_store (module S) t in
Sync.pull_exn t upstream `Set >>= fun _ -> S.tree t *)
end
module Key = struct
@ -66,11 +74,18 @@ module Key = struct
| `Unknown of string ]
(* Type of key code. *)
type code = [`Uchar of Uchar.t (* A unicode character. *) | special]
type code =
[ `Uchar of Uchar.t (* A unicode character. *) | special ]
type keyaction = [ `Press | `Release | `Repeat ]
type keystate =
{ctrl: bool; meta: bool; shift: bool; super: bool; code: code}
type keystate = {
ctrl : bool;
meta : bool;
shift : bool;
super : bool;
code : code;
}
module KeyS = struct
type t = keystate
@ -86,11 +101,12 @@ module Key = struct
type 'a resolver = 'a list S.resolver
type 'a result = 'a list S.result
type 'a state =
{ mutable bindings: 'a t
; mutable state: 'a result
; mutable last_keyseq: keystate list
; mutable last_actions: 'a list }
type 'a state = {
mutable bindings : 'a t;
mutable state : 'a result;
mutable last_keyseq : keystate list;
mutable last_actions : 'a list;
}
type mods = Ctrl | Meta | Super | Shift
type key = C of char | U of code
@ -110,16 +126,19 @@ module Key = struct
List.map
(fun (m, k) ->
keystate_of_mods
{ meta= false
; ctrl= false
; super= false
; shift= false
; code=
{
meta = false;
ctrl = false;
super = false;
shift = false;
code =
(match k with
| C c -> `Uchar (Uchar.of_char c)
| U c -> c ) }
| U c -> c);
}
m)
events in
events
in
S.add events action bindings
let default_resolver b = S.resolver [ S.pack (fun x -> x) b ]
@ -128,7 +147,12 @@ module Key = struct
match result with S.Continue r -> r | _ -> default
let init bindings =
{bindings; state= S.Rejected; last_keyseq= []; last_actions= []}
{
bindings;
state = S.Rejected;
last_keyseq = [];
last_actions = [];
}
let resolve = S.resolve
let empty = S.empty
@ -300,7 +324,8 @@ module Event_js = struct
| `Await -> decode dec d
| `End -> d
| `Uchar u ->
if Option.is_none d then decode dec (Some u) else None in
if Option.is_none d then decode dec (Some u) else None
in
decode
(Uutf.decoder
~nln:(`Readline (Uchar.of_int 0x000A))
@ -332,13 +357,15 @@ module Event_js = struct
match Js.Optdef.to_option evt##.key with
| Some s ->
`Key
( p
, Key.
{ meta= Js.to_bool evt##.altKey
; shift= Js.to_bool evt##.shiftKey
; ctrl= Js.to_bool evt##.ctrlKey
; super= Js.to_bool evt##.metaKey
; code= of_jskey (Js.to_string s) } )
( p,
Key.
{
meta = Js.to_bool evt##.altKey;
shift = Js.to_bool evt##.shiftKey;
ctrl = Js.to_bool evt##.ctrlKey;
super = Js.to_bool evt##.metaKey;
code = of_jskey (Js.to_string s);
} )
| None -> `Unknown "keypress .key is None?"
end
@ -347,10 +374,11 @@ module Panel = struct
open NVG
(* current window state to be passed to window renderer *)
type state =
{ box: box2
type state = {
box : box2;
(* This is cannonically box within which the next element should draw *)
; renderer: NVG.t }
renderer : NVG.t;
}
(* the box2 here is cannonically the place the returner drew
(the Wall.image extents) *)
@ -365,7 +393,11 @@ module Panel = struct
let draw_pane vg pane width height =
let _, _ =
pane {box= Box2.v (P2.v 0. 0.) (P2.v width height); renderer= vg}
pane
{
box = Box2.v (P2.v 0. 0.) (P2.v width height);
renderer = vg;
}
in
Ok ()
@ -397,27 +429,32 @@ module Panel = struct
module Style = struct
module Font = struct
type t =
{ size: float option
; font: [`Sans | `Serif | `Mono | `None]
; weight: [`Bold | `Regular | `Light | `None]
; italic: [`Italic | `None]
; underline: [`Underline | `None] }
type t = {
size : float option;
font : [ `Sans | `Serif | `Mono | `None ];
weight : [ `Bold | `Regular | `Light | `None ];
italic : [ `Italic | `None ];
underline : [ `Underline | `None ];
}
let empty =
{ size= None
; font= `None
; weight= `None
; italic= `None
; underline= `None }
{
size = None;
font = `None;
weight = `None;
italic = `None;
underline = `None;
}
let default =
ref
{ size= Some 20.
; font= `Sans
; weight= `Regular
; italic= `None
; underline= `None }
{
size = Some 20.;
font = `Sans;
weight = `Regular;
italic = `None;
underline = `None;
}
let size { size; _ } =
match (size, !default.size) with
@ -425,35 +462,37 @@ module Panel = struct
| None, Some s | Some s, _ -> s
let merge a b =
{ size=
{
size =
(match (a.size, b.size) with
| None, None -> None
| Some s, None | None, Some s -> Some s
| Some s1, Some s2 -> Some (Float.max_num s1 s2) )
; font=
| Some s1, Some s2 -> Some (Float.max_num s1 s2));
font =
(match (a.font, b.font) with
| `Sans, _ | _, `Sans -> `Sans
| `Serif, (`Serif | `Mono | `None)
| (`Mono | `None), `Serif ->
`Serif
| `Mono, (`Mono | `None) | `None, `Mono -> `Mono
| `None, `None -> `None )
; weight=
| `None, `None -> `None);
weight =
(match (a.weight, b.weight) with
| `Bold, _ | _, `Bold -> `Bold
| `Regular, (`Regular | `Light | `None)
| (`Light | `None), `Regular ->
`Regular
| `Light, (`Light | `None) | `None, `Light -> `Light
| `None, `None -> `None )
; italic=
| `None, `None -> `None);
italic =
(match (a.italic, b.italic) with
| `Italic, _ | _, `Italic -> `Italic
| _ -> `None )
; underline=
| _ -> `None);
underline =
(match (a.underline, b.underline) with
| `Underline, _ | _, `Underline -> `Underline
| _ -> `None ) }
| _ -> `None);
}
let set vg t =
(match t.size with
@ -470,7 +509,11 @@ module Panel = struct
let gray a = Color.rgbf ~r:a ~g:a ~b:a
let empty =
{fg= Color.transparent; bg= Color.transparent; font= Font.empty}
{
fg = Color.transparent;
bg = Color.transparent;
font = Font.empty;
}
let light = { empty with fg = gray 0.2 }
let dark = { empty with fg = gray 0.8 }
@ -480,17 +523,21 @@ module Panel = struct
if a1 == empty then a2
else if a2 == empty then a1
else
{ a1 with
fg= Color.lerp a1.fg a2.fg ~a:0.5
; bg= Color.lerp a1.bg a2.bg ~a:0.5 }
{
a1 with
fg = Color.lerp a1.fg a2.fg ~a:0.5;
bg = Color.lerp a1.bg a2.bg ~a:0.5;
}
let fg fg = { empty with fg }
let bg bg = { empty with bg }
let merge a b =
{ fg= Color.lerp a.fg b.fg ~a:0.5
; bg= Color.lerp a.bg b.bg ~a:0.5
; font= Font.merge a.font b.font }
{
fg = Color.lerp a.fg b.fg ~a:0.5;
bg = Color.lerp a.bg b.bg ~a:0.5;
font = Font.merge a.font b.font;
}
let set vg s =
F.epr "Style.set @.";
@ -500,13 +547,20 @@ module Panel = struct
end
module Pad = struct
type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1}
type t = {
t : Gg.size1;
b : Gg.size1;
l : Gg.size1;
r : Gg.size1;
}
let empty =
{ t= Gg.Size1.zero
; b= Gg.Size1.zero
; l= Gg.Size1.zero
; r= Gg.Size1.zero }
{
t = Gg.Size1.zero;
b = Gg.Size1.zero;
l = Gg.Size1.zero;
r = Gg.Size1.zero;
}
let all v = { t = v; b = v; l = v; r = v }
end
@ -605,8 +659,8 @@ module Panel = struct
let rec node_up_ (d : [ `Left | `Right ]) n' =
match (d, n'.parent) with
| _, `None -> None
| ( _
, ( `Left ({t= `Attr _; _} as p)
| ( _,
( `Left ({ t = `Attr _; _ } as p)
| `Right ({ t = `Attr _; _ } as p) ) ) ->
node_up_ d p
| `Right, `Right ({ t = `Join _; _ } as p)
@ -693,7 +747,8 @@ module Panel = struct
| Some { t = `Atom _; _ } -> ()
| Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n'
| Some { t = `Join (_, a, b); _ } ->
traverse_nodes ~f a ; traverse_nodes ~f b
traverse_nodes ~f a;
traverse_nodes ~f b
| None -> ()
let insert_join_l (d : dir) (n : node) (n' : node) : node =
@ -769,8 +824,7 @@ module Panel = struct
| `Page -> "`Page"
| `Text ->
"`Text"
(* text is like a file (unicode calls it End Of Text) *)
)
(* text is like a file (unicode calls it End Of Text) *))
ppf ()
let pp_atom ppf v =
@ -782,7 +836,9 @@ module Panel = struct
| `Hint h ->
any "`Hint "
++ any
(match h with `Line -> "`Line" | `Other -> "`Other")
(match h with
| `Line -> "`Line"
| `Other -> "`Other")
| `Empty -> any "`Empty")
ppf ()
@ -831,15 +887,18 @@ module Panel = struct
pf ppf "@[<hov>%a@]"
(braces
(record
[ field "n" (fun v -> v.n) int
; field "t" (fun v -> v.t) (_pp_t child)
; field "parent" (fun v -> v.parent) _pp_parent ] ) )
[
field "n" (fun v -> v.n) int;
field "t" (fun v -> v.t) (_pp_t child);
field "parent" (fun v -> v.parent) _pp_parent;
]))
v
and pp_node_n_record =
F.(
braces
(record ~sep:semi [field "n" Fun.id pp_node_n; any "..."]))
(record ~sep:semi
[ field "n" Fun.id pp_node_n; any "..." ]))
and pp_node ppf = _pp_node pp_node_n ppf
and pp_dump_node ppf = _pp_node pp_dump_node ppf
@ -859,8 +918,11 @@ module Panel = struct
| `Attr (a, n) ->
[ const pp_attr a; const pp_node_structure n ]
| `Join (d, l, r) ->
[ const pp_dir d; const pp_node_structure l
; const pp_node_structure r ] ) ))
[
const pp_dir d;
const pp_node_structure l;
const pp_node_structure r;
])))
ppf ()
end
@ -908,8 +970,7 @@ module Panel = struct
(Uutf.decoder
~nln:(`Readline (Uchar.of_int 0x000A))
(`String str))
empty_append
(empty_append, `Await)
empty_append (empty_append, `Await)
let text = of_string
let nl = atom (`Boundary `Line)
@ -939,7 +1000,8 @@ module Panel = struct
let rec encode c =
match Uutf.encode enc c with
| `Ok -> ()
| `Partial -> encode `Await in
| `Partial -> encode `Await
in
encode (`Uchar uc);
encode `End;
let text = Bytes.to_string (Buffer.to_bytes b) in
@ -963,7 +1025,8 @@ module Panel = struct
Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h;
let img_paint =
Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h
~angle:0.0 ~image ~alpha:0. in
~angle:0.0 ~image ~alpha:0.
in
set_fill_paint vg ~paint:img_paint;
fill vg;
P2.v (P2.x b +. w) (P2.y b +. h)
@ -994,7 +1057,8 @@ module Panel = struct
| `X -> P2.v (P2.x av) (P2.y t)
| `Y -> P2.v (P2.x t) (P2.y av)
| `Z -> t)
b in
b
in
match d with
| `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv))
| `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv)
@ -1008,7 +1072,8 @@ module Panel = struct
match n.t with
| `Atom a -> atom t b a
| `Attr a -> attr t b a
| `Join a -> join t b a in
| `Join a -> join t b a
in
(*ignore
(Display.path_box t.vg
(Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
@ -1092,7 +1157,9 @@ module Panel = struct
(search_backward
(function
| { t = `Atom (`Boundary `Line); _ } -> Some ()
| {t= `Atom (`Uchar _); _} -> incr i ; None
| { t = `Atom (`Uchar _); _ } ->
incr i;
None
| _ -> None)
c.sel);
match search_forward (is_boundary `Line) c.sel with
@ -1111,7 +1178,9 @@ module Panel = struct
search_backward
(function
| { t = `Atom (`Boundary `Line); _ } as n' -> Some n'
| {t= `Atom (`Uchar _); _} -> incr i ; None
| { t = `Atom (`Uchar _); _ } ->
incr i;
None
| _ -> None)
c.sel
with
@ -1189,8 +1258,7 @@ module Panel = struct
(`Draw
(fun (t : draw_context) (b : P2.t) ->
Draw.node t b
(Text.lines (Fmt.to_to_string pp_node_structure c.root))
) )
(Text.lines (Fmt.to_to_string pp_node_structure c.root))))
(atom `Empty)
let draw_cursor_sel (c : cursor) : node =
@ -1220,9 +1288,11 @@ module Panel = struct
match e with
| `Key (`Press, (k : Key.keystate)) -> (
match k.code with
| `Uchar c -> Some (`Insert (atom (`Uchar c)))
| `Uchar c ->
Some (`Insert (atom (`Uchar c)))
| _ -> None)
| _ -> None ) in
| _ -> None)
in
let r =
match a with
| Some x ->
@ -1237,9 +1307,10 @@ module Panel = struct
Action.pp_t x);
c.sel <- insert_attr cursor_attr c.sel;
None
| None -> None in
r )
, n ) ;
| None -> None
in
r),
n );
join_y (pad 5. c.root)
(join_y
(pad 5. (draw_cursor_sel c))
@ -1265,16 +1336,22 @@ module Panel = struct
F.epr "Unhandled event: %s@." (Event.to_string _e));
Draw.node { vg; style = Style.dark } p t
let test =
style Style.dark
(pad 20.
(textedit
Text.(
(* text "--- welcome to my land of idiocy ---"
^/^ *)
text "hello bitch"
(*^^ text "! sup daddy" ^^ nl)
^/^ lines "123")*)) ) )
let storetree = ref (Nav.test_pull ())
let storecursor = ref []
open Lwt.Infix
let render_lwt (vg : NVG.t) (p : P2.t) (_ev : Event.t) :
unit Lwt.t =
!storetree >>= fun tree ->
Nav.S.Tree.list tree !storecursor >>= fun l ->
let contents =
String.concat "\n" (List.map (fun (step, _t') -> step) l)
in
Draw.node { vg; style = Style.dark } p (Text.lines contents)
|> ignore;
Lwt.return_unit
end
end