Source file handlers.ml

open! Oxbow_core
open! Oxbow_state
open! Oxbow_ops

let registry : Wayland.Registry.t option ref = ref None

let with_registry f =
  match !registry with
  | None -> Log.err @@ fun m -> m "no registry defined!!!"
  | Some r -> f r
;;

let window_of proxy =
  match Wayland.Proxy.user_data proxy with
  | Types.User_data.Window w -> Some w
  | _ -> None
;;

let output_of proxy =
  match Wayland.Proxy.user_data proxy with
  | Types.User_data.Output o -> Some o
  | _ -> None
;;

let seat_of proxy =
  match Wayland.Proxy.user_data proxy with
  | Types.User_data.Seat s -> Some s
  | _ -> None
;;

let on_finished (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm -> Lifecycle.notify_finished wm
;;

let on_manage_start proxy (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | Some wm -> Cycle.manage wm proxy
  | None -> River.Window_management.River_window_manager_v1.manage_finish proxy
;;

let on_output _ river_output (wm_box : Wm.t Box.t) =
  with_registry
  @@ fun registry ->
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let output_box : Output.t Box.t = { body = None } in
    let layer_shell =
      River.Layer_shell.River_layer_shell_v1.get_output
        wm.river_lsh_v1
        ~output:river_output
      @@ object
           inherit [_] River.Obj.Layer_shell.Client.output

           method on_non_exclusive_area _ ~x ~y ~width ~height =
             Exceptions.guard "on_non_exclusive_area"
             @@ fun () ->
             match output_box.body with
             | Some o ->
               Output.set_usable o
               @@ Int32.
                    { x = to_int x; y = to_int y; w = to_int width; h = to_int height }
             | None -> ()
         end
    in
    let output : Output.t =
      { obj = river_output
      ; layer_shell
      ; lifecycle = Active
      ; is_captured = false
      ; name = None
      ; labels = []
      ; geom = { x = 0l; y = 0l; w = 0l; h = 0l }
      ; usable = { x = 0; y = 0; w = 0; h = 0 }
      ; tags = { selected = Tag.Set.singleton 1; previous = Tag.Set.singleton 1 }
      ; overview =
          { offset = 0
          ; enabled = false
          ; gaps = wm.config.default_overview_gaps
          ; head = None
          }
      ; tag_data =
          Tag.Table.make (fun () -> Config.copy_tag_data wm.config.default_tag_config)
      ; focus_stack = []
      ; wm_stack = []
      }
    in
    let sync_usable () =
      if output.usable.w = 0 || output.usable.h = 0
      then Rect.to_int output.geom |> Output.set_usable output
    in
    Box.fill output_box output;
    Wayland.Proxy.Handler.attach
      river_output
      object
        inherit [_] River.Obj.Window_management.Client.output
        method! user_data = Types.User_data.Output output
        method on_removed _ = Output.set_lifecycle output Removed

        method on_wl_output _ ~name =
          Exceptions.guard "on_wl_output"
          @@ fun () ->
          let _ =
            Wayland.Wayland_client.Wl_registry.bind
              (Wayland.Registry.wl_registry registry)
              ~name
            @@ ( object
                   inherit [_] Wayland.Wayland_client.Wl_output.v4

                   method on_name _ ~name =
                     Output.set_name output @@ Some name;
                     List.iter (fun w -> Window.rehome w name) wm.windows

                   method on_scale _ ~factor:_ = ()
                   method on_mode _ ~flags:_ ~width:_ ~height:_ ~refresh:_ = ()

                   method on_geometry
                     _
                     ~x:_
                     ~y:_
                     ~physical_width:_
                     ~physical_height:_
                     ~subpixel:_
                     ~make:_
                     ~model:_
                     ~transform:_ =
                     ()

                   method on_done _ = ()
                   method on_description _ ~description:_ = ()
                 end
               , 4l )
          in
          ()

        method on_position _ ~x ~y =
          Exceptions.guard "on_position"
          @@ fun () ->
          Output.set_geom output { x; y; w = output.geom.w; h = output.geom.h };
          sync_usable ()

        method on_dimensions _ ~width ~height =
          Exceptions.guard "on_dimensions"
          @@ fun () ->
          Output.set_geom
            output
            { x = output.geom.x; y = output.geom.y; w = width; h = height };
          sync_usable ()

        method on_capture_sessions _ ~count =
          Exceptions.guard "on_capture_sessions"
          @@ fun () -> Output.set_is_captured output (count > 0l)
      end;
    Wm.set_outputs wm (output :: wm.outputs);
    List.iter (Wm.ensure_seat_output wm) wm.seats
;;

let on_render_start proxy (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | Some wm -> Cycle.render wm proxy
  | None -> River.Window_management.River_window_manager_v1.render_finish proxy
;;

let on_seat _ river_seat (wm_box : Wm.t Box.t) =
  with_registry
  @@ fun registry ->
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let seat_box : Seat.t Box.t = { body = None } in
    let layer_shell =
      River.Layer_shell.River_layer_shell_v1.get_seat wm.river_lsh_v1 ~seat:river_seat
      @@ object
           inherit [_] River.Obj.Layer_shell.Client.seat

           method on_focus_none _ =
             Exceptions.guard "on_focus_none"
             @@ fun () -> Option.iter (fun s -> Seat.set_layer_focus s None) seat_box.body

           method on_focus_non_exclusive _ =
             Exceptions.guard "on_focus_non_exclusive"
             @@ fun () ->
             Option.iter
               (fun s -> Seat.set_layer_focus s @@ Some Non_exclusive)
               seat_box.body

           method on_focus_exclusive _ =
             Exceptions.guard "on_focus_exclusive"
             @@ fun () ->
             Option.iter (fun s -> Seat.set_layer_focus s @@ Some Exclusive) seat_box.body
         end
    in
    let seat : Seat.t =
      { obj = river_seat
      ; layer_shell
      ; xkb_seat =
          Emit.create_xkb_bindings_seat
            wm.river_xkb_v1
            ~seat:river_seat
            ~on_modifiers_update:(fun ~old:_ ~new_ ->
              Option.iter
                (fun (s : Seat.t) ->
                   if s.overview_watch <> 0l && Int32.logand new_ s.overview_watch = 0l
                   then (
                     s.overview_watch <- 0l;
                     Option.iter Arrange.exit_overview s.output))
                seat_box.body)
      ; overview_watch = 0l
      ; watch_sent = 0l
      ; lifecycle = New
      ; name = None
      ; output = None
      ; focus_cleared = false
      ; position = { x = 0l; y = 0l }
      ; layer_focus = None
      ; mode = Mode.normal
      ; xkb_bindings = []
      ; pointer_bindings = []
      ; pending_requests = Queue.create ()
      ; hovered = None
      ; interacted = None
      ; warp_request = No_request
      ; focus_state = Idle
      ; cursor_target = None
      ; op = None
      }
    in
    Box.fill seat_box seat;
    Wayland.Proxy.Handler.attach
      river_seat
      object
        inherit [_] River.Obj.Window_management.Client.seat
        method! user_data = Types.User_data.Seat seat
        method on_removed _ = Seat.set_lifecycle seat Closing

        method on_pointer_enter _ ~window =
          Exceptions.guard "on_pointer_enter"
          @@ fun () ->
          match window_of window with
          | Some w -> Seat.set_hovered seat @@ Some w
          | None -> ()

        method on_pointer_leave _ = Seat.set_hovered seat None

        method on_window_interaction _ ~window =
          Exceptions.guard "on_window_interaction"
          @@ fun () ->
          match window_of window with
          | Some w -> Seat.set_interacted seat @@ Some w
          | None -> ()

        method on_op_delta _ ~dx ~dy = Seat.set_op_delta seat dx dy

        method on_op_release _ =
          Exceptions.guard "on_op_release" @@ fun () -> Seat.release_op seat

        method on_wl_seat _ ~name =
          let _ =
            Wayland.Wayland_client.Wl_registry.bind
              (Wayland.Registry.wl_registry registry)
              ~name
            @@ ( object
                   inherit [_] Wayland.Wayland_client.Wl_seat.v9
                   method on_name _ ~name = Seat.set_name seat @@ Some name
                   method on_capabilities _ ~capabilities:_ = ()
                 end
               , 9l )
          in
          ()

        method on_shell_surface_interaction _ ~shell_surface:_ = ()

        method on_pointer_position _ ~x ~y =
          Exceptions.guard "on_pointer_position"
          @@ fun () -> Pointer.handle_position wm seat (x, y)
      end;
    Wm.set_seats wm (seat :: wm.seats);
    if Option.is_none wm.primary_seat then Wm.set_primary_seat wm @@ Some seat;
    Wm.ensure_seat_output wm seat
;;

let on_session_locked _proxy (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    Wm.set_session_locked wm true;
    Schedule.manage ()
;;

let on_session_unlocked _proxy (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    Wm.set_session_locked wm false;
    Schedule.manage ()
;;

let on_unavailable _proxy =
  Printf.eprintf "error: another window manager is already running\n";
  raise Exceptions.Unavailable
;;

let on_window _ river_window (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let scroll_width =
      match Wm.default_output wm with
      | None -> wm.config.default_tag_config.scrolling.default_width
      | Some o -> (Output.to_tag_data o).scrolling.default_width
    in
    let output = Wm.default_output wm in
    let window = Window.create output scroll_width river_window in
    Wayland.Proxy.Handler.attach
      river_window
      object
        inherit [_] River.Obj.Window_management.Client.window
        method! user_data = Types.User_data.Window window
        method on_closed _ = Window.set_lifecycle window Closing

        method on_dimensions _ ~width ~height =
          Exceptions.guard "on_dimensions"
          @@ fun () ->
          let consumed = Window.consume_in_flight window ~width ~height in
          if window.geom.w = width && window.geom.h = height
          then Window.set_defense window Idle
          else if not consumed
          then
            if Output.arranges window
            then (
              Log.warn (fun m ->
                m
                  "%s client changed size while tiled"
                  (Option.value ~default:"?" window.app_id));
              Window.reject_dimensions window ~width ~height)
            else Window.queue_request window @@ Dimensions { width; height }

        method on_unreliable_pid _ ~unreliable_pid =
          Window.set_unreliable_pid window @@ Some unreliable_pid

        method on_parent _ ~parent =
          Exceptions.guard "on_parent"
          @@ fun () ->
          let set_parent p = Window.set_parent window ~parent:p in
          Option.bind parent window_of |> set_parent

        method on_title _ ~title = Window.set_title window title

        method on_identifier _ ~identifier =
          Window.set_identifier window @@ Some identifier

        method on_dimensions_hint _ ~min_width ~min_height ~max_width ~max_height =
          Exceptions.guard "on_dimensions_hint"
          @@ fun () ->
          let hint v = if v > 0l then Some v else None in
          let hints : _ Window.Size_hints.t =
            { min_w = hint min_width
            ; max_w = hint max_width
            ; min_h = hint min_height
            ; max_h = hint max_height
            }
          in
          let is_fixed =
            match hints with
            | { min_w = Some a; max_w = Some b; min_h = Some c; max_h = Some d } ->
              a = b && c = d
            | _ -> false
          in
          Window.set_is_fixed window is_fixed;
          Window.set_size_hints window hints;
          if is_fixed && window.presentation = Tiled && window.lifecycle = Active
          then (
            Window.float window;
            Schedule.manage ())

        method on_decoration_hint _ ~hint =
          Exceptions.guard "on_decoration_hint"
          @@ fun () ->
          Window.Decoration_hint.(
            Window.set_decoration_hint window
            @@ Some
                 (match hint with
                  | Only_supports_csd -> Only_csd
                  | Prefers_csd -> Prefer_csd
                  | Prefers_ssd -> Prefer_ssd
                  | No_preference -> No_preference))

        method on_app_id _ ~app_id = Window.set_app_id window app_id

        method on_pointer_move_requested _ ~seat =
          Exceptions.guard "on_pointer_move_requested"
          @@ fun () ->
          match seat_of seat with
          | Some s -> Window.queue_request window @@ Move { seat = s }
          | None -> ()

        method on_pointer_resize_requested _ ~seat ~edges =
          Exceptions.guard "on_pointer_resize_requested"
          @@ fun () ->
          match seat_of seat with
          | Some s -> Window.queue_request window @@ Resize { seat = s; edges }
          | None -> ()

        method on_maximize_requested _ = ()
        method on_unmaximize_requested _ = ()

        method on_fullscreen_requested _ ~output =
          Exceptions.guard "on_fullscreen_requested"
          @@ fun () ->
          let queue_request o =
            Window.queue_request window @@ Fullscreen { output = o }
          in
          Option.bind output output_of |> queue_request

        method on_exit_fullscreen_requested _ =
          Window.queue_request window Exit_fullscreen

        method on_presentation_hint _ ~hint =
          Exceptions.guard "on_presentation_hint"
          @@ fun () -> Window.set_presentation_hint window @@ Some hint

        method on_show_window_menu_requested _ ~x:_ ~y:_ = ()
        method on_minimize_requested _ = ()

        method on_capture_sessions _ ~count =
          Exceptions.guard "on_capture_sessions"
          @@ fun () -> Window.set_is_captured window (count > 0l)
      end;
    Wm.set_windows wm (window :: wm.windows)
;;

let on_input_device proxy (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let device_kind : River.Proto.Input.Management.River_input_device_v1.Type.t option ref
      =
      ref None
    in
    let device_name = ref "" in
    let device_box : Input_device.t Box.t = { body = None } in
    let resolve_device device =
      Box.fill device_box device;
      Wm.add_input_device wm device
    in
    let make role =
      let device =
        Input_device.
          { obj = proxy; name = !device_name; role; lifecycle = New; libinput = None }
      in
      resolve_device device;
      device
    in
    Wayland.Proxy.Handler.attach proxy
    @@ object
         inherit [_] River.Obj.Input.Management.Client.device
         method on_type _ ~type_ = device_kind := Some type_
         method on_name _ ~name = device_name := name

         method on_done _ =
           Exceptions.guard "on_done"
           @@ fun () ->
           if Option.is_none device_box.body
           then (
             match !device_kind with
             | Some Keyboard ->
               let keyboard = Wm.find_xkb_stash_opt wm @@ Wayland.Proxy.id proxy in
               let device = make (Keyboard { keyboard }) in
               Emit.set_repeat_info
                 proxy
                 ~rate:(Int32.of_int wm.config.repeat_rate)
                 ~delay:(Int32.of_int wm.config.repeat_delay);
               Option.iter (Input_device.set_keyboard wm device) keyboard
             | Some Pointer -> ignore @@ make (Pointer { class_ = Mouse })
             | Some Touch -> ignore @@ make Touch
             | Some Tablet -> ignore @@ make Tablet
             | None -> Log.err @@ fun m -> m "input device sent 'done' without a type")

         method on_removed _ =
           Exceptions.guard "on_removed"
           @@ fun () ->
           match device_box.body with
           | Some device -> Wm.remove_input_device wm device
           | None -> Emit.destroy_input_device proxy
       end
;;

let on_libinput_device device (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let device_box : Input_device.t Box.t = { body = None } in
    Wayland.Proxy.Handler.attach device
    @@ object
         inherit [_] River.Obj.Input.Config.Client.device

         method on_input_device _ ~device:paired =
           Exceptions.guard "on_input_device"
           @@ fun () ->
           match Wm.find_input_device_opt wm (Wayland.Proxy.id paired) with
           | None -> Log.warn @@ fun m -> m "input device unknown"
           | Some d ->
             Box.fill device_box d;
             d.libinput <- Some device

         method on_tap_support _ ~finger_count =
           Exceptions.guard "on_tap_support"
           @@ fun () ->
           Option.iter
             (fun (d : Input_device.t) ->
                if finger_count > 0l
                then (
                  match d.role with
                  | Pointer p -> p.class_ <- Touchpad
                  | r ->
                    Log.err
                    @@ fun m ->
                    m
                      "got tap support on a non-pointer device: %s"
                      (Input_device.role_to_string r)))
             device_box.body

         method on_done _ =
           Exceptions.guard "on_done"
           @@ fun () ->
           Option.iter
             (fun (d : Input_device.t) ->
                if d.lifecycle = New
                then (
                  Input_device.set_lifecycle d Active;
                  Input_rules.apply_rules_to wm d))
             device_box.body

         method on_removed _ =
           Exceptions.guard "on_removed"
           @@ fun () ->
           Option.iter
             (fun (d : Input_device.t) ->
                d.libinput <- None;
                Emit.destroy_libinput_device device)
             device_box.body

         method on_three_finger_drag_support _ ~finger_count:_ = ()
         method on_three_finger_drag_default _ ~state:_ = ()
         method on_three_finger_drag_current _ ~state:_ = ()
         method on_tap_default _ ~state:_ = ()
         method on_tap_current _ ~state:_ = ()
         method on_tap_button_map_default _ ~button_map:_ = ()
         method on_tap_button_map_current _ ~button_map:_ = ()
         method on_send_events_support _ ~modes:_ = ()
         method on_send_events_default _ ~mode:_ = ()
         method on_send_events_current _ ~mode:_ = ()
         method on_scroll_method_support _ ~methods:_ = ()
         method on_scroll_method_default _ ~method_:_ = ()
         method on_scroll_method_current _ ~method_:_ = ()
         method on_scroll_button_lock_default _ ~state:_ = ()
         method on_scroll_button_lock_current _ ~state:_ = ()
         method on_scroll_button_default _ ~button:_ = ()
         method on_scroll_button_current _ ~button:_ = ()
         method on_rotation_support _ ~supported:_ = ()
         method on_rotation_default _ ~angle:_ = ()
         method on_rotation_current _ ~angle:_ = ()
         method on_natural_scroll_support _ ~supported:_ = ()
         method on_natural_scroll_default _ ~state:_ = ()
         method on_natural_scroll_current _ ~state:_ = ()
         method on_middle_emulation_support _ ~supported:_ = ()
         method on_middle_emulation_default _ ~state:_ = ()
         method on_middle_emulation_current _ ~state:_ = ()
         method on_left_handed_support _ ~supported:_ = ()
         method on_left_handed_default _ ~state:_ = ()
         method on_left_handed_current _ ~state:_ = ()
         method on_dwtp_support _ ~supported:_ = ()
         method on_dwtp_default _ ~state:_ = ()
         method on_dwtp_current _ ~state:_ = ()
         method on_dwt_support _ ~supported:_ = ()
         method on_dwt_default _ ~state:_ = ()
         method on_dwt_current _ ~state:_ = ()
         method on_drag_lock_default _ ~state:_ = ()
         method on_drag_lock_current _ ~state:_ = ()
         method on_drag_default _ ~state:_ = ()
         method on_drag_current _ ~state:_ = ()
         method on_clickfinger_button_map_default _ ~button_map:_ = ()
         method on_clickfinger_button_map_current _ ~button_map:_ = ()
         method on_click_method_support _ ~methods:_ = ()
         method on_click_method_default _ ~method_:_ = ()
         method on_click_method_current _ ~method_:_ = ()
         method on_calibration_matrix_support _ ~supported:_ = ()
         method on_calibration_matrix_default _ ~matrix:_ = ()
         method on_calibration_matrix_current _ ~matrix:_ = ()
         method on_accel_speed_default _ ~speed:_ = ()
         method on_accel_speed_current _ ~speed:_ = ()
         method on_accel_profiles_support _ ~profiles:_ = ()
         method on_accel_profile_default _ ~profile:_ = ()
         method on_accel_profile_current _ ~profile:_ = ()
       end
;;

let on_xkb_keyboard keyboard (wm_box : Wm.t Box.t) =
  match wm_box.body with
  | None -> ()
  | Some wm ->
    let device_ref : int32 option ref = ref None in
    Wayland.Proxy.Handler.attach keyboard
    @@ object
         inherit [_] River.Obj.Xkb.Config.Client.keyboard

         method on_input_device _ ~device =
           Exceptions.guard "on_input_device"
           @@ fun () ->
           let d = Wayland.Proxy.id device in
           device_ref := Some d;
           match Wm.find_input_device_opt wm d with
           | None ->
             Wm.add_xkb_stash wm d keyboard;
             Log.warn @@ fun m -> m "xkb keyboard for unknown device"
           | Some entry -> Input_device.set_keyboard wm entry keyboard

         method on_removed _ =
           Exceptions.guard "on_removed"
           @@ fun () ->
           Emit.destroy_xkb_keyboard keyboard;
           match !device_ref with
           | Some device ->
             (match Wm.find_input_device_opt wm device with
              | Some d -> Input_device.clear_device d keyboard
              | None -> Wm.remove_xkb_stash wm device)
           | None -> ()

         method on_numlock_enabled _ = ()
         method on_numlock_disabled _ = ()
         method on_layout _ ~index:_ ~name:_ = ()
         method on_done _ = ()
         method on_capslock_enabled _ = ()
         method on_capslock_disabled _ = ()
       end
;;