Add ppx.

.merlin

@@ -1,6 +1,7 @@
 S lib
 S syntax
 S tools
+S ppx
 
 B _build/*
 
@@ -9,3 +10,4 @@ FLG -w -32-34-37
 FLG -strict_sequence -safe_string
 
 PKG uutf re
+PKG compiler-libs.common ppx_tools.metaquot markup

Makefile

@@ -1,3 +1,6 @@
+OCAMLFIND_IGNORE_DUPS_IN = $(shell ocamlfind query compiler-libs)
+export OCAMLFIND_IGNORE_DUPS_IN
+
 # OASIS_START
 # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954)
 

_oasis

@@ -32,6 +32,10 @@ Flag syntax
   Description: Build the camlp4 syntax extension.
   Default: true
 
+Flag ppx
+  Description: Build the ppx syntax extension.
+  Default: false
+
 Library tyxml
   FindlibName: tyxml
   Path: implem
@@ -106,6 +110,33 @@ Library tymlx_p
   Modules:
     Simplexmlparser
 
+Library ppx
+  Build$: flag(ppx)
+  FindlibName: ppx
+  FindlibParent: tyxml
+  Path: ppx
+  InternalModules: Ppx_tyxml
+  XMETADescription:
+    HTML5 and SVG syntax extension (ppx)
+  XMETARequires: tyxml
+  XMETAExtraLines: ppx = "ppx_tyxml"
+
+Executable ppx_tyxml
+  Build$: flag(ppx)
+  Path: ppx
+  MainIs: ppx_tyxml.ml
+  BuildDepends:
+    re.str, ppx_tools.metaquot, markup, tyxml.tools
+  CompiledObject: best
+
+Executable ppx_reflect
+  Build$: flag(ppx)
+  Path: ppx
+  MainIs: ppx_reflect.ml
+  BuildDepends:
+    compiler-libs.common, ppx_tools.metaquot
+  CompiledObject: best
+
 ## Tests
 
 Executable emit_big
@@ -173,4 +204,4 @@ Document "tyxml-api"
   BuildTools: ocamldoc
   XOCamlbuildPath: ./
   XOCamlbuildLibraries:
-    tyxml, tyxml.functor, tyxml.parser, tyxml.syntax
+    tyxml, tyxml.functor, tyxml.parser, tyxml.syntax, tyxml.ppx

_tags

@@ -11,3 +11,6 @@ not <syntax/*>: warn_error(+1..49), warn_error(-45-3)
 not <syntax/*>: strict_sequence, safe_string, short_paths
 
 true: keep_locs
+
+# Tests use the tyxml ppx
+<test/*.ml>: ppx_tyxml

lib/html5_f.ml

@@ -85,9 +85,6 @@ struct
   (* space-separated *)
   let length_attrib = user_attrib C.string_of_multilength
 
-  let multilengths_attrib name x =
-    user_attrib C.string_of_multilengths name x
-
   let linktypes_attrib name x =
     user_attrib C.string_of_linktypes name x
 
@@ -461,10 +458,6 @@ struct
 
   let a_codetype = string_attrib "codetype"
 
-  let a_fs_rows mls = multilengths_attrib "rows" mls
-
-  let a_fs_cols mls = multilengths_attrib "cols" mls
-
   let a_frameborder x =
     user_attrib C.string_of_big_variant "frameborder" x
 
@@ -1042,9 +1035,6 @@ struct
   let string_of_numbers l =
     String.concat "," (List.map string_of_number l)
 
-  let string_of_multilengths l =
-    String.concat ", " (List.map string_of_multilength l)
-
   let string_of_mediadesc l =
     String.concat ", " (List.map string_of_mediadesc_token l)
 

lib/html5_sigs.mli

@@ -309,10 +309,12 @@ module type T = sig
   val a_max : float_number wrap -> [> | `Max] attrib
 
   val a_input_max : float_number wrap -> [> | `Input_Max] attrib
+    [@@reflect.attribute "max" ["input"]]
 
   val a_min : float_number wrap -> [> | `Min] attrib
 
   val a_input_min : float_number wrap -> [> | `Input_Min] attrib
+    [@@reflect.attribute "min" ["input"]]
 
   val a_novalidate : [> | `Novalidate] attrib
 
@@ -360,6 +362,7 @@ module type T = sig
   val a_srcset : image_candidate list wrap -> [> | `Srcset] attrib
 
   val a_img_sizes : text list wrap -> [> | `Img_sizes] attrib
+    [@@reflect.attribute "sizes" ["img"]]
 
   val a_start : number wrap -> [> | `Start] attrib
 
@@ -456,6 +459,7 @@ module type T = sig
   val a_for : idref wrap -> [> | `For] attrib
 
   val a_for_list : idrefs wrap -> [> | `For_List] attrib
+    [@@reflect.attribute "for" ["output"]]
 
   val a_maxlength : number wrap -> [> | `Maxlength] attrib
 
@@ -506,29 +510,36 @@ module type T = sig
     | `Date
     | `Color
     | `Button] wrap -> [> | `Input_Type] attrib
+      [@@reflect.attribute "type" ["input"]]
 
   val a_text_value : text wrap -> [> | `Text_Value] attrib
+    [@@reflect.attribute "value" ["param"; "button"; "option"]]
   (** This attribute specifies the initial value of the
       control. If this attribute is not set, the initial value is
       set to the contents of the [option] element. *)
 
   val a_int_value : number wrap -> [> | `Int_Value] attrib
+    [@@reflect.attribute "value" ["li"]]
 
   (*VVV NO *)
   val a_value : cdata wrap -> [> | `Value] attrib
 
   val a_float_value : float_number wrap -> [> | `Float_Value] attrib
+    [@@reflect.attribute "value" ["progress"; "meter"]]
 
   val a_disabled : [> | `Disabled] attrib
 
   val a_readonly : [> | `ReadOnly] attrib
   val a_button_type :
     [< | `Button | `Submit | `Reset] wrap -> [> | `Button_Type] attrib
+      [@@reflect.attribute "type" ["button"]]
 
   val a_command_type :
     [< | `Command | `Checkbox | `Radio] wrap -> [> | `Command_Type] attrib
+      [@@reflect.attribute "type" ["command"]]
 
   val a_menu_type : [< | `Context | `Toolbar] wrap -> [> | `Menu_Type] attrib
+    [@@reflect.attribute "type" ["menu"]]
 
   val a_label : text wrap -> [> | `Label] attrib
 
@@ -581,10 +592,6 @@ module type T = sig
 
   val a_codetype : contenttype wrap -> [> | `Codetype] attrib
 
-  val a_fs_rows : multilengths wrap -> [> | `FS_Rows] attrib
-
-  val a_fs_cols : multilengths wrap -> [> | `FS_Cols] attrib
-
   val a_frameborder : [< | `Zero | `One] wrap -> [> | `Frameborder] attrib
 
   val a_marginheight : pixels wrap -> [> | `Marginheight] attrib
@@ -614,10 +621,12 @@ module type T = sig
   val html :
     ?a: ((html_attrib attrib) list) ->
     [< | `Head] elt wrap -> [< | `Body] elt wrap -> [> | `Html] elt
+      [@@reflect.element "html"]
 
   val head :
     ?a: ((head_attrib attrib) list) ->
     [< | `Title] elt wrap -> (head_content_fun elt) list_wrap -> [> | head] elt
+      [@@reflect.element "head"]
 
   val base : ([< | base_attrib], [> | base]) nullary
 
@@ -698,6 +707,7 @@ module type T = sig
   val figure :
     ?figcaption: ([`Top of [< `Figcaption ] elt wrap | `Bottom of [< `Figcaption ] elt wrap ]) ->
     ([< | figure_attrib], [< | figure_content_fun], [> | figure]) star
+      [@@reflect.element "figure"]
 
   val hr : ([< | hr_attrib], [> | hr]) nullary
 
@@ -783,6 +793,7 @@ module type T = sig
       | `Name
       | `Usemap
     ], 'a, [> | `Object of 'a ]) star
+      [@@reflect.element "object_" "object"]
 
   val param : ([< | param_attrib], [> | param]) nullary
 
@@ -793,11 +804,13 @@ module type T = sig
     ?src:Xml.uri wrap ->
     ?srcs:(([< | source] elt) list_wrap) ->
     ([< | audio_attrib], 'a, [> 'a audio ]) star
+      [@@reflect.element "audio_video"]
 
   val video :
     ?src:Xml.uri wrap ->
     ?srcs: (([< | source] elt) list_wrap) ->
     ([< | video_attrib], 'a, [> 'a video]) star
+      [@@reflect.element "audio_video"]
 
   val canvas : ([< | canvas_attrib], 'a, [> | 'a canvas]) star
 
@@ -830,13 +843,15 @@ module type T = sig
     ?thead: [< | thead] elt wrap ->
     ?tfoot: [< | tfoot] elt wrap ->
     ([< | table_attrib], [< | table_content_fun], [> | table]) star
+      [@@reflect.element "table"]
 
   val tablex :
     ?caption: [< | caption] elt wrap ->
     ?columns: [< | colgroup] elt list_wrap ->
     ?thead: [< | thead] elt wrap ->
     ?tfoot: [< | tfoot] elt wrap ->
     ([< | tablex_attrib], [< | tablex_content_fun], [> | tablex]) star
+      [@@reflect.element "table" "table"]
 
   val colgroup :
     ([< | colgroup_attrib], [< | colgroup_content_fun], [> | colgroup]) star
@@ -866,6 +881,7 @@ module type T = sig
     ?legend: [ | `Legend ] elt wrap ->
     ([< | common | `Disabled | `Form | `Name], [< | flow5],
      [> | `Fieldset]) star
+      [@@reflect.element "fieldset"]
 
   val legend :
     ([< | legend_attrib], [< | legend_content_fun], [> | legend]) star
@@ -891,6 +907,7 @@ module type T = sig
         | `Options of ([< | `Option] elt) list_wrap
         | `Phras of ([< | phrasing] elt) list_wrap
       ]) -> ([< | common], [> | `Datalist]) nullary
+        [@@reflect.element "datalist"]
 
   val optgroup :
     label: text wrap  ->
@@ -929,6 +946,7 @@ module type T = sig
   val details :
     [< | `Summary] elt wrap ->
     ([< | common | `Open], [< | flow5], [> | `Details]) star
+      [@@reflect.element "details"]
 
   val summary :
     ([< | summary_attrib], [< | summary_content_fun], [> | summary]) star
@@ -950,6 +968,7 @@ module type T = sig
         | `Lis of ([< | `Li of [< | common]] elt) list_wrap
         | `Flows of ([< | flow5] elt) list_wrap
       ]) -> ([< | common | `Label | `Menu_Type], [> | `Menu]) nullary
+        [@@reflect.element "menu"]
 
   (** {3 Scripting} *)
 
@@ -1106,9 +1125,6 @@ module type Wrapped_functions = sig
   val string_of_multilength :
     ([< Html5_types.multilength], string) Xml.W.ft
 
-  val string_of_multilengths :
-    ([< Html5_types.multilength] list, string) Xml.W.ft
-
   val string_of_numbers : (Html5_types.numbers, string) Xml.W.ft
 
   val string_of_sandbox :

lib/html5_types.mli

@@ -122,7 +122,7 @@ type linktype =
     | `Sidebar
     | `Tag
     | `Up
-    | `Other of string ]
+    | `Other of string ] [@@reflect.total_variant]
 
 type linktypes = linktype list
 (** Authors may use the following recognized link types, listed here with
@@ -194,7 +194,7 @@ type mediadesc_token =
   | `Speech
   | `TTY
   | `TV
-  | `Raw_mediadesc of string ]
+  | `Raw_mediadesc of string ] [@@reflect.total_variant]
 
 type mediadesc = mediadesc_token list
 
@@ -237,10 +237,6 @@ type multilength = [ | length | `Relative of int ]
         ["2*"], and ["3*"], the ["1*"] will be allotted 10 pixels, the ["2*"] will be
         allotted 20 pixels, and the ["3*"] will be allotted 30 pixels. *)
 
-(* comma-separated *)
-type multilengths = multilength list
-(** A comma separated list of items of type MultiLength. *)
-
 type number = int
 
 (* space-separated *)

lib/svg_types.mli

@@ -1952,7 +1952,7 @@ type in_value =
   | `BackgroundAlpha
   | `FillPaint
   | `StrokePaint
-  | `Ref of string ]
+  | `Ref of string ] [@@reflect.total_variant]
 
 type offset =
   [ `Number of float

myocamlbuild.ml

@@ -25,6 +25,30 @@
 
 open Ocamlbuild_plugin
 
+(* Determine extension of CompiledObject: best *)
+let native_suffix =
+  let env =
+    BaseEnvLight.load ~allow_empty:true
+      ~filename:MyOCamlbuildBase.env_filename ()
+  in
+  if BaseEnvLight.var_get "is_native" env = "true"
+  then "native" else "byte"
+
+let reflect_ppx () =
+  let ppx_reflect = "ppx/ppx_reflect."^native_suffix in
+
+  let prod = "ppx/%_reflected.ml" in
+  let dep = "lib/%.mli" in
+
+  rule "ppx_reflect: mli -> _reflected.ml" ~prod ~deps:[dep; ppx_reflect]
+    begin fun env _ ->
+      Cmd (S [A ppx_reflect ; P (env dep); P (env prod)])
+    end
+
+let tyxml_ppx () =
+  let ppx_tyxml = "ppx/ppx_tyxml."^native_suffix in
+  flag_and_dep [ "ocaml" ; "compile" ; "ppx_tyxml" ] (S [A "-ppx"; P ppx_tyxml])
+
 let () =
   dispatch
     (fun hook ->
@@ -44,6 +68,9 @@ let () =
          if String.sub Sys.ocaml_version 0 4 = "4.00" then
            flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");
 
+         reflect_ppx () ;
+         tyxml_ppx () ;
+
        | _ ->
          ())
 

opam

@@ -11,12 +11,14 @@ dev-repo: "https://github.com/ocsigen/tyxml.git"
 build: [
   ["ocaml" "setup.ml" "-configure"
       "--%{camlp4:enable}%-syntax"
+      "--%{ppx_tools:enable}%-ppx"
       "--prefix" prefix]
   ["ocaml" "setup.ml" "-build"]
 ]
 build-test: [
   ["ocaml" "setup.ml" "-configure"
       "--%{camlp4:enable}%-syntax"
+      "--%{ppx_tools:enable}%-ppx"
       "--enable-tests"
       "--prefix" prefix]
   ["ocaml" "setup.ml" "-build"]
@@ -31,6 +33,8 @@ depends: [
   "uutf"
   "base-bytes"
   "re"
+  "markup"
+  ( "base-no-ppx" | "ppx_tools" )
   "alcotest" {test}
   ## OASIS is not required in released version
   "oasis" {build & >= "0.4.4"}