Adding support for fill-opacity

CHANGES.md

@@ -1,3 +1,9 @@
+# NEXT
+
+* Add support for opacity attributes (`opacity`, `fill-opacity`, etc.).
+	(#325 by Martin @MBodin Bodin)
+
+
 # 4.6.0
 
 * Update for OCaml 5.0 and drop support for OCaml 4.2.0

lib/svg_f.ml

@@ -539,6 +539,8 @@ struct
   let a_animation_fill x =
     user_attrib C.string_of_big_variant "fill" x
 
+  let a_fill_opacity = user_attrib C.string_of_alpha_value "fill-opacity"
+
   let a_fill_rule = user_attrib C.string_of_fill_rule "fill-rule"
 
   let a_calcMode x =
@@ -711,9 +713,12 @@ struct
   let a_ontouchmove = Xml.touch_event_handler_attrib "ontouchmove"
   let a_ontouchcancel = Xml.touch_event_handler_attrib "ontouchcancel"
 
+
+  let a_opacity = user_attrib C.string_of_alpha_value "opacity"
+
   let a_stop_color = color_attrib "stop-color"
 
-  let a_stop_opacity = user_attrib C.string_of_number "stop-opacity"
+  let a_stop_opacity = user_attrib C.string_of_alpha_value "stop-opacity"
 
   let a_stroke = user_attrib C.string_of_paint "stroke"
 
@@ -735,7 +740,7 @@ struct
     user_attrib C.string_of_length "stroke-dashoffset"
 
   let a_stroke_opacity =
-    user_attrib C.string_of_number "stroke-opacity"
+    user_attrib C.string_of_alpha_value "stroke-opacity"
 
   (* xlink namespace given a nickname since some attributes mandated by
      the svg standard such as xlink:href live in that namespace, and we
@@ -1114,6 +1119,8 @@ struct
 
   let string_of_paint = string_of_paint
 
+  let string_of_alpha_value = string_of_number
+
   let string_of_fill_rule = string_of_fill_rule
 
   let string_of_strokedasharray = function

lib/svg_sigs.mli

@@ -78,7 +78,7 @@ module type T = sig
   *)
   type 'a wrap = 'a Xml.W.t
 
-  (** [list_wrap] is a containre for list of elements.
+  (** [list_wrap] is a container for list of elements.
 
       In most cases, ['a list_wrap = 'a list]. For [R] modules (in eliom or js_of_ocaml),
       It will be {!ReactiveData.RList.t}.
@@ -488,6 +488,8 @@ module type T = sig
   val a_animation_fill : [< | `Freeze | `Remove ] wrap -> [> | `Fill_Animation ] attrib
     [@@reflect.attribute "fill" ["animate"]]
 
+  val a_fill_opacity : alpha_value wrap -> [> | `Fill_opacity ] attrib
+
   val a_fill_rule : fill_rule wrap -> [> | `Fill_rule ] attrib
 
   val a_calcMode :
@@ -633,9 +635,11 @@ module type T = sig
        | `Text_after_edge | `Text_before_edge | `Inherit ] wrap ->
     [> | `Dominant_Baseline ] attrib
 
+  val a_opacity : alpha_value wrap -> [> | `Opacity ] attrib
+
   val a_stop_color : color wrap -> [> | `Stop_Color ] attrib
 
-  val a_stop_opacity : number wrap -> [> | `Stop_Opacity ] attrib
+  val a_stop_opacity : alpha_value wrap -> [> | `Stop_Opacity ] attrib
 
   val a_stroke : paint wrap -> [> | `Stroke ] attrib
 
@@ -654,7 +658,7 @@ module type T = sig
 
   val a_stroke_dashoffset : Unit.length wrap -> [> `Stroke_Dashoffset ] attrib
 
-  val a_stroke_opacity : float wrap -> [> `Stroke_Opacity ] attrib
+  val a_stroke_opacity : alpha_value wrap -> [> `Stroke_Opacity ] attrib
 
   (** {2 Events}
 
@@ -1112,6 +1116,8 @@ module type Wrapped_functions = sig
   val string_of_orient : (Svg_types.Unit.angle option, string) Xml.W.ft
 
   val string_of_paint : ([< Svg_types.paint], string) Xml.W.ft
+
+  val string_of_alpha_value : (Svg_types.alpha_value, string) Xml.W.ft
 
   val string_of_fill_rule : ([< Svg_types.fill_rule], string) Xml.W.ft
 

lib/svg_types.mli

@@ -279,6 +279,10 @@ type strings = string list
 type color = string
 type icccolor = string
 
+(* An alpha value can be either a number or a percentage.
+  We represent both as a number between 0 and 1. *)
+type alpha_value = float
+
 type paint_whitout_icc =
   [ `None | `CurrentColor
   | `Color of (color * icccolor option)

syntax/attribute_value.ml

@@ -484,6 +484,28 @@ let paint ?separated_by:_ ?default:_ loc name s =
             `Icc ([%e iri], Some [%e paint_without_icc loc name remainder])]
     end [@metaloc loc]
 
+let alpha_value =
+  let bad_form name loc =
+    Common.error loc "Value of %s must be a number or percentage" name in
+  let regexp = Re_str.regexp "\\([-+0-9eE.]+\\)\\(%\\)?" in
+
+  fun ?separated_by:_ ?default:_ loc name s ->
+    if not @@ does_match regexp s then bad_form name loc;
+    begin
+      try
+        let n = float_of_string (Re_str.matched_group 1 s) in
+        let v =
+          if group_matched 2 s then (n /. 100.)
+          else n in
+        if v >= 0. && v <= 1. then
+          Some [%expr [%e (Common.float loc @@ v)]]
+        else
+          let (min, max) =
+            if group_matched 2 s then ("0", "1") else ("0%", "100%") in
+          Common.error loc "Value of %s must be between %s and %s." name min max
+      with Failure _ -> bad_form name loc
+    end [@metaloc loc]
+
 let fill_rule ?separated_by:_ ?default:_ loc _name s =
   begin match s with
   | "nonzero" ->

syntax/attribute_value.mli

@@ -198,6 +198,14 @@ val paint : parser
    {:{https://www.w3.org/TR/SVG/painting.html#SpecifyingPaint} Specifying
    paint}. *)
 
+val alpha_value : parser
+(** Parses an SVG alpha value (either a percentage or a number),
+  converting it into a number between 0. and 1.
+  This parser is used in various places expecting opacity values.
+
+    @see <https://www.w3.org/TR/css-color-4/#alpha-syntax>
+*)
+
 val fill_rule : parser
 (** Parses an SVG fill-rule value.
 

syntax/reflect/reflect.ml

@@ -154,6 +154,8 @@ let rec to_attribute_parser lang name ~loc = function
   | [[%type: iri]]
   | [[%type: color]] -> [%expr string]
 
+  | [[%type: alpha_value]] -> [%expr alpha_value]
+
   | [[%type: nmtoken]; [%type: text wrap]] -> [%expr wrap string]
   | [[%type: string]; [%type: string wrap]] -> [%expr wrap string]
   | [[%type: string]; [%type: string list wrap]] -> [%expr wrap (spaces string)]

test/test_jsx.re

@@ -331,6 +331,18 @@ let svg = (
           ),
         ],
       ),
+      (
+        "opacity, circle",
+        [<circle cx="1" cy="2" r="3" fill="green" opacity="0.5" />],
+        [circle(~a=[a_cx((1., None)), a_cy((2., None)), a_r((3., None)),
+					a_fill(`Color (("green", None))), a_opacity(0.5)], [])],
+      ),
+      (
+        "fill_opacity percentage, rect",
+        [<rect x="1" y="2" width="3" height="4" fill="blue" fill_opacity="50%" />],
+        [rect(~a=[a_x((1., None)), a_y((2., None)), a_width((3., None)), a_height((4., None)),
+					a_fill(`Color (("blue", None))), a_fill_opacity(0.5)], [])],
+      ),
       (
         "fill_rule nonzero",
         [<path fill_rule="nonzero" />],

test/test_ppx.ml

@@ -416,6 +416,16 @@ let svg = "svg", SvgTests.make Svg.[
   [[%svg "<animate fill='freeze' values='1 2'/>"]],
   [animate ~a:[a_animation_fill `Freeze; a_animation_values ["1"; "2"]] []] ;
 
+  "opacity, circle",
+  [[%svg "<circle cx=1 cy=2 r=3 fill='green' opacity=0.5 />"]],
+  [circle ~a:[a_cx (1., None); a_cy (2., None); a_r (3., None);
+    a_fill (`Color ("green", None)); a_opacity 0.5] []] ;
+
+  "fill_opacity percentage, rect",
+  [[%svg "<rect x=1 y='2' width=3 height='4' fill='blue' fill-opacity='50%' />"]],
+  [rect ~a:[a_x (1., None); a_y (2., None); a_width (3., None); a_height (4., None);
+    a_fill (`Color ("blue", None)); a_fill_opacity 0.5] []] ;
+
   "fill_rule type nonzero",
   [[%svg "<path fill-rule='nonzero'/>"]],
   [path ~a:[a_fill_rule `Nonzero] []] ;