From 4f1d1a0ea53648c95de61373e7f2d486bb9e624d Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Tue, 7 Aug 2018 09:27:37 +0000 Subject: [PATCH 1/7] Add Comparable.Operators Signed-off-by: Etienne Millon --- src/stdune/comparable.ml | 38 ++++++++++++++++++++++++++++++++++++++ src/stdune/comparable.mli | 11 +++++++++++ 2 files changed, 49 insertions(+) diff --git a/src/stdune/comparable.ml b/src/stdune/comparable.ml index 18bce70b..7c5a7bb9 100644 --- a/src/stdune/comparable.ml +++ b/src/stdune/comparable.ml @@ -2,3 +2,41 @@ module type S = sig type t val compare : t -> t -> Ordering.t end + +module type OPS = sig + type t + val (=) : t -> t -> bool + val (>=) : t -> t -> bool + val (>) : t -> t -> bool + val (<=) : t -> t -> bool + val (<) : t -> t -> bool +end + +module Operators (X : S) = struct + type t = X.t + + let (=) a b = + match X.compare a b with + | Eq -> true + | Gt | Lt -> false + + let (>=) a b = + match X.compare a b with + | Gt | Eq -> true + | Lt -> false + + let (>) a b = + match X.compare a b with + | Gt -> true + | Lt | Eq -> false + + let (<=) a b = + match X.compare a b with + | Lt | Eq -> true + | Gt -> false + + let (<) a b = + match X.compare a b with + | Lt -> true + | Gt | Eq -> false +end diff --git a/src/stdune/comparable.mli b/src/stdune/comparable.mli index 18bce70b..ed01cb49 100644 --- a/src/stdune/comparable.mli +++ b/src/stdune/comparable.mli @@ -2,3 +2,14 @@ module type S = sig type t val compare : t -> t -> Ordering.t end + +module type OPS = sig + type t + val (=) : t -> t -> bool + val (>=) : t -> t -> bool + val (>) : t -> t -> bool + val (<=) : t -> t -> bool + val (<) : t -> t -> bool +end + +module Operators (X : S) : OPS with type t = X.t From da1f65bc5621bc423f71cdf333be3d578fbf9ade Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Fri, 3 Aug 2018 15:21:47 +0000 Subject: [PATCH 2/7] Use explicit comparison for Syntax.Version.t Signed-off-by: Etienne Millon --- src/jbuild.ml | 2 ++ src/pform.ml | 1 + src/stdune/int.ml | 2 ++ src/stdune/int.mli | 2 ++ src/syntax.ml | 24 +++++++++++++++++++++--- src/syntax.mli | 3 +++ 6 files changed, 31 insertions(+), 3 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index 8c0eb18d..4f86ae40 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -958,6 +958,7 @@ module Library = struct and dune_version = Syntax.get_exn Stanza.syntax in let name = + let open Syntax.Version.Infix in match name, public with | Some n, _ -> Lib_name.validate n ~wrapped @@ -1202,6 +1203,7 @@ module Executables = struct in fun names public_names ~multi -> let names = + let open Syntax.Version.Infix in match names, public_names with | Some names, _ -> names | None, Some public_names -> diff --git a/src/pform.ml b/src/pform.ml index 32ccaf0a..80dc5a59 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -157,6 +157,7 @@ module Map = struct let rec expand map ~syntax_version ~pform = let open Option.O in + let open Syntax.Version.Infix in let name = String_with_vars.Var.name pform in String.Map.find map name >>= fun v -> let describe = String_with_vars.Var.describe in diff --git a/src/stdune/int.ml b/src/stdune/int.ml index d5c4a717..a80839c6 100644 --- a/src/stdune/int.ml +++ b/src/stdune/int.ml @@ -19,3 +19,5 @@ let of_string_exn s = | exception Failure _ -> failwith (Printf.sprintf "of_string_exn: invalid int %S" s) | s -> s + +module Infix = Comparable.Operators(T) diff --git a/src/stdune/int.mli b/src/stdune/int.mli index 62aeba20..4099bba3 100644 --- a/src/stdune/int.mli +++ b/src/stdune/int.mli @@ -5,3 +5,5 @@ module Set : Set.S with type elt = t module Map : Map.S with type key = t val of_string_exn : string -> t + +module Infix : Comparable.OPS with type t = t diff --git a/src/syntax.ml b/src/syntax.ml index 8ea07e32..d470c300 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,7 +1,18 @@ open Import module Version = struct - type t = int * int + module T = struct + type t = int * int + + let compare (major_a, minor_a) (major_b, minor_b) = + match Int.compare major_a major_b with + | (Gt | Lt) as ne -> ne + | Eq -> Int.compare minor_a minor_b + end + + include T + + module Infix = Comparable.Operators(T) let to_string (a, b) = sprintf "%u.%u" a b @@ -19,8 +30,11 @@ module Version = struct | sexp -> of_sexp_error (Sexp.Ast.loc sexp) "Atom expected" - let can_read ~parser_version:(pa, pb) ~data_version:(da, db) = - pa = da && db <= pb + let can_read + ~parser_version:(parser_major, parser_minor) + ~data_version:(data_major, data_minor) = + let open Int.Infix in + parser_major = data_major && parser_minor >= data_minor end module Supported_versions = struct @@ -92,6 +106,7 @@ let check_supported t (loc, ver) = (String.concat ~sep:"\n" (List.map (Supported_versions.supported_ranges t.supported_versions) ~f:(fun (a, b) -> + let open Version.Infix in if a = b then sprintf "- %s" (Version.to_string a) else @@ -125,6 +140,7 @@ let desc () = | Fields (loc, Some s) -> (loc, sprintf "Field '%s'" s) let deleted_in t ver = + let open Version.Infix in get_exn t >>= fun current_ver -> if current_ver < ver then return () @@ -134,6 +150,7 @@ let deleted_in t ver = end let renamed_in t ver ~to_ = + let open Version.Infix in get_exn t >>= fun current_ver -> if current_ver < ver then return () @@ -143,6 +160,7 @@ let renamed_in t ver ~to_ = end let since t ver = + let open Version.Infix in get_exn t >>= fun current_ver -> if current_ver >= ver then return () diff --git a/src/syntax.mli b/src/syntax.mli index 1baca844..6c81e2c2 100644 --- a/src/syntax.mli +++ b/src/syntax.mli @@ -16,6 +16,9 @@ module Version : sig (** Whether the parser can read the data or not *) val can_read : parser_version:t -> data_version:t -> bool + + val compare : t -> t -> Ordering.t + module Infix : Comparable.OPS with type t = t end type t From 35ea17ebc4c33efbcc2c65cb601289dba3b65247 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 6 Aug 2018 07:52:39 +0000 Subject: [PATCH 3/7] Use explicit comparison for path functions Signed-off-by: Etienne Millon --- bin/main.ml | 2 +- src/build_system.ml | 8 ++++---- src/dir_contents.ml | 2 +- src/jbuild.ml | 2 +- src/jbuild_load.ml | 2 +- src/js_of_ocaml_rules.ml | 2 +- src/print_diff.ml | 2 +- src/process.ml | 2 +- src/stdune/path.ml | 6 ++++++ src/stdune/path.mli | 3 +++ src/super_context.ml | 4 ++-- 11 files changed, 22 insertions(+), 13 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index cae9be5d..8cf16934 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -630,7 +630,7 @@ let target_hint (setup : Main.setup) path = (* Only suggest hints for the basename, otherwise it's slow when there are lots of files *) List.filter_map candidates ~f:(fun path -> - if Path.parent_exn path = sub_dir then + if Path.equal (Path.parent_exn path) sub_dir then Some (Path.to_string path) else None) diff --git a/src/build_system.ml b/src/build_system.ml index 6f3e924e..b8fa87d7 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -431,7 +431,7 @@ let get_dir_status t ~dir = Path.Table.find_or_add t.dirs dir ~f:(fun _ -> if Path.is_in_source_tree dir then Dir_status.Loaded (File_tree.files_of t.file_tree dir) - else if dir = Path.build_dir then + else if Path.equal dir Path.build_dir then (* Not allowed to look here *) Dir_status.Loaded Path.Set.empty else if not (Path.is_managed dir) then @@ -901,7 +901,7 @@ and load_dir_and_get_targets t ~dir = | [] -> assert false | x :: l -> t.load_dir_stack <- l; - assert (x = dir))); + assert (Path.equal x dir))); Path.Table.replace t.dirs ~key:dir ~data:Failed_to_load; reraise exn @@ -1095,7 +1095,7 @@ The following targets are not: | [] -> assert false | x :: l -> t.load_dir_stack <- l; - assert (x = dir)); + assert (Path.equal x dir)); (* Compile the rules and cleanup stale artifacts *) List.iter rules ~f:(compile_rule t ~copy_source:false); @@ -1528,7 +1528,7 @@ let get_collector t ~dir = Exn.code_error (if Path.is_in_source_tree dir then "Build_system.get_collector called on source directory" - else if dir = Path.build_dir then + else if Path.equal dir Path.build_dir then "Build_system.get_collector called on build_dir" else if not (Path.is_managed dir) then "Build_system.get_collector called on external directory" diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 1440d2c9..0cb2dee5 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -549,7 +549,7 @@ module Dir_status = struct let project_root = Path.of_local (File_tree.Dir.project ft_dir).root in match Super_context.stanzas_in sctx ~dir with | None -> - if dir = project_root || + if Path.equal dir project_root || is_standalone (get sctx ~dir:(Path.parent_exn dir)) then Standalone (Some (ft_dir, None)) else diff --git a/src/jbuild.ml b/src/jbuild.ml index 4f86ae40..9ad3b66d 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -1846,7 +1846,7 @@ module Stanzas = struct if not (Path.exists current_file) then Loc.fail loc "File %s doesn't exist." (Path.to_string_maybe_quoted current_file); - if List.exists include_stack ~f:(fun (_, f) -> f = current_file) then + if List.exists include_stack ~f:(fun (_, f) -> Path.equal f current_file) then raise (Include_loop (current_file, include_stack)); let sexps = Io.Sexp.load ~lexer current_file ~mode:Many in parse stanza_parser sexps ~lexer ~current_file ~include_stack diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index fe5510d8..a3ab2ab3 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -242,7 +242,7 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () = ~f:(fun dir acc -> let p = File_tree.Dir.project dir in match Path.kind (File_tree.Dir.path dir) with - | Local d when d = p.root -> p :: acc + | Local d when Path.Local.equal d p.root -> p :: acc | _ -> acc) in let packages = diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index 910871fb..67202a77 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -125,7 +125,7 @@ let build_cm cc ~(js_of_ocaml:Jbuild.Js_of_ocaml.t) ~src ~target = >>> js_of_ocaml_rule sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target:itarget ] - @ (if target = itarget then + @ (if Path.equal target itarget then [] else [Build.symlink ~src:itarget ~dst:target]) diff --git a/src/print_diff.ml b/src/print_diff.ml index b5fe1bfe..c25180de 100644 --- a/src/print_diff.ml +++ b/src/print_diff.ml @@ -8,7 +8,7 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 = Path.extract_build_context_dir path1, Path.extract_build_context_dir path2 with - | Some (dir1, f1), Some (dir2, f2) when dir1 = dir2 -> + | Some (dir1, f1), Some (dir2, f2) when Path.equal dir1 dir2 -> (dir1, Path.to_string f1, Path.to_string f2) | _ -> (Path.root, Path.to_string path1, Path.to_string path2) diff --git a/src/process.ml b/src/process.ml index 6c59b2aa..8dbc0e36 100644 --- a/src/process.ml +++ b/src/process.ml @@ -125,7 +125,7 @@ module Fancy = struct in match stdout_to, stderr_to with | (File fn1 | Opened_file { filename = fn1; _ }), - (File fn2 | Opened_file { filename = fn2; _ }) when fn1 = fn2 -> + (File fn2 | Opened_file { filename = fn2; _ }) when Path.equal fn1 fn2 -> sprintf "%s &> %s" s (Path.to_string fn1) | _ -> let s = diff --git a/src/stdune/path.ml b/src/stdune/path.ml index e7d73cdd..3683a9b1 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -136,6 +136,7 @@ module Local : sig val is_root : t -> bool val compare : t -> t -> Ordering.t val compare_val : t -> t -> Ordering.t + val equal : t -> t -> bool val of_string : ?error_loc:Usexp.Loc.t -> string -> t val to_string : t -> string val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t @@ -172,6 +173,11 @@ end = struct let compare_val x y = String.compare (to_string x) (to_string y) + let equal x y = + match compare x y with + | Eq -> true + | Gt | Lt -> false + let root = make "." let is_root t = t = root diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 7ed85a3c..4e2c1c0a 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -2,6 +2,7 @@ module Local : sig type t val sexp_of_t : t -> Sexp.t + val equal : t -> t -> bool end (** In the outside world *) @@ -31,6 +32,8 @@ val sexp_of_t : t Sexp.To_sexp.t val compare : t -> t -> Ordering.t (** a directory is smaller than its descendants *) +val equal : t -> t -> bool + module Set : sig include Set.S with type elt = t val sexp_of_t : t Sexp.To_sexp.t diff --git a/src/super_context.ml b/src/super_context.ml index 060db608..5a4340f4 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -638,7 +638,7 @@ let create List.iter stanzas ~f:(function | Dune_env.T config -> let inherit_from = - if ctx_dir = Scope.root scope then + if Path.equal ctx_dir (Scope.root scope) then context_env_node else lazy (Env.get t ~dir:(Path.parent_exn ctx_dir)) @@ -811,7 +811,7 @@ module Action = struct | Some host -> fun exe -> match Path.extract_build_context_dir exe with - | Some (dir, exe) when dir = sctx.context.build_dir -> + | Some (dir, exe) when Path.equal dir sctx.context.build_dir -> Path.append host.context.build_dir exe | _ -> exe From c6d5faa79f5530edb8ec19187b1175c007f17d2e Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 6 Aug 2018 08:01:42 +0000 Subject: [PATCH 4/7] Use explicit comparison function for Loc.t Signed-off-by: Etienne Millon --- src/dir_contents.ml | 2 +- src/gen_rules.ml | 2 +- src/loc.ml | 19 +++++++++++++++++++ src/loc.mli | 2 ++ src/report_error.ml | 7 ++++++- src/stdune/option.ml | 7 +++++++ src/stdune/option.mli | 2 ++ src/stdune/string.ml | 1 + src/stdune/string.mli | 1 + 9 files changed, 40 insertions(+), 3 deletions(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 0cb2dee5..7f3d362d 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -274,7 +274,7 @@ let mlds t (doc : Documentation.t) = let map = Lazy.force t.mlds in match List.find_map map ~f:(fun (doc', x) -> - Option.some_if (doc.loc = doc'.loc) x) + Option.some_if (Loc.equal doc.loc doc'.loc) x) with | Some x -> x | None -> diff --git a/src/gen_rules.ml b/src/gen_rules.ml index bd77fcfd..c4b434f5 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -697,7 +697,7 @@ module Gen(P : Install_rules.Params) = struct Option.bind (Dir_contents.lookup_module dir_contents name) ~f:(fun buildable -> List.find_map cctxs ~f:(fun (loc, cctx) -> - Option.some_if (loc = buildable.loc) cctx))) + Option.some_if (Loc.equal loc buildable.loc) cctx))) with | None -> (* This happens often when passing a [-p ...] option that diff --git a/src/loc.ml b/src/loc.ml index 81b0f470..60b9eea1 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -77,3 +77,22 @@ let to_file_colon_line t = let pp_file_colon_line ppf t = Format.pp_print_string ppf (to_file_colon_line t) + +let equal_position + { Lexing.pos_fname = f_a; pos_lnum = l_a + ; pos_bol = b_a; pos_cnum = c_a } + { Lexing.pos_fname = f_b; pos_lnum = l_b + ; pos_bol = b_b; pos_cnum = c_b } + = + let open Int.Infix in + String.equal f_a f_b + && l_a = l_b + && b_a = b_b + && c_a = c_b + +let equal + { start = start_a ; stop = stop_a } + { start = start_b ; stop = stop_b } + = + equal_position start_a start_b + && equal_position stop_a stop_b diff --git a/src/loc.mli b/src/loc.mli index 5bcad0cc..053030ed 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -3,6 +3,8 @@ type t = Usexp.Loc.t = ; stop : Lexing.position } +val equal : t -> t -> bool + val sexp_of_t : t -> Usexp.t val of_lexbuf : Lexing.lexbuf -> t diff --git a/src/report_error.ml b/src/report_error.ml index c347549a..7832aa8d 100644 --- a/src/report_error.ml +++ b/src/report_error.ml @@ -114,7 +114,12 @@ let report exn = let backtrace = Printexc.get_raw_backtrace () in let ppf = err_ppf in let p = report_with_backtrace exn in - let loc = if p.loc = Some Loc.none then None else p.loc in + let loc = + if Option.equal Loc.equal p.loc (Some Loc.none) then + None + else + p.loc + in Option.iter loc ~f:(fun loc -> Loc.print ppf loc); p.pp ppf; Format.pp_print_flush ppf (); diff --git a/src/stdune/option.ml b/src/stdune/option.ml index 6280f4d9..abbaa621 100644 --- a/src/stdune/option.ml +++ b/src/stdune/option.ml @@ -52,3 +52,10 @@ let both x y = let to_list = function | None -> [] | Some x -> [x] + +let equal eq x y = + match (x, y) with + | None, None -> true + | Some _, None -> false + | None, Some _ -> false + | Some sx, Some sy -> eq sx sy diff --git a/src/stdune/option.mli b/src/stdune/option.mli index 30385045..720386f5 100644 --- a/src/stdune/option.mli +++ b/src/stdune/option.mli @@ -26,3 +26,5 @@ val is_none : _ t -> bool val both : 'a t -> 'b t -> ('a * 'b) t val to_list : 'a t -> 'a list + +val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool diff --git a/src/stdune/string.ml b/src/stdune/string.ml index e75da57f..00c926e0 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -7,6 +7,7 @@ include struct let uncapitalize_ascii = String.uncapitalize let uppercase_ascii = String.uppercase let lowercase_ascii = String.lowercase + let equal (a:string) b = Pervasives.(=) a b end include StringLabels diff --git a/src/stdune/string.mli b/src/stdune/string.mli index a21c574f..3a0844b1 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -1,5 +1,6 @@ include module type of struct include StringLabels end +val equal : t -> t -> bool val compare : t -> t -> Ordering.t val break : t -> pos:int -> t * t From 8306f261e785987b22b824fd0f823afd52192deb Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 6 Aug 2018 08:26:10 +0000 Subject: [PATCH 5/7] Add List.physically_equal Signed-off-by: Etienne Millon --- src/lib.ml | 2 +- src/stdune/list.ml | 2 ++ src/stdune/list.mli | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/lib.ml b/src/lib.ml index 0cf8c91a..fd08f678 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -533,7 +533,7 @@ module Dep_stack = struct let to_required_by t ~stop_at = let stop_at = stop_at.stack in let rec loop acc l = - if l == stop_at then + if List.physically_equal l stop_at then List.rev acc else match l with diff --git a/src/stdune/list.ml b/src/stdune/list.ml index c24031c3..0c48614d 100644 --- a/src/stdune/list.ml +++ b/src/stdune/list.ml @@ -115,3 +115,5 @@ let rec nth t i = | [], _ -> None | x :: _, 0 -> Some x | _ :: xs, i -> nth xs (i - 1) + +let physically_equal = Pervasives.(==) diff --git a/src/stdune/list.mli b/src/stdune/list.mli index 6aa7dcd6..505b1de0 100644 --- a/src/stdune/list.mli +++ b/src/stdune/list.mli @@ -43,3 +43,5 @@ val assoc : ('a * 'b) t -> 'a -> 'b option val singleton : 'a -> 'a t val nth : 'a t -> int -> 'a option + +val physically_equal : 'a t -> 'a t -> bool From 0ec9baf257e7a8cfee582065b5fc9d36a4d4e3e9 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 6 Aug 2018 08:27:54 +0000 Subject: [PATCH 6/7] Add comparison functions for names Signed-off-by: Etienne Millon --- src/build_system.ml | 1 + src/dir_contents.ml | 2 ++ src/dune_project.ml | 29 +++++++++++++++++++---------- src/dune_project.mli | 2 ++ src/module.ml | 9 +++++++-- src/module.mli | 2 ++ src/ocamldep.ml | 3 +++ src/package.ml | 6 +++++- src/package.mli | 2 ++ src/preprocessing.ml | 1 + 10 files changed, 44 insertions(+), 13 deletions(-) diff --git a/src/build_system.ml b/src/build_system.ml index b8fa87d7..ad3a2d82 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -1475,6 +1475,7 @@ let package_deps t pkg files = else List.fold_left pkgs ~init:acc ~f:add_package and add_package acc p = + let open Package.Name.Infix in if p = pkg then acc else diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 7f3d362d..c2b9cb20 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -175,6 +175,7 @@ module Library_modules = struct if not lib.wrapped then modules else + let open Module.Name.Infix in Module.Name.Map.map modules ~f:(fun m -> if m.name = main_module_name then m @@ -409,6 +410,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = match Module.Name.Map.of_list rev_modules with | Ok x -> x | Error (name, _, _) -> + let open Module.Name.Infix in let locs = List.filter_map rev_modules ~f:(fun (n, b) -> Option.some_if (n = name) b.loc) diff --git a/src/dune_project.ml b/src/dune_project.ml index 910ffd86..c40f4f6c 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -32,20 +32,28 @@ module Name : sig val named : string -> t option val anonymous_root : t + + module Infix : Comparable.OPS with type t = t end = struct - type t = - | Named of string - | Anonymous of Path.t + module T = struct + type t = + | Named of string + | Anonymous of Path.t + + let compare a b = + match a, b with + | Named x, Named y -> String.compare x y + | Anonymous x, Anonymous y -> Path.compare x y + | Named _, Anonymous _ -> Lt + | Anonymous _, Named _ -> Gt + end + + include T + + module Infix = Comparable.Operators(T) let anonymous_root = Anonymous Path.root - let compare a b = - match a, b with - | Named x, Named y -> String.compare x y - | Anonymous x, Anonymous y -> Path.compare x y - | Named _, Anonymous _ -> Lt - | Anonymous _, Named _ -> Gt - let to_string_hum = function | Named s -> s | Anonymous p -> sprintf "" (Path.to_string_maybe_quoted p) @@ -305,6 +313,7 @@ let default_name ~dir ~packages = | None -> Option.value_exn (Name.anonymous dir) | Some (_, pkg) -> let pkg = + let open Package.Name.Infix in Package.Name.Map.fold packages ~init:pkg ~f:(fun pkg acc -> if acc.Package.name <= pkg.Package.name then acc diff --git a/src/dune_project.mli b/src/dune_project.mli index e9fd5ca3..482d54b6 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -27,6 +27,8 @@ module Name : sig (** Convert to/from an encoded string that is suitable to use in filenames *) val encode : t -> string val decode : string -> t + + module Infix : Comparable.OPS with type t = t end module Project_file : sig diff --git a/src/module.ml b/src/module.ml index bd5f836c..7bc804d4 100644 --- a/src/module.ml +++ b/src/module.ml @@ -1,13 +1,17 @@ open Import module Name = struct - type t = string + module T = struct + type t = string + let compare = compare + end + + include T let t = Sexp.atom let add_suffix = (^) - let compare = compare let of_string = String.capitalize let to_string x = x @@ -19,6 +23,7 @@ module Name = struct module Set = String.Set module Map = String.Map module Top_closure = Top_closure.String + module Infix = Comparable.Operators(T) end module Syntax = struct diff --git a/src/module.mli b/src/module.mli index b9268c4d..8f5b4727 100644 --- a/src/module.mli +++ b/src/module.mli @@ -19,6 +19,8 @@ module Name : sig module Map : Map.S with type key = t module Top_closure : Top_closure.S with type key := t + + module Infix : Comparable.OPS with type t = t end module Syntax : sig diff --git a/src/ocamldep.ml b/src/ocamldep.ml index 2c11ee40..af61f85a 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -60,6 +60,7 @@ module Dep_graphs = struct end let parse_module_names ~(unit : Module.t) ~modules words = + let open Module.Name.Infix in List.filter_map words ~f:(fun m -> let m = Module.Name.of_string m in if m = unit.name then @@ -68,6 +69,7 @@ let parse_module_names ~(unit : Module.t) ~modules words = Module.Name.Map.find modules m) let is_alias_module cctx (m : Module.t) = + let open Module.Name.Infix in match CC.alias_module cctx with | None -> false | Some alias -> alias.name = m.name @@ -103,6 +105,7 @@ let parse_deps cctx ~file ~unit lines = (match lib_interface_module with | None -> () | Some (m : Module.t) -> + let open Module.Name.Infix in if unit.name <> m.name && not (is_alias_module cctx unit) && List.exists deps ~f:(fun x -> Module.name x = m.name) then die "Module %a in directory %s depends on %a.\n\ diff --git a/src/package.ml b/src/package.ml index 5979b5c3..af79aae1 100644 --- a/src/package.ml +++ b/src/package.ml @@ -1,12 +1,14 @@ open Stdune module Name = struct - include Interned.Make(struct + module T = Interned.Make(struct let initial_size = 16 let resize_policy = Interned.Conservative let order = Interned.Natural end)() + include T + let of_string = make let opam_fn (t : t) = to_string t ^ ".opam" @@ -14,6 +16,8 @@ module Name = struct let pp fmt t = Format.pp_print_string fmt (to_string t) let t = Sexp.Of_sexp.(map string ~f:of_string) + + module Infix = Comparable.Operators(T) end diff --git a/src/package.mli b/src/package.mli index bc64323b..35ee0768 100644 --- a/src/package.mli +++ b/src/package.mli @@ -14,6 +14,8 @@ module Name : sig include Interned.S with type t := t val t : t Sexp.Of_sexp.t + + module Infix : Comparable.OPS with type t = t end type t = diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 0087d5f4..c2dd73bd 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -346,6 +346,7 @@ let ppx_driver_exe sctx libs ~dir_kind = | Private scope_name -> Some scope_name | Public _ | Installed -> None in + let open Dune_project.Name.Infix in match acc, scope_for_key with | Some a, Some b -> assert (a = b); acc | Some _, None -> acc From 27b460c32089bcc6a31061942f74e2cc8d633af1 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Mon, 6 Aug 2018 08:32:59 +0000 Subject: [PATCH 7/7] Use pattern matching when possible Signed-off-by: Etienne Millon --- src/exe.ml | 16 +++++++++------- src/gen_rules.ml | 5 +++-- src/jbuild.ml | 10 ++-------- 3 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/exe.ml b/src/exe.ml index bc23399a..a6085537 100644 --- a/src/exe.ml +++ b/src/exe.ml @@ -76,25 +76,27 @@ module Linkage = struct let flags = match m.kind with | Exe -> - if wanted_mode = Native && real_mode = Byte then - ["-custom"] - else - [] + begin + match wanted_mode, real_mode with + | Native, Byte -> ["-custom"] + | _ -> [] + end | Object -> o_flags | Shared_object -> let so_flags = - if ctx.os_type = "Win32" then + if String.equal ctx.os_type "Win32" then so_flags_windows else so_flags_unix in - if real_mode = Native then + match real_mode with + | Native -> (* The compiler doesn't pass these flags in native mode. This looks like a bug in the compiler. *) List.concat_map ctx.native_c_libraries ~f:(fun flag -> ["-cclib"; flag]) @ so_flags - else + | Byte -> so_flags in { ext diff --git a/src/gen_rules.ml b/src/gen_rules.ml index c4b434f5..caafa74a 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -487,9 +487,10 @@ module Gen(P : Install_rules.Params) = struct let l = let has_native = Option.is_some ctx.ocamlopt in List.filter_map (L.Set.to_list exes.modes) ~f:(fun (mode : L.t) -> - if not has_native && mode.mode = Native then + match has_native, mode.mode with + | false, Native -> None - else + | _ -> Some (Exe.Linkage.of_user_config ctx mode)) in (* If bytecode was requested but not native or best version, diff --git a/src/jbuild.ml b/src/jbuild.ml index 9ad3b66d..6a115aa3 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -870,15 +870,9 @@ module Mode_conf = struct let default = of_list [Byte; Best] let eval t ~has_native = - let best : Mode.t = - if has_native then - Native - else - Byte - in let has_best = mem t Best in - let byte = mem t Byte || (has_best && best = Byte) in - let native = best = Native && (mem t Native || has_best) in + let byte = mem t Byte || (has_best && (not has_native)) in + let native = has_native && (mem t Native || has_best) in { Mode.Dict.byte; native } end end