/src/dialog.ml

  1module D = Dom
  2module F = Froc
  3module Fd = Froc_dom
  4
  5type dlgstate =
  6    Normal
  7  | Moving of int * int
  8  | Resizing of int * int
  9
 10let set_text (e : D.element) text =
 11  let text_node = (D.document#createTextNode "" : D.text) in
 12  text_node#_set_data text;
 13  ignore (e#appendChild text_node)
 14
 15let mouse_down_if_e p (elt : D.element) =
 16  let e, s = F.make_event () in
 17  let f_down me = if p me then F.send s (true, me#_get_clientX - elt#_get_offsetLeft, me#_get_clientY - elt#_get_offsetTop) in
 18  let f_up me = if p me then F.send s (false, me#_get_clientX - elt#_get_offsetLeft, me#_get_clientY - elt#_get_offsetTop) in
 19  elt#addEventListener_mouseEvent_ "mousedown" f_down false;
 20  elt#addEventListener_mouseEvent_ "mouseup" f_up false;
 21  F.cleanup (fun () -> elt#removeEventListener_mouseEvent_ "mousedown" f_down false; elt#removeEventListener_mouseEvent_ "mouseup" f_up false);
 22  e
 23
 24let mouse_down_e (elt : D.element) = mouse_down_if_e (fun x -> true) elt
 25
 26class dialog ~elt:(elt: D.element) ?x0:(x=50) ?y0:(y=50) () =
 27object (self)
 28  val dialog = (D.document#createElement "div")
 29  val mutable state = Normal
 30  
 31  method add_title =
 32    let title = (D.document#createElement "div") in
 33    let close = (D.document#createElement "div") in
 34    set_text title "title";
 35    set_text close "x";
 36    ignore (title#_get_style#_set_border "1px solid black");
 37    ignore (title#_get_style#_set_display "absolute");
 38    ignore (title#_get_style#_set_left "0");
 39    ignore (title#_get_style#_set_top "0");
 40    ignore (title#_get_style#_set_right "0");
 41    ignore (title#_get_style#_set_height "20px");
 42    ignore (close#_get_style#_set_display "inline-block");
 43    ignore (close#_get_style#_set_position "absolute");
 44    ignore (close#_get_style#_set_right "5px");
 45    ignore (close#_get_style#_set_cursor "hand");
 46    close#_set_onclick
 47      (fun _ -> self#hide; true);
 48    ignore (title#appendChild close);
 49    ignore (dialog#appendChild title)
 50
 51  method add_body =
 52    let body = (D.document#createElement "div") in
 53    set_text body "body";
 54    ignore (body#_get_style#_set_position "absolute");
 55    ignore (body#_get_style#_set_border "1px solid black");
 56    ignore (body#_get_style#_set_borderTop "1px none black");
 57    ignore (body#_get_style#_set_left "0");
 58    ignore (body#_get_style#_set_top "20px");
 59    ignore (body#_get_style#_set_right "0");
 60    ignore (body#_get_style#_set_bottom "0");
 61    ignore (dialog#appendChild body)
 62
 63  method add_mouse_events =
 64    let mouse_move = Fd.mouse_b () in
 65    Fd.appendChild elt
 66    (F.blift mouse_move (fun (x,y) ->
 67      match state with
 68	| Moving (o_x, o_y) ->
 69	  begin
 70	    dialog#_get_style#_set_left (string_of_int (x - o_x));
 71	    dialog#_get_style#_set_top (string_of_int (y - o_y));
 72	    dialog
 73	  end
 74	| Resizing (o_x, o_y) ->
 75	  begin
 76	    let l = dialog#_get_offsetLeft in
 77	    let t = dialog#_get_offsetTop in
 78	    dialog#_get_style#_set_width (string_of_int (x - l + 5));
 79	    dialog#_get_style#_set_height (string_of_int (y - t + 5));
 80	    dialog
 81	  end
 82	| _ -> dialog
 83     ));
 84    let is_resize me =
 85      let x = me#_get_clientX in
 86      let y = me#_get_clientY in
 87      let l = dialog#_get_offsetLeft in
 88      let t = dialog#_get_offsetTop in
 89      let w = dialog#_get_offsetWidth in
 90      let h = dialog#_get_offsetHeight in
 91      x > (l+w)-20 && y > (t+h)-20
 92    in
 93    let mouse_down_move = F.hold (false,0,0) (mouse_down_if_e (fun me -> not (is_resize me)) dialog) in
 94    F.notify_result_b (F.blift mouse_down_move (fun a -> a)) (fun r -> match r with
 95      |  F.Value (b,x,y) -> (state <- if b then Moving (x,y) else Normal)
 96      | _ -> ());
 97    let mouse_down_resize = F.hold (false,0,0) (mouse_down_if_e (fun me -> is_resize me) dialog) in
 98    F.notify_result_b (F.blift mouse_down_resize (fun a -> a)) (fun r -> match r with
 99      |  F.Value (b,x,y) -> (state <- if b then Resizing (x,y) else Normal)
100      | _ -> ())
101
102  method hide = ignore (elt#removeChild dialog);
103
104  method decorate =
105    self#add_title;
106    self#add_body;
107    self#add_mouse_events;
108    ignore (dialog#_get_style#_set_display "inline-block");
109    ignore (dialog#_get_style#_set_position "absolute");
110    ignore (dialog#_get_style#_set_width "200px");
111    ignore (dialog#_get_style#_set_height "150px");
112    ignore (dialog#_get_style#_set_left (string_of_int x));
113    ignore (dialog#_get_style#_set_top (string_of_int y))
114
115  initializer self#decorate
116end