diff --git a/CHANGES.md b/CHANGES.md index bb71b71c5..3bcd2b39f 100644 --- a/CHANGES.md +++ b/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 diff --git a/lib/svg_f.ml b/lib/svg_f.ml index 3a6a13ff5..09bee606b 100644 --- a/lib/svg_f.ml +++ b/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 diff --git a/lib/svg_sigs.mli b/lib/svg_sigs.mli index 94bf76ed7..98f135892 100644 --- a/lib/svg_sigs.mli +++ b/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 diff --git a/lib/svg_types.mli b/lib/svg_types.mli index a786da522..a8c8af1ed 100644 --- a/lib/svg_types.mli +++ b/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) diff --git a/syntax/attribute_value.ml b/syntax/attribute_value.ml index 4630d6e11..457b01e61 100644 --- a/syntax/attribute_value.ml +++ b/syntax/attribute_value.ml @@ -484,6 +484,29 @@ 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 percent = group_matched 2 s in + let v = + if percent then (n /. 100.) + else n in + if v >= 0. && v <= 1. then + Some [%expr [%e (Common.float loc @@ v)]] + else + let (min, max) = + if percent then ("0%", "100%") else ("0", "1") 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" -> diff --git a/syntax/attribute_value.mli b/syntax/attribute_value.mli index 339afa6bd..0986e3a6c 100644 --- a/syntax/attribute_value.mli +++ b/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 +*) + val fill_rule : parser (** Parses an SVG fill-rule value. diff --git a/syntax/reflect/reflect.ml b/syntax/reflect/reflect.ml index dafd1975b..3a390463d 100644 --- a/syntax/reflect/reflect.ml +++ b/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)] diff --git a/test/test_jsx.re b/test/test_jsx.re index 18a5d4a7c..d7f50047d 100644 --- a/test/test_jsx.re +++ b/test/test_jsx.re @@ -331,6 +331,18 @@ let svg = ( ), ], ), + ( + "opacity, circle", + [], + [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(~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", [], diff --git a/test/test_ppx.ml b/test/test_ppx.ml index b521aada4..dd71af748 100644 --- a/test/test_ppx.ml +++ b/test/test_ppx.ml @@ -416,6 +416,16 @@ let svg = "svg", SvgTests.make Svg.[ [[%svg ""]], [animate ~a:[a_animation_fill `Freeze; a_animation_values ["1"; "2"]] []] ; + "opacity, circle", + [[%svg ""]], + [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 ~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 ~a:[a_fill_rule `Nonzero] []] ;