From 2d250c611d01b35c01ce5d97a96128a7d019bff5 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Fri, 26 Feb 2016 12:36:59 -0600 Subject: [PATCH 01/35] Add ppx. Adds HTML and SVG "templating" based on the parser in Markup.ml. --- _oasis | 24 +- lib/html5_sigs.mli | 23 ++ lib/html5_types.mli | 4 +- lib/svg_types.mli | 2 +- myocamlbuild.ml | 17 + ppx/ppx_attribute_value.ml | 597 ++++++++++++++++++++++++++++++++++++ ppx/ppx_attribute_value.mli | 210 +++++++++++++ ppx/ppx_attributes.ml | 142 +++++++++ ppx/ppx_attributes.mli | 38 +++ ppx/ppx_common.ml | 52 ++++ ppx/ppx_common.mli | 53 ++++ ppx/ppx_element.ml | 43 +++ ppx/ppx_element.mli | 30 ++ ppx/ppx_element_content.ml | 262 ++++++++++++++++ ppx/ppx_element_content.mli | 82 +++++ ppx/ppx_namespace.ml | 31 ++ ppx/ppx_namespace.mli | 29 ++ ppx/ppx_reflect.ml | 471 ++++++++++++++++++++++++++++ ppx/ppx_sigs_reflected.mli | 42 +++ ppx/ppx_tyxml.ml | 205 +++++++++++++ 20 files changed, 2353 insertions(+), 4 deletions(-) create mode 100644 ppx/ppx_attribute_value.ml create mode 100644 ppx/ppx_attribute_value.mli create mode 100644 ppx/ppx_attributes.ml create mode 100644 ppx/ppx_attributes.mli create mode 100644 ppx/ppx_common.ml create mode 100644 ppx/ppx_common.mli create mode 100644 ppx/ppx_element.ml create mode 100644 ppx/ppx_element.mli create mode 100644 ppx/ppx_element_content.ml create mode 100644 ppx/ppx_element_content.mli create mode 100644 ppx/ppx_namespace.ml create mode 100644 ppx/ppx_namespace.mli create mode 100644 ppx/ppx_reflect.ml create mode 100644 ppx/ppx_sigs_reflected.mli create mode 100644 ppx/ppx_tyxml.ml diff --git a/_oasis b/_oasis index 41f59fdde..d173803f0 100644 --- a/_oasis +++ b/_oasis @@ -106,6 +106,28 @@ Library tymlx_p Modules: Simplexmlparser +Library 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 + Path: ppx + MainIs: ppx_tyxml.ml + BuildDepends: + str, ppx_tools.metaquot, markup, tyxml.tools + +Executable ppx_reflect + Path: ppx + MainIs: ppx_reflect.ml + BuildDepends: + compiler-libs.common + ## Tests Executable emit_big @@ -173,4 +195,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/lib/html5_sigs.mli b/lib/html5_sigs.mli index cce3068c8..f5921df4b 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 @@ -614,10 +625,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 +711,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 +797,7 @@ module type T = sig | `Name | `Usemap ], 'a, [> | `Object of 'a ]) star + [@@reflect.element "object_" "object"] val param : ([< | param_attrib], [> | param]) nullary @@ -793,11 +808,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 +847,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 +855,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 +885,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 +911,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 +950,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 +972,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} *) diff --git a/lib/html5_types.mli b/lib/html5_types.mli index 9a8412e96..85e1cf97d 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 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..ea30de8bc 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -25,6 +25,21 @@ open Ocamlbuild_plugin +let reflect_ppx () = + let ppx_reflect = "ppx/ppx_reflect.byte" 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 "ocamlc"; + A "-I"; A "lib"; + A "-ppx"; A (Printf.sprintf "%s %s" ppx_reflect (env prod)); + A "-c"; A (env dep)]) + end + let () = dispatch (fun hook -> @@ -44,6 +59,8 @@ let () = if String.sub Sys.ocaml_version 0 4 = "4.00" then flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot"); + reflect_ppx () + | _ -> ()) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml new file mode 100644 index 000000000..5860bee60 --- /dev/null +++ b/ppx/ppx_attribute_value.ml @@ -0,0 +1,597 @@ +(* 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 + +(* Not opening all of Ast_helper in order to avoid shadowing stdlib's Str with + Ast_helper.Str. *) +module Exp = Ast_helper.Exp + + + +type parser = + ?separated_by:string -> ?default:string -> Location.t -> string -> string -> + Parsetree.expression option + + + +(* 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 = + 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_exp loc + |> fun e -> Some e + +let spaces = _list (Str.regexp " +") "space" +let commas = _list (Str.regexp " *, *") "comma" +let semicolons = _list (Str.regexp " *; *") "semicolon" + +let _spaces_or_commas_regexp = 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 ?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_exp implementation loc e) + +let nowrap (parser : parser) _ ?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 = + Str.string_match regexp s 0 && 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 Str.matched_group index s |> ignore; true + with Not_found -> false + +let _int_exp loc s = + try Some (Ppx_common.int_exp loc (int_of_string s)) + with Failure "int_of_string" -> None + +let _float_exp loc s = + try + float_of_string s |> ignore; + Some (Ppx_common.float_exp loc 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_exp 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 orderx]] + | _ -> 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 = 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 (Str.matched_group 1 s), + int_of_string (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_exp loc width], + [%e Ppx_common.int_exp loc height]] [@metaloc loc] + + + +(* Dimensional. *) + +let length = + let regexp = 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 (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 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 + +(* This is only called by the commas combinator; hence the error message. *) +let multilength = + let regexp = Str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([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" + name "list of relative lengths, such as 100px, 50%, or *"; + + begin + if _group_matched 1 s then + let n = + match _int_exp loc (Str.matched_group 1 s) with + | Some n -> n + | None -> + Ppx_common.error loc "Value in %s out of range" name + in + + match Str.matched_group 2 s with + | "%" -> Some [%expr `Percent [%e n]] + | "px" -> Some [%expr `Pixels [%e n]] + | _ -> Ppx_common.error loc "Internal error: Ppx_attribute.multilength" + + else + let n = + match _int_exp loc (Str.matched_group 3 s) with + | exception Not_found -> [%expr 1] + | Some n -> n + | None -> + Ppx_common.error loc "Relative length in %s out of range" name + in + + Some [%expr `Relative [%e n]] + end [@metaloc loc] + +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 = 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 (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 = 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 = 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 (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 = 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 = Str.matched_group 1 s in + let values = 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 Str.bounded_split _spaces_or_commas_regexp values 2 with + | [angle] -> + [%expr Svg_types.Rotate ([%e _angle loc "rotate" angle], None)] + | [angle; axis] -> + begin match _spaces_or_commas float loc "rotate axis" axis with + | [cx; cy] -> + [%expr Svg_types.Rotate + ([%e _angle loc "rotate" angle], 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_exp 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 (Str.search_forward (Str.regexp "icc-color(\\([^)]*\\))") s 0) + with Not_found -> None + in + + match icc_color_start with + | None -> [%expr `Color ([%e Ppx_common.string_exp loc s], None)] + | Some i -> + let icc_color = Str.matched_group 1 s in + let color = String.sub s 0 i in + [%expr `Color + ([%e Ppx_common.string_exp loc color], + Some [%e Ppx_common.string_exp loc icc_color])] + end [@metaloc loc] + +let paint ?separated_by ?default loc name s = + if not @@ Str.string_match (Str.regexp "url(\\([^)]+\\))") s 0 then + Some (_paint_without_icc loc name s) + else + let iri = Str.matched_group 1 s |> Ppx_common.string_exp loc in + let remainder_start = 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 = Str.regexp " +" in + + fun ?separated_by ?default loc name s -> + let e = + begin match Str.bounded_split space s 2 with + | [url] -> + [%expr `Url [%e Ppx_common.string_exp 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_exp 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..51f8db38a --- /dev/null +++ b/ppx/ppx_attribute_value.mli @@ -0,0 +1,210 @@ +(* 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 parser = + ?separated_by:string -> ?default:string -> Location.t -> string -> string -> + Parsetree.expression option +(** 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. *) + +val wrap : parser -> string -> parser +(** [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 -> string -> parser +(** [nowrap parser _ _ _ s] evaluates to [parser _ _ s]. The purpose of this + combinator is 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 multilength : parser +(** [multilength _ _ s] produces a parse tree for + + - [`Pixels i] if [s] has form [(string_of_int i) ^ "px"], + - [`Percent i] if [s] has form [(string_of_int i) ^ "%"], + - [`Relative i] if [s] has form [(string_of_int i) ^ "*"], or + - [`Relative 1] if [s] is ["*"]. *) + +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..c3ea313df --- /dev/null +++ b/ppx/ppx_attributes.ml @@ -0,0 +1,142 @@ +(* 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, implementation, (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" + 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 implementation 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.qualify implementation tyxml_name in + let identifier = Ppx_common.identifier loc identifier in + + let tag = Ppx_common.string_exp loc tag in + + let e = + match parser implementation 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.qualify implementation tyxml_name in + let identifier = Ppx_common.identifier loc identifier in + + let e = + match parser implementation loc local_name value with + | None -> identifier + | Some e' -> [%expr [%e identifier] [%e e']] [@metaloc loc] + in + + labeled, e::regular + in + + let labeled, regular = + attributes |> List.fold_left parse_attribute ([], []) 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_exp 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..75af6f0f6 --- /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 * string) 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..d032fa232 --- /dev/null +++ b/ppx/ppx_common.ml @@ -0,0 +1,52 @@ +(* 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 + +let find f l = + try Some (List.find f l) + with Not_found -> None + +let int_exp loc n = Exp.constant ~loc (Const_int n) + +let float_exp loc s = Exp.constant ~loc (Const_float s) + +let string_exp loc s = Exp.constant ~loc (Const_string (s, None)) + +let identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) + +let list_exp loc l = + (l |> List.rev |> List.fold_left (fun acc tree -> + [%expr [%e tree]::[%e acc]]) + [%expr []]) [@metaloc loc] + +let error loc = + Printf.ksprintf + (fun s -> raise (Location.Error (Location.error ~loc ("Error: " ^ s)))) + +let html5_implementation = "Html5" +let svg_implementation = "Svg" + +let qualify module_ identifier = Printf.sprintf "%s.%s" module_ identifier + +let wrap_exp implementation loc e = + [%expr + [%e identifier loc (qualify 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..842895b9f --- /dev/null +++ b/ppx/ppx_common.mli @@ -0,0 +1,53 @@ +(* 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]. *) + + + +(** Expression helpers. *) + +val int_exp : Location.t -> int -> Parsetree.expression +val float_exp : Location.t -> string -> Parsetree.expression +val string_exp : Location.t -> string -> Parsetree.expression +val identifier : Location.t -> string -> Parsetree.expression +val list_exp : Location.t -> Parsetree.expression list -> Parsetree.expression + +val wrap_exp : + string -> 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]. *) + + + +val html5_implementation : string +(** The module name ["Html5"]. *) + +val svg_implementation : string +(** The module name ["Svg"]. *) + +val qualify : string -> string -> string +(** [qualify m i] is [m ^ "." ^ i]. *) diff --git a/ppx/ppx_element.ml b/ppx/ppx_element.ml new file mode 100644 index 000000000..f2537225f --- /dev/null +++ b/ppx/ppx_element.ml @@ -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. +*) + +let parse loc ((ns, name) as element_name) attributes children = + let attributes = Ppx_attributes.parse loc element_name attributes in + + let language, implementation, (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.qualify implementation name + |> Ppx_common.identifier loc + in + + let assembler = + try List.assoc name Reflected.element_assemblers + with Not_found -> Ppx_common.error loc "Unknown %s element %s" language name + in + + let children = assembler implementation loc name children in + + Ast_helper.Exp.apply ~loc element_function (attributes @ children) diff --git a/ppx/ppx_element.mli b/ppx/ppx_element.mli new file mode 100644 index 000000000..1ff8e3c1e --- /dev/null +++ b/ppx/ppx_element.mli @@ -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. +*) + +(** Element parsing. *) + + + +val parse : + Location.t -> + Markup.name -> (Markup.name * string) 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]. *) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml new file mode 100644 index 000000000..883f7091b --- /dev/null +++ b/ppx/ppx_element_content.ml @@ -0,0 +1,262 @@ +(* 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 + + + +type assembler = + string -> Location.t -> string -> Parsetree.expression list -> + (Asttypes.label * 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 implementation = function + | [%expr pcdata [%e ? s]] as e -> + let identifier = + Ppx_common.identifier e.pexp_loc + (Ppx_common.qualify implementation "pcdata") + in + [%expr [%e identifier] [%e s]] [@metaloc e.pexp_loc] + + | {pexp_desc = + Pexp_apply ({pexp_desc = Pexp_ident lid} as e', arguments)} as e + when Longident.last lid.txt = "svg" + && implementation = Ppx_common.html5_implementation -> + let html5_svg = Ppx_common.qualify Ppx_common.html5_implementation "svg" in + let lid = {lid with txt = Longident.parse html5_svg} in + let identifier = {e' with pexp_desc = Pexp_ident lid} 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 implementation loc es = + let nil = + [%expr + [%e Ppx_common.identifier loc + (Ppx_common.qualify implementation "Xml.W.nil")] + ()] [@metaloc loc] + in + let cons = + Ppx_common.identifier loc + (Ppx_common.qualify implementation "Xml.W.cons") + in + + es + |> List.map (_qualify_child implementation) + |> List.rev + |> List.fold_left (fun wrapped e -> + [%expr [%e cons] [%e e] [%e wrapped]] [@metaloc loc]) + nil + +(* 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 ? {pexp_desc = Pexp_constant (Const_string (s, _))}]] + when String.trim s = "" -> false + | _ -> 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 Longident.flatten txt |> String.concat "." = 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 = + Ppx_common.qualify Ppx_common.html5_implementation local_name + + + +(* Generic. *) + +let nullary _ loc name children = + if children <> [] then + Ppx_common.error loc "%s should have no content" name; + ["", [%expr ()] [@metaloc loc]] + +let unary implementation loc name children = + match children with + | [child] -> + let child = + _qualify_child implementation child + |> Ppx_common.wrap_exp implementation loc + in + ["", child] + | _ -> Ppx_common.error loc "%s should have exactly one child" name + +let star implementation loc _ children = + ["", _list_wrap_exp implementation loc children] + + + +(* Special-cased. *) + +let html implementation 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], [] -> + ["", Ppx_common.wrap_exp implementation loc head; + "", Ppx_common.wrap_exp implementation loc body] + | _ -> + Ppx_common.error loc + "%s element must have exactly head and body child elements" name + +let head implementation loc name children = + let title, others = _partition (_html5 "title") children in + + match title with + | [title] -> + ("", Ppx_common.wrap_exp implementation loc title):: + (star implementation loc name others) + | _ -> + Ppx_common.error loc + "%s element must have exactly one title child element" name + +let figure implementation loc name children = + begin match children with + | [] -> star implementation loc name children + | first::others -> + if _is_element_with_name (_html5 "figcaption") first then + ("figcaption", + [%expr `Top [%e Ppx_common.wrap_exp implementation loc first]]):: + (star implementation 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 Ppx_common.wrap_exp implementation loc last]]):: + (star implementation loc name others) + else + star implementation loc name children + end [@metaloc loc] + +let object_ implementation loc name children = + let params, others = _partition (_html5 "param") children in + + if params <> [] then + ("params", _list_wrap_exp implementation loc params):: + (star implementation loc name others) + else + star implementation loc name others + +let audio_video implementation loc name children = + let sources, others = _partition (_html5 "source") children in + + if sources <> [] then + ("srcs", _list_wrap_exp implementation loc sources):: + (star implementation loc name others) + else + star implementation loc name others + +let table implementation 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, Ppx_common.wrap_exp implementation loc child] + | _ -> Ppx_common.error loc "%s cannot have more than one %s" name label + in + + let columns = + if columns = [] then [] + else ["columns", _list_wrap_exp implementation loc columns] + in + + (one "caption" caption) @ + columns @ + (one "thead" thead) @ + (one "tfoot" tfoot) @ + (star implementation loc name others) + +let fieldset implementation loc name children = + let legend, others = _partition (_html5 "legend") children in + + match legend with + | [] -> star implementation loc name others + | [legend] -> + ("legend", Ppx_common.wrap_exp implementation loc legend):: + (star implementation loc name others) + | _ -> Ppx_common.error loc "%s cannot have more than one legend" name + +let datalist implementation loc name children = + let options, others = _partition (_html5 "option") children in + + let children = + begin match others with + | [] -> + "children", + [%expr `Options [%e _list_wrap_exp implementation loc options]] + + | _ -> + "children", + [%expr `Phras [%e _list_wrap_exp implementation loc children]] + end [@metaloc loc] + in + + children::(nullary implementation loc name []) + +let details implementation loc name children = + let summary, others = _partition (_html5 "summary") children in + + match summary with + | [summary] -> + ("", Ppx_common.wrap_exp implementation loc summary):: + (star implementation loc name others) + | _ -> Ppx_common.error loc "%s must have exactly one summary child" name + +let menu implementation loc name children = + let children = + "child", + [%expr `Flows [%e _list_wrap_exp implementation loc children]] + [@metaloc loc] + in + children::(nullary implementation loc name []) diff --git a/ppx/ppx_element_content.mli b/ppx/ppx_element_content.mli new file mode 100644 index 000000000..1fba5ba1f --- /dev/null +++ b/ppx/ppx_element_content.mli @@ -0,0 +1,82 @@ +(* 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 = + string -> Location.t -> string -> Parsetree.expression list -> + (Asttypes.label * Parsetree.expression) list +(** Assemblers satisfy: [assembler implementation 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..4960fbd9f --- /dev/null +++ b/ppx/ppx_namespace.ml @@ -0,0 +1,31 @@ +(* 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 reflect loc = function + | ns when ns = Markup.Ns.html -> + "HTML", + Ppx_common.html5_implementation, + (module Html5_sigs_reflected : Ppx_sigs_reflected.S) + + | ns when ns = Markup.Ns.svg -> + "SVG", + Ppx_common.svg_implementation, + (module Svg_sigs_reflected : Ppx_sigs_reflected.S) + + | ns -> Ppx_common.error loc "Unknown namespace %s" ns diff --git a/ppx/ppx_namespace.mli b/ppx/ppx_namespace.mli new file mode 100644 index 000000000..377385de7 --- /dev/null +++ b/ppx/ppx_namespace.mli @@ -0,0 +1,29 @@ +(* 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 -> string * string * (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. *) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml new file mode 100644 index 000000000..f00095338 --- /dev/null +++ b/ppx/ppx_reflect.ml @@ -0,0 +1,471 @@ +(* 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 + + + +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) + +let argument_types t = + let rec scan acc = function + | Ptyp_arrow (_, t, t') -> scan (t::acc) t'.ptyp_desc + | _ -> List.rev acc + in + scan [] t.ptyp_desc + + + +(* 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 type_to_attribute_parser name types = + let rec no_constructor_arguments = function + | [] -> true + | (Rinherit _)::_ + | (Rtag (_, _, _, _::_))::_ -> false + | (Rtag (_, _, _, []))::more -> no_constructor_arguments more + in + + match types with + | [] -> + "nowrap presence" + + | [[%type : character wrap]] -> + "wrap char" + + | [[%type : bool wrap]] -> + "wrap bool" + + | [[%type : number wrap]] + | [[%type : pixels wrap]] + | [[%type : int wrap]] -> + "wrap int" + + | [[%type : numbers wrap]] -> + "wrap (commas int)" + + | [[%type : float_number wrap]] + | [[%type : float wrap]] -> + "wrap float" + + | [[%type : float_number option wrap]] -> + "wrap (option \"any\" float)" + + | [[%type : numbers_semicolon wrap]] -> + "wrap (semicolons float)" + + | [[%type : fourfloats wrap]] -> + "wrap fourfloats" + + | [[%type : number_optional_number wrap]] -> + "wrap number_pair" + + | [[%type : coords wrap]] -> + "wrap points" + + | [[%type : (number * number) list option wrap]] -> + "wrap (option \"any\" (spaces icon_size))" + + | [[%type : length wrap]] -> + "wrap length" + + | [[%type : multilengths wrap]] -> + "wrap (commas multilength)" + + | [[%type : coord wrap]] + | [[%type : Unit.length wrap]] -> + "wrap svg_length" + + | [[%type : Unit.length list wrap]] -> + "wrap (spaces_or_commas svg_length)" + + | [[%type : Unit.angle option wrap]] -> + "wrap (option \"auto\" angle)" + + | [[%type : string wrap]] + | [[%type : text wrap]] + | [[%type : nmtoken wrap]] + | [[%type : idref wrap]] + | [[%type : Xml.uri wrap]] + | [[%type : contenttype wrap]] + | [[%type : languagecode wrap]] + | [[%type : cdata wrap]] + | [[%type : charset wrap]] + | [[%type : frametarget wrap]] + | [[%type : iri wrap]] + | [[%type : color wrap]] + | [[%type : nmtoken]; [%type : text wrap]] -> + "wrap string" + + | [[%type : Xml.event_handler]] + | [[%type : Xml.mouse_event_handler]] + | [[%type : Xml.keyboard_event_handler]] -> + "nowrap string" + + | [[%type : string option wrap]] -> + "wrap (option \"\" string)" + + | [[%type : + [%t ? {ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] wrap]] + when no_constructor_arguments constructors -> + "wrap variant" + + | [[%type : shape wrap]] -> + "wrap variant" + + | [[%type : nmtokens wrap]] + | [[%type : idrefs wrap]] + | [[%type : charsets wrap]] + | [[%type : spacestrings wrap]] + | [[%type : strings wrap]] -> + "wrap (spaces string)" + + | [[%type : commastrings wrap]] + | [[%type : text list wrap]] + | [[%type : contenttypes wrap]] -> + "wrap (commas string)" + + | [[%type : linktypes wrap]] -> + "wrap (spaces (total_variant Html5_types_reflected.linktype))" + + | [[%type : mediadesc wrap]] -> + "wrap (commas (total_variant Html5_types_reflected.mediadesc_token))" + + | [[%type : transform wrap]] -> + "wrap transform" + + | [[%type : lengths wrap]] -> + "wrap (spaces_or_commas svg_length)" + + | [[%type : transforms wrap]] -> + "wrap (spaces_or_commas transform)" + + | [[%type : paint wrap]] -> + "wrap paint" + + | [[%type : image_candidate list wrap]] -> + "wrap (commas srcset_element)" + + | _ -> + let name = strip_a name in + let name = if name = "in" then "in_" else name in + Printf.sprintf "wrap %s" name + +(* 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 = + attributes + |> Ppx_common.find (fun attr -> (fst attr).txt = "reflect.attribute") + in + + match maybe_attribute with + | None -> [] + | Some ({loc}, payload) -> + match payload with + | PStr [%str + [%e ? {pexp_desc = Pexp_constant (Const_string (real_name, _))}] + [%e ? element_names]] -> + let element_names = + let rec traverse acc = function + | [%expr + [%e ? {pexp_desc = + Pexp_constant (Const_string (element_name, _))}]:: + [%e ? tail]] -> + traverse (element_name::acc) tail + | [%expr []] -> acc + | {pexp_loc} -> + Ppx_common.error pexp_loc + "List in [@@reflect.attribute] must contain strings" + in + traverse [] element_names + in + + [name, real_name, element_names] + + | _ -> + Ppx_common.error loc + "Payload of [@@reflect.attribute] must be a string and a string list" + +(* 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 = + value_description.pval_attributes + |> Ppx_common.find (fun attr -> (fst attr).txt = "reflect.element") + in + + let maybe_assembler, real_name = + match maybe_attribute with + | Some ({loc}, payload) -> + begin match payload with + | PStr [%str + [%e ? {pexp_desc = Pexp_constant (Const_string (assembler, _))}]] -> + Some assembler, None + + | PStr [%str + [%e ? {pexp_desc = Pexp_constant (Const_string (assembler, _))}] + [%e ? {pexp_desc = Pexp_constant (Const_string (name, _))}]] -> + Some assembler, Some name + + | _ -> + Ppx_common.error loc + "Payload of [@@reflect.element] must be a one or two strings" + end + + | None -> + let result_type = + let rec scan = function + | {ptyp_desc = Ptyp_arrow (_, _, t')} -> scan t' + | t -> t + in + scan value_description.pval_type + in + + match result_type with + | [%type : ([%t ? _], [%t ? _]) nullary] -> Some "nullary", None + | [%type : ([%t ? _], [%t ? _], [%t ? _]) unary] -> Some "unary", None + | [%type : ([%t ? _], [%t ? _], [%t ? _]) star] -> Some "star", None + | _ -> None, None + in + + match maybe_assembler with + | None -> None + | Some assembler -> + let labeled_attributes = + let rec scan acc = function + | Ptyp_arrow (label, t, t') -> + let label = + if label = "" || label.[0] <> '?' then label + else String.sub label 1 (String.length label - 1) + in + if label = "" then scan acc t'.ptyp_desc + else begin + let maybe_attribute_type = + match t with + | [%type : [%t ? _] wrap] -> + Some t + + | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t ? _] elt wrap]])} + when Longident.last lid.txt = "option" -> + None + + | {ptyp_desc = + Ptyp_constr (lid, [[%type : [%t ? _] wrap] as t''])} + when Longident.last lid.txt = "option" -> + Some t'' + + | _ -> + None + in + + match maybe_attribute_type with + | None -> scan acc t'.ptyp_desc + | Some t'' -> + let parser = type_to_attribute_parser label [t''] in + scan ((name, label, parser)::acc) t'.ptyp_desc + end + + | _ -> acc + in + scan [] value_description.pval_type.ptyp_desc + 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 = argument_types type_ in + let attribute_parser_mapping = + name, type_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 = + rows |> List.partition (fun (_, types) -> types = []) 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 = nullary |> List.map fst 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 + + + +(* Creates an AST mapper that applies [signature_item] and [type_declaration], + then formats the generated reflection information as ML code to the file + whose name is given in the first argument to the PPX reflector. *) +let () = + if Array.length Sys.argv < 2 then begin + Printf.eprintf "Usage: %s FILE\n" Sys.argv.(0); + exit 2 + end; + + let filename = Sys.argv.(1) in + + register "reflect_sig" (fun _ -> + {default_mapper with signature_item; type_declaration}); + + (* The channel will be closed on process exit. *) + let channel = open_out filename in + let write f = Printf.fprintf channel f in + + if !attribute_parsers <> [] then begin + write "open Ppx_attribute_value\n"; + + write "\nlet attribute_parsers = [\n"; + !attribute_parsers |> List.iter (fun (name, parser) -> + write " %S, %s;\n" name parser); + write "]\n"; + + write "\nlet renamed_attributes = [\n"; + !renamed_attributes |> List.iter (fun (name, real_name, element_names) -> + write " %S, %S, [" name real_name; + element_names + |> List.map (Printf.sprintf "%S") + |> String.concat "; " + |> write "%s];\n"); + write "]\n"; + + write "\nlet labeled_attributes = [\n"; + !labeled_attributes |> List.iter (fun (name, label, parser) -> + write " %S, %S, %s;\n" name label parser); + write "]\n"; + + write "\nopen Ppx_element_content\n"; + + write "\nlet element_assemblers = [\n"; + !element_assemblers |> List.iter (fun (name, assembler) -> + write " %S, %s;\n" name assembler); + write "]\n"; + + write "\nlet renamed_elements = [\n"; + !renamed_elements |> List.iter (fun (real_name, name) -> + write " %S, %S;\n" real_name name); + write "]\n" + end; + + !reflected_variants |> List.iter (fun (name, (unary, nullary)) -> + write "\nlet %s = %S, [\n" name unary; + nullary |> List.iter (fun nullary -> + write " %S;\n" nullary); + write "]\n") diff --git a/ppx/ppx_sigs_reflected.mli b/ppx/ppx_sigs_reflected.mli new file mode 100644 index 000000000..84160a33c --- /dev/null +++ b/ppx/ppx_sigs_reflected.mli @@ -0,0 +1,42 @@ +(* 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 * (string -> Ppx_attribute_value.parser)) 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 * (string -> Ppx_attribute_value.parser)) 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..a5df6ea3e --- /dev/null +++ b/ppx/ppx_tyxml.ml @@ -0,0 +1,205 @@ +(* 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 + + + +(* Converts a Markup.ml input location into an OCaml location. [start_loc] is + the OCaml location of the string being parsed by Markup.ml. + [delimiter_length] is the length of string delimiter. For a regular string, + this is [1] (for the quote). For a delimited string, it is the length of the + delimiter plus two for the [{] and [|] characters. [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_location start_loc delimiter_length consumed (line, column) = + let open Location in + let open Lexing in + + let column = + if line <> 1 then column + else + start_loc.loc_start.pos_cnum - start_loc.loc_start.pos_bol + + column + delimiter_length - consumed + in + let line = start_loc.loc_start.pos_lnum + line - 1 in + + let position = + {pos_fname = start_loc.loc_start.pos_fname; + pos_lnum = line; + pos_bol = 0; + pos_cnum = column}; + in + + {loc_start = position; + loc_end = position; + loc_ghost = false} + +(* Given the payload of a [%tyxml ...] expression, converts it to a TyXML + expression representing the markup contained therein. + + The payload [expr] is either a single string, or an application expression + involving strings and literal TyXML expressions. + + [markup_to_expr] first converts the payload to a list of strings and TyXML + expressions. It then builds an input stream for Markup.ml, which walks this + list. Bytes in strings encountered are passed to Markup.ml. When a TyXML + expression is encountered, it is appended to the current child list. + + The current child list is a piece of state maintained by the assembler, which + reads the Markup.ml signal (output) stream and recursively assembles the + TyXML expression. + + The current implementation stores the child list in a reference, becuase it + is modified by both the assembler and the input stream function. A better + implementation would scan the payload for the locations of literal TyXML + expressions, and merge them into the child list in the assembler. *) +let markup_to_expr loc expr = + let current_adjust_location = ref (adjust_location Location.none 0 0) in + let current_children = ref [] in + + let input_stream = + let expressions = + match expr.pexp_desc with + | Pexp_apply (f, arguments) -> f::(List.map snd arguments) + | _ -> [expr] + in + + let strings_and_antiquotations = + expressions |> List.map (fun expr -> + match expr.pexp_desc with + | Pexp_constant (Const_string (s, maybe_delimiter)) -> + let delimiter_length = + match maybe_delimiter with + | None -> 1 + | Some d -> String.length d + 2 + in + `String (s, expr.pexp_loc, delimiter_length) + + | _ -> + `Expression expr) + in + + let items = ref strings_and_antiquotations in + let offset = ref 0 in + let consumed = ref 0 in + + let rec next () = + match !items with + | (`String (s, loc, delimiter_length))::rest -> + if !offset = 0 then begin + current_adjust_location := + adjust_location loc delimiter_length !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 + + | (`Expression expr)::rest -> + current_children := expr::!current_children; + items := rest; + next () + + | [] -> + None + in + + Markup.fn next + 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 = + input_stream + |> Markup.parse_html + ~encoding:Markup.Encoding.utf_8 + ~report:(fun loc error -> + let loc = !current_adjust_location loc in + let message = Markup.Error.to_string error |> String.capitalize in + Ppx_common.error loc "%s" message) + in + let signals = parser |> Markup.signals in + + let rec assemble () = + match Markup.next signals with + | None | Some `End_element -> + current_children := List.rev !current_children + + | Some (`Text ss) -> + let loc = parser |> Markup.location |> !current_adjust_location in + let node = + [%expr pcdata [%e Ppx_common.string_exp loc (String.concat "" ss)]] + [@metaloc loc] + in + current_children := node::!current_children; + assemble () + + | Some (`Start_element (name, attributes)) -> + let loc = parser |> Markup.location |> !current_adjust_location in + + let accumulator = !current_children in + current_children := []; + assemble (); + let children = !current_children in + + let node = Ppx_element.parse loc name attributes children in + + current_children := node::accumulator; + assemble () + + | Some _ -> + assemble () + in + + assemble (); + Ppx_common.list_exp loc !current_children + + + +open Ast_mapper + +let map_expr mapper e = + match e.pexp_desc with + | Pexp_extension ({txt = "tyxml"; loc}, payload) -> + begin match payload with + | PStr [{pstr_desc = Pstr_eval (e, _)}] -> + markup_to_expr loc e + | _ -> + Ppx_common.error e.pexp_loc + "Error: Payload of [%%tyxml] must be a single string" + end + | _ -> default_mapper.expr mapper e + + + +let () = + register "tyxml" (fun _ -> {default_mapper with expr = map_expr}) From e798a19d465160fa3429572f2c44a43e66b36916 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 16:39:38 +0100 Subject: [PATCH 02/35] Typo. --- ppx/ppx_tyxml.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index a5df6ea3e..4c318af30 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -67,7 +67,7 @@ let adjust_location start_loc delimiter_length consumed (line, column) = reads the Markup.ml signal (output) stream and recursively assembles the TyXML expression. - The current implementation stores the child list in a reference, becuase it + The current implementation stores the child list in a reference, because it is modified by both the assembler and the input stream function. A better implementation would scan the payload for the locations of literal TyXML expressions, and merge them into the child list in the assembler. *) From 243f3605461eb27974a67bdd37aae8a6fffc0a9d Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 16:40:18 +0100 Subject: [PATCH 03/35] Fix merlin and improve _oasis. --- .merlin | 2 ++ _oasis | 8 +++++++- 2 files changed, 9 insertions(+), 1 deletion(-) 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/_oasis b/_oasis index d173803f0..cc6a3f3b4 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 @@ -107,6 +111,7 @@ Library tymlx_p Simplexmlparser Library ppx + Build$: flag(ppx) FindlibName: ppx FindlibParent: tyxml Path: ppx @@ -117,6 +122,7 @@ Library ppx XMETAExtraLines: ppx = "ppx_tyxml" Executable ppx_tyxml + Build$: flag(ppx) Path: ppx MainIs: ppx_tyxml.ml BuildDepends: @@ -126,7 +132,7 @@ Executable ppx_reflect Path: ppx MainIs: ppx_reflect.ml BuildDepends: - compiler-libs.common + compiler-libs.common, ppx_tools.metaquot ## Tests From f21c1cdd73233addc73d863c03f5900cb6e7bca2 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 16:40:37 +0100 Subject: [PATCH 04/35] Small simplification in ppx_common. --- ppx/ppx_common.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index d032fa232..59fb3b686 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -37,9 +37,7 @@ let list_exp loc l = [%expr [%e tree]::[%e acc]]) [%expr []]) [@metaloc loc] -let error loc = - Printf.ksprintf - (fun s -> raise (Location.Error (Location.error ~loc ("Error: " ^ s)))) +let error loc fmt = Location.raise_errorf ~loc ("Error: "^^fmt) let html5_implementation = "Html5" let svg_implementation = "Svg" From 65c48934b352780151690d0835c2f0ecea4eecd9 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 17:18:39 +0100 Subject: [PATCH 05/35] Remove some confusing whitespaces. --- ppx/ppx_element_content.ml | 4 ++-- ppx/ppx_reflect.ml | 28 ++++++++++++++-------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index 883f7091b..aa60e615a 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -40,7 +40,7 @@ type assembler = from any module, modifies the child to be an application of [Html5.svg] - Otherwise, evaluates to the child as passed. *) let _qualify_child implementation = function - | [%expr pcdata [%e ? s]] as e -> + | [%expr pcdata [%e? s]] as e -> let identifier = Ppx_common.identifier e.pexp_loc (Ppx_common.qualify implementation "pcdata") @@ -86,7 +86,7 @@ let _list_wrap_exp implementation loc es = only whitespace. *) let _filter_whitespace children = children |> List.filter (function - | [%expr pcdata [%e ? {pexp_desc = Pexp_constant (Const_string (s, _))}]] + | [%expr pcdata [%e? {pexp_desc = Pexp_constant (Const_string (s, _))}]] when String.trim s = "" -> false | _ -> true) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index f00095338..03b119d3f 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -135,7 +135,7 @@ let type_to_attribute_parser name types = "wrap (option \"\" string)" | [[%type : - [%t ? {ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] wrap]] + [%t? {ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] wrap]] when no_constructor_arguments constructors -> "wrap variant" @@ -197,14 +197,14 @@ let ocaml_attributes_to_renamed_attribute name attributes = | Some ({loc}, payload) -> match payload with | PStr [%str - [%e ? {pexp_desc = Pexp_constant (Const_string (real_name, _))}] - [%e ? element_names]] -> + [%e? {pexp_desc = Pexp_constant (Const_string (real_name, _))}] + [%e? element_names]] -> let element_names = let rec traverse acc = function | [%expr - [%e ? {pexp_desc = + [%e? {pexp_desc = Pexp_constant (Const_string (element_name, _))}]:: - [%e ? tail]] -> + [%e? tail]] -> traverse (element_name::acc) tail | [%expr []] -> acc | {pexp_loc} -> @@ -241,12 +241,12 @@ let val_item_to_element_info value_description = | Some ({loc}, payload) -> begin match payload with | PStr [%str - [%e ? {pexp_desc = Pexp_constant (Const_string (assembler, _))}]] -> + [%e? {pexp_desc = Pexp_constant (Const_string (assembler, _))}]] -> Some assembler, None | PStr [%str - [%e ? {pexp_desc = Pexp_constant (Const_string (assembler, _))}] - [%e ? {pexp_desc = Pexp_constant (Const_string (name, _))}]] -> + [%e? {pexp_desc = Pexp_constant (Const_string (assembler, _))}] + [%e? {pexp_desc = Pexp_constant (Const_string (name, _))}]] -> Some assembler, Some name | _ -> @@ -264,9 +264,9 @@ let val_item_to_element_info value_description = in match result_type with - | [%type : ([%t ? _], [%t ? _]) nullary] -> Some "nullary", None - | [%type : ([%t ? _], [%t ? _], [%t ? _]) unary] -> Some "unary", None - | [%type : ([%t ? _], [%t ? _], [%t ? _]) star] -> Some "star", None + | [%type : ([%t? _], [%t ? _]) nullary] -> Some "nullary", None + | [%type : ([%t? _], [%t ? _], [%t ? _]) unary] -> Some "unary", None + | [%type : ([%t? _], [%t ? _], [%t ? _]) star] -> Some "star", None | _ -> None, None in @@ -284,15 +284,15 @@ let val_item_to_element_info value_description = else begin let maybe_attribute_type = match t with - | [%type : [%t ? _] wrap] -> + | [%type : [%t? _] wrap] -> Some t - | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t ? _] elt wrap]])} + | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t? _] elt wrap]])} when Longident.last lid.txt = "option" -> None | {ptyp_desc = - Ptyp_constr (lid, [[%type : [%t ? _] wrap] as t''])} + Ptyp_constr (lid, [[%type : [%t? _] wrap] as t''])} when Longident.last lid.txt = "option" -> Some t'' From 76e74e789f8e5beb66fcad0c4b21625e328e0db5 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 18:41:57 +0100 Subject: [PATCH 06/35] Fix warnings Also fix a small bug. orderx/ordery. --- ppx/ppx_attribute_value.ml | 46 +++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 5860bee60..4a89a24f9 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -33,7 +33,7 @@ type parser = (* Options. *) -let option none (parser : parser) ?separated_by ?default:_ loc name s = +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 @@ -63,7 +63,7 @@ let _exp_list delimiter separated_by (element_parser : parser) loc name s = (* 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 = + delimiter separated_by element_parser ?separated_by:_ ?default:_ loc name s = _exp_list delimiter separated_by element_parser loc name s |> Ppx_common.list_exp loc @@ -81,12 +81,12 @@ let spaces_or_commas = _list _spaces_or_commas_regexp "space- or comma" (* Wrapping. *) -let wrap (parser : parser) implementation ?separated_by ?default loc name s = +let wrap (parser : parser) implementation ?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_exp implementation loc e) -let nowrap (parser : parser) _ ?separated_by ?default loc name s = +let nowrap (parser : parser) _ ?separated_by:_ ?default:_ loc name s = parser loc name s @@ -138,7 +138,7 @@ let _float_exp loc s = (* Numeric. *) -let char ?separated_by ?default loc name s = +let char ?separated_by:_ ?default:_ loc name s = let open Markup in let open Markup.Encoding in @@ -164,7 +164,7 @@ let char ?separated_by ?default loc name s = Some (Exp.constant ~loc (Const_char c)) -let bool ?separated_by ?default loc name s = +let bool ?separated_by:_ ?default:_ loc name s = begin try bool_of_string s |> ignore with Invalid_argument "bool_of_string" -> @@ -187,7 +187,7 @@ let float ?separated_by ?default loc name s = "a number (decimal fraction)" "numbers (decimal fractions)" separated_by default loc name -let points ?separated_by ?default loc name s = +let points ?separated_by:_ ?default:_ loc name s = let expressions = _spaces_or_commas float loc name s in let rec pair acc = function @@ -198,18 +198,18 @@ let points ?separated_by ?default loc name s = Some (pair [] expressions) -let number_pair ?separated_by ?default loc name s = +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 orderx]] + | [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 = +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])] @@ -220,7 +220,7 @@ let fourfloats ?separated_by ?default loc name s = let icon_size = let regexp = Str.regexp "\\([0-9]+\\)[xX]\\([0-9]+\\)" in - fun ?separated_by ?default loc name s -> + 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"; @@ -245,7 +245,7 @@ let icon_size = let length = let regexp = Str.regexp "\\([0-9]+\\)\\([^0-9]+\\)" in - fun ?separated_by ?default loc name s -> + 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; @@ -271,7 +271,7 @@ let length = let multilength = let regexp = Str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([0-9]+\\)?\\*" in - fun ?separated_by ?default loc name s -> + 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" name "list of relative lengths, such as 100px, 50%, or *"; @@ -370,7 +370,7 @@ let offset = let regexp = Str.regexp "\\([-+0-9eE.]+\\)$\\|\\([0-9]+\\)%" in - fun ?separated_by ?default loc name s -> + fun ?separated_by:_ ?default:_ loc name s -> if not @@ _does_match regexp s then bad_form name loc; begin @@ -397,7 +397,7 @@ let offset = let transform = let regexp = Str.regexp "\\([^(]+\\)(\\([^)]*\\))" in - fun ?separated_by ?default loc name s -> + 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; @@ -462,7 +462,7 @@ let transform = (* String-like. *) -let string ?separated_by ?default loc _ s = +let string ?separated_by:_ ?default:_ loc _ s = Some (Exp.constant ~loc (Const_string (s, None))) let _variand s = @@ -473,10 +473,10 @@ let _variand s = s |> Tyxml_name.polyvar |> without_backtick -let variant ?separated_by ?default loc _ s = +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 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_exp loc s))) @@ -485,9 +485,9 @@ let total_variant (unary, nullary) ?separated_by ?default loc name s = (* Miscellaneous. *) -let presence ?separated_by ?default _ _ _ = None +let presence ?separated_by:_ ?default:_ _ _ _ = None -let _paint_without_icc loc name s = +let _paint_without_icc loc _name s = begin match s with | "none" -> [%expr `None] @@ -511,7 +511,7 @@ let _paint_without_icc loc name s = Some [%e Ppx_common.string_exp loc icc_color])] end [@metaloc loc] -let paint ?separated_by ?default loc name s = +let paint ?separated_by:_ ?default:_ loc name s = if not @@ Str.string_match (Str.regexp "url(\\([^)]+\\))") s 0 then Some (_paint_without_icc loc name s) else @@ -533,7 +533,7 @@ let paint ?separated_by ?default loc name s = let srcset_element = let space = Str.regexp " +" in - fun ?separated_by ?default loc name s -> + fun ?separated_by:_ ?default:_ loc name s -> let e = begin match Str.bounded_split space s 2 with | [url] -> @@ -590,7 +590,7 @@ let in_ = total_variant Svg_types_reflected.in_value let in2 = in_ -let xmlns ?separated_by ?default loc name s = +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; From 28837bb21c44575e59660038ec0182631649e46f Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 18:52:27 +0100 Subject: [PATCH 07/35] Remove the various _. --- ppx/ppx_attribute_value.ml | 124 ++++++++++++++++++------------------- ppx/ppx_element_content.ml | 62 +++++++++---------- 2 files changed, 93 insertions(+), 93 deletions(-) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 4a89a24f9..300f14826 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -44,7 +44,7 @@ let option none (parser : parser) ?separated_by:_ ?default:_ loc name s = (* Lists. *) -let _filter_map f l = +let filter_map f l = l |> List.fold_left (fun acc v -> match f v with @@ -56,26 +56,26 @@ let _filter_map f l = (* 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 = +let exp_list delimiter separated_by (element_parser : parser) loc name s = Str.split delimiter s - |> _filter_map (element_parser ~separated_by loc name) + |> filter_map (element_parser ~separated_by loc name) (* Behaves as _expr_list, but wraps the resulting expression list as a list expression. *) -let _list +let list delimiter separated_by element_parser ?separated_by:_ ?default:_ loc name s = - _exp_list delimiter separated_by element_parser loc name s + exp_list delimiter separated_by element_parser loc name s |> Ppx_common.list_exp loc |> fun e -> Some e -let spaces = _list (Str.regexp " +") "space" -let commas = _list (Str.regexp " *, *") "comma" -let semicolons = _list (Str.regexp " *; *") "semicolon" +let spaces = list (Str.regexp " +") "space" +let commas = list (Str.regexp " *, *") "comma" +let semicolons = list (Str.regexp " *; *") "semicolon" -let _spaces_or_commas_regexp = 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" +let spaces_or_commas_regexp = 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" @@ -93,7 +93,7 @@ let nowrap (parser : parser) _ ?separated_by:_ ?default:_ loc name s = (* Error reporting for values in lists and options. *) -let _must_be_a +let must_be_a singular_description plural_description separated_by default loc name = let description = @@ -114,20 +114,20 @@ let _must_be_a (* 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 = +let does_match regexp s = Str.string_match regexp s 0 && 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 = +let group_matched index s = try Str.matched_group index s |> ignore; true with Not_found -> false -let _int_exp loc s = +let int_exp loc s = try Some (Ppx_common.int_exp loc (int_of_string s)) with Failure "int_of_string" -> None -let _float_exp loc s = +let float_exp loc s = try float_of_string s |> ignore; Some (Ppx_common.float_exp loc s) @@ -174,21 +174,21 @@ let bool ?separated_by:_ ?default:_ loc name s = 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 + match int_exp loc s with | Some _ as e -> e | None -> - _must_be_a "a whole number" "whole numbers" separated_by default loc name + 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 + match float_exp loc s with | Some _ as e -> e | None -> - _must_be_a + 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 expressions = spaces_or_commas_ float loc name s in let rec pair acc = function | [] -> List.rev acc |> Ppx_common.list_exp loc @@ -200,7 +200,7 @@ let points ?separated_by:_ ?default:_ loc name s = let number_pair ?separated_by:_ ?default:_ loc name s = let e = - begin match _spaces_or_commas float loc name s with + 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 @@ -210,7 +210,7 @@ let number_pair ?separated_by:_ ?default:_ loc name s = Some e let fourfloats ?separated_by:_ ?default:_ loc name s = - match _spaces_or_commas float loc name s with + 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] @@ -221,7 +221,7 @@ let icon_size = let regexp = Str.regexp "\\([0-9]+\\)[xX]\\([0-9]+\\)" in fun ?separated_by:_ ?default:_ loc name s -> - if not @@ _does_match regexp s then + 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"; @@ -246,12 +246,12 @@ let length = let regexp = Str.regexp "\\([0-9]+\\)\\([^0-9]+\\)" in fun ?separated_by:_ ?default:_ loc name s -> - if not @@ _does_match regexp s then + 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 (Str.matched_group 1 s) with + match int_exp loc (Str.matched_group 1 s) with | Some n -> n | None -> Ppx_common.error loc "Value of %s out of range" name @@ -272,14 +272,14 @@ let multilength = let regexp = Str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([0-9]+\\)?\\*" in fun ?separated_by:_ ?default:_ loc name s -> - if not @@ _does_match regexp s then + if not @@ does_match regexp s then Ppx_common.error loc "Value of %s must be a %s" name "list of relative lengths, such as 100px, 50%, or *"; begin - if _group_matched 1 s then + if group_matched 1 s then let n = - match _int_exp loc (Str.matched_group 1 s) with + match int_exp loc (Str.matched_group 1 s) with | Some n -> n | None -> Ppx_common.error loc "Value in %s out of range" name @@ -292,7 +292,7 @@ let multilength = else let n = - match _int_exp loc (Str.matched_group 3 s) with + match int_exp loc (Str.matched_group 3 s) with | exception Not_found -> [%expr 1] | Some n -> n | None -> @@ -302,7 +302,7 @@ let multilength = Some [%expr `Relative [%e n]] end [@metaloc loc] -let _svg_quantity = +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 @@ -311,11 +311,11 @@ let _svg_quantity = let regexp = 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; + 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 (Str.matched_group 1 s) with + match float_exp loc (Str.matched_group 1 s) with | Some n -> n | None -> Ppx_common.error loc "Number out of range in %s" name in @@ -346,10 +346,10 @@ let svg_length = fun ?separated_by ?default loc name s -> Some - (_svg_quantity "an SVG length" "SVG lengths" parse_unit + (svg_quantity "an SVG length" "SVG lengths" parse_unit ?separated_by ?default loc name s) -let _angle = +let angle_ = let parse_unit loc name unit = begin match unit with | "deg" -> [%expr `Deg] @@ -359,10 +359,10 @@ let _angle = end [@metaloc loc] in - _svg_quantity "an SVG angle" "SVG angles" parse_unit + 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) + Some (angle_ ?separated_by ?default loc name s) let offset = let bad_form name loc = @@ -371,12 +371,12 @@ let offset = let regexp = 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; + if not @@ does_match regexp s then bad_form name loc; begin - if _group_matched 1 s then + if group_matched 1 s then let n = - match _float_exp loc s with + match float_exp loc s with | Some n -> n | None -> bad_form name loc in @@ -385,7 +385,7 @@ let offset = else let n = - match _int_exp loc (Str.matched_group 2 s) with + match int_exp loc (Str.matched_group 2 s) with | Some n -> n | None -> Ppx_common.error loc "Percentage out of range in %s" name @@ -398,7 +398,7 @@ let transform = let regexp = Str.regexp "\\([^(]+\\)(\\([^)]*\\))" in fun ?separated_by:_ ?default:_ loc name s -> - if not @@ _does_match regexp s then + if not @@ does_match regexp s then Ppx_common.error loc "Value of %s must be an SVG transform" name; let kind = Str.matched_group 1 s in @@ -407,7 +407,7 @@ let transform = let e = begin match kind with | "matrix" -> - begin match _spaces_or_commas float loc "matrix" values with + 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])] @@ -416,7 +416,7 @@ let transform = end | "translate" -> - begin match _spaces_or_commas float loc "translate" values with + 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)] | _ -> @@ -424,7 +424,7 @@ let transform = end | "scale" -> - begin match _spaces_or_commas float loc "scale" values with + 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)] | _ -> @@ -432,14 +432,14 @@ let transform = end | "rotate" -> - begin match Str.bounded_split _spaces_or_commas_regexp values 2 with - | [angle] -> - [%expr Svg_types.Rotate ([%e _angle loc "rotate" angle], None)] - | [angle; axis] -> - begin match _spaces_or_commas float loc "rotate axis" axis with + begin match 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" angle], Some ([%e cx], [%e cy]))] + ([%e angle_ loc "rotate" a], Some ([%e cx], [%e cy]))] | _ -> Ppx_common.error loc "%s: rotate center requires two numbers" name end @@ -448,9 +448,9 @@ let transform = "%s: rotate requires an angle and an optional center" name end - | "skewX" -> [%expr Svg_types.SkewX [%e _angle loc "skewX" values]] + | "skewX" -> [%expr Svg_types.SkewX [%e angle_ loc "skewX" values]] - | "skewY" -> [%expr Svg_types.SkewY [%e _angle loc "skewY" 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] @@ -465,7 +465,7 @@ let transform = let string ?separated_by:_ ?default:_ loc _ s = Some (Exp.constant ~loc (Const_string (s, None))) -let _variand s = +let variand s = let without_backtick s = let length = String.length s in String.sub s 1 (length - 1) @@ -474,10 +474,10 @@ let _variand s = s |> Tyxml_name.polyvar |> without_backtick let variant ?separated_by:_ ?default:_ loc _ s = - Some (Exp.variant ~loc (_variand s) None) + Some (Exp.variant ~loc (variand s) None) let total_variant (unary, nullary) ?separated_by:_ ?default:_ loc _name s = - let variand = _variand s in + 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_exp loc s))) @@ -487,7 +487,7 @@ let total_variant (unary, nullary) ?separated_by:_ ?default:_ loc _name s = let presence ?separated_by:_ ?default:_ _ _ _ = None -let _paint_without_icc loc _name s = +let paint_without_icc loc _name s = begin match s with | "none" -> [%expr `None] @@ -513,7 +513,7 @@ let _paint_without_icc loc _name s = let paint ?separated_by:_ ?default:_ loc name s = if not @@ Str.string_match (Str.regexp "url(\\([^)]+\\))") s 0 then - Some (_paint_without_icc loc name s) + Some (paint_without_icc loc name s) else let iri = Str.matched_group 1 s |> Ppx_common.string_exp loc in let remainder_start = Str.group_end 0 in @@ -527,7 +527,7 @@ let paint ?separated_by:_ ?default:_ loc name s = else Some [%expr - `Icc ([%e iri], Some [%e _paint_without_icc loc name remainder])] + `Icc ([%e iri], Some [%e paint_without_icc loc name remainder])] end [@metaloc loc] let srcset_element = @@ -556,7 +556,7 @@ let srcset_element = if is_width then let n = - match _int_exp loc (String.sub descriptor 0 suffix_index) with + 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 @@ -566,7 +566,7 @@ let srcset_element = else let n = - match _float_exp loc (String.sub descriptor 0 suffix_index) with + 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 diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index aa60e615a..2bb7185b2 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -39,7 +39,7 @@ type assembler = - 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 implementation = function +let qualify_child implementation = function | [%expr pcdata [%e? s]] as e -> let identifier = Ppx_common.identifier e.pexp_loc @@ -62,7 +62,7 @@ let _qualify_child implementation = function 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 implementation loc es = +let list_wrap_exp implementation loc es = let nil = [%expr [%e Ppx_common.identifier loc @@ -75,7 +75,7 @@ let _list_wrap_exp implementation loc es = in es - |> List.map (_qualify_child implementation) + |> List.map (qualify_child implementation) |> List.rev |> List.fold_left (fun wrapped e -> [%expr [%e cons] [%e e] [%e wrapped]] [@metaloc loc]) @@ -84,7 +84,7 @@ let _list_wrap_exp implementation loc es = (* 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 = +let filter_whitespace children = children |> List.filter (function | [%expr pcdata [%e? {pexp_desc = Pexp_constant (Const_string (s, _))}]] when String.trim s = "" -> false @@ -92,18 +92,18 @@ let _filter_whitespace children = (* 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 +let is_element_with_name name = function | {pexp_desc = Pexp_apply ({pexp_desc = Pexp_ident {txt}}, _)} when Longident.flatten txt |> String.concat "." = 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 +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 = +let html5 local_name = Ppx_common.qualify Ppx_common.html5_implementation local_name @@ -119,23 +119,23 @@ let unary implementation loc name children = match children with | [child] -> let child = - _qualify_child implementation child + qualify_child implementation child |> Ppx_common.wrap_exp implementation loc in ["", child] | _ -> Ppx_common.error loc "%s should have exactly one child" name let star implementation loc _ children = - ["", _list_wrap_exp implementation loc children] + ["", list_wrap_exp implementation loc children] (* Special-cased. *) let html implementation 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 + 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], [] -> @@ -146,7 +146,7 @@ let html implementation loc name children = "%s element must have exactly head and body child elements" name let head implementation loc name children = - let title, others = _partition (_html5 "title") children in + let title, others = partition (html5 "title") children in match title with | [title] -> @@ -160,14 +160,14 @@ let figure implementation loc name children = begin match children with | [] -> star implementation loc name children | first::others -> - if _is_element_with_name (_html5 "figcaption") first then + if is_element_with_name (html5 "figcaption") first then ("figcaption", [%expr `Top [%e Ppx_common.wrap_exp implementation loc first]]):: (star implementation 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 + if is_element_with_name (html5 "figcaption") last then let others = List.rev (List.tl children_reversed) in ("figcaption", [%expr `Bottom [%e Ppx_common.wrap_exp implementation loc last]]):: @@ -177,28 +177,28 @@ let figure implementation loc name children = end [@metaloc loc] let object_ implementation loc name children = - let params, others = _partition (_html5 "param") children in + let params, others = partition (html5 "param") children in if params <> [] then - ("params", _list_wrap_exp implementation loc params):: + ("params", list_wrap_exp implementation loc params):: (star implementation loc name others) else star implementation loc name others let audio_video implementation loc name children = - let sources, others = _partition (_html5 "source") children in + let sources, others = partition (html5 "source") children in if sources <> [] then - ("srcs", _list_wrap_exp implementation loc sources):: + ("srcs", list_wrap_exp implementation loc sources):: (star implementation loc name others) else star implementation loc name others let table implementation 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 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 | [] -> [] @@ -208,7 +208,7 @@ let table implementation loc name children = let columns = if columns = [] then [] - else ["columns", _list_wrap_exp implementation loc columns] + else ["columns", list_wrap_exp implementation loc columns] in (one "caption" caption) @ @@ -218,7 +218,7 @@ let table implementation loc name children = (star implementation loc name others) let fieldset implementation loc name children = - let legend, others = _partition (_html5 "legend") children in + let legend, others = partition (html5 "legend") children in match legend with | [] -> star implementation loc name others @@ -228,24 +228,24 @@ let fieldset implementation loc name children = | _ -> Ppx_common.error loc "%s cannot have more than one legend" name let datalist implementation loc name children = - let options, others = _partition (_html5 "option") children in + let options, others = partition (html5 "option") children in let children = begin match others with | [] -> "children", - [%expr `Options [%e _list_wrap_exp implementation loc options]] + [%expr `Options [%e list_wrap_exp implementation loc options]] | _ -> "children", - [%expr `Phras [%e _list_wrap_exp implementation loc children]] + [%expr `Phras [%e list_wrap_exp implementation loc children]] end [@metaloc loc] in children::(nullary implementation loc name []) let details implementation loc name children = - let summary, others = _partition (_html5 "summary") children in + let summary, others = partition (html5 "summary") children in match summary with | [summary] -> @@ -256,7 +256,7 @@ let details implementation loc name children = let menu implementation loc name children = let children = "child", - [%expr `Flows [%e _list_wrap_exp implementation loc children]] + [%expr `Flows [%e list_wrap_exp implementation loc children]] [@metaloc loc] in children::(nullary implementation loc name []) From 703eb468466723dcec29c2ec3e1c192e0b01374f Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 19:48:58 +0100 Subject: [PATCH 08/35] Use a datatype for the language (and shorten some combinators). --- ppx/ppx_attribute_value.ml | 28 ++++++++++++------------- ppx/ppx_attribute_value.mli | 4 ++-- ppx/ppx_attributes.ml | 23 +++++++++----------- ppx/ppx_common.ml | 24 +++++++++++++++------ ppx/ppx_common.mli | 30 +++++++++++++------------- ppx/ppx_element.ml | 13 +++++------- ppx/ppx_element_content.ml | 42 +++++++++++++++---------------------- ppx/ppx_element_content.mli | 2 +- ppx/ppx_namespace.ml | 8 ++----- ppx/ppx_namespace.mli | 2 +- ppx/ppx_sigs_reflected.mli | 5 +++-- ppx/ppx_tyxml.ml | 4 ++-- 12 files changed, 89 insertions(+), 96 deletions(-) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 300f14826..29f875310 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -66,7 +66,7 @@ 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_exp loc + |> Ppx_common.list loc |> fun e -> Some e let spaces = list (Str.regexp " +") "space" @@ -84,7 +84,7 @@ let spaces_or_commas = list spaces_or_commas_regexp "space- or comma" let wrap (parser : parser) implementation ?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_exp implementation loc e) + | Some e -> Some (Ppx_common.wrap implementation loc e) let nowrap (parser : parser) _ ?separated_by:_ ?default:_ loc name s = parser loc name s @@ -124,13 +124,13 @@ let group_matched index s = with Not_found -> false let int_exp loc s = - try Some (Ppx_common.int_exp loc (int_of_string s)) + try Some (Ppx_common.int loc (int_of_string s)) with Failure "int_of_string" -> None let float_exp loc s = try float_of_string s |> ignore; - Some (Ppx_common.float_exp loc s) + Some (Ppx_common.float loc s) with Failure "float_of_string" -> None @@ -191,7 +191,7 @@ 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_exp loc + | [] -> 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 @@ -235,8 +235,8 @@ let icon_size = Some [%expr - [%e Ppx_common.int_exp loc width], - [%e Ppx_common.int_exp loc height]] [@metaloc loc] + [%e Ppx_common.int loc width], + [%e Ppx_common.int loc height]] [@metaloc loc] @@ -479,7 +479,7 @@ let variant ?separated_by:_ ?default:_ loc _ s = 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_exp loc s))) + else Some (Exp.variant ~loc unary (Some (Ppx_common.string loc s))) @@ -502,20 +502,20 @@ let paint_without_icc loc _name s = in match icc_color_start with - | None -> [%expr `Color ([%e Ppx_common.string_exp loc s], None)] + | None -> [%expr `Color ([%e Ppx_common.string loc s], None)] | Some i -> let icc_color = Str.matched_group 1 s in let color = String.sub s 0 i in [%expr `Color - ([%e Ppx_common.string_exp loc color], - Some [%e Ppx_common.string_exp loc icc_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 @@ Str.string_match (Str.regexp "url(\\([^)]+\\))") s 0 then Some (paint_without_icc loc name s) else - let iri = Str.matched_group 1 s |> Ppx_common.string_exp loc in + let iri = Str.matched_group 1 s |> Ppx_common.string loc in let remainder_start = Str.group_end 0 in let remainder_length = String.length s - remainder_start in let remainder = @@ -537,13 +537,13 @@ let srcset_element = let e = begin match Str.bounded_split space s 2 with | [url] -> - [%expr `Url [%e Ppx_common.string_exp loc 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_exp loc url in + let url = Ppx_common.string loc url in let suffix_index = String.length descriptor - 1 in let is_width = diff --git a/ppx/ppx_attribute_value.mli b/ppx/ppx_attribute_value.mli index 51f8db38a..7c5fcd9c4 100644 --- a/ppx/ppx_attribute_value.mli +++ b/ppx/ppx_attribute_value.mli @@ -72,11 +72,11 @@ val semicolons : parser -> parser val spaces_or_commas : parser -> parser (** Similar to [spaces], but splits on both spaces and commas. *) -val wrap : parser -> string -> parser +val wrap : parser -> Ppx_common.lang -> parser (** [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 -> string -> parser +val nowrap : parser -> Ppx_common.lang -> parser (** [nowrap parser _ _ _ s] evaluates to [parser _ _ s]. The purpose of this combinator is provide a signature similar to [wrap] in situations where wrapping is not wanted. *) diff --git a/ppx/ppx_attributes.ml b/ppx/ppx_attributes.ml index c3ea313df..d37610de6 100644 --- a/ppx/ppx_attributes.ml +++ b/ppx/ppx_attributes.ml @@ -18,7 +18,7 @@ *) let parse loc (ns, element_name) attributes = - let language, implementation, (module Reflected) = + let language, (module Reflected) = Ppx_namespace.reflect loc ns in (* For attribute names ["data-foo"], evaluates to [Some "foo"], otherwise @@ -28,7 +28,7 @@ let parse loc (ns, element_name) attributes = let length = String.length prefix in let is_user_data = - try language = "HTML" && String.sub local_name 0 length = prefix + try language = Html && String.sub local_name 0 length = prefix with Invalid_argument _ -> false in @@ -50,7 +50,7 @@ let parse loc (ns, element_name) attributes = let unknown () = Ppx_common.error loc "Unknown attribute in %s element: %s" - language local_name + (Ppx_common.lang language) local_name in (* Check whether this attribute is individually labeled. Parse its argument @@ -58,7 +58,7 @@ let parse loc (ns, element_name) attributes = match Ppx_common.find test_labeled Reflected.labeled_attributes with | Some (_, label, parser) -> let e = - match parser implementation loc local_name value with + match parser language loc local_name value with | None -> Ppx_common.error loc "Internal error: labeled attribute %s without an argument" label @@ -92,13 +92,11 @@ let parse loc (ns, element_name) attributes = Ppx_common.error loc "Internal error: no parser for %s" tyxml_name in - let identifier = Ppx_common.qualify implementation tyxml_name in - let identifier = Ppx_common.identifier loc identifier in - - let tag = Ppx_common.string_exp loc tag in + let identifier = Ppx_common.make ~loc language tyxml_name in + let tag = Ppx_common.string loc tag in let e = - match parser implementation loc local_name value with + 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" @@ -119,11 +117,10 @@ let parse loc (ns, element_name) attributes = with Not_found -> unknown () in - let identifier = Ppx_common.qualify implementation tyxml_name in - let identifier = Ppx_common.identifier loc identifier in + let identifier = Ppx_common.make ~loc language tyxml_name in let e = - match parser implementation loc local_name value with + match parser language loc local_name value with | None -> identifier | Some e' -> [%expr [%e identifier] [%e e']] [@metaloc loc] in @@ -138,5 +135,5 @@ let parse loc (ns, element_name) attributes = for a list, and prefix that with the ~a label. *) if regular = [] then List.rev labeled else - let regular = "a", Ppx_common.list_exp loc (List.rev regular) in + let regular = "a", Ppx_common.list loc (List.rev regular) in List.rev (regular::labeled) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index 59fb3b686..20ebd7f12 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -24,27 +24,39 @@ let find f l = try Some (List.find f l) with Not_found -> None -let int_exp loc n = Exp.constant ~loc (Const_int n) +let int loc n = Exp.constant ~loc (Const_int n) -let float_exp loc s = Exp.constant ~loc (Const_float s) +let float loc s = Exp.constant ~loc (Const_float s) -let string_exp loc s = Exp.constant ~loc (Const_string (s, None)) +let string loc s = Exp.constant ~loc (Const_string (s, None)) let identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) -let list_exp loc l = +let list loc l = (l |> List.rev |> List.fold_left (fun acc tree -> [%expr [%e tree]::[%e acc]]) [%expr []]) [@metaloc loc] let error loc fmt = Location.raise_errorf ~loc ("Error: "^^fmt) +type lang = Html | Svg + let html5_implementation = "Html5" let svg_implementation = "Svg" +let implementation = function + | Html -> html5_implementation + | Svg -> svg_implementation + +let lang = function + | Html -> "HTML" + | Svg -> "SVG" + let qualify module_ identifier = Printf.sprintf "%s.%s" module_ identifier -let wrap_exp implementation loc e = +let make ~loc i s = identifier loc (qualify (implementation i) s) + +let wrap implementation loc e = [%expr - [%e identifier loc (qualify implementation "Xml.W.return")] + [%e make ~loc implementation "Xml.W.return"] [%e e]] [@metaloc loc] diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 842895b9f..0238e6c3f 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -22,32 +22,30 @@ val find : ('a -> bool) -> 'a list -> 'a option [Not_found]. *) +(** Module implementations *) + +type lang = Html | Svg +val lang : lang -> string +val implementation : lang -> string + +val make : + loc:Location.t -> lang -> string -> Parsetree.expression (** Expression helpers. *) -val int_exp : Location.t -> int -> Parsetree.expression -val float_exp : Location.t -> string -> Parsetree.expression -val string_exp : Location.t -> string -> Parsetree.expression +val int : Location.t -> int -> Parsetree.expression +val float : Location.t -> string -> Parsetree.expression +val string : Location.t -> string -> Parsetree.expression val identifier : Location.t -> string -> Parsetree.expression -val list_exp : Location.t -> Parsetree.expression list -> Parsetree.expression +val list : Location.t -> Parsetree.expression list -> Parsetree.expression -val wrap_exp : - string -> Location.t -> Parsetree.expression -> 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]. *) - - -val html5_implementation : string -(** The module name ["Html5"]. *) - -val svg_implementation : string -(** The module name ["Svg"]. *) - val qualify : string -> string -> string (** [qualify m i] is [m ^ "." ^ i]. *) diff --git a/ppx/ppx_element.ml b/ppx/ppx_element.ml index f2537225f..071bed24b 100644 --- a/ppx/ppx_element.ml +++ b/ppx/ppx_element.ml @@ -20,24 +20,21 @@ let parse loc ((ns, name) as element_name) attributes children = let attributes = Ppx_attributes.parse loc element_name attributes in - let language, implementation, (module Reflected) = + let language, (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.qualify implementation name - |> Ppx_common.identifier loc - in + let element_function = Ppx_common.make ~loc language name in let assembler = try List.assoc name Reflected.element_assemblers - with Not_found -> Ppx_common.error loc "Unknown %s element %s" language name + with Not_found -> + Ppx_common.error loc "Unknown %s element %s" (Ppx_common.lang language) name in - let children = assembler implementation loc name children in + let children = assembler language loc name children in Ast_helper.Exp.apply ~loc element_function (attributes @ children) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index 2bb7185b2..118a1e4ab 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -20,10 +20,8 @@ open Asttypes open Parsetree - - type assembler = - string -> Location.t -> string -> Parsetree.expression list -> + Ppx_common.lang -> Location.t -> string -> Parsetree.expression list -> (Asttypes.label * Parsetree.expression) list @@ -39,19 +37,17 @@ type assembler = - 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 implementation = function +let qualify_child lang = function | [%expr pcdata [%e? s]] as e -> let identifier = - Ppx_common.identifier e.pexp_loc - (Ppx_common.qualify implementation "pcdata") + Ppx_common.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} as e', arguments)} as e - when Longident.last lid.txt = "svg" - && implementation = Ppx_common.html5_implementation -> - let html5_svg = Ppx_common.qualify Ppx_common.html5_implementation "svg" in + when Longident.last lid.txt = "svg" && lang = Html -> + let html5_svg = Ppx_common.qualify Ppx_common.(implementation Html) "svg" in let lid = {lid with txt = Longident.parse html5_svg} in let identifier = {e' with pexp_desc = Pexp_ident lid} in {e with pexp_desc = Pexp_apply (identifier, arguments)} @@ -65,14 +61,10 @@ let qualify_child implementation = function let list_wrap_exp implementation loc es = let nil = [%expr - [%e Ppx_common.identifier loc - (Ppx_common.qualify implementation "Xml.W.nil")] + [%e Ppx_common.make ~loc implementation "Xml.W.nil"] ()] [@metaloc loc] in - let cons = - Ppx_common.identifier loc - (Ppx_common.qualify implementation "Xml.W.cons") - in + let cons = Ppx_common.make ~loc implementation "Xml.W.cons" in es |> List.map (qualify_child implementation) @@ -104,7 +96,7 @@ let partition name children = (* Given the name [n] of a function in [Html5_sigs.T], evaluates to ["Html5." ^ n]. *) let html5 local_name = - Ppx_common.qualify Ppx_common.html5_implementation local_name + Ppx_common.qualify Ppx_common.(implementation Html) local_name @@ -120,7 +112,7 @@ let unary implementation loc name children = | [child] -> let child = qualify_child implementation child - |> Ppx_common.wrap_exp implementation loc + |> Ppx_common.wrap implementation loc in ["", child] | _ -> Ppx_common.error loc "%s should have exactly one child" name @@ -139,8 +131,8 @@ let html implementation loc name children = match head, body, others with | [head], [body], [] -> - ["", Ppx_common.wrap_exp implementation loc head; - "", Ppx_common.wrap_exp implementation loc body] + ["", Ppx_common.wrap implementation loc head; + "", Ppx_common.wrap implementation loc body] | _ -> Ppx_common.error loc "%s element must have exactly head and body child elements" name @@ -150,7 +142,7 @@ let head implementation loc name children = match title with | [title] -> - ("", Ppx_common.wrap_exp implementation loc title):: + ("", Ppx_common.wrap implementation loc title):: (star implementation loc name others) | _ -> Ppx_common.error loc @@ -162,7 +154,7 @@ let figure implementation loc name children = | first::others -> if is_element_with_name (html5 "figcaption") first then ("figcaption", - [%expr `Top [%e Ppx_common.wrap_exp implementation loc first]]):: + [%expr `Top [%e Ppx_common.wrap implementation loc first]]):: (star implementation loc name others) else let children_reversed = List.rev children in @@ -170,7 +162,7 @@ let figure implementation loc name children = if is_element_with_name (html5 "figcaption") last then let others = List.rev (List.tl children_reversed) in ("figcaption", - [%expr `Bottom [%e Ppx_common.wrap_exp implementation loc last]]):: + [%expr `Bottom [%e Ppx_common.wrap implementation loc last]]):: (star implementation loc name others) else star implementation loc name children @@ -202,7 +194,7 @@ let table implementation loc name children = let one label = function | [] -> [] - | [child] -> [label, Ppx_common.wrap_exp implementation loc child] + | [child] -> [label, Ppx_common.wrap implementation loc child] | _ -> Ppx_common.error loc "%s cannot have more than one %s" name label in @@ -223,7 +215,7 @@ let fieldset implementation loc name children = match legend with | [] -> star implementation loc name others | [legend] -> - ("legend", Ppx_common.wrap_exp implementation loc legend):: + ("legend", Ppx_common.wrap implementation loc legend):: (star implementation loc name others) | _ -> Ppx_common.error loc "%s cannot have more than one legend" name @@ -249,7 +241,7 @@ let details implementation loc name children = match summary with | [summary] -> - ("", Ppx_common.wrap_exp implementation loc summary):: + ("", Ppx_common.wrap implementation loc summary):: (star implementation loc name others) | _ -> Ppx_common.error loc "%s must have exactly one summary child" name diff --git a/ppx/ppx_element_content.mli b/ppx/ppx_element_content.mli index 1fba5ba1f..a97a20a73 100644 --- a/ppx/ppx_element_content.mli +++ b/ppx/ppx_element_content.mli @@ -23,7 +23,7 @@ type assembler = - string -> Location.t -> string -> Parsetree.expression list -> + Ppx_common.lang -> Location.t -> string -> Parsetree.expression list -> (Asttypes.label * Parsetree.expression) list (** Assemblers satisfy: [assembler implementation loc name children] evaluates to a list of optionally-labeled parse trees for passing [children] to the diff --git a/ppx/ppx_namespace.ml b/ppx/ppx_namespace.ml index 4960fbd9f..ddfab5b7e 100644 --- a/ppx/ppx_namespace.ml +++ b/ppx/ppx_namespace.ml @@ -19,13 +19,9 @@ let reflect loc = function | ns when ns = Markup.Ns.html -> - "HTML", - Ppx_common.html5_implementation, - (module Html5_sigs_reflected : Ppx_sigs_reflected.S) + Ppx_common.Html ,(module Html5_sigs_reflected : Ppx_sigs_reflected.S) | ns when ns = Markup.Ns.svg -> - "SVG", - Ppx_common.svg_implementation, - (module Svg_sigs_reflected : Ppx_sigs_reflected.S) + Ppx_common.Svg, (module Svg_sigs_reflected : Ppx_sigs_reflected.S) | ns -> Ppx_common.error loc "Unknown namespace %s" ns diff --git a/ppx/ppx_namespace.mli b/ppx/ppx_namespace.mli index 377385de7..731cbd754 100644 --- a/ppx/ppx_namespace.mli +++ b/ppx/ppx_namespace.mli @@ -22,7 +22,7 @@ val reflect : - Location.t -> string -> string * string * (module Ppx_sigs_reflected.S) + 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 diff --git a/ppx/ppx_sigs_reflected.mli b/ppx/ppx_sigs_reflected.mli index 84160a33c..36a97fecc 100644 --- a/ppx/ppx_sigs_reflected.mli +++ b/ppx/ppx_sigs_reflected.mli @@ -24,14 +24,15 @@ module type S = sig - val attribute_parsers : (string * (string -> Ppx_attribute_value.parser)) list + val attribute_parsers : + (string * (Ppx_common.lang -> Ppx_attribute_value.parser)) 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 * (string -> Ppx_attribute_value.parser)) list + (string * string * (Ppx_common.lang -> Ppx_attribute_value.parser)) list (** Triples [tyxml_element_name, label, wrapped_attribute_value_parser]. *) val element_assemblers : (string * Ppx_element_content.assembler) list diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 4c318af30..e65fd33ff 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -157,7 +157,7 @@ let markup_to_expr loc expr = | Some (`Text ss) -> let loc = parser |> Markup.location |> !current_adjust_location in let node = - [%expr pcdata [%e Ppx_common.string_exp loc (String.concat "" ss)]] + [%expr pcdata [%e Ppx_common.string loc (String.concat "" ss)]] [@metaloc loc] in current_children := node::!current_children; @@ -181,7 +181,7 @@ let markup_to_expr loc expr = in assemble (); - Ppx_common.list_exp loc !current_children + Ppx_common.list loc !current_children From e37c8d3024d25f5c27bf35f6a8e190d5da167a68 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 20:09:57 +0100 Subject: [PATCH 09/35] Remove some superfluous functions. --- ppx/ppx_common.mli | 4 ---- ppx/ppx_element_content.ml | 10 ++++------ 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 0238e6c3f..2a11821c0 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -36,7 +36,6 @@ val make : val int : Location.t -> int -> Parsetree.expression val float : Location.t -> string -> Parsetree.expression val string : Location.t -> string -> Parsetree.expression -val identifier : Location.t -> string -> Parsetree.expression val list : Location.t -> Parsetree.expression list -> Parsetree.expression val wrap : @@ -46,6 +45,3 @@ val wrap : val error : Location.t -> ('b, unit, string, 'a) format4 -> 'b (** Raises an error using compiler module [Location]. *) - -val qualify : string -> string -> string -(** [qualify m i] is [m ^ "." ^ i]. *) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index 118a1e4ab..e369b1561 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -45,11 +45,9 @@ let qualify_child lang = function [%expr [%e identifier] [%e s]] [@metaloc e.pexp_loc] | {pexp_desc = - Pexp_apply ({pexp_desc = Pexp_ident lid} as e', arguments)} as e + Pexp_apply ({pexp_desc = Pexp_ident lid}, arguments)} as e when Longident.last lid.txt = "svg" && lang = Html -> - let html5_svg = Ppx_common.qualify Ppx_common.(implementation Html) "svg" in - let lid = {lid with txt = Longident.parse html5_svg} in - let identifier = {e' with pexp_desc = Pexp_ident lid} in + let identifier = Ppx_common.make ~loc:lid.loc Html "svg" in {e with pexp_desc = Pexp_apply (identifier, arguments)} | e -> e @@ -86,7 +84,7 @@ let filter_whitespace children = application of a function with name [name]. *) let is_element_with_name name = function | {pexp_desc = Pexp_apply ({pexp_desc = Pexp_ident {txt}}, _)} - when Longident.flatten txt |> String.concat "." = name -> true + when txt = name -> true | _ -> false (* Partitions a list of elements according to [_is_element_with_name name]. *) @@ -96,7 +94,7 @@ let partition name children = (* Given the name [n] of a function in [Html5_sigs.T], evaluates to ["Html5." ^ n]. *) let html5 local_name = - Ppx_common.qualify Ppx_common.(implementation Html) local_name + Longident.Ldot (Lident Ppx_common.(implementation Html), local_name) From 1317c9ebc671173fe91be0b9f9d7b82c482e9f22 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 20:10:13 +0100 Subject: [PATCH 10/35] Fix comment. --- ppx/ppx_common.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 2a11821c0..b840cec74 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -22,7 +22,7 @@ val find : ('a -> bool) -> 'a list -> 'a option [Not_found]. *) -(** Module implementations *) +(** Markup language *) type lang = Html | Svg val lang : lang -> string From 024bd87ec73f7738f281f7e083366b5eb63809ad Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 21:22:28 +0100 Subject: [PATCH 11/35] Various changes for 4.03 --- ppx/ppx_attribute_value.ml | 3 +- ppx/ppx_common.ml | 12 ++-- ppx/ppx_common.mli | 3 +- ppx/ppx_element_content.ml | 58 +++++++++--------- ppx/ppx_reflect.ml | 118 ++++++++++++++++++------------------- ppx/ppx_tyxml.ml | 1 + 6 files changed, 102 insertions(+), 93 deletions(-) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 29f875310..27a9c7444 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -129,8 +129,7 @@ let int_exp loc s = let float_exp loc s = try - float_of_string s |> ignore; - Some (Ppx_common.float loc s) + Some (Ppx_common.float loc @@ float_of_string s) with Failure "float_of_string" -> None diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index 20ebd7f12..4d58026da 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -17,18 +17,22 @@ * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. *) -open Asttypes open Ast_helper +module Label = Ast_convenience.Label + let find f l = try Some (List.find f l) with Not_found -> None -let int loc n = Exp.constant ~loc (Const_int n) +let with_loc loc f x = + with_default_loc loc @@ fun () -> f x + +let int loc = with_loc loc Ast_convenience.int -let float loc s = Exp.constant ~loc (Const_float s) +let float loc = with_loc loc Ast_convenience.float -let string loc s = Exp.constant ~loc (Const_string (s, None)) +let string loc = with_loc loc Ast_convenience.str let identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index b840cec74..4ee12e669 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -21,6 +21,7 @@ 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 *) @@ -34,7 +35,7 @@ val make : (** Expression helpers. *) val int : Location.t -> int -> Parsetree.expression -val float : Location.t -> string -> 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 diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index e369b1561..a7b7002a3 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -19,9 +19,10 @@ open Asttypes open Parsetree +module Pc = Ppx_common type assembler = - Ppx_common.lang -> Location.t -> string -> Parsetree.expression list -> + Pc.lang -> Location.t -> string -> Parsetree.expression list -> (Asttypes.label * Parsetree.expression) list @@ -40,14 +41,14 @@ type assembler = let qualify_child lang = function | [%expr pcdata [%e? s]] as e -> let identifier = - Ppx_common.make ~loc:e.pexp_loc lang "pcdata" + 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 = Ppx_common.make ~loc:lid.loc Html "svg" in + let identifier = Pc.make ~loc:lid.loc Html "svg" in {e with pexp_desc = Pexp_apply (identifier, arguments)} | e -> e @@ -59,10 +60,10 @@ let qualify_child lang = function let list_wrap_exp implementation loc es = let nil = [%expr - [%e Ppx_common.make ~loc implementation "Xml.W.nil"] + [%e Pc.make ~loc implementation "Xml.W.nil"] ()] [@metaloc loc] in - let cons = Ppx_common.make ~loc implementation "Xml.W.cons" in + let cons = Pc.make ~loc implementation "Xml.W.cons" in es |> List.map (qualify_child implementation) @@ -76,8 +77,11 @@ let list_wrap_exp implementation loc es = only whitespace. *) let filter_whitespace children = children |> List.filter (function - | [%expr pcdata [%e? {pexp_desc = Pexp_constant (Const_string (s, _))}]] - when String.trim s = "" -> false + | [%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 @@ -94,7 +98,7 @@ let partition name children = (* Given the name [n] of a function in [Html5_sigs.T], evaluates to ["Html5." ^ n]. *) let html5 local_name = - Longident.Ldot (Lident Ppx_common.(implementation Html), local_name) + Longident.Ldot (Lident Pc.(implementation Html), local_name) @@ -102,21 +106,21 @@ let html5 local_name = let nullary _ loc name children = if children <> [] then - Ppx_common.error loc "%s should have no content" name; - ["", [%expr ()] [@metaloc loc]] + Pc.error loc "%s should have no content" name; + [Pc.Label.nolabel, [%expr ()] [@metaloc loc]] let unary implementation loc name children = match children with | [child] -> let child = qualify_child implementation child - |> Ppx_common.wrap implementation loc + |> Pc.wrap implementation loc in - ["", child] - | _ -> Ppx_common.error loc "%s should have exactly one child" name + [Pc.Label.nolabel, child] + | _ -> Pc.error loc "%s should have exactly one child" name let star implementation loc _ children = - ["", list_wrap_exp implementation loc children] + [Pc.Label.nolabel, list_wrap_exp implementation loc children] @@ -129,10 +133,10 @@ let html implementation loc name children = match head, body, others with | [head], [body], [] -> - ["", Ppx_common.wrap implementation loc head; - "", Ppx_common.wrap implementation loc body] + [Pc.Label.nolabel, Pc.wrap implementation loc head; + Pc.Label.nolabel, Pc.wrap implementation loc body] | _ -> - Ppx_common.error loc + Pc.error loc "%s element must have exactly head and body child elements" name let head implementation loc name children = @@ -140,10 +144,10 @@ let head implementation loc name children = match title with | [title] -> - ("", Ppx_common.wrap implementation loc title):: + (Pc.Label.nolabel, Pc.wrap implementation loc title):: (star implementation loc name others) | _ -> - Ppx_common.error loc + Pc.error loc "%s element must have exactly one title child element" name let figure implementation loc name children = @@ -152,7 +156,7 @@ let figure implementation loc name children = | first::others -> if is_element_with_name (html5 "figcaption") first then ("figcaption", - [%expr `Top [%e Ppx_common.wrap implementation loc first]]):: + [%expr `Top [%e Pc.wrap implementation loc first]]):: (star implementation loc name others) else let children_reversed = List.rev children in @@ -160,7 +164,7 @@ let figure implementation loc name children = if is_element_with_name (html5 "figcaption") last then let others = List.rev (List.tl children_reversed) in ("figcaption", - [%expr `Bottom [%e Ppx_common.wrap implementation loc last]]):: + [%expr `Bottom [%e Pc.wrap implementation loc last]]):: (star implementation loc name others) else star implementation loc name children @@ -192,8 +196,8 @@ let table implementation loc name children = let one label = function | [] -> [] - | [child] -> [label, Ppx_common.wrap implementation loc child] - | _ -> Ppx_common.error loc "%s cannot have more than one %s" name label + | [child] -> [label, Pc.wrap implementation loc child] + | _ -> Pc.error loc "%s cannot have more than one %s" name label in let columns = @@ -213,9 +217,9 @@ let fieldset implementation loc name children = match legend with | [] -> star implementation loc name others | [legend] -> - ("legend", Ppx_common.wrap implementation loc legend):: + ("legend", Pc.wrap implementation loc legend):: (star implementation loc name others) - | _ -> Ppx_common.error loc "%s cannot have more than one legend" name + | _ -> Pc.error loc "%s cannot have more than one legend" name let datalist implementation loc name children = let options, others = partition (html5 "option") children in @@ -239,9 +243,9 @@ let details implementation loc name children = match summary with | [summary] -> - ("", Ppx_common.wrap implementation loc summary):: + (Pc.Label.nolabel, Pc.wrap implementation loc summary):: (star implementation loc name others) - | _ -> Ppx_common.error loc "%s must have exactly one summary child" name + | _ -> Pc.error loc "%s must have exactly one summary child" name let menu implementation loc name children = let children = diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index 03b119d3f..4ce45b55f 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -195,30 +195,36 @@ let ocaml_attributes_to_renamed_attribute name attributes = 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? {pexp_desc = Pexp_constant (Const_string (real_name, _))}] + [%e? const] [%e? element_names]] -> - let element_names = - let rec traverse acc = function - | [%expr - [%e? {pexp_desc = - Pexp_constant (Const_string (element_name, _))}]:: - [%e? tail]] -> - traverse (element_name::acc) tail - | [%expr []] -> acc - | {pexp_loc} -> - Ppx_common.error pexp_loc - "List in [@@reflect.attribute] must contain strings" - in - traverse [] element_names - in - - [name, real_name, element_names] - - | _ -> - Ppx_common.error loc - "Payload of [@@reflect.attribute] must be a string and a string list" + 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 @@ -239,19 +245,18 @@ let val_item_to_element_info value_description = let maybe_assembler, real_name = match maybe_attribute with | Some ({loc}, payload) -> - begin match payload with - | PStr [%str - [%e? {pexp_desc = Pexp_constant (Const_string (assembler, _))}]] -> - Some assembler, None - - | PStr [%str - [%e? {pexp_desc = Pexp_constant (Const_string (assembler, _))}] - [%e? {pexp_desc = Pexp_constant (Const_string (name, _))}]] -> - Some assembler, Some name - - | _ -> - Ppx_common.error loc - "Payload of [@@reflect.element] must be a one or two strings" + 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 a one or two strings" end | None -> @@ -276,33 +281,28 @@ let val_item_to_element_info value_description = let labeled_attributes = let rec scan acc = function | Ptyp_arrow (label, t, t') -> - let label = - if label = "" || label.[0] <> '?' then label - else String.sub label 1 (String.length label - 1) + + let maybe_attribute_type = + match t with + | [%type : [%t? _] wrap] -> + Some t + + | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t? _] elt wrap]])} + when Longident.last lid.txt = "option" -> + None + + | {ptyp_desc = + Ptyp_constr (lid, [[%type : [%t? _] wrap] as t''])} + when Longident.last lid.txt = "option" -> + Some t'' + + | _ -> + None in - if label = "" then scan acc t'.ptyp_desc - else begin - let maybe_attribute_type = - match t with - | [%type : [%t? _] wrap] -> - Some t - - | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t? _] elt wrap]])} - when Longident.last lid.txt = "option" -> - None - - | {ptyp_desc = - Ptyp_constr (lid, [[%type : [%t? _] wrap] as t''])} - when Longident.last lid.txt = "option" -> - Some t'' - - | _ -> - None - in - match maybe_attribute_type with - | None -> scan acc t'.ptyp_desc - | Some t'' -> + begin match Ppx_common.Label.explode label, maybe_attribute_type with + | Nolabel, _ | _,None -> scan acc t'.ptyp_desc + | (Labelled label | Optional label), Some t'' -> let parser = type_to_attribute_parser label [t''] in scan ((name, label, parser)::acc) t'.ptyp_desc end diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index e65fd33ff..22ee303b5 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -85,6 +85,7 @@ let markup_to_expr loc expr = let strings_and_antiquotations = 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, maybe_delimiter)) -> let delimiter_length = match maybe_delimiter with From e703ffe13db00f28be8c9e6f321908c86ac8df93 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 21:45:02 +0100 Subject: [PATCH 12/35] Sometimes, |> is not an improvement. --- ppx/ppx_attributes.ml | 2 +- ppx/ppx_reflect.ml | 12 ++++++------ ppx/ppx_tyxml.ml | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/ppx/ppx_attributes.ml b/ppx/ppx_attributes.ml index d37610de6..6abd73929 100644 --- a/ppx/ppx_attributes.ml +++ b/ppx/ppx_attributes.ml @@ -129,7 +129,7 @@ let parse loc (ns, element_name) attributes = in let labeled, regular = - attributes |> List.fold_left parse_attribute ([], []) in + 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. *) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index 4ce45b55f..a1823471d 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -188,8 +188,8 @@ let type_to_attribute_parser name types = from markup name to TyXML name should be performed. *) let ocaml_attributes_to_renamed_attribute name attributes = let maybe_attribute = - attributes - |> Ppx_common.find (fun attr -> (fst attr).txt = "reflect.attribute") + Ppx_common.find (fun attr -> (fst attr).txt = "reflect.attribute") + attributes in match maybe_attribute with @@ -238,8 +238,8 @@ let val_item_to_element_info value_description = let name = value_description.pval_name.txt in let maybe_attribute = - value_description.pval_attributes - |> Ppx_common.find (fun attr -> (fst attr).txt = "reflect.element") + Ppx_common.find (fun attr -> (fst attr).txt = "reflect.element") + value_description.pval_attributes in let maybe_assembler, real_name = @@ -388,7 +388,7 @@ let type_declaration mapper declaration = in let nullary, unary = - rows |> List.partition (fun (_, types) -> types = []) in + List.partition (fun (_, types) -> types = []) rows in let unary = match unary with @@ -398,7 +398,7 @@ let type_declaration mapper declaration = "Expected exactly one non-nullary constructor `C of string" in - let nullary = nullary |> List.map fst in + let nullary = List.map fst nullary in reflected_variants := (name, (unary, nullary))::!reflected_variants diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 22ee303b5..14e315f73 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -148,7 +148,7 @@ let markup_to_expr loc expr = let message = Markup.Error.to_string error |> String.capitalize in Ppx_common.error loc "%s" message) in - let signals = parser |> Markup.signals in + let signals = Markup.signals parser in let rec assemble () = match Markup.next signals with From 7274c09e41f7f76ce8a626ae9736982059ab6708 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 22:15:06 +0100 Subject: [PATCH 13/35] Move list wrap to common. --- ppx/ppx_common.ml | 62 ++++++++++++++++++++++++-------------- ppx/ppx_common.mli | 1 + ppx/ppx_element_content.ml | 16 ++-------- 3 files changed, 43 insertions(+), 36 deletions(-) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index 4d58026da..da65eb0c4 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -18,30 +18,9 @@ *) open Ast_helper - module Label = Ast_convenience.Label -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 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 identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) - -let list loc l = - (l |> List.rev |> List.fold_left (fun acc tree -> - [%expr [%e tree]::[%e acc]]) - [%expr []]) [@metaloc loc] - -let error loc fmt = Location.raise_errorf ~loc ("Error: "^^fmt) +(** Lang utilities *) type lang = Html | Svg @@ -57,9 +36,46 @@ let lang = function | Svg -> "SVG" let qualify module_ identifier = Printf.sprintf "%s.%s" module_ identifier - +let identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) let make ~loc i s = identifier loc (qualify (implementation i) s) +(** 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"] diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 4ee12e669..3b6fb8cd4 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -38,6 +38,7 @@ 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 diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index a7b7002a3..f10e2763e 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -57,20 +57,10 @@ let qualify_child lang = function 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 implementation loc es = - let nil = - [%expr - [%e Pc.make ~loc implementation "Xml.W.nil"] - ()] [@metaloc loc] - in - let cons = Pc.make ~loc implementation "Xml.W.cons" in - +let list_wrap_exp lang loc es = es - |> List.map (qualify_child implementation) - |> List.rev - |> List.fold_left (fun wrapped e -> - [%expr [%e cons] [%e e] [%e wrapped]] [@metaloc loc]) - nil + |> 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 From 1534200b701b00a85a589a57d1c4390db1a1e9a8 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 22:27:10 +0100 Subject: [PATCH 14/35] Simplify Ppx_common.make. --- ppx/ppx_common.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index da65eb0c4..08abaaba7 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -35,9 +35,9 @@ let lang = function | Html -> "HTML" | Svg -> "SVG" -let qualify module_ identifier = Printf.sprintf "%s.%s" module_ identifier -let identifier loc s = Exp.ident ~loc (Location.mkloc (Longident.parse s) loc) -let make ~loc i s = identifier loc (qualify (implementation i) s) +let make ~loc i s = + let lid = Longident.parse @@ implementation i ^ "." ^ s in + Exp.ident ~loc @@ Location.mkloc lid loc (** Generic *) From 4f6e005a6ff492101024b35b7a4e2f5584f3a47b Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 18 Mar 2016 23:38:36 +0100 Subject: [PATCH 15/35] Misc changes. --- ppx/ppx_element.ml | 13 +++-- ppx/ppx_element.mli | 12 ++--- ppx/ppx_element_content.ml | 98 ++++++++++++++++++------------------- ppx/ppx_element_content.mli | 15 +++--- ppx/ppx_tyxml.ml | 2 +- 5 files changed, 68 insertions(+), 72 deletions(-) diff --git a/ppx/ppx_element.ml b/ppx/ppx_element.ml index 071bed24b..4949b633b 100644 --- a/ppx/ppx_element.ml +++ b/ppx/ppx_element.ml @@ -17,24 +17,23 @@ * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. *) -let parse loc ((ns, name) as element_name) attributes children = - let attributes = Ppx_attributes.parse loc element_name attributes in +let parse ~loc ~name:((ns, name) as element_name) ~attributes children = - let language, (module Reflected) = - Ppx_namespace.reflect loc ns in + 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 language 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 language) name + Ppx_common.error loc "Unknown %s element %s" (Ppx_common.lang lang) name in - let children = assembler language loc name children in + let children = assembler ~lang ~loc ~name children in Ast_helper.Exp.apply ~loc element_function (attributes @ children) diff --git a/ppx/ppx_element.mli b/ppx/ppx_element.mli index 1ff8e3c1e..37ab1be02 100644 --- a/ppx/ppx_element.mli +++ b/ppx/ppx_element.mli @@ -19,12 +19,12 @@ (** Element parsing. *) - - val parse : - Location.t -> - Markup.name -> (Markup.name * string) list -> Parsetree.expression list -> - Parsetree.expression -(** [parse loc name attributes children] evaluates to a parse tree for applying + loc:Location.t -> + name:Markup.name -> + attributes:(Markup.name * string) 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]. *) diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index f10e2763e..64fe755b0 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -22,8 +22,11 @@ open Parsetree module Pc = Ppx_common type assembler = - Pc.lang -> Location.t -> string -> Parsetree.expression list -> - (Asttypes.label * Parsetree.expression) list + lang:Ppx_common.lang -> + loc:Location.t -> + name:string -> + Parsetree.expression list -> + (Pc.Label.t * Parsetree.expression) list @@ -54,7 +57,7 @@ let qualify_child lang = function | 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] + 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 = @@ -81,7 +84,7 @@ let is_element_with_name name = function when txt = name -> true | _ -> false -(* Partitions a list of elements according to [_is_element_with_name name]. *) +(* Partitions a list of elements according to [is_element_with_name name]. *) let partition name children = List.partition (is_element_with_name name) children @@ -94,91 +97,88 @@ let html5 local_name = (* Generic. *) -let nullary _ loc name children = +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 implementation loc name children = +let unary ~lang ~loc ~name children = match children with | [child] -> let child = - qualify_child implementation child - |> Pc.wrap implementation loc + 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 implementation loc _ children = - [Pc.Label.nolabel, list_wrap_exp implementation loc children] +let star ~lang ~loc ~name:_ children = + [Pc.Label.nolabel, list_wrap_exp lang loc children] (* Special-cased. *) -let html implementation loc name children = +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 implementation loc head; - Pc.Label.nolabel, Pc.wrap implementation loc 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 implementation loc name children = +let head ~lang ~loc ~name children = let title, others = partition (html5 "title") children in match title with | [title] -> - (Pc.Label.nolabel, Pc.wrap implementation loc title):: - (star implementation loc name others) + (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 implementation loc name children = +let figure ~lang ~loc ~name children = begin match children with - | [] -> star implementation loc name children + | [] -> star ~lang ~loc ~name children | first::others -> if is_element_with_name (html5 "figcaption") first then ("figcaption", - [%expr `Top [%e Pc.wrap implementation loc first]]):: - (star implementation loc name others) + [%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 implementation loc last]]):: - (star implementation loc name others) + [%expr `Bottom [%e Pc.wrap lang loc last]]):: + (star ~lang ~loc ~name others) else - star implementation loc name children + star ~lang ~loc ~name children end [@metaloc loc] -let object_ implementation loc name children = +let object_ ~lang ~loc ~name children = let params, others = partition (html5 "param") children in if params <> [] then - ("params", list_wrap_exp implementation loc params):: - (star implementation loc name others) + ("params", list_wrap_exp lang loc params) :: star ~lang ~loc ~name others else - star implementation loc name others + star ~lang ~loc ~name others -let audio_video implementation loc name children = +let audio_video ~lang ~loc ~name children = let sources, others = partition (html5 "source") children in if sources <> [] then - ("srcs", list_wrap_exp implementation loc sources):: - (star implementation loc name others) + ("srcs", list_wrap_exp lang loc sources) :: star ~lang ~loc ~name others else - star implementation loc name others + star ~lang ~loc ~name others -let table implementation loc name children = +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 @@ -186,61 +186,61 @@ let table implementation loc name children = let one label = function | [] -> [] - | [child] -> [label, Pc.wrap implementation loc child] + | [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 implementation loc columns] + else ["columns", list_wrap_exp lang loc columns] in (one "caption" caption) @ columns @ (one "thead" thead) @ (one "tfoot" tfoot) @ - (star implementation loc name others) + (star ~lang ~loc ~name others) -let fieldset implementation loc name children = +let fieldset ~lang ~loc ~name children = let legend, others = partition (html5 "legend") children in match legend with - | [] -> star implementation loc name others + | [] -> star ~lang ~loc ~name others | [legend] -> - ("legend", Pc.wrap implementation loc legend):: - (star implementation loc name others) + ("legend", Pc.wrap lang loc legend):: + (star ~lang ~loc ~name others) | _ -> Pc.error loc "%s cannot have more than one legend" name -let datalist implementation loc name children = +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 implementation loc options]] + [%expr `Options [%e list_wrap_exp lang loc options]] | _ -> "children", - [%expr `Phras [%e list_wrap_exp implementation loc children]] + [%expr `Phras [%e list_wrap_exp lang loc children]] end [@metaloc loc] in - children::(nullary implementation loc name []) + children::(nullary ~lang ~loc ~name []) -let details implementation loc name children = +let details ~lang ~loc ~name children = let summary, others = partition (html5 "summary") children in match summary with | [summary] -> - (Pc.Label.nolabel, Pc.wrap implementation loc summary):: - (star implementation loc name others) + (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 implementation loc name children = +let menu ~lang ~loc ~name children = let children = "child", - [%expr `Flows [%e list_wrap_exp implementation loc children]] + [%expr `Flows [%e list_wrap_exp lang loc children]] [@metaloc loc] in - children::(nullary implementation loc name []) + children::(nullary ~lang ~loc ~name []) diff --git a/ppx/ppx_element_content.mli b/ppx/ppx_element_content.mli index a97a20a73..d85a4cbda 100644 --- a/ppx/ppx_element_content.mli +++ b/ppx/ppx_element_content.mli @@ -20,12 +20,13 @@ (** Element child argument assemblers. These are almost parsers, except they only tell how to pass already-parsed children to element functions. *) - - type assembler = - Ppx_common.lang -> Location.t -> string -> Parsetree.expression list -> - (Asttypes.label * Parsetree.expression) list -(** Assemblers satisfy: [assembler implementation loc name children] evaluates + 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 @@ -58,16 +59,12 @@ type assembler = 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 diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 14e315f73..61fe84534 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -172,7 +172,7 @@ let markup_to_expr loc expr = assemble (); let children = !current_children in - let node = Ppx_element.parse loc name attributes children in + let node = Ppx_element.parse ~loc ~name ~attributes children in current_children := node::accumulator; assemble () From dd6ab0abca21b146583196fefea9b6191b06cf90 Mon Sep 17 00:00:00 2001 From: Drup Date: Tue, 29 Mar 2016 18:31:10 +0200 Subject: [PATCH 16/35] Remove str Use Re_str temporarly. --- _oasis | 2 +- ppx/ppx_attribute_value.ml | 72 ++++++++++++++++++-------------------- 2 files changed, 35 insertions(+), 39 deletions(-) diff --git a/_oasis b/_oasis index cc6a3f3b4..4d1eab7aa 100644 --- a/_oasis +++ b/_oasis @@ -126,7 +126,7 @@ Executable ppx_tyxml Path: ppx MainIs: ppx_tyxml.ml BuildDepends: - str, ppx_tools.metaquot, markup, tyxml.tools + re.str, ppx_tools.metaquot, markup, tyxml.tools Executable ppx_reflect Path: ppx diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 27a9c7444..75589ad86 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -18,11 +18,7 @@ *) open Asttypes - -(* Not opening all of Ast_helper in order to avoid shadowing stdlib's Str with - Ast_helper.Str. *) -module Exp = Ast_helper.Exp - +open Ast_helper type parser = @@ -57,7 +53,7 @@ let filter_map f l = 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 = - Str.split delimiter 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 @@ -69,11 +65,11 @@ let list |> Ppx_common.list loc |> fun e -> Some e -let spaces = list (Str.regexp " +") "space" -let commas = list (Str.regexp " *, *") "comma" -let semicolons = list (Str.regexp " *; *") "semicolon" +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 = Str.regexp "\\( *, *\\)\\| +" +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" @@ -115,12 +111,12 @@ let must_be_a (* 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 = - Str.string_match regexp s 0 && Str.match_end () = String.length 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 Str.matched_group index s |> ignore; true + try Re_str.matched_group index s |> ignore; true with Not_found -> false let int_exp loc s = @@ -217,7 +213,7 @@ let fourfloats ?separated_by:_ ?default:_ loc name s = (* These are always in a list; hence the error message. *) let icon_size = - let regexp = Str.regexp "\\([0-9]+\\)[xX]\\([0-9]+\\)" in + 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 @@ -226,8 +222,8 @@ let icon_size = let width, height = try - int_of_string (Str.matched_group 1 s), - int_of_string (Str.matched_group 2 s) + 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 @@ -242,7 +238,7 @@ let icon_size = (* Dimensional. *) let length = - let regexp = Str.regexp "\\([0-9]+\\)\\([^0-9]+\\)" in + let regexp = Re_str.regexp "\\([0-9]+\\)\\([^0-9]+\\)" in fun ?separated_by:_ ?default:_ loc name s -> if not @@ does_match regexp s then @@ -250,14 +246,14 @@ let length = loc "Value of %s must be a length, such as 100px or 50%%" name; let n = - match int_exp loc (Str.matched_group 1 s) with + 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 Str.matched_group 2 s with + 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 @@ -268,7 +264,7 @@ let length = (* This is only called by the commas combinator; hence the error message. *) let multilength = - let regexp = Str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([0-9]+\\)?\\*" in + let regexp = Re_str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([0-9]+\\)?\\*" in fun ?separated_by:_ ?default:_ loc name s -> if not @@ does_match regexp s then @@ -278,20 +274,20 @@ let multilength = begin if group_matched 1 s then let n = - match int_exp loc (Str.matched_group 1 s) with + match int_exp loc (Re_str.matched_group 1 s) with | Some n -> n | None -> Ppx_common.error loc "Value in %s out of range" name in - match Str.matched_group 2 s with + match Re_str.matched_group 2 s with | "%" -> Some [%expr `Percent [%e n]] | "px" -> Some [%expr `Pixels [%e n]] | _ -> Ppx_common.error loc "Internal error: Ppx_attribute.multilength" else let n = - match int_exp loc (Str.matched_group 3 s) with + match int_exp loc (Re_str.matched_group 3 s) with | exception Not_found -> [%expr 1] | Some n -> n | None -> @@ -307,19 +303,19 @@ let svg_quantity = 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 = Str.regexp quantity 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 (Str.matched_group 1 s) with + 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 = Str.matched_group 4 s 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] @@ -367,7 +363,7 @@ let offset = let bad_form name loc = Ppx_common.error loc "Value of %s must be a number or percentage" name in - let regexp = Str.regexp "\\([-+0-9eE.]+\\)$\\|\\([0-9]+\\)%" 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; @@ -384,7 +380,7 @@ let offset = else let n = - match int_exp loc (Str.matched_group 2 s) with + 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 @@ -394,14 +390,14 @@ let offset = end [@metaloc loc] let transform = - let regexp = Str.regexp "\\([^(]+\\)(\\([^)]*\\))" in + 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 = Str.matched_group 1 s in - let values = Str.matched_group 2 s in + let kind = Re_str.matched_group 1 s in + let values = Re_str.matched_group 2 s in let e = begin match kind with @@ -431,7 +427,7 @@ let transform = end | "rotate" -> - begin match Str.bounded_split spaces_or_commas_regexp values 2 with + 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] -> @@ -496,14 +492,14 @@ let paint_without_icc loc _name s = | _ -> let icc_color_start = - try Some (Str.search_forward (Str.regexp "icc-color(\\([^)]*\\))") s 0) + 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 = Str.matched_group 1 s in + 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], @@ -511,11 +507,11 @@ let paint_without_icc loc _name s = end [@metaloc loc] let paint ?separated_by:_ ?default:_ loc name s = - if not @@ Str.string_match (Str.regexp "url(\\([^)]+\\))") s 0 then + if not @@ Re_str.string_match (Re_str.regexp "url(\\([^)]+\\))") s 0 then Some (paint_without_icc loc name s) else - let iri = Str.matched_group 1 s |> Ppx_common.string loc in - let remainder_start = Str.group_end 0 in + 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 @@ -530,11 +526,11 @@ let paint ?separated_by:_ ?default:_ loc name s = end [@metaloc loc] let srcset_element = - let space = Str.regexp " +" in + let space = Re_str.regexp " +" in fun ?separated_by:_ ?default:_ loc name s -> let e = - begin match Str.bounded_split space s 2 with + begin match Re_str.bounded_split space s 2 with | [url] -> [%expr `Url [%e Ppx_common.string loc url]] From 76e1db883f55cf5f7f34fef5c661bdff403fa595 Mon Sep 17 00:00:00 2001 From: Drup Date: Tue, 29 Mar 2016 19:05:03 +0200 Subject: [PATCH 17/35] Freshen up ppx_reflect a bit. --- ppx/ppx_reflect.ml | 84 ++++++++++++++++++++++------------------------ 1 file changed, 41 insertions(+), 43 deletions(-) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index a1823471d..f184b1e46 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -26,6 +26,8 @@ open Ast_mapper open Asttypes open Parsetree +open Ast_helper +module AC = Ast_convenience @@ -410,6 +412,41 @@ let type_declaration mapper declaration = default_mapper.type_declaration mapper 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 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 () = + + begin if !attribute_parsers <> [] then [%str + open Ppx_attribute_value + + let attribute_parsers = + [%e Combi.(list @@ tuple2 str id) !attribute_parsers ] + let renamed_attributes = + [%e Combi.(list @@ tuple3 str str (list str)) !renamed_attributes ] + let labeled_attributes = + [%e Combi.(list @@ tuple3 str str id) !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 + (* Creates an AST mapper that applies [signature_item] and [type_declaration], then formats the generated reflection information as ML code to the file @@ -425,47 +462,8 @@ let () = register "reflect_sig" (fun _ -> {default_mapper with signature_item; type_declaration}); - (* The channel will be closed on process exit. *) + let reflected_struct = emit_module () in let channel = open_out filename in - let write f = Printf.fprintf channel f in - - if !attribute_parsers <> [] then begin - write "open Ppx_attribute_value\n"; - - write "\nlet attribute_parsers = [\n"; - !attribute_parsers |> List.iter (fun (name, parser) -> - write " %S, %s;\n" name parser); - write "]\n"; - - write "\nlet renamed_attributes = [\n"; - !renamed_attributes |> List.iter (fun (name, real_name, element_names) -> - write " %S, %S, [" name real_name; - element_names - |> List.map (Printf.sprintf "%S") - |> String.concat "; " - |> write "%s];\n"); - write "]\n"; - - write "\nlet labeled_attributes = [\n"; - !labeled_attributes |> List.iter (fun (name, label, parser) -> - write " %S, %S, %s;\n" name label parser); - write "]\n"; - - write "\nopen Ppx_element_content\n"; - - write "\nlet element_assemblers = [\n"; - !element_assemblers |> List.iter (fun (name, assembler) -> - write " %S, %s;\n" name assembler); - write "]\n"; - - write "\nlet renamed_elements = [\n"; - !renamed_elements |> List.iter (fun (real_name, name) -> - write " %S, %S;\n" real_name name); - write "]\n" - end; - - !reflected_variants |> List.iter (fun (name, (unary, nullary)) -> - write "\nlet %s = %S, [\n" name unary; - nullary |> List.iter (fun nullary -> - write " %S;\n" nullary); - write "]\n") + let fmt = Format.formatter_of_out_channel channel in + Format.fprintf fmt "%a%!" Pprintast.structure reflected_struct ; + close_out channel From e0c18e81f9b7e58024cb54048ee6ff8db36b138b Mon Sep 17 00:00:00 2001 From: Drup Date: Tue, 29 Mar 2016 23:32:49 +0200 Subject: [PATCH 18/35] Rewrite IO part of ppx_reflect to behave sensibly. --- _oasis | 1 + myocamlbuild.ml | 17 ++++++++----- ppx/ppx_reflect.ml | 60 ++++++++++++++++++++++++++++++++++------------ 3 files changed, 57 insertions(+), 21 deletions(-) diff --git a/_oasis b/_oasis index 4d1eab7aa..27a01c0ae 100644 --- a/_oasis +++ b/_oasis @@ -133,6 +133,7 @@ Executable ppx_reflect MainIs: ppx_reflect.ml BuildDepends: compiler-libs.common, ppx_tools.metaquot + CompiledObject: best ## Tests diff --git a/myocamlbuild.ml b/myocamlbuild.ml index ea30de8bc..0bce0a1f1 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -25,19 +25,24 @@ 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.byte" in + 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 "ocamlc"; - A "-I"; A "lib"; - A "-ppx"; A (Printf.sprintf "%s %s" ppx_reflect (env prod)); - A "-c"; A (env dep)]) + Cmd (S [A ppx_reflect ; A (env dep); A (env prod)]) end let () = diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index f184b1e46..cf74bb3d7 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -411,6 +411,7 @@ let type_declaration mapper declaration = 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 @@ -424,7 +425,7 @@ 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 @@ -448,22 +449,51 @@ let emit_module () = List.map Combi.(let_ AC.pvar (tuple2 str (list str))) !reflected_variants -(* Creates an AST mapper that applies [signature_item] and [type_declaration], - then formats the generated reflection information as ML code to the file - whose name is given in the first argument to the PPX reflector. *) +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 < 2 then begin - Printf.eprintf "Usage: %s FILE\n" Sys.argv.(0); + if Array.length Sys.argv < 3 then begin + Printf.eprintf "Usage: %s IN OUT\n" Sys.argv.(0); exit 2 end; - let filename = Sys.argv.(1) in + let in_file = Sys.argv.(1) in + let out_file = Sys.argv.(2) in - register "reflect_sig" (fun _ -> - {default_mapper with signature_item; type_declaration}); - - let reflected_struct = emit_module () in - let channel = open_out filename in - let fmt = Format.formatter_of_out_channel channel in - Format.fprintf fmt "%a%!" Pprintast.structure reflected_struct ; - close_out channel + try + read_sig in_file + |> reflected_struct + |> write_struct out_file + with exn -> + Location.report_exception Format.err_formatter exn; + exit 2 From ce057f5e3f402afd10f84f5f2dbb6a56942d568c Mon Sep 17 00:00:00 2001 From: Drup Date: Tue, 29 Mar 2016 23:39:43 +0200 Subject: [PATCH 19/35] Compile ppx_tyxml in native if possible. --- _oasis | 1 + 1 file changed, 1 insertion(+) diff --git a/_oasis b/_oasis index 27a01c0ae..c42db6c68 100644 --- a/_oasis +++ b/_oasis @@ -127,6 +127,7 @@ Executable ppx_tyxml MainIs: ppx_tyxml.ml BuildDepends: re.str, ppx_tools.metaquot, markup, tyxml.tools + CompiledObject: best Executable ppx_reflect Path: ppx From 55c3c7282c531a64e99e781407c05efc4e53cb0c Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Tue, 29 Mar 2016 17:33:38 -0500 Subject: [PATCH 20/35] Have OPAM pass the --enable-ppx flag to OASIS. Also added OPAM dependency on ppx_tools and conditioned building of ppx_reflect on --enable-ppx. --- _oasis | 1 + opam | 3 +++ 2 files changed, 4 insertions(+) diff --git a/_oasis b/_oasis index c42db6c68..ea0bfdf9e 100644 --- a/_oasis +++ b/_oasis @@ -130,6 +130,7 @@ Executable ppx_tyxml CompiledObject: best Executable ppx_reflect + Build$: flag(ppx) Path: ppx MainIs: ppx_reflect.ml BuildDepends: diff --git a/opam b/opam index 497ba19df..6c2f3db60 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,7 @@ depends: [ "uutf" "base-bytes" "re" + ( "base-no-ppx" | "ppx_tools" ) "alcotest" {test} ## OASIS is not required in released version "oasis" {build & >= "0.4.4"} From 742bf8291883b8ba639554e33a41679ea8fd6986 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Tue, 29 Mar 2016 17:41:32 -0500 Subject: [PATCH 21/35] Depend on Markup.ml in opam file. --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index 6c2f3db60..8eda1b6e1 100644 --- a/opam +++ b/opam @@ -33,6 +33,7 @@ depends: [ "uutf" "base-bytes" "re" + "markup" ( "base-no-ppx" | "ppx_tools" ) "alcotest" {test} ## OASIS is not required in released version From 3d1a4c938bf8bacf5fff02e9c2a91e6e23c51f65 Mon Sep 17 00:00:00 2001 From: Drup Date: Wed, 30 Mar 2016 19:13:18 +0200 Subject: [PATCH 22/35] Introduce value parsers and modify various types. --- ppx/ppx_attribute_value.ml | 25 +++++++++++++++++++++---- ppx/ppx_attribute_value.mli | 24 ++++++++++++++++++------ ppx/ppx_attributes.mli | 2 +- ppx/ppx_element.mli | 2 +- ppx/ppx_sigs_reflected.mli | 4 ++-- 5 files changed, 43 insertions(+), 14 deletions(-) diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 75589ad86..89c8ab185 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -20,12 +20,25 @@ open Asttypes open Ast_helper +type value = [ + | `String of string + | `Expr of Parsetree.expression +] -type parser = - ?separated_by:string -> ?default:string -> Location.t -> string -> string -> +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. *) @@ -77,12 +90,16 @@ let spaces_or_commas = list spaces_or_commas_regexp "space- or comma" (* Wrapping. *) -let wrap (parser : parser) implementation ?separated_by:_ ?default:_ loc name s = +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) _ ?separated_by:_ ?default:_ loc name s = +let nowrap (parser : parser) _ = + expr @@ + fun ?separated_by:_ ?default:_ loc name s -> parser loc name s diff --git a/ppx/ppx_attribute_value.mli b/ppx/ppx_attribute_value.mli index 7c5fcd9c4..97638eb0c 100644 --- a/ppx/ppx_attribute_value.mli +++ b/ppx/ppx_attribute_value.mli @@ -20,10 +20,19 @@ (** 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 parser = - ?separated_by:string -> ?default:string -> Location.t -> string -> string -> - Parsetree.expression option +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 @@ -72,13 +81,16 @@ val semicolons : parser -> parser val spaces_or_commas : parser -> parser (** Similar to [spaces], but splits on both spaces and commas. *) -val wrap : parser -> Ppx_common.lang -> parser +(** {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 -> parser +val nowrap : parser -> Ppx_common.lang -> vparser (** [nowrap parser _ _ _ s] evaluates to [parser _ _ s]. The purpose of this - combinator is provide a signature similar to [wrap] in situations where + combinator is to provide a signature similar to [wrap] in situations where wrapping is not wanted. *) diff --git a/ppx/ppx_attributes.mli b/ppx/ppx_attributes.mli index 75af6f0f6..4e728aaab 100644 --- a/ppx/ppx_attributes.mli +++ b/ppx/ppx_attributes.mli @@ -22,7 +22,7 @@ val parse : - Location.t -> Markup.name -> (Markup.name * string) list -> + 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 diff --git a/ppx/ppx_element.mli b/ppx/ppx_element.mli index 37ab1be02..023482f5c 100644 --- a/ppx/ppx_element.mli +++ b/ppx/ppx_element.mli @@ -22,7 +22,7 @@ val parse : loc:Location.t -> name:Markup.name -> - attributes:(Markup.name * string) list -> + 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 diff --git a/ppx/ppx_sigs_reflected.mli b/ppx/ppx_sigs_reflected.mli index 36a97fecc..3bb696b1c 100644 --- a/ppx/ppx_sigs_reflected.mli +++ b/ppx/ppx_sigs_reflected.mli @@ -25,14 +25,14 @@ module type S = sig val attribute_parsers : - (string * (Ppx_common.lang -> Ppx_attribute_value.parser)) list + (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.parser)) list + (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 From 7ce2be0298947fa4360f613cc9eb24610b5217c9 Mon Sep 17 00:00:00 2001 From: Drup Date: Wed, 30 Mar 2016 03:47:05 +0200 Subject: [PATCH 23/35] Implement antiquotations using placeholder elements. --- ppx/ppx_tyxml.ml | 180 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 122 insertions(+), 58 deletions(-) diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 61fe84534..3df57273e 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -20,7 +20,94 @@ open Asttypes open Parsetree +(** 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." (* Converts a Markup.ml input location into an OCaml location. [start_loc] is the OCaml location of the string being parsed by Markup.ml. @@ -61,19 +148,10 @@ let adjust_location start_loc delimiter_length consumed (line, column) = [markup_to_expr] first converts the payload to a list of strings and TyXML expressions. It then builds an input stream for Markup.ml, which walks this list. Bytes in strings encountered are passed to Markup.ml. When a TyXML - expression is encountered, it is appended to the current child list. - - The current child list is a piece of state maintained by the assembler, which - reads the Markup.ml signal (output) stream and recursively assembles the - TyXML expression. - - The current implementation stores the child list in a reference, because it - is modified by both the assembler and the input stream function. A better - implementation would scan the payload for the locations of literal TyXML - expressions, and merge them into the child list in the assembler. *) + expression is encountered, a dummy token is inserted that is later replaced by + the proper expression. *) let markup_to_expr loc expr = let current_adjust_location = ref (adjust_location Location.none 0 0) in - let current_children = ref [] in let input_stream = let expressions = @@ -83,28 +161,28 @@ let markup_to_expr loc expr = in let strings_and_antiquotations = - 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, maybe_delimiter)) -> - let delimiter_length = - match maybe_delimiter with - | None -> 1 - | Some d -> String.length d + 2 - in - `String (s, expr.pexp_loc, delimiter_length) - - | _ -> - `Expression expr) + 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, maybe_delimiter)) -> + let delimiter_length = + match maybe_delimiter with + | None -> 1 + | Some d -> String.length d + 2 + in + (s, expr.pexp_loc, delimiter_length) + + | _ -> + (Antiquot.create expr, expr.pexp_loc, 0) in let items = ref strings_and_antiquotations in let offset = ref 0 in let consumed = ref 0 in - let rec next () = - match !items with - | (`String (s, loc, delimiter_length))::rest -> + let rec next () = match !items with + | [] -> None + | (s, loc, delimiter_length)::rest -> if !offset = 0 then begin current_adjust_location := adjust_location loc delimiter_length !consumed; @@ -120,14 +198,6 @@ let markup_to_expr loc expr = items := rest; next () end - - | (`Expression expr)::rest -> - current_children := expr::!current_children; - items := rest; - next () - - | [] -> - None in Markup.fn next @@ -150,39 +220,33 @@ let markup_to_expr loc expr = in let signals = Markup.signals parser in - let rec assemble () = + let get_loc () = + parser |> Markup.location |> !current_adjust_location + in + + let rec assemble children = match Markup.next signals with - | None | Some `End_element -> - current_children := List.rev !current_children + | None | Some `End_element -> List.rev children | Some (`Text ss) -> - let loc = parser |> Markup.location |> !current_adjust_location in - let node = - [%expr pcdata [%e Ppx_common.string loc (String.concat "" ss)]] - [@metaloc loc] - in - current_children := node::!current_children; - assemble () + let loc = get_loc () in + let node = make_text ~loc ss in + assemble (node @ children) | Some (`Start_element (name, attributes)) -> - let loc = parser |> Markup.location |> !current_adjust_location in - - let accumulator = !current_children in - current_children := []; - assemble (); - let children = !current_children in - - let node = Ppx_element.parse ~loc ~name ~attributes children in + let loc = get_loc () in - current_children := node::accumulator; - assemble () + let sub_children = assemble [] 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 (node :: children) | Some _ -> - assemble () + assemble children in - assemble (); - Ppx_common.list loc !current_children + Ppx_common.list loc @@ assemble [] From 36b04fb3ac1cc83941afc4adcf5f0233c366ea0f Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 00:50:07 +0200 Subject: [PATCH 24/35] Add testing for the ppx. --- _tags | 3 ++ myocamlbuild.ml | 9 +++-- test/main_test.ml | 1 + test/test_ppx.ml | 84 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 95 insertions(+), 2 deletions(-) create mode 100644 test/test_ppx.ml 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/myocamlbuild.ml b/myocamlbuild.ml index 0bce0a1f1..0c1bf2305 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -42,9 +42,13 @@ let reflect_ppx () = rule "ppx_reflect: mli -> _reflected.ml" ~prod ~deps:[dep; ppx_reflect] begin fun env _ -> - Cmd (S [A ppx_reflect ; A (env dep); A (env prod)]) + 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 -> @@ -64,7 +68,8 @@ let () = if String.sub Sys.ocaml_version 0 4 = "4.00" then flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot"); - reflect_ppx () + reflect_ppx () ; + tyxml_ppx () ; | _ -> ()) 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..0afd4267d --- /dev/null +++ b/test/test_ppx.ml @@ -0,0 +1,84 @@ +(** 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. +*) + +open Html5 + +module TyTests = struct + type t = Xml.elt list + let pp fmt x = + P.print_list ~output:(Format.pp_print_string fmt) (M.totl x) + let equal = (=) +end + + +let tyxml_tests l = + let f (name, ty1, ty2) = + name, `Quick, fun () -> + Alcotest.(check (module TyTests)) name (M.toeltl ty1) (M.toeltl ty2) + in + List.map f l + +module Html5 = M +let basics = "ppx basics", tyxml_tests M.[ + + "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"] ] []] ; + +] + +let elt1 = M.(span [pcdata "one"]) +let elt2 = M.(b [pcdata "two"]) +let id = "pata" + +let antiquot = "ppx antiquot", tyxml_tests M.[ + + "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 ; +] From 871f52a470b431fa4ceac44528a6194d7df88839 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 01:33:15 +0200 Subject: [PATCH 25/35] Untangle things a bit more. --- ppx/ppx_tyxml.ml | 188 ++++++++++++++++++++++++----------------------- 1 file changed, 97 insertions(+), 91 deletions(-) diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 3df57273e..26b1a1187 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -20,6 +20,48 @@ 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)". @@ -109,99 +151,66 @@ let replace_attribute ~loc (attr,value) = Ppx_common.error loc "Mixing literals and OCaml expressions is not authorized in attribute values." -(* Converts a Markup.ml input location into an OCaml location. [start_loc] is - the OCaml location of the string being parsed by Markup.ml. - [delimiter_length] is the length of string delimiter. For a regular string, - this is [1] (for the quote). For a delimited string, it is the length of the - delimiter plus two for the [{] and [|] characters. [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_location start_loc delimiter_length consumed (line, column) = - let open Location in - let open Lexing in - - let column = - if line <> 1 then column - else - start_loc.loc_start.pos_cnum - start_loc.loc_start.pos_bol + - column + delimiter_length - consumed - in - let line = start_loc.loc_start.pos_lnum + line - 1 in - let position = - {pos_fname = start_loc.loc_start.pos_fname; - pos_lnum = line; - pos_bol = 0; - pos_cnum = column}; - in +(** Processing *) - {loc_start = position; - loc_end = position; - loc_ghost = false} +(** Takes the ast and transforms it into a Markup.ml char stream. -(* Given the payload of a [%tyxml ...] expression, converts it to a TyXML - expression representing the markup contained therein. + 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}). - The payload [expr] is either a single string, or an application expression - involving strings and literal TyXML expressions. + 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 - [markup_to_expr] first converts the payload to a list of strings and TyXML - expressions. It then builds an input stream for Markup.ml, which walks this - list. Bytes in strings encountered are passed to Markup.ml. When a TyXML - expression is encountered, a dummy token is inserted that is later replaced by - the proper expression. *) -let markup_to_expr loc expr = - let current_adjust_location = ref (adjust_location Location.none 0 0) in + let expressions = + match expr.pexp_desc with + | Pexp_apply (f, arguments) -> f::(List.map snd arguments) + | _ -> [expr] + in - let input_stream = - 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 strings_and_antiquotations = - 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, maybe_delimiter)) -> - let delimiter_length = - match maybe_delimiter with - | None -> 1 - | Some d -> String.length d + 2 - in - (s, expr.pexp_loc, delimiter_length) - - | _ -> - (Antiquot.create expr, expr.pexp_loc, 0) - 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 - let items = ref strings_and_antiquotations in - let offset = ref 0 in - let consumed = ref 0 in - - let rec next () = match !items with - | [] -> None - | (s, loc, delimiter_length)::rest -> - if !offset = 0 then begin - current_adjust_location := - adjust_location loc delimiter_length !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) - Markup.fn next - in +(** Given the payload of a [%tyxml ...] expression, converts it to a TyXML + expression representing the markup contained therein. *) +let markup_to_expr 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 @@ -210,19 +219,16 @@ let markup_to_expr loc expr = 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 = - input_stream - |> Markup.parse_html + Markup.parse_html ~encoding:Markup.Encoding.utf_8 ~report:(fun loc error -> - let loc = !current_adjust_location loc in + 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 () = - parser |> Markup.location |> !current_adjust_location - in + let get_loc () = adjust_location @@ Markup.location parser in let rec assemble children = match Markup.next signals with From 8d68c53d60256a91289ff25865e2df1ebeb12557 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 02:06:43 +0200 Subject: [PATCH 26/35] Split Ppx_namespace and export some internal bits. --- ppx/ppx_namespace.ml | 15 +++++++++------ ppx/ppx_namespace.mli | 6 ++++++ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ppx/ppx_namespace.ml b/ppx/ppx_namespace.ml index ddfab5b7e..0e151f819 100644 --- a/ppx/ppx_namespace.ml +++ b/ppx/ppx_namespace.ml @@ -17,11 +17,14 @@ * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. *) -let reflect loc = function - | ns when ns = Markup.Ns.html -> - Ppx_common.Html ,(module Html5_sigs_reflected : Ppx_sigs_reflected.S) +let get : Ppx_common.lang -> (module Ppx_sigs_reflected.S) = function + | Html -> (module Html5_sigs_reflected) + | Svg -> (module Svg_sigs_reflected) - | ns when ns = Markup.Ns.svg -> - Ppx_common.Svg, (module Svg_sigs_reflected : Ppx_sigs_reflected.S) +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 - | ns -> 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 index 731cbd754..e70211785 100644 --- a/ppx/ppx_namespace.mli +++ b/ppx/ppx_namespace.mli @@ -27,3 +27,9 @@ val reflect : 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. *) From 295e01e2c914e5e77715303273ce3f6c5a847333 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 02:07:12 +0200 Subject: [PATCH 27/35] Add handling of comments. --- ppx/ppx_element.ml | 7 +++++++ ppx/ppx_element.mli | 7 +++++++ ppx/ppx_tyxml.ml | 16 ++++++++++------ test/test_ppx.ml | 4 ++++ 4 files changed, 28 insertions(+), 6 deletions(-) diff --git a/ppx/ppx_element.ml b/ppx/ppx_element.ml index 4949b633b..b12ab68bb 100644 --- a/ppx/ppx_element.ml +++ b/ppx/ppx_element.ml @@ -37,3 +37,10 @@ let parse ~loc ~name:((ns, name) as element_name) ~attributes children = 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 index 023482f5c..51ad6f36d 100644 --- a/ppx/ppx_element.mli +++ b/ppx/ppx_element.mli @@ -28,3 +28,10 @@ val parse : (** [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_tyxml.ml b/ppx/ppx_tyxml.ml index 26b1a1187..e9bbc1e06 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -230,29 +230,33 @@ let markup_to_expr loc expr = let signals = Markup.signals parser in let get_loc () = adjust_location @@ Markup.location parser in - let rec assemble children = + 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 (node @ children) + 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 [] 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 (node :: children) + assemble lang (node :: children) + + | Some (`Comment s) -> + [Ppx_element.comment ~loc ~lang s] | Some _ -> - assemble children + assemble lang children in - Ppx_common.list loc @@ assemble [] + Ppx_common.list loc @@ assemble Ppx_common.Html [] diff --git a/test/test_ppx.ml b/test/test_ppx.ml index 0afd4267d..faf3d36ea 100644 --- a/test/test_ppx.ml +++ b/test/test_ppx.ml @@ -44,6 +44,10 @@ let basics = "ppx basics", tyxml_tests M.[ [%tyxml "

"], [p ~a:[a_id "foo"; a_class ["bar"] ] []] ; + "comment", + [%tyxml ""], + [tot @@ Xml.comment "foo"] + ] let elt1 = M.(span [pcdata "one"]) From f89faf6908ec2b3904c715e4163bb12c767395c7 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 02:21:01 +0200 Subject: [PATCH 28/35] Make the pattern match complete. --- ppx/ppx_tyxml.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index e9bbc1e06..68711258b 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -252,7 +252,7 @@ let markup_to_expr loc expr = | Some (`Comment s) -> [Ppx_element.comment ~loc ~lang s] - | Some _ -> + | Some (`Xml _ | `Doctype _ | `PI _) -> assemble lang children in From 9dca2fa0ddd628d20219ac7a49dc3763214aafa3 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 19:25:20 +0200 Subject: [PATCH 29/35] Rewrite ppx_reflect's handling of attribute arguments. --- ppx/ppx_reflect.ml | 113 ++++++++++++++++++++++++--------------------- 1 file changed, 61 insertions(+), 52 deletions(-) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index cf74bb3d7..4684e6156 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -37,14 +37,50 @@ 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) -let argument_types t = - let rec scan acc = function - | Ptyp_arrow (_, t, t') -> scan (t::acc) t'.ptyp_desc - | _ -> List.rev acc - in - scan [] t.ptyp_desc +(** 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) +end (* 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]) @@ -251,67 +287,40 @@ let val_item_to_element_info value_description = | 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 + 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 a one or two strings" + "Payload of [@@reflect.element] must be one or two strings" end | None -> - let result_type = - let rec scan = function - | {ptyp_desc = Ptyp_arrow (_, _, t')} -> scan t' - | t -> t - in - scan value_description.pval_type - in - - match result_type with - | [%type : ([%t? _], [%t ? _]) nullary] -> Some "nullary", None - | [%type : ([%t? _], [%t ? _], [%t ? _]) unary] -> Some "unary", None - | [%type : ([%t? _], [%t ? _], [%t ? _]) star] -> Some "star", None - | _ -> None, 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 -> - let labeled_attributes = - let rec scan acc = function - | Ptyp_arrow (label, t, t') -> - - let maybe_attribute_type = - match t with - | [%type : [%t? _] wrap] -> - Some t - - | {ptyp_desc = Ptyp_constr (lid, [[%type : [%t? _] elt wrap]])} - when Longident.last lid.txt = "option" -> - None - - | {ptyp_desc = - Ptyp_constr (lid, [[%type : [%t? _] wrap] as t''])} - when Longident.last lid.txt = "option" -> - Some t'' - | _ -> - None - in - - begin match Ppx_common.Label.explode label, maybe_attribute_type with - | Nolabel, _ | _,None -> scan acc t'.ptyp_desc - | (Labelled label | Optional label), Some t'' -> - let parser = type_to_attribute_parser label [t''] in - scan ((name, label, parser)::acc) t'.ptyp_desc - end - - | _ -> acc + (* 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 = type_to_attribute_parser label [ty] in + (name, label, parser) :: acc in - scan [] value_description.pval_type.ptyp_desc + List.fold_right aux arguments [] in let rename = @@ -340,7 +349,7 @@ let signature_item mapper item = when is_attribute name -> (* Attribute declaration. *) - let argument_types = argument_types type_ in + let argument_types = List.map snd @@ FunTyp.arguments type_ in let attribute_parser_mapping = name, type_to_attribute_parser name argument_types in attribute_parsers := attribute_parser_mapping::!attribute_parsers; From 00bcb622bfee73ea8e72c0da02fe0d6f0e9b3185 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 19:49:22 +0200 Subject: [PATCH 30/35] Use expressions instead of strings in ppx_reflect. It works with string only because we emit a .ml, it wouldn't work if we were giving the generated AST to the compiler ... --- ppx/ppx_reflect.ml | 187 +++++++++++++++++++++------------------------ 1 file changed, 88 insertions(+), 99 deletions(-) diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index 4684e6156..1588c32d6 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -80,143 +80,131 @@ module FunTyp = struct | Nolabel, _ | _, None -> None | (Labelled lab | Optional lab), Some t -> Some (lab, t) -end - -(* 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 type_to_attribute_parser name types = let rec no_constructor_arguments = function | [] -> true | (Rinherit _)::_ | (Rtag (_, _, _, _::_))::_ -> false | (Rtag (_, _, _, []))::more -> no_constructor_arguments more - in - - match types with - | [] -> - "nowrap presence" - | [[%type : character wrap]] -> - "wrap char" - | [[%type : bool wrap]] -> - "wrap bool" - - | [[%type : number wrap]] - | [[%type : pixels wrap]] - | [[%type : int wrap]] -> - "wrap int" +(* 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 : numbers wrap]] -> - "wrap (commas int)" + | [[%type: character]] -> [%expr char] + | [[%type: bool]] -> [%expr bool] - | [[%type : float_number wrap]] - | [[%type : float wrap]] -> - "wrap float" + | [[%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 : float_number option wrap]] -> - "wrap (option \"any\" float)" + | [[%type : numbers_semicolon]] -> + [%expr semicolons float] - | [[%type : numbers_semicolon wrap]] -> - "wrap (semicolons float)" + | [[%type : fourfloats]] -> + [%expr fourfloats] - | [[%type : fourfloats wrap]] -> - "wrap fourfloats" + | [[%type : number_optional_number]] -> + [%expr number_pair] - | [[%type : number_optional_number wrap]] -> - "wrap number_pair" + | [[%type : coords]] -> + [%expr points] - | [[%type : coords wrap]] -> - "wrap points" + | [[%type : (number * number) list option]] -> + [%expr option "any" (spaces icon_size)] - | [[%type : (number * number) list option wrap]] -> - "wrap (option \"any\" (spaces icon_size))" + | [[%type : length]] -> + [%expr length] - | [[%type : length wrap]] -> - "wrap length" + | [[%type : multilengths]] -> + [%expr commas multilength] - | [[%type : multilengths wrap]] -> - "wrap (commas multilength)" + | [[%type : coord]] | [[%type : Unit.length]] -> + [%expr svg_length] - | [[%type : coord wrap]] - | [[%type : Unit.length wrap]] -> - "wrap svg_length" + | [[%type : Unit.length list]] -> + [%expr spaces_or_commas svg_length] - | [[%type : Unit.length list wrap]] -> - "wrap (spaces_or_commas svg_length)" + | [[%type : Unit.angle option]] -> + [%expr option "auto" angle] - | [[%type : Unit.angle option wrap]] -> - "wrap (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 : string wrap]] - | [[%type : text wrap]] - | [[%type : nmtoken wrap]] - | [[%type : idref wrap]] - | [[%type : Xml.uri wrap]] - | [[%type : contenttype wrap]] - | [[%type : languagecode wrap]] - | [[%type : cdata wrap]] - | [[%type : charset wrap]] - | [[%type : frametarget wrap]] - | [[%type : iri wrap]] - | [[%type : color wrap]] - | [[%type : nmtoken]; [%type : text wrap]] -> - "wrap string" + | [[%type: nmtoken]; [%type: text wrap]] -> [%expr wrap string] | [[%type : Xml.event_handler]] | [[%type : Xml.mouse_event_handler]] | [[%type : Xml.keyboard_event_handler]] -> - "nowrap string" + [%expr nowrap string] - | [[%type : string option wrap]] -> - "wrap (option \"\" string)" + | [[%type : string option]] -> + [%expr (option "" string)] - | [[%type : - [%t? {ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] wrap]] + | [{ptyp_desc = Ptyp_variant (_::_::_ as constructors, _, _)}] when no_constructor_arguments constructors -> - "wrap variant" + [%expr variant] - | [[%type : shape wrap]] -> - "wrap variant" + | [[%type : shape]] -> + [%expr variant] - | [[%type : nmtokens wrap]] - | [[%type : idrefs wrap]] - | [[%type : charsets wrap]] - | [[%type : spacestrings wrap]] - | [[%type : strings wrap]] -> - "wrap (spaces string)" + | [[%type : nmtokens]] + | [[%type : idrefs]] + | [[%type : charsets]] + | [[%type : spacestrings]] + | [[%type : strings]] -> + [%expr spaces string] - | [[%type : commastrings wrap]] - | [[%type : text list wrap]] - | [[%type : contenttypes wrap]] -> - "wrap (commas string)" + | [[%type : commastrings]] + | [[%type : text list]] + | [[%type : contenttypes]] -> + [%expr commas string] - | [[%type : linktypes wrap]] -> - "wrap (spaces (total_variant Html5_types_reflected.linktype))" + | [[%type : linktypes]] -> + [%expr spaces (total_variant Html5_types_reflected.linktype)] - | [[%type : mediadesc wrap]] -> - "wrap (commas (total_variant Html5_types_reflected.mediadesc_token))" + | [[%type : mediadesc]] -> + [%expr commas (total_variant Html5_types_reflected.mediadesc_token)] - | [[%type : transform wrap]] -> - "wrap transform" + | [[%type : transform]] -> + [%expr transform] - | [[%type : lengths wrap]] -> - "wrap (spaces_or_commas svg_length)" + | [[%type : lengths]] -> + [%expr spaces_or_commas svg_length] - | [[%type : transforms wrap]] -> - "wrap (spaces_or_commas transform)" + | [[%type : transforms]] -> + [%expr spaces_or_commas transform] - | [[%type : paint wrap]] -> - "wrap paint" + | [[%type : paint]] -> + [%expr paint] - | [[%type : image_candidate list wrap]] -> - "wrap (commas srcset_element)" + | [[%type : image_candidate list]] -> + [%expr commas srcset_element] | _ -> let name = strip_a name in let name = if name = "in" then "in_" else name in - Printf.sprintf "wrap %s" name + 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 @@ -317,7 +305,7 @@ let val_item_to_element_info value_description = let aux x acc = match FunTyp.extract_attribute_argument x with | None -> acc | Some (label, ty) -> - let parser = type_to_attribute_parser label [ty] in + let parser = FunTyp.to_attribute_parser label [ty] in (name, label, parser) :: acc in List.fold_right aux arguments [] @@ -351,7 +339,7 @@ let signature_item mapper item = let argument_types = List.map snd @@ FunTyp.arguments type_ in let attribute_parser_mapping = - name, type_to_attribute_parser name argument_types in + 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 @@ -429,6 +417,7 @@ module Combi = struct 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 @@ -439,11 +428,11 @@ let emit_module () = open Ppx_attribute_value let attribute_parsers = - [%e Combi.(list @@ tuple2 str id) !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 id) !labeled_attributes ] + [%e Combi.(list @@ tuple3 str str expr) !labeled_attributes ] open Ppx_element_content From 1714b35900286099699d2905161a7a277201e3ff Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 22:50:29 +0200 Subject: [PATCH 31/35] Allow to modify the module implementation. --- ppx/ppx_common.ml | 12 +++++++++--- ppx/ppx_common.mli | 1 + 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index 08abaaba7..f4caee6a2 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -24,13 +24,19 @@ module Label = Ast_convenience.Label type lang = Html | Svg -let html5_implementation = "Html5" -let svg_implementation = "Svg" +let html5_implementation = ref "Html5" +let svg_implementation = ref "Svg" -let implementation = function +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" diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 3b6fb8cd4..823b60405 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -28,6 +28,7 @@ module Label = Ast_convenience.Label 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 From 3125fe6b83170b020bbc3541ccc26bc222e90633 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 31 Mar 2016 22:50:50 +0200 Subject: [PATCH 32/35] Allow %html5 and %svg, along with changing the base module. Accepted syntaxes: %tyxml (auto) %(tyxml.)html5(.Mod) %(tyxml.)svg(.Mod) --- ppx/ppx_tyxml.ml | 62 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 55 insertions(+), 7 deletions(-) diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 68711258b..923ea45bd 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -208,7 +208,7 @@ let ast_to_stream expr = (** Given the payload of a [%tyxml ...] expression, converts it to a TyXML expression representing the markup contained therein. *) -let markup_to_expr loc expr = +let markup_to_expr ?context loc expr = let input_stream, adjust_location = ast_to_stream expr in @@ -221,6 +221,7 @@ let markup_to_expr loc expr = 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 @@ -258,19 +259,66 @@ let markup_to_expr loc expr = 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 ({txt = "tyxml"; loc}, payload) -> - begin match payload with - | PStr [{pstr_desc = Pstr_eval (e, _)}] -> - markup_to_expr loc e - | _ -> + | 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 From 9a95ba157458da510cfc0d4e62f72fb4affb6a88 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Fri, 1 Apr 2016 07:58:38 -0500 Subject: [PATCH 33/35] Suppress warnings about topdirs.cmi. Only builds by the "make" command are fixed by this change. --- Makefile | 3 +++ 1 file changed, 3 insertions(+) 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) From 42f98cdf1ba8b42dfd9af1fed9d6b939d7db9394 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Fri, 1 Apr 2016 11:57:20 -0500 Subject: [PATCH 34/35] Remove a_fs_rows and a_fs_cols. TyXML does not have or , so these attributes are pointless. Also removed PPX machinery for handling these attributes' values. --- lib/html5_f.ml | 10 ---------- lib/html5_sigs.mli | 7 ------- lib/html5_types.mli | 4 ---- ppx/ppx_attribute_value.ml | 35 ----------------------------------- ppx/ppx_attribute_value.mli | 8 -------- ppx/ppx_reflect.ml | 3 --- 6 files changed, 67 deletions(-) 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 f5921df4b..75924437f 100644 --- a/lib/html5_sigs.mli +++ b/lib/html5_sigs.mli @@ -592,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 @@ -1129,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 85e1cf97d..4fcdc3da4 100644 --- a/lib/html5_types.mli +++ b/lib/html5_types.mli @@ -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/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index 89c8ab185..62884f0c6 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -279,41 +279,6 @@ let length = Some e -(* This is only called by the commas combinator; hence the error message. *) -let multilength = - let regexp = Re_str.regexp "\\([0-9]+\\)\\(%\\|px\\)\\|\\([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" - name "list of relative lengths, such as 100px, 50%, or *"; - - begin - if group_matched 1 s then - let n = - match int_exp loc (Re_str.matched_group 1 s) with - | Some n -> n - | None -> - Ppx_common.error loc "Value in %s out of range" name - in - - match Re_str.matched_group 2 s with - | "%" -> Some [%expr `Percent [%e n]] - | "px" -> Some [%expr `Pixels [%e n]] - | _ -> Ppx_common.error loc "Internal error: Ppx_attribute.multilength" - - else - let n = - match int_exp loc (Re_str.matched_group 3 s) with - | exception Not_found -> [%expr 1] - | Some n -> n - | None -> - Ppx_common.error loc "Relative length in %s out of range" name - in - - Some [%expr `Relative [%e n]] - end [@metaloc loc] - let svg_quantity = let integer = "[+-]?[0-9]+" in let integer_scientific = Printf.sprintf "%s\\([Ee]%s\\)?" integer integer in diff --git a/ppx/ppx_attribute_value.mli b/ppx/ppx_attribute_value.mli index 97638eb0c..57deb70fa 100644 --- a/ppx/ppx_attribute_value.mli +++ b/ppx/ppx_attribute_value.mli @@ -141,14 +141,6 @@ val length : parser - [`Pixels i] if [s] has form [(string_of_int i) ^ "px"], or - [`Percent i] if [s] has form [(string_of_int i) ^ "%"]. *) -val multilength : parser -(** [multilength _ _ s] produces a parse tree for - - - [`Pixels i] if [s] has form [(string_of_int i) ^ "px"], - - [`Percent i] if [s] has form [(string_of_int i) ^ "%"], - - [`Relative i] if [s] has form [(string_of_int i) ^ "*"], or - - [`Relative 1] if [s] is ["*"]. *) - 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 diff --git a/ppx/ppx_reflect.ml b/ppx/ppx_reflect.ml index 1588c32d6..25ab6877f 100644 --- a/ppx/ppx_reflect.ml +++ b/ppx/ppx_reflect.ml @@ -124,9 +124,6 @@ let rec to_attribute_parser name = function | [[%type : length]] -> [%expr length] - | [[%type : multilengths]] -> - [%expr commas multilength] - | [[%type : coord]] | [[%type : Unit.length]] -> [%expr svg_length] From 04c40fb0a528f773a3a7edc63326978835625466 Mon Sep 17 00:00:00 2001 From: Drup Date: Sat, 2 Apr 2016 00:37:36 +0200 Subject: [PATCH 35/35] Adapt ppx test to module renamings. --- test/test_ppx.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/test/test_ppx.ml b/test/test_ppx.ml index faf3d36ea..f3873f965 100644 --- a/test/test_ppx.ml +++ b/test/test_ppx.ml @@ -4,12 +4,12 @@ html or svg should go to the other files. *) -open Html5 - module TyTests = struct type t = Xml.elt list let pp fmt x = - P.print_list ~output:(Format.pp_print_string fmt) (M.totl x) + Format.pp_print_list ~pp_sep:(fun _ () -> ()) + (Html5.pp_elt ()) + fmt (Html5.totl x) let equal = (=) end @@ -17,12 +17,11 @@ end let tyxml_tests l = let f (name, ty1, ty2) = name, `Quick, fun () -> - Alcotest.(check (module TyTests)) name (M.toeltl ty1) (M.toeltl ty2) + Alcotest.(check (module TyTests)) name (Html5.toeltl ty1) (Html5.toeltl ty2) in List.map f l -module Html5 = M -let basics = "ppx basics", tyxml_tests M.[ +let basics = "ppx basics", tyxml_tests Html5.[ "elems", [%tyxml "

"], @@ -50,11 +49,11 @@ let basics = "ppx basics", tyxml_tests M.[ ] -let elt1 = M.(span [pcdata "one"]) -let elt2 = M.(b [pcdata "two"]) +let elt1 = Html5.(span [pcdata "one"]) +let elt2 = Html5.(b [pcdata "two"]) let id = "pata" -let antiquot = "ppx antiquot", tyxml_tests M.[ +let antiquot = "ppx antiquot", tyxml_tests Html5.[ "child", [%tyxml "

" elt1 "

"],