Source file w.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

module U = Utils

open Stk
open Rdf

type term_map = { mutable map : Widget.widget Term.TMap.t }
let term_map_create () = { map = Term.TMap.empty }
let term_map_add m term w =  m.map <- Term.TMap.add term w m.map
let term_map_remove m term =  m.map <- Term.TMap.remove term m.map
let term_map_find_opt m term = Term.TMap.find_opt term m.map
let term_map_pp ppf m =
  Term.TMap.iter
    (fun term w ->
       (Format.fprintf ppf "%s=>%s\n" (Term.string_of_term term) w#me))
      m.map

type ctx =
  { graph: Graph.graph;
    tmap: term_map;
    on_term_click: Widget.button_ev -> Term.term -> Graph.graph -> unit ;
    on_term_activate: Term.term -> Graph.graph -> unit ;
    namespaces : (string * string) list ;
  }

let apply_namespaces namespaces iri =
  let len_iri = String.length iri in
  let rec iter = function
  | [] -> None
  | (pref,ns) :: q ->
      let len = String.length ns in
      if len <= len_iri && String.sub iri 0 len = ns then
        Some (pref, String.sub iri len (len_iri - len))
      else
        iter q
  in
  iter namespaces

let p_fullterm = Props.(PBool.mk_prop
   ~after:[Resize] ~default:true ~inherited:false "rdf_fullterm")
let css_fullterm = Theme.bool_prop p_fullterm

let p_term = U.PTerm.mk_prop
   ~after:[Props.Resize] ~inherited:false "rdf_term"

let init =
  let initialized = ref false in
  fun () ->
    if !initialized then
      ()
    else
      (
       initialized := true ;
       let css = {css|
           box.rdf_node, box.rdf_box, label.rdf_node_cell {
             bg_color: transparent;
             border_color_selected: var(--bg-color-selected);
           }
           box.rdf_box {
             bg_color: var(--bg-color);
             fill: true;
           }
           clist.rdf_node_relations {
             margin: 0 2 2 20;
             border_width: 0 0 0 2;
           }
           label.rdf_node_cell {
               border_width: 2;
               border_color_focused: var(--border-color-focused);
               border_color_selected: var(--bg-color-selected) var(--bg-color-selected)
                 var(--bg-color-selected) transparent;
           }
           textview.rdf_term, label.rdf_term_cell {
               padding: 2 4 2 4;
               halign: 0;
               valign: 0;
               editable: false;
               show_cursors: false;
               bg_color_selected: transparent;
               max_height: 150;
               rdf_fullterm: false;
           }
           label.rdf_term_cell {
             border_width: 2;
             border_color_focused: var(--border-color-focused);
             border_color_selected: var(--bg-color-selected) transparent
               var(--bg-color-selected) var(--bg-color-selected) ;
           }
             |css}
       in
       Theme.add_css_to_extension ~body:css "rdf"
      )

class term ?(classes=[]) ?name ?props ?wdata ctx =
  let classes = "rdf_term" :: classes in
  let () = init () in
  object(self)
    inherit Textview.textview ~classes ?name ?props ?wdata () as super

    method set_term = self#set_p p_term
    method term = self#opt_p p_term

    method set_fullterm = self#set_p p_fullterm
    method fullterm = self#get_p p_fullterm

    method private string_of_iri iri =
      let s_iri = Iri.to_string iri in
      match self#fullterm with
      | true -> s_iri
      | false ->
          match apply_namespaces ctx.namespaces s_iri with
          | None -> s_iri
          | Some ("",rel) -> rel
          | Some (ns,rel) -> Printf.sprintf "%s:%s" ns rel

    method on_term_changed ~prev ~now =
      let str = match now with
        | Term.Iri iri ->
            self#set_wrap_mode Textview.Wrap_none ;
            self#string_of_iri iri
        | _ ->
            self#set_wrap_mode Textview.Wrap_char ;
            Rdf.Term.string_of_term now
      in
      self#delete ();
      self#insert str
    initializer
      let _ = self#connect (Object.Prop_changed p_term) self#on_term_changed in
      ()
  end

class ['a] term_cell ?(classes=[]) ?name ?props ?wdata ~to_data ~of_data ctx () =
  let classes = "rdf_term" :: classes in
  let () = init () in
  object(self)
    inherit ['a] Clist.cell_ ~classes ?name ?props () as dsuper
    inherit term ~classes ?name ?props ?wdata ctx as super
    method contents (d:'a) = to_data d super#term self#props
    method set_contents d =
      let (term, p) = of_data d in
      Option.iter super#set_props p ;
      super#set_term term;
(*    initializer
      self#set_bg_color_selected Color.transparent ;
      Log.warn (fun m -> m "%s: props=%a" self#me Props.pp self#props);*)
  end

let term_cell ?classes ?name ?props ?(focusable=true) of_data
  ?(to_data=fun _ _ _ -> ()) ctx () =
  let o = new term_cell ?classes ?name ?props ~to_data ~of_data ctx () in
  o#set_focusable focusable ;
  o#set_can_focus focusable ;
  (*let _ = o#connect (Object.Prop_changed Props.selected)
    (fun ~prev ~now -> Log.warn (fun m -> m "%s#props: %a" o#me Props.pp o#props))
  in*)
  ( o :> 'a Clist.cell)

class node ?(classes=[]) ?name ?props ?wdata ctx =
  let classes = "rdf_node" :: classes in
  let () = init () in
  let hbox = Pack.hbox () in
  let label = new term ?props ctx in
  let bexpand = Button.checkbutton () in
  let relbox = Pack.vbox () in
  let rels = new relations ctx in
  object(self)
    inherit [unit] Pack.box ~classes ?name ?props ?wdata ()

    method set_term = self#set_p p_term
    method term = self#opt_p p_term

    method on_clicked (bev:Widget.button_ev) =
      match bev.button, Tsdl.Sdl.Event.(get bev.Widget.event mouse_button_clicks) with
      | 1, 2 -> (* double click *)
          (match self#term with
           | None -> false
           | Some term ->
               match term_map_find_opt ctx.tmap term with
               | Some w ->
                   if not (label#equal w) then
                     (
                      let bg = w#bg_color in
                      w#set_bg_color Color.cyan;
                      w#set_bg_color ~delay:2.0 bg;
                     );
                   true
               | None -> false
          )
      | _ -> false

    method on_term_changed ~prev ~now =
      label#set_term now;
      Option.iter (term_map_remove ctx.tmap) prev ;
      let term_widget = term_map_find_opt ctx.tmap now in
      match now with
      | Term.Literal _ ->
          bexpand#set_visible false;
          (rels:>Widget.widget)#set_visible false;
          (match label#opt_p Props.max_height with
           | None -> ()
           | Some h -> self#set_p Props.max_height h)
      | _ ->
          bexpand#set_visible true;
          match term_widget with
          | None ->
              term_map_add ctx.tmap now label#coerce ;
              rels#set_term ?delay:None ?propagate:None now ;
          | Some _ ->
              (rels:>Widget.widget)#set_visible false

    initializer
      self#set_orientation Props.Vertical;
      self#pack ~vexpand:0 ~hfill:true hbox#coerce ;
      bexpand#set_padding_ 0 0 0 2;
      bexpand#set_indicator_active_char (Uchar.of_int 9660);
      bexpand#set_indicator_inactive_char (Uchar.of_int 9654);
      hbox#pack ~hexpand:0 ~vfill:false bexpand#coerce;
      hbox#pack ~hexpand:1 label#coerce;
      self#pack ~vexpand:1 relbox#coerce;
      relbox#pack rels#coerce;
      let _ = self#connect (Object.Prop_changed p_term) self#on_term_changed in
      let _ = rels#connect (Object.Prop_changed Props.visible)
        (fun ~prev ~now -> bexpand#set_visible now)
      in
      let _ = bexpand#set_active rels#visible in
      let _ = bexpand#connect (Object.Prop_changed Button.active)
        (fun ~prev ~now -> relbox#set_visible (now && bexpand#visible); self#need_resize)
      in
      let _ = self#connect Widget.Clicked self#on_clicked in
      ()
  end

and relations ?(classes=[]) ?name ?props ?wdata ctx =
  let classes = "rdf_node_relations" :: classes in
  let col_pred =
    let mk = term_cell (fun (pred, obj) -> Term.Iri pred, None) ctx in
    Clist.column mk
  in
  let col_obj =
    let mk x =
      let o = new node_cell
        ~to_data:(fun _ _ _ -> ())
          ~of_data:(fun (pred, obj) -> obj, None)
          ctx x
      in
      ( o  :> 'a Clist.cell)
    in
    Clist.column mk
  in
  object(self)
    inherit [Iri.t * Term.term] Clist.clist ~classes ?name ?props ?wdata () as super

    method set_term = self#set_p p_term
    method term = self#opt_p p_term

    method on_term_changed ~prev ~now =
      let l = ctx.graph.Rdf.Graph.find ~sub:now () in
      self#set_list (List.map (fun (_,p,o) -> (p,o)) l);
      self#set_p Props.visible (l<>[])

    initializer
      let (_:int) = self#add_column col_pred in
      let (_:int) = self#add_column col_obj in
      self#set_show_headers false ;
      self#set_row_height (-1);
      let _ = self#connect (Object.Prop_changed p_term) self#on_term_changed in
(*      Log.warn (fun m -> m "%s#props: %a" self#me Props.pp self#props);*)
      ()
  end

and ['a] node_cell ?(classes=[]) ?name ?props ?wdata ~to_data ~of_data ctx () =
  let classes = "rdf_node_cell" :: classes in
  object(self)
    inherit ['a] Clist.cell_ ~classes ?name ?props () as dsuper
    inherit node ~classes ?name ?props ?wdata ctx as super
    method contents (d:'a) = to_data d super#term self#props
    method set_contents d =
      let (term, p) = of_data d in
      Option.iter super#set_props p ;
      super#set_term term
 end

let default_namespaces =
  [
    Acl.acl, "acl" ;
    Activitystreams.activitystreams, "as" ;
    Dc.dc, "dc" ;
    Doap.doap, "doap" ;
    Earl.earl, "earl" ;
    Foaf.foaf, "foaf" ;
    Ldp.ldp, "ldp" ;
    Oa.oa, "oa" ;
    Owl.owl, "owl" ;
    Pim.pim, "pim" ;
    Prov.prov, "prov" ;
    Rdf_.rdf, "rdf" ;
    Rdfs.rdfs, "rfds" ;
    Security.security, "security" ;
    Sioc.sioc, "sioc" ;
    Solid.solid, "solid" ;
    Time.time, "time" ;
    Vcard.vcard, "vcard" ;
    Rdf_.xsd, "xsd" ;
  ]

class box ?(classes=[]) ?name ?props ?wdata ?(namespaces=default_namespaces)
  ?(on_term_click=fun _ _ _ -> ())
    ?(on_term_activate=fun _ _ -> ()) graph =
  let classes = "rdf_box" :: classes in
  let namespaces =
    try Rdf.Dot.build_namespaces ~namespaces graph
    with Failure msg ->
        Log.warn (fun m -> m "%s" msg);
        Rdf.Dot.build_namespaces ~namespaces (Rdf.Graph.open_graph (Iri.of_string ""))
  in
  let ctx = { graph ;
      tmap = term_map_create () ;
      on_term_click ;
      on_term_activate ;
      namespaces ;
    }
  in
  object(self)
    inherit node ~classes ?name ?props ?wdata ctx as super
    method! set_term ?delay ?propagate t =
      self#ignore_need_resize;
      super#set_term ?delay ?propagate t;
      self#handle_need_resize;
      self#need_resize
(*
      Log.warn (fun m -> m "%s#props: %a" self#me Props.pp self#props);
*)
  end

let box ?classes ?name ?props ?wdata ?pack ?namespaces ?on_term_click ?on_term_activate graph =
  let w = new box ?classes ?name ?props ?wdata ?namespaces ?on_term_click ?on_term_activate graph in
  Widget.may_pack ?pack w ;
  w