[feature] parser, compiler, xhtml: boolean attributes ("checked", "se…

…lected"...) now accept boolean values:

*   <input type="checkbox" checked={true}>
    produces:
    <input type="checkbox" checked="checked">

*   <input type="checkbox" checked={false}>
    produces
    <input type="checkbox">

CHANGELOG

@@ -1,6 +1,11 @@
 Feature:
 
+  * Xhtml boolean attributes ("checked", "selected"...) now accept boolean values:
+    <input type="checkbox" checked={true}> produces <input type="checkbox" checked="checked">
+    <input type="checkbox" checked={false}> produces <input type="checkbox">
+
   * New Dropbox database backend (experimental)
+
   * Added is_module and opacapi info in the doc API JSON file (generated with --api)
 
 Updated APIs:

compiler/opacapi/opacapi.ml

@@ -434,6 +434,8 @@ struct
 
   let void = !! "void"
   let xhtml = !! "xhtml"
+  let xhtml_bool_attribute_value = !! "xhtml_bool_attribute_value"
+  let xhtml_bool_attribute = !! "xhtml_bool_attribute"
   let xhtml_event = !! "xhtml_event"
   let xhtml_href   = !! "xhtml_href"
   let xml = !! "xml"

compiler/opalang/classic_syntax/parser_utils.ml

@@ -1187,6 +1187,9 @@ type 'b dom_tag_args = {
   (* CSS styles -- special probably because we want to preprocess them *)
   style : (string, 'b) expr option;
 
+  (* Boolean attributes like "checked", "selected" *)
+  bool_attributes : ((string, 'b) expr) list;
+
   (* Namespace bindings of the form [xmlns:bar = "foo"] or [xmlns = "foo"] *)
   xmlns_declaration: (string(*prefix, possibly empty*) * (string, 'b) expr(*unique uri*)) list;
 
@@ -1216,7 +1219,13 @@ let css_build1' s e = css_build (s,nlabel e) []
 let hyphen_to_underscore s = String.replace s "-" "_"
 let map_tuple4 f (a,b,c,d) = (f a, f b, f c, f d)
 
-
+let xhtml_bool_attribute name value =
+  let value = match value with
+    | Some v -> v
+    | None -> simple_record_expr "none" (nlabel name)
+  in
+  let value = coerce_name_expr value Opacapi.Types.xhtml_bool_attribute_value in
+  coerce_name_expr (record [("name", string2 name);  ("value", value)]) Opacapi.Types.xhtml_bool_attribute
 
 let to_handle (name : string * QmlLoc.annot) : (_,_) expr  =
   coerce_name_expr (record [(undecorate name, void (label name))]) Opacapi.Types.Dom.Event.kind
@@ -1230,15 +1239,16 @@ let hassoc_event name value =
 let empty_args _label = { args = [];
                          class_ = None;
                          style = None;
+                         bool_attributes = [];
                          events = [];
                          events_options = [];
                          events_expr = None;
                          xmlns_declaration = [];
                          href = None
                        }
 
-let is_empty_args {args=_; class_; style; events; events_options; events_expr; xmlns_declaration=_; href} =
-  events = [] && events_options = [] && events_expr = None && href = None &&
+let is_empty_args {args=_; class_; style; bool_attributes; events; events_options; events_expr; xmlns_declaration=_; href} =
+  events = [] && events_options = [] && bool_attributes = [] && events_expr = None && href = None &&
   class_ = None && style = None
 
 let arg_default (o,label) =
@@ -1302,7 +1312,8 @@ let create_element (ns,tag) args children =
   let record =
     if xhtml_mode () && not (is_empty_args args) then (
       let events         = list_expr_of_expr_list args.events         (nlabel tag)
-      and events_options = list_expr_of_expr_list args.events_options (nlabel tag) in
+      and events_options = list_expr_of_expr_list args.events_options (nlabel tag)
+      and bool_attributes = list_expr_of_expr_list args.bool_attributes (nlabel tag) in
       let class_ =
         match args.class_ with
         | None -> list_nil (label ns)
@@ -1314,11 +1325,12 @@ let create_element (ns,tag) args children =
       let specific_attributes =
         record [("class",class_);
                 ("style",style);
+                ("bool_attributes", bool_attributes);
                 ("events",appendlo events args.events_expr);
                 ("events_options", events_options);
                 ("href", match args.href with
                  | None   -> coerce_name_expr (simple_record_expr "none" (nlabel tag)) Opacapi.Types.xhtml_href
-                 | Some s -> s)
+                 | Some s -> s);
                ] in
       record [("namespace",tag_ns);
               ("tag",unc2 string tag);
@@ -1381,8 +1393,14 @@ let add_arg src ((prefix,_),name) value =
   let old = arg_default src in
   { old with args = (prefix, fst name, Option.default (unc2 string name) value) :: old.args }
 
+let add_bool_attribute src name value =
+  let name = match name with (s,pos) -> (String.lowercase s, pos) in
+  let old = arg_default src in
+    { old with bool_attributes = (xhtml_bool_attribute name value ) :: old.bool_attributes }
 
-
+let bool_record e =
+  let e = coerce_name_expr e Opacapi.Types.bool in
+  record [("bool", e)]
 
 let add_event src name value =
   let name = match name with (s,pos) -> (String.lowercase s, pos) in

compiler/opalang/classic_syntax/parser_utils.mli

@@ -411,6 +411,7 @@ type 'b dom_tag_args = {
   args : (string * string * (string, 'b) expr) list;
   class_ : (string, 'b) expr option;
   style : (string, 'b) expr option;
+  bool_attributes : ((string, 'b) expr) list;
   xmlns_declaration: (string * (string, 'b) expr) list;
   events : ((string, 'b) expr) list;
   events_expr : (string, 'b) expr option;
@@ -453,6 +454,11 @@ val add_arg :
   'a dom_tag_args option * annot ->
   (string * annot) * (string * annot) ->
   (string, 'a) expr option -> 'a dom_tag_args
+val add_bool_attribute :
+  'a dom_tag_args option * annot ->
+  string * annot ->
+  ((string, 'a) expr) option -> 'a dom_tag_args
+val bool_record : (string, [> `coerce ] as 'a) expr -> (string, 'a) expr
 val to_handle : string * annot -> (string, [> `coerce ]) expr
 val add_event :
   'a dom_tag_args option * annot ->

compiler/opalang/classic_syntax/xml.trx

@@ -210,6 +210,7 @@ just_args <-
     }}
   / xhtml_specific style_insensitive spacing "=" spacing style_value:v spacing args_option:tl               {{ {(arg_default tl) with style  = Some v} }}
   / xhtml_specific class_insensitive spacing "=" spacing class_value:v spacing args_option:tl               {{ {(arg_default tl) with class_ = Some v} }}
+  / xhtml_specific boolean_attribute_incensitive:s spacing boolean_attribute_value?:v spacing args_option:tl               {{ add_bool_attribute tl s v }}
   / xhtml_specific event_insensitive deco_sname:s spacing "=" spacing event_value:ev spacing args_option:tl {{ add_event tl s ev }}
   / xhtml_specific options_on_event_insensitive deco_sname:s spacing "=" spacing options_on_event_value:ev spacing args_option:tl  {{ add_event_option tl s ev }}
   / xhtml_specific "events_unsafe" spacing "=" spacing opa_expr:e spacing args_option:tl                           {{ add_events tl e }}
@@ -534,6 +535,24 @@ class_value        <-
   / deco_ename:e                                                                     {{ list_expr_of_expr_list [string2 e] (label e)}}
   / opa_expr:e                                                                       {{ e }}
 
+#####################################################################################
+## BOOLEAN ATTRIBUTE ################################################################
+#####################################################################################
+
+boolean_attribute_incensitive = deco boolean_attribute_incensitive_aux
+boolean_attribute_incensitive_aux <- 
+  / "checked"~ / "compact"~ / "declare"~ / "defer"~ / "disabled"~
+  / "ismap"~ / "multiple"~ / "nohref"~ / "noresize"~ / "noshade"~
+  / "nowrap"~ / "readonly"~ / "selected"~
+
+boolean_attribute_value <- "=" spacing boolean_attribute_value_aux:v {{ v }}
+
+boolean_attribute_value_aux <-
+  / squot deco_svalue:s squot {{ record ["string", string2 s] }}
+  / String_expr.string_with_opa:e spacing {{ record ["string", e] }}
+  / opa_expr:e {{ bool_record e }}
+  / deco_ename:s {{ record ["string", string2 s] }}
+
 #####################################################################################
 ## HANDLERS ASSIGNATION #############################################################
 #####################################################################################

lib/stdlib/core/xhtml/dom.opa

@@ -2008,7 +2008,7 @@ Dom = {{
                  ),
                (_nsenv, tag, args, element, attribute ->
                  match attribute with
-                 | ~{class style events events_options href} ->
+                 | ~{class style bool_attributes events events_options href} ->
                    //Handle classes
                    do List.iter(
                         class -> add_class_name(element, class),
@@ -2018,6 +2018,14 @@ Dom = {{
                         (| ~{name value} ->
                            add_style_application(cons, element, name, value)),
                            Css_printer.to_xhtml_style(style))
+                   //Handle boolean attributes like "checked" or "selected"
+                   do List.iter(~{name value} ->
+                        match value with
+                        | {string=value} -> set_attribute(element, name, value)
+                        | {bool=b} -> if b then set_attribute(element, name, name) else void
+                        | {none} -> set_attribute(element, name, name)
+                        end,
+                        bool_attributes)
                    //Handle events
                    do List.iter(
                         (|~{name value} ->

lib/stdlib/core/xhtml/xhtml.opa

@@ -82,10 +82,20 @@ type xhtml_href =
 /   {typed:Uri.uri}   /**Typed structure, we assume that it has already been checked, so no additional check.*/
 /   {none}            /**No URI*/
 
+@opacapi
+type xhtml_bool_attribute_value =
+    {string:string}
+/   {bool:bool}
+/   {none}
+
+@opacapi
+type xhtml_bool_attribute = { name:string value:xhtml_bool_attribute_value }
+
 type xhtml_specific_attributes =
   {
         class:list(string)/**The classes of this element.*/
         style:Css.properties /**The style properties of this element*/
+        bool_attributes:list(xhtml_bool_attribute)
         events:list(handle_assoc(xhtml_event)) /**The event handlers associated with this element, as a list of pairs event name (_not_ attribute name) * event handler */
         events_options:list(handle_assoc(list(Dom.event_option)))
         href: xhtml_href/**Possibly a hyperlink.*/
@@ -180,7 +190,7 @@ Xmlns =
      | {xml_dialect = {none}} as v -> {some = v}
      | {xml_dialect = {some=_}} -> {none}
      | ~{namespace tag args content xmlns specific_attributes={none}}
-     | ~{namespace tag args content xmlns specific_attributes={some = {style=[] class=[] events=[] events_options=[] href={none}}}} ->
+     | ~{namespace tag args content xmlns specific_attributes={some = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}}}} ->
         match List.map_while_opt(of_xhtml,content) with
         | {none} -> {none}
         | {some=content} ->
@@ -717,7 +727,7 @@ Xhtml =
       (c -> "&#{c};")
     )
 
-  default_attributes = {style=[] class=[] events=[] events_options=[] href={none}} : xhtml_specific_attributes
+  default_attributes = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}} : xhtml_specific_attributes
 
   createFragment : list(xhtml) -> xhtml = Xml.create_fragment
 
@@ -941,7 +951,7 @@ Xhtml =
 
           do match specific_attributes with
              | {none} -> void
-             | {some=~{class style events events_options href}} ->
+             | {some=~{class style bool_attributes events events_options href}} ->
           //Normalize tags
                do (
                  match tag with
@@ -967,6 +977,14 @@ Xhtml =
                    | _ -> void
                )
 
+               do List.iter(~{name value} ->
+                  match value with
+                  | {string=value} -> print_arg(sassoc(name,value))
+                  | {bool=b} -> if b then print_arg(sassoc(name,name)) else void
+                  | {none} -> print_arg(sassoc(name,name))
+                  end,
+                  bool_attributes)
+
                (load_events, other_events) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events)
                (_,   other_events_options) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events_options)
 
@@ -1463,7 +1481,7 @@ Replaced by a default value.")
                 {a with value="/*unsafe attribute from a client*/"}
               | _ -> a
               , _)
-          check_sargs({class=_ style=_ ~events events_options=_ href=_} as a) =
+          check_sargs({class=_ style=_ bool_attributes=_ ~events events_options=_ href=_} as a) =
             { a with events = List.map(
               | ~{name value=~{value}} ->
                 do Log.warning("Xhtml",