diff --git a/.merlin b/.merlin index 260b6d5d8..4b45eab73 100644 --- a/.merlin +++ b/.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 diff --git a/Makefile b/Makefile index f47ef93e0..3fb117ec5 100644 --- a/Makefile +++ b/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) diff --git a/_oasis b/_oasis index 41f59fdde..ea0bfdf9e 100644 --- a/_oasis +++ b/_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 diff --git a/_tags b/_tags index 6537ccae5..17bf2a88b 100644 --- a/_tags +++ b/_tags @@ -11,3 +11,6 @@ not : warn_error(+1..49), warn_error(-45-3) not : strict_sequence, safe_string, short_paths true: keep_locs + +# Tests use the tyxml ppx +: ppx_tyxml diff --git a/lib/html5_f.ml b/lib/html5_f.ml index 5de04c90e..737501bc0 100644 --- a/lib/html5_f.ml +++ b/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) diff --git a/lib/html5_sigs.mli b/lib/html5_sigs.mli index cce3068c8..75924437f 100644 --- a/lib/html5_sigs.mli +++ b/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,6 +843,7 @@ 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 -> @@ -837,6 +851,7 @@ module type T = sig ?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 : diff --git a/lib/html5_types.mli b/lib/html5_types.mli index 9a8412e96..4fcdc3da4 100644 --- a/lib/html5_types.mli +++ b/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 *) diff --git a/lib/svg_types.mli b/lib/svg_types.mli index 918bc10d2..6c55b2fee 100644 --- a/lib/svg_types.mli +++ b/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 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 9bde95767..0c1bf2305 100644 --- a/myocamlbuild.ml +++ b/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 () ; + | _ -> ()) diff --git a/opam b/opam index 497ba19df..8eda1b6e1 100644 --- a/opam +++ b/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"} diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml new file mode 100644 index 000000000..62884f0c6 --- /dev/null +++ b/ppx/ppx_attribute_value.ml @@ -0,0 +1,574 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +open Asttypes +open Ast_helper + +type value = [ + | `String of string + | `Expr of Parsetree.expression +] + +type 'a gparser = + ?separated_by:string -> ?default:string -> Location.t -> string -> 'a -> + Parsetree.expression option + +type parser = string gparser +type vparser = value gparser + +(* Handle expr *) + +let expr (parser : parser) : vparser = + fun ?separated_by ?default loc name v -> + match v with + | `Expr e -> Some e + | `String s -> parser ?separated_by ?default loc name s + +(* Options. *) + +let option none (parser : parser) ?separated_by:_ ?default:_ loc name s = + if s = none then Some [%expr None] [@metaloc loc] + else + match parser ~default:none loc name s with + | None -> None + | Some e -> Some [%expr Some [%e e]] [@metaloc loc] + + + +(* Lists. *) + +let filter_map f l = + l + |> List.fold_left (fun acc v -> + match f v with + | None -> acc + | Some v' -> v'::acc) + [] + |> List.rev + +(* Splits the given string on the given delimiter (a regular expression), then + applies [element_parser] to each resulting component. Each such application + resulting in [Some expr] is included in the resulting expression list. *) +let exp_list delimiter separated_by (element_parser : parser) loc name s = + Re_str.split delimiter s + |> filter_map (element_parser ~separated_by loc name) + +(* Behaves as _expr_list, but wraps the resulting expression list as a list + expression. *) +let list + delimiter separated_by element_parser ?separated_by:_ ?default:_ loc name s = + + exp_list delimiter separated_by element_parser loc name s + |> Ppx_common.list loc + |> fun e -> Some e + +let spaces = list (Re_str.regexp " +") "space" +let commas = list (Re_str.regexp " *, *") "comma" +let semicolons = list (Re_str.regexp " *; *") "semicolon" + +let spaces_or_commas_regexp = Re_str.regexp "\\( *, *\\)\\| +" +let spaces_or_commas_ = exp_list spaces_or_commas_regexp "space- or comma" +let spaces_or_commas = list spaces_or_commas_regexp "space- or comma" + + + +(* Wrapping. *) + +let wrap (parser : parser) implementation = + expr @@ + fun ?separated_by:_ ?default:_ loc name s -> + match parser loc name s with + | None -> Ppx_common.error loc "wrap applied to presence; nothing to wrap" + | Some e -> Some (Ppx_common.wrap implementation loc e) + +let nowrap (parser : parser) _ = + expr @@ + fun ?separated_by:_ ?default:_ loc name s -> + parser loc name s + + + +(* Error reporting for values in lists and options. *) + +let must_be_a + singular_description plural_description separated_by default loc name = + + let description = + match separated_by with + | Some separated_by -> + Printf.sprintf "a %s-separated list of %s" separated_by plural_description + | None -> + match default with + | Some default -> Printf.sprintf "%s or %s" singular_description default + | None -> singular_description + in + + Ppx_common.error loc "Value of %s must be %s" name description + + + +(* General helpers. *) + +(* Checks that the given string matches the given regular expression exactly, + i.e. the match begins at position 0 and ends at the end of the string. *) +let does_match regexp s = + Re_str.string_match regexp s 0 && Re_str.match_end () = String.length s + +(* Checks that the group with the given index was matched in the given + string. *) +let group_matched index s = + try Re_str.matched_group index s |> ignore; true + with Not_found -> false + +let int_exp loc s = + try Some (Ppx_common.int loc (int_of_string s)) + with Failure "int_of_string" -> None + +let float_exp loc s = + try + Some (Ppx_common.float loc @@ float_of_string s) + with Failure "float_of_string" -> + None + + + +(* Numeric. *) + +let char ?separated_by:_ ?default:_ loc name s = + let open Markup in + let open Markup.Encoding in + + let report _ error = + Ppx_common.error loc "%s in attribute %s" + (Markup.Error.to_string error |> String.capitalize) name + in + let decoded = string s |> decode ~report utf_8 in + + let c = + match next decoded with + | None -> Ppx_common.error loc "No character in attribute %s" name + | Some i -> + try Char.chr i + with Invalid_argument "Char.chr" -> + Ppx_common.error loc "Character out of range in attribute %s" name + in + + begin match next decoded with + | None -> () + | Some _ -> Ppx_common.error loc "Multiple characters in attribute %s" name + end; + + 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; + + Some (Exp.construct ~loc (Location.mkloc (Longident.parse s) loc) None) + +let int ?separated_by ?default loc name s = + match int_exp loc s with + | Some _ as e -> e + | None -> + must_be_a "a whole number" "whole numbers" separated_by default loc name + +let float ?separated_by ?default loc name s = + match float_exp loc s with + | Some _ as e -> e + | None -> + must_be_a + "a number (decimal fraction)" "numbers (decimal fractions)" + separated_by default loc name + +let points ?separated_by:_ ?default:_ loc name s = + let expressions = spaces_or_commas_ float loc name s in + + let rec pair acc = function + | [] -> List.rev acc |> Ppx_common.list loc + | [_] -> Ppx_common.error loc "Unpaired coordinate in %s" name + | ex::ey::rest -> pair (([%expr [%e ex], [%e ey]] [@metaloc loc])::acc) rest + in + + Some (pair [] expressions) + +let number_pair ?separated_by:_ ?default:_ loc name s = + let e = + begin match spaces_or_commas_ float loc name s with + | [orderx] -> [%expr [%e orderx], None] + | [orderx; ordery] -> [%expr [%e orderx], Some [%e ordery]] + | _ -> Ppx_common.error loc "%s requires one or two numbers" name + end [@metaloc loc] + in + + Some e + +let fourfloats ?separated_by:_ ?default:_ loc name s = + match spaces_or_commas_ float loc name s with + | [min_x; min_y; width; height] -> + Some [%expr ([%e min_x], [%e min_y], [%e width], [%e height])] + [@metaloc loc] + | _ -> Ppx_common.error loc "Value of %s must be four numbers" name + +(* These are always in a list; hence the error message. *) +let icon_size = + let regexp = Re_str.regexp "\\([0-9]+\\)[xX]\\([0-9]+\\)" in + + fun ?separated_by:_ ?default:_ loc name s -> + if not @@ does_match regexp s then + Ppx_common.error loc "Value of %s must be a %s, or %s" + name "space-separated list of icon sizes, such as 16x16" "any"; + + let width, height = + try + int_of_string (Re_str.matched_group 1 s), + int_of_string (Re_str.matched_group 2 s) + with Invalid_argument "int_of_string" -> + Ppx_common.error loc "Icon dimension out of range in %s" name + in + + Some + [%expr + [%e Ppx_common.int loc width], + [%e Ppx_common.int loc height]] [@metaloc loc] + + + +(* Dimensional. *) + +let length = + let regexp = Re_str.regexp "\\([0-9]+\\)\\([^0-9]+\\)" in + + fun ?separated_by:_ ?default:_ loc name s -> + if not @@ does_match regexp s then + Ppx_common.error + loc "Value of %s must be a length, such as 100px or 50%%" name; + + let n = + match int_exp loc (Re_str.matched_group 1 s) with + | Some n -> n + | None -> + Ppx_common.error loc "Value of %s out of range" name + in + + let e = + begin match Re_str.matched_group 2 s with + | "%" -> [%expr `Percent [%e n]] + | "px" -> [%expr `Pixels [%e n]] + | unit -> Ppx_common.error loc "Unknown unit %s in %s" unit name + end [@metaloc loc] + in + + Some e + +let svg_quantity = + let integer = "[+-]?[0-9]+" in + let integer_scientific = Printf.sprintf "%s\\([Ee]%s\\)?" integer integer in + let fraction = Printf.sprintf "[+-]?[0-9]*\\.[0-9]+\\([Ee]%s\\)?" integer in + let number = Printf.sprintf "%s\\|%s" integer_scientific fraction in + let quantity = Printf.sprintf "\\(%s\\)\\([^0-9]*\\)$" number in + let regexp = Re_str.regexp quantity in + + fun kind_singular kind_plural parse_unit ?separated_by ?default loc name s -> + if not @@ does_match regexp s then + must_be_a kind_singular kind_plural separated_by default loc name; + + let n = + match float_exp loc (Re_str.matched_group 1 s) with + | Some n -> n + | None -> Ppx_common.error loc "Number out of range in %s" name + in + + let unit_string = Re_str.matched_group 4 s in + let unit = + (if unit_string = "" then [%expr None] + else [%expr Some [%e parse_unit loc name unit_string]]) [@metaloc loc] + in + + [%expr [%e n], [%e unit]] [@metaloc loc] + +let svg_length = + let parse_unit loc name unit = + begin match unit with + | "cm" -> [%expr `Cm] + | "em" -> [%expr `Em] + | "ex" -> [%expr `Ex] + | "in" -> [%expr `In] + | "mm" -> [%expr `Mm] + | "pc" -> [%expr `Pc] + | "pt" -> [%expr `Pt] + | "px" -> [%expr `Px] + | "%" -> [%expr `Percent] + | s -> Ppx_common.error loc "Invalid length unit %s in %s" s name + end [@metaloc loc] + in + + fun ?separated_by ?default loc name s -> + Some + (svg_quantity "an SVG length" "SVG lengths" parse_unit + ?separated_by ?default loc name s) + +let angle_ = + let parse_unit loc name unit = + begin match unit with + | "deg" -> [%expr `Deg] + | "rad" -> [%expr `Rad] + | "grad" -> [%expr `Grad] + | s -> Ppx_common.error loc "Invalid angle unit %s in %s" s name + end [@metaloc loc] + in + + svg_quantity "an SVG angle" "SVG angles" parse_unit + +let angle ?separated_by ?default loc name s = + Some (angle_ ?separated_by ?default loc name s) + +let offset = + let bad_form name loc = + Ppx_common.error loc "Value of %s must be a number or percentage" name in + + let regexp = Re_str.regexp "\\([-+0-9eE.]+\\)$\\|\\([0-9]+\\)%" in + + fun ?separated_by:_ ?default:_ loc name s -> + if not @@ does_match regexp s then bad_form name loc; + + begin + if group_matched 1 s then + let n = + match float_exp loc s with + | Some n -> n + | None -> bad_form name loc + in + + Some [%expr `Number [%e n]] + + else + let n = + match int_exp loc (Re_str.matched_group 2 s) with + | Some n -> n + | None -> + Ppx_common.error loc "Percentage out of range in %s" name + in + + Some [%expr `Percentage [%e n]] + end [@metaloc loc] + +let transform = + let regexp = Re_str.regexp "\\([^(]+\\)(\\([^)]*\\))" in + + fun ?separated_by:_ ?default:_ loc name s -> + if not @@ does_match regexp s then + Ppx_common.error loc "Value of %s must be an SVG transform" name; + + let kind = Re_str.matched_group 1 s in + let values = Re_str.matched_group 2 s in + + let e = + begin match kind with + | "matrix" -> + begin match spaces_or_commas_ float loc "matrix" values with + | [a; b; c; d; e; f] -> + [%expr Svg_types.Matrix + ([%e a], [%e b], [%e c], [%e d], [%e e], [%e f])] + | _ -> + Ppx_common.error loc "%s: matrix requires six numbers" name + end + + | "translate" -> + begin match spaces_or_commas_ float loc "translate" values with + | [tx; ty] -> [%expr Svg_types.Translate ([%e tx], Some [%e ty])] + | [tx] -> [%expr Svg_types.Translate ([%e tx], None)] + | _ -> + Ppx_common.error loc "%s: translate requires one or two numbers" name + end + + | "scale" -> + begin match spaces_or_commas_ float loc "scale" values with + | [sx; sy] -> [%expr Svg_types.Scale ([%e sx], Some [%e sy])] + | [sx] -> [%expr Svg_types.Scale ([%e sx], None)] + | _ -> + Ppx_common.error loc "%s: scale requires one or two numbers" name + end + + | "rotate" -> + begin match Re_str.bounded_split spaces_or_commas_regexp values 2 with + | [a] -> + [%expr Svg_types.Rotate ([%e angle_ loc "rotate" a], None)] + | [a; axis] -> + begin match spaces_or_commas_ float loc "rotate axis" axis with + | [cx; cy] -> + [%expr Svg_types.Rotate + ([%e angle_ loc "rotate" a], Some ([%e cx], [%e cy]))] + | _ -> + Ppx_common.error loc "%s: rotate center requires two numbers" name + end + | _ -> + Ppx_common.error loc + "%s: rotate requires an angle and an optional center" name + end + + | "skewX" -> [%expr Svg_types.SkewX [%e angle_ loc "skewX" values]] + + | "skewY" -> [%expr Svg_types.SkewY [%e angle_ loc "skewY" values]] + + | s -> Ppx_common.error loc "%s: %s is not a valid transform type" name s + end [@metaloc loc] + in + + Some e + + + +(* String-like. *) + +let string ?separated_by:_ ?default:_ loc _ s = + Some (Exp.constant ~loc (Const_string (s, None))) + +let variand s = + let without_backtick s = + let length = String.length s in + String.sub s 1 (length - 1) + in + + s |> Tyxml_name.polyvar |> without_backtick + +let variant ?separated_by:_ ?default:_ loc _ s = + Some (Exp.variant ~loc (variand s) None) + +let total_variant (unary, nullary) ?separated_by:_ ?default:_ loc _name s = + let variand = variand s in + if List.mem variand nullary then Some (Exp.variant ~loc variand None) + else Some (Exp.variant ~loc unary (Some (Ppx_common.string loc s))) + + + +(* Miscellaneous. *) + +let presence ?separated_by:_ ?default:_ _ _ _ = None + +let paint_without_icc loc _name s = + begin match s with + | "none" -> + [%expr `None] + + | "currentColor" -> + [%expr `CurrentColor] + + | _ -> + let icc_color_start = + try Some (Re_str.search_forward (Re_str.regexp "icc-color(\\([^)]*\\))") s 0) + with Not_found -> None + in + + match icc_color_start with + | None -> [%expr `Color ([%e Ppx_common.string loc s], None)] + | Some i -> + let icc_color = Re_str.matched_group 1 s in + let color = String.sub s 0 i in + [%expr `Color + ([%e Ppx_common.string loc color], + Some [%e Ppx_common.string loc icc_color])] + end [@metaloc loc] + +let paint ?separated_by:_ ?default:_ loc name s = + if not @@ Re_str.string_match (Re_str.regexp "url(\\([^)]+\\))") s 0 then + Some (paint_without_icc loc name s) + else + let iri = Re_str.matched_group 1 s |> Ppx_common.string loc in + let remainder_start = Re_str.group_end 0 in + let remainder_length = String.length s - remainder_start in + let remainder = + String.sub s remainder_start remainder_length |> String.trim in + + begin + if remainder = "" then + Some [%expr `Icc ([%e iri], None)] + else + Some + [%expr + `Icc ([%e iri], Some [%e paint_without_icc loc name remainder])] + end [@metaloc loc] + +let srcset_element = + let space = Re_str.regexp " +" in + + fun ?separated_by:_ ?default:_ loc name s -> + let e = + begin match Re_str.bounded_split space s 2 with + | [url] -> + [%expr `Url [%e Ppx_common.string loc url]] + + | [url; descriptor] -> + let bad_descriptor () = + Ppx_common.error loc "Bad width or density descriptor in %s" name in + + let url = Ppx_common.string loc url in + let suffix_index = String.length descriptor - 1 in + + let is_width = + match descriptor.[suffix_index] with + | 'w' -> true + | 'x' -> false + | _ -> bad_descriptor () + | exception Invalid_argument _ -> bad_descriptor () + in + + if is_width then + let n = + match int_exp loc (String.sub descriptor 0 suffix_index) with + | Some n -> n + | None -> + Ppx_common.error loc "Bad number for width in %s" name + in + + [%expr `Url_width ([%e url], [%e n])] + + else + let n = + match float_exp loc (String.sub descriptor 0 suffix_index) with + | Some n -> n + | None -> + Ppx_common.error loc "Bad number for pixel density in %s" name + in + + [%expr `Url_pixel ([%e url], [%e n])] + + | _ -> Ppx_common.error loc "Missing URL in %s" name + end [@metaloc loc] + in + + Some e + + + +(* Special-cased. *) + +let sandbox = spaces variant + +let in_ = total_variant Svg_types_reflected.in_value + +let in2 = in_ + +let xmlns ?separated_by:_ ?default:_ loc name s = + if s <> Markup.Ns.html then + Ppx_common.error loc "%s: namespace must be %s" name Markup.Ns.html; + + Some [%expr `W3_org_1999_xhtml] [@metaloc loc] diff --git a/ppx/ppx_attribute_value.mli b/ppx/ppx_attribute_value.mli new file mode 100644 index 000000000..57deb70fa --- /dev/null +++ b/ppx/ppx_attribute_value.mli @@ -0,0 +1,214 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Attribute value parsers and parser combinators. *) + + +type value = [ + | `String of string + | `Expr of Parsetree.expression +] +(** Values are either an OCaml expression, provided through an antiquotations + or a string parser from a literal. +*) + +type 'a gparser = + ?separated_by:string -> ?default:string -> Location.t -> string -> 'a -> + Parsetree.expression option +and parser = string gparser +and vparser = value gparser +(** Attribute value parsers are assigned to each attribute depending on the type + of the attribute's argument, though some attributes have special parsers + based on their name, or on a [[@@reflect]] annotation. A parser is a + function [p] such that [p loc name value] either: + + - converts the string [value] into [Some] of a parse tree representing that + value, for use with attributes that take an argument, or + - evaluates to [None], for use with attributes that take no argument (for + instance, [a_selected]). + + For example, [int loc name "3"] converts ["3"] into the parse tree + [{pexp_desc = Pexp_constant (Const_int 3); ...}]. + + The parse tree is assigned the location [loc]. This {e should} be the + location of the start of the value string, but, presently, the location of + the element containing the value string is used. + + [name] is the name of the attribute. This is used only for error reporting. + + [~separated_by] and [~default] are used internally by combinators to modify + the error message (for example, to make nouns plural if an error occurs in a + list). *) + + + +(** {2 Combinators} *) + +val option : string -> parser -> parser +(** [option none parser _ _ s] behaves as follows: + + - if [s] = [none], evaluates to a parse tree for [None]. + - otherwise, if [parser _ _ s] evaluates to a parse tree for [e], [option] + evaluates to a parse tree for [Some e]. *) + +val spaces : parser -> parser +(** [spaces parser _ _ s] splits [s] on spaces, then applies [parser] to each + component. The resulting parse trees for [e, e', ...] are combined into a + parse tree fo [[e; e'; ...]]. *) + +val commas : parser -> parser +(** Similar to [spaces], but splits on commas. *) + +val semicolons : parser -> parser +(** Similar to [spaces], but splits on semicolons. *) + +val spaces_or_commas : parser -> parser +(** Similar to [spaces], but splits on both spaces and commas. *) + +(** {3 Top combinators} + Exported parsers should always use one of those combinators last. *) + +val wrap : parser -> Ppx_common.lang -> vparser +(** [wrap parser module_ _ _ s] applies [parser _ _ s] to get a parse tree for + [e], then evaluates to the parse tree for [module_.Xml.W.return e]. *) + +val nowrap : parser -> Ppx_common.lang -> vparser +(** [nowrap parser _ _ _ s] evaluates to [parser _ _ s]. The purpose of this + combinator is to provide a signature similar to [wrap] in situations where + wrapping is not wanted. *) + + + +(** {2 Numeric} *) + +val char : parser +(** [char _ _ s], where [s] is a string containing a single byte [c], produces + 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"]. *) + +val int : parser +(** [int _ _ s] produces a parse tree for [int_of_string s]. *) + +val float : parser +(** [float _ _ s] produces a parse tree for [float_of_string s]. This is a + slight superset of HTML and SVG decimal fraction number syntax. *) + +val points : parser +(** Similar to [spaces_or_commas float], but pairs consecutive numbers. *) + +val number_pair : parser +(** [number_pair _ _ s] produces a parse tree for + + - [n, None] if [s] = [(string_of_float n)], or + - [m, Some n'] if [s] is a space- or comma-separated list of representations + of two floats. *) + +val fourfloats : parser +(** Acts as [spaces_or_commas float], but expects the list to have exactly four + elements. *) + +val icon_size : parser +(** [icon_size _ _ s] produces a parse tree for the pair [(width, height)] when + [s] has the form [(string_of_int width) ^ x ^ (string_of_int height)] and + [x] is either ["x"] or ["X"]. *) + + + +(** {2 Dimensional} *) + +val length : parser +(** [length _ _ s] produces a parse tree for + + - [`Pixels i] if [s] has form [(string_of_int i) ^ "px"], or + - [`Percent i] if [s] has form [(string_of_int i) ^ "%"]. *) + +val svg_length : parser +(** [svg_length _ _ s] produces a parse tree for a value of type + [Svg_types.Unit.(length quantity)]. [s] is expected to have form + [(string_of_float n) ^ unit] for some number [n] and a valid SVG length + unit, or no unit. *) + +val angle : parser +(** Similar to [svg_length], but for SVG angles. *) + +val offset : parser +(** [offset _ _ s produces a parse tree for + + - [`Number n] if [s] = [string_of_float n], or + - [`Percentage i] if [s] has form [(string_of_int i) ^ "%"]. *) + +val transform : parser +(** Parses an SVG transform attribute value. See + {:{https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/transform} + transform (MDN)}. *) + + + +(* {2 String-like} *) + +val string : parser +(** [string _ _ s] produces a parse tree for [s]. This is intended for ordinary + attributes containing text that requires no further parsing. *) + +val variant : parser +(** [variant _ _ s] produces a parse tree for the variand + [Tyxml_name.polyvar s]. This is intended for attributes whose argument type + is a polymorphic variant, none of whose constructors take arguments. *) + +val total_variant : (string * string list) -> parser +(** [total_variant] is used for parsing arguments whose type is a variant with + the following pattern: + +{[ +| `A | `B | `C | `EverythingElse of string +]} + + It behaves like [variant] for strings matching the no-argument constructors. + Any other string [s] is mapped to the parse trees for + [`EverythingElse s]. *) + + + +(* {2 Miscellaneous} *) + +val presence : parser +(** [presence _ _ _] evaluates to [None]. It is used as a "parser" for + attributes that do not take arguments. *) + +val paint : parser +(* Parses SVG paint values. See + {:{https://www.w3.org/TR/SVG/painting.html#SpecifyingPaint} Specifying + paint}. *) + +val srcset_element : parser +(** Used for [a_srcset]. *) + + + +(* {2 Special-cased} + + These parsers are named after the attribute for which they are used. *) + +val sandbox : parser +val in_ : parser +val in2 : parser +val xmlns : parser diff --git a/ppx/ppx_attributes.ml b/ppx/ppx_attributes.ml new file mode 100644 index 000000000..6abd73929 --- /dev/null +++ b/ppx/ppx_attributes.ml @@ -0,0 +1,139 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +let parse loc (ns, element_name) attributes = + let language, (module Reflected) = + Ppx_namespace.reflect loc ns in + + (* For attribute names ["data-foo"], evaluates to [Some "foo"], otherwise + evaluates to [None]. *) + let parse_user_data local_name = + let prefix = "data-" in + let length = String.length prefix in + + let is_user_data = + try language = Html && String.sub local_name 0 length = prefix + with Invalid_argument _ -> false + in + + if not is_user_data then None + else Some (String.sub local_name length (String.length local_name - length)) + in + + (* Applied to each attribute. Accumulates individually labeled attributes, + such as img/src, in "labeled," and attributes passed in ~a in "regular." *) + let parse_attribute (labeled, regular) ((_, local_name), value) = + (* Convert the markup name of the attribute to a TyXML name without regard + to renamed attributes such as "a_input_max." Renaming will be accounted + for later. *) + let tyxml_name = Tyxml_name.attrib local_name in + + let test_labeled (e, a, _) = e = element_name && a = local_name in + let test_blacklisted (a, _, _) = a = tyxml_name in + let test_renamed (_, a, es) = a = local_name && List.mem element_name es in + + let unknown () = + Ppx_common.error loc "Unknown attribute in %s element: %s" + (Ppx_common.lang language) local_name + in + + (* Check whether this attribute is individually labeled. Parse its argument + and accumulate the attribute if so. *) + match Ppx_common.find test_labeled Reflected.labeled_attributes with + | Some (_, label, parser) -> + let e = + match parser language loc local_name value with + | None -> + Ppx_common.error loc + "Internal error: labeled attribute %s without an argument" label + | Some e -> e + in + + (label, e)::labeled, regular + + | None -> + (* The attribute is not individually labeled, so it is passed in ~a. + + First, check if the default TyXML name of this attribute collides with + the TyXML name of a renamed attribute. For example, if the language is + HTML, and this attribute has markup name "input-max" (which is + invalid), then its default TyXML name will be "a_input_max", which is a + *valid* value in TyXML. We want to avoid mapping "input-max" to + "a_input_max", because "input-max" is invalid, and because + "a_input_max" maps to "max" instead. *) + if List.exists test_blacklisted Reflected.renamed_attributes then + unknown () + else + (* Check if this is a "data-foo" attribute. Parse the attribute value, + and accumulate it in the list of attributes passed in ~a. *) + match parse_user_data local_name with + | Some tag -> + let tyxml_name = "a_user_data" in + + let parser = + try List.assoc tyxml_name Reflected.attribute_parsers + with Not_found -> + Ppx_common.error loc "Internal error: no parser for %s" tyxml_name + in + + let identifier = Ppx_common.make ~loc language tyxml_name in + let tag = Ppx_common.string loc tag in + + let e = + match parser language loc local_name value with + | Some e' -> [%expr [%e identifier] [%e tag] [%e e']] [@metaloc loc] + | None -> + Ppx_common.error loc "Internal error: no expression for %s" + tyxml_name + in + + labeled, e::regular + + | None -> + let tyxml_name = + match Ppx_common.find test_renamed Reflected.renamed_attributes with + | Some (name, _, _) -> name + | None -> tyxml_name + in + + let parser = + try List.assoc tyxml_name Reflected.attribute_parsers + with Not_found -> unknown () + in + + let identifier = Ppx_common.make ~loc language tyxml_name in + + let e = + match parser language loc local_name value with + | None -> identifier + | Some e' -> [%expr [%e identifier] [%e e']] [@metaloc loc] + in + + labeled, e::regular + in + + let labeled, regular = + List.fold_left parse_attribute ([], []) attributes in + + (* If there are any attributes to pass in ~a, assemble them into a parse tree + for a list, and prefix that with the ~a label. *) + if regular = [] then List.rev labeled + else + let regular = "a", Ppx_common.list loc (List.rev regular) in + List.rev (regular::labeled) diff --git a/ppx/ppx_attributes.mli b/ppx/ppx_attributes.mli new file mode 100644 index 000000000..4e728aaab --- /dev/null +++ b/ppx/ppx_attributes.mli @@ -0,0 +1,38 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Attribute parsing. *) + + + +val parse : + Location.t -> Markup.name -> (Markup.name * Ppx_attribute_value.value) list -> + (Asttypes.label * Parsetree.expression) list +(** [parse loc element_name attributes] evaluates to a list of labeled parse + trees, each representing an attribute argument to the element function for + [element_name]. For example, if called on the HTML element + [bar], this function will evaluate to + parse trees for the arguments: + +{[ +~src:(return "foo") ~alt:(return "bar") ~a:[id (return "some-image")] +]} + + This satisfies the attribute arguments in the signature of + [Html5_sigs.T.img]. *) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml new file mode 100644 index 000000000..f4caee6a2 --- /dev/null +++ b/ppx/ppx_common.ml @@ -0,0 +1,88 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +open Ast_helper +module Label = Ast_convenience.Label + +(** Lang utilities *) + +type lang = Html | Svg + +let html5_implementation = ref "Html5" +let svg_implementation = ref "Svg" + +let implemenentation_ref = function + | Html -> html5_implementation + | Svg -> svg_implementation + +let set_implementation lang s = + (implemenentation_ref lang) := s + +let implementation lang = + !(implemenentation_ref lang) + +let lang = function + | Html -> "HTML" + | Svg -> "SVG" + +let make ~loc i s = + let lid = Longident.parse @@ implementation i ^ "." ^ s in + Exp.ident ~loc @@ Location.mkloc lid loc + +(** Generic *) + +let find f l = + try Some (List.find f l) + with Not_found -> None + +let with_loc loc f x = + with_default_loc loc @@ fun () -> f x +let error loc fmt = Location.raise_errorf ~loc ("Error: "^^fmt) + +(** Ast manipulation *) + +let int loc = with_loc loc Ast_convenience.int + +let float loc = with_loc loc Ast_convenience.float + +let string loc = with_loc loc Ast_convenience.str + +let list_gen cons nil l = + (l |> List.rev |> List.fold_left cons nil) + +let list loc = + let nil = [%expr []][@metaloc loc] in + let cons acc x = [%expr [%e x]::[%e acc]][@metaloc loc] in + list_gen cons nil + +let list_wrap lang loc = + let nil = + [%expr + [%e make ~loc lang "Xml.W.nil"] + ()] [@metaloc loc] + in + let cons acc x = + [%expr [%e make ~loc lang "Xml.W.cons"] [%e x] [%e acc]][@metaloc loc] + in + list_gen cons nil + +let wrap implementation loc e = + [%expr + [%e make ~loc implementation "Xml.W.return"] + [%e e]] [@metaloc loc] diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli new file mode 100644 index 000000000..823b60405 --- /dev/null +++ b/ppx/ppx_common.mli @@ -0,0 +1,50 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +val find : ('a -> bool) -> 'a list -> 'a option +(** Similar to [List.find], but evaluates to an option instead of raising + [Not_found]. *) + +module Label = Ast_convenience.Label + +(** Markup language *) + +type lang = Html | Svg +val lang : lang -> string +val implementation : lang -> string +val set_implementation : lang -> string -> unit + +val make : + loc:Location.t -> lang -> string -> Parsetree.expression + +(** Expression helpers. *) + +val int : Location.t -> int -> Parsetree.expression +val float : Location.t -> float -> Parsetree.expression +val string : Location.t -> string -> Parsetree.expression +val list : Location.t -> Parsetree.expression list -> Parsetree.expression +val list_wrap : lang -> Location.t -> Parsetree.expression list -> Parsetree.expression + +val wrap : + lang -> Location.t -> Parsetree.expression -> Parsetree.expression +(** [wrap_exp implementation loc e] creates a parse tree for + [implementation.Xml.W.return e]. *) + +val error : Location.t -> ('b, unit, string, 'a) format4 -> 'b +(** Raises an error using compiler module [Location]. *) diff --git a/ppx/ppx_element.ml b/ppx/ppx_element.ml new file mode 100644 index 000000000..b12ab68bb --- /dev/null +++ b/ppx/ppx_element.ml @@ -0,0 +1,46 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +let parse ~loc ~name:((ns, name) as element_name) ~attributes children = + + let attributes = Ppx_attributes.parse loc element_name attributes in + let lang, (module Reflected) = Ppx_namespace.reflect loc ns in + + let name = + try List.assoc name Reflected.renamed_elements + with Not_found -> name + in + let element_function = Ppx_common.make ~loc lang name in + + let assembler = + try List.assoc name Reflected.element_assemblers + with Not_found -> + Ppx_common.error loc "Unknown %s element %s" (Ppx_common.lang lang) name + in + + let children = assembler ~lang ~loc ~name children in + + Ast_helper.Exp.apply ~loc element_function (attributes @ children) + +let comment ~loc ~lang s = + let tot = Ppx_common.make ~loc lang "tot" in + let comment = Ppx_common.make ~loc lang "Xml.comment" in + let s = Ppx_common.string loc s in + (* Using metaquot here avoids fiddling with labels. *) + [%expr [%e tot] ([%e comment] [%e s])][@metaloc loc] diff --git a/ppx/ppx_element.mli b/ppx/ppx_element.mli new file mode 100644 index 000000000..51ad6f36d --- /dev/null +++ b/ppx/ppx_element.mli @@ -0,0 +1,37 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Element parsing. *) + +val parse : + loc:Location.t -> + name:Markup.name -> + attributes:(Markup.name * Ppx_attribute_value.value) list -> + Parsetree.expression list -> + Parsetree.expression +(** [parse ~loc ~name ~attributes children] evaluates to a parse tree for applying + the TyXML function corresponding to element [name] to suitable arguments + representing [attributes] and [children]. *) + +val comment : + loc:Location.t -> + lang:Ppx_common.lang -> + string -> + Parsetree.expression +(** [comment ~loc ~ns s] evaluates to a parse tree that represents an XML comment. *) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml new file mode 100644 index 000000000..64fe755b0 --- /dev/null +++ b/ppx/ppx_element_content.ml @@ -0,0 +1,246 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +open Asttypes +open Parsetree +module Pc = Ppx_common + +type assembler = + lang:Ppx_common.lang -> + loc:Location.t -> + name:string -> + Parsetree.expression list -> + (Pc.Label.t * Parsetree.expression) list + + + +(* Helpers. *) + +(* Called on a parse tree representing a child of an element. The argument + [implementation] is the module name (string) ["Html5"] if the parent element + is in the HTML namespace, and ["Svg"] if the parent is in the SVG namespace. + + - If the child is an unqualified application of the function [pcdata], + qualifies it with the module [implementation]. + - If [implementation] is ["Html5"] and the child is an application of [svg] + from any module, modifies the child to be an application of [Html5.svg] + - Otherwise, evaluates to the child as passed. *) +let qualify_child lang = function + | [%expr pcdata [%e? s]] as e -> + let identifier = + Pc.make ~loc:e.pexp_loc lang "pcdata" + in + [%expr [%e identifier] [%e s]] [@metaloc e.pexp_loc] + + | {pexp_desc = + Pexp_apply ({pexp_desc = Pexp_ident lid}, arguments)} as e + when Longident.last lid.txt = "svg" && lang = Html -> + let identifier = Pc.make ~loc:lid.loc Html "svg" in + {e with pexp_desc = Pexp_apply (identifier, arguments)} + + | e -> e + +(* Called on a list of parse trees representing children of an element. The + argument [implementation] is as in [qualify_child]. Applies [qualify_child] + to each child, then assembles the children into a parse tree representing a + value of type [_ implementation.list_wrap]. *) +let list_wrap_exp lang loc es = + es + |> List.map (qualify_child lang) + |> Pc.list_wrap lang loc + +(* Given a list of parse trees representing children of an element, filters out + all children that consist of applications of [pcdata] to strings containing + only whitespace. *) +let filter_whitespace children = + children |> List.filter (function + | [%expr pcdata [%e? s]]-> begin + match Ast_convenience.get_str s with + | Some s when String.trim s = "" -> false + | _ -> true + end + | _ -> true) + +(* Given a parse tree and a string [name], checks whether the parse tree is an + application of a function with name [name]. *) +let is_element_with_name name = function + | {pexp_desc = Pexp_apply ({pexp_desc = Pexp_ident {txt}}, _)} + when txt = name -> true + | _ -> false + +(* Partitions a list of elements according to [is_element_with_name name]. *) +let partition name children = + List.partition (is_element_with_name name) children + +(* Given the name [n] of a function in [Html5_sigs.T], evaluates to + ["Html5." ^ n]. *) +let html5 local_name = + Longident.Ldot (Lident Pc.(implementation Html), local_name) + + + +(* Generic. *) + +let nullary ~lang:_ ~loc ~name children = + if children <> [] then + Pc.error loc "%s should have no content" name; + [Pc.Label.nolabel, [%expr ()] [@metaloc loc]] + +let unary ~lang ~loc ~name children = + match children with + | [child] -> + let child = + qualify_child lang child + |> Pc.wrap lang loc + in + [Pc.Label.nolabel, child] + | _ -> Pc.error loc "%s should have exactly one child" name + +let star ~lang ~loc ~name:_ children = + [Pc.Label.nolabel, list_wrap_exp lang loc children] + + + +(* Special-cased. *) + +let html ~lang ~loc ~name children = + let children = filter_whitespace children in + let head, others = partition (html5 "head") children in + let body, others = partition (html5 "body") others in + + match head, body, others with + | [head], [body], [] -> + [Pc.Label.nolabel, Pc.wrap lang loc head; + Pc.Label.nolabel, Pc.wrap lang loc body] + | _ -> + Pc.error loc + "%s element must have exactly head and body child elements" name + +let head ~lang ~loc ~name children = + let title, others = partition (html5 "title") children in + + match title with + | [title] -> + (Pc.Label.nolabel, Pc.wrap lang loc title) :: star ~lang ~loc ~name others + | _ -> + Pc.error loc + "%s element must have exactly one title child element" name + +let figure ~lang ~loc ~name children = + begin match children with + | [] -> star ~lang ~loc ~name children + | first::others -> + if is_element_with_name (html5 "figcaption") first then + ("figcaption", + [%expr `Top [%e Pc.wrap lang loc first]]):: + (star ~lang ~loc ~name others) + else + let children_reversed = List.rev children in + let last = List.hd children_reversed in + if is_element_with_name (html5 "figcaption") last then + let others = List.rev (List.tl children_reversed) in + ("figcaption", + [%expr `Bottom [%e Pc.wrap lang loc last]]):: + (star ~lang ~loc ~name others) + else + star ~lang ~loc ~name children + end [@metaloc loc] + +let object_ ~lang ~loc ~name children = + let params, others = partition (html5 "param") children in + + if params <> [] then + ("params", list_wrap_exp lang loc params) :: star ~lang ~loc ~name others + else + star ~lang ~loc ~name others + +let audio_video ~lang ~loc ~name children = + let sources, others = partition (html5 "source") children in + + if sources <> [] then + ("srcs", list_wrap_exp lang loc sources) :: star ~lang ~loc ~name others + else + star ~lang ~loc ~name others + +let table ~lang ~loc ~name children = + let caption, others = partition (html5 "caption") children in + let columns, others = partition (html5 "colgroup") others in + let thead, others = partition (html5 "thead") others in + let tfoot, others = partition (html5 "tfoot") others in + + let one label = function + | [] -> [] + | [child] -> [label, Pc.wrap lang loc child] + | _ -> Pc.error loc "%s cannot have more than one %s" name label + in + + let columns = + if columns = [] then [] + else ["columns", list_wrap_exp lang loc columns] + in + + (one "caption" caption) @ + columns @ + (one "thead" thead) @ + (one "tfoot" tfoot) @ + (star ~lang ~loc ~name others) + +let fieldset ~lang ~loc ~name children = + let legend, others = partition (html5 "legend") children in + + match legend with + | [] -> star ~lang ~loc ~name others + | [legend] -> + ("legend", Pc.wrap lang loc legend):: + (star ~lang ~loc ~name others) + | _ -> Pc.error loc "%s cannot have more than one legend" name + +let datalist ~lang ~loc ~name children = + let options, others = partition (html5 "option") children in + + let children = + begin match others with + | [] -> + "children", + [%expr `Options [%e list_wrap_exp lang loc options]] + + | _ -> + "children", + [%expr `Phras [%e list_wrap_exp lang loc children]] + end [@metaloc loc] + in + + children::(nullary ~lang ~loc ~name []) + +let details ~lang ~loc ~name children = + let summary, others = partition (html5 "summary") children in + + match summary with + | [summary] -> + (Pc.Label.nolabel, Pc.wrap lang loc summary):: + (star ~lang ~loc ~name others) + | _ -> Pc.error loc "%s must have exactly one summary child" name + +let menu ~lang ~loc ~name children = + let children = + "child", + [%expr `Flows [%e list_wrap_exp lang loc children]] + [@metaloc loc] + in + children::(nullary ~lang ~loc ~name []) diff --git a/ppx/ppx_element_content.mli b/ppx/ppx_element_content.mli new file mode 100644 index 000000000..d85a4cbda --- /dev/null +++ b/ppx/ppx_element_content.mli @@ -0,0 +1,79 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Element child argument assemblers. These are almost parsers, except they + only tell how to pass already-parsed children to element functions. *) + +type assembler = + lang:Ppx_common.lang -> + loc:Location.t -> + name:string -> + Parsetree.expression list -> + (Ppx_common.Label.t * Parsetree.expression) list +(** Assemblers satisfy: [assembler ~lang ~loc ~name children] evaluates + to a list of optionally-labeled parse trees for passing [children] to the + the element function for element [name]. For example, for a table element + +{[ + + + + + + +
AB
+]} + + The assembler [table], when called with the parsed children, will evaluate + to parse trees representing + +{[ +~thead:(* the thead element *) [(* the tbody element *)] +]} + + This satisfies the child arguments in the signature of + [Html5_sigs.T.tablex]. The [~table] label is represented by the string + ["table"], and the unlabeled list argument is paired with the empty string. + + The argument [implementation] is the name of the module providing the + run-time implementation of the element function that will be applied to the + children. It is either [Html5] or [Svg], and is based on the element's + namespace. It is used for wrapping child elements, and for scoping child + [pcdata] elements. + + The [name] argument is used for error reporting. *) + +(** {2 Generic} *) + +val nullary : assembler +val unary : assembler +val star : assembler + +(** {2 Special-cased} *) + +val html : assembler +val head : assembler +val figure : assembler +val object_ : assembler +val audio_video : assembler +val table : assembler +val fieldset : assembler +val datalist : assembler +val details : assembler +val menu : assembler diff --git a/ppx/ppx_namespace.ml b/ppx/ppx_namespace.ml new file mode 100644 index 000000000..0e151f819 --- /dev/null +++ b/ppx/ppx_namespace.ml @@ -0,0 +1,30 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +let get : Ppx_common.lang -> (module Ppx_sigs_reflected.S) = function + | Html -> (module Html5_sigs_reflected) + | Svg -> (module Svg_sigs_reflected) + +let to_lang loc ns = + if ns = Markup.Ns.html then Ppx_common.Html + else if ns = Markup.Ns.svg then Ppx_common.Svg + else Ppx_common.error loc "Unknown namespace %s" ns + +let reflect loc ns = + let l = to_lang loc ns in (l, get l) diff --git a/ppx/ppx_namespace.mli b/ppx/ppx_namespace.mli new file mode 100644 index 000000000..e70211785 --- /dev/null +++ b/ppx/ppx_namespace.mli @@ -0,0 +1,35 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Namespace-specific values. *) + + + +val reflect : + Location.t -> string -> Ppx_common.lang * (module Ppx_sigs_reflected.S) +(** When given either [Markup.Ns.html] or [Markup.Ns.svg] as argument, evaluates + to the title of the corresponding markup language, the name of the run-time + module containing its TyXML implementation, and a preprocessing-time module + containing reflection information. *) + +val get : Ppx_common.lang -> (module Ppx_sigs_reflected.S) +(** Similar to {!reflect} but takes a {!Ppx_common.lang} directly. *) + +val to_lang : Location.t -> string -> Ppx_common.lang +(** Takes a namespace and returns the appropriate language. *) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml new file mode 100644 index 000000000..25ab6877f --- /dev/null +++ b/ppx/ppx_reflect.ml @@ -0,0 +1,494 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(* Runs on [html5_sigs.mli], [svg_sigs.mli], and [html5_types.mli]. Certain type + and value declarations are read for type information, which is stored in + corresponding [_reflected] files - for example, [html5_sigs.mli] results in + [html5_sigs_reflected.ml]. See comments by functions below and in + [ppx_sigs_reflected.mli] for details. *) + +open Ast_mapper +open Asttypes +open Parsetree +open Ast_helper +module AC = Ast_convenience + + + +let is_attribute s = String.length s >= 2 && String.sub s 0 2 = "a_" + +let strip_a s = + if String.length s < 2 || String.sub s 0 2 <> "a_" then s + else String.sub s 2 (String.length s - 2) + +(** Utilities for types of functions. *) +module FunTyp = struct + + (* Extract the tuple (arguments, return) of a function type. *) + let get t = + let rec scan acc = function + | {ptyp_desc = Ptyp_arrow (lab, t, t')} -> scan ((lab,t)::acc) t' + | ret -> (List.rev acc, ret) + in + scan [] t + + let arguments t = fst @@ get t + let result t = snd @@ get t + + exception Found + + (** Check if a type contains the "elt" constructor, somewhere. *) + let contains_elt t = + (* Ast_iterator is not available in 4.02, so we use a mapper. *) + let typ mapper = function + | [%type: [%t? _] elt] -> raise Found + | ty -> default_mapper.typ mapper ty + in + let m = {Ast_mapper.default_mapper with typ} in + try ignore (m.typ m t) ; false + with Found -> true + + (** Extract the type inside [wrap]. *) + let unwrap = function + (* Optional argument are [_ wrap *predef*.option], In 4.02 *) + | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t? _] wrap] as t])} + when Longident.last lid.txt = "option" -> + Some t + | [%type : [%t? _] wrap] as t -> Some t + | _ -> None + + (** Extract the type of for html/svg attributes. *) + let extract_attribute_argument (lab, t) = + if contains_elt t then None + else match AC.Label.explode lab, unwrap t with + | Nolabel, _ | _, None -> None + | (Labelled lab | Optional lab), Some t -> Some (lab, t) + + let rec no_constructor_arguments = function + | [] -> true + | (Rinherit _)::_ + | (Rtag (_, _, _, _::_))::_ -> false + | (Rtag (_, _, _, []))::more -> no_constructor_arguments more + + +(* Given the name of a TyXML attribute function and a list of its argument + types, selects the attribute value parser (in module [Ppx_attribute_value]) + that should be used for that attribute. *) +let rec to_attribute_parser name = function + | [] -> [%expr nowrap presence] + | [[%type: [%t? ty] wrap]] -> + [%expr wrap [%e to_attribute_parser name [ty]]] + + | [[%type: character]] -> [%expr char] + | [[%type: bool]] -> [%expr bool] + + | [[%type: number]] + | [[%type: pixels]] + | [[%type: int]] -> [%expr int] + | [[%type: numbers]] -> [%expr commas int] + | [[%type : float_number]] | [[%type : float]] -> [%expr float] + | [[%type : float_number option]] -> + [%expr option "any" float] + + | [[%type : numbers_semicolon]] -> + [%expr semicolons float] + + | [[%type : fourfloats]] -> + [%expr fourfloats] + + | [[%type : number_optional_number]] -> + [%expr number_pair] + + | [[%type : coords]] -> + [%expr points] + + | [[%type : (number * number) list option]] -> + [%expr option "any" (spaces icon_size)] + + | [[%type : length]] -> + [%expr length] + + | [[%type : coord]] | [[%type : Unit.length]] -> + [%expr svg_length] + + | [[%type : Unit.length list]] -> + [%expr spaces_or_commas svg_length] + + | [[%type : Unit.angle option]] -> + [%expr option "auto" angle] + + | [[%type: string]] + | [[%type: text]] + | [[%type: nmtoken]] + | [[%type: idref]] + | [[%type: Xml.uri]] + | [[%type: contenttype]] + | [[%type: languagecode]] + | [[%type: cdata]] + | [[%type: charset]] + | [[%type: frametarget]] + | [[%type: iri]] + | [[%type: color]] -> [%expr string] + + | [[%type: nmtoken]; [%type: text wrap]] -> [%expr wrap string] + + | [[%type : Xml.event_handler]] + | [[%type : Xml.mouse_event_handler]] + | [[%type : Xml.keyboard_event_handler]] -> + [%expr nowrap string] + + | [[%type : string option]] -> + [%expr (option "" string)] + + | [{ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] + when no_constructor_arguments constructors -> + [%expr variant] + + | [[%type : shape]] -> + [%expr variant] + + | [[%type : nmtokens]] + | [[%type : idrefs]] + | [[%type : charsets]] + | [[%type : spacestrings]] + | [[%type : strings]] -> + [%expr spaces string] + + | [[%type : commastrings]] + | [[%type : text list]] + | [[%type : contenttypes]] -> + [%expr commas string] + + | [[%type : linktypes]] -> + [%expr spaces (total_variant Html5_types_reflected.linktype)] + + | [[%type : mediadesc]] -> + [%expr commas (total_variant Html5_types_reflected.mediadesc_token)] + + | [[%type : transform]] -> + [%expr transform] + + | [[%type : lengths]] -> + [%expr spaces_or_commas svg_length] + + | [[%type : transforms]] -> + [%expr spaces_or_commas transform] + + | [[%type : paint]] -> + [%expr paint] + + | [[%type : image_candidate list]] -> + [%expr commas srcset_element] + + | _ -> + let name = strip_a name in + let name = if name = "in" then "in_" else name in + AC.evar name + +end + +(* Given a list of attributes from a val declaration whose name begins with a_, + checks if the declaration has a [@@reflect.attribute] annotation. If so, the + declaration's name does not directly correspond to markup attribute name + (e.g. "a_input_max" does not directly correspond to "max"). The annotation is + parsed to get the markup name and the element types in which the translation + from markup name to TyXML name should be performed. *) +let ocaml_attributes_to_renamed_attribute name attributes = + let maybe_attribute = + Ppx_common.find (fun attr -> (fst attr).txt = "reflect.attribute") + attributes + in + + match maybe_attribute with + | None -> [] + | Some ({loc}, payload) -> + let error () = + Ppx_common.error loc + "Payload of [@@reflect.attribute] must be a string and a string list" + in + match payload with + | PStr [%str + [%e? const] + [%e? element_names]] -> + begin match Ast_convenience.get_str const with + | None -> error () + | Some real_name -> + let element_names = + let error loc = + Ppx_common.error loc + "List in [@@reflect.attribute] must contain strings" + in + let rec traverse acc = function + | [%expr [%e? e]::[%e? tail]] -> + begin match Ast_convenience.get_str e with + | Some element_name -> traverse (element_name::acc) tail + | None -> error e.pexp_loc + end + | [%expr []] -> acc + | {pexp_loc} -> error pexp_loc + in + traverse [] element_names + in + [name, real_name, element_names] + end + | _ -> error () + +(* Given a val declaration, determines whether it is for an element. If so, + evaluates to the element's child assembler (from module + [Ppx_element_content]), list of attributes passed as labeled arguments, and + markup name, if different from its TyXML name (for example, [object_] is + [object] in markup). + + A val declaration is for an element if it either has a [@@reflect.element] + attribute, or its result type is [_ nullary], [_ unary], or [_ star]. *) +let val_item_to_element_info value_description = + let name = value_description.pval_name.txt in + + let maybe_attribute = + Ppx_common.find (fun attr -> (fst attr).txt = "reflect.element") + value_description.pval_attributes + in + + let maybe_assembler, real_name = + match maybe_attribute with + | Some ({loc}, payload) -> + let assembler, real_name = match payload with + | PStr [%str [%e? assembler] [%e? name]] -> + Ast_convenience.get_str assembler, Ast_convenience.get_str name + | PStr [%str [%e? assembler]] -> + Ast_convenience.get_str assembler, None + | _ -> None, None + in + begin match assembler with + | Some _ -> (assembler, real_name) + | None -> + Ppx_common.error loc + "Payload of [@@reflect.element] must be one or two strings" + end + + | None -> + let result_type = FunTyp.result value_description.pval_type in + let assembler = match result_type with + | [%type : ([%t? _], [%t ? _]) nullary] -> Some "nullary" + | [%type : ([%t? _], [%t ? _], [%t ? _]) unary] -> Some "unary" + | [%type : ([%t? _], [%t ? _], [%t ? _]) star] -> Some "star" + | _ -> None + in assembler, None + in + + match maybe_assembler with + | None -> None + | Some assembler -> + + (* We gather all the labeled arguments that are attributes. *) + let arguments = FunTyp.arguments value_description.pval_type in + let labeled_attributes = + let aux x acc = match FunTyp.extract_attribute_argument x with + | None -> acc + | Some (label, ty) -> + let parser = FunTyp.to_attribute_parser label [ty] in + (name, label, parser) :: acc + in + List.fold_right aux arguments [] + in + + let rename = + match real_name with + | None -> [] + | Some real_name -> [real_name, name] + in + + Some (assembler, labeled_attributes, rename) + + + +let attribute_parsers = ref [] +let labeled_attributes = ref [] +let renamed_attributes = ref [] +let element_assemblers = ref [] +let renamed_elements = ref [] + +(* Walks over signature items, looking for elements and attributes. Calls the + functions immediately above, and accumulates their results in the above + references. This function is relevant for [html5_sigs.mli] and + [svg_sigs.mli]. *) +let signature_item mapper item = + begin match item.psig_desc with + | Psig_value {pval_name = {txt = name}; pval_type = type_; pval_attributes} + when is_attribute name -> + (* Attribute declaration. *) + + let argument_types = List.map snd @@ FunTyp.arguments type_ in + let attribute_parser_mapping = + name, FunTyp.to_attribute_parser name argument_types in + attribute_parsers := attribute_parser_mapping::!attribute_parsers; + + let renaming = ocaml_attributes_to_renamed_attribute name pval_attributes in + renamed_attributes := renaming @ !renamed_attributes + + | Psig_value v -> + (* Non-attribute, but potentially an element declaration. *) + + begin match val_item_to_element_info v with + | None -> () + | Some (assembler, labeled_attributes', rename) -> + element_assemblers := (v.pval_name.txt, assembler)::!element_assemblers; + labeled_attributes := labeled_attributes' @ !labeled_attributes; + renamed_elements := rename @ !renamed_elements + end + + | _ -> () + end; + + default_mapper.signature_item mapper item + + + +let reflected_variants = ref [] + +(* Walks over type declarations (which will be in signature items). For each + that is marked with [@@reflect.total_variant], expects it to be a polymorphic + variant. Splits the constructors into those that have no arguments, and one + constructor that has one string argument. This constructor information is + accumulated in [reflected_variants]. This function is relevant for + [html5_types.mli]. *) +let type_declaration mapper declaration = + let is_reflect attr = (fst attr).txt = "reflect.total_variant" in + if List.exists is_reflect declaration.ptype_attributes then begin + let name = declaration.ptype_name.txt in + + match declaration.ptype_manifest with + | Some {ptyp_desc = Ptyp_variant (rows, _, _); ptyp_loc} -> + let rows = + rows |> List.map (function + | Rtag (label, _, _, types) -> label, types + | Rinherit {ptyp_loc} -> + Ppx_common.error ptyp_loc + "Inclusion is not supported by [@@refect.total_variant]") + in + + let nullary, unary = + List.partition (fun (_, types) -> types = []) rows in + + let unary = + match unary with + | [name, [[%type : string]]] -> name + | _ -> + Ppx_common.error ptyp_loc + "Expected exactly one non-nullary constructor `C of string" + in + + let nullary = List.map fst nullary in + + reflected_variants := (name, (unary, nullary))::!reflected_variants + + | _ -> + Ppx_common.error declaration.ptype_loc + "[@@reflect.total_variant] expects a polymorphic variant type" + end; + + default_mapper.type_declaration mapper declaration + +let mapper = {default_mapper with signature_item; type_declaration} + +(** Small set of combinators to help {!make_module}. *) +module Combi = struct + let list f l = AC.list @@ List.map f l + let tuple2 f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] + let tuple3 f1 f2 f3 (x1, x2, x3) = Exp.tuple [f1 x1; f2 x2; f3 x3] + let str = AC.str + let id = AC.evar + let expr x = x + let let_ p f (x,e) = Str.value Nonrecursive [Vb.mk (p x) (f e)] +end + +(** Create a module based on the various things collected while reading the file. *) +let emit_module () = + default_loc := Location.(in_file !input_name) ; + begin if !attribute_parsers <> [] then [%str + open Ppx_attribute_value + + let attribute_parsers = + [%e Combi.(list @@ tuple2 str expr) !attribute_parsers ] + let renamed_attributes = + [%e Combi.(list @@ tuple3 str str (list str)) !renamed_attributes ] + let labeled_attributes = + [%e Combi.(list @@ tuple3 str str expr) !labeled_attributes ] + + open Ppx_element_content + + let element_assemblers = + [%e Combi.(list @@ tuple2 str id) !element_assemblers ] + let renamed_elements = + [%e Combi.(list @@ tuple2 str str) !renamed_elements ] + + ] else [] + end @ + + List.map Combi.(let_ AC.pvar (tuple2 str (list str))) !reflected_variants + + +let reflected_struct sig_ = + ignore @@ mapper.signature mapper sig_ ; + emit_module () + + +(* Crude I/O tools to read a signature and output a structure. + The executable will take as first argument the name of the signature + and as second argument the name of the structure. + +*) + +let read_sig filename = + Location.input_name := filename ; + let handle = + try open_in filename + with Sys_error msg -> prerr_endline msg; exit 1 + in + let buf = Lexing.from_channel handle in + Location.init buf filename ; + let ast = Parse.interface buf in + close_in handle ; + ast + +let write_struct filename ast = + let handle = + try open_out filename + with Sys_error msg -> prerr_endline msg; exit 1 + in + let fmt = Format.formatter_of_out_channel handle in + Format.fprintf fmt "%a@." Pprintast.structure ast ; + close_out handle + +let () = + if Array.length Sys.argv < 3 then begin + Printf.eprintf "Usage: %s IN OUT\n" Sys.argv.(0); + exit 2 + end; + + let in_file = Sys.argv.(1) in + let out_file = Sys.argv.(2) in + + try + read_sig in_file + |> reflected_struct + |> write_struct out_file + with exn -> + Location.report_exception Format.err_formatter exn; + exit 2 diff --git a/ppx/ppx_sigs_reflected.mli b/ppx/ppx_sigs_reflected.mli new file mode 100644 index 000000000..3bb696b1c --- /dev/null +++ b/ppx/ppx_sigs_reflected.mli @@ -0,0 +1,43 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +(** Signature of [Html5_sigs_reflected] and [Svg_sigs_reflected] (but not + [Html5_types_reflected]). *) + + + +module type S = +sig + val attribute_parsers : + (string * (Ppx_common.lang -> Ppx_attribute_value.vparser)) list + (** Pairs [tyxml_attribute_name, wrapped_attribute_value_parser]. *) + + val renamed_attributes : (string * string * string list) list + (** Triples [tyxml_attribute_name, markup_name, in_element_types]. *) + + val labeled_attributes : + (string * string * (Ppx_common.lang -> Ppx_attribute_value.vparser)) list + (** Triples [tyxml_element_name, label, wrapped_attribute_value_parser]. *) + + val element_assemblers : (string * Ppx_element_content.assembler) list + (** Pairs [tyxml_element_name, child_argument_assembler]. *) + + val renamed_elements : (string * string) list + (** Pairs [markup_element_name, tyxml_name]. *) +end diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml new file mode 100644 index 000000000..923ea45bd --- /dev/null +++ b/ppx/ppx_tyxml.ml @@ -0,0 +1,328 @@ +(* TyXML + * http://www.ocsigen.org/tyxml + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. +*) + +open Asttypes +open Parsetree + + +module Loc = struct + + let shift (pos:Lexing.position) x = {pos with pos_cnum = pos.pos_cnum + x} + + (** Returns the real (OCaml) location of a string, taking delimiters into + account. *) + let string_start delimiter loc = + let delimiter_length = match delimiter with + | None -> 1 + | Some d -> String.length d + 2 + in + shift loc.Location.loc_start delimiter_length + + (** Converts a Markup.ml input location into an OCaml location. [loc] is the + start of the OCaml location of the string being parsed by Markup.ml. + [consumed] is the number of bytes consumed by Markup.ml before the + beginning of the current string. + [(line, column)] is the Markup.ml location to be converted. *) + let adjust loc consumed (line, column) = + let open Location in + let open Lexing in + + let column = + if line <> 1 then column + else loc.pos_cnum - loc.pos_bol + column - consumed + in + let line = loc.pos_lnum + line - 1 in + + let position = + {pos_fname = loc.pos_fname; + pos_lnum = line; + pos_bol = 0; + pos_cnum = column}; + in + + {loc_start = position; + loc_end = position; + loc_ghost = false} + +end + +(** Antiquotations + + We replace antiquotations expressions by a dummy token "(tyxmlX)". + We store a table token to expression to retrieve them after parsing. +*) +module Antiquot = struct + + let fmt_id = Printf.sprintf "(tyxml%i)" + let regex_id = Re.(seq [ str "(tyxml" ; rep digit ; char ')' ]) + let re_id = Re.compile regex_id + let whole_re_id = Re.(compile @@ whole_string regex_id) + + let make_id = + let r = ref 0 in + fun () -> incr r ; fmt_id !r + + module H = Hashtbl.Make(struct + type t = string + let hash = Hashtbl.hash + let equal (x:string) y = x = y + end) + + let tbl = H.create 17 + + let create expr = + let s = make_id () in + H.add tbl s expr ; + s + + let get loc s = + if H.mem tbl s then H.find tbl s + else + Ppx_common.error loc + "Internal error: This expression placeholder is not registered." + + let mem s = H.mem tbl s + + let contains loc s = match Re.exec_opt re_id s with + | None -> `No + | Some g -> + let (i,j) = Re.Group.offset g 0 in + let is_whole = i = 0 && j = String.length s in + if is_whole + then `Whole (get loc s) + else `Yes (get loc @@ Re.Group.get g 0) + + let assert_no_antiquot ~loc kind (_namespace,s) = + match contains loc s with + | `No -> () + | `Yes e | `Whole e -> + Ppx_common.error e.pexp_loc + "OCaml expressions are not accepted as %s names." kind + +end + +(** Building block to rebuild the output with expressions intertwined. *) + +let make_pcdata ~loc s = + [%expr pcdata [%e Ppx_common.string loc s]][@metaloc loc] + +(** Walk the text list to replace placeholders by OCaml expressions when + appropriate. Use {!make_pcdata} on the rest. *) +let make_text ~loc ss = + let buf = Buffer.create 17 in + let push_pcdata buf l = + let s = Buffer.contents buf in + Buffer.clear buf ; + if s = "" then l else make_pcdata ~loc s :: l + in + let rec aux ~loc res = function + | [] -> push_pcdata buf res + | `Text s :: t -> + Buffer.add_string buf s ; + aux ~loc res t + | `Delim g :: t -> + let e = Antiquot.get loc @@ Re.get g 0 in + aux ~loc (e :: push_pcdata buf res) t + in + aux ~loc [] @@ Re.split_full Antiquot.re_id @@ String.concat "" ss + +let replace_attribute ~loc (attr,value) = + Antiquot.assert_no_antiquot ~loc "attribute" attr ; + match Antiquot.contains loc value with + | `No -> (attr, `String value) + | `Whole e -> (attr, `Expr e) + | `Yes _ -> + Ppx_common.error loc + "Mixing literals and OCaml expressions is not authorized in attribute values." + + +(** Processing *) + +(** Takes the ast and transforms it into a Markup.ml char stream. + + The payload [expr] is either a single token, or an application (that is, a list). + A token is either a string or an antiquotation, which is transformed into + a string (see {!Antiquot}). + + Each token is equipped with a starting (but no ending) position. +*) +let ast_to_stream expr = + let current_adjust_location = ref (Loc.adjust Lexing.dummy_pos 0) in + + let expressions = + match expr.pexp_desc with + | Pexp_apply (f, arguments) -> f::(List.map snd arguments) + | _ -> [expr] + in + + let strings = + expressions |> List.map @@ fun expr -> + match expr.pexp_desc with + (* TODO: Doesn't work in 4.03, can't pattern match. *) + | Pexp_constant (Const_string (s, delimiter)) -> + (s, Loc.string_start delimiter expr.pexp_loc) + | _ -> + (Antiquot.create expr, expr.pexp_loc.loc_start) + in + + let items = ref strings in + let offset = ref 0 in + let consumed = ref 0 in + + let rec next () = match !items with + | [] -> None + | (s, loc)::rest -> + if !offset = 0 then begin + current_adjust_location := Loc.adjust loc !consumed; + consumed := !consumed + String.length s + end; + + if !offset < String.length s then begin + offset := !offset + 1; + Some (s.[!offset - 1]) + end + else begin + offset := 0; + items := rest; + next () + end + in + + Markup.fn next, (fun x -> !current_adjust_location x) + +(** Given the payload of a [%tyxml ...] expression, converts it to a TyXML + expression representing the markup contained therein. *) +let markup_to_expr ?context loc expr = + + let input_stream, adjust_location = ast_to_stream expr in + + (* The encoding is specified as a workaround: when not specified, Markup.ml + prescans the input looking for byte-order marks or tags. We don't + want a prescan, because that will trigger premature insertion of literal + TyXML expressions into the initial, empty, child list, by the input stream, + before the expression assembler starts running. This is fragile and will be + fixed by merging TyXML expressions in the assembler instead of as now. *) + let parser = + Markup.parse_html + ~encoding:Markup.Encoding.utf_8 + ?context + ~report:(fun loc error -> + let loc = adjust_location loc in + let message = Markup.Error.to_string error |> String.capitalize in + Ppx_common.error loc "%s" message) + input_stream + in + let signals = Markup.signals parser in + let get_loc () = adjust_location @@ Markup.location parser in + + let rec assemble lang children = + match Markup.next signals with + | None | Some `End_element -> List.rev children + + | Some (`Text ss) -> + let loc = get_loc () in + let node = make_text ~loc ss in + assemble lang (node @ children) + + | Some (`Start_element (name, attributes)) -> + let lang = Ppx_namespace.to_lang loc @@ fst name in + let loc = get_loc () in + + let sub_children = assemble lang [] in + Antiquot.assert_no_antiquot ~loc "element" name ; + let attributes = List.map (replace_attribute ~loc) attributes in + let node = Ppx_element.parse ~loc ~name ~attributes sub_children in + assemble lang (node :: children) + + | Some (`Comment s) -> + [Ppx_element.comment ~loc ~lang s] + + | Some (`Xml _ | `Doctype _ | `PI _) -> + assemble lang children + in + + Ppx_common.list loc @@ assemble Ppx_common.Html [] + +let context_of_lang = function + | None -> None + | Some Ppx_common.Svg -> Some (`Fragment "svg") + | Some Html -> Some (`Fragment "html") + +let markup_to_expr_with_implementation lang modname loc expr = + let context = context_of_lang lang in + match lang, modname with + | Some lang, Some modname -> + let current_modname = Ppx_common.implementation lang in + Ppx_common.set_implementation lang modname ; + let res = markup_to_expr ?context loc expr in + Ppx_common.set_implementation lang current_modname ; + res + | _ -> + markup_to_expr ?context loc expr + + +let is_capitalized s = + if String.length s < 0 then false + else match s.[0] with + | 'A'..'Z' -> true + | _ -> false + +let get_modname ~loc l = + if l = [] then None + else if not (List.for_all is_capitalized l) then + Ppx_common.error loc + "This identifier is not a module name." + else Some (String.concat "." l) + +let re_dot = Re.(compile @@ char '.') +let dispatch_ext {txt ; loc} = + let l = Re.split re_dot txt in + match l with + | "html5" :: l + | "tyxml" :: "html5" :: l -> + Some (Some Ppx_common.Html, get_modname ~loc l) + | "svg" :: l + | "tyxml" :: "svg" :: l -> + Some (Some Ppx_common.Svg, get_modname ~loc l) + | "tyxml" :: [] + -> Some (None, None) + | "tyxml" :: (_ :: _) -> + Ppx_common.error loc + "Module names are only accepted for html5 and svg quotations." + | _ -> None + +open Ast_mapper + +let map_expr mapper e = + match e.pexp_desc with + | Pexp_extension (ext, payload) -> + begin match dispatch_ext ext, payload with + | Some (lang, modname), PStr [{pstr_desc = Pstr_eval (e, _)}] -> + markup_to_expr_with_implementation lang modname e.pexp_loc e + | Some _, _ -> + Ppx_common.error e.pexp_loc + "Error: Payload of [%%tyxml] must be a single string" + | None, _ -> default_mapper.expr mapper e + end + | _ -> default_mapper.expr mapper e + + + +let () = + register "tyxml" (fun _ -> {default_mapper with expr = map_expr}) diff --git a/test/main_test.ml b/test/main_test.ml index fe2c15f29..20adb06f9 100644 --- a/test/main_test.ml +++ b/test/main_test.ml @@ -2,4 +2,5 @@ let () = Alcotest.run "tyxml" ( Test_html.tests + @ Test_ppx.tests ) diff --git a/test/test_ppx.ml b/test/test_ppx.ml new file mode 100644 index 000000000..f3873f965 --- /dev/null +++ b/test/test_ppx.ml @@ -0,0 +1,87 @@ +(** Ppx Tests + + This file is here to torture the ppx. Tests that are directly related to + html or svg should go to the other files. +*) + +module TyTests = struct + type t = Xml.elt list + let pp fmt x = + Format.pp_print_list ~pp_sep:(fun _ () -> ()) + (Html5.pp_elt ()) + fmt (Html5.totl x) + let equal = (=) +end + + +let tyxml_tests l = + let f (name, ty1, ty2) = + name, `Quick, fun () -> + Alcotest.(check (module TyTests)) name (Html5.toeltl ty1) (Html5.toeltl ty2) + in + List.map f l + +let basics = "ppx basics", tyxml_tests Html5.[ + + "elems", + [%tyxml "

"], + [p []] ; + + "child", + [%tyxml "

foo

"], + [p [span [pcdata "foo"]]] ; + + "list", + [%tyxml "

foo"], + [p [] ; span [pcdata "foo"]] ; + + "attrib", + [%tyxml "

"], + [p ~a:[a_id "foo"] []] ; + + "attribs", + [%tyxml "

"], + [p ~a:[a_id "foo"; a_class ["bar"] ] []] ; + + "comment", + [%tyxml ""], + [tot @@ Xml.comment "foo"] + +] + +let elt1 = Html5.(span [pcdata "one"]) +let elt2 = Html5.(b [pcdata "two"]) +let id = "pata" + +let antiquot = "ppx antiquot", tyxml_tests Html5.[ + + "child", + [%tyxml "

" elt1 "

"], + [p [elt1]]; + + "children", + [%tyxml "

bar"elt1"foo"elt2"baz

"], + [p [pcdata "bar"; elt1 ; pcdata "foo" ; elt2 ; pcdata "baz" ]]; + + "insertion", + [%tyxml "

" elt1 "

"], + [p [em [elt1]]]; + + "attrib", + [%tyxml "

bla

"], + [p ~a:[a_id id] [pcdata "bla"]]; + + (* should succeed *) + (* "escape", *) + (* [%tyxml "

(tyxml4)

"], *) + (* [p [pcdata "(tyxml4)"]]; *) + + +] + + + +let tests = [ + basics ; + antiquot ; +]