Source file stk_ocf.ml

(** *)

open Stk

module Wrapper =
  struct
    class virtual ['a] wrapper =
      object
        method virtual as_widget : Widget.widget
        method virtual set : 'a -> unit
        method virtual get : 'a
        method is_none = false
        method set_none : (unit -> unit) option = None
      end

    exception Conv_error of string
    let conv_error fmt = Printf.ksprintf (fun s -> raise (Conv_error s)) fmt
    let () = Printexc.register_printer
      (function Conv_error msg -> Some (Printf.sprintf "Could not convert: %s" msg)
       | _ -> None)

    type ('a, 'b) conv = { from_w : 'b -> 'a ; to_w : 'a -> 'b }

    let int_string_conv =
      let to_w = string_of_int in
      let from_w s =
        match int_of_string_opt s with
        | Some n -> n
        | None -> conv_error "%S is not a valid integer" s
      in
      { to_w ; from_w }

    let float_string_conv =
      let to_w = string_of_float in
      let from_w s =
        match float_of_string_opt s with
        | Some n -> n
        | None -> conv_error "%S is not a valid float" s
      in
      { to_w ; from_w }

    let id_conv = let id x = x in { from_w = id ; to_w = id }
    let list_string_conv (c:('a,string) conv) sep =
      let to_w : 'a list -> string =
        fun l -> String.concat (String.make 1 sep) (List.map c.to_w l)
      in
      let from_w : string -> 'a list =
        fun s ->
          match Misc.strip_string s with
          | "" -> []
          | _ -> List.map c.from_w (String.split_on_char sep s)
      in
      { to_w ; from_w }

    class ['a] entry (conv:('a,string) conv) () =
      object(self)
        inherit Edit.entry ()
        inherit ['a] wrapper
        method set v = self#set_text (conv.to_w v)
        method get = conv.from_w (self#text ())
        method is_none = Misc.strip_string (self#text()) = ""
        method set_none = Some (fun () -> self#set_text "")
        initializer
          self#set_vexpand 0;
          self#set_vfill false
      end

    let entry conv = new entry conv
    let int_entry = new entry int_string_conv
    let float_entry = new entry float_string_conv
    let string_entry = new entry id_conv
    let list_entry conv sep = new entry (list_string_conv conv sep)
    let int () = (int_entry () :> int wrapper)
    let float () = (float_entry () :> float wrapper)
    let string () = (string_entry () :> string wrapper)
    let string_list_entry ?(sep=',') () = list_entry id_conv sep
    let int_list_entry ?(sep=',') () = list_entry int_string_conv sep
    let float_list_entry ?(sep=',') () = list_entry float_string_conv sep

    class checkbutton ?text () =
      object(self)
        inherit Button.checkbutton ()
        inherit [bool] wrapper
        method set v = self#set_active v
        method get = self#active
        method is_none = false
        method set_none = None
        initializer
          Option.iter (fun text ->
             let label = Text.label ~text () in
             self#set_child label#coerce)
            text;
          self#set_vexpand 0;
          self#set_vfill false
      end
    let checkbutton ?text () = new checkbutton ?text ()

    class date ?button_text () =
      let (label,label_date,set_date,hbox) = Datetime.date_label ~allow_none:false ?button_text () in
      object(self)
        inherit [Datetime.date] wrapper
        method set v = set_date (Some v)
        method get =
          match label_date () with
          | None -> (1970,1,1)
          | Some d -> d
        method as_widget = hbox#as_widget
        method is_none = Option.is_none (label_date())
        method set_none = Some (fun () ->
             label#set_p Datetime.p_allow_none true;
             set_date None)
        initializer
          hbox#set_vexpand 0;
          hbox#set_vfill false
      end
    let date ?button_text () = new date ?button_text ()

    class ['b] explicit_option (wrapper:'a wrapper) =
      let hbox = Box.hbox ~inter_padding:2 () in
      let chk = Button.checkbutton ~pack:(hbox#pack ~hexpand:0 ~hfill:false) () in
      let () = hbox#pack wrapper#as_widget in
      let _ = chk#connect (Object.Prop_changed Props.active)
        (fun ~prev ~now -> wrapper#as_widget#set_sensitive now)
      in
      object(self)
        inherit ['a option] wrapper
        method set v =
          match v with
          | None -> chk#set_active false
          | Some v -> chk#set_active true; wrapper#set v
        method get : 'b=
          match chk#active with
          | false -> None
          | true -> Some wrapper#get
        method as_widget = hbox#as_widget
        initializer
          hbox#set_vexpand 0;
          hbox#set_vfill false
      end

    class ['b] option_ (wrapper:'a wrapper) =
      object(self)
        inherit ['a option] wrapper
        method set v =
          match v with
          | Some v -> wrapper#set v
          | None ->
              match wrapper#set_none with
              | None ->
                  Log.err (fun m -> m "Stk_ocf: wrapper passed to option has no set_none fun");
                  ()
              | Some f -> f ()
        method get : 'b =
          if wrapper#is_none then None else Some wrapper#get
        method as_widget = wrapper#as_widget
      end
      let explicit_option w () = new explicit_option w
      let option w () =
          match w#set_none with
          | None -> explicit_option w ()
          | Some _ -> new option_ w
  end

class virtual ['a] group g =
  object(self)
    val mutable ocf_group : 'a Ocf.group = g
    val mutable apply_funs = []
    method virtual as_widget : Widget.widget
    method as_group = (self :> 'a group)
    method ocf_group = ocf_group
    method apply = List.iter (fun f -> f ()) apply_funs
  end

class ['a] conf_option (wrapper:'a Wrapper.wrapper) (o: 'a Ocf.conf_option) =
  object
    inherit [ [`Closed] ] group (Ocf.as_group o)
    method set_value v = wrapper#set v
    method apply = Ocf.set o wrapper#get
    method get = Ocf.get o
    method set = Ocf.set o
    method option = o
    method as_widget = wrapper#as_widget
  end

let get (o:'a conf_option) = o#get
let set (o:'a conf_option) = o#set

let date_wrapper = Ocf.Wrapper.(triple int int int)
let ocf_date ?doc ?cb (v:Datetime.date) = Ocf.option date_wrapper ?doc ?cb v

let option mk_wrapper ocf_wrapper ?doc ?cb v =
 let wcb = ref (fun _ -> ()) in
  let cb =
    fun v ->
      !wcb v;
      match cb with
      | None -> ()
      | Some f -> f v
  in
  let o = Ocf.option ?doc ?cb:(Some cb) ocf_wrapper v in
  let wrapper = (mk_wrapper ():> 'a Wrapper.wrapper) in
  let w = new conf_option wrapper o in
  w#set_value v;
  wcb := w#set_value ;
  (w :> 'a conf_option)

let int = option Wrapper.int_entry Ocf.Wrapper.int
let int_list ?sep = option (Wrapper.int_list_entry ?sep ()) Ocf.Wrapper.(list int)

let string = option Wrapper.string_entry Ocf.Wrapper.string
let string_list ?sep = option (Wrapper.string_list_entry ?sep ()) Ocf.Wrapper.(list string)

let bool ?text = option (Wrapper.checkbutton ?text) Ocf.Wrapper.bool
let date ?button_text = option (Wrapper.date ?button_text) date_wrapper
let explicit_option w ocf_w = option (Wrapper.explicit_option w) (Ocf.Wrapper.option ocf_w)
let option_ w ocf_w = option (Wrapper.option w) (Ocf.Wrapper.option ocf_w)

let to_string (group:_ #group) = group#apply ; Ocf.to_string group#ocf_group
let to_json (group:_ #group) = group#apply ; Ocf.to_json group#ocf_group

let from_string (group:_ #group) str = Ocf.from_string group#ocf_group str
let from_json (group:_ #group) json = Ocf.from_json group#ocf_group json

class virtual ['a] open_group g =
  object(self)
    (*constraint ('a = [`Open])*)
    inherit ['a] group g
    method private add_option_to_group : 'b. Ocf.path -> 'b conf_option -> unit =
      fun path o ->
        ocf_group <- Ocf.add ocf_group path o#option;
        apply_funs <- (fun () -> o#apply) :: apply_funs
    method private add_group_to_group : 'g. Ocf.path -> 'g group -> unit =
      fun path g ->
        ocf_group <- Ocf.add_group ocf_group path g#ocf_group;
        apply_funs <- (fun () -> g#apply) :: apply_funs
  end

let group f = f Ocf.group

let opt_label_or_text ?label ?text () =
  match label, text with
  | None, None -> None
  | None, Some text -> Some ((Text.label ~valign:0. ~halign:1. ~text ())#coerce)
  | Some l, _ -> Some l#coerce
let label_or_text ?label ?text () =
  match opt_label_or_text ?label ?text () with
  | Some w -> w
  | None -> (Text.label ~text:"" ())#coerce

class ['a] box orientation ?classes ?name ?props ?wdata () =
  object(self)
    inherit Box.box ?classes ?name ?props ?wdata ()
    inherit ['a] open_group Ocf.group
    method add_option : 'b. ?pos:int -> ?hexpand:int -> ?vexpand:int -> ?hfill:bool -> ?vfill:bool ->
      Ocf.path -> 'b conf_option -> unit =
        fun ?pos ?hexpand ?vexpand ?hfill ?vfill path o ->
          self#add_option_to_group path o;
          self#pack ?pos ?hexpand ?vexpand ?hfill ?vfill o#as_widget
    method add_group : 'g. ?pos:int -> ?hexpand:int -> ?vexpand:int -> ?hfill:bool -> ?vfill:bool ->
      Ocf.path -> 'g group -> unit =
      fun ?pos ?hexpand ?vexpand ?hfill ?vfill path g ->
          self#add_group_to_group path g;
          self#pack ?pos ?hexpand ?vexpand ?hfill ?vfill g#as_widget
    initializer
      self#set_orientation orientation
  end
let vbox = new box Props.Vertical
let hbox = new box Props.Horizontal

class ['a] notebook orientation ?classes ?name ?props ?wdata () =
  object(self)
    inherit Notebook.notebook ?classes ?name ?props ?wdata ()
    inherit ['a] open_group Ocf.group
    method add_group : 'g.
      ?pos:int -> ?label:Widget.widget -> ?text:string -> Ocf.path -> 'g group -> unit =
        fun ?pos ?label ?text path g ->
          self#add_group_to_group path g;
          let label = label_or_text ?label ?text () in
          self#pack ?pos ~label g#as_widget
    initializer
      self#set_orientation orientation
  end
let vnotebook = new notebook Props.Vertical
let hnotebook = new notebook Props.Horizontal

class ['a] frame ?classes ?name ?props ?wdata ?label gr =
  object(self)
    inherit Frame.frame ?classes ?name ?props ?wdata ?label ()
    inherit [ 'a ] group gr#ocf_group
    method! apply = gr#apply
    initializer
      self#set_child gr#as_widget
  end
let frame ?classes ?name ?props ?wdata ?label ?text gr =
  let label = opt_label_or_text ?label ?text () in
  new frame ?classes ?name ?props ?wdata ?label gr

class ['a] table ?classes ?name ?props ?wdata () =
  object(self)
    inherit Table.table ?classes ?name ?props ?wdata ()
    inherit ['a] open_group Ocf.group
    method add_option  : 'b.
      ?hexpand:int -> ?vexpand:int -> ?hfill:bool -> ?vfill:bool ->
      ?label:Widget.widget -> ?text:string -> Ocf.path -> 'b conf_option -> unit =
        fun ?hexpand ?vexpand ?hfill ?vfill ?label ?text path o ->
          self#add_option_to_group path o;
          self#set_rows (self#rows + 1);
          let label = label_or_text ?label ?text () in
          self#pack ~vexpand:0 ~vfill:false ~hexpand:0 label;
          self#pack ?hexpand ?vexpand ?hfill ?vfill o#as_widget
    method add_group  : 'g.
      ?hexpand:int -> ?vexpand:int -> ?hfill:bool -> ?vfill:bool ->
        ?label:Widget.widget -> ?text:string -> Ocf.path -> 'g group -> unit =
        fun ?hexpand ?vexpand ?hfill ?vfill ?label ?text path g ->
          self#add_group_to_group path g;
          self#set_rows (self#rows + 1);
          let label = label_or_text ?label ?text () in
          self#pack ~vexpand:0 ~vfill:false ~hexpand:0 label;
          self#pack ?hexpand ?vexpand ?hfill ?vfill g#as_widget
    initializer
      self#set_columns 2
  end
let table = new table