diff --git a/.travis.yml b/.travis.yml index aa11715e5..0185fcd42 100644 --- a/.travis.yml +++ b/.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" diff --git a/appveyor.yml b/appveyor.yml index 1562bb49f..6703fea04 100644 --- a/appveyor.yml +++ b/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: diff --git a/ast/dune b/ast/dune index 97a9ce5b6..1ed8f935a 100644 --- a/ast/dune +++ b/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}))) diff --git a/ast/gen-compiler_specifics b/ast/gen-compiler_specifics index 88d875a80..9aa5251c2 100644 --- a/ast/gen-compiler_specifics +++ b/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) diff --git a/ast/import.ml b/ast/import.ml index 4bce801e7..d979268f9 100644 --- a/ast/import.ml +++ b/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 diff --git a/ast/lexer.mll b/ast/lexer.mll index b0df67715..741779fc6 100644 --- a/ast/lexer.mll +++ b/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 ) diff --git a/ast/parser0.mly b/ast/parser0.mly index 82450088a..0fd47326f 100644 --- a/ast/parser0.mly +++ b/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)), diff --git a/ast/syntaxerr.ml b/ast/syntaxerr.ml index 0f68bae6b..85cf1d804 100644 --- a/ast/syntaxerr.ml +++ b/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,_,_,_) diff --git a/dune b/dune new file mode 100644 index 000000000..b2f6eaac1 --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +(env + (dev + (flags (:standard -w -66)))) diff --git a/ppxlib.opam b/ppxlib.opam index 2c592c743..16404ca60 100644 --- a/ppxlib.opam +++ b/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} diff --git a/src/driver.ml b/src/driver.ml index c06618763..2916f16f0 100644 --- a/src/driver.ml +++ b/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 = diff --git a/src/gen-compiler_specifics b/src/gen-compiler_specifics index f8c68ebf6..e28fd3fc5 100644 --- a/src/gen-compiler_specifics +++ b/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 diff --git a/src/location.ml b/src/location.ml index bbecce8e3..698a0bd0f 100644 --- a/src/location.ml +++ b/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 diff --git a/src/location.mli b/src/location.mli index 36c799471..485e5f236 100644 --- a/src/location.mli +++ b/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