From 27a299437dd1d0cbf3606d23350d26f103563d91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Sun, 26 Feb 2017 21:28:30 +0000 Subject: [PATCH] 4.02.3 compatiblity --- jbuilder.opam | 2 +- src/build.ml | 6 ++- src/build.mli | 6 ++- src/build_system.ml | 10 ++++- src/context.ml | 22 ++++++--- src/context.mli | 8 +++- src/future.ml | 2 +- src/glob_lexer.mli | 2 + src/glob_lexer.mll | 4 +- src/import.ml | 15 ++++--- src/install.ml | 26 +++++------ src/jbuild_load.ml | 10 +++-- src/jbuild_types.ml | 85 ++++++++++++++++++----------------- src/lib.ml | 4 +- src/mode.ml | 6 +-- src/sexp.ml | 33 ++++++++------ src/sexp.mli | 13 +++--- src/workspace.ml | 2 +- vendor/cmdliner/src/result.ml | 5 ++- 19 files changed, 157 insertions(+), 104 deletions(-) diff --git a/jbuilder.opam b/jbuilder.opam index 218eed8a..86df07c3 100644 --- a/jbuilder.opam +++ b/jbuilder.opam @@ -10,7 +10,7 @@ build: [ ["ocaml" "bootstrap.ml"] ["./boot.exe" "-j" jobs] ] -available: [ ocaml-version >= "4.03.0" ] +available: [ ocaml-version >= "4.02.3" ] descr: " Fast, portable and opinionated build system diff --git a/src/build.ml b/src/build.ml index 0c5a9e0c..6b2d6c72 100644 --- a/src/build.ml +++ b/src/build.ml @@ -18,9 +18,13 @@ type lib_dep_kind = type lib_deps = lib_dep_kind String_map.t module Repr = struct + type ('a, 'b) prim = + { targets : Path.t list + ; exec : 'a -> 'b Future.t + } type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t - | Prim : { targets : Path.t list; exec : 'a -> 'b Future.t } -> ('a, 'b) t + | Prim : ('a, 'b) prim -> ('a, 'b) t | Store_vfile : 'a Vspec.t -> ('a, unit) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t diff --git a/src/build.mli b/src/build.mli index 14676af5..464e9b6a 100644 --- a/src/build.mli +++ b/src/build.mli @@ -103,9 +103,13 @@ type lib_deps = lib_dep_kind String_map.t module Repr : sig + type ('a, 'b) prim = + { targets : Path.t list + ; exec : 'a -> 'b Future.t + } type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t - | Prim : { targets : Path.t list; exec : 'a -> 'b Future.t } -> ('a, 'b) t + | Prim : ('a, 'b) prim -> ('a, 'b) t | Store_vfile : 'a Vspec.t -> ('a, unit) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t diff --git a/src/build_system.ml b/src/build_system.ml index f2b7fc55..229ca746 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -6,10 +6,16 @@ module Pmap = Path.Map module Vspec = Build.Vspec module Exec_status = struct + module Starting = struct + type t = { for_file : Path.t } + end + module Running = struct + type t = { for_file : Path.t; future : unit Future.t } + end type t = | Not_started of (targeting:Path.t -> unit Future.t) - | Starting of { for_file : Path.t } - | Running of { for_file : Path.t; future : unit Future.t } + | Starting of Starting.t + | Running of Running.t end module Rule = struct diff --git a/src/context.ml b/src/context.ml index 6836bb64..40cbc94a 100644 --- a/src/context.ml +++ b/src/context.ml @@ -2,7 +2,13 @@ open Import open Future module Kind = struct - type t = Default | Opam of { root : string; switch : string } + module Opam = struct + type t = + { root : string + ; switch : string + } + end + type t = Default | Opam of Opam.t end type t = @@ -152,13 +158,17 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin = | Error (key, _, _) -> die "variable %S present twice in the output of `%s`" key ocamlc_config_cmd in - let get var = + let get ?default var = match String_map.find var ocamlc_config with - | None -> die "variable %S not found in the output of `%s`" var ocamlc_config_cmd | Some s -> s + | None -> + match default with + | Some x -> x + | None -> + die "variable %S not found in the output of `%s`" var ocamlc_config_cmd in - let get_bool var = - match get var with + let get_bool ?default var = + match get ?default:(Option.map default ~f:string_of_bool) var with | "true" -> true | "false" -> false | _ -> die "variable %S is neither 'true' neither 'false' in the output of `%s`" @@ -210,7 +220,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin = ; default_executable_name = get "default_executable_name" ; host = get "host" ; target = get "target" - ; flambda = get_bool "flambda" + ; flambda = get_bool "flambda" ~default:false ; exec_magic_number = get "exec_magic_number" ; cmi_magic_number = get "cmi_magic_number" ; cmo_magic_number = get "cmo_magic_number" diff --git a/src/context.mli b/src/context.mli index 3dcc3ffd..7c2bd5fd 100644 --- a/src/context.mli +++ b/src/context.mli @@ -21,7 +21,13 @@ open! Import module Kind : sig - type t = Default | Opam of { root : string; switch : string } + module Opam : sig + type t = + { root : string + ; switch : string + } + end + type t = Default | Opam of Opam.t end type t = diff --git a/src/future.ml b/src/future.ml index e5e7b188..39518871 100644 --- a/src/future.ml +++ b/src/future.ml @@ -313,7 +313,7 @@ module Scheduler = struct in match finished with | [] -> - Unix.sleepf 0.001; + ignore (Unix.select [] [] [] 0.001); wait_win32 () | _ -> List.iter finished ~f:(fun (job, status) -> diff --git a/src/glob_lexer.mli b/src/glob_lexer.mli index 10a9e13c..066db21e 100644 --- a/src/glob_lexer.mli +++ b/src/glob_lexer.mli @@ -1 +1,3 @@ +open Import + val parse_string : string -> (Jbuilder_re.Re.t, int * string) result diff --git a/src/glob_lexer.mll b/src/glob_lexer.mll index 757015a8..174d6f19 100644 --- a/src/glob_lexer.mll +++ b/src/glob_lexer.mll @@ -60,8 +60,8 @@ and char_set st = parse let parse_string s = let lb = Lexing.from_string s in match initial lb with - | re -> Ok re + | re -> Import.Ok re | exception Failure msg -> - Error (Lexing.lexeme_start lb, msg) + Import.Error (Lexing.lexeme_start lb, msg) } diff --git a/src/import.ml b/src/import.ml index 473dd2ca..8902b9d4 100644 --- a/src/import.ml +++ b/src/import.ml @@ -16,14 +16,16 @@ let ksprintf = Printf.ksprintf exception Code_error of string let code_errorf fmt = ksprintf (fun msg -> raise (Code_error msg)) fmt +type ('a, 'b) result = + | Ok of 'a + | Error of 'b + type ('a, 'b) either = | Inl of 'a | Inr of 'b module List = struct - type 'a t = 'a list = - | [] - | ( :: ) of 'a * 'a t + type 'a t = 'a list include ListLabels @@ -193,8 +195,11 @@ module String = struct len >= suffix_len && sub s ~pos:(len - suffix_len) ~len:suffix_len = suffix - let capitalize_ascii = String.capitalize_ascii - let uncapitalize_ascii = String.uncapitalize_ascii + include struct + [@@@warning "-3"] + let capitalize_ascii = String.capitalize + let uncapitalize_ascii = String.uncapitalize + end let split_words s = let rec skip_blanks i = diff --git a/src/install.ml b/src/install.ml index af75c92a..ee8b437c 100644 --- a/src/install.ml +++ b/src/install.ml @@ -33,19 +33,19 @@ module Section = struct let t = let open Sexp.Of_sexp in - sum - [ cstr "lib" [] Lib - ; cstr "libexec" [] Libexec - ; cstr "bin" [] Bin - ; cstr "sbin" [] Sbin - ; cstr "toplevel" [] Toplevel - ; cstr "share" [] Share - ; cstr "share_root" [] Share_root - ; cstr "etc" [] Etc - ; cstr "doc" [] Doc - ; cstr "stublibs" [] Stublibs - ; cstr "man" [] Man - ; cstr "misc" [] Misc + enum + [ "lib" , Lib + ; "libexec" , Libexec + ; "bin" , Bin + ; "sbin" , Sbin + ; "toplevel" , Toplevel + ; "share" , Share + ; "share_root" , Share_root + ; "etc" , Etc + ; "doc" , Doc + ; "stublibs" , Stublibs + ; "man" , Man + ; "misc" , Misc ] end diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 0401205f..e1718a1b 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -2,12 +2,14 @@ open Import open Jbuild_types module Jbuilds = struct + type script = + { dir : Path.t + ; visible_packages : Package.t String_map.t + } + type one = | Literal of Path.t * Stanza.t list - | Script of - { dir : Path.t - ; visible_packages : Package.t String_map.t - } + | Script of script type t = one list diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 9f9866f7..c49e6e1d 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -127,10 +127,10 @@ module User_action = struct let rec t a sexp = sum - [ cstr_rest "run" [a] a (fun prog args -> Run (prog, args)) - ; cstr "chdir" [a; t a] (fun dn t -> Chdir (dn, t)) - ; cstr "setenv" [a; a; t a] (fun k v t -> Setenv (k, v, t)) - ; cstr "with-stdout-to" [a; t a] (fun fn t -> With_stdout_to (fn, t)) + [ cstr_rest "run" (a @> nil) a (fun prog args -> Run (prog, args)) + ; cstr "chdir" (a @> t a @> nil) (fun dn t -> Chdir (dn, t)) + ; cstr "setenv" (a @> a @> t a @> nil) (fun k v t -> Setenv (k, v, t)) + ; cstr "with-stdout-to" (a @> t a @> nil) (fun fn t -> With_stdout_to (fn, t)) ] sexp @@ -231,11 +231,14 @@ module Dep_conf = struct let t = let t = + let cstr name f = + cstr name (String_with_vars.t @> nil) f + in sum - [ cstr "file" [String_with_vars.t] (fun x -> File x) - ; cstr "alias" [String_with_vars.t] (fun x -> Alias x) - ; cstr "glob_files" [String_with_vars.t] (fun x -> Glob_files x) - ; cstr "files_recursively_in" [String_with_vars.t] (fun x -> Files_recursively_in x) + [ cstr "file" (fun x -> File x) + ; cstr "alias" (fun x -> Alias x) + ; cstr "glob_files" (fun x -> Glob_files x) + ; cstr "files_recursively_in" (fun x -> Files_recursively_in x) ] in fun sexp -> @@ -256,16 +259,17 @@ module Dep_conf = struct end module Preprocess = struct + type pps = { pps : Pp_set.t; flags : string list } type t = | No_preprocessing | Command of String_with_vars.t - | Pps of { pps : Pp_set.t; flags : string list } + | Pps of pps let t = sum - [ cstr "no_preprocessing" [] No_preprocessing - ; cstr "command" [String_with_vars.t] (fun x -> Command x) - ; cstr "pps" [list Pp_or_flag.t] (fun l -> + [ cstr "no_preprocessing" nil No_preprocessing + ; cstr "command" (String_with_vars.t @> nil) (fun x -> Command x) + ; cstr "pps" (list Pp_or_flag.t @> nil) (fun l -> let pps, flags = Pp_or_flag.split l in Pps { pps = Pp_set.of_list pps; flags }) ] @@ -337,9 +341,11 @@ module Lib_dep = struct ; file : string } + type select = { result_fn : string; choices : choice list } + type t = | Direct of string - | Select of { result_fn : string; choices : choice list } + | Select of select let choice = function | List (_, l) as sexp -> @@ -363,10 +369,10 @@ module Lib_dep = struct let sexp_of_choice { lits; file } : Sexp.t = List (List.fold_right lits ~init:[Atom "->"; Atom file] - ~f:(fun lit acc : Sexp.t list -> + ~f:(fun lit acc -> match lit with - | Pos s -> Atom s :: acc - | Neg s -> Atom ("!" ^ s) :: acc)) + | Pos s -> Sexp.Atom s :: acc + | Neg s -> Sexp.Atom ("!" ^ s) :: acc)) let t = function | Atom (_, s) -> @@ -457,10 +463,10 @@ module Library = struct | Ppx_rewriter let t = - sum - [ cstr "normal" [] Normal - ; cstr "ppx_type_conv_plugin" [] Ppx_type_conv_plugin - ; cstr "ppx_rewriter" [] Ppx_rewriter + enum + [ "normal" , Normal + ; "ppx_type_conv_plugin" , Ppx_type_conv_plugin + ; "ppx_rewriter" , Ppx_rewriter ] end @@ -779,36 +785,35 @@ module Stanza = struct let v1 = sum - [ cstr' "library" [Library.v1] (fun x -> Library x) - ; cstr' "executables" [Executables.v1] (fun x -> Executables x) - ; cstr' "rule" [Rule.v1] (fun x -> Rule x) - ; cstr' "ocamllex" [Ocamllex.v1] (fun x -> Ocamllex x) - ; cstr' "ocamlyacc" [Ocamlyacc.v1] (fun x -> Ocamlyacc x) - ; cstr' "provides" [Provides.v1] (fun x -> Provides x) - ; cstr' "install" [Install_conf.v1] (fun x -> Install x) - ; cstr' "alias" [Alias_conf.v1] (fun x -> Alias x) + [ cstr' "library" (Library.v1 @> nil) (fun x -> Library x) + ; cstr' "executables" (Executables.v1 @> nil) (fun x -> Executables x) + ; cstr' "rule" (Rule.v1 @> nil) (fun x -> Rule x) + ; cstr' "ocamllex" (Ocamllex.v1 @> nil) (fun x -> Ocamllex x) + ; cstr' "ocamlyacc" (Ocamlyacc.v1 @> nil) (fun x -> Ocamlyacc x) + ; cstr' "provides" (Provides.v1 @> nil) (fun x -> Provides x) + ; cstr' "install" (Install_conf.v1 @> nil) (fun x -> Install x) + ; cstr' "alias" (Alias_conf.v1 @> nil) (fun x -> Alias x) (* Just for validation and error messages *) - ; cstr "jbuild_version" [Jbuild_version.t] (fun _ -> None) - ; cstr "use_meta_lang" [] None + ; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> None) ] let vjs = - let ign name = cstr name [fun _ -> ()] (fun () -> None) in + let ign name = cstr name ((fun _ -> ()) @> nil) (fun () -> None) in sum - [ cstr' "library" [Library.vjs] (fun x -> Library x) - ; cstr' "executables" [Executables.vjs] (fun x -> Executables x) - ; cstr' "rule" [Rule.vjs] (fun x -> Rule x) - ; cstr' "ocamllex" [Ocamllex.vjs] (fun x -> Ocamllex x) - ; cstr' "ocamlyacc" [Ocamlyacc.vjs] (fun x -> Ocamlyacc x) - ; cstr' "provides" [Provides.vjs] (fun x -> Provides x) - ; cstr' "install" [Install_conf.vjs] (fun x -> Install x) - ; cstr' "alias" [Alias_conf.vjs] (fun x -> Alias x) + [ cstr' "library" (Library.vjs @> nil) (fun x -> Library x) + ; cstr' "executables" (Executables.vjs @> nil) (fun x -> Executables x) + ; cstr' "rule" (Rule.vjs @> nil) (fun x -> Rule x) + ; cstr' "ocamllex" (Ocamllex.vjs @> nil) (fun x -> Ocamllex x) + ; cstr' "ocamlyacc" (Ocamlyacc.vjs @> nil) (fun x -> Ocamlyacc x) + ; cstr' "provides" (Provides.vjs @> nil) (fun x -> Provides x) + ; cstr' "install" (Install_conf.vjs @> nil) (fun x -> Install x) + ; cstr' "alias" (Alias_conf.vjs @> nil) (fun x -> Alias x) ; ign "enforce_style" ; ign "toplevel_expect_tests" ; ign "unified_tests" ; ign "embed" (* Just for validation and error messages *) - ; cstr "jbuild_version" [Jbuild_version.t] (fun _ -> None) + ; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> None) ] let select : Jbuild_version.t -> t option Sexp.Of_sexp.t = function diff --git a/src/lib.ml b/src/lib.ml index 80a4f190..72eff8c8 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -71,10 +71,10 @@ let describe = function let link_flags ts ~mode = Arg_spec.S (include_flags ts :: - List.map ts ~f:(fun t : _ Arg_spec.t -> + List.map ts ~f:(fun t -> match t with | External pkg -> - Deps_rel (pkg.dir, Mode.Dict.get pkg.archives mode) + Arg_spec.Deps_rel (pkg.dir, Mode.Dict.get pkg.archives mode) | Internal (dir, lib) -> Dep_rel (dir, lib.name ^ Mode.compiled_lib_ext mode))) diff --git a/src/mode.ml b/src/mode.ml index fd7edbcb..2ffa17f9 100644 --- a/src/mode.ml +++ b/src/mode.ml @@ -6,9 +6,9 @@ let all = [Byte; Native] let t = let open Sexp.Of_sexp in - sum - [ cstr "byte" [] Byte - ; cstr "native" [] Native + enum + [ "byte" , Byte + ; "native" , Native ] let choose byte native = function diff --git a/src/sexp.ml b/src/sexp.ml index 7f311cd7..cc3ccc6c 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -258,28 +258,33 @@ module Of_sexp = struct module Constructor_args_spec = struct type 'a conv = 'a t type ('a, 'b) t = - | [] : ('a, 'a) t - | ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t + | Nil : ('a, 'a) t + | Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t let rec convert : type a b c. (a, b) t -> (b, c) rest -> Ast.t -> Ast.t list -> a -> c = fun t rest sexp sexps f -> match t, rest, sexps with - | [], No_rest, [] -> f - | [], Many _ , [] -> f [] - | _ :: _, _, [] -> of_sexp_error sexp "not enough arguments" - | [], No_rest, _ :: _ -> of_sexp_error sexp "too many arguments" - | [], Many conv, l -> f (List.map l ~f:conv) - | conv :: t, _, s :: sexps -> + | Nil, No_rest, [] -> f + | Nil, Many _ , [] -> f [] + | Cons _, _, [] -> of_sexp_error sexp "not enough arguments" + | Nil, No_rest, _ :: _ -> of_sexp_error sexp "too many arguments" + | Nil, Many conv, l -> f (List.map l ~f:conv) + | Cons (conv, t), _, s :: sexps -> convert t rest sexp sexps (f (conv s)) end + let nil = Constructor_args_spec.Nil + let ( @> ) a b = Constructor_args_spec.Cons (a, b) + module Constructor_spec = struct - type 'a t = - T : { name : string - ; args : ('a, 'b) Constructor_args_spec.t - ; rest : ('b, 'c) rest - ; make : 'a - } -> 'c t + type ('a, 'b, 'c) unpacked = + { name : string + ; args : ('a, 'b) Constructor_args_spec.t + ; rest : ('b, 'c) rest + ; make : 'a + } + + type 'a t = T : (_, _, 'a) unpacked -> 'a t end let cstr_rest name args rest make = diff --git a/src/sexp.mli b/src/sexp.mli index 3723f11a..459d8c03 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -65,11 +65,14 @@ module Of_sexp : sig end module Constructor_args_spec : sig - type 'a conv = 'a t - type ('a, 'b) t = - | [] : ('a, 'a) t - | ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t - end with type 'a conv := 'a t + type ('a, 'b) t + end + + val nil : ('a, 'a) Constructor_args_spec.t + val ( @> ) + : 'a t + -> ('b, 'c) Constructor_args_spec.t + -> ('a -> 'b, 'c) Constructor_args_spec.t val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t val cstr_rest diff --git a/src/workspace.ml b/src/workspace.ml index 0fd8bac1..d0f826c1 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -44,7 +44,7 @@ let t sexps = List.fold_left sexps ~init:(None, []) ~f:(fun (merlin_ctx, ctxs) sexp -> let ctx = sum - [ cstr "context" [Context.t] (fun x -> x) ] + [ cstr "context" (Context.t @> nil) (fun x -> x) ] sexp in let name = Context.name ctx in diff --git a/vendor/cmdliner/src/result.ml b/vendor/cmdliner/src/result.ml index 8ec16b72..6241d166 100644 --- a/vendor/cmdliner/src/result.ml +++ b/vendor/cmdliner/src/result.ml @@ -1,2 +1,3 @@ - -type nonrec ('ok, 'err) result = ('ok, 'err) result +type ('ok, 'err) result = + | Ok of 'ok + | Error of 'err