package stk_xml

  1. Overview
  2. Docs

Source file view.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
(*********************************************************************************)
(*                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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** XML view widget.

This widget allows to display a XML document, using other Stk widgets.

It can handle styling with CSS, use remote resources if a [load_resource]
function is provided, add event handlers on created widgets according
to CSS selectors (see {!Eprops}).

One can also provide a function to handle some XML nodes and change
the widgets used to display these nodes (with method {!View.class-xmlview.method-set_of_node},
see {!Layout}.)
*)

(** {2 Properties} *)

(** Property to store XML document. *)
let prop_xml = Xml.mk_prop_xml "xmlview-xml"

(** Property to store IRI. *)
let prop_iri = Types.iri_prop "xmlview-iri"

(** {2 Events} *)

type _ Stk.Events.ev += Doc_updated : (unit -> unit) Stk.Events.ev

(** {2 Widget} *)

(** The xmlview widget, with kind ["xmlview"].

  Note that the widget will automatically rebuild the widgets to display the XML document
  when the source of the style changes (i.e. event [Prop_changed] with
  property {!Style.prop_source}).
*)
class xmlview ?classes ?name ?props ?wdata ?load_resource ?(style=new Style.style()) () =
  object(self)
    inherit Stk.Bin.bin ?classes ?name ?props ?wdata () as super

    (**/**)

    method! kind = "xmlview"
    val mutable doc = Doc.doc_empty
    val style = style
    val mutable style_change_cb = None
    val mutable event_css : Iri.t Css.S.rule_ list = []
    val mutable load_resource : Types.load_resource option = load_resource
    val mutable of_node : Layout.of_node_fun option = None

    (**/**)

    (** Get the style object used by the view. If none was provided
         at creation time, a default one is used. *)
    method style = style

    (** Return the current XML view document. *)
    method doc = doc

    (** Set CSS statements describing which event handlers to add to
        created widgets (see {!Eprops}). *)
    method set_event_css css = event_css <- (Style.rules_of_css css)

    (** Append CSS statements for event handlers. *)
    method add_event_css css = event_css <- event_css @ (Style.rules_of_css css)

    (** [#load_resource iri] retrieves resource at [iri], if a [load_resource]
         function was provided; else returns [`None]. *)
    method load_resource iri =
      match load_resource with
      | None -> Lwt.return `None
      | Some f -> f iri

    (** Set the function used to retrieve remote resources. *)
    method set_load_resource f = load_resource <- f

    (** Set the function building widgets from an XML node. See {!Layout} module. *)
    method set_of_node f = of_node <- f

    (** Set the XML document to display. This will remove all widgets displaying
        previous document. The [iri] optional argument is used to resolve relative
        IRIs. *)
    method set_xml ?(iri:Iri.t option) xml =
      Stk.Props.set_opt props prop_iri iri;
      self#set_p prop_xml xml

    (** Get the currently displayed XML document. *)
    method xml = self#get_p prop_xml

    (** Get the current IRI, i.e. the one set with [#set_xml]. *)
    method iri = self#opt_p prop_iri

    (**/**)

    method private update_doc () =
      let%lwt css_rules = style#css_rules ?base:self#iri self#load_resource self#xml in
      let css_rules = css_rules @ event_css in
      (*Log.warn (fun m -> m "%a" (Css.S.pp_list "\n" (Css.S.pp_rule_ Xml.QName.to_string)) css);*)
      let (d,_) = Layout.build_doc ?of_node self#iri self#load_resource
        self#set_child css_rules self#xml.Xml.elements
      in
      doc <- d;
      self#trigger_unit_event Doc_updated () ;
      Lwt.return_unit

    method! destroy =
      Option.iter Stk.Events.unregister style_change_cb ;
      super#destroy

    (**/**)

    initializer
      let _ = self#connect (Stk.Object.Prop_changed prop_xml)
        (fun ~prev ~now -> Lwt.async self#update_doc)
      in
      let cb_id = style#connect (Stk.Object.Prop_changed Style.prop_source)
        (fun ~prev ~now -> Lwt.async self#update_doc)
      in
      style_change_cb <- Some cb_id
  end

type Stk.Widget.widget_type += Xmlview of xmlview

(** Use this function to create a {!class-xmlview} widget. *)
let xmlview ?classes ?name ?props ?wdata ?load_resource ?style ?pack () =
  let w = new xmlview ?classes ?name ?props ?wdata ?load_resource ?style () in
  w#set_typ (Xmlview w);
  Stk.Widget.may_pack ?pack w ;
  w