package stk_xml

  1. Overview
  2. Docs

Source file style.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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
(*********************************************************************************)
(*                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 Log = (val Log.create_src "style")


let qname_matches ((ns1,ln1) as q1) ((ns2,ln2) as q2) =
  match ln1 with
  | "*" -> Iri.equal ns1 ns2
  | _ -> Xml.QName.compare q1 q2 = 0

let string_of_path =
  let string_of_node n = Printf.sprintf "<%s>%s"
    (Xml.QName.to_string n.Xml.name)
      (match Xml.opt_att n Xml.xhtml_class with
       | None -> ""
       | Some (str,_) -> Printf.sprintf "[%s]" str)
  in
  fun p ->
    String.concat "\n"
      (List.map
       (fun l -> (String.concat " / " (List.map string_of_node l)))
         p)
let pp_path ppf p = Format.pp_print_string ppf (string_of_path p)

open Css.S

let attr_value_matches iri v node =
  match Xml.opt_att node iri with
  | None -> false
  | Some (s,_) ->
      let (s,vs) =
        if v.case_sensitive then
          (s, v.v)
        else
          (String.lowercase_ascii s, String.lowercase_ascii v.v)
      in
      match v.op with
      | Exact -> s = vs
      | Exact_list -> List.mem vs (Stk.Misc.split_string s [' ';'\n';'\t';'\r'])
      | Hyphen -> s = vs || Stk.Misc.is_prefix ~s ~pref:(vs^"-")
      | Prefix -> Stk.Misc.is_prefix ~s ~pref:vs
      | Suffix -> Stk.Misc.is_suffix ~s ~suff:vs
      | Contain -> Stk.Misc.string_contains ~s ~pat:vs


let attr_selector_matches s node =
  match s with
  | Attr_present iri -> Xml.opt_att node iri <> None
  | Attr_value (iri, v) -> attr_value_matches iri v node


let pseudo_classes_match l node =
  (* pseudo classes are not handled by now, except ":root" which is
     applied only on special ':root' element *)
  match l with
  | [] -> true
  | _ ->
      List.exists (fun (cl,_loc) -> cl = `Root) l &&
        (let (iri,str) = node.Xml.name in
         Iri.to_string iri = "" && str = ":root")

let pseudo_elt_match elt node = elt = None

let attr_selectors_match l node =
  List.for_all (fun (s,_) -> attr_selector_matches s node) l

let single_selector_matches s node =
  (pseudo_classes_match s.sel_pseudo_class node) &&
  (pseudo_elt_match s.sel_pseudo_elt node) &&
  (match s.sel_qname with
   | None -> true
   | Some (n,_loc) -> qname_matches n node.Xml.name
  )
    && (attr_selectors_match s.sel_attr node)
    &&
    (match s.sel_id with
     | None -> true
     | Some (id,_) ->
         match Xml.opt_att node Xml.xhtml_id with
         | None -> false
         | Some (id2,_) -> id = id2
    )

let rec selector_matches sel path node =
  match sel with
  | Single s -> single_selector_matches s node
  | Inside (s, ss) ->
      (match path with
       | [] | [_] -> false
       | _ :: q ->
           single_selector_matches ss node
             && path_matches_inside s q
      )
  | Child (s, ss) ->
      (match path with
       | [] | [_] -> false
       | _ :: q ->
           single_selector_matches ss node
             && path_matches_child s q
      )
  | Adjacent (s, ss) ->
      single_selector_matches ss node
      && path_matches_adjacent s path

  | Sibling (s, ss) ->
      single_selector_matches ss node
      && path_matches_sibling s path

and path_matches_inside sel path =
      let b =
        match path with
        | [] -> false
        | [] :: _ -> false
        | (h :: _) :: q ->
            selector_matches sel q h
              || path_matches_inside sel q
      in
      (*prerr_endline (Printf.sprintf "path_match_INSIDE path=%s: %b" (string_of_path path) b) ;*)
      b

and path_matches_child sel path =
  (*prerr_endline (Printf.sprintf "path_match_CHILD path=%s" (string_of_path path)) ;*)
  match path with
  | [] -> false
  | [] :: _ -> false
  | (h :: _) :: q -> selector_matches sel q h

and path_matches_adjacent sel path =
  match path with
  | [] -> false
  | [] :: _ -> false
  | (h :: q) :: parent -> selector_matches sel (q::parent) h

and path_matches_sibling sel path =
  match path with
  | [] -> false
  | [] :: _ -> false
  | (h :: q) :: parent ->
      let rec iter = function
      | [] -> false
      | h::q ->
          selector_matches sel (q::parent) h
            || iter q
      in
      iter q

let apply_rules =
  let apply ~root ~parent path node acc r =
    if List.exists (fun (s,_) -> selector_matches s path node) r.sel then
      Css.compute_decls (module Css.P.Css) ~root ~parent acc r.decls
    else
      acc
  in
  fun rules path node ~root ~parent ->
    let t = Css.C.filter_inherited parent in
    let t = List.fold_left (apply ~root ~parent path node) t rules in
    t

let apply_style_attr ~root ~parent props (node:Xml.node) =
  let (ns, lname) = node.name in
  match Xml.opt_att node (Iri.of_string "","style") with
  | None -> props
  | Some (str,_) ->
      Log.warn (fun m -> m "applying style %S attribute for node (%s,%s)"
         str (Iri.to_string ns) lname);
      let str = Printf.sprintf "* { %s }" str in
      match Css.parse_css str with
      | exception (Css.T.Error e) ->
          Log.warn (fun m -> m "could not parse style attribute: %a"
             Css.T.pp_error e);
          props
      | [ Css.S.Rule (r, _) ] ->
          Css.compute_decls (module Css.P.Css) ~root ~parent props r.Css.S.decls
      | _ ->
          Log.err (fun m -> m "style attribute: zero or more than one rule parsed ??");
          props

let get_props ?(honor_style_attr=true) path ?(root=Css.C.empty) ?(parent=Css.C.empty) rules (node:Xml.node) =
  let props = apply_rules rules path node ~root ~parent in
  if honor_style_attr then
    apply_style_attr ~root ~parent props node
  else
    props

type source =
| Document of Iri.t Css.S.rule_ list
| Rules of Iri.t Css.S.rule_ list

module TSource = struct
    type t = source
    let compare s1 s2 =
      match s1, s2 with
      | Document l1, Document l2 -> List.compare (Stdlib.compare) l1 l2
      | Document _, _ -> -1
      | _, Document _ -> 1
      | Rules l1, Rules l2 -> List.compare (Stdlib.compare) l1 l2
    let wrapper = None
    let transition = None
  end
module PSource = Stk.Props.Add_prop_type(TSource)
let prop_source = PSource.mk_prop ~default:(Document[]) ~inherited:false "style_source"


let get_xhtml_style_info ~base xmls =
  let open Xml in
  let find str xmls =
    let pred = function
    | E  { name } -> QName.compare name (xhtml_ str) = 0
    | _ -> false
    in
    List.find_opt pred xmls
  in
  let find_html = find "html" in
  let find_head = find "head" in
  let rec iter acc = function
  | [] -> List.rev acc
  | E node :: q when QName.compare node.name (xhtml_ "link") = 0 ->
      (match Xml.opt_att node (xhtml_ "rel") with
       | Some ("stylesheet",_) ->
           (match Xml.opt_att node (xhtml_ "href") with
            | None -> iter acc q
            | Some (str,loc) ->
                (try
                   let iri = Iri.of_string str in
                   let iri = Iri.resolve ~base iri in
                   iter ((`Iri iri)::acc) q
                 with e ->
                     Log.err (fun m -> m "%a: stylesheet iri error: %s"
                        Types.pp_loc_option loc (Printexc.to_string e));
                     iter acc q
                )
          )
      | _ -> iter acc q
     )
  | E { name ; subs } :: q when QName.compare name (xhtml_ "style") = 0 ->
      let cdata = Xml.text_of_xmls subs in
      iter ((`Inline cdata) :: acc) q
  | _ :: q -> iter acc q
  in
  match find_html xmls with
  | Some (E { subs }) ->
      (match find_head subs with
       | Some (E { subs }) -> Some (iter [] subs)
       | _ -> None
      )
  | _ -> None

let load_css load_resource iri =
 match%lwt load_resource iri with
  | `None -> Lwt.return []
  | `Error msg ->
      Log.err (fun m -> m "Loading %a: %s" Iri.pp iri msg);
      Lwt.return []
  | `Ok r ->
      match r with
      | Ldp.Types.Non_rdf r ->
          (match Css.parse_css r.contents with
          | statements -> Lwt.return statements
          | exception Css.T.Error e ->
              Log.err (fun m -> m "%a: %a" Iri.pp iri Css.T.pp_error e);
              Lwt.return [])
      | _ -> Lwt.return []

let css_of_doc load_resource base doc =
  let f source acc =
    match source with
    | `Iri iri ->
        let%lwt l = load_css load_resource iri in
        Lwt.return (l @ acc)
    | `Inline str ->
        match Css.parse_css str with
        | statements -> Lwt.return (statements @ acc)
        | exception Css.T.Error e -> Log.err (fun m -> m "%a" Css.T.pp_error e); Lwt.return acc
  in
  match get_xhtml_style_info ~base doc.Xml.elements with
  | None -> Lwt.return []
  | Some l -> Lwt_list.fold_right_s f l []

let rules_of_css css =
  let css = Css.S.expand_statement_list css in
  let css = Css.S.expand_nested css in
  List.filter_map
    (function
     | Css.S.At_rule _ -> None
     | Rule (r,_) -> Some r)
    css

class style ?props () =
  object(self)
    inherit Stk.Object.o ?props ()
    method set_source = self#set_p prop_source
    method source = self#get_p prop_source
    method css_rules ?base (load_resource:Types.load_resource) xml =
      match self#source with
      | Document base_rules ->
          let base = match base with None -> Iri.of_string "" | Some i -> i in
          let%lwt css = css_of_doc load_resource base xml in
          Lwt.return (base_rules @ rules_of_css css)
      | Rules rules ->
          Lwt.return rules
  end

let style ?props () = new style ?props ()

let default_xhtml_css = Css.parse_css [%blob "xml/default_xhtml.css"]

OCaml

Innovation. Community. Security.