Merge pull request #105 from ocsigen/4.03

Restore compatibility with 4.03

Author: Drup

_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
 

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"

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."

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,18 +160,17 @@ 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
   | None -> ()
   | 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 =

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)

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

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 *)
 

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

ppx/ppx_element_content.ml

@@ -127,15 +127,15 @@ 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
       let children_reversed = List.rev children in
       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,15 +146,17 @@ 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
 
 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

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