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 =
  ws 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) ;
        (ident 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 ctx >>| fst) ) <?> "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 = (ws ctx *>
  with_loc ctx
     (choice [
        (char '.' *> ident ctx >>| fun (i,_) ->
           Attr_value (("","class"), { v=i; op=Exact_list; case_sensitive=true})
        );
        block_ lbracket rbracket sel_attr ctx ;
      ]
     )
  ) <?> "sel_attribute"

let sel_attributes ctx = many (sel_attribute ctx)

let single_selector ctx sel =
  opt_ (with_loc ctx (sel_qname ctx)) >>= fun qname ->
    opt_ (sel_id ctx) >>= fun sel_id ->
    (sel_attributes ctx) >>= fun sel_attr ->
    many (sel_pseudo_class ctx sel) >>= fun 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 <* ws ctx >>= 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 rec declaration prop_space ctx decls = (ws ctx *>
   ident ctx <* colon ctx <* ws ctx >>= fun (propname, loc) ->
     ctx.get_pos >>= fun start ->
     let module Space = (val prop_space:P.Prop_space) in
     match Space.parse_and_add_by_name propname with
     | None ->
         U.warn
           (fun m -> m "%sUnknown property %S" (ctx.string_of_loc loc) propname);
         skip_to_next_prop >>| (fun () -> decls)
     | Some f ->
         (* we miss some way to access why a parser failed *)
         choice [
           (f ctx start P.empty >>= fun t ->
              check_no_more_prop_value ctx >>| fun () ->
              let bindings = P.to_list t in
              decls @ bindings
              ) ;
           (skip_to_next_prop >>= fun () ->
              U.warn (fun m -> m "%scould not parse value for property %S"
                 (ctx.string_of_loc (start, start)) propname);
              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 =
  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 at_namespace ctx = (
   let url i =  Vp.url_or_string ctx <* U.semicolon ctx >>| fun iri -> Namespace (i, iri) 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 [
       (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 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 _ ->
     U.warn (fun m -> m "@media condition not parsed (not implemented)") ;
     take_while ((<>) '{') >>= fun cond ->
       block_ lbrace rbrace (statements prop_space) ctx >>|
       fun stmts -> Media (cond, stmts)
  ) <?> "@media"

and at_other prop_space ctx = (
  Angstrom.char '@' *> ident ctx <* ws ctx >>= fun (i,_) ->
     U.warn (fun m -> m "@%s ignored (not implemented)" i) ;
     skip_while ((<>) '{') *>
       choice [
         (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)