Source file sp.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Statement parsers. *)

open Angstrom
open T
open U
open Vp
open S
(* force link to shorthand *)
let () = Sh.register ()

let block_ left right p ctx =
  left ctx *> p ctx <* ws ctx <* right ctx

let skip_to_next_prop = skip_while (fun c -> c <> ';' && c <> '}')
let skip_to_next_selector = skip_while (fun c -> c <> ',' && c <> '{')

let check_no_more_prop_value ctx =
  ws ctx *>  peek_char >>= (function
   | Some (';'|'}') -> return ()
   | Some c -> fail (Printf.sprintf "unexpected char %c" c)
   | _ -> fail ""
  )

let check_no_more_selector_def ctx =
  ws ctx *>  peek_char >>= (function
   | Some (','|'{') -> return ()
   | Some c -> fail (Printf.sprintf "unexpected char %c" c)
   | _ -> fail ""
  )

let qname ctx = (ws ctx *>
   U.with_loc ctx
     (option "" (ident ctx <* pipe ctx >>| fun (i,_) -> i) >>= fun ns ->
       ident ctx >>| fun (i,_) ->
          (*U.debug (fun m -> m "qname parsed: %s|%s" ns i);*)
        (ns,i))
 ) <?> "qname"

let ident_or_star ctx = ws ctx *> ((ident ctx >>| fst) <|> Angstrom.string "*")

let revert_selector =
  let rec iter f left_ss = function
    | `Single ss -> f (Single left_ss) ss
    | `Child (ss0, s) ->
        let f s ss = Child (f s ss0, ss) in
        iter f left_ss s
    | `Adjacent (ss0, s) ->
        let f s ss = Adjacent (f s ss0, ss) in
        iter f left_ss s
    | `Sibling (ss0, s) ->
        let f s ss = Sibling (f s ss0, ss) in
        iter f left_ss s
    | `Inside (ss0,s) ->
        let f s ss = Inside (f s ss0, ss) in
        iter f left_ss s
  in
  function
  | `Single s -> Single s
  | `Child (ss, s) -> iter (fun s ss -> Child (s, ss)) ss s
  | `Adjacent (ss, s) -> iter (fun s ss -> Adjacent (s, ss)) ss s
  | `Sibling (ss, s) -> iter (fun s ss -> Sibling (s, ss)) ss s
  | `Inside (ss, s) -> iter (fun s ss -> Inside (s, ss)) ss s

let sel_qname ctx = (ws ctx *>
   U.with_loc ctx
     (
      option "" ((ident_or_star ctx) <* pipe ctx) >>= fun ns ->
        (*debug ctx (fun m -> m "sel_qname: ns=%S" ns);*)
        (ident_or_star ctx) >>|
          (fun i ->
             (*Vp.debug ctx (fun m -> m "qname parsed: %s|%s" ns i);*)
             (ns,i)
          )
     )
  ) <?> "sel_qname"

let sel_id ctx = ( ws ctx *> with_loc ctx (sharp ctx *> ident ctx >>| fst) ) <?> "selector_id"

let sel_pseudo_class ctx selector =
  ( ws ctx *> with_loc ctx (colon ctx >>= fun _ ->
      choice [
        (Angstrom.string "not" *>
         block_ lpar rpar (fun _ -> selector) ctx >>| fun sel -> `Not (revert_selector sel)) ;
        (Angstrom.string "lang" *>
         block_ lpar rpar ident ctx >>| fun (i,_) -> `Lang i) ;
        (Angstrom.string "nth-child" *>
         block_ lpar rpar integer ctx >>| fun n -> `Nth_child n) ;
        (Angstrom.string "nth-last-child" *>
         block_ lpar rpar integer ctx >>| fun n -> `Nth_last_child n) ;
        (Angstrom.string "nth-of-type" *>
         block_ lpar rpar integer ctx >>| fun n -> `Nth_of_type n) ;
        (ident ~of_fun:true ctx >>= fun (i,_) ->
           match S.pseudo_class_of_string i with
           | Some x -> return x
           | None ->
               opt_ (Vp.fun_args ctx) >>= function
               | None -> return (`Other i)
               | Some args -> return (`Other (Printf.sprintf "%s(%s)" i args))
        ) ;
      ]
   )
  ) <?> "selector_pseudo_class"

let sel_pseudo_elt ctx =
  ( ws ctx *> with_loc ctx
   (colon ctx *> char ':' *>
    ident ~of_fun:true ctx >>= fun (name,_) ->
      choice [
        (block_ (fun _ctx -> char '(') rpar Vp.declaration_value ctx >>=
         fun args -> return (name, Some args));
        return (name, None)
      ]
   )
  ) <?> "selector_pseudo_elt"

let sel_attr_value ctx qn =
  (*prerr_endline (Printf.sprintf "sel_attr_expr_qname");*)
  let v op = choice [
      (string ctx >>| fun s -> s.s) ;
      (ident ctx >>| fst)
    ] >>= fun s ->
     choice [
      (ws ctx *> Angstrom.(char 'i' <|> char 'I') *>
       peek_char >>= function
       | Some ']' -> return { v=s; op; case_sensitive=false } ;
       | _ -> return { v=s; op; case_sensitive=true } ;
      ) ;
      return { v=s; op; case_sensitive=true } ;
    ]
  in
  ws ctx *> choice Angstrom.[
    (string "=" *> v Exact) ;
    (string "~=" *> v Exact_list) ;
    (string "|=" *> v Hyphen) ;
    (string "^=" *> v Prefix) ;
    (string "$=" *> v Suffix) ;
    (string "*=" *> v Contain) ;
  ] >>| fun v -> Attr_value (qn, v)

let sel_attr ctx = (
   ws ctx *> qname ctx >>= (fun (qn,_) ->
      choice [
        (sel_attr_value ctx qn) ;
        return (Attr_present qn)
      ]
   )
  ) <?> "sel_attr"

let sel_attribute ctx = (
  with_loc ctx
     (choice [
        (char '.' *> ident ctx >>| fun (i,_) ->
           Attr_value (("","class"), { v=i; op=Exact_list; case_sensitive=true})
        );
        (* do not use lbracket as block delimiter, because it accept spaces ahead
           and attribute must not be separated from selector by a space *)
        block_ (fun _ctx -> char '[') rbracket sel_attr ctx ;
      ]
     )
  ) <?> "sel_attribute"

let sel_attributes ctx = many (sel_attribute ctx)

let rec subclass_selector ctx sel (acc_id, acc_a, acc_pc) =
  choice [
     (sel_id ctx >>= fun sel_id -> subclass_selector ctx sel (Some sel_id,acc_a,acc_pc)) ;
     (sel_attribute ctx >>= fun a -> subclass_selector ctx sel (acc_id,a::acc_a, acc_pc)) ;
     (sel_pseudo_class ctx sel >>= fun pc -> subclass_selector ctx sel (acc_id,acc_a, pc::acc_pc)) ;
     (return (acc_id,acc_a, acc_pc))
   ] <?> "subclass_selector"

let single_selector ctx sel =
  opt_ (with_loc ctx (sel_qname ctx)) >>= fun qname ->
    subclass_selector ctx sel (None,[],[]) >>= fun (sel_id,sel_attr,sel_pseudo_class) ->
    opt_ (sel_pseudo_elt ctx) >>= fun sel_pseudo_elt ->
  let sel_qname = Option.map fst qname in
  let sel = {
      sel_qname ;
      sel_attr ;
      sel_id ;
      sel_pseudo_class ;
      sel_pseudo_elt ;
    }
  in
  (*check_no_more_selector_def ctx >>= fun () ->*)
  if S.selector_is_empty sel then
    fail "empty selector"
  else return sel

let selector_ ctx =
  fix (fun sel -> ws ctx *>
     choice [
       (single_selector ctx sel <* gt ctx >>= fun s1 -> sel >>| fun s2 -> `Child (s1, s2)) ;
       (single_selector ctx sel <* plus ctx >>= fun s1 -> sel >>| fun s2 -> `Adjacent (s1, s2)) ;
       (single_selector ctx sel <* tilde ctx >>= fun s1 -> sel >>| fun s2 -> `Sibling (s1, s2)) ;
       (single_selector ctx sel <* take_while1 U.is_ws >>= fun s1 -> sel >>| fun s2 -> `Inside (s1, s2)) ;
       (single_selector ctx sel >>| fun s -> `Single s) ;
     ]
  ) <?> "selector"

let selector ctx =
  (with_loc ctx (selector_ ctx) >>| fun (s, loc) -> (revert_selector s, loc))

let selectors ctx = (
   sep_by1 (U.comma ctx) (selector ctx)
  ) <?> "selectors"


let prop_value prop_space prop_name ?(start=Lexing.dummy_pos) decls ctx =
  let module Space = (val prop_space:P.Prop_space) in
  match  Space.parse_and_add_by_name prop_name with
  | None -> return `Unknown_property
  | Some f ->
      ws ctx *>
        choice [
          (f ctx start P.empty >>= fun t ->
             let bindings = P.to_list t in
             return (`Bindings (decls @ bindings))
          ) ;
          (return `Parse_error)
        ]

let rec declaration prop_space ctx decls = (ws ctx *>
   choice [
     (ident ctx <* colon ctx <* ws ctx >>= fun (prop_name, loc) ->
        ctx.get_pos >>= fun start ->
          prop_value prop_space prop_name ~start decls ctx >>= function
          | `Unknown_property ->
              U.warn
                (fun m -> m "%sUnknown property %S" (ctx.string_of_loc loc) prop_name);
              skip_to_next_prop >>| (fun () -> decls)
          | `Parse_error ->
              (skip_to_next_prop >>= fun () ->
                 U.warn (fun m -> m "%scould not parse value for property %S"
                    (ctx.string_of_loc (start, start)) prop_name);
                 return decls)
          | `Bindings decls ->
              check_no_more_prop_value ctx >>= fun () ->
                return decls
     );
     (char ';' >>= fun _ ->
       ctx.get_pos >>=
         (fun start ->
            Log.warn (fun m -> m "%a: ignoring ';'" T.pp_loc (start,start));
            return decls));
   ]
  ) <?> "declaration"

and declarations prop_space ctx acc =
  declaration prop_space ctx acc >>=
    fun acc ->
      ws ctx *> peek_char >>= function
      | Some ';' -> (advance 1 >>= fun () -> declarations prop_space ctx acc <|> return acc)
      | _ -> return acc

and declaration_block prop_space ctx =
  ws ctx *> block_ lbrace rbrace
    (fun ctx -> choice [
       (option [] (declarations prop_space ctx []) >>= fun decls ->
            sep_by (ws ctx) (U.with_loc ctx (nested_rule prop_space ctx)) >>= fun nested ->
              return (decls, nested)
         ) ;
       (ws ctx >>| fun _ -> ([], [])) ;
     ]
    ) ctx

and rule prop_space ctx = (ws ctx *>
   selectors ctx >>=
     fun sel -> declaration_block prop_space ctx >>|
       fun (decls, nested) -> { sel ; decls ; nested }
  ) <?> "rule"


and nested_rule_rel ctx = ws ctx *>
  (choice [
     (char '&' *> ws ctx >>= function "" -> return `Add_to_parent | _ -> fail "not add_to_parent") ;
     (opt_ (char '&') *> ws ctx *>
      choice [
         (char '>' *> ws ctx *> return `Child) ;
         (char '+' *> ws ctx *> return `Adjacent) ;
         (char '~' *> ws ctx *> return `Sibling) ;
         (return `Inside) ;
       ]
     )
   ]
  ) <?> "nested_rule_rel"
and nested_rule prop_space ctx : string nested_rule_ Angstrom.t =
  (nested_rule_rel ctx >>= fun rel ->
     selector ctx >>= fun sel ->
       U.with_loc ctx (declaration_block prop_space ctx) >>|
       fun ((decls, nested), loc) -> (rel, ({ sel = [sel]; decls ; nested }, loc))
  )<?> "nested_rule"

let url_string ctx = (ws ctx *>
  string ctx >>= Vp.iri_of_string ctx >>= fun iri -> return (`Iri iri)
  ) <?> "url_string"
let url_or_string ctx = Vp.url ctx <|> url_string ctx

let at_namespace ctx = (
   let url i = url_or_string ctx <* U.semicolon ctx >>| fun url -> Namespace(i,url) in
   Angstrom.string "@namespace" *> ws ctx *>
     choice [
       (url None) ;
       (ident ctx >>= fun (i,_) -> url (Some i))
     ]
 ) <?> "@namespace"

let at_charset ctx = (
   Angstrom.string "@charset" *> ws ctx *> Vp.delim_string '"' ctx <* U.semicolon ctx >>|
     fun cs -> Charset cs.s
  ) <?> "@charset"


let layer_name ctx = (sep_by1 (char '.') (ident ctx) >>| fun l -> List.map fst l)

let at_import_layer ctx = ( ws ctx *>
    (Angstrom.string "layer" *>
     choice [
       (ws ctx *> block_ lpar rpar layer_name ctx >>| fun l -> Some l);
       return (Some [])
     ]
   ) <|> return None
  ) <?> "@import_layer"
let at_import ctx = (
   Angstrom.string "@import" >>= fun _ ->
     U.debug (fun m -> m "parsing @@import");
     choice [
       (ws ctx *> url_or_string ctx >>= fun iri ->
          U.debug (fun m -> m "@@import %s" (T.string_of_url iri));
         at_import_layer ctx >>= fun layer ->
            ws ctx *> Angstrom.take_while ((<>) ';') <* U.semicolon ctx >>= fun rest ->
          if rest <> "" then U.warn (fun m -> m "ignoring import arguments: %s" rest);
          return (Import (iri, layer, None))
       );
       (pos >>= fun _ ->
          parse_error_at ctx (Other "bad import arguments")
       );
     ]
  ) <?> "@import"

let media_type ctx : S.media_type Angstrom.t =
  ws ctx *> Angstrom.option () (Angstrom.string "only" *> return ()) *> of_kws S.media_types ctx

let media_feature_name = ident

let media_feature_value ctx =
  choice [
    (Vp.ident ctx >>= fun i -> return (`Ident i)) ;
    (Vp.dimension ctx >>= fun d -> return (`Dim d));
    (Vp.ratio ctx >>= fun r -> return (`Ratio r)) ;
    (Vp.number ctx >>= fun n -> return (`Number n)) ;
  ]

let media_feature_range =
  let n = media_feature_name in
  let v = media_feature_value in
  fun ctx ->
    choice [
      (v ctx >>= fun v1 -> lt ctx *> n ctx >>= fun n ->
         choice [
           (lt ctx *> v ctx >>= fun v2 -> return (n, `Gt_lt (v1, v2))) ;
           (lte ctx *> v ctx >>= fun v2 -> return (n, `Gt_lte (v1, v2))) ;
         ]
      );
      (v ctx >>= fun v1 -> lte ctx *> n ctx >>= fun n ->
         choice [
           (lt ctx *> v ctx >>= fun v2 -> return (n, `Gte_lt (v1, v2))) ;
           (lte ctx *> v ctx >>= fun v2 -> return (n, `Gte_lte (v1, v2))) ;
         ]
      );
      (v ctx >>= fun v2 -> gt ctx *> n ctx >>= fun n ->
         choice [
           (gt ctx *> v ctx >>= fun v1 -> return (n, `Gt_lt (v1, v2))) ;
           (gte ctx *> v ctx >>= fun v1 -> return (n, `Gt_lte (v1, v2))) ;
         ]
      );
      (v ctx >>= fun v2 -> gte ctx *> n ctx >>= fun n ->
         choice [
           (gt ctx *> v ctx >>= fun v1 -> return (n, `Gt_lt (v1, v2))) ;
           (gte ctx *> v ctx >>= fun v1 -> return (n, `Gt_lte (v1, v2))) ;
         ]
      );

      (n ctx >>= fun n -> lt ctx >>= fun _ -> v ctx >>= fun v -> return (n, `Lt v)) ;
      (n ctx >>= fun n -> lte ctx *> v ctx >>= fun v -> return (n, `Lte v)) ;
      (n ctx >>= fun n -> gt ctx *> v ctx >>= fun v -> return (n, `Gt v)) ;
      (n ctx >>= fun n -> gte ctx *> v ctx >>= fun v -> return (n, `Gte v)) ;

      (v ctx >>= fun v -> lt ctx *> n ctx >>= fun n -> return (n, `Gt v)) ;
      (v ctx >>= fun v -> lte ctx *> n ctx >>= fun n -> return (n, `Gte v)) ;
      (v ctx >>= fun v -> gt ctx *> n ctx >>= fun n -> return (n, `Lt v)) ;
      (v ctx >>= fun v -> gte ctx *> n ctx >>= fun n -> return (n, `Lte v)) ;
    ]

let media_feature ctx : S.media_feature Angstrom.t =
  lpar ctx *> ws ctx >>= fun _ ->
    choice [
    (media_feature_range ctx >>= fun (name, r) -> return (name, `Range r)) ;
    (media_feature_name ctx >>= fun name ->
       choice [
         (colon ctx >>= fun _ -> media_feature_value ctx >>= fun v -> return (`Value v)) ;
         (ws ctx >>= fun _ -> return `Present) ;
       ] >>= fun f -> return (name, f)) ;
  ] >>= fun f -> rpar ctx *> return (S.media_feature_map_min_max f)


let rec media_condition ctx : S.media_condition Angstrom.t =
  ws ctx >>= fun _ ->
    choice [
    (media_condition_and ctx >>= fun c -> return c);
    (media_condition_or ctx >>= fun c -> return c);
    (media_condition_not ctx >>= fun c -> return c);
  ]

and media_condition_or ctx : S.media_condition Angstrom.t =
  (ws ctx >>= fun _ ->
     choice [
       (media_feature ctx >>= fun f -> ws ctx *> Angstrom.string "or" *>
          media_condition_or ctx >>= fun c -> return (`Or (`Feature f, c)) );
       (media_feature ctx >>= fun f -> return (`Feature f)) ;
       (lpar ctx *> media_condition ctx >>= fun c -> rpar ctx *> return c);
       (media_condition_not ctx >>= fun c -> return c) ;
  ]
  ) <?> "media_condition_or"

and media_condition_and ctx : S.media_condition Angstrom.t =
  (ws ctx >>= fun _ ->
     choice [
       (media_feature ctx >>= fun f -> ws ctx *> Angstrom.string "and" *>
          media_condition_and ctx >>= fun c -> return (`And (`Feature f, c)) );
       (media_feature ctx >>= fun f -> return (`Feature f)) ;
       (lpar ctx *> media_condition ctx >>= fun c -> rpar ctx *> return c);
       (media_condition_not ctx >>= fun c -> return c) ;
  ]
  ) <?> "media_condition_and"

and media_condition_not ctx : S.media_condition Angstrom.t =
  (ws ctx >>= fun _ ->
   choice [
     (Angstrom.string "not" *> media_feature ctx >>= fun f -> return (`Not (`Feature f)) ) ;
     (Angstrom.string "not" >>= fun _ -> lpar ctx >>= fun _ ->
        media_condition ctx >>= fun c -> rpar ctx *> return (`Not c) );
   ]
  ) <?> "media_condition_not"

let media_query ctx =
  (ws ctx *> Angstrom.option false (Angstrom.string "not" *> ws ctx *> return true) >>=
   fun negated -> choice Angstrom.[
       (media_type ctx >>= fun media_type -> ws ctx *> string "and" *>
          media_condition ctx >>= fun media_condition ->
            return S.{ negated ;
              media_type = Some media_type ;
              media_condition = Some media_condition }) ;
       (media_type ctx >>= fun media_type ->
          return S.{ negated ;
            media_type = Some media_type;
            media_condition = None }) ;
       (media_condition ctx >>= fun media_condition ->
          return S.{ negated ;
            media_type = None ;
            media_condition = Some media_condition }) ;
     ]
) <?> "media_query"

let media_query_list ctx = Angstrom.sep_by1 (comma ctx) (media_query ctx)

let rec at_layer prop_space ctx = (
    Angstrom.string "@layer" *> ws ctx >>= fun _ -> (* beware than changing to [ws ctx *>] makes angstrom loop *)
     choice [
       (block_ lbrace rbrace (statements prop_space) ctx >>| fun l -> Layer ([], l)) ;
       (layer_name ctx >>= fun layer -> ws ctx *>
          (block_ lbrace rbrace (statements prop_space) ctx) >>| fun l ->
            Layer ([layer], l) );
       (sep_by (comma ctx) (layer_name ctx) <* ws ctx <* semicolon ctx >>| fun l -> Layer (l, [])) ;
     ]
  ) <?> "@layer"

and at_media prop_space ctx = (
   Angstrom.string "@media" *> ws ctx >>= fun _ ->
     choice [
       (media_query_list ctx >>= fun query_list ->
         ws ctx *>
           block_ lbrace rbrace (statements prop_space) ctx >>|
           fun stmts -> Media (query_list, stmts)) ;
       (take_till ((=) '}') >>= fun str -> rbrace ctx >>= fun _ ->
          Log.warn (fun m -> m "Could not parse @media: %s}" str);
          return (Media ([],[]))) ;
     ]
  ) <?> "@media"

and at_other prop_space ctx = (
  Angstrom.char '@' *> ident ~of_fun:true ctx <* ws ctx >>= fun (i,_) ->
     U.warn (fun m -> m "@%s ignored (not implemented)" i) ;
     skip_while ((<>) '{') *>
       choice [
         (ws ctx *> block_ lbrace rbrace (statements prop_space) ctx >>| fun _ -> ());
         (declaration_block prop_space ctx >>| fun _ -> ())
       ] >>| fun _ -> Other i
  ) <?> "@<other>"

and at_rule prop_space ctx = (ws ctx *>
   choice [
     at_charset ctx ;
     at_import ctx ;
     at_layer prop_space ctx ;
     at_media prop_space ctx ;
     at_namespace ctx ;
     at_other prop_space ctx ;
   ]
  ) <?> "at_rule"

and statement prop_space ctx = (ws ctx *>
   choice [
     (U.with_loc ctx (at_rule prop_space ctx) >>| fun (r,loc) -> At_rule (r, loc)) ;
     (U.with_loc ctx (rule prop_space ctx) >>| fun (r,loc) -> Rule (r, loc)) ;
     fail "end"
   ] >>= fun r -> commit >>| fun () ->
     Log.debug (fun m -> m "statement parsed: %a" (S.pp_statement snd) r);
     r
  ) <?> "statement"

and statements prop_space ctx =
  sep_by (ws ctx) (statement prop_space ctx)