Merge pull request #125 from ocsigen/fix-eliom-275

Add unit arg for constant attributes.

Author: Drup

lib/html_f.ml

@@ -79,7 +79,7 @@ struct
 
   let bool_attrib = user_attrib C.string_of_bool
 
-  let constant_attrib a =
+  let constant_attrib a () =
     string_attrib a (W.return a)
 
   let linktypes_attrib name x =

lib/html_sigs.mli

@@ -250,15 +250,15 @@ 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 : [> | `Async] attrib
+  val a_async : unit -> [> | `Async] attrib
 
-  val a_autofocus : [> | `Autofocus] attrib
+  val a_autofocus : unit -> [> | `Autofocus] attrib
 
-  val a_autoplay : [> | `Autoplay] attrib
+  val a_autoplay : unit -> [> | `Autoplay] attrib
 
-  val a_muted : [> | `Muted] attrib
+  val a_muted : unit -> [> | `Muted] attrib
 
   val a_crossorigin :
     [< | `Anonymous | `Use_credentials ] wrap -> [> | `Crossorigin ] attrib
@@ -271,7 +271,7 @@ module type T = sig
 
   val a_contextmenu : idref wrap -> [> | `Contextmenu] attrib
 
-  val a_controls : [> | `Controls] attrib
+  val a_controls : unit -> [> | `Controls] attrib
 
   val a_dir : [< | `Rtl | `Ltr] wrap -> [> | `Dir] attrib
 
@@ -283,23 +283,23 @@ module type T = sig
 
   val a_formenctype : contenttype wrap -> [> | `Formenctype] attrib
 
-  val a_formnovalidate : [> | `Formnovalidate] attrib
+  val a_formnovalidate : unit -> [> | `Formnovalidate] attrib
 
   val a_formtarget : text wrap -> [> | `Formtarget] attrib
 
-  val a_hidden : [> | `Hidden] attrib
+  val a_hidden : unit -> [> | `Hidden] attrib
 
   val a_high : float_number wrap -> [> | `High] attrib
 
   val a_icon : Xml.uri wrap -> [> | `Icon] attrib
 
-  val a_ismap : [> | `Ismap] attrib
+  val a_ismap : unit -> [> | `Ismap] attrib
 
   val a_keytype : text wrap -> [> | `Keytype] attrib
 
   val a_list : idref wrap -> [> | `List] attrib
 
-  val a_loop : [> | `Loop] attrib
+  val a_loop : unit -> [> | `Loop] attrib
 
   val a_low : float_number wrap -> [> | `High] attrib
 
@@ -321,9 +321,9 @@ module type T = sig
     [> `Inputmode] attrib
   (** @see <https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input#Attributes> Input HTML documentation. *)
 
-  val a_novalidate : [> | `Novalidate] attrib
+  val a_novalidate : unit -> [> | `Novalidate] attrib
 
-  val a_open : [> | `Open] attrib
+  val a_open : unit -> [> | `Open] attrib
 
   val a_optimum : float_number wrap -> [> | `Optimum] attrib
 
@@ -335,21 +335,21 @@ module type T = sig
 
   val a_preload : [< | `None | `Metadata | `Audio] wrap -> [> | `Preload] attrib
 
-  val a_pubdate : [> | `Pubdate] attrib
+  val a_pubdate : unit -> [> | `Pubdate] attrib
 
   val a_radiogroup : text wrap -> [> | `Radiogroup] attrib
 
-  val a_required : [> | `Required] attrib
+  val a_required : unit -> [> | `Required] attrib
 
-  val a_reversed : [> | `Reversed] attrib
+  val a_reversed : unit -> [> | `Reversed] attrib
 
   val a_sandbox : [< | sandbox_token ] list wrap -> [> | `Sandbox] attrib
 
   val a_spellcheck : bool wrap -> [> | `Spellcheck] attrib
 
-  val a_scoped : [> | `Scoped] attrib
+  val a_scoped : unit -> [> | `Scoped] attrib
 
-  val a_seamless : [> | `Seamless] attrib
+  val a_seamless : unit -> [> | `Seamless] attrib
 
   val a_sizes : (number * number) list option wrap -> [> | `Sizes] attrib
 
@@ -444,7 +444,7 @@ module type T = sig
   (** This attribute specifies a form processing agent. User agent
       behavior for a value other than an HTTP URI is undefined. *)
 
-  val a_checked : [> | `Checked] attrib
+  val a_checked : unit -> [> | `Checked] attrib
   (** When the [type] attribute has the value ["radio"] or
       ["checkbox"], this boolean attribute specifies that the
       button is on. User agents must ignore this attribute for
@@ -485,7 +485,7 @@ module type T = sig
     [@@ocaml.deprecated "Use a_method"]
   (** @deprecated Use a_method *)
 
-  val a_multiple : [> | `Multiple] attrib
+  val a_multiple : unit -> [> | `Multiple] attrib
 
   val a_name : text wrap -> [> | `Name] attrib
   (** This attribute assigns the control name. *)
@@ -497,7 +497,7 @@ module type T = sig
       the contents of the control when the contents extend beyond
       the visible area. *)
 
-  val a_selected : [> | `Selected] attrib
+  val a_selected : unit -> [> | `Selected] attrib
   (** When set, this boolean attribute specifies that
       this option is pre-selected. *)
 
@@ -545,9 +545,9 @@ module type T = sig
   val a_float_value : float_number wrap -> [> | `Float_Value] attrib
     [@@reflect.attribute "value" ["progress"; "meter"]]
 
-  val a_disabled : [> | `Disabled] attrib
+  val a_disabled : unit -> [> | `Disabled] attrib
 
-  val a_readonly : [> | `ReadOnly] attrib
+  val a_readonly : unit -> [> | `ReadOnly] attrib
   val a_button_type :
     [< | `Button | `Submit | `Reset] wrap -> [> | `Button_Type] attrib
       [@@reflect.attribute "type" ["button"]]
@@ -618,7 +618,7 @@ module type T = sig
 
   val a_http_equiv : text wrap -> [> | `Http_equiv] attrib
 
-  val a_defer :[> | `Defer] attrib
+  val a_defer : unit -> [> | `Defer] attrib
 
   val a_media : mediadesc wrap -> [> | `Media] 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,31 @@ let char ?separated_by:_ ?default:_ loc name s =
 
   Some (Exp.constant ~loc (Const_char c))
 
+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)
+
 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 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)
 
-  Some (Exp.construct ~loc (Location.mkloc (Longident.parse s) loc) None)
+let unit ?separated_by:_ ?default:_ loc name s =
+  if s = "" || s = name then
+    Some (Ast_convenience.(with_default_loc loc unit))
+  else
+    Ppx_common.error loc
+      {|Value of %s must be %s or "".|}
+      name name
 
 let int ?separated_by ?default loc name s =
   match int_exp loc s with

ppx/ppx_attribute_value.mli

@@ -94,8 +94,15 @@ 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]. *)
 
 val int : parser
 (** [int _ _ s] produces a parse tree for [int_of_string s]. *)

ppx/ppx_reflect.ml

@@ -96,7 +96,10 @@ 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]
 
   | [[%type: number]]
   | [[%type: pixels]]

test/test_ppx.ml

@@ -64,6 +64,42 @@ let basics = "ppx basics", tyxml_tests Html.[
 
 ]
 
+let attribs = "ppx attribs", tyxml_tests Html.[
+
+  "unit absent",
+  [[%html "<div hidden></div>"]],
+  [div ~a:[a_hidden ()] []] ;
+
+  "unit present",
+  [[%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.[
 
   "html/svg",
@@ -122,6 +158,7 @@ let antiquot = "ppx antiquot", tyxml_tests Html.[
 
 let tests = [
   basics ;
+  attribs ;
   ns_nesting ;
   antiquot ;
 ]