Source file s.ml

(*********************************************************************************)
(*                OCaml-CSS                                                      *)
(*                                                                               *)
(*    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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Statements. *)

open T

let rec pp_list sep pp ppf = function
| [] -> ()
| [x] -> pp ppf x
| x :: q -> Format.fprintf ppf "%a%s%a" pp x sep (pp_list sep pp) q

type 'a qname = 'a * string

type attr_value_operator =
  | Exact (* [attr=value] *)
  | Exact_list (* [attr~=value] *)
  | Hyphen (* [attr|=value] *)
  | Prefix (* [attr^=value] *)
  | Suffix  (* [attr$=value] *)
  | Contain (* [attr*=value] *)

type attr_value =
  { v:string;
    op: attr_value_operator ;
    case_sensitive : bool ;
  }
type 'ns attr_selector =
| Attr_present of 'ns qname
| Attr_value of 'ns qname * attr_value

type 'ns pseudo_class = [
| `Active | `Default | `Disabled | `Empty | `Enabled
| `First_child | `First_of_type | `Focus | `Fullscreen
| `Hover | `In_range | `Indeterminate | `Invalid
| `Lang of string | `Last_child | `Last_of_type | `Link
| `Not of 'ns selector | `Nth_child of int
| `Nth_last_child of int
| `Nth_last_of_type | `Nth_of_type
| `Only_of_type | `Only_child | `Optional
| `Out_of_range | `Read_only | `Read_write
| `Required | `Root | `Target | `Valid | `Visited
| `Other of string
]

and 'ns single_selector =
  {
    sel_qname : 'ns qname with_loc option ;
    sel_attr : 'ns attr_selector with_loc list ;
    sel_id : string with_loc option ;
    sel_pseudo_class : ('ns pseudo_class with_loc) list ;
    sel_pseudo_elt : string with_loc option ;
  }

and 'ns selector =
| Single of 'ns single_selector
| Inside of 'ns selector * 'ns single_selector
| Child of 'ns selector * 'ns single_selector
| Adjacent of 'ns selector * 'ns single_selector
| Sibling of 'ns selector * 'ns single_selector

let pseudo_class_kws : 'a pseudo_class list = [
    `Active ; `Default ; `Disabled ; `Empty ; `Enabled ;
    `First_child ; `First_of_type ; `Focus ; `Fullscreen ;
    `Hover ; `In_range ; `Indeterminate ; `Invalid ;
    `Last_child ; `Last_of_type ; `Link ;
    `Nth_last_of_type ; `Nth_of_type ;
    `Only_of_type ; `Only_child ; `Optional ; `Out_of_range ;
    `Read_only ; `Read_write ; `Required ; `Root ;
    `Target ; `Valid ; `Visited ]

let selector_is_empty s =
  match s.sel_qname, s.sel_id, s.sel_attr, s.sel_pseudo_class, s.sel_pseudo_elt with
  | None, None, [], [], None -> true
  | _ -> false

type nested_rule_rel = [ `Add_to_parent | `Inside | `Child | `Adjacent | `Sibling ]
let string_of_nested_rule_rel : nested_rule_rel -> string = function
| `Add_to_parent -> ""
| `Inside -> " "
| `Child -> " > "
| `Adjacent -> " + "
| `Sibling -> " ~ "

type 'ns rule_ =
  { sel : 'ns selector with_loc list ;
    decls : P.binding list ;
    nested : 'ns nested_rule list ;
  }
and 'ns rule = 'ns rule_ with_loc
and 'ns nested_rule_ = nested_rule_rel * 'ns rule
and 'ns nested_rule = 'ns nested_rule_ with_loc

let string_of_attr_value (v:attr_value) =
  let str_v = T.(string_of_str { s = v.v; quoted = true }) in
  let str_op =
  match v.op with
  | Exact -> "="
  | Exact_list -> "~="
  | Hyphen -> "|="
  | Prefix -> "^="
  | Suffix -> "$="
  | Contain -> "*="
  in
  Printf.sprintf "%s%s" str_op str_v

let string_of_attr_selector string_of_qname = function
| Attr_present name -> Printf.sprintf "[%s]" (string_of_qname name)
| Attr_value ((_,"class"), { op=Exact ; v ; case_sensitive = true}) -> Printf.sprintf ".%s" v
| Attr_value (name,v) -> Printf.sprintf "[%s%s%s]"
  (string_of_qname name) (string_of_attr_value v)
  (if v.case_sensitive then "" else " i")

let string_of_attr_selector_list string_of_qname l =
  String.concat "" (List.map
   (fun (a,_loc) -> string_of_attr_selector string_of_qname a) l)

let rec string_of_single_selector string_of_qname s =
  Printf.sprintf "%s%s%s%s%s"
    (match s.sel_qname with None -> "" | Some (q,_) -> string_of_qname q)
    (match s.sel_id with None -> "" | Some (id,_) -> "#"^id)
    (string_of_attr_selector_list string_of_qname s.sel_attr)
    (String.concat ""
     (List.map (fun (c,_loc) ->
         Printf.sprintf ":%s" (string_of_pseudo_class string_of_qname c))
      s.sel_pseudo_class)
     )
    (match s.sel_pseudo_elt with
     | None -> ""
     | Some (s,_) -> Printf.sprintf "::%s" s)

and string_of_selector string_of_qname = function
| Single s -> string_of_single_selector string_of_qname s
| Inside (s, ss) -> Printf.sprintf "%s %s"
  (string_of_selector string_of_qname s)
  (string_of_single_selector string_of_qname ss)
| Child (s, ss) -> Printf.sprintf "%s > %s"
  (string_of_selector string_of_qname s)
  (string_of_single_selector string_of_qname ss)
| Adjacent (s, ss) -> Printf.sprintf "%s + %s"
  (string_of_selector string_of_qname s)
  (string_of_single_selector string_of_qname ss)
| Sibling (s, ss) -> Printf.sprintf "%s ~ %s"
  (string_of_selector string_of_qname s)
  (string_of_single_selector string_of_qname ss)

and string_of_selector_ string_of_qname (s,_loc) =
  string_of_selector string_of_qname s

and string_of_pseudo_class string_of_qname = function
| `Active -> "active"
| `Default -> "default"
| `Disabled -> "disabled"
| `Empty -> "empty"
| `Enabled -> "enabled"
| `First_child -> "first-child"
| `First_of_type -> "first-of-type"
| `Focus -> "focus"
| `Fullscreen -> "fullscreen"
| `Hover -> "hover"
| `In_range -> "in-range"
| `Indeterminate -> "indeterminate"
| `Invalid -> "invalid"
| `Lang str -> Printf.sprintf "lang(%s)" str
| `Last_child -> "last-child"
| `Last_of_type -> "last-of-type"
| `Link -> "link"
| `Not sel -> Printf.sprintf "not(%s)" (string_of_selector string_of_qname sel)
| `Nth_child n -> Printf.sprintf "nth-child(%d)" n
| `Nth_last_child n -> Printf.sprintf "nth-last-child(%d)" n
| `Nth_last_of_type -> "nth-last-of-type"
| `Nth_of_type -> "nth-of-type"
| `Only_of_type -> "only-of-type"
| `Only_child -> "only-child"
| `Optional -> "optional"
| `Out_of_range -> "out-of-range"
| `Read_only -> "read-only"
| `Read_write -> "read-write"
| `Required -> "required"
| `Root -> "root"
| `Target -> "target"
| `Valid -> "valid"
| `Visited -> "visited"
| `Other str -> str

let pseudo_class_of_string =
  T.mk_of_string ~case_sensitive:false
    (string_of_pseudo_class
     (fun (ns,s) -> match ns with "" -> s | _ -> Printf.sprintf "%s|%s" ns s)
    )
    pseudo_class_kws

let pp_decl ppf = function
| P.B (prop, {v ; important}) ->
    Format.fprintf ppf "%s: %s%s ;"
      (P.name prop)
      (P.value_to_string prop v)
      (if important then " !important" else "")

let pp_decls ppf l = List.iter (fun d -> Format.fprintf ppf "%a@\n" pp_decl d) l

let rec pp_rule_ string_of_qname ppf r =
  Format.pp_open_vbox ppf 2 ;
  Format.fprintf ppf "%s {@\n"
    (String.concat ", "
     (List.map (string_of_selector_ string_of_qname) r.sel));
  pp_decls ppf r.decls ;
  (match r.nested with
   | [] -> ()
   | l ->
       List.iter (pp_nested_rule string_of_qname ppf) l
  );
  Format.fprintf ppf "@]}@\n"

and pp_rule string_of_qname ppf (r, _loc) =
  pp_rule_ string_of_qname ppf r

and pp_nested_rule string_of_qname ppf ((rel, r), _) =
  Format.fprintf ppf "&%s%a"
    (string_of_nested_rule_rel rel) (pp_rule string_of_qname) r

type media_condition = string

let pp_media_cond ppf str = Format.pp_print_string ppf str

type import_conditions = unit
type layer_name = string list
let pp_layer_name = pp_list "." Format.pp_print_string
let pp_layer_names = pp_list ", " pp_layer_name

type 'ns at_rule_ =
| Charset of string
| Import of Iri.t * layer_name option * import_conditions option
| Layer of layer_name list * 'ns statement list
| Media of media_condition * 'ns statement list
| Namespace of string option * Iri.t
| Other of string

and 'ns at_rule = 'ns at_rule_ * loc

and 'ns statement =
| Rule of 'ns rule
| At_rule of 'ns at_rule

let rec pp_at_rule_ string_of_qname ppf r =
  match r with
  | Charset cs -> Format.fprintf ppf "@@charset %S;@\n" cs
  | Import (iri, layer, cond) ->
      Format.fprintf ppf "@@import %s" (T.string_of_url iri);
      (match layer with
       | None -> ()
       | Some [] -> Format.pp_print_string ppf " layer"
       | Some l -> Format.fprintf ppf " layer(%a)" pp_layer_name l);
      Format.fprintf ppf ";@\n"
  | Layer (names, stmts) ->
      if stmts <> [] then Format.pp_open_vbox ppf 2 ;
      Format.fprintf ppf "@@layer";
      (match names with
       | [] -> ()
       | _ -> Format.fprintf ppf " %a" pp_layer_names names );
      (match stmts with
       | [] -> Format.fprintf ppf ";@\n"
       | _ ->
           Format.fprintf ppf " {@\n%a@]}@\n"
             (pp_statement_list string_of_qname) stmts
      );
  | Media (cond, stmts) ->
      Format.pp_open_vbox ppf 2 ;
      Format.fprintf ppf "@@media %a {" pp_media_cond cond;
      Format.fprintf ppf "@\n%a@]}@\n"
        (pp_statement_list string_of_qname) stmts
  | Namespace (p, iri) ->
      Format.fprintf ppf "@@namespace %s%s;@\n"
        (match p with None -> "" | Some s -> s^" ")
        (T.string_of_url iri)
  | Other _ -> ()

and pp_at_rule string_of_qname ppf (r, _) =
  pp_at_rule_ string_of_qname ppf r

and pp_statement string_of_qname ppf = function
| Rule r -> pp_rule string_of_qname ppf r
| At_rule r -> pp_at_rule string_of_qname ppf r

and pp_statement_list string_of_qname ppf l =
  List.iter (pp_statement string_of_qname ppf) l

module Smap = T.Smap

let empty_iri = Iri.of_string ""

let expand_qname ?(all=true) ns loc (n,ln) =
  try
    match n with
    | "" when not all -> (empty_iri, ln)
    | _ ->
        let base = Smap.find n ns in
        (base, ln)
  with
  | Not_found -> T.error (Undefined_namespace (n, loc))

let expand_attr_selector ns loc = function
| Attr_present qname -> Attr_present (expand_qname ~all:false ns loc qname)
| Attr_value (qname, v) -> Attr_value (expand_qname ~all:false ns loc qname, v)

let rec expand_pseudo_class ns = function
| `Not s -> `Not (expand_selector ns s)
| `Active | `Default | `Disabled | `Empty | `Enabled
| `First_child | `First_of_type | `Focus | `Fullscreen
| `Hover | `In_range | `Indeterminate | `Invalid
| `Lang _ | `Last_child | `Last_of_type | `Link
| `Nth_child _
| `Nth_last_child _
| `Nth_last_of_type | `Nth_of_type
| `Only_of_type | `Only_child | `Optional
| `Out_of_range | `Read_only | `Read_write
| `Required | `Root | `Target | `Valid | `Visited
| `Other _ as x -> x

and expand_single_selector (ns:Iri.t Smap.t) s =
    let sel_attr = List.map
      (fun (a,loc) -> (expand_attr_selector ns loc a, loc)) s.sel_attr
    in
    let sel_pseudo_class =
      List.map (fun (c,loc) -> expand_pseudo_class ns c, loc) s.sel_pseudo_class
    in
    {
      sel_qname = Option.map (fun (a,loc) -> (expand_qname ns loc a, loc)) s.sel_qname ;
      sel_attr ;
      sel_id = s.sel_id ;
      sel_pseudo_class ;
      sel_pseudo_elt = s.sel_pseudo_elt ;
    }

and expand_selector ns = function
| Single s -> Single (expand_single_selector ns s)
| Inside (s, ss) -> Inside (expand_selector ns s, expand_single_selector ns ss)
| Child (s, ss) -> Child (expand_selector ns s, expand_single_selector ns ss)
| Adjacent (s, ss) -> Adjacent (expand_selector ns s, expand_single_selector ns ss)
| Sibling (s, ss) -> Sibling (expand_selector ns s, expand_single_selector ns ss)

let rec expand_rule ns r =
  let sel = List.map (fun (s,loc) -> (expand_selector ns s, loc)) r.sel in
  let nested = List.map (fun ((rel,(r,locr)), loc) ->
       ((rel, (expand_rule ns r, locr)), loc)) r.nested
  in
  { r with sel ; nested }

let html_ns_iri = Iri.of_string "http://www.w3.org/1999/xhtml"
let math_ns = ("math", Iri.of_string "http://www.w3.org/1998/Math/MathML")
let svg_ns = ("svg", Iri.of_string "http://www.w3.org/2000/svg")

(** Default namespaces used when expanding namespaces in CSS.
  These consist in:
  {ul
   {- [""] mapped to ["http://www.w3.org/1999/xhtml"],}
   {- ["math"] mapped to ["http://www.w3.org/1998/Math/MathML"],}
   {- ["svg"] mapped to ["http://www.w3.org/2000/svg"].}
  }*)
let default_ns =
  List.fold_left (fun acc (name,iri) -> Smap.add name iri acc)
     (Smap.singleton "" html_ns_iri)
    [ math_ns ; svg_ns ]

let rec expand_at_rule :
  'a Smap.t -> string at_rule_ -> 'a Smap.t * 'a at_rule_  = fun ns -> function
| Namespace (p,iri) ->
    let ns =
      let s = match p with None -> "" | Some s -> s in
      Smap.add s iri ns
    in
    (ns, Namespace (p,iri))
| Layer (names, stmts) ->
    let stmts = expand_statement_list ~ns stmts in
    (ns, Layer (names, stmts))
| Media (cond, stmts) ->
    let stmts = expand_statement_list ~ns stmts in
    (ns, Media (cond, stmts))
| Charset c -> ns, Charset c
| Import (iri, name, cond) -> ns, Import (iri, name, cond)
| Other str -> ns, Other str


and expand_statement ns = function
| Rule (r, loc) -> ns, Rule (expand_rule ns r, loc)
| At_rule (r, loc) ->
    let (ns, r) = expand_at_rule ns r in
    (ns, At_rule (r, loc))

and expand_statement_list =
  let f (ns, acc) st =
    let (ns, st) = expand_statement ns st in
    (ns, st :: acc)
  in
  fun ?(ns=default_ns) l ->
    let (_ns, stmts) = List.fold_left f (ns, []) l in
    List.rev stmts

let expand_nested : 'a statement list -> 'a statement list =
  let warn loc str =
    Log.warn (fun m -> m "Expanding nested at %a: %s" T.pp_loc loc str)
  in
  let add_to_ss nested_ss ss =
    { ss with
      sel_attr = ss.sel_attr @ nested_ss.sel_attr ;
      sel_id = (match ss.sel_id with None -> nested_ss.sel_id | x -> x) ;
      sel_pseudo_class = ss.sel_pseudo_class @ nested_ss.sel_pseudo_class ;
      sel_pseudo_elt = nested_ss.sel_pseudo_elt ;
    }
  in
  let add_to_parent nested_ss loc (parent_sel,_) acc =
    match parent_sel with
    | Single ss | Inside (_,ss) | Child (_,ss)
    | Adjacent (_,ss) | Sibling (_,ss) when ss.sel_pseudo_elt <> None -> acc
    | _ ->
        let sel =
          match parent_sel with
          | Single ss -> Single (add_to_ss nested_ss ss)
          | Inside (s,ss) -> Inside (s, add_to_ss nested_ss ss)
          | Child (s,ss) -> Child (s, add_to_ss nested_ss ss)
          | Adjacent (s,ss) -> Adjacent (s, add_to_ss nested_ss ss)
          | Sibling (s,ss) -> Sibling (s, add_to_ss nested_ss ss)
        in
        (sel,loc) :: acc
  in
  let append_ f nested_ss loc (parent_sel,_) acc =
    (f parent_sel nested_ss, loc) :: acc
  in
  let append_inside x = append_ (fun s ss -> Inside (s,ss)) x in
  let append_child x = append_ (fun s ss -> Child (s,ss)) x in
  let append_adjacent x = append_ (fun s ss -> Adjacent (s,ss)) x in
  let append_sibling x = append_ (fun s ss -> Sibling (s,ss)) x in

  let rec exp_stmt acc = function
  | At_rule (r,loc) -> At_rule (exp_at_rule r, loc) :: acc
  | Rule (r, loc) ->
      let rules = exp_rule r in
      List.fold_left (fun acc r -> Rule(r, loc) :: acc) acc rules
  and exp_stmts l = List.fold_left exp_stmt [] l
  and exp_at_rule r =
    match r with
    | Namespace _ -> r
    | Layer (names, stmts) -> Layer (names, exp_stmts stmts)
    | Media (cond, stmts) -> Media (cond, exp_stmts stmts)
    | Charset _ | Import _ | Other _ -> r
  and exp_rule r =
    let r0 = { r with nested = [] } in
    let rules = List.map (fun ((rel,(subr,subrloc)), loc) ->
       match subr.sel with
       | [] -> warn loc "Nested rule has no selector"; []
       | (Single s,loc) :: q ->
             if q <> [] then warn loc "Handling only first selector of nested rule";
             let new_sel =
               match rel with
               | `Add_to_parent -> List.fold_right (add_to_parent s loc) r.sel []
               | `Inside -> List.fold_right (append_inside s loc) r.sel []
               | `Child -> List.fold_right (append_child s loc) r.sel []
               | `Adjacent -> List.fold_right (append_adjacent s loc) r.sel []
               | `Sibling -> List.fold_right (append_sibling s loc) r.sel []
              in
              let r = { subr with sel = new_sel } in
              exp_rule r
       | _ -> warn loc "Only single selectors handled in nested rules"; []
     ) r.nested
   in
   r0 :: (List.flatten rules)
  in
  fun l -> List.rev (exp_stmts l)