Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Page
Library
Module
Module type
Parameter
Class
Class type
Source
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"]