Merge pull request #1100 from ocaml/remove-some-polymorphic-comparisons

Remove some polymorphic comparisons

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)

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);
@@ -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
@@ -1528,7 +1529,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"

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
@@ -274,7 +275,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 ->
@@ -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)
@@ -549,7 +551,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

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 =
+  module T = struct
-    | Named     of string
+    type t =
-    | Anonymous of Path.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 "<anonymous %s>" (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

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

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
+        begin
-          ["-custom"]
+          match wanted_mode, real_mode with
-        else
+          | 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

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,
@@ -697,7 +698,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

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 byte = mem t Byte || (has_best && (not has_native)) in
-      let native = best = Native && (mem t Native || has_best) in
+      let native = has_native && (mem t Native || has_best) in
       { Mode.Dict.byte; native }
   end
 end
@@ -958,6 +952,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 +1197,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 ->
@@ -1844,7 +1840,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

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 =

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

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

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

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

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

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

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\

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
 
 

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 =

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

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

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)

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 =

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 ();

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

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

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)

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

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.(==)

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

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

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

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

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

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

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

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
 

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) =
+  let can_read
-    pa = da && db <= pb
+        ~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 ()

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