Source file container.ml

(** Container widget. *)

open Misc
open Tsdl
open Widget

(** A container child, parametrized by the type of
  the associated data. *)
type 'a child = {
    widget : Widget.widget ;
    mutable data : 'a ;
  }

(** A container widget is a widget which can contain a list
of widgets.
Each widget can be associated to additional data ['a],
so each container has type [['a] container].
This class must be inherited (as it is for example by
{!Pack.class-box} or {!Pack.class-paned}).
*)
class virtual ['a] container ?class_ ?name ?props () =
  object(self)
    inherit widget ?class_ ?name ?props () as super

    (**/**)
    val mutable children = ([]:'a child list)
    method private children = children

    method private child_by_widget (w:Widget.widget) =
      let id = w#id in
      List.find_opt (fun c -> Oid.equal c.widget#id id) children

    method private widget_index (w:Widget.widget) =
      let id = w#id in
      let rec iter i = function
      | [] -> None
      | c :: _ when Oid.equal c.widget#id id -> Some i
      | _ :: q -> iter (i+1) q
      in
      iter 0 children

    method private child_by_coords ~x ~y =
      List.find_opt (fun c ->
         c.widget#visible &&
           G.inside ~x ~y c.widget#geometry) children

    method private reorder_child w pos =
      let id = w#id in
      match self#child_by_widget w with
      | None -> ()
      | Some child ->
          let rec iter acc p = function
          | [] -> List.rev acc
          | l when p = pos -> iter (child::acc) (p+1) l
          | c :: q ->
              if Oid.equal c.widget#id id then
                iter acc p q
              else iter (c::acc) (p+1) q
          in
          children <- iter [] 0 children;
          self#need_resize

    method private widget_data (w:Widget.widget) =
      match self#child_by_widget w with
      | None -> None
      | Some c -> Some c.data

    method private set_widget_data w data =
      match self#child_by_widget w with
      | None -> Log.warn (fun m -> m "No widget %s in %s" w#me self#me)
      | Some c -> c.data <- data

    method private visible_children =
      List.fold_right
        (fun c acc ->
           if c.widget#visible then c.widget::acc else acc)
        children []

    method! set_p ?(propagate=false) p v =
      Log.debug (fun m -> m "%s#set_p %s ~propagate:%b" self#me
         (Props.name p) propagate);
      super#set_p ~propagate p v ;
      if propagate then
        List.iter (fun c -> c.widget#set_p ~propagate p v) children

    method! wtree = N (self#coerce, List.map (fun c -> c.widget#wtree) children)

    method private focused_child =
      List.find_opt
        (fun c -> c.widget#get_p Props.is_focus)
        children

    method! focused_widget =
      if self#is_focus then
        match self#focused_child with
        | None -> Some self#coerce
        | Some c -> c.widget#focused_widget
      else
        None

    method! release_focus =
      match
        match self#focused_child with
        | None -> true
        | Some c -> c.widget#release_focus
      with
      | true ->
          self#set_p Props.is_focus false ;
          self#set_p Props.has_focus false ;
          true
      | _ -> false

    method! get_focus =
      match super#get_focus with
      | None -> None
      | Some has_focus ->
          List.iter
            (fun c -> c.widget#set_p Props.is_focus false) children;
          Some has_focus

    method! set_has_focus b =
      match super#set_has_focus b with
      | true -> true
      | false ->
          match self#focused_child with
          | None -> false
          | Some c -> c.widget#set_has_focus b

    method! grab_focus ?(last=false) () =
      Log.debug (fun m -> m "%s#grab_focus ~last:%b" self#me last);
      if self#visible then
        match self#get_p Props.can_focus with
        | false -> false
        | true ->
            let rec iter = function
            | [] -> false
            | c :: q ->
                match c.widget#visible, c.widget#get_p Props.can_focus with
                | true, true ->
                    (match c.widget#grab_focus ~last () with
                     | false -> iter q
                     | true -> true)
                | _ -> iter q
            in
            iter (if last then List.rev children else children)
      else
        false

    method private child_move_focus (w:widget) last children on_none =
      let rec iter = function
      | c :: next :: q ->
          if Oid.equal c.widget#id w#id then
            (Log.debug (fun m -> m "%s#child_move_focus next.widget=%s, visible=%b"
              self#me next.widget#me next.widget#visible);
             if next.widget#visible then
               match next.widget#grab_focus ~last () with
               | false -> iter (c :: q)
               | true -> true
             else
               iter (c :: q)
            )
          else
            iter (next :: q)
      | [] | [_] -> on_none ()
      in
      iter children

    method! child_focus_next (w:widget) =
      self#child_move_focus w false
        children (fun () -> self#focus_next)

    method! child_focus_prev (w:widget) =
      self#child_move_focus w true
        (List.rev children)
        (fun () -> self#focus_prev)

    method! on_sdl_event_down ~oldpos pos e =
      Log.debug (fun m -> m "%s#on_sdl_event_down e=%a" self#me Fmts.pp_event e);
      if self#sensitive then
        match
          let f (x,y) = (x - g.x - g_inner.x , y - g.y - g_inner.y) in
          let oldpos = Option.map f oldpos in
          let pos = Option.map f pos in
          match Sdl.Event.(enum (get e typ)) with
          | `Key_down | `Key_up | `Text_input | `Text_editing ->
              (
               match List.find_opt
                 (fun c -> c.widget#get_p Props.is_focus)
                   children
               with
               | None -> false
               | Some c -> c.widget#on_sdl_event_down ~oldpos pos e
              )
          | _ ->
              List.fold_left
                (fun acc c ->
                   let w = c.widget in
                   if
                     (match oldpos with
                      | Some (x,y) -> G.inside ~x ~y w#geometry
                      | None -> false
                     ) ||
                       match pos with
                       | Some (x,y) -> G.inside ~x ~y w#geometry
                       | None -> false
                   then
                     (
                      Log.debug (fun m -> m "%s#on_sdl_event_down: propagating event to %s"
                         self#me w#me);
                      let b = w#on_sdl_event_down ~oldpos pos e in
                      acc || b
                     )
                   else
                     acc
                )
                false children
        with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method private add ?pos w data =
      Log.info (fun m -> m "%s#add %s" self#me w#me);
      if List.exists (fun c -> Oid.equal c.widget#id w#id) children then
        (
         (Log.warn (fun m -> m "%s is already packed in %s" w#me self#me));
         false
        )
      else
        (
         let old_parent = w#parent in
         match old_parent with
         | Some p when p#equal self#as_widget -> false
         | _ ->
             children <- Misc.list_add ?pos children { widget = w ; data } ;
             Option.iter (fun p -> p#child_reparented w) old_parent ;
             w#set_parent ?with_rend:with_renderer (Some self#coerce) ;
             min_width <- None ;
             min_height <- None ;
             true
        )

    method! child_reparented w = self#remove w; self#need_resize
    method private remove (w:widget) =
      let len = List.length children in
      children <- List.filter (fun c -> not (Oid.equal c.widget#id w#id)) children ;
      let len2 = List.length children in
      let b = len <> len2 in
      if b then
        (
         min_width <- None ;
         min_height <- None ;
         w#set_parent None
        )
      else
        Log.warn (fun m -> m "%s is not packed in %s, not removing" w#me self#me);
      b

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w ;
      List.iter
        (fun c -> c.widget#set_parent ?with_rend (Some self#coerce))
        children

    method! child_need_resize w =
      match List.find_opt (fun c -> Oid.equal c.widget#id w#id) children with
      | None ->
          Log.warn (fun m -> m
             "%s#child_need_resize: %s not in children" self#me w#me);
          ()
      | Some c -> if w#visible then self#need_resize

    method private render_me ~layer rend ~offset:(x,y) rg =
      let off_x = g.x + g_inner.x in
      let off_y = g.y + g_inner.y in
      let offset = (x + off_x, y + off_y) in
      let rg = G.translate ~x:(-off_x) ~y:(-off_y) rg in
      List.iter
        (fun c -> c.widget#render ~layer ~offset rend rg)
        children

    method! is_leaf_widget = false
    method! leaf_widget_at ~x ~y =
      let x = x - g.x - g_inner.x in
      let y = y - g.y - g_inner.y in
      match self#child_by_coords ~x ~y with
      | None -> None
      | Some c ->  c.widget#leaf_widget_at ~x ~y

    method! next_widget ?inside ~loop pred w =
      let rec iter = function
      | [] ->
          (match inside, parent with
           | Some i,_ when self#equal i ->
               if loop then self#next_widget ?inside ~loop pred None else None
           | _, None -> None
           | _, Some p -> p#next_widget ?inside ~loop pred (Some self#coerce))
      | c :: q when pred c.widget -> Some c.widget
      | c :: q ->
          match c.widget#next_widget ?inside ~loop pred None with
          | None -> iter q
          | x -> x
      in
      match w with
      | None -> iter children
      | Some w ->
          let rec find = function
          | [] -> iter []
          | c :: q when c.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find children

    method! prev_widget ?inside ~loop pred w =
      let rec iter = function
      | [] ->
          (match inside, parent with
           | Some i, _ when self#equal i ->
               if loop then self#prev_widget ?inside ~loop pred None else None
           | _, None -> None
           | _, Some p -> p#prev_widget ?inside ~loop pred (Some self#coerce))
      | c :: q when pred c.widget -> Some c.widget
      | c :: q ->
          match c.widget#prev_widget ?inside ~loop pred None with
          | None -> iter q
          | x -> x
      in
      match w with
      | None -> iter (List.rev children)
      | Some w ->
          let rec find = function
          | [] -> iter []
          | c :: q when c.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find (List.rev children)

    method! destroy =
      List.iter (fun c -> c.widget#destroy) children;
      super#destroy ;

  end