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

(** Shorthand properties. *)

open Angstrom
open U
open Vp
open P

let (>!) (t,loc) p = (P.add t p (`V (P.initial p)) loc false, loc)

let register_shorthand props name (parser : T.ctx -> P.t -> P.t Angstrom.t) =
  let module Space = (val props : P.Prop_space) in
  let f ctx start t = parser ctx t in
  Space.register_prop_parser name f

let fold_with_parsers parsers ?(fail=true) ?(parse_important=false) end_char =
  let rec iter ctx acc =
    let parsers =
      ((if parse_important then Vp.important ctx else return false)
       >>= fun important -> peek_char >>= function
         | Some c when end_char c -> return (acc, important)
         | _ -> if fail then Angstrom.fail "" else return (acc, important)
      ) ::
        List.rev_map (fun f -> f ctx acc >>= iter ctx) parsers
    in
    ws ctx *> choice (List.rev parsers)
  in
  iter

let background_position =
  let p ctx = choice [
      (x_position ctx >>= fun x -> y_position ctx >>| fun y -> (x,y)) ;
      (y_position ctx >>= fun y -> x_position ctx >>| fun x -> (x,y)) ;
      (x_position ctx >>= function
       | (T.Kw `Center) -> return (T.Kw `Center, T.Kw `Center)
       | (Offset o) as x ->
           let y = T.Offset (`Percent 50.) in
           return (x,y)
       | (Kw (`Left | `Right) | KO ((`Left|`Right|`Center), _)) as x ->
           let y = T.Offset (`Percent 50.) in
           return (x,y)
      );
      (y_position ctx >>= function
       | (T.Kw `Center) -> return (T.Kw `Center, T.Kw `Center)
       | (Offset o) as y ->
          (* we should not be here, since this case should have been handled
              above *)
           U.warn (fun m -> m "background-position: strange case");
           return (y, y)
       | (Kw (`Top | `Bottom) | KO ((`Top|`Bottom|`Center), _)) as y ->
           let x = T.Offset (`Percent 50.) in
           return (x,y)
      );
    ]
  in
  let f = Vp.background_ "position" p in
  fun ctx -> with_loc ctx (f ctx)

let p_background_position ctx t =
  ctx.T.get_pos >>= fun pos ->
  let loc = pos,pos in
  let t = fst ((t,loc) >! background_position_x >! background_position_y) in
  choice [
    (with_loc ctx (Vp.global_kw ctx) >>= fun (x,lvc) ->
       Vp.important ctx >>= fun imp ->
       let t = P.add t P.background_position_x (x :> T.background_position_x T.p_value) loc imp in
       let t = P.add t P.background_position_y (x :> T.background_position_y T.p_value) loc imp in
      Angstrom.return t
    ) ;
    (background_position ctx >>= fun (l,loc) ->
       Vp.important ctx >>= fun imp ->
       let x, y = List.split l in
       let t = P.add t P.background_position_x (`V x) loc imp in
       let t = P.add t P.background_position_y (`V y) loc imp in
       Angstrom.return t
    ) ;
  ]

let background_layer ~last_layer ctx =
 ctx.T.get_pos >>= fun start ->
  let one_box_read = ref false in
  let f prop parser _ctx t =
    ws ctx *> U.with_loc ctx (parser ctx) >>| fun (v,loc) ->
      U.debug (fun m -> m "background layer: read %s value: %s"
         (P.name prop) (P.to_string prop [v]));
    P.add t prop (`V [v]) loc false
  in
  let bg_color ctx t =
    with_loc ctx (Vp.color ctx) >>| fun (c,loc) ->
      P.add t background_color (`V c) loc false
  in
  let pos ctx t =
    p_background_position ctx t >>= fun t ->
      U.debug (fun m -> m "background layer: read background-position value");
      choice [
        (slash ctx >>= fun _ ->
           f background_size Vp.background_size_ ctx t) ;
        return t
      ]
  in
  let p_box ctx t =
    if !one_box_read then
      f background_clip Vp.background_clip_ ctx t
    else
       ws ctx *> U.with_loc ctx (Vp.background_origin_ ctx) >>=
        fun (v,loc) ->
          one_box_read := true ;
          let t = P.add t background_origin (`V [v]) loc false in
          let t = P.add t background_clip (`V [(v:>T.background_clip_)]) loc false in
          return t
  in
  let parsers = P.(
       [
         f background_repeat Vp.background_repeat_;
         pos ;
         p_box ;
         f background_image Vp.background_image_;
         f background_attachment Vp.background_attachment_;
       ] @
     (if last_layer then [ bg_color ] else [])

    )
  in
  fold_with_parsers parsers (function ';'|',' -> true | _ ->  false)
    ~parse_important:last_layer ctx P.empty

let background =
  let rec p acc ctx =
    choice [
      (background_layer ~last_layer:false ctx <* comma ctx >>= fun (t,imp) -> p (t::acc) ctx) ;
      (with_loc ctx (background_layer ~last_layer:true ctx) >>= fun ((t,imp),loc) ->
         (* if we succeed this must be the last layer, no comma after *)
         choice [
           (ws ctx *> char ',' >>| fun _ -> false) ;
           return true
         ] >>= function
         | true -> return ((t :: acc), imp)
         | false ->
             U.err
               (fun m -> m "%afinal background layer syntax is follow by ','"
                  T.pp_loc loc);
             fail "") ;
    ]
  in
  fun ctx ->
    (ws ctx *>
     choice [
       (Vp.global_kw ctx >>= (fun g ->
           Vp.important ctx >>| fun imp -> (`G g, imp)));
       (p [] ctx >>| fun (l, imp) -> (`List (List.rev l), imp))
     ]
    ) <?> "background"

let p_background ctx t =
  ctx.T.get_pos >>= fun pos ->
  let loc = pos,pos in
(*  let t = fst ((t,loc)
     >! background_color >! background_clip >! background_image
       >! background_origin >! background_position_x
       >! background_position_y >! background_repeat
       >! background_size)
  in*)
  try
    background ctx >>= (function
     | `G (#T.global_kw as x), important ->
         let (++) t p = P.add t p x loc important in
         let t = P.(t
            ++ background_attachment ++ background_clip ++ background_color
              ++ background_image ++ background_origin ++ background_position_x
              ++ background_position_y ++ background_repeat ++ background_size)
         in
         return t
     | (`List layers, important) ->
         let (++) t p =
           let l = List.map (fun layer ->
              match P.get layer p with
                | `V [x] -> x
                | _ -> failwith "Invalid background layer"
             ) layers
           in
           P.add t p (`V l) loc important
         in
         let t = P.(t
            ++ background_attachment ++ background_clip
              ++ background_image ++ background_origin ++ background_position_x
              ++ background_position_y ++ background_repeat ++ background_size)
         in
         match List.rev layers with
         | [] -> return t
         | final :: _ ->
             let t = P.(add t background_color (get final background_color) loc important) in
             return t
    )
  with
  | Failure msg -> U.warn (fun m -> m "%s" msg); return t

let f : type a. a prop -> (T.ctx -> a Angstrom.t) -> T.ctx -> P.t -> P.t Angstrom.t =
  fun prop parser ctx t ->
    ws ctx *> U.with_loc ctx (parser ctx) >>| fun (v,loc) ->
      U.debug (fun m -> m "read %s value: %s"
         (P.name prop) (P.to_string prop v));
    P.add t prop (`V v) loc false

let mk_border (c,s,w) =
  let glob ctx t =
    with_loc ctx (global_kw ctx) >>= fun (x,loc) ->
      Vp.important ctx >>= fun imp ->
    let t = P.add t c (x:>T.color T.p_value) loc imp in
    let t = P.add t s (x:>T.line_style T.p_value) loc imp in
    let t = P.add t w (x:>T.border_width T.p_value) loc imp in
    return t
  in
  let pstyle = f s (Vp.line_style :> T.ctx -> T.line_style Angstrom.t) in
  let pcolor = f c (Vp.color :> T.ctx -> T.color Angstrom.t) in
  let pwidth = f w (Vp.border_width :> T.ctx -> T.border_width Angstrom.t) in
  let parsers = [ pwidth ; pstyle ; pcolor ] in
  let fold ctx t =
    fold_with_parsers parsers ~parse_important:true
      (function ';'|'}' -> true | _ ->  false) ctx t
      >>= fun (t,imp) ->
      let t = P.set_important t s imp in
      let t = P.set_important t c imp in
      let t = P.set_important t w imp in
    return t
  in
  fun ctx t ->
    ctx.T.get_pos >>= fun pos ->
    let loc = pos, pos in
    let t = fst ((t,loc) >! c >! s >! w) in
    ws ctx *> choice [
      glob ctx t ;
      fold ctx t ;
    ] <?> "border"

let p_border_top = mk_border P.border_top
let p_border_right = mk_border P.border_right
let p_border_bottom = mk_border P.border_bottom
let p_border_left = mk_border P.border_left

let trbl ?(end_cond=fun c -> c = ';'|| c = '}') (pt, pr, pb, pl) parser ctx t =
  let parser = Vp.p_value parser in
  let parser ctx = U.with_loc ctx (parser ctx) in
  (parser ctx >>= fun v1 ->
      choice [
        (parser ctx >>= fun v2 ->
           choice [
             (parser ctx >>= fun v3 ->
                 choice [
                  (parser ctx >>| fun v4 -> (v1, v2, v3, v4));
                  return (v1, v2, v3, v2) ]
             );
             return (v1, v2, v1, v2) ]
        ) ;
        return (v1, v1, v1, v1) ]
  ) >>= fun ((vt,lt), (vr,lr), (vb,lb), (vl, ll)) ->
    Vp.important ctx >>= fun important ->
    ws ctx *> peek_char >>= (function
     | Some c when end_cond c ->
         let t = P.add t pt vt lt important in
         let t = P.add t pr vr lr important in
         let t = P.add t pb vb lb important in
         let t = P.add t pl vl ll important in
         return t
     | _ -> fail ""
    ) <?> "trbl"

let global_or_trbl ((pt, pr, pb, pl) as props) parser ctx t =
  let glob =
    with_loc ctx (Vp.global_kw ctx) >>= fun (x,loc) ->
      Vp.important ctx >>=
      (fun important ->
         let (++) t p = P.add t p (x:>'a T.p_value) loc important in
         let t = P.(t ++ pt ++ pr ++ pb ++ pb) in
         return t
      )
  in
  choice [ glob ; trbl props parser ctx t ]

let p_border_color = trbl
   P.(border_top_color, border_right_color,
   border_bottom_color, border_left_color)
   Vp.color

let p_border_style = trbl
   P.(border_top_style, border_right_style,
    border_bottom_style, border_left_style)
     Vp.line_style

let p_border_width = trbl
  P.(border_top_width, border_right_width,
   border_bottom_width, border_left_width)
    Vp.border_width

let p_flex_flow ctx t =
  (with_loc ctx (Vp.flex_direction ctx) |||
   with_loc ctx (Vp.flex_wrap ctx)) >>= fun (d,w) ->
    Vp.important ctx >>= fun important ->
    let t = match d with
    | None -> t
    | Some (d,loc) -> P.add t P.flex_direction (`V d) loc important in
    let t = match w with
    | None -> t
    | Some (w,loc) -> P.add t P.flex_wrap (`V w) loc important in
  return t

let p_flex =
  let one ctx t = choice [
      (with_loc ctx (Vp.number ctx) >>|
       fun (n,loc) -> P.add t P.flex_grow (`V n) loc false) ;
      (with_loc ctx (of_kws [`None ; `Auto] ctx) >>= function
       | `Auto, loc ->
           let t = P.add t P.flex_grow (`V 1.) loc false in
           let t = P.add t P.flex_shrink (`V 1.) loc false in
           let t = P.add t P.flex_basis (`V `Auto) loc false in
           return t
       | `None, loc ->
           let t = P.add t P.flex_grow (`V 0.) loc false in
           let t = P.add t P.flex_shrink (`V 0.) loc false in
           let t = P.add t P.flex_basis (`V `Auto) loc false in
           return t
      );
      (with_loc ctx (Vp.flex_basis ctx) >>|
       (fun (v,loc) -> P.add t P.flex_basis (`V v) loc false)) ;
    ]
  in
  let two ctx t =
    with_loc ctx (Vp.number ctx) >>= fun (g,loc) ->
    let t = P.add t P.flex_grow (`V g) loc false in
    choice [
      (with_loc ctx (Vp.number ctx) >>| fun (n,loc) -> P.add t P.flex_shrink (`V n) loc false) ;
      (with_loc ctx (Vp.flex_basis ctx) >>= fun (v,loc) ->
         let t = P.add t P.flex_basis (`V v) loc false in
         return t);
    ]
  in
  let three ctx t =
    Angstrom.map3
      (with_loc ctx (Vp.number ctx))
      (with_loc ctx (Vp.number ctx))
      (with_loc ctx (Vp.flex_basis ctx))
      ~f:(fun g sh b ->
         let t = P.add_vl t P.flex_grow g in
         let t = P.add_vl t P.flex_shrink sh in
         let t = P.add_vl t P.flex_basis b in
         t
      )
  in
  let glob ctx t =
    with_loc ctx (global_kw ctx) >>= fun (x,loc) ->
    let t = P.add t P.flex_grow (x:>'a T.p_value) loc false in
    let t = P.add t P.flex_shrink (x:>'a T.p_value) loc false in
    let t = P.add t P.flex_basis (x:>T.flex_basis T.p_value) loc false in
    return t
  in
  fun ctx t ->
    choice (List.map (fun f -> f ctx t) [ glob ; three ; two ; one ]) >>= fun t ->
      Vp.important ctx >>| fun important ->
    let t = P.set_important t P.flex_grow important in
    let t = P.set_important t P.flex_shrink important in
    let t = P.set_important t P.flex_basis important in
    t

let font_variant =
  let palts = f P.font_variant_alternates Vp.font_variant_alternates in
  let pcaps = f P.font_variant_caps Vp.font_variant_caps in
  let pea = f P.font_variant_east_asian Vp.font_variant_east_asian in
  let pemoji = f P.font_variant_emoji Vp.font_variant_emoji in
  let plig = f P.font_variant_ligatures Vp.font_variant_ligatures in
  let pnum = f P.font_variant_numeric Vp.font_variant_numeric in
  let ppos = f P.font_variant_position Vp.font_variant_position in
  let parsers = [ palts ; pcaps ; pea ; pemoji ; plig ; pnum ; ppos ] in
  let fold ctx t = fold_with_parsers parsers
    ~parse_important:true (function ';'|'}' -> true | _ ->  false) ctx t in
  fun ctx t ->
    ctx.T.get_pos >>= fun pos ->
    let loc = pos, pos in
    let t = P.(fst ((t,loc)
        >! font_variant_alternates >! font_variant_caps >! font_variant_east_asian
          >! font_variant_emoji >! font_variant_ligatures >! font_variant_numeric
          >! font_variant_position))
    in
    (ws ctx *> fold ctx t >>= fun (t,imp) ->
       let t = P.set_important t P.font_variant_alternates imp in
       let t = P.set_important t P.font_variant_caps imp in
       let t = P.set_important t P.font_variant_east_asian imp in
       let t = P.set_important t P.font_variant_emoji imp in
       let t = P.set_important t P.font_variant_ligatures imp in
       let t = P.set_important t P.font_variant_numeric imp in
       let t = P.set_important t P.font_variant_position imp in
       return t
    )<?> "font-variant"

let p_font_variant =
  let set_normal loc t imp =
    let open P in let a = P.add in
    let n = `V `Normal in
    let t = a t font_variant_alternates n loc imp in
    let t = a t font_variant_caps n loc imp in
    let t = a t font_variant_east_asian n loc imp in
    let t = a t font_variant_emoji n loc imp in
    let t = a t font_variant_ligatures n loc imp in
    let t = a t font_variant_numeric n loc imp in
    let t = a t font_variant_position n loc imp in
    t
  in
  let of_kw ctx t =
    with_loc ctx (Vp.of_kws [`Normal ; `None] ctx) >>= fun kw ->
      Vp.important ctx >>| fun imp ->
      match kw with
      | (`Normal, loc) -> set_normal loc t imp
      | (`None, loc) ->
          let t = set_normal loc t imp in
          P.(add t font_variant_ligatures (`V `None) loc imp)
  in
  let glob ctx t =
    with_loc ctx (global_kw ctx) >>= fun (x,loc) ->
      Vp.important ctx >>= fun imp ->
    let open P in let a = P.add in
    let t = a t font_variant_alternates (x:>T.font_variant_alternates T.p_value) loc imp in
    let t = a t font_variant_caps (x:>T.font_variant_caps T.p_value) loc imp in
    let t = a t font_variant_east_asian (x:>T.font_variant_east_asian T.p_value) loc imp in
    let t = a t font_variant_emoji (x:>T.font_variant_emoji T.p_value) loc imp in
    let t = a t font_variant_ligatures (x:>T.font_variant_ligatures T.p_value) loc imp in
    let t = a t font_variant_numeric (x:>T.font_variant_numeric T.p_value) loc imp in
    let t = a t font_variant_position (x:>T.font_variant_position T.p_value) loc imp in
    return t
  in
  fun ctx t -> choice [
      glob ctx t ;
      of_kw ctx t ;
      font_variant ctx t ;
    ] <?> "p-font-variant"

let p_font =
  let sys_kw = of_kws T.system_font_names in
  let sys ctx t =
    with_loc ctx (sys_kw ctx) >>= fun (f,loc) ->
      Vp.important ctx >>| fun imp ->
      match T.get_system_font f with
      | None ->
          U.warn (fun m -> m "System font %S not defined" (Kw.string_of_kw f));
          t
      | Some f ->
          let open P in let a = P.add in
          let t = a t font_family (`V f.T.family) loc imp in
          let t = a t font_size (`V f.size) loc imp in
          let t = a t font_stretch (`V f.stretch) loc imp in
          let t = a t font_style (`V f.style) loc imp in
          let t = a t font_variant_alternates (`V f.variant_alternates) loc imp in
          let t = a t font_variant_caps (`V f.variant_caps) loc imp in
          let t = a t font_variant_east_asian (`V f.variant_east_asian) loc imp in
          let t = a t font_variant_emoji (`V f.variant_emoji) loc imp in
          let t = a t font_variant_ligatures (`V f.variant_ligatures) loc imp in
          let t = a t font_variant_numeric (`V f.variant_numeric) loc imp in
          let t = a t font_variant_position (`V f.variant_position) loc imp in
          let t = a t font_weight (`V f.weight) loc imp in
          let t = a t line_height (`V f.line_height) loc imp in
          t
  in
  let pstyle = f P.font_style Vp.font_style in
  let pvariant = f P.font_variant_caps (of_kws T.font_variant_css2) in
  let pweight = f P.font_weight Vp.font_weight in
  let pstretch = f P.font_stretch
    (of_kws T.font_stretch_css3 :> T.ctx -> T.font_stretch Angstrom.t) in
  let parsers = [  pstretch ; pstyle ; pvariant ; pweight ] in
  let fold ctx t = fold_with_parsers parsers
    ~fail:false ~parse_important:false
      (function ';'|'}' -> true | _ ->  false) ctx t
  in
  let spec ctx t =
    ctx.T.get_pos >>= fun pos ->
    let loc = pos, pos in
    let t = P.(fst ((t,loc)
          >! font_style >! font_weight >! font_stretch >! font_size >! line_height
            >! font_family >! font_kerning
            >! font_variant_alternates >! font_variant_caps >! font_variant_east_asian
            >! font_variant_emoji >! font_variant_ligatures >! font_variant_numeric
            >! font_variant_position))
    in
    (ws ctx *> fold ctx t >>= fun (t,_) ->
      with_loc ctx (Vp.font_size ctx) >>= fun (s,loc) ->
       let t = P.(add_vl t font_size (s,loc)) in
       U.debug (fun m -> m "font: parsed font_size");
       option t (U.slash ctx *> ws ctx *>
        with_loc ctx (Vp.line_height ctx) >>|
          (fun (h,loc) -> P.(add_vl t line_height (h, loc))))
         >>= (fun t ->
            U.debug (fun m -> m "font: parsed optional line_height");
            with_loc ctx (Vp.font_family ctx) >>| fun f ->
              P.(add_vl t font_family f)
         )
    ) >>= fun t -> Vp.important ctx >>= fun imp ->
    if imp then
      let (>!) t p = P.set_important t p imp in
      let t =
        t >! font_style >! font_weight >! font_stretch >! font_size >! line_height
          >! font_family >! font_kerning
          >! font_variant_alternates >! font_variant_caps >! font_variant_east_asian
          >! font_variant_emoji >! font_variant_ligatures >! font_variant_numeric
          >! font_variant_position
      in
      return t
    else
      return t

<?> "font-spec"
  in
  fun ctx t -> choice [
      (sys ctx t) ;
      (spec ctx t) ;
    ] <?> "font"

let set_borders_important t imp =
  let t = set_important t P.border_top_color imp in
  let t = set_important t P.border_top_style imp in
  let t = set_important t P.border_top_width imp in
  let t = set_important t P.border_right_color imp in
  let t = set_important t P.border_right_style imp in
  let t = set_important t P.border_right_width imp in
  let t = set_important t P.border_bottom_color imp in
  let t = set_important t P.border_bottom_style imp in
  let t = set_important t P.border_bottom_width imp in
  let t = set_important t P.border_left_color imp in
  let t = set_important t P.border_left_style imp in
  let t = set_important t P.border_left_width imp in
  t

let border =
  let pw ctx t =
    with_loc ctx (Vp.border_width ctx) >>= fun (v,loc) ->
    let v = P.{ v = `V v; loc; important = false } in
    let t = P.add_v t P.border_top_width v in
    let t = P.add_v t P.border_right_width v in
    let t = P.add_v t P.border_bottom_width v in
    let t = P.add_v t P.border_left_width v in
    return t
  in
  let ps ctx t =
    with_loc ctx (Vp.line_style ctx) >>= fun (v,loc) ->
    let v = P.{ v = `V v; loc; important = false } in
    let t = P.add_v t P.border_top_style v in
    let t = P.add_v t P.border_right_style v in
    let t = P.add_v t P.border_bottom_style v in
    let t = P.add_v t P.border_left_style v in
    return t
  in
 let pc ctx t =
    with_loc ctx (Vp.color ctx) >>= fun (v,loc) ->
    let v = P.{ v = `V v; loc; important = false } in
    let t = P.add_v t P.border_top_color v in
    let t = P.add_v t P.border_right_color v in
    let t = P.add_v t P.border_bottom_color v in
    let t = P.add_v t P.border_left_color v in
    return t
  in
  let parsers = [ pw ; ps ; pc ] in
  let fold ctx t = fold_with_parsers parsers
    ~parse_important:true (function ';'|'}' -> true | _ ->  false) ctx t in
  fun ctx t ->
    ctx.T.get_pos >>= fun pos ->
    let loc = pos, pos in
    let t = P.(fst ((t,loc)
        >! border_top_color >! border_top_style >! border_top_width
        >! border_right_color >! border_right_style >! border_right_width
        >! border_bottom_color >! border_bottom_style >! border_bottom_width
        >! border_left_color >! border_left_style >! border_left_width))
    in
    (ws ctx *> fold ctx t >>= fun (t,imp) ->
       return (set_borders_important t imp)
    ) <?> "border"

let p_border =
  let glob ctx t =
    with_loc ctx (global_kw ctx) >>= fun (x,loc) ->
    let c = (x:>T.color T.p_value) in
    let s = (x:>T.line_style T.p_value) in
    let w = (x:>T.border_width T.p_value) in
    let t = List.fold_left (fun t p -> P.add t p c loc false)
      t [ border_top_color ; border_right_color ;
        border_bottom_color ; border_left_color ]
    in
    let t = List.fold_left (fun t p -> P.add t p s loc false)
      t [ border_top_style ; border_right_style ;
        border_bottom_style ; border_left_style ]
    in
    let t = List.fold_left (fun t p -> P.add t p w loc false)
      t [ border_top_width ; border_right_width ;
        border_bottom_width ; border_left_width ]
    in
    return t
  in
  let with_important p ctx t =
    p ctx t >>= fun t -> Vp.important ctx >>= fun imp ->
      return (set_borders_important t imp)
  in
  fun ctx t -> choice [
      with_important glob ctx t ;
      border ctx t ;
    ] <?> "p-border"


let list_style =
  let pimg = f P.list_style_image Vp.list_style_image in
  let ppos = f P.list_style_position Vp.list_style_position in
  let ptyp= f P.list_style_type Vp.list_style_type in
  let parsers = [ pimg ; ppos ; ptyp ] in
  let fold ctx t = fold_with_parsers parsers
    ~parse_important:true (function ';'|'}' -> true | _ ->  false) ctx t in
  fun ctx t ->
    ctx.T.get_pos >>= fun pos ->
    let loc = pos, pos in
    let t = P.(fst ((t,loc)
        >! list_style_image >! list_style_position >! list_style_type))
    in
    (ws ctx *> fold ctx t >>= fun (t,imp) ->
       let t = set_important t P.list_style_image imp in
       let t = set_important t P.list_style_position imp in
       let t = set_important t P.list_style_type imp in
       return t
    ) <?> "list-style"


let p_list_style =
  let set_none loc t =
    let open P in
    let t = P.add t list_style_image (`V `None) loc false in
    let t = P.add t list_style_position (`V `Outside) loc false in
    let t = P.add t list_style_type (`V `None) loc false in
    t
  in
  let of_kw ctx t =
    with_loc ctx (Vp.of_kws [`None] ctx) >>| (function
     | (`None, loc) -> set_none loc t
    )
  in
  let glob ctx t =
    with_loc ctx (global_kw ctx) >>= fun (x,loc) ->
    let t = P.add t list_style_image (x:>T.list_style_image T.p_value) loc false in
    let t = P.add t list_style_position (x:>T.list_style_position T.p_value) loc false in
    let t = P.add t list_style_type (x:>T.list_style_type T.p_value) loc false in
    return t
  in
  let with_important p ctx t =
    p ctx t >>= fun t -> Vp.important ctx >>= fun imp ->
    let t = set_important t list_style_image imp in
    let t = set_important t list_style_position imp in
    let t = set_important t list_style_type imp in
    return t
  in
  fun ctx t -> choice [
      with_important glob ctx t ;
      with_important of_kw ctx t ;
      list_style ctx t ;
    ] <?> "p-list-style"


let p_margin = trbl P.margins Vp.margin
let p_padding = trbl P.paddings Vp.padding

let register () =
  let r = register_shorthand (module P.Css) in
  r "background-position" p_background_position;
  r "background" p_background;
  r "border-top" p_border_top;
  r "border-right" p_border_right;
  r "border-bottom" p_border_bottom;
  r "border-left" p_border_left ;
  r "border-color" p_border_color ;
  r "border-style" p_border_style ;
  r "border-width" p_border_width ;
  r "border" p_border ;
  r "flex-flow" p_flex_flow ;
  r "flex" p_flex ;
  r "font-variant" p_font_variant ;
  r "font" p_font ;
  r "list-style" p_list_style ;
  r "margin" p_margin ;
  r "padding" p_padding ;
  ()