Merge pull request #78 from ocaml-ppx/408

Add support for 4.08

.travis.yml

@@ -11,3 +11,4 @@ env:
   - PACKAGE="ppxlib" OCAML_VERSION="4.04.2"
   - PACKAGE="ppxlib" OCAML_VERSION="4.05.0"
   - PACKAGE="ppxlib" OCAML_VERSION="4.06.0"
+  - PACKAGE="ppxlib" OCAML_VERSION="4.07.1"

appveyor.yml

@@ -19,6 +19,10 @@ environment:
     PACKAGE: ppxlib
   - OPAM_SWITCH: 4.06.0+mingw32c
     PACKAGE: ppxlib
+  - OPAM_SWITCH: 4.07.1+mingw64c
+    PACKAGE: ppxlib
+  - OPAM_SWITCH: 4.07.1+mingw32c
+    PACKAGE: ppxlib
 install:
 - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1"))
 build_script:

ast/dune

@@ -10,6 +10,7 @@
  (modules
   ast_helper
   ast
+  clflags_helper
   docstrings
   import
   lexer
@@ -28,7 +29,7 @@
 ;; This is to make the code compatible with different versions of
 ;; OCaml
 (rule
- (targets location_helper.ml)
+ (targets location_helper.ml clflags_helper.ml)
  (deps    gen-compiler_specifics)
  (action  (run %{ocaml} %{deps} %{ocaml_version} %{targets})))
 

ast/gen-compiler_specifics

@@ -2,14 +2,38 @@
 
 open Printf
 
+let with_file path ~f =
+  let oc = open_out_bin path in
+  let pr fmt = fprintf oc (fmt ^^ "\n") in
+  f pr;
+  close_out oc
+
 let () =
   let ver = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> a, b) in
-  let oc = open_out_bin Sys.argv.(2) in
-  let pr fmt = fprintf oc (fmt ^^ "\n") in
-  pr "module O = Ocaml_common";
-  if ver < (4, 06) then
-    output_string oc {|
+  with_file Sys.argv.(2) ~f:(fun pr -> (* location_helper *)
+    if ver < (4, 06) then
+      pr {|
 let deprecated loc s =
   Ocaml_common.Location.prerr_warning loc (Ocaml_common.Warnings.Deprecated s)
 |};
-  close_out oc
+    if ver < (4, 08) then begin
+      pr {|
+let print_error ppf loc = Ocaml_common.Location.print_error ppf loc
+let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer loc x y
+|};
+    end else begin
+      pr {|
+let print_error ppf loc = Format.fprintf ppf "%%aError:" Ocaml_common.Location.print_loc loc
+let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer ~loc x y
+|};
+    end);
+  with_file Sys.argv.(3) ~f:(fun pr -> (* clflags_helper *)
+    if ver < (4, 08) then begin
+      pr {|
+let is_unsafe () = !Ocaml_common.Clflags.fast[@ocaml.warning "-3"]
+|};
+    end else begin
+      pr {|
+let is_unsafe () = !Ocaml_common.Clflags.unsafe[@ocaml.warning "-3"]
+|};
+    end)

ast/import.ml

@@ -107,8 +107,12 @@ module Location   = struct
   include Location_helper
 end
 
+module Clflags    = struct
+  include Ocaml_common.Clflags
+  include Clflags_helper
+end
+
 (* Modules imported directly from the compiler *)
-module Clflags    = Ocaml_common.Clflags
 module Longident  = Ocaml_common.Longident
 module Misc       = Ocaml_common.Misc
 module Warnings   = Ocaml_common.Warnings

ast/lexer.mll

@@ -297,7 +297,7 @@ let () =
   Location.register_error_of_exn
     (function
       | Error (err, loc) ->
-          Some (Location.error_of_printer loc report_error err)
+          Some (Location.error_of_printer ~loc report_error err)
       | _ ->
           None
     )

ast/parser0.mly

@@ -151,7 +151,7 @@ let mkpat_opt_constraint p = function
   | Some typ -> mkpat (Ppat_constraint(p, typ))
 
 let array_function str name =
-  ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
+  ghloc (Ldot(Lident str, (if Clflags.is_unsafe () then "unsafe_" ^ name else name)))
 
 let syntax_error () =
   raise Syntaxerr.Escape_error
@@ -174,7 +174,7 @@ let bigarray_untuplify = function
   | exp -> [exp]
 
 let bigarray_get arr arg =
-  let get = if !Clflags.fast then "unsafe_get" else "get" in
+  let get = if Clflags.is_unsafe () then "unsafe_get" else "get" in
   match bigarray_untuplify arg with
     [c1] ->
       mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
@@ -190,7 +190,7 @@ let bigarray_get arr arg =
                        [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
 
 let bigarray_set arr arg newval =
-  let set = if !Clflags.fast then "unsafe_set" else "set" in
+  let set = if Clflags.is_unsafe () then "unsafe_set" else "set" in
   match bigarray_untuplify arg with
     [c1] ->
       mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),

ast/syntaxerr.ml

@@ -30,38 +30,37 @@ type error =
 exception Error of error
 exception Escape_error
 
+let make_error ~loc ?(sub = []) msg =
+  Selected_ast.Ast.Ast_mapper.make_error_of_message ~loc msg ~sub
+
 let prepare_error = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf ~loc:closing_loc
-        ~sub:[
-          Location.errorf ~loc:opening_loc
-            "This '%s' might be unmatched" opening
-        ]
-        ~if_highlight:
-          (Printf.sprintf "Syntax error: '%s' expected, \
-                           the highlighted '%s' might be unmatched"
-             closing opening)
-        "Syntax error: '%s' expected" closing
-
+    make_error
+      ~loc:closing_loc
+      ~sub:[
+        opening_loc, (Printf.sprintf
+          "This '%s' might be unmatched" opening)
+      ]
+      (Printf.sprintf "Syntax error: '%s' expected" closing)
   | Expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s expected." nonterm
+      make_error ~loc (Printf.sprintf "Syntax error: %s expected." nonterm)
   | Not_expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+      make_error ~loc (Printf.sprintf "Syntax error: %s not expected." nonterm)
   | Applicative_path loc ->
-      Location.errorf ~loc
+      make_error ~loc
         "Syntax error: applicative paths of the form F(X).t \
          are not supported when the option -no-app-func is set."
   | Variable_in_scope (loc, var) ->
-      Location.errorf ~loc
-        "In this scoped type, variable '%s \
+      make_error ~loc
+        (Printf.sprintf "In this scoped type, variable '%s \
          is reserved for the local type %s."
-         var var
+         var var)
   | Other loc ->
-      Location.errorf ~loc "Syntax error"
+      make_error ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
-      Location.errorf ~loc "broken invariant in parsetree: %s" s
+      make_error ~loc (Printf.sprintf "broken invariant in parsetree: %s" s)
   | Invalid_package_type (loc, s) ->
-      Location.errorf ~loc "invalid package type: %s" s
+      make_error ~loc (Printf.sprintf "invalid package type: %s" s)
 
 let () =
   Location.register_error_of_exn
@@ -72,7 +71,7 @@ let () =
 
 
 let report_error ppf err =
-  Location.report_error ppf (prepare_error err)
+  Selected_ast.Ast.Ast_mapper.print_error ppf (prepare_error err)
 
 let location_of_error = function
   | Unclosed(l,_,_,_)

dune

@@ -0,0 +1,3 @@
+(env
+  (dev
+    (flags (:standard -w -66))))

ppxlib.opam

@@ -18,7 +18,7 @@ depends: [
   "base"                    {>= "v0.11.0"}
   "dune"                    {build}
   "ocaml-compiler-libs"     {>= "v0.11.0"}
-  "ocaml-migrate-parsetree" {>= "1.0.9"}
+  "ocaml-migrate-parsetree" {>= "1.3.1"}
   "ppx_derivers"            {>= "1.0"}
   "stdio"                   {>= "v0.11.0"}
   "ocamlfind"               {with-test}

src/driver.ml

@@ -440,7 +440,7 @@ let as_ppx_config () =
   Migrate_parsetree.Driver.make_config ()
     ~tool_name:(Ocaml_common.Ast_mapper.tool_name ())
     ~include_dirs:!Ocaml_common.Clflags.include_dirs
-    ~load_path:!Ocaml_common.Config.load_path
+    ~load_path:(Compiler_specifics.get_load_path ())
     ~debug:!Ocaml_common.Clflags.debug
     ?for_package:!Ocaml_common.Clflags.for_package
 
@@ -601,16 +601,20 @@ let string_contains_binary_ast s =
 type pp_error = { filename : string; command_line : string }
 exception Pp_error of pp_error
 
-let report_pp_error ppf e =
+let report_pp_error e =
+  let buff = Buffer.create 128 in
+  let ppf = Caml.Format.formatter_of_buffer buff in
   Caml.Format.fprintf ppf "Error while running external preprocessor@.\
-                           Command line: %s@." e.command_line
+                           Command line: %s@." e.command_line;
+  Caml.Format.pp_print_flush ppf ();
+  Buffer.contents buff
 
 let () =
   Location.Error.register_error_of_exn
     (function
       | Pp_error e ->
-        Some (Location.Error.createf ~loc:(Location.in_file e.filename) "%a"
-                report_pp_error e)
+        Some (Location.Error.make ~loc:(Location.in_file e.filename) ~sub:[]
+                (report_pp_error e))
       | _ -> None)
 
 let remove_no_error fn =

src/gen-compiler_specifics

@@ -7,13 +7,8 @@ let () =
   let oc = open_out_bin Sys.argv.(2) in
   let pr fmt = fprintf oc (fmt ^^ "\n") in
   pr "module O = Ocaml_common";
-  if ver < (4, 06) then
-    pr "let error_of_exn = O.Location.error_of_exn"
+  if ver < (4, 08) then
+    pr "let get_load_path () = !Ocaml_common.Config.load_path"
   else
-    pr "\
-let error_of_exn exn =
-  match O.Location.error_of_exn exn with
-  | None -> None
-  | Some `Already_displayed -> None
-  | Some (`Ok t) -> Some t";
+    pr "let get_load_path () = Ocaml_common.Load_path.get_paths ()";
   close_out oc

src/location.ml

@@ -45,36 +45,23 @@ type nonrec 'a loc = 'a loc =
   }
 
 module Error = struct
-  type t = L.error
-
-  let createf ~loc fmt = L.errorf ~loc fmt
-
-  let message (t : t) = t.msg
-  let set_message (t : t) msg = { t with msg }
-
-  let register_error_of_exn = L.register_error_of_exn
-
-  let of_exn = Compiler_specifics.error_of_exn
-
-  let rec to_extension (t : t) =
-    let loc = t.loc in
-    let str s =
-      { pstr_loc  = loc
-      ; pstr_desc =
-          Pstr_eval
-            ({ pexp_loc = loc
-             ; pexp_attributes = []
-             ; pexp_desc = Pexp_constant (Pconst_string (s, None))
-             }, [])
-      }
-    in
-    ({ loc = t.loc; txt = "ocaml.error" },
-     PStr (str t.msg          ::
-           str t.if_highlight ::
-           List.map t.sub ~f:(fun t ->
-             { pstr_loc = loc
-             ; pstr_desc = Pstr_extension (to_extension t, [])
-             })))
+  module Helpers = Selected_ast.Ast.Ast_mapper
+
+  type t = Helpers.location_error
+
+  let make = Helpers.make_error_of_message
+  let createf ~loc fmt =
+    Printf.ksprintf
+      (fun str -> Helpers.make_error_of_message ~loc ~sub:[] str) fmt
+
+  let message = Helpers.get_error_message
+  let set_message = Helpers.set_error_message
+
+  let register_error_of_exn = Helpers.register_error_of_exn
+
+  let of_exn = Helpers.error_of_exn
+
+  let to_extension = Helpers.extension_of_error
 end
 
 exception Error of Error.t

src/location.mli

@@ -37,9 +37,10 @@ type nonrec 'a loc = 'a loc =
 
 module Error : sig
   type location = t
-  type t = Ocaml_common.Location.error
+  type t
 
-  val createf : loc:location -> ('a, Caml.Format.formatter, unit, t) format4 -> 'a
+  val make : loc:location -> string -> sub:(location * string) list -> t
+  val createf : loc:location -> ('a, unit, string, t) format4 -> 'a
 
   val message : t -> string
   val set_message : t -> string -> t