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

(** Value parsers. *)

open Angstrom
open T
open U

let important ctx =
  choice [
    (ws ctx *> Angstrom.string "!important" >>| fun _ -> true);
    return false
  ]

let float_of_string str =
  try float_of_string str
  with Failure _ ->
      Log.err (fun m -> m "Invalid float: %s" str);
      0.0

let exponent_ ctx =
  char 'e' >>= fun _ -> option '+' (sign ctx) >>=
    fun sign -> take_while1 is_digit >>=
      fun str -> return (Printf.sprintf "e%c%s" sign str)

let exponent ctx = option "" (exponent_ ctx)

let number ctx : float Angstrom.t = (ws ctx *> option '+' (sign ctx) >>=
   (fun sign -> take_while is_digit >>=
      fun whole ->
        peek_char >>= function
        | None ->
            if whole = "" then
              fail ""
            else
              (let s = Printf.sprintf "%c%s" sign whole in
               return (float_of_string s)
              )
        | Some '.' ->
            (advance 1 >>= fun () ->
              take_while is_digit >>=
                 fun frac -> exponent ctx >>= fun exp ->
                   let s = Printf.sprintf "%c%s.%s%s" sign whole frac exp in
                   return (float_of_string s)
            )
        | Some c when whole = "" -> fail ""
        | _ ->
            exponent ctx >>= fun exp ->
              let s = Printf.sprintf "%c%s%s" sign whole exp in
              return (float_of_string s)
  )) <?> "number"

let ratio ctx : ratio Angstrom.t =
  number ctx >>= fun n1 -> slash ctx *> number ctx >>= fun n2 -> return (n1, n2)

(* https://www.w3.org/TR/css-syntax-3/#escaping *)
let escaped_codepoint first = take_while_upto is_hex 5 >>=
  fun s ->
    let s = Printf.sprintf "0x%c%s" first s in
    (
     peek_char >>= function
     | None -> return ()
     | Some ' ' -> (take_char >>| fun _ -> ())
     | Some _ -> return ()
    ) >>= fun () ->
    let uc = Uchar.of_int (int_of_string s) in
    return uc

let rec string_ delim ctx b esc = take_char >>= function
| None -> parse_error_at ctx Unterminated_string
| Some c ->
    (*prerr_endline (Printf.sprintf "char %C" c);*)
    match c with
    | _ when c = delim && not esc -> return (Buffer.contents b)
    | '\\' when not esc -> string_ delim ctx b true
    | '\\' when esc -> Buffer.add_char b c; string_ delim ctx b false
    | '\n' when esc -> string_ delim ctx b false
    | 'n' when esc -> Buffer.add_char b '\n'; string_ delim ctx b false
    | 'r' when esc -> Buffer.add_char b '\r'; string_ delim ctx b false
    | 't' when esc -> Buffer.add_char b '\t'; string_ delim ctx b false
    | _ when esc && is_hex c ->
        (escaped_codepoint c >>= fun uc ->
           Buffer.add_utf_8_uchar b uc;
           string_ delim ctx b false)
    | _ when esc -> fail (Printf.sprintf "Invalid escaping of character %c" c)
    | _ ->
        (*prerr_endline (Printf.sprintf "add_char %c" c);*)
        Buffer.add_char b c; string_ delim ctx b false

let delim_string delim ctx =
  ws ctx *> take_char >>= function
| Some c when c = delim ->
    let b = Buffer.create 256 in
    (*prerr_endline (Printf.sprintf "calling string_ %C" delim);*)
    string_ delim ctx b false >>| fun s -> T.{ s ; quoted = true }
| _ -> fail ""

let string ctx = ((delim_string '"' ctx) <|> (delim_string '\'' ctx)) <?> "string"

let is_unescaped_ident_char = function
| 'a'..'z' | 'A'..'Z'
| '0'..'9' | '-' | '_' -> true
| _ -> false

let rec ident_ ~of_fun ctx start_pos b esc = peek_char >>= function
| None when esc -> parse_error_at ctx Unterminated_char_escape
| Some '(' when not of_fun && not esc ->
    (* not an ident but a function, let's fail *)
    fail ""
| Some '\\' when not esc ->
    advance 1 >>= (fun () -> ident_ ~of_fun ctx start_pos b true)
| Some c when esc && is_hex c ->
    advance 1 >>= (fun () ->
       escaped_codepoint c >>= fun uc ->
         Buffer.add_utf_8_uchar b uc;
       ident_ ~of_fun ctx start_pos b false
    )
| Some c when esc ->
    advance 1 >>= (fun () -> Buffer.add_char b c; ident_ ~of_fun ctx start_pos b false)
| Some c when is_unescaped_ident_char c ->
    advance 1 >>= (fun () ->
       Buffer.add_char b c;
       ident_ ~of_fun ctx start_pos b false
    )
| None when not esc ->
    (ctx.get_pos >>= fun stop -> return ((Buffer.contents b), (start_pos, stop)))
| _ -> (ctx.get_pos >>= fun stop -> return ((Buffer.contents b), (start_pos, stop)))

let parse_ident ~of_fun ctx start_pos start =
  let b = Buffer.create 20 in
  start b ;
  ident_ ~of_fun ctx start_pos b false

let ident_hyphen ~of_fun ctx start_pos = take_char >>= function
| None -> fail "invalid_ident"
| Some '-' -> parse_ident ~of_fun ctx start_pos (fun b -> Buffer.add_string b "--")
| Some '0'..'9' -> fail "ident cannot start with -<digit>"
| Some '\\' ->
    (take_char >>= function
     | None -> parse_error_at ctx Unterminated_char_escape
     | Some c when is_hex c ->
         (escaped_codepoint c >>= fun uc ->
            if not (Uchar.is_char uc) then
              parse_ident ~of_fun ctx start_pos
                (fun b -> Buffer.(add_char b '-'; add_utf_8_uchar b uc))
            else
              match Uchar.to_char uc with
              | '0'..'9' -> fail "ident cannot start with -<digit>"
              | '-' -> parse_ident ~of_fun ctx start_pos
                  (fun b -> Buffer.add_string b "--")
              | c -> parse_ident ~of_fun ctx start_pos
                  (fun b -> Buffer.(add_char b '-'; add_char b c))
         )
     | Some c -> parse_ident ~of_fun ctx start_pos
         (fun b -> Buffer.(add_char b '-'; add_char b c))
    )
| Some c when is_unescaped_ident_char c ->
    parse_ident ~of_fun ctx start_pos
      (fun b -> Buffer.(add_char b '-'; add_char b c))
| Some c -> fail (Printf.sprintf "invalid character %C in ident" c)

let ident_digit ctx first start_pos =
  choice ~failure_msg:"ident cannot start with <digit>" [
    (take_while (function '0'..'9' -> true | _ -> false) >>= fun str ->
       char '%' >>= fun _ ->
       let id = Printf.sprintf "%c%s%%" first str in
       ctx.get_pos >>| fun stop -> (id, (start_pos, stop)));
  ]

let ident ~of_fun ctx = take_char >>= function
| None -> fail "empty ident"
| Some c ->
    ctx.get_pos >>= fun start_pos ->
      match c with
      | '0'..'9' -> ident_digit ctx c start_pos
      | '-' -> ident_hyphen ~of_fun ctx start_pos
      | '\\' ->
          (take_char >>= function
           | None -> parse_error_at ctx Unterminated_char_escape
           | Some c when is_hex c ->
               (escaped_codepoint c >>= fun uc ->
                  if not (Uchar.is_char uc) then
                    parse_ident ~of_fun ctx start_pos
                      (fun b -> Buffer.add_utf_8_uchar b uc)
                  else
                    match Uchar.to_char uc with
                    | '0'..'9' -> fail "ident cannot start with <digit>"
                    | '-' ->  ident_hyphen ~of_fun ctx start_pos
                    | c -> parse_ident ~of_fun ctx start_pos (fun b -> Buffer.add_char b c)
             )
         | Some c when is_unescaped_ident_char c ->
             parse_ident ~of_fun ctx start_pos (fun b -> Buffer.add_char b c)
         | Some (*('!' as c)*) c when c <> '"'->
             parse_ident ~of_fun ctx start_pos (fun b -> Buffer.add_char b c)
         | _ -> fail (Printf.sprintf "invalid character %C in ident" c)
        )
    | c when is_unescaped_ident_char c ->
        parse_ident ~of_fun ctx start_pos (fun b -> Buffer.add_char b c)
    | _ ->  fail (Printf.sprintf "invalid character %C in ident" c)

let ident : ?of_fun:bool -> ctx -> (string * loc) Angstrom.t = fun ?(of_fun=false) ctx ->
    (ws ctx *> option ' ' (char '*') *> ident ~of_fun ctx) <?> "ident" >>|
      function (str,loc) as x ->
          (*prerr_endline (Printf.sprintf "%sident %S" (T.string_of_loc loc) str) ;*)
          x

(* https://www.w3.org/TR/css-syntax-3/#any-value *)
let declaration_value =
  let rec iter b ctx =
    choice [
      (comment ctx >>= fun _ -> return (Some ctx)) ;
      (string ctx >>= fun str -> Buffer.add_string b (U.quote_string str.s); return (Some ctx)) ;
      (satisfy T.is_open_block_char >>= fun c ->
         Buffer.add_char b c; return (Some (T.ctx_open_block ctx (T.block_of_char c)))
      );
      (Angstrom.string "\\!" >>= fun _ -> Buffer.add_char b '!'; return (Some ctx)) ;
      (Angstrom.peek_char >>= function
       | Some ';' ->
           if T.ctx_toplevel ctx
           then return None
           else (Angstrom.char ';' >>= fun c -> Buffer.add_char b c; return (Some ctx))
       | Some c when T.is_close_block_char c ->
           let bl = T.block_of_char c in
           if T.ctx_can_close_block ctx bl then
             (
              Angstrom.any_char >>= fun _ ->
                Buffer.add_char b c;
                return (Some (T.ctx_close_block ctx bl))
             )
           else
             return None
       | Some c when c <> '!' -> (Angstrom.any_char >>= fun _ -> Buffer.add_char b c; return (Some ctx))
       | _ -> return None
      );
    ] <?> "declaration_value" >>= function
  | None -> return ()
  | Some ctx -> iter b ctx
  in
  fun ctx ->
    let b = Buffer.create 125 in
    iter b ctx >>= fun () -> return (Buffer.contents b)

let var_value ctx = ws ctx *> declaration_value ctx

let of_kws : 'a list -> (ctx -> 'a Angstrom.t) = fun kws ->
  let of_string = T.(mk_of_string Kw.string_of_kw kws) in
  fun ctx ->
    ident ctx >>= fun (i,loc) ->
      match of_string i with
      | None -> fail (Printf.sprintf "Unknown keyword %S" i)
      | Some v -> return v

let left_center_right : ctx -> T.lcr Angstrom.t = of_kws [ `Left ; `Center ; `Right ]

let global_kw : ctx -> T.global_kw Angstrom.t = of_kws T.global_kws

let global_kw_or : (ctx -> 'a Angstrom.t) -> ctx -> 'a p_value Angstrom.t = fun p ->
    fun ctx -> choice [
        (global_kw ctx >>| fun k -> (k :> 'a p_value)) ;
        (p ctx >>| fun v -> `V v) ;
      ]

let fun_parser ctx ?name p =
  ident ~of_fun:true ctx <* lpar ctx >>= (fun (i,loc) ->
    match name with
    | Some str when i <> str  ->
        fail (Printf.sprintf "Unexpected function %S" i)
    | None -> fail ""
    | Some name -> (p >>| fun v -> (name, v))
  ) <* (rpar ctx)

let fixed_fun_parser ctx name p =
  fun_parser ctx ~name p >>| (fun (_,args) -> args)

let rec to_closing_rpar b n =
  take 1 >>= function
| "(" -> Buffer.add_char b '('; to_closing_rpar b (n+1)
| ")" ->
    let n = n - 1 in
    if n = 0
    then return (Buffer.contents b)
    else (Buffer.add_char b ')' ; to_closing_rpar b n)
| s -> Buffer.add_string b s ; to_closing_rpar b n

let to_closing_rpar () =
  let b = Buffer.create 32 in
  to_closing_rpar b 1

let var ctx =
  ws ctx *> ident ~of_fun:true ctx >>= fun (i,loc) ->
    match i with
    | "var" ->
        (lpar ctx *> ident ctx >>= fun (i,loc) ->
           choice [
             (comma ctx *> ws ctx *> to_closing_rpar () >>= fun args -> return (i, Some args)) ;
             (rpar ctx >>| fun _ -> (i, None))
           ]
        )
    | _ -> fail "var"

let or_var p ctx =
  choice [
    (var ctx >>| fun (name,args) -> `Var (name, args));
    (p ctx >>| fun v -> `V v) ;
  ] <?> "or_var"

let p_value p ctx =
  choice [
    (global_kw_or p ctx);
    (var ctx >>| fun (i,args) -> `Var (i, args)) ;
  ]

let iri_of_string ctx s =
  match Iri.of_string s.s with
  | exception (Iri.Error e) -> parse_error_at ctx (Invalid_iri (s.s, e))
  | iri -> return iri

let mime_type ctx =
  Angstrom.take_while
    (function
     | 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' | '/' | '.' | '+' -> true
     | _ -> false)

let charset ctx = mime_type ctx
let encoding ctx = mime_type ctx

let url_data ctx =
  (Angstrom.string "data:" *>
    mime_type ctx >>=
    fun mime ->
      Log.debug (fun m -> m "data: mime_type=%S" mime);
      U.opt_ (Angstrom.string ";charset=" *> ws ctx *> charset ctx)
        >>= fun charset ->
        Log.debug (fun m -> m "data: charset=%S" (Option.value ~default:"None" charset));
        U.opt_ (semicolon ctx *> ws ctx *> encoding ctx)
        >>= fun encoding ->
        Log.debug (fun m -> m "data: encoding=%S" (Option.value ~default:"None" encoding));
        comma ctx *> Angstrom.take_till (fun _ -> false) >>=
        fun data ->
          return T.{ mime ; charset ; encoding ; data }
  ) <?> "url_data"

let url_url =
  let next ctx str =
    if String.length str.s >= 4 && U.is_prefix ~s:str.s ~pref:"data:" then
      (*let ctx2 = T.string_ctx str.s in*)
      let parser = U.handle_end url_data ctx in
      match Angstrom.parse_string ~consume:Angstrom.Consume.All parser str.s with
      | Ok data -> return (`Data data)
      | Error msg ->
           (*parse_error_at ctx (Invalid_data (str.s, msg))*)
          let msg = Printf.sprintf "Invalid data %S: %s" str.s msg in
          fail msg
    else
      iri_of_string ctx str >>= fun iri -> return (`Iri iri)
  in
  fun ctx ->
    (ws ctx *>
      U.opt_ (string ctx) >>=
      function
      | Some str -> next ctx str
      | None -> take_while ((<>) ')') >>= fun s -> next ctx { s ; quoted = false }
    ) <?> "url_url"

let url_src ctx =
  (ws ctx *>
   choice [
     (var ctx >>= fun v -> return (`Src (`Var v)));
     (url_url ctx >>= function `Iri i -> return (`Src (`Iri i)) | `Data d -> return (`Data d)) ;
   ]
  ) <?> "url_src"

let url ctx =
  (ws ctx *>
   choice [
     (Angstrom.string "url" *> ws ctx *> lpar ctx *> url_url ctx >>= fun x -> rpar ctx *> return x) ;
     (Angstrom.string "src" *> ws ctx *> lpar ctx *> url_src ctx >>= fun x -> rpar ctx *> return x) ;
   ]
  ) <?> "url"

let fun_args ctx = lpar ctx *> to_closing_rpar ()
let function_ ctx = ( ws ctx *>
  ident ~of_fun:true ctx >>= fun (name,_) -> fun_args ctx >>| fun args ->
   `Function (name, args)
) <?> "function"

let gradient_kind = Angstrom.(
  choice [
     (string "linear-gradient" *> return `Linear) ;
     (string "repeating-linear-gradient" *> return `Repeating_linear) ;
     (string "radial-gradient" *> return `Radial) ;
     (string "repeating-radial-gradient" *> return `Repeating_radial) ;
   ])

let gradient ctx = (ws ctx *>
  gradient_kind <* lpar ctx >>= fun g ->
    to_closing_rpar () >>| fun args -> `Gradient (g,args)
  ) <?> "gradient"

let image : ctx -> T.image Angstrom.t = fun ctx -> (ws ctx *>
   choice [
     (url ctx >>| fun x -> `Url x) ;
     (gradient ctx) ;
     (function_ ctx) ;
   ]
  ) <?> "image"

let percentage ctx = (ws ctx *> number ctx >>= fun n ->
     peek_char >>= function
     | Some '%' -> (advance 1 >>| fun () -> n)
     | _ -> fail "no %"
  ) <?> "percentage"

let unit_ to_string l =
  let f s x = Angstrom.string s >>| fun _ -> x in
  let l = List.map (fun v -> f (to_string v) v) l in
  choice l

let rel_length_unit =
  unit_ T.string_of_rel_length_unit T.rel_length_units
let abs_length_unit =
  unit_ T.string_of_abs_length_unit T.abs_length_units
let angle_unit =
  unit_ T.string_of_angle_unit T.angle_units
let time_unit =
  unit_ T.string_of_time_unit T.time_units
let freq_unit =
  unit_ T.string_of_freq_unit T.freq_units
let flex_unit =
  unit_ T.string_of_flex_unit T.flex_units
let resolution_unit =
  unit_ T.string_of_resolution_unit T.resolution_units

let length_unit =
  let rel_l = (rel_length_unit :> T.length_unit Angstrom.t) in
  let abs_l  = (abs_length_unit :>  T.length_unit Angstrom.t) in
  choice ([ rel_l ; abs_l])

let dim_unit =
  let len = (length_unit :> T.dim_unit Angstrom.t) in
  let angle  = (angle_unit :>  T.dim_unit Angstrom.t) in
  let time  = (time_unit :>  T.dim_unit Angstrom.t) in
  let freq  = (freq_unit :>  T.dim_unit Angstrom.t) in
  let flex  = (flex_unit :>  T.dim_unit Angstrom.t) in
  let resolution  = (resolution_unit :>  T.dim_unit Angstrom.t) in
  choice ([ len ; angle ; time ; freq ; flex ; resolution])

let dimension_ ctx ~parser_name ?default_unit unit = (ws ctx *> number ctx >>= fun n ->
  peek_char >>= function
     | Some ('a'..'z'|'A'..'Z') ->
         (unit >>= fun u -> return (n,u))
     | _ -> (* fail if no unit or n=0 and no default unit *)
         match default_unit with
         | Some u when n = 0. -> return (n, u)
         | _ ->
             debug (fun m -> m "no unit for value %f; %f = 0 ? %b" n n (n=0.));
             fail "missing unit"
  ) <?> parser_name

let length ctx = dimension_ ctx ~parser_name:"length" ~default_unit:`px length_unit
let angle ctx = dimension_ ctx ~parser_name:"angle" ~default_unit:`deg angle_unit
let time ctx= dimension_ ctx ~parser_name:"time" ~default_unit:`s time_unit
let freq ctx = dimension_ ctx ~parser_name:"freq" ~default_unit:`hz freq_unit
let flex ctx = dimension_ ctx ~parser_name:"flex" ~default_unit:`fr flex_unit
let resolution ctx = dimension_ ctx ~parser_name:"resolution" ~default_unit:`dpi resolution_unit

let dimension ctx = dimension_ ctx "dimension" dim_unit

let percentage_ ctx name p = (ws ctx *>
   choice
     [ percentage ctx >>| (fun n -> `Percent n) ; p ]
  ) <?> name

let length_percentage ctx : T.length_percentage Angstrom.t =
  percentage_  ctx "length-percentage"
    (length ctx >>| (fun d -> `Length d))

let angle_percentage ctx =
  percentage_ ctx "angle-percentage"
    (angle ctx >>| (fun d -> `Angle d))

let hexa_color =
  let n255 = Int32.of_int 255 in
  let of_small_hex s =
    let b = Buffer.create 8 in
    for i = 0 to 3 do
      Buffer.add_char b s.[i];
      Buffer.add_char b s.[i];
    done;
    Buffer.contents b
  in
  let of_string s =
    let len = String.length s in
    let s =
      match len with
      | 3 -> of_small_hex (s^"f")
      | 4 -> of_small_hex s
      | 6 -> s^"ff"
      | _ -> s
    in
    let s = Printf.sprintf "0x%s" s in
    let n = Int32.(of_string s) in
    (*prerr_endline (Printf.sprintf "hexa_color %S => n=%#d" s n);*)
    let r = Int32.(to_int (shift_right_logical n 24)) in
    let g = Int32.(to_int (shift_right_logical n 16)) in
    let b = Int32.(to_int (shift_right_logical n 8)) in
    let a = Int32.(to_int (logand n n255)) in
    let norm x = float (x land 255) /. 255. in
    `Rgba (norm r, norm g, norm b, norm a)
  in
  take_while1 is_hex >>| of_string

let rgb_args ctx =
  let sep ctx = comma ctx  *> return () <|> ws ctx *> return () in
  number ctx >>= fun r -> sep ctx *>
    number ctx >>= fun g -> sep ctx *>
    number ctx >>= fun b -> return (r,g,b)

let rgba_args ctx =
  rgb_args ctx >>= fun (r,g,b) ->
    (comma ctx <|> slash ctx) *> number ctx >>| fun a -> (r,g,b,a)

let color : ctx -> color Angstrom.t = fun ctx -> (ws ctx *>
     peek_char >>= function
     | None -> fail ""
     | Some '#' -> (advance 1 >>= fun () -> hexa_color)
     | Some _ ->
         ident ~of_fun:true ctx >>= function
         | "currentcolor",_ -> return `Current_color
         | "transparent",_ -> return `Transparent
         | "rgb", _ ->
             (lpar ctx *>
               choice [
                (rgb_args ctx <* rpar ctx >>| fun (r,g,b) -> `Rgba (r,g,b, 1.)) ;
                (rgba_args ctx <* rpar ctx >>| fun (r,g,b,a) -> `Rgba (r,g,b, a))
              ]
             )
         | "rgba", _ ->
             (lpar ctx *> rgba_args ctx <* rpar ctx >>|
              fun (r,g,b,a) -> `Rgba (r,g,b,a) )
         | "var", _ -> fail ""
         | ident,_ ->
             match T.system_color_of_string ident with
             | Some sc -> return (`System_color sc)
             | None -> return (`Named_color ident)
    ) <?> "color"

let x_axis_pos_kw : ctx -> T.x_position_kw Angstrom.t = of_kws T.x_position_kws
let y_axis_pos_kw : ctx -> T.y_position_kw Angstrom.t = of_kws T.y_position_kws

let axis_position_ p ctx = ws ctx *>
  choice [
    (p ctx <* ws ctx >>= function
     | `Center -> return (Kw `Center)
     |  kw ->
         choice [
           (length_percentage ctx >>| fun o -> KO (kw, o)) ;
           return (Kw kw)
         ]) ;
    (length_percentage ctx >>| fun o -> Offset o) ;
  ]

let x_position = axis_position_ x_axis_pos_kw
let y_position = axis_position_ y_axis_pos_kw

let xy_pos ctx = ws ctx *>
  choice [
    (x_axis_pos_kw ctx >>= fun x -> y_axis_pos_kw ctx  >>| fun y -> (Kw x, Kw y)) ;
    (x_axis_pos_kw ctx >>= fun x -> length_percentage ctx >>| fun y -> (Kw x, Offset y)) ;
    (length_percentage ctx >>= fun x -> length_percentage ctx >>| fun y -> (Offset x, Offset y)) ;
    (length_percentage ctx >>= fun x -> y_axis_pos_kw ctx >>| fun y -> (Offset x, Kw y)) ;
    (x_axis_pos_kw ctx >>= fun xkw -> ws ctx *>
       length_percentage ctx >>= fun xo -> ws ctx *>
         y_axis_pos_kw ctx >>= fun ykw -> ws ctx *>
         length_percentage ctx >>| fun yo -> (KO (xkw,xo), KO (ykw, yo))) ;
  ]
let axis_position : ctx -> T.axis_position Angstrom.t =
  let of_kw = of_kws T.trblc_kws in
  fun ctx -> (
     choice [
       (xy_pos ctx >>| (fun (x, y) -> XY (x,y))) ;
       (of_kw ctx >>| fun p -> Single_kw p) ;
   ]) <?> "axis-position"

let size ?(name="size") : ctx -> T.size Angstrom.t =
  let of_kw = of_kws T.size_kws in
  fun ctx -> (
     choice [
       (length_percentage ctx :> T.size t) ;
       (of_kw ctx :> T.size t);
       ((fixed_fun_parser ctx "fit-content" (length_percentage ctx) >>|
         fun lp -> `Fit_content(lp)) :> T.size t)
     ]
    ) <?> name

let max_size ?(name="max-size") : ctx -> T.max_size Angstrom.t =
  let of_kw = of_kws T.max_size_kws in
  fun ctx -> (
     choice [
       (length_percentage ctx :> T.max_size Angstrom.t) ;
       (of_kw ctx :> T.max_size Angstrom.t);
       ((fixed_fun_parser ctx "fit-content" (length_percentage ctx) >>|
         fun lp -> `Fit_content(lp)) :> T.max_size Angstrom.t)
     ]
    ) <?> name

let accent_color =
  let of_kw = of_kws T.accent_color_kws in
  fun ctx -> (ws ctx *>
     choice [
       (of_kw ctx :> T.accent_color t);
       (color ctx :> T.accent_color t);
     ]
  ) <?> "accent-color"

let baseline_position =
  let of_kw = of_kws T.baseline_position_kws in
  fun ctx -> (ws ctx *>
     choice [
       (Angstrom.string "first" *> ws ctx *> Angstrom.string "baseline" *> return `First_baseline) ;
       (Angstrom.string "last" *> ws ctx *> Angstrom.string "baseline" *> return `Last_baseline) ;
       (of_kw ctx :> baseline_position Angstrom.t);
     ]) <?> "baseline-position"

let content_position : ctx -> T.content_position Angstrom.t =
  of_kws T.content_position_kws
let content_position_lr : ctx -> T.content_position_lr Angstrom.t =
  of_kws T.content_position_lr_kws
let self_position : ctx -> T.self_position Angstrom.t =
  of_kws T.self_position_kws
let self_position_lr : ctx -> T.self_position_lr Angstrom.t =
  of_kws T.self_position_lr_kws
let content_distribution : ctx -> T.content_distribution Angstrom.t =
  of_kws T.content_distribution_kws

let align_content =
  let of_kw = of_kws T.align_content_kws in
  fun ctx -> (ws ctx *>
     choice [
       (of_kw ctx :> align_content Angstrom.t);
       (baseline_position ctx :> align_content Angstrom.t) ;
       (content_distribution ctx :> align_content Angstrom.t) ;
       (content_position ctx :> align_content Angstrom.t) ;
       (Angstrom.string "safe" *> ws ctx *> content_position ctx >>| fun k -> `Safe_pos k) ;
       (Angstrom.string "unsafe" *> ws ctx *> content_position ctx >>| fun k -> `Unsafe_pos k) ;
     ]
    ) <?> "align-content"

let align_items =
  let of_kw = of_kws T.align_items_kws in
  fun ctx -> (ws ctx *>
     choice [
       (of_kw ctx :> T.align_items Angstrom.t);
       (baseline_position ctx :> T.align_items Angstrom.t) ;
       (self_position ctx :> T.align_items Angstrom.t) ;
       (Angstrom.string "safe" *> ws ctx *> self_position ctx >>| fun k -> `Safe_self_pos k) ;
       (Angstrom.string "unsafe" *> ws ctx *> self_position ctx >>| fun k -> `Unsafe_self_pos k) ;
     ]
    ) <?> "align-items"

let align_self =
  let of_kw = of_kws T.align_self_kws in
  fun ctx -> (choice
     [ (of_kw ctx :> align_self Angstrom.t) ;
       (align_items ctx :> align_self Angstrom.t) ;
     ]) <?> "align-self"

let aspect_ratio =
  let of_kw = of_kws T.aspect_ratio_kws in
  (fun ctx ->
     (ws ctx *> choice
      [ (number ctx >>= fun n1 ->
           opt_ (ws ctx *> char '/' *> ws ctx *> number ctx) >>| fun n2 -> `Ratio (n1, n2)
        );
        (of_kw ctx :> T.aspect_ratio t);
      ]
     ) <?> "aspect-ratio")

let background_ name p =
  let name = "background-"^name in
  fun ctx ->
    (ws ctx *> sep_by1 (comma ctx) (p ctx)
    ) <?> name

let background_attachment_ : ctx -> background_attachment_ Angstrom.t =
  of_kws T.background_attachment_kws
let background_attachment : ctx -> background_attachment Angstrom.t =
  background_ "attachment" background_attachment_

let background_clip_ = of_kws T.background_clip_kws
let background_clip : ctx -> background_clip Angstrom.t =
  background_ "clip" background_clip_

let background_image_ : ctx -> background_image_ Angstrom.t =
  let of_kw = of_kws T.background_image_kws in
  fun ctx -> choice [
      (of_kw ctx :> T.background_image_ t) ;
      (image ctx >>| fun i -> `Image i);
    ]
let background_image : ctx -> background_image Angstrom.t =
  background_ "image" background_image_

let background_origin_ : ctx -> T.background_origin_ Angstrom.t =
  of_kws T.background_origin_kws
let background_origin : ctx -> background_origin Angstrom.t =
  background_ "origin" background_origin_

let background_position_x : ctx -> background_position_x Angstrom.t =
  background_ "position-x" x_position
let background_position_y : ctx -> background_position_y Angstrom.t =
  background_ "position-y" y_position

let background_repeat_ : ctx -> background_repeat_ Angstrom.t =
  let of_kw = of_kws T.background_repeat_kws in
  let of_kw_r = of_kws T.repeat_kws in
  let p ctx = choice [
      (of_kw ctx >>| function
       | `Repeat_x -> (`Repeat, `No_repeat)
       | `Repeat_y -> (`No_repeat, `Repeat));
      (of_kw_r ctx <* ws ctx >>= fun x ->
         choice [
           (of_kw_r ctx >>| fun y -> (x, y)) ;
           return (x, x) ;
         ]);
    ]
  in
  p
let background_repeat : ctx -> background_repeat Angstrom.t =
  background_ "repeat" background_repeat_

let background_size_ : ctx -> (background_size_ * background_size_) Angstrom.t =
  let of_kw = of_kws T.background_size_kws in
  let s ctx =
     choice [
       (of_kw ctx <* ws ctx :> T.background_size_ t) ;
       (length_percentage ctx :> T.background_size_ t) ;
     ]
  in
  let p ctx =
    s ctx <* ws ctx >>= fun x ->
      choice [
        (s ctx >>| fun y -> (x, y)) ;
        return (x, `Auto) ;
      ]
  in
  p
let background_size : ctx -> background_size Angstrom.t =
  background_ "size" background_size_

let background_color : ctx -> background_color Angstrom.t = color

let line_style = (of_kws T.line_styles :> ctx -> line_style Angstrom.t)

let border_collapse : ctx -> T.border_collapse Angstrom.t =
  let of_kw = of_kws T.border_collapse_kws in
  fun ctx -> of_kw ctx <?> "border_collapse"

let border_spacing : ctx -> T.border_spacing Angstrom.t =
  fun ctx ->
    (or_var length ctx >>= fun x ->
       choice [
         (or_var length ctx >>= fun y -> return (x,y)) ;
         return (x, x) ;
       ]
    ) <?> "border_spacing"

let border_width : ctx -> T.border_width t =
  let of_kw = of_kws T.border_width_kws in
  fun ctx -> choice [
      (of_kw ctx :> border_width Angstrom.t) ;
      (size ctx :> border_width Angstrom.t)]

let display =
  let out_kw = of_kws T.display_outside_kws in
  let in_kw = of_kws T.display_inside_kws in
  let flow_kw = (of_kws T.display_flow_kws :> ctx -> T.display_inside Angstrom.t) in
  let li_kw : ctx -> display_listitem_kw Angstrom.t = of_kws T.display_listitem_kws in
  let int_kw = of_kws T.display_internal_kws in
  let box_kw = of_kws T.display_box_kws in
  let leg_kw = of_kws T.display_legacy_kws in
  let out_in ctx : T.display_out_in Angstrom.t =
    (out_kw ctx) ||| (in_kw ctx) >>= function
        (* https://www.w3.org/TR/css-display-3/#the-display-properties *)
    | Some o, Some i -> return (o, i, None)
    | Some o, None -> return (o, `Flow, None)
    | None, Some `Ruby -> return (`Inline, `Ruby, None)
    | None, Some i -> return (`Block, i, None)
    | None, None -> fail "Invalid display"
  in
  let li ctx : T.display_out_in Angstrom.t =
    let o = option `Block (out_kw ctx) in
    let f = option `Flow (flow_kw ctx) in
    let li = li_kw ctx in
    choice [
      map3 o f li ~f:(fun o f li -> (o,f,Some li)) ;
      map3 o li f ~f:(fun o li f -> (o,f,Some li)) ;
      map3 f o li ~f:(fun f o li -> (o,f,Some li)) ;
      map3 f li o ~f:(fun f li o -> (o,f,Some li)) ;
      map3 li f o ~f:(fun li f o -> (o,f,Some li)) ;
      map3 li o f ~f:(fun li o f -> (o,f,Some li)) ;
    ]
  in
  let leg ctx = leg_kw ctx >>| function
  | `Inline_block -> (`Inline, `Flow_root, None)
  | `Inline_table -> (`Inline, `Table, None)
  | `Inline_flex -> (`Inline, `Flex, None)
  | `Inline_grid -> (`Inline, `Grid, None)
  in
  fun ctx ->
    choice [
      (choice [ leg ctx ; li ctx ; out_in ctx] >>|
       fun (i,o,li) -> (`Out_in (i,o,li) :> T.display) ) ;
      (int_kw ctx :> T.display Angstrom.t) ;
      (box_kw ctx :> T.display Angstrom.t) ;
    ]

let flex_basis =
  let of_kw = of_kws T.flex_basis_kws in
  fun ctx ->
    choice [
      (of_kw ctx :> flex_basis Angstrom.t) ;
      (size ~name:"flex-basis" ctx :> flex_basis Angstrom.t)
    ]

let flex_direction : ctx -> flex_direction Angstrom.t = of_kws T.flex_direction_kws

let flex_wrap : ctx -> flex_wrap Angstrom.t = of_kws T.flex_wrap_kws

let font_family_generic : ctx -> font_family_generic_kw Angstrom.t =
  of_kws T.font_family_generic_kws
let font_family_ ctx = (ws ctx *> choice [
     (font_family_generic ctx >>| fun kw -> `Generic kw) ;
     (ident ctx >>| fun (s,_) -> `Family s) ;
     (string ctx >>| fun s -> `Family s.s) ;
   ]) <?> "font-family"
let font_family : ctx -> font_family Angstrom.t = fun ctx ->
  sep_by1 (comma ctx) (font_family_ ctx)

let font_family_with_unquoted_spaced_idents_ ctx =
  choice [
    (sep_by1 (ws ctx) (ident ctx) >>| fun l -> `Family (String.concat " " (List.map fst l))) ;
    font_family_ ctx ;
  ]
let font_family_with_unquoted_spaced_idents : ctx -> font_family Angstrom.t = fun ctx ->
    sep_by1 (comma ctx) (font_family_with_unquoted_spaced_idents_ ctx)

let font_kerning : ctx -> font_kerning Angstrom.t = of_kws T.font_kerning_kws

let font_size_kw : ctx -> font_size_kw Angstrom.t = of_kws T.font_size_kws
let font_size ctx = (choice [
     (font_size_kw ctx :> font_size Angstrom.t) ;
     (length_percentage ctx :> font_size Angstrom.t) ;
   ]) <?> "font-size"

let font_stretch_kw : ctx -> font_stretch_kw Angstrom.t = of_kws T.font_stretch_kws
let font_stretch ctx =
   percentage_ ctx "font-stretch" (font_stretch_kw ctx :> font_stretch Angstrom.t)

let font_style_kw : ctx -> font_style_kw Angstrom.t = of_kws T.font_style_kws
let font_style ctx = (choice [
     (font_style_kw ctx :> T.font_style Angstrom.t) ;
     (ident ctx >>= function
      (* by now, accept and forget optinal second angle, used in font-face blocks *)
      | ("oblique",_) -> opt_ (angle ctx) <* opt_(angle ctx) >>| (fun d -> `Oblique d)
      | _ -> fail ""
     ) ;
   ]) <?> "font-style"

let font_variant_alt : ctx -> font_variant_alt Angstrom.t =
  let fun_ ctx f = ws ctx *> lpar ctx *> ident ctx <* ws ctx <* rpar ctx >>| (fun (i,_) -> f i) in
  let fun_l ctx f = ws ctx *> lpar ctx *> sep_by1 (comma ctx) (ident ctx) <* ws ctx <* rpar ctx >>|
    (fun l -> f (List.map fst l))
  in
  fun ctx ->
    ident ctx >>= (function
     | ("historical-forms",_) -> return `Historical_forms
     | ("stylistic",_) -> fun_ ctx (fun i -> `Stylistic i)
     | ("styleset",_) -> fun_l ctx (fun l -> `Styleset l)
     | ("character-variant",_) -> fun_l ctx (fun l -> `Character_variant l)
     | ("swash",_) -> fun_ ctx (fun i -> `Swash i)
     | ("ornaments", _) -> fun_ ctx (fun i -> `Ornaments i)
     | ("annotation",_) -> fun_ ctx (fun i -> `Annotation i)
     | (i,_) -> fail (Printf.sprintf "unexpected ident %S" i)
    )

let font_variant_alternates : ctx -> font_variant_alternates Angstrom.t =
  fun ctx ->
    (choice [
       (of_kws [`Normal] ctx :> font_variant_alternates Angstrom.t) ;
       (sep_by1 (ws ctx) (font_variant_alt ctx) >>| fun l -> `List l)
     ]
    ) <?> "font-variant-alternates"

let font_variant_caps : ctx -> font_variant_caps Angstrom.t =
  of_kws T.font_variant_caps_kws

let font_variant_east_asian : ctx -> font_variant_east_asian Angstrom.t =
  let of_kw = of_kws T.font_variant_east_asian_kws in
  fun ctx ->
    (choice [
       (of_kws [`Normal] ctx :> font_variant_east_asian Angstrom.t) ;
       (sep_by1 (ws ctx) (of_kw ctx) >>| fun l -> `List l)
   ]
  ) <?> "font-variant-east-asian"

let font_variant_emoji : ctx -> font_variant_emoji Angstrom.t =
  of_kws T.font_variant_emoji_kws

let font_variant_ligatures : ctx -> font_variant_ligatures Angstrom.t =
  let of_kw = of_kws T.font_variant_ligatures_kws in
  fun ctx ->
    (choice [
       (of_kws [`Normal ; `None] ctx :> font_variant_ligatures Angstrom.t) ;
       (sep_by1 (ws ctx) (of_kw ctx) >>| fun l -> `List l)
   ]
  ) <?> "font-variant-ligatures"

let font_variant_numeric : ctx -> font_variant_numeric Angstrom.t =
  let of_kw = of_kws T.font_variant_numeric_kws in
  fun ctx ->
    (choice [
       (of_kws [`Normal] ctx :> font_variant_numeric Angstrom.t) ;
       (sep_by1 (ws ctx) (of_kw ctx) >>| fun l -> `List l)
   ]
  ) <?> "font-variant-numeric"

let font_variant_position : ctx -> font_variant_position Angstrom.t =
  of_kws T.font_variant_position_kws

let font_weight : ctx -> font_weight Angstrom.t =
  let of_kw = of_kws T.font_weight_kws in
  let numbers = List.map
    (fun n -> Angstrom.string (string_of_int n))
      [ 100; 200 ; 300 ; 400 ; 500 ; 600 ; 700 ; 800 ; 900 ]
  in
  fun ctx -> (choice [
       (of_kw ctx :> font_weight Angstrom.t);
       (ws ctx *> choice numbers >>= fun s ->
          (* by now, accept and forget additional weights, used in font-face blocks *)
          (many (ws ctx *> choice numbers)) >>= fun _ ->
          return (`Weight (int_of_string s))) ;
     ]) <?> "font-weight"

let justify_content : ctx -> justify_content Angstrom.t =
  let of_kw = of_kws T.justify_content_kws in
  fun ctx -> (ws ctx *>
     choice [
       (of_kw ctx :> justify_content Angstrom.t);
       (content_distribution ctx :> justify_content Angstrom.t) ;
       (content_position_lr ctx :> justify_content Angstrom.t) ;
       (Angstrom.string "safe" *> ws ctx *> content_position_lr ctx >>| fun k -> `Safe_pos_lr k) ;
       (Angstrom.string "unsafe" *> ws ctx *> content_position_lr ctx >>| fun k -> `Unsafe_pos_lr k) ;
     ]
    ) <?> "justify-content"

let justify_items : ctx -> justify_items Angstrom.t =
  let of_kw = of_kws T.justify_items_kws in
  fun ctx -> (ws ctx *>
     choice [
       (((ws ctx *> Angstrom.string "legacy") &&& (left_center_right ctx)) >>| fun (_,x) -> `Legacy_lcr x) ;
       (of_kw ctx :> T.justify_items Angstrom.t);
       (baseline_position ctx :> T.justify_items Angstrom.t) ;
       (self_position_lr ctx :> T.justify_items Angstrom.t) ;
       (Angstrom.string "safe" *> ws ctx *> self_position_lr ctx >>| fun k -> `Safe_self_pos_lr k) ;
       (Angstrom.string "unsafe" *> ws ctx *> self_position_lr ctx >>| fun k -> `Unsafe_self_pos_lr k) ;
     ]
    ) <?> "justify-items"

let justify_self : ctx -> justify_self Angstrom.t =
  let of_kw = of_kws T.justify_self_kws in
  fun ctx -> (ws ctx *>
     choice [
       (of_kw ctx :> T.justify_self Angstrom.t);
       (baseline_position ctx :> T.justify_self Angstrom.t) ;
       (self_position_lr ctx :> T.justify_self Angstrom.t) ;
       (Angstrom.string "safe" *> ws ctx *> self_position_lr ctx >>| fun k -> `Safe_self_pos_lr k) ;
       (Angstrom.string "unsafe" *> ws ctx *> self_position_lr ctx >>| fun k -> `Unsafe_self_pos_lr k) ;
     ]
    ) <?> "justify-self"

let number_ ctx = (number ctx >>| fun n -> `Number n)
let line_height : ctx -> line_height Angstrom.t =
  let of_kw = of_kws T.line_height_kws in
  fun ctx -> (choice [
       (of_kw ctx :> line_height Angstrom.t);
       (length_percentage ctx :> line_height Angstrom.t) ;
       (number_ ctx) ;
     ]) <?> "line-height"


let opacity : ctx -> T.opacity Angstrom.t =
  fun ctx -> (
     percentage_  ctx "opacity-percentage"
       (number ctx >>| (fun d -> `Factor d))
    ) <?> "opacity"

let list_style_image : ctx -> list_style_image Angstrom.t =
  let of_kw = of_kws T.list_style_image_kws in
  fun ctx -> (choice [
       (image ctx >>| fun i -> `Image i) ;
       (of_kw ctx :> list_style_image Angstrom.t)
     ]) <?> "list-style-image"

let list_style_position_kw : ctx -> list_style_position_kw Angstrom.t =
  of_kws T.list_style_position_kws
let list_style_position : ctx -> list_style_position Angstrom.t =
  list_style_position_kw

let list_style_type : ctx -> list_style_type Angstrom.t =
  let of_kw = of_kws T.list_style_type_kws in
  fun ctx -> (choice [
       (of_kw ctx :> list_style_type Angstrom.t) ;
       (string ctx >>| fun s -> `String_ s.s) ;
       (ident ctx >>| fun (i,_) -> `Ident_ i) ;
       (fixed_fun_parser ctx "symbols" (fun_args ctx) >>| fun s -> `Symbols_ s) ;
     ]) <?> "list-style-type"

let margin : ctx -> margin Angstrom.t =
  let of_kw = of_kws T.margin_kws in
  fun ctx -> (choice [
       (of_kw ctx :> margin Angstrom.t) ;
       (length_percentage ctx :> margin Angstrom.t);
     ]) <?> "margin"

let padding = length_percentage

let position : ctx -> position Angstrom.t = of_kws T.position_kws

let text_align : ctx -> text_align Angstrom.t = of_kws T.text_align_kws

let text_align_last : ctx -> text_align_last Angstrom.t =
  of_kws T.text_align_last_kws

let vertical_align : ctx -> vertical_align Angstrom.t =
  let of_kw = of_kws T.vertical_align_kws in
  fun ctx -> (
     choice [
       (length_percentage ctx :> T.vertical_align t) ;
       (of_kw ctx :> T.vertical_align t);
     ]
    ) <?> "vertical-align"

let visibility : ctx -> visibility Angstrom.t = of_kws T.visibility_kws

let white_space : ctx -> white_space Angstrom.t = of_kws T.white_space_kws

let word_spacing : ctx -> word_spacing Angstrom.t =
  let of_kw = of_kws T.word_spacing_kws in
  fun ctx -> (
     choice [
       (length ctx >>| fun (n,u) -> (`Length (n,u) :> T.word_spacing)) ;
       (of_kw ctx :> T.word_spacing t);
     ]
    ) <?> "word-spacing"

let value ctx = choice [
    (percentage ctx >>| fun n -> Percent n) ;
    (dimension ctx >>| (fun (n,u) -> Dimension (n,u))) ;
    (number ctx >>| fun n -> Number n) ;
    (integer ctx >>| fun n -> Integer n) ;
    (string ctx >>| fun str -> String str) ;
    (color ctx >>| fun c -> Color c) ;
    (axis_position ctx >>| fun p -> Position p) ;
  ] <?> "value"