diff --git a/_oasis b/_oasis index 9885c9cbf..2246d25c8 100644 --- a/_oasis +++ b/_oasis @@ -15,6 +15,7 @@ License: LGPL-2.1 with OCaml linking exception Plugins: META (0.3), DevFiles (0.3) BuildTools: ocamlbuild AlphaFeatures: pure_interface +OCamlVersion: >= 4.02.0 Synopsis: Statically correct HTML and SVG documents @@ -182,10 +183,12 @@ Test html TestTools: main_test Run$: flag(tests) && flag(ppx) -Test html_fail - Command: ocamlbuild test/html_fail.stamp - TestTools: main_test - Run$: flag(tests) && flag(ppx) +## This test is disabled as it can't run on both 4.03 and 4.02 +## Curent oasis doesn't allow to restrict the version just for this test. +# Test html_fail +# Command: ocamlbuild -use-ocamlfind test/html_fail.stamp +# TestTools: main_test +# Run$: flag(tests) && flag(ppx) ## Examples diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 7a9038162..21aaeb47f 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -19,7 +19,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) - +[@@@ocaml.warning "-3"] (* OASIS_START *) (* OASIS_STOP *) # 26 "myocamlbuild.ml" diff --git a/opam b/opam index 449c59171..b2ee06e88 100644 --- a/opam +++ b/opam @@ -42,6 +42,9 @@ depopts: [ "markup" "ppx_tools" ] +conflicts: [ + "ppx_tools" { < "5.0" } +] available: ocaml-version >= "4.02" messages: [ "For tyxml's ppx, please install markup and ppx_tools." diff --git a/ppx/ppx_attribute_value.ml b/ppx/ppx_attribute_value.ml index c90c326a9..27ec5ab67 100644 --- a/ppx/ppx_attribute_value.ml +++ b/ppx/ppx_attribute_value.ml @@ -17,7 +17,6 @@ * Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA. *) -open Asttypes open Ast_helper module Pc = Ppx_common @@ -134,12 +133,12 @@ let group_matched index s = let int_exp loc s = try Some (Ppx_common.int loc (int_of_string s)) - with Failure "int_of_string" -> None + with Failure _ -> None let float_exp loc s = try Some (Ppx_common.float loc @@ float_of_string s) - with Failure "float_of_string" -> + with Failure _ -> None let bool_exp loc b = @@ -161,10 +160,9 @@ let char ?separated_by:_ ?default:_ loc name s = 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 + | Some i when i <= 255 -> Char.chr i + | Some _ -> + Ppx_common.error loc "Character out of range in attribute %s" name in begin match next decoded with @@ -172,7 +170,7 @@ let char ?separated_by:_ ?default:_ loc name s = | Some _ -> Ppx_common.error loc "Multiple characters in attribute %s" name end; - Some (Exp.constant ~loc (Const_char c)) + Some (with_default_loc loc @@ fun () -> Ast_convenience.char c) let onoff ?separated_by:_ ?default:_ loc name s = let b = match s with @@ -256,7 +254,7 @@ let icon_size = try int_of_string (Re_str.matched_group 1 s), int_of_string (Re_str.matched_group 2 s) - with Invalid_argument "int_of_string" -> + with Invalid_argument _ -> Ppx_common.error loc "Icon dimension out of range in %s" name in @@ -417,7 +415,7 @@ let transform = (* String-like. *) let string ?separated_by:_ ?default:_ loc _ s = - Some (Exp.constant ~loc (Const_string (s, None))) + Some (with_default_loc loc @@ fun () -> Ast_convenience.str s) let variand s = let without_backtick s = diff --git a/ppx/ppx_attributes.ml b/ppx/ppx_attributes.ml index 6abd73929..1664a71d4 100644 --- a/ppx/ppx_attributes.ml +++ b/ppx/ppx_attributes.ml @@ -65,7 +65,7 @@ let parse loc (ns, element_name) attributes = | Some e -> e in - (label, e)::labeled, regular + (Ppx_common.Label.labelled label, e)::labeled, regular | None -> (* The attribute is not individually labeled, so it is passed in ~a. @@ -135,5 +135,8 @@ 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 loc (List.rev regular) in + let regular = + Ppx_common.Label.labelled "a", + Ppx_common.list loc (List.rev regular) + in List.rev (regular::labeled) diff --git a/ppx/ppx_attributes.mli b/ppx/ppx_attributes.mli index 5d1cd2d8b..5c1f03854 100644 --- a/ppx/ppx_attributes.mli +++ b/ppx/ppx_attributes.mli @@ -23,7 +23,7 @@ val parse : Location.t -> Markup.name -> (Markup.name * string Ppx_common.value) list -> - (Asttypes.label * Parsetree.expression) list + (Ppx_common.Label.t * 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 diff --git a/ppx/ppx_common.ml b/ppx/ppx_common.ml index fbd802725..d31b3268f 100644 --- a/ppx/ppx_common.ml +++ b/ppx/ppx_common.ml @@ -57,7 +57,17 @@ let find f l = let with_loc loc f x = with_default_loc loc @@ fun () -> f x -let error loc fmt = Location.raise_errorf ~loc ("Error: "^^fmt) + +let error_prefix : _ format6 = "Error: " +(* We use a custom implementation because the type of Location.raise_errorf + changed in 4.03 *) +let error loc ppf = + let buf = Buffer.create 17 in + let fmt = Format.formatter_of_buffer buf in + Format.kfprintf + (fun _ -> Location.raise_errorf ~loc "%s" (Buffer.contents buf)) + fmt + (error_prefix^^ppf) (** Ast manipulation *) diff --git a/ppx/ppx_common.mli b/ppx/ppx_common.mli index 721824cd7..59c1074f1 100644 --- a/ppx/ppx_common.mli +++ b/ppx/ppx_common.mli @@ -62,5 +62,4 @@ val list_wrap_value : lang -> Location.t -> Parsetree.expression value list -> Parsetree.expression -val error : Location.t -> ('b, unit, string, 'a) format4 -> 'b -(** Raises an error using compiler module [Location]. *) +val error : Location.t -> ('b, Format.formatter, unit, 'a) format4 -> 'b diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml index af24f6026..de1b1ffef 100644 --- a/ppx/ppx_element_content.ml +++ b/ppx/ppx_element_content.ml @@ -127,7 +127,7 @@ let figure ~lang ~loc ~name children = | [] -> star ~lang ~loc ~name children | first::others -> if is_element_with_name (html "figcaption") first then - ("figcaption", + (Pc.Label.labelled "figcaption", [%expr `Top [%e Pc.wrap_value lang loc first]]):: (star ~lang ~loc ~name others) else @@ -135,7 +135,7 @@ let figure ~lang ~loc ~name children = let last = List.hd children_reversed in if is_element_with_name (html "figcaption") last then let others = List.rev (List.tl children_reversed) in - ("figcaption", + (Pc.Label.labelled "figcaption", [%expr `Bottom [%e Pc.wrap_value lang loc last]]):: (star ~lang ~loc ~name others) else @@ -146,7 +146,8 @@ let object_ ~lang ~loc ~name children = let params, others = partition (html "param") children in if params <> [] then - ("params", Pc.list_wrap_value lang loc params) :: star ~lang ~loc ~name others + (Pc.Label.labelled "params", Pc.list_wrap_value lang loc params) :: + star ~lang ~loc ~name others else star ~lang ~loc ~name others @@ -154,7 +155,8 @@ let audio_video ~lang ~loc ~name children = let sources, others = partition (html "source") children in if sources <> [] then - ("srcs", Pc.list_wrap_value lang loc sources) :: star ~lang ~loc ~name others + (Pc.Label.labelled "srcs", Pc.list_wrap_value lang loc sources) :: + star ~lang ~loc ~name others else star ~lang ~loc ~name others @@ -166,13 +168,13 @@ let table ~lang ~loc ~name children = let one label = function | [] -> [] - | [child] -> [label, Pc.wrap_value lang loc child] + | [child] -> [Pc.Label.labelled label, Pc.wrap_value lang loc child] | _ -> Pc.error loc "%s cannot have more than one %s" name label in let columns = if columns = [] then [] - else ["columns", Pc.list_wrap_value lang loc columns] + else [Pc.Label.labelled "columns", Pc.list_wrap_value lang loc columns] in (one "caption" caption) @ @@ -187,7 +189,7 @@ let fieldset ~lang ~loc ~name children = match legend with | [] -> star ~lang ~loc ~name others | [legend] -> - ("legend", Pc.wrap_value lang loc legend):: + (Pc.Label.labelled "legend", Pc.wrap_value lang loc legend):: (star ~lang ~loc ~name others) | _ -> Pc.error loc "%s cannot have more than one legend" name @@ -197,11 +199,11 @@ let datalist ~lang ~loc ~name children = let children = begin match others with | [] -> - "children", + Pc.Label.labelled "children", [%expr `Options [%e Pc.list_wrap_value lang loc options]] | _ -> - "children", + Pc.Label.labelled "children", [%expr `Phras [%e Pc.list_wrap_value lang loc children]] end [@metaloc loc] in @@ -219,7 +221,7 @@ let details ~lang ~loc ~name children = let menu ~lang ~loc ~name children = let children = - "child", + Pc.Label.labelled "child", [%expr `Flows [%e Pc.list_wrap_value lang loc children]] [@metaloc loc] in diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml index 7db154842..da9d65868 100644 --- a/ppx/ppx_tyxml.ml +++ b/ppx/ppx_tyxml.ml @@ -246,11 +246,10 @@ let ast_to_stream expr = 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)) -> + match Ast_convenience.get_str_with_quotation_delimiter expr with + | Some (s, delimiter) -> (s, Loc.string_start delimiter expr.pexp_loc) - | _ -> + | None -> (Antiquot.create expr, expr.pexp_loc.loc_start) in diff --git a/setup.ml b/setup.ml index eaa59da10..dce67d248 100644 --- a/setup.ml +++ b/setup.ml @@ -1,5 +1,6 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) +[@@@ocaml.warning "-3"] (* OASIS_START *) (* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) (******************************************************************************) diff --git a/test/html_fail.expected b/test/html_fail.expected index a8dbb787f..ca67a3077 100644 --- a/test/html_fail.expected +++ b/test/html_fail.expected @@ -7,7 +7,7 @@ Error: This expression has type but an expression was expected of type ([< Html_types.div_content_fun ] as 'd) Tyxml.Html.elt = 'd Tyxml_html.elt - Type 'a is not compatible with type + Type [> `A of 'b ] as 'a is not compatible with type 'd = [< `A of Html_types.flow5_without_interactive | `Abbr @@ -92,7 +92,7 @@ Error: This expression has type | `Video of Html_types.flow5_without_media | `Video_interactive of Html_types.flow5_without_media | `Wbr ] - Type 'b is not compatible with type + Type [> `A of 'c ] as 'b is not compatible with type Html_types.flow5_without_interactive = [ `Abbr | `Address