Source file style.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 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"]