(*

ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!

Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2

a computation console

- irmin store provides a tree of data objects
- the tree can be navigated in the default view
- the selected object can be edited <enter> or executed as an ocaml top level phrase <C-enter>
- each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message
- while editing a data object <ctrl-enter> wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text.
- executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default??


but how do we integrate this with the ocaml environment and name spaces??
some options:
- always wrap execution units from data objects in some sort of local namespace so opens are not global?
- dig into the toplevel environment and manipulate it, this will also help with things like completion and context help

*)

open Lwt.Infix
module F = Fmt
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)

module Key = struct
  type special =
    [ `Enter
    | `Escape
    | `Tab
    | `Arrow of [`Up | `Down | `Left | `Right]
    | `Function of int
    | `Page of [`Up | `Down]
    | `Home
    | `End
    | `Insert
    | `Delete
    | `Backspace ]

  (** Type of key code. *)
  type code =
    [`Uchar of Uchar.t  (** A unicode character. *) | special]

  type keystate =
    {ctrl: bool; meta: bool; shift: bool; super: bool; code: code}

  module KeyS = struct
    type t = keystate

    let compare = compare
  end

  module Bind = struct
    (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
    module S = Zed_input.Make (KeyS)

    type 'a t = 'a list S.t
    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 mods = Ctrl | Meta | Super | Shift
    type key = C of char | U of code

    let keystate_of_mods ks m =
      List.fold_left
        (fun ks m ->
          match m with
          | Meta -> {ks with meta= true}
          | Ctrl -> {ks with ctrl= true}
          | Super -> {ks with super= true}
          | Shift -> {ks with shift= true} )
        ks m

    let add events action bindings =
      let events =
        List.map
          (fun (m, k) ->
            keystate_of_mods
              { meta= false
              ; ctrl= false
              ; super= false
              ; shift= false
              ; code=
                  ( match k with
                  | C c -> `Uchar (Uchar.of_char c)
                  | U c -> c ) }
              m )
          events in
      S.add events action bindings

    let default_resolver b = S.resolver [S.pack (fun x -> x) b]

    let get_resolver result default =
      match result with S.Continue r -> r | _ -> default

    let init bindings =
      {bindings; state= S.Rejected; last_keyseq= []; last_actions= []}

    let resolve = S.resolve
    let empty = S.empty

    type action =
      | Custom of (unit -> unit)
      | CustomLwt of (unit -> unit Lwt.t)
      | Zed of Zed_edit.action

    let resolve_events (state : 'a state) events =
      List.flatten
        (List.filter_map
           (fun e ->
             match e with
             | `Key (`Press, (k : keystate)) -> (
                 ( match state.state with
                 | Continue _ -> ()
                 | _ -> state.last_keyseq <- [] ) ;
                 state.state <-
                   resolve k
                     (get_resolver state.state
                        (default_resolver state.bindings) ) ;
                 state.last_keyseq <- k :: state.last_keyseq ;
                 match state.state with
                 | Accepted a ->
                     state.last_actions <- a ;
                     Some a
                 | Rejected ->
                     state.last_actions <- [] ;
                     None
                 | _ -> None )
             | _ -> None )
           events )

    let actions_of_events (state : action state) events =
      List.flatten
        (List.filter_map
           (fun e ->
             match e with
             | `Key (`Press, (k : keystate)) -> (
                 ( match state.state with
                 | Continue _ -> ()
                 | _ -> state.last_keyseq <- [] ) ;
                 state.state <-
                   resolve k
                     (get_resolver state.state
                        (default_resolver state.bindings) ) ;
                 state.last_keyseq <- k :: state.last_keyseq ;
                 match state.state with
                 | Accepted a ->
                     state.last_actions <- a ;
                     Some a
                 | Rejected ->
                     state.last_actions <- [] ;
                     None
                 | _ -> None )
             | _ -> None )
           events )

    let process bindstate events =
      Lwt_list.iter_s
        (function
          | Custom f -> Lwt.return (f ())
          | CustomLwt f -> f ()
          | Zed _ -> Lwt.return_unit )
        (actions_of_events bindstate events)
  end

  (* 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)
    | `Enter -> "Enter"
    | `Escape -> "Escape"
    | `Tab -> "Tab"
    | `Arrow `Up -> "Up"
    | `Arrow `Down -> "Down"
    | `Arrow `Left -> "Left"
    | `Arrow `Right -> "Right"
    | `Function i -> F.str "F%d" i
    | `Page `Up -> "Page Up"
    | `Page `Down -> "Page Down"
    | `Home -> "Home"
    | `End -> "End"
    | `Insert -> "Insert"
    | `Delete -> "Delete"
    | `Backspace -> "Backspace"

  let to_string key =
    Printf.sprintf
      "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
      key.ctrl key.meta key.shift key.super
      (string_of_code key.code)

  let to_string_compact key =
    let buffer = Buffer.create 32 in
    if key.ctrl then Buffer.add_string buffer "Ctrl-" ;
    if key.meta then Buffer.add_string buffer "Meta-" ;
    if key.shift then Buffer.add_string buffer "Shift-" ;
    if key.super then Buffer.add_string buffer "Super-" ;
    ( match key.code with
    | `Uchar ch ->
        let code = Uchar.to_int ch in
        if Uchar.is_char ch then
          match Uchar.to_char ch with
          | ( 'a' .. 'z'
            | 'A' .. 'Z'
            | '0' .. '9'
            | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
            | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
            | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
              Buffer.add_char buffer ch
          | ' ' -> Buffer.add_string buffer "space"
          | _ -> Printf.bprintf buffer "U+%02x" code
        else if code <= 0xffff then
          Printf.bprintf buffer "U+%04x" code
        else Printf.bprintf buffer "U+%06x" code
    | `Page `Down -> Buffer.add_string buffer "pgup"
    | `Page `Up -> Buffer.add_string buffer "pgdn"
    | code ->
        Buffer.add_string buffer
          (String.lowercase_ascii (string_of_code code)) ) ;
    Buffer.contents buffer
end

module Event = struct
  open Tsdl
  open Key
  open Gg

  type mouse = V2.t

  type t =
    [ `Key of [`Press | `Release | `Repeat] * keystate
    | `Mouse of mouse
    | `Quit
    | `Fullscreen of bool
    | `Unknown of string ]

  type events = t list

  let to_string = function
    | `Key (x, k) ->
        "`Key "
        ^ ( match x with
          | `Press -> "`Press "
          | `Release -> "`Release "
          | `Repeat -> "`Repeat " )
        ^ Key.to_string k
    | `Mouse m -> F.str "`Mouse %a" V2.pp m
    | `Quit -> "`Quit"
    | `Fullscreen b -> F.str "`Fullscreen %b" b
    | `Unknown s -> F.str "`Unknown %s" s

  let sdlkey_map = Hashtbl.create 1024

  let () =
    let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in
    let open Sdl.K in
    aa return `Enter ;
    aa escape `Escape ;
    aa backspace `Backspace ;
    aa tab `Tab ;
    aa f1 (`Function 1) ;
    aa f2 (`Function 2) ;
    aa f3 (`Function 3) ;
    aa f4 (`Function 4) ;
    aa f5 (`Function 5) ;
    aa f6 (`Function 6) ;
    aa f7 (`Function 7) ;
    aa f8 (`Function 8) ;
    aa f9 (`Function 9) ;
    aa f10 (`Function 10) ;
    aa f11 (`Function 11) ;
    aa f12 (`Function 12) ;
    aa insert `Insert ;
    aa delete `Delete ;
    aa home `Home ;
    aa kend `End ;
    aa pageup (`Page `Up) ;
    aa pagedown (`Page `Down) ;
    aa right (`Arrow `Right) ;
    aa left (`Arrow `Left) ;
    aa down (`Arrow `Down) ;
    aa up (`Arrow `Up)

  let key_of_sdlkey ev =
    let (kc : Sdl.keycode) =
      Sdl.Event.get ev Sdl.Event.keyboard_keycode
      land lnot Sdl.K.scancode_mask in
    match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with
    | Some s, _ -> Some s
    | None, true -> Some (`Uchar (Uchar.of_int kc))
    | None, false -> None

  let event_of_sdlevent ev : t option =
    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
    | (`Key_down | `Key_up) as d -> (
      match key_of_sdlkey ev with
      | None -> None
      | Some code ->
          let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
          Some
            (`Key
              ( ( match d with
                | _
                  when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1
                  ->
                    `Repeat
                | `Key_up -> `Release
                | _ -> `Press )
              , { code
                ; ctrl= km land Sdl.Kmod.ctrl > 0
                ; meta= km land Sdl.Kmod.alt > 0
                ; super= km land Sdl.Kmod.gui > 0
                ; shift= km land Sdl.Kmod.shift > 0 } ) ) )
    | `Mouse_motion ->
        let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in
        Some (`Mouse (V2.v (float x) (float y)))
    | `Quit -> Some `Quit
    (* Unhandled events *)
    | `Text_editing -> Some (`Unknown "`Text_editing")
    | `Text_input -> Some (`Unknown "`Text_input")
    | `App_did_enter_background ->
        Some (`Unknown "`App_did_enter_background")
    | `App_did_enter_foreground ->
        Some (`Unknown "`App_did_enter_foreground ")
    | `App_low_memory -> Some (`Unknown "`App_low_memory ")
    | `App_terminating -> Some (`Unknown "`App_terminating ")
    | `App_will_enter_background ->
        Some (`Unknown "`App_will_enter_background ")
    | `App_will_enter_foreground ->
        Some (`Unknown "`App_will_enter_foreground ")
    | `Clipboard_update -> Some (`Unknown "`Clipboard_update ")
    | `Controller_axis_motion ->
        Some (`Unknown "`Controller_axis_motion ")
    | `Controller_button_down ->
        Some (`Unknown "`Controller_button_down ")
    | `Controller_button_up -> Some (`Unknown "`Controller_button_up ")
    | `Controller_device_added ->
        Some (`Unknown "`Controller_device_added ")
    | `Controller_device_remapped ->
        Some (`Unknown "`Controller_device_remapped ")
    | `Controller_device_removed ->
        Some (`Unknown "`Controller_device_removed ")
    | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ")
    | `Dollar_record -> Some (`Unknown "`Dollar_record ")
    | `Drop_file -> Some (`Unknown "`Drop_file ")
    | `Finger_down -> Some (`Unknown "`Finger_down")
    | `Finger_motion -> Some (`Unknown "`Finger_motion ")
    | `Finger_up -> Some (`Unknown "`Finger_up ")
    | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ")
    | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ")
    | `Joy_button_down -> Some (`Unknown "`Joy_button_down ")
    | `Joy_button_up -> Some (`Unknown "`Joy_button_up ")
    | `Joy_device_added -> Some (`Unknown "`Joy_device_added ")
    | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ")
    | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ")
    | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ")
    | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up")
    | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ")
    | `Multi_gesture -> Some (`Unknown "`Multi_gesture")
    | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ")
    | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e))
    | `User_event -> Some (`Unknown "`User_event ")
    | `Display_event -> Some (`Unknown "`Display_event ")
    | `Sensor_update -> Some (`Unknown "`Sensor_update ")
    | `Window_event -> Some (`Unknown "`Window_event ")

  let key_up : Sdl.keycode = 0x40000052
  let key_down : Sdl.keycode = 0x40000051
  let key_left : Sdl.keycode = 0x40000050
  let key_right : Sdl.keycode = 0x4000004f
  let handle_keyevents (el : events) f = List.iter f el
end

module Display = struct
  open Tgles2
  open Tsdl
  open Gg
  open Wall
  module I = Image
  module P = Path

  let ( >>>= ) x f =
    match x with Ok a -> f a | Error _ as result -> result

  let get_result = function
    | Ok x -> x
    | Error (`Msg msg) -> failwith msg

  (* current window state to be passed to window renderer *)
  type state =
    { box: box2
          (* This is cannonically box within which the next element should draw *)
    ; time: float
    ; wall: Wall.renderer }

  (* the box2 here is cannonically the place the returner drew
     (the Wall.image extents) *)
  type image = box2 * Wall.image
  type pane = state -> state * image
  type actor = (Event.events -> pane Lwt.t) ref

  let pane_empty s =
    (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty))

  type frame =
    { sdl_win: Sdl.window
    ; gl: Sdl.gl_context
    ; wall: Wall.renderer
    ; mutable last_pane: pane
    ; mutable quit: bool
    ; mutable fullscreen: bool }

  let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.

  let on_failure ~cleanup result =
    (match result with Ok _ -> () | Error _ -> cleanup ()) ;
    result

  let video_initialized = lazy (Sdl.init Sdl.Init.video)

  let make_frame ?(title = "komm") ~w ~h () =
    Lazy.force video_initialized
    >>>= fun () ->
    Sdl.create_window ~w ~h title
      Sdl.Window.(
        opengl + allow_highdpi + resizable (*+ input_grabbed*))
    >>>= fun sdl_win ->
    Sdl.set_window_title sdl_win title ;
    ignore (Sdl.gl_set_swap_interval (-1)) ;
    ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ;
    on_failure
      ( Sdl.gl_create_context sdl_win
      >>>= fun gl ->
      let wall =
        Wall.Renderer.create ~antialias:true ~stencil_strokes:true ()
      in
      Ok
        { sdl_win
        ; gl
        ; wall
        ; quit= false
        ; fullscreen= false
        ; last_pane= pane_empty } )
      ~cleanup:(fun () -> Sdl.destroy_window sdl_win)

  let handle_frame_events frame events =
    List.iter
      (fun (e : Event.t) ->
        match e with
        | `Quit -> frame.quit <- true
        | `Fullscreen a ->
            frame.fullscreen <- a ;
            ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ;
            ignore
              ( Sdl.set_window_fullscreen frame.sdl_win
                  ( if frame.fullscreen then
                    Sdl.Window.fullscreen_desktop
                  else Sdl.Window.windowed )
                : _ result )
        | _ -> () )
      events

  let draw_pane frame pane =
    let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
    let _, (_, image) =
      pane
        { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height))
        ; time= ticks ()
        ; wall= frame.wall } in
    Sdl.gl_make_current frame.sdl_win frame.gl
    >>>= fun () ->
    Gl.viewport 0 0 width height ;
    Gl.clear_color 0.0 0.0 0.0 1.0 ;
    Gl.(
      clear
        (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ;
    Gl.enable Gl.blend ;
    Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one
      Gl.one_minus_src_alpha ;
    Gl.enable Gl.cull_face_enum ;
    Gl.disable Gl.depth_test ;
    let width = float width and height = float height in
    Wall.Renderer.render frame.wall ~width ~height image ;
    Sdl.gl_swap_window frame.sdl_win ;
    Ok ()

  let rec get_events () : Event.t list =
    (* create and fill event list *)
    let ev = Sdl.Event.create () in
    if Sdl.poll_event (Some ev) then
      match Event.event_of_sdlevent ev with
      | Some e -> get_events () @ [e]
      | None -> get_events ()
    else []

  let successful_actor = ref (fun _ -> Lwt.return pane_empty)

  let display_frame frame (actor : actor) =
    let events = get_events () in
    handle_frame_events frame events ;
    if List.length events > 0 then (
      (* recompute the actor definition with the new events to return a new pane *)
      ( try
          !actor events
          >|= fun p ->
          successful_actor := !actor ;
          p
        with e ->
          F.epr
            "Display.display_frame (!actor events) failed with:@. %s \
             @."
            (Printexc.to_string e) ;
          actor := !successful_actor ;
          !actor events )
      >>= fun p ->
      frame.last_pane <- p ;
      (* call draw_pane because we should redraw now that we have updated *)
      ignore (draw_pane frame frame.last_pane) ;
      Lwt.return_unit )
    else Lwt.return_unit

  let run frame actor () =
    let frame = get_result frame in
    Sdl.show_window frame.sdl_win ;
    let rec loop () =
      Lwt.pause () (* seems required for the irc connection to work *)
      >>= fun () ->
      Lwt_unix.sleep 0.030
      >>= fun () ->
      display_frame frame actor
      >>= fun () ->
      if not frame.quit then loop () else Lwt.return_unit in
    Lwt_main.run (loop ()) ;
    print_endline "quit" ;
    Sdl.hide_window frame.sdl_win ;
    Sdl.gl_delete_context frame.gl ;
    Sdl.destroy_window frame.sdl_win ;
    Sdl.quit () ;
    ()

  let gray ?(a = 1.0) v = Color.v v v v a

  module FontCache = Map.Make (String)

  let font_cache = ref FontCache.empty

  let load_font name =
    match FontCache.find_opt name !font_cache with
    | Some font -> font
    | None -> (
        let ic = open_in_bin name in
        let dim = in_channel_length ic in
        let fd = Unix.descr_of_in_channel ic in
        let buffer =
          Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout
            false [|dim|]
          |> Bigarray.array1_of_genarray in
        let offset = List.hd (Stb_truetype.enum buffer) in
        match Stb_truetype.init buffer offset with
        | None -> assert false
        | Some font ->
            font_cache := FontCache.add name font !font_cache ;
            font )

  let font_icons = lazy (load_font "fonts/entypo.ttf")
  let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf")
  let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf")
  let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf")
  let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf")

  let font_sans_bold_italic =
    lazy (load_font "fonts/Roboto-BoldItalic.ttf")

  let font_serif =
    lazy (load_font "fonts/ScheherazadeNew-Regular.ttf")

  let font_serif_bold =
    lazy (load_font "fonts/ScheherazadeNew-Bold.ttf")

  let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular")

  let font_mono_bold =
    lazy (load_font "fonts/static/RobotoMono-Regular")

  let font_mono_light =
    lazy (load_font "fonts/static/RobotoMono-Regular")

  let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")

  let str_of_box b =
    Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
      (Box2.oy b) (Box2.maxx b) (Box2.maxy b)

  let draw_label text b =
    let f =
      Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans)
    in
    ( Box2.v (Box2.o b)
        (P2.v (Wall_text.Font.text_width f text) (Box2.h b))
    , I.paint
        (Paint.color (gray ~a:0.5 1.0))
        Wall_text.(
          simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b)
            ~y:(Box2.oy b +. (Box2.h b *. 0.75))
            text) )

  let fill_box c b =
    ( b
    , I.paint (Paint.color c)
        ( I.fill_path
        @@ fun t ->
        P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
          ~h:(Box2.h b) ) )

  let draw_filled_box c (s : state) = (s, fill_box c s.box)

  let path_box c b (s : state) =
    ( s
    , ( b
      , I.paint (Paint.color c)
          ( I.stroke_path (Outline.make ())
          @@ fun t ->
          P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
            ~h:(Box2.h b) ) ) )

  let path_circle c b (s : state) =
    ( s
    , ( b
      , I.paint (Paint.color c)
          ( I.stroke_path (Outline.make ())
          @@ fun t ->
          P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b)
            ~r:(Box2.w b /. 2.) ) ) )

  (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
    This way basic widgets will just expand to the full area of a box, while other widgets can have
    the express purpose of limiting the size of an object in a larger system of limitations. 

    Panes return a tuple: (state, (box, image))
    state is the updated state, where state.box is always 
      - the top left corner of the box the pane drew in, and
      - the bottom right corner of the state.box that was passed in
    box is the area the widget actually drew in (or wants to sort of "use")
    image is the Wall.image to compose with other panes and draw to the display
  *)

  let simple_text f text (s : state) =
    let fm = Wall_text.Font.font_metrics f in
    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
    let tm = Wall_text.Font.text_measure f text in
    let br_pt =
      P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height)
    in
    let bextent = Box2.of_pts (Box2.o s.box) br_pt in
    (*  let _, (_, redbox) = path_box Color.red bextent s in*)
    ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)}
    , ( bextent
      , (* I.stack redbox *)
        I.paint
          (Paint.color (gray ~a:0.5 1.0))
          Wall_text.(
            simple_text f ~valign:`BASELINE ~halign:`LEFT
              ~x:(Box2.ox s.box)
              ~y:(Box2.oy s.box +. fm.ascent)
              text) ) )

  let pane_box next_point_func (subpanes : pane list) (so : state) =
    let sr, (br, ir) =
      List.fold_left
        (fun (sp, (bp, ip)) (pane : pane) ->
          (* uses br to hold max extent of boxes *)
          let sr, (br, ir) = pane sp in
          (* draw the pane *)
          let _, (_, irb) = path_box Color.blue br sr in
          (* draw the box around the pane *)
          ( { sr with
              box= Box2.of_pts (next_point_func br) (Box2.max sp.box)
            }
          , ( Box2.of_pts (Box2.o bp)
                (P2.v
                   (max (Box2.maxx br) (Box2.maxx bp))
                   (max (Box2.maxy br) (Box2.maxy bp)) )
            , Image.seq [ip; irb; ir] ) ) )
        ( so
        , (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty)
        )
        subpanes in
    let _, (_, redbox) = path_box Color.red br sr in
    (sr, (br, Image.stack redbox ir))
end

module Panel = struct
  open Display
  open Gg

  type t =
    { mutable act: t -> Event.events -> Display.pane Lwt.t
    ; mutable subpanels: t Lwt.t list
    ; mutable tag: string }

  type panel = t

  let blank =
    { act= (fun _panel _events -> Lwt.return Display.pane_empty)
    ; subpanels= []
    ; tag= "blank pane" }

  let draw (pane : Display.pane) =
    Lwt.return
      { act= (fun _panel _events -> Lwt.return pane)
      ; subpanels= []
      ; tag= "draw-pane" }

  let actor (panel : t) : Event.events -> Display.pane Lwt.t =
   fun events ->
    panel.act panel events >>= fun pane -> Lwt.return pane

  let filter_events ef p =
    p
    >>= fun p' ->
    Lwt.return
      {p' with act= (fun panel events -> p'.act panel (ef events))}

  let resolve_panels events =
    Lwt_list.map_s (fun s ->
        s
        >>= fun subpanel ->
        subpanel.act subpanel events >>= fun pane -> Lwt.return pane )

  (* draws subsequent items below *)
  let vbox subpanels =
    Lwt.return
      { act=
          (fun panel events ->
            resolve_panels events panel.subpanels
            >|= fun pl -> pane_box Box2.tl_pt pl )
          (* tl_pt is actually bl_pt in the Wall coordinate system *)
      ; subpanels
      ; tag= "vertical-box" }

  (* draws subsequent item to the right *)
  let hbox subpanels =
    Lwt.return
      { act=
          (fun panel events ->
            resolve_panels events panel.subpanels
            >|= fun pl -> pane_box Box2.br_pt pl )
          (* br_pt is actually tr_pt in the Wall coordinate system *)
      ; subpanels
      ; tag= "horizontal-box" }

  (* draws subsequent panels overtop each other *)
  let obox (subpanels : t Lwt.t list) =
    { act=
        (fun panel events ->
          resolve_panels events panel.subpanels
          >|= fun pl -> pane_box Box2.o pl )
    ; subpanels
    ; tag= "origin-box" }

  let g_text_height = ref 25.

  type Format.stag += Color_bg of Wall.color
  type Format.stag += Color_fg of Wall.color
  type Format.stag += Cursor of Wall.color
  type Format.stag += None_tag

  let draw_pp height fpp (s : state) =
    let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in
    let push (s, (b, i)) =
      node := I.stack !node i ;
      sc := s ;
      box := b in
    let font =
      Wall_text.Font.make ~size:height (Lazy.force font_sans) in
    let fm = Wall_text.Font.font_metrics font in
    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
    let max_x = ref 0. in
    let out_string text o l =
      let sp = !sc in
      push @@ simple_text font (String.sub text o l) !sc ;
      max_x := max !max_x (Box2.maxx !box) ;
      sc :=
        { !sc with
          box=
            Box2.of_pts
              (P2.v (Box2.maxx !box) (Box2.oy sp.box))
              (Box2.max sp.box) } in
    let out_flush () = () in
    let out_newline () =
      sc :=
        { !sc with
          box=
            Box2.of_pts
              (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height))
              (Box2.max s.box) } in
    let out_spaces n =
      let wpx = Wall_text.Font.text_width font " " in
      if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then
        (* WRAP *)
        out_newline () ;
      let so = !sc in
      (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
         push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*)
      box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ;
      sc :=
        {!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)}
    in
    let out_indent n =
      let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in
      sc :=
        { !sc with
          box=
            Box2.of_pts
              (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box))
              (Box2.max !sc.box) } in
    let out_funs =
      Format.
        {out_string; out_flush; out_newline; out_spaces; out_indent}
    in
    let pp = Format.formatter_of_out_functions out_funs in
    Format.pp_set_formatter_stag_functions pp
      { mark_open_stag=
          (fun s ->
            ( match s with
            | Cursor c ->
                push
                @@ ( !sc
                   , fill_box c
                       (Box2.v (Box2.o !sc.box)
                          (P2.v (height *. 0.333) height) ) )
            | Color_bg c -> push @@ (!sc, fill_box c !box)
            | _ -> () ) ;
            "" )
      ; mark_close_stag= (function _ -> () ; "")
      ; print_open_stag= (fun _ -> (*"<open_stag>"*) ())
      ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
        print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
    Format.pp_set_tags pp true ;
    let margin =
      int_of_float (Box2.w s.box /. Wall_text.Font.text_width font " ")
    in
    let max_indent = margin - 1 in
    Format.pp_safe_set_geometry pp ~max_indent ~margin ;
    fpp pp ;
    Format.pp_force_newline pp () ;
    ( !sc
    , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
      , !node ) )

  let format_symbolic_output_items (ppf : Format.formatter) buf =
    List.iter
      Format.(
        function
        | Output_flush -> F.pf ppf "@?"
        | Output_newline -> F.pf ppf "@."
        | Output_string s -> Format.pp_print_string ppf s
        | Output_spaces n | Output_indent n ->
            Format.pp_print_string ppf (String.make n ' '))
      buf

  let format_symbolic_output_buffer (ppf : Format.formatter) buf =
    format_symbolic_output_items ppf
      (Format.get_symbolic_output_buffer buf)

  let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
      fpp =
    Lwt.return
      { act= (fun _panel _events -> Lwt.return (draw_pp height fpp))
      ; subpanels= []
      ; tag }

  module Textedit = struct
    type t =
      { mutable zed: unit Zed_edit.context
      ; mutable view: Zed_cursor.t
      ; mutable keybind: Key.Bind.action Key.Bind.state }

    let bindings te =
      let open Key.Bind in
      add [([], U (`Arrow `Left))] [Zed Prev_char]
      @@ add [([], U (`Arrow `Right))] [Zed Next_char]
      @@ add [([], U (`Arrow `Up))] [Zed Prev_line]
      @@ add [([], U (`Arrow `Down))] [Zed Next_line]
      @@ add [([], U `Home)] [Zed Goto_bol]
      @@ add [([], U `End)] [Zed Goto_eol]
      @@ add [([], U `Insert)] [Zed Switch_erase_mode]
      @@ add [([], U `Delete)] [Zed Delete_next_char]
      @@ add [([], U `Enter)] [Zed Newline]
      @@ add [([Ctrl], C ' ')] [Zed Set_mark]
      @@ add [([Ctrl], C 'a')] [Zed Goto_bol]
      @@ add [([Ctrl], C 'e')] [Zed Goto_eol]
      @@ add [([Ctrl], C 'd')] [Zed Delete_next_char]
      @@ add [([Ctrl], C 'h')] [Zed Delete_prev_char]
      @@ add [([Ctrl], C 'k')] [Zed Kill_next_line]
      @@ add [([Ctrl], C 'u')] [Zed Kill_prev_line]
      @@ add [([Ctrl], C 'n')] [Zed Next_line]
      @@ add [([Ctrl], C 'p')] [Zed Prev_line]
      @@ add [([Ctrl], C 'w')] [Zed Kill]
      @@ add [([Ctrl], C 'y')] [Zed Yank]
      @@ add [([], U `Backspace)] [Zed Delete_prev_char]
      @@ add [([Meta], C 'w')] [Zed Copy]
      @@ add [([Meta], C 'c')] [Zed Capitalize_word]
      @@ add [([Meta], C 'l')] [Zed Lowercase_word]
      @@ add [([Meta], C 'u')] [Zed Uppercase_word]
      @@ add [([Meta], C 'b')] [Zed Prev_word]
      @@ add [([Meta], C 'f')] [Zed Next_word]
      @@ add [([Meta], U (`Arrow `Right))] [Zed Next_word]
      @@ add [([Meta], U (`Arrow `Left))] [Zed Prev_word]
      @@ add [([Ctrl], U (`Arrow `Right))] [Zed Next_word]
      @@ add [([Ctrl], U (`Arrow `Left))] [Zed Prev_word]
      @@ add [([Meta], U `Backspace)] [Zed Kill_prev_word]
      @@ add [([Meta], U `Delete)] [Zed Kill_prev_word]
      @@ add [([Ctrl], U `Delete)] [Zed Kill_next_word]
      @@ add [([Meta], C 'd')] [Zed Kill_next_word]
      @@ add [([Ctrl], C '/')] [Zed Undo]
      @@ add [([Ctrl], C 'x'); ([], C 'u')] [Zed Undo]
      @@ add
           [([Ctrl], C 'v')]
           [ Custom
               (fun () ->
                 let r = Zed_edit.text (Zed_edit.edit te.zed) in
                 let l = Zed_lines.of_rope r in
                 let i = Zed_cursor.get_line te.view in
                 Zed_cursor.goto te.view
                   (Zed_lines.line_start l i + 10) ) ]
      @@ add
           [([Meta], C 'v')]
           [ Custom
               (fun () ->
                 let r = Zed_edit.text (Zed_edit.edit te.zed) in
                 let l = Zed_lines.of_rope r in
                 let i = Zed_cursor.get_line te.view in
                 Zed_cursor.goto te.view
                   (Zed_lines.line_start l i - 10) ) ]
      @@ empty

    let clear te =
      let ze = Zed_edit.create () in
      te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze)

    let insert te text =
      Zed_edit.insert te.zed
        (Zed_rope.of_string (Zed_string.of_utf8 text))

    let contents (te : t) =
      Zed_string.to_utf8
        (Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed)))

    let make ?(keybinds = bindings) initialtext () =
      let ze = Zed_edit.create () in
      let te =
        { zed= Zed_edit.context ze (Zed_edit.new_cursor ze)
        ; view= Zed_edit.new_cursor ze
        ; keybind= Key.Bind.(init empty) } in
      te.keybind.bindings <- keybinds te ;
      insert te initialtext ;
      te

    let panel ?(height = !g_text_height) te =
      Lwt.return
        { act=
            (fun _panel events ->
              (* collect events and update Zed context *)
              Lwt_list.iter_s
                (function
                  | `Key (`Press, (k : Key.keystate)) -> (
                      let open Key.Bind in
                      ( match te.keybind.state with
                      | Accepted _ | Rejected ->
                          te.keybind.last_keyseq <- [] ;
                          te.keybind.last_actions <- []
                      | Continue _ -> () ) ;
                      te.keybind.state <-
                        resolve k
                          (get_resolver te.keybind.state
                             (default_resolver te.keybind.bindings) ) ;
                      te.keybind.last_keyseq <-
                        k :: te.keybind.last_keyseq ;
                      match te.keybind.state with
                      | Accepted a ->
                          te.keybind.last_actions <- a ;
                          Lwt_list.iter_s
                            (function
                              | Custom f -> Lwt.return (f ())
                              | CustomLwt f -> f ()
                              | Zed za ->
                                  Lwt.return
                                    (Zed_edit.get_action za te.zed) )
                            a
                      | Continue _ | Rejected -> Lwt.return_unit )
                  | _ -> Lwt.return_unit )
                events
              >>= fun () ->
              let draw_textedit =
                draw_pp height (fun pp ->
                    let _, view =
                      Zed_rope.break
                        (Zed_edit.text (Zed_edit.edit te.zed))
                        (Zed_cursor.get_position te.view) in
                    Format.pp_open_hvbox pp 0 ;
                    if
                      Zed_cursor.get_position te.view
                      > Zed_cursor.get_position
                          (Zed_edit.cursor te.zed)
                    then (
                      let zrb, zra =
                        Zed_rope.break
                          (Zed_edit.text (Zed_edit.edit te.zed))
                          (Zed_cursor.get_position
                             (Zed_edit.cursor te.zed) ) in
                      let before_cursor =
                        Zed_string.to_utf8 (Zed_rope.to_string zrb)
                      in
                      let after_cursor =
                        Zed_string.to_utf8 (Zed_rope.to_string zra)
                      in
                      F.text pp before_cursor ;
                      Format.pp_open_stag pp
                        (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
                      F.pf pp "" ;
                      Format.pp_close_stag pp () ;
                      F.text pp after_cursor )
                    else
                      F.text pp
                        (Zed_string.to_utf8 (Zed_rope.to_string view)) ;
                    F.pf pp "@." ;
                    Format.pp_close_box pp () ) in
              Lwt.return draw_textedit )
        ; subpanels= []
        ; tag= "textedit" }

    (* pane that displays last key binding match state *)
    let bindingstate ?(height = !g_text_height)
        (b : Key.Bind.action Key.Bind.state) =
      Lwt.return
        { act=
            (fun _panel _events ->
              Lwt.return
                (draw_pp height (fun pp ->
                     Format.pp_open_hbox pp () ;
                     F.text pp
                       (List.fold_left
                          (fun s x ->
                            Key.to_string_compact x ^ " " ^ s )
                          "" b.last_keyseq ) ;
                     F.text pp "-> " ;
                     F.text pp
                       ( match b.state with
                       | Accepted a ->
                           "Accepted "
                           ^ List.fold_right
                               (fun x s ->
                                 s
                                 ^ Key.Bind.(
                                     match x with
                                     | Zed a ->
                                         Zed_edit.name_of_action a
                                     | CustomLwt _ -> "CustomLwt"
                                     | Custom _ -> "Custom")
                                 ^ "; " )
                               a ""
                       | Rejected -> "Rejected"
                       | Continue _ -> "Continue" ) ;
                     Format.pp_close_box pp () ;
                     F.flush pp () ) ) )
        ; subpanels= []
        ; tag= "binding-state" }
  end

  module Modal = struct
    type t =
      { te: Textedit.t
      ; mutable input: string option
      ; mutable handle: string -> unit
      ; mutable prompt: string }

    let make () =
      { te= Textedit.make "" ()
      ; input= None
      ; handle= (fun _text -> ())
      ; prompt= "" }

    let panel ?(height = !g_text_height) me =
      let keybinds =
        let open Key.Bind in
        add
          [([], U `Enter)]
          [ Custom
              (fun () ->
                (* set input first so a modal can trigger another modal *)
                me.input <- None ;
                me.handle (Textedit.contents me.te) ) ]
          (Textedit.bindings me.te) in
      me.te.keybind.bindings <- keybinds ;
      Lwt.return
        { act=
            (fun panel events ->
              match me.input with
              | Some text ->
                  Textedit.insert me.te text ;
                  hbox panel.subpanels >>= fun p -> p.act panel events
              | None -> Lwt.return Display.pane_empty
              (* don't draw anything if modal isn't active *) )
        ; subpanels=
            [ prettyprint (fun pp -> F.text pp me.prompt)
            ; Textedit.panel ~height me.te ]
        ; tag= "modal-edit" }

    let start me ?(prompt = "> ") text handler =
      me.input <- Some text ;
      Textedit.clear me.te ;
      Textedit.insert me.te text ;
      me.handle <- handler ;
      me.prompt <- prompt

    let is_active me =
      match me.input with Some _ -> true | None -> false
  end

  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] }

      let empty =
        { size= None
        ; font= `None
        ; weight= `None
        ; italic= `None
        ; underline= `None }

      let default =
        ref
          { size= Some 20.
          ; font= `Sans
          ; weight= `Regular
          ; italic= `None
          ; underline= `None }

      let size {size; _} =
        match (size, !default.size) with
        | None, None -> 20.
        | None, Some s | Some s, _ -> s

      let get a =
        Wall_text.Font.make ~size:(size a)
          (load_font
             ( match (a.font, a.weight, a.italic) with
             | `Sans, `Regular, `None -> "fonts/Roboto-Regular.ttf"
             | `Sans, `Bold, `None -> "fonts/Roboto-Bold.ttf"
             | `Sans, `Light, `None -> "fonts/Roboto-Light.ttf"
             (* | `Sans, `Regular, `Italic -> "fonts/Roboto-Italic.ttf"
                | `Sans, `Bold, `Italic -> "fonts/Roboto-BoldItalic.ttf"
                | `Sans, `Light, `Italic ->
                    "fonts/Roboto-LightItalic.ttf"
                | `Serif, `Bold, _ -> "fonts/ScheherazadeNew-Bold.ttf"
                | `Serif, _, _ -> "fonts/ScheherazadeNew-Regular.ttf"
                | `Mono, `Regular, `None ->
                    "fonts/static/RobotoMono-Regular.ttf"*)
             | _, _, _ -> "fonts/Roboto-Regular.ttf" ) )

      let merge a b =
        { size=
            ( match (a.size, b.size) with
            | None, None -> None
            | Some s, None | None, Some s -> Some s
            | Some s1, Some s2 -> Some (Float.fmax 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=
            ( 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=
            ( match (a.italic, b.italic) with
            | `Italic, _ | _, `Italic -> `Italic
            | _ -> `None )
        ; underline=
            ( match (a.underline, b.underline) with
            | `Underline, _ | _, `Underline -> `Underline
            | _ -> `None ) }
    end

    type t = {fg: Wall.color; bg: Wall.color; font: Font.t}
    type attr = t

    let empty = {fg= Color.void; bg= Color.void; font= Font.empty}
    let light = {empty with fg= Color.gray 0.2}
    let dark = {empty with fg= Color.gray 0.8}
    let equal = ( == )

    let ( ++ ) a1 a2 =
      if a1 == empty then a2
      else if a2 == empty then a1
      else
        { a1 with
          fg= Color.blend a1.fg a2.fg
        ; bg= Color.blend a1.bg a2.bg }

    let fg fg = {empty with fg}
    let bg bg = {empty with bg}

    let merge a b =
      { fg= Wall.Color.blend a.fg b.fg
      ; bg= Wall.Color.blend a.bg b.bg
      ; font= Font.merge a.font b.font }
  end

  module Pad = struct
    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 }
  end

  module Ui = struct
    (* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
    (* i think this is gonna end up being a binary tree?? *)

    (* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)

    open Gg
    open Wall

    type t =
      [ `Atom of atom
      | `Attr of attr * node
      | `Join of dir * node * node ]

    and node = {mutable parent: node option; mutable t: t; n: int}
    and cursor = {root: node; mutable sel: node}

    and atom =
      [ `Image of image
      | `Uchar of Uchar.t
      | `Boundary of boundary
      | `Hint of [`Line | `Other]
      | `Empty ]

    and attr =
      [ `Style of style
      | `Pad of Pad.t
      | `Shift of dim
      | `Handler of handler ]

    and dir = [`X | `Y | `Z]
    and dim = Size2.t
    and image = Wall.image * dim
    and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text]
    and style = Style.t
    and handler = node -> Event.t -> Event.t option Lwt.t

    let set_parent_on_children n : node =
      ( match n.t with
      | `Atom _ -> ()
      | `Attr (_, a) -> a.parent <- Some n
      | `Join (_, a, b) ->
          a.parent <- Some n ;
          b.parent <- Some n ) ;
      n

    let node_count = ref 0

    let node_n () =
      node_count := !node_count + 1 ;
      !node_count - 1

    let node (t : t) =
      set_parent_on_children {parent= None; t; n= node_n ()}

    let empty_image = (Image.empty, V2.zero)
    let empty_node () = node (`Atom `Empty)
    let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))

    module Pp = struct
      let pp_uchar ppf v =
        if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
        else Fmt.Dump.uchar ppf v

      let pp_boundary ppf v =
        F.any
          ( match v with
          | `Char -> "`Char"
          | `Word -> "`Word"
          | `Phrase -> "`Phrase"
          | `Line -> "`Line"
          | `Page -> "`Page"
          | `Text ->
              "`Text"
              (* text is like a file (unicode calls it End Of Text) *)
          )
          ppf ()

      let pp_atom ppf v =
        let open Fmt in
        ( match v with
        | `Image _ -> any "`Image"
        | `Uchar c -> any "`Uchar " ++ const pp_uchar c
        | `Boundary b -> any "`Boundary " ++ const pp_boundary b
        | `Hint h ->
            any "`Hint "
            ++ any
                 (match h with `Line -> "`Line" | `Other -> "`Other")
        | `Empty -> any "`Empty" )
          ppf ()

      let pp_attr ppf v =
        let open Fmt in
        (any
           ( match v with
           | `Style _ -> "`Style ..."
           | `Pad _ -> "`Pad ..."
           | `Shift _ -> "`Shift ..."
           | `Cursor -> "`Cursor"
           | `Handler _ -> "`Handler ..." ) )
          ppf ()

      let pp_dir ppf v =
        F.pf ppf "%s"
          (match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")

      let pp_node_n ppf v = F.(pf ppf "%a" int v.n)

      let rec _pp_t child ppf v =
        let open Fmt in
        match v with
        | `Atom x -> pf ppf "`Atom %a" pp_atom x
        | `Attr (a, n) ->
            pf ppf "`Attr %a"
              (parens (const pp_attr a ++ comma ++ const child n))
              ()
        | `Join (d, a, b) ->
            pf ppf "`Join %a"
              (parens
                 ( const pp_dir d ++ comma ++ const child a ++ comma
                 ++ const child b ) )
              ()

      and _pp_node child ppf v =
        let open Fmt in
        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)
                    (option pp_node_n) ] ) )
          v

      and pp_node_n_record =
        F.(
          braces
            (record ~sep:semi [field "n" Fun.id pp_node_n; any "..."]))

      and pp_node ppf = _pp_node pp_node_n_record ppf
      and pp_dump_node ppf = _pp_node pp_dump_node ppf

      let pp_t = _pp_t pp_node_n_record

      let rec pp_node_structure ppf v =
        F.(
          const int v.n
          ++ parens
               (concat ~sep:comma
                  ( match v.t with
                  | `Atom a -> [const pp_atom a]
                  | `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 ] ) ))
          ppf ()
    end

    open Pp

    let rec traverse_nodes ~(f : node -> node option) (n : node) :
        unit =
      match f n with
      | Some {t= `Atom _; _} -> ()
      | Some {t= `Attr (_, n'); _} -> traverse_nodes ~f n'
      | Some {t= `Join (_, a, b); _} ->
          traverse_nodes ~f a ; traverse_nodes ~f b
      | None -> ()

    let insert_attr (a : attr) (n : node) : node =
      let p = n.parent in
      let n' = node (`Attr (a, n)) in
      n'.parent <- p ;
      ( match p with
      | Some p ->
          p.t <-
            ( match p.t with
            | `Attr (a, _) -> `Attr (a, n')
            | `Join (d, a, b) when n == a -> `Join (d, n', b)
            | `Join (d, a, b) when n == b -> `Join (d, a, n')
            | _ -> assert false )
      | None -> () ) ;
      n'

    let remove_attr (n : node) : node =
      match n.t with
      | `Attr (_, n') ->
          ( match n.parent with
          | Some p ->
              p.t <-
                ( match p.t with
                | `Attr (a, _) -> `Attr (a, n')
                | `Join (d, a, b) when n == a -> `Join (d, n', b)
                | `Join (d, a, b) when n == b -> `Join (d, a, n')
                | _ -> assert false ) ;
              ignore (set_parent_on_children p)
          | None -> () ) ;
          n'
      | _ -> assert false

    let sub (n : node) : node =
      match n.t with
      | `Atom _ -> n
      | `Attr (_, n) -> n
      | `Join (_, a, _) -> a

    let join_ d (a : node) (b : node) =
      set_parent_on_children
        {parent= a.parent; t= `Join (d, a, b); n= node_n ()}

    let join_x = join_ `X
    let join_y = join_ `Y
    let join_z = join_ `Z
    let pack_x : node Lwd_utils.monoid = (empty_node (), join_x)
    let pack_y : node Lwd_utils.monoid = (empty_node (), join_y)
    let pack_z : node Lwd_utils.monoid = (empty_node (), join_z)
    let ( ^^ ) = join_x
    let ( ^/^ ) = join_y
    let ( ^*^ ) = join_z

    let append_ d (l : node -> node) (a : node) : node -> node =
      F.epr "append_%a@." pp_dir d ;
      fun n -> l (join_ d a n)

    let empty_append = Fun.id
    let append_x = append_ `X
    let append_y = append_ `Y
    let append_z = append_ `Z

    (* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
       so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
       ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
       I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
       So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
       The main problem with this thought is that you can't do anything but append with the datastructure.
    *)

    module Text = struct
      let rec _of_string
          (segmenter :
               'a
            -> [`Uchar of Uchar.t | `Await | `End]
            -> 'a * [`Uchar of Uchar.t | `Await | `End] ) dec (ly, lx)
          =
        F.epr "_of_string@." ;
        let rec segment aa ll =
          F.epr "segment %s -> "
            ( match aa with
            | `Await -> "`Await"
            | `End -> "`End"
            | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ;
          match segmenter ll aa with
          | (ly', lx'), `Await -> (
              F.epr "`Await -> decode@." ;
              match Uutf.decode dec with
              | `Malformed b ->
                  F.epr
                    "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
                    (String.escaped b) ;
                  _of_string segmenter dec
                    (ly', append_x lx' (of_string (String.escaped b)))
              | (`End | `Await | `Uchar _) as a -> segment a (lx', ly')
              )
          | (ly', lx'), `Uchar c ->
              F.epr "`Uchar U+%04x -> `Await@." (Uchar.to_int c) ;
              segment `Await
                (ly', append_x lx' (node (`Atom (`Uchar c))))
          | (ly', lx'), `End ->
              F.epr "`End ;@." ;
              append_y ly' (lx' (node (`Atom (`Boundary `Text))))
        in
        let r = segment `Await (ly, lx) in
        F.epr "@." ; r

      and of_string str =
        (_of_string
           (fun l s ->
             F.epr "segmenter[of_string] %s -> "
               ( match s with
               | `Await -> "`Await"
               | `End -> "`End"
               | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ;
             (l, s) )
           (Uutf.decoder
              ~nln:(`Readline (Uchar.of_int 0x000A))
              (`String str) )
           (empty_append, empty_append) )
          (node (`Atom (`Boundary `Text)))

      and lines str =
        let rec line_seg u (ly, lx) s =
          F.epr "line_seg %s -> "
            ( match s with
            | `Await -> "`Await"
            | `End -> "`End"
            | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ;
          match Uuseg.add u s with
          | (`End | `Await | `Uchar _) as s' -> ((lx, ly), s')
          | `Boundary when Uuseg.mandatory u ->
              line_seg u
                ( append_y ly (lx (node (`Atom (`Boundary `Line))))
                , empty_append )
                `Await
          | `Boundary ->
              line_seg u
                (ly, append_x lx (node (`Atom (`Hint `Line))))
                `Await in
        (_of_string
           (line_seg (Uuseg.create `Line_break))
           (Uutf.decoder
              ~nln:(`Readline (Uchar.of_int 0x000A))
              (`String str) )
           (empty_append, empty_append) )
          (node (`Atom (`Boundary `Text)))
    end

    let text = Text.lines

    module Draw = struct
      type d = [`X | `Y | `Z]

      let cursor ((i, v) : image) =
        ( I.stack
            (I.paint (Paint.color Color.red)
               ( I.stroke_path (Outline.make ())
               @@ fun t ->
               P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) )
            i
        , v )

      let vcat d a b =
        match d with
        | `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b))
        | `Y -> V2.v (Float.fmax (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
        | `Z ->
            V2.v
              (Float.fmax (V2.x a) (V2.x b))
              (Float.fmax (V2.y a) (V2.y b))

      let pad (p : Pad.t) (img, sv) =
        ( I.transform Transform.(translate ~x:p.l ~y:p.t identity) img
        , V2.v (p.l +. V2.x sv +. p.r) (p.t +. V2.y sv +. p.b) )

      let shift v (img, sv) =
        ( I.transform
            Transform.(
              translate ~x:(Size2.w v) ~y:(Size2.h v) identity)
            img
        , sv )

      let uchar (style : Style.t) (uc : Uchar.t) : image =
        let open Wall_text in
        let f = Style.Font.get style.font in
        let b = Buffer.create 1 in
        let enc = Uutf.encoder `UTF_8 (`Buffer b) in
        let rec encode c =
          match Uutf.encode enc c with
          | `Ok -> ()
          | `Partial -> encode `Await in
        encode (`Uchar uc) ;
        encode `End ;
        let str = Bytes.to_string (Buffer.to_bytes b) in
        let m = Wall_text.Font.text_measure f str in
        let v = Gg.Size2.v m.width (f.size +. f.line_height) in
        ( I.stack
            (I.paint
               (Wall.Paint.color style.bg)
               ( I.fill_path
               @@ fun t ->
               P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) )
            (I.paint
               (Wall.Paint.color style.fg)
               (simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
                  str ) )
        , v )

      let cat d (ai, av) (bi, bv) =
        ( I.stack ai
            (I.transform
               Transform.(
                 match d with
                 | `X -> translate ~x:(Size2.w av) ~y:0. identity
                 | `Y -> translate ~x:0. ~y:(Size2.h av) identity
                 | `Z -> translate ~x:0. ~y:0. identity)
               bi )
        , vcat d av bv )

      let rec atom ?(style = Style.empty) : atom -> image = function
        | `Image i -> i
        | `Uchar uc -> uchar style uc
        | `Boundary _ -> empty_image
        | `Hint _ -> empty_image
        | `Empty -> empty_image

      and attr ?(style = Style.empty) (attr, node) : image =
        match attr with
        | `Style s -> pane ~style:(Style.merge s style) node
        | `Pad p -> pad p (pane ~style node)
        | `Shift s -> shift s (pane ~style node)
        | _ -> pane ~style node

      and join ?(style = Style.empty) (d, a, b) : image =
        cat d (pane ~style a) (pane ~style b)

      and pane ?(style = Style.empty) (node : node) : image =
        match node.t with
        | `Atom a -> atom ~style a
        | `Attr a -> attr ~style a
        | `Join a -> join ~style a
    end

    module Action = struct
      type segment =
        [ `Beginning of boundary
        | `Forward of boundary
        | `Backward of boundary
        | `End of boundary ]

      and t =
        [ `Move of segment
        | `Yank of segment
        | `Kill of segment
        | `Ascend
        | `Descend
        | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]

      and dir =
        [ `Next
        | `Prev
        | `Up
        | `Down
        | `Left
        | `Right
        | `Fwd
        | `Enter
        | `In
        | `Out ]

      open Fmt

      let pp_dir ppf v =
        any
          ( match v with
          | `Next -> "`Next"
          | `Prev -> "`Prev"
          | `Up -> "`Up"
          | `Down -> "`Down"
          | `Left -> "`Left"
          | `Right -> "`Right"
          | `Fwd -> "`Fwd"
          | `Enter -> "`Enter"
          | `In -> "`In"
          | `Out -> "`Out" )
          ppf ()

      let pp_segment ppf v =
        ( match v with
        | `Beginning s -> any "`Beginning " ++ const pp_boundary s
        | `Forward s -> any "`Forward " ++ const pp_boundary s
        | `Backward s -> any "`Backward " ++ const pp_boundary s
        | `End s -> any "`End " ++ const pp_boundary s )
          ppf ()

      let pp_t ppf v =
        ( match v with
        | `Move s -> any "`Move " ++ const pp_segment s
        | `Yank s -> any "`Yank " ++ const pp_segment s
        | `Kill s -> any "`Kill " ++ const pp_segment s
        | `Ascend -> any "`Ascend"
        | `Descend -> any "`Descend"
        | `Custom (s, _) ->
            fun ppf () -> pf ppf "`Custom \"%a\"" string s )
          ppf ()
    end

    let tree_next (n : node) =
      let rec next_right n' =
        match n'.parent with
        | None -> None
        | Some ({t= `Attr _; _} as p) -> next_right p
        | Some {t= `Join (_, a, b); _} when n' == a -> Some b
        | Some ({t= `Join (_, _, b); _} as p) when n' == b ->
            next_right p
        | Some {t= `Join _; _} -> assert false
        | Some {t= `Atom _; _} -> assert false in
      match n.t with
      | `Atom _ -> next_right n
      | `Attr (_, n') -> Some n'
      | `Join (_, a, _) -> Some a

    let tree_prev (n : node) =
      let rec prev_right n' =
        match n'.t with
        | `Attr (_, nn) -> prev_right nn
        | `Join (_, _, b) -> prev_right b
        | `Atom _ -> Some n' in
      match n.parent with
      | None -> None
      | Some {t= `Atom _; _} ->
          assert false
          (* shouldn't happen TODO is there no way to type constrain these? *)
      | Some {t= `Attr _; _} -> n.parent
      | Some {t= `Join (_, a, b); _} when b == n -> prev_right a
      | Some {t= `Join (_, a, _); _} when a == n -> n.parent
      | Some {t= `Join _; _} -> assert false
    (* shouldn't happen *)

    let rec search_forward (n : node) (f : node -> 'a option) :
        'a option =
      match f n with
      | None -> (
        match tree_next n with
        | Some n' -> search_forward n' f
        | None -> None )
      | x -> x

    let rec search_backward (n : node) (f : node -> 'a option) :
        'a option =
      match tree_prev n with
      | None -> None
      | Some p -> (
        match f p with
        | None -> search_backward p f
        | Some x -> Some x )

    let perform_action (a : Action.t) (c : cursor) : node option =
      let r =
        match a with
        | `Move (`Beginning `Char) -> None
        | `Move (`Beginning `Word) ->
            search_backward c.sel (fun n ->
                match n.t with
                | `Atom (`Boundary `Word) -> Some n
                | _ -> None )
        | `Move (`Forward `Char) ->
            search_forward c.sel (fun n ->
                match n.t with
                | _ when n == c.sel -> None
                (* TODO proper detection of root | _ when n == c.root -> Some n *)
                | `Atom (`Uchar _) -> Some n
                | _ -> None )
        | `Move (`Backward `Char) ->
            search_backward c.sel (fun n ->
                match n.t with
                (* TODO proper detection of root | _ when n == c.root -> Some np *)
                | `Atom (`Uchar _) -> Some n
                | _ -> None )
        | `Move _ -> None
        | `Yank _s -> None
        | `Kill _s -> None
        | `Descend -> Some (sub c.sel)
        | `Ascend -> c.sel.parent
        | `Custom _s -> None in
      match r with
      | Some n ->
          c.sel <- n ;
          Some n
      | None -> None

    type event_status = [`Handled | `Event of Event.t]

    let textedit_bindings =
      let open Key.Bind in
      empty
      |> add [([Ctrl], C 'f')] [`Move (`Forward `Char)]
      |> add [([Ctrl], C 'b')] [`Move (`Backward `Char)]
      |> add [([Meta], C 'f')] [`Move (`Forward `Word)]
      |> add [([Meta], C 'b')] [`Move (`Backward `Word)]
      |> add
           [([Ctrl], C 'c'); ([Ctrl], C 'n')]
           [`Move (`Forward `Phrase)]
      |> add
           [([Ctrl], C 'c'); ([Ctrl], C 'p')]
           [`Move (`Backward `Phrase)]
      |> add [([Ctrl], C 'n')] [`Move (`Forward `Line)]
      |> add [([Ctrl], C 'p')] [`Move (`Backward `Line)]
      |> add [([Ctrl], C 'v')] [`Move (`Forward `Page)]
      |> add [([Meta], C 'v')] [`Move (`Backward `Page)]
      |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)]
      |> add [([Ctrl], C 'e')] [`Move (`End `Line)]
      |> add [([Ctrl], C 'k')] [`Kill (`End `Line)]
      |> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)]
      |> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
      |> add
           [([Ctrl], C 'x'); ([], U `Backspace)]
           [`Kill (`Backward `Phrase)]
      |> add [([Ctrl], C 'q')] [`Ascend]
      |> add [([Ctrl], C 'e')] [`Descend]

    let join_search_forward n =
      search_forward n (fun v ->
          match v.t with `Join _ -> Some v | _ -> None )

    let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))

    let textedit_handler ?(bindings = textedit_bindings) (n : node) =
      let bind = Key.Bind.init bindings in
      let c =
        { root= n
        ; sel=
            insert_attr cursor_attr
              ( match join_search_forward n with
              | Some n -> n
              | None -> n ) } in
      Format.pp_set_max_boxes F.stderr 64 ;
      (*full screen fynn  *)
      Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ;
      node
        (`Attr
          ( `Handler
              (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
                match Key.Bind.resolve_events bind [e] with
                | x :: _ ->
                    c.sel <- remove_attr c.sel ;
                    F.epr
                      "textedit_handler c.root=@.@[%a@]@.c.sel=%a@."
                      pp_node_structure c.root pp_node c.sel ;
                    ( match perform_action x c with
                    | Some _ ->
                        F.epr
                          "textedit_handler perform_action @[%a@] \
                           success@."
                          Action.pp_t x
                    | None ->
                        F.epr
                          "textedit_handler perform_action @[%a@] \
                           FAILURE@."
                          Action.pp_t x ) ;
                    c.sel <- insert_attr cursor_attr c.sel ;
                    Lwt.return_none
                | [] -> Lwt.return_some e )
          , n ) )

    let handler_of_node (n : node) : handler option =
      search_forward n (fun n ->
          match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )

    let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
      match handler_of_node n with
      | Some f -> (
          f n ev
          >>= function
          | Some ev -> Lwt.return (`Event ev)
          | None -> Lwt.return `Handled )
      | None -> Lwt.return (`Event ev)

    let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t =
      let rq = Lwd.make_release_queue () in
      let root = Lwd.observe t in
      Lwt.return (fun ev ->
          let r = Lwd.sample rq root in
          (* F.epr "Draw.pane: %a@." pp_ui r ; *)
          Lwt_list.iter_s
            (fun e ->
              handle_event r e
              >>= fun h ->
              ( match h with
              | `Handled -> F.epr "Handled %s@." (Event.to_string e)
              | `Event _e ->
                  (* F.epr "Unhandled event: %s@."
                     (Event.to_string _e)*)
                  () ) ;
              Lwt.return_unit )
            ev
          >|= fun () -> Draw.pane r )

    let test =
      panel
        (Lwd.pure
           (textedit_handler
              (style Style.dark
                 (* (join_y
                     (join_y
                        (Text.of_string
                           "-- welcome to my land of idiocy ---" )
                        ( ( Text.of_string "hello bitch"
                          ^^ Text.of_string "!\n sup daddy" )
                        ^/^ (text "hello bitch" ^^ text "!\n sup daddy")
                        ^/^ text "hello bitch" ^/^ text "!\n sup daddy"
                        ) ) *)
                 (Text.of_string "123")
                 (* )p *) ) ) )
  end
end

module Toplevel = struct
  type t =
    {mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer}

  let init () =
    let sob = Format.make_symbolic_output_buffer () in
    Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ;
    {eval= !Topinf.eval; res= sob}

  let eval t str =
    let ppf = Format.formatter_of_symbolic_output_buffer t.res in
    Topinf.ppf := ppf ;
    ignore (Format.flush_symbolic_output_buffer t.res) ;
    try
      t.eval ppf (str ^ ";;") ;
      (*HACK to prevent getting stuck in parser*)
      let b = Buffer.create 69 in
      Panel.(
        format_symbolic_output_buffer
          (Format.formatter_of_buffer b)
          t.res)
    with e ->
      F.pf ppf "Exception in pane_top//eval@." ;
      Location.report_exception ppf e ;
      F.epr "Exception in pane_top//eval@."

  let result_sob t = t.res
end

module Store = struct
  (* storeview shows items of the selected level *)

  type storeview =
    { store: Istore.t
    ; mutable view: Istore.key
    ; mutable selection: Istore.key
    ; mutable editmode: bool
    ; sob: Format.symbolic_output_buffer }

  let make_storeview ?(path = []) storepath branch =
    Istore.Repo.v (Irmin_git.config storepath)
    >>= fun repo ->
    Istore.of_branch repo branch
    >>= fun store ->
    let view = Istore.Key.v path in
    Istore.list store view
    >>= fun viewlist ->
    Lwt.return
      { store
      ; view
      ; selection= Istore.Key.v [fst (List.hd viewlist)]
      ; editmode= false
      ; sob= Format.make_symbolic_output_buffer () }

  let directives (top : Toplevel.t) sv =
    let dir_use_key key_lid =
      (* TODO: currently causes a segfault :( *)
      let key_obj =
        try
          match
            Env.find_value_by_name key_lid !Topinf.toplevel_env
          with
          | path, _desc ->
              Topinf.eval_value_path !Topinf.toplevel_env path
          | exception Not_found ->
              F.epr "Unbound value %a.@." Printtyp.longident key_lid ;
              raise Exit
        with Exit -> Obj.repr ["nofile"] in
      let key = Obj.obj key_obj in
      let contents =
        Lwt_main.run
          ( Istore.kind sv.store key
          >>= function
          | Some a -> (
            match a with
            | `Contents -> Istore.get sv.store key
            | `Node ->
                Lwt.return "\"use_key on Node not implemented yet\"" )
          | None -> Lwt.return "Invalid Selection..." ) in
      Toplevel.eval top contents in
    Topinf.add_directive "use_key" (Directive_ident dir_use_key)
      { section= "Console Store"
      ; doc=
          "Read, compile and execute source phrases from the given \
           store key." }

  let navigate sv action =
    let rec findi value = function
      | [] -> 0
      | a :: b -> (if a = value then -1 else findi value b) + 1 in
    fun () ->
      Istore.get_tree sv.store sv.view
      >>= fun top ->
      match Istore.Key.rdecons sv.selection with
      | Some (ppath, step) ->
          Istore.Tree.list top ppath
          >>= fun neighbors ->
          let steplist = fst (List.split neighbors) in
          let stepi = findi step steplist in
          Istore.Tree.list (snd (List.nth neighbors stepi)) []
          >>= fun subtreelist ->
          Lwt.return
            ( match action with
            | `Next ->
                let stepi = findi step steplist in
                if List.length steplist - 1 > stepi then
                  sv.selection <-
                    Istore.Key.rcons ppath
                      (List.nth steplist (stepi + 1))
            | `Prev ->
                if stepi > 0 then
                  sv.selection <-
                    Istore.Key.rcons ppath
                      (List.nth steplist (stepi - 1))
            | `Sub ->
                if List.length subtreelist > 0 then
                  sv.selection <-
                    sv.selection @ [fst (List.hd subtreelist)]
            | `Sup ->
                if List.length ppath > 0 then sv.selection <- ppath )
      | None -> Lwt.return_unit

  let editor ?(branch = "current") storepath : Panel.t Lwt.t =
    make_storeview storepath branch
    >>= fun sv ->
    let top = Toplevel.init () in
    let modalstate = Panel.Modal.make () in
    let te = Panel.Textedit.make "" () in
    let save store path content =
      Lwt.async (fun () ->
          Istore.set_exn store
            ~info:(Irmin_unix.info "editor-save")
            path content ) in
    let editbinds =
      let open Key.Bind in
      add
        [([Ctrl], C 'c')]
        [ Custom
            (fun () ->
              sv.editmode <- not sv.editmode ;
              save sv.store
                (sv.view @ sv.selection)
                (Panel.Textedit.contents te) ) ]
      @@ add
           [([Ctrl], C 's')]
           [ Custom
               (fun () ->
                 save sv.store
                   (sv.view @ sv.selection)
                   (Panel.Textedit.contents te) ) ]
      @@ add
           [([Ctrl], C 'x'); ([], C 'x')]
           [ Custom
               (fun () ->
                 Toplevel.eval top (Panel.Textedit.contents te) ) ]
           (Panel.Textedit.bindings te) in
    te.keybind.bindings <- editbinds ;
    let is_node path =
      Istore.get_tree sv.store sv.view
      >>= fun t ->
      Istore.Tree.kind t path
      >>= function
      | Some `Node -> Lwt.return_true | _ -> Lwt.return_false in
    let update_storeview () =
      ignore (Format.flush_symbolic_output_buffer sv.sob) ;
      let pp = Format.formatter_of_symbolic_output_buffer sv.sob in
      let rec draw_levels ?(indent = 0) (sel : Istore.key)
          (tree : Istore.tree) : unit Lwt.t =
        Istore.Tree.list tree []
        >>= Lwt_list.iteri_s (fun _i (step, node) ->
                Format.pp_open_box pp indent ;
                if sel = [step] then (
                  Format.pp_open_stag pp
                    (Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
                  F.pf pp "@," ;
                  Format.pp_close_stag pp () ) ;
                Istore.Tree.kind node []
                >>= fun k ->
                ( match k with
                | Some `Contents ->
                    F.pf pp "- %s@." step ; Lwt.return_unit
                | Some `Node ->
                    F.pf pp "> %s@." step ;
                    let subsel =
                      match Istore.Key.decons sel with
                      | Some (_tstep, subkey) -> subkey
                      | None -> [] in
                    Format.pp_open_vbox pp 0 ;
                    draw_levels ~indent:(indent + 1) subsel node
                    >>= fun () ->
                    Format.pp_close_box pp () ;
                    Lwt.return_unit
                | None -> F.pf pp "ERROR: None" ; Lwt.return_unit )
                >>= fun () ->
                Format.pp_close_box pp () ;
                Lwt.return_unit ) in
      Istore.get_tree sv.store sv.view >>= draw_levels sv.selection
    in
    let update_textedit () =
      Panel.Textedit.clear te ;
      Istore.get_tree sv.store sv.view
      >>= fun t ->
      Istore.Tree.kind t sv.selection
      >>= function
      | Some `Contents ->
          Istore.Tree.get t sv.selection
          >>= fun content ->
          Panel.Textedit.insert te content ;
          Lwt.return_unit
      | Some `Node ->
          Panel.Textedit.insert te "Node..." ;
          Lwt.return_unit
      | None -> Lwt.return_unit in
    let navbinds =
      let open Key.Bind in
      let new_contents name content =
        Lwt.async (fun () ->
            let s =
              match Istore.Key.rdecons sv.selection with
              | Some (t, _) -> t
              | None -> Istore.Key.empty in
            Istore.get_tree sv.store (sv.view @ s)
            >>= fun tree ->
            Istore.Tree.add tree name content
            >>= fun newtree ->
            Istore.set_tree_exn
              ~info:(Irmin_unix.info "new Contents")
              sv.store sv.view newtree ) in
      add [([], C 'n')] [CustomLwt (navigate sv `Next)]
      @@ add [([], C 'p')] [CustomLwt (navigate sv `Prev)]
      @@ add [([], C 'w')] [CustomLwt (navigate sv `Prev)]
      @@ add [([], C 's')] [CustomLwt (navigate sv `Next)]
      @@ add [([], C 'd')] [CustomLwt (navigate sv `Sub)]
      @@ add [([], C 'a')] [CustomLwt (navigate sv `Sup)]
      @@ add
           [([], C 'e')] (* enter edit mode *)
           [ Custom
               (fun () ->
                 Lwt.async (fun () ->
                     is_node sv.selection
                     >>= fun nb ->
                     if not nb then sv.editmode <- not sv.editmode ;
                     Lwt.return_unit ) ) ]
      @@ add
           [([], C 'f')] (* find: enter path in modal *)
           [Custom (fun () -> ())]
      @@ add
           [([], C 'c')] (* contents: create new contents node *)
           [ Custom
               (fun () ->
                 Panel.Modal.start ~prompt:"Contents name > "
                   modalstate "" (fun name ->
                     new_contents (Istore.Key.v [name]) "" ) ) ]
      @@ add
           [([], C 't')] (* tree: create new subtree *)
           [ Custom
               (fun () ->
                 Panel.Modal.start ~prompt:"Node name > " modalstate
                   "" (fun nodename ->
                     Panel.Modal.start
                       ~prompt:"Initial Contents name > " modalstate
                       "" (fun contentsname ->
                         new_contents
                           (Istore.Key.v [nodename; contentsname])
                           "" ) ) ) ]
      @@ add
           [([], C 'r')] (* remove contents/node *)
           [ CustomLwt
               (fun () ->
                 let selection = sv.selection in
                 navigate sv `Next ()
                 >>= fun () ->
                 Istore.get_tree sv.store sv.view
                 >>= fun tree ->
                 Istore.Tree.remove tree selection
                 >>= fun newtree ->
                 Istore.set_tree_exn
                   ~info:(Irmin_unix.info "remove Contents/Node")
                   sv.store sv.view newtree ) ]
      @@ add
           [([], C 'x')] (* execute contents/node *)
           [ Custom
               (fun () ->
                 Toplevel.eval top (Panel.Textedit.contents te) ) ]
           empty in
    let bindstate = Key.Bind.init navbinds in
    Lwt.return
      Panel.
        { act=
            (fun panel events ->
              ( if
                (not sv.editmode)
                && not (Panel.Modal.is_active modalstate)
              then
                Key.Bind.process bindstate events
                >>= fun () ->
                Lwt.join [update_storeview (); update_textedit ()]
              else Lwt.return_unit )
              >>= fun () ->
              Panel.vbox panel.subpanels
              >>= fun p -> p.act panel events )
        ; subpanels=
            [ Panel.filter_events
                (fun ev ->
                  if Panel.Modal.is_active modalstate then ev else []
                  )
                (Panel.Modal.panel modalstate)
            ; Panel.hbox
                [ Panel.prettyprint (fun pp ->
                      Panel.format_symbolic_output_buffer pp sv.sob )
                ; Panel.vbox
                    [ Panel.filter_events
                        (fun ev -> if sv.editmode then ev else [])
                        (Panel.Textedit.panel te)
                    ; Panel.prettyprint (fun pp ->
                          Format.pp_open_hovbox pp 0 ;
                          Panel.format_symbolic_output_buffer pp
                            (Toplevel.result_sob top) ;
                          Format.pp_close_box pp () ;
                          F.flush pp () ) ] ]
            ; Panel.Textedit.bindingstate bindstate
            ; Panel.prettyprint (fun pp ->
                  Format.fprintf pp "sv.editmode = %b @." sv.editmode )
            ]
        ; tag= "store-editor" }
end

let std_actor (root_panel : Panel.t Lwt.t) =
  Panel.actor
    (Panel.obox
       [ Panel.draw (fun (s : Display.state) ->
             (s, Display.fill_box (Display.gray 0.125) s.box) )
       ; root_panel ] )

let image_pane (f : (Event.events -> Panel.Ui.image Lwt.t) Lwt.t) :
    Panel.t Lwt.t =
  f (* do the initialization (lol what?) *)
  >>= fun f ->
  Lwt.return
    Panel.
      { act=
          (fun _ events ->
            f events
            >>= fun i ->
            Lwt.return (fun s ->
                (s, (Gg.Box2.of_pts Gg.V2.zero (snd i), fst i)) ) )
      ; subpanels= []
      ; tag= "irc" }

let root_actor =
  ref
    (std_actor
       (image_pane Panel.Ui.test) (*Store.editor "../rootstore"*) )

let start () =
  Display.(
    run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ())

(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)

(* FUTURE: (thinking now this should be based on react for that sweet incremental compuation)

   type panetree
   type eventree
   type imagetree

   Display.run should be:
   Init: setup initial panetree and compute eventree and imagetree from it.last_actions
   New events trigger parsing the eventree, the results of which update the imagetree
      which is then parsed and displayed. *)
