Add handling of on/off attributes (and improve bools).

Author: Drup

lib/html_sigs.mli

@@ -250,7 +250,7 @@ module type T = sig
 
   (** {3 Other attributes} *)
 
-  val a_autocomplete : bool wrap -> [> | `Autocomplete] attrib
+  val a_autocomplete : (bool[@onoff]) wrap -> [> | `Autocomplete] attrib
 
   val a_async : unit -> [> | `Async] attrib
 

ppx/ppx_attribute_value.ml

@@ -142,7 +142,9 @@ let float_exp loc s =
   with Failure "float_of_string" ->
     None
 
-
+let bool_exp loc b =
+  let s = if b then "true" else "false" in
+  Exp.construct ~loc (Location.mkloc (Longident.Lident s) loc) None
 
 (* Numeric. *)
 
@@ -172,14 +174,23 @@ let char ?separated_by:_ ?default:_ loc name s =
 
   Some (Exp.constant ~loc (Const_char c))
 
-let bool ?separated_by:_ ?default:_ loc name s =
-  begin
-    try bool_of_string s |> ignore
-    with Invalid_argument "bool_of_string" ->
-      Ppx_common.error loc "Value of %s must be \"true\" or \"false\"" name
-  end;
+let onoff ?separated_by:_ ?default:_ loc name s =
+  let b = match s with
+    | "" | "on" -> true
+    | "off" -> false
+    | _ ->
+      Ppx_common.error loc {|Value of %s must be "on", "" or "off"|} name
+  in
+  Some (bool_exp loc b)
 
-  Some (Exp.construct ~loc (Location.mkloc (Longident.parse s) loc) None)
+let bool ?separated_by:_ ?default:_ loc name s =
+  let b = match s with
+    | "" | "true" -> true
+    | "false" -> false
+    | _ ->
+      Ppx_common.error loc {|Value of %s must be "true", "" or "false"|} name
+  in
+  Some (bool_exp loc b)
 
 let unit ?separated_by:_ ?default:_ loc name s =
   if s = "" || s = name then

ppx/ppx_attribute_value.mli

@@ -94,8 +94,12 @@ val char : parser
     a parse tree for [c]. *)
 
 val bool : parser
-(** [bool _ _ s] produces a parse tree for the boolean [true] if [s = "true"]
-    and [false] if [s = "false"]. *)
+(** [bool _ _ s] produces a parse tree for the boolean [true]
+    if [s = "true"] or [""] and [false] if [s = "false"]. *)
+
+val onoff : parser
+(** [onoff _ _ s] produces a parse tree for the boolean [true]
+    if [s = "on"] or [""] and [false] if [s = "off"]. *)
 
 val unit : parser
 (** [unit _ name s] produces a parse tree for [()]. It fails if [name <> s]. *)

ppx/ppx_reflect.ml

@@ -96,6 +96,8 @@ let rec to_attribute_parser name = function
     [%expr wrap [%e to_attribute_parser name [ty]]]
 
   | [[%type: character]] -> [%expr char]
+  | [[%type: bool] as ty]
+    when AC.has_attr "onoff" ty.ptyp_attributes -> [%expr onoff]
   | [[%type: bool]] -> [%expr bool]
   | [[%type: unit]] -> [%expr nowrap unit]
 

test/test_ppx.ml

@@ -74,6 +74,30 @@ let attribs = "ppx attribs", tyxml_tests Html.[
   [[%html "<div hidden=hidden></div>"]],
   [div ~a:[a_hidden ()] []] ;
 
+  "bool default",
+  [[%html "<div draggable></div>"]],
+  [div ~a:[a_draggable true] []] ;
+
+  "bool true",
+  [[%html "<div draggable=true></div>"]],
+  [div ~a:[a_draggable true] []] ;
+
+  "bool false",
+  [[%html "<div draggable=false></div>"]],
+  [div ~a:[a_draggable false] []] ;
+
+  "onoff default",
+  [[%html "<form autocomplete></form>"]],
+  [form ~a:[a_autocomplete true] []] ;
+
+  "bool true",
+  [[%html "<form autocomplete=on></form>"]],
+  [form ~a:[a_autocomplete true] []] ;
+
+  "bool false",
+  [[%html "<form autocomplete=off></form>"]],
+  [form ~a:[a_autocomplete false] []] ;
+
 ]
 
 let ns_nesting = "namespace nesting" , tyxml_tests Html.[