oxcaml · liam923 · Aug 7, 2025 · Aug 4, 2025 · Aug 5, 2025 · Aug 5, 2025
diff --git a/src/analysis/overrides.ml b/src/analysis/overrides.ml
@@ -89,14 +89,13 @@ module Override = struct
       Ok { loc = { Location.loc_start; loc_end; loc_ghost }; payload }
     | _ -> error_unexpected_merlin_override_attribute_structure
 
-  let is_target_override t ~cursor =
-    Lexing.compare_pos cursor t.loc.loc_start >= 0
-    && Lexing.compare_pos cursor t.loc.loc_end <= 0
-
   let payload t = t.payload
+
+  let to_interval t =
+    Overrides_interval_tree.Interval.create ~loc:t.loc ~payload:t
 end
 
-type t = Override.t list
+type t = Override.t Overrides_interval_tree.t
 
 let rec of_payload ~attribute_name ({ pexp_desc; _ } : Parsetree.expression) =
   match pexp_desc with
@@ -137,17 +136,19 @@ let get_overrides ~attribute_name pipeline =
             Some attr
           | _ -> None)
   in
-  List.concat_map attributes ~f:(fun attribute ->
-      match of_attribute ~attribute_name attribute with
-      | Ok overrides -> overrides
-      | Error err ->
-        log ~title:"get_overrides" "%s" err;
-        [])
-
-let find t ~cursor =
-  match List.find_all ~f:(Override.is_target_override ~cursor) t with
-  | [] -> None
-  | override :: [] -> Some override
-  | override :: _ :: _ ->
-    log ~title:"find" "found multiple target overrides, using first target";
-    Some override
+  attributes
+  |> List.concat_map ~f:(fun attribute ->
+         match of_attribute ~attribute_name attribute with
+         | Ok overrides -> overrides
+         | Error err ->
+           log ~title:"get_overrides" "%s" err;
+           [])
+  |> List.filter_map ~f:(fun (override : Override.t) ->
+         match Override.to_interval override with
+         | Ok interval -> Some interval
+         | Error err ->
+           log ~title:"get_overrides" "%s" err;
+           None)
+  |> Overrides_interval_tree.of_alist
+
+let find t ~cursor = Overrides_interval_tree.find t cursor
diff --git a/src/analysis/overrides_interval_tree.ml b/src/analysis/overrides_interval_tree.ml
@@ -0,0 +1,95 @@
+module Interval = struct
+  type 'a t = { loc : Location.t; payload : 'a }
+
+  let create ~(loc : Location.t) ~payload =
+    match loc.loc_start.pos_cnum <= loc.loc_end.pos_cnum with
+    | true -> Ok { loc; payload }
+    | false -> Error "input loc_start greater than loc_end"
+
+  let compare_loc t1 t2 = Location_aux.compare t1.loc t2.loc
+
+  let loc t = t.loc
+  let low t = t.loc.loc_start.pos_cnum
+  let high t = t.loc.loc_end.pos_cnum
+
+  let compare_range t1 t2 = Int.compare (high t1 - low t1) (high t2 - low t2)
+
+  let payload t = t.payload
+end
+
+(** The type representing an interval tree node. *)
+type 'a t =
+  | Empty
+  | Node of
+      { center : Lexing.position;
+            (** [center] is an approximation of the median of all intervals contained in the subtree [t]. *)
+        left : 'a t;
+            (** [left] is the subtree containing all intervals to the left of [center]. *)
+        right : 'a t;
+            (** [left] is the subtree containing all intervals to the right of [center]. *)
+        intervals : 'a Interval.t list
+            (** [intervals] is a list of all intervals that contain [center] *)
+      }
+
+(** Implementation based off of
+    {{:https://en.wikipedia.org/wiki/Interval_tree#With_a_point}}this description.  *)
+let rec find_helper t position =
+  match t with
+  | Empty -> []
+  | Node node -> (
+    let of_t =
+      List.filter
+        (fun (interval : _ Interval.t) ->
+          Location_aux.compare_pos position (Interval.loc interval) = 0)
+        node.intervals
+    in
+    match Std.Lexing.compare_pos position node.center with
+    | n when n < 0 ->
+      let of_left = find_helper node.left position in
+      of_left @ of_t
+    | n when n > 0 ->
+      let of_right = find_helper node.right position in
+      of_right @ of_t
+    | _ -> of_t)
+
+let find t point =
+  let tightest_interval =
+    find_helper t point |> Std.List.min_elt ~cmp:Interval.compare_range
+  in
+  match tightest_interval with
+  | None -> None
+  | Some interval -> Some (Interval.payload interval)
+
+let rec of_alist_helper (lst : _ Interval.t list) =
+  match List.length lst with
+  | 0 -> Empty
+  | length ->
+    let median =
+      (* The start position of the range of the middle interval is a close approximation
+         to the median. *)
+      let median_interval = List.nth lst (length / 2) in
+      (Interval.loc median_interval).loc_start
+    in
+    let to_left, to_overlap, to_right =
+      List.fold_right
+        (fun (interval : _ Interval.t) (to_left, to_overlap, to_right) ->
+          match Location_aux.compare_pos median (Interval.loc interval) with
+          | n when n > 0 -> (interval :: to_left, to_overlap, to_right)
+          | n when n < 0 -> (to_left, to_overlap, interval :: to_right)
+          | _ -> (to_left, interval :: to_overlap, to_right))
+        lst ([], [], [])
+    in
+    let left = of_alist_helper to_left in
+    let right = of_alist_helper to_right in
+    let intervals = to_overlap in
+    Node { center = median; left; right; intervals }
+
+let of_alist lst =
+  lst
+  (* Sorting using [Interval.compare_loc] does not guarantee a well-balanced interval tree
+     construction on all possible inputs because [Interval.compare_loc] compares
+     [loc_start] first, then compares [loc_end]. However, because this is used only by
+     [Overrides.t] which typically handles disjoint and sparse [Location.t] ranges, this
+     sorting should be a good heuristic. *)
+  |> List.stable_sort Interval.compare_loc
+  |> of_alist_helper
diff --git a/src/analysis/overrides_interval_tree.mli b/src/analysis/overrides_interval_tree.mli
@@ -0,0 +1,31 @@
+(** This interval tree is an immutable data structure that stores mappings from integer
+    intervals to values ['a] and allows efficient queries for intervals that contain a
+    given point.
+
+    This is the minimal interface to support querying [[@@@merlin]] overrides by cursor
+    position. Common functions, such as [insert] and [delete], are left unimplemented since
+    they are not necessary, but are possibly easy to include.
+
+    The general design of the data structure is on
+    {{:https://en.wikipedia.org/wiki/Interval_tree#Centered_interval_tree}this wiki page}. *)
+
+(** [Interval] contains an interval tree entry's range and payload. *)
+module Interval : sig
+  type 'a t
+
+  (** [low] and [high] are included in the range. Returns [Error] if [low] > [high] *)
+  val create : loc:Location.t -> payload:'a -> ('a t, string) result
+end
+
+type 'a t
+
+(** Find the tightest interval that contains a given position. Runs in O(logn + m)
+    where m is the number of intervals containing the point.
+
+    [find] assumes that an interval is either contained by or contains every other interval.
+    If there are multiple matching intervals of the same tightness, the interval that came
+    first in the list during construction is returned. *)
+val find : 'a t -> Lexing.position -> 'a option
+
+(** Constructs a ['a t] given a list of ['a Interval.t]. Runs in O(nlogn) time. *)
+val of_alist : 'a Interval.t list -> 'a t
diff --git a/tests/test-dirs/overrides.t b/tests/test-dirs/overrides.t
@@ -232,6 +232,24 @@ Test overrides on %swap
   }
   [merlin document] output: %swap swaps the first two arguments of a function call
 
+Test overrides on last character of %swap
+
+  $ test_merlin_overrides "2:14" "./basic.ml"
+  [merlin locate] output: {
+    "file": "$TESTCASE_ROOT/test/ppx.ml",
+    "pos": {
+      "line": 12,
+      "col": 24
+    }
+  }
+  [merlin document] output: %swap swaps the first two arguments of a function call
+
+Test overrides one character to the right of %swap
+
+  $ test_merlin_overrides "2:15" "./basic.ml"
+  [merlin locate] output: Not in environment 'f'
+  [merlin document] output: Not in environment 'f'
+
 Test overrides on @add_one
 
   $ test_merlin_overrides "3:13" "./basic.ml"

diff --git a/tests/test-units/analysis/analysis_test.ml b/tests/test-units/analysis/analysis_test.ml
@@ -0,0 +1,2 @@
+let () =
+  Alcotest.run "merlin-lib.analysis" [ Overrides_interval_tree_test.cases ]
diff --git a/tests/test-units/analysis/dune b/tests/test-units/analysis/dune
@@ -0,0 +1,4 @@
+(test
+ (name analysis_test)
+ (flags :standard -open Ocaml_parsing)
+ (libraries alcotest ocaml_parsing merlin-lib.analysis))
diff --git a/tests/test-units/analysis/overrides_interval_tree_test.ml b/tests/test-units/analysis/overrides_interval_tree_test.ml
@@ -0,0 +1,116 @@
+open Merlin_analysis
+
+let create_position pos_cnum =
+  { Lexing.pos_fname = "test.ml"; pos_lnum = 1; pos_bol = 0; pos_cnum }
+
+let create_tree intervals =
+  intervals
+  |> List.map (fun ((low, high), payload) ->
+         let loc =
+           { Location.loc_start = create_position low;
+             loc_end = create_position high;
+             loc_ghost = false
+           }
+         in
+         Result.get_ok (Overrides_interval_tree.Interval.create ~loc ~payload))
+  |> Overrides_interval_tree.of_alist
+
+let test_of_alist_exn =
+  let open Alcotest in
+  test_case "test basic list construction" `Quick (fun () ->
+      let _ : string Overrides_interval_tree.t =
+        create_tree
+          [ ((0, 1), "1");
+            ((0, 3), "2");
+            ((2, 3), "3");
+            ((0, 4), "4");
+            ((0, 10), "5");
+            ((5, 10), "6");
+            ((5, 7), "7");
+            ((8, 10), "8");
+            ((0, 2), "9")
+          ]
+      in
+      ())
+
+let test_invalid_interval =
+  let open Alcotest in
+  test_case "test creating invalid interval" `Quick (fun () ->
+      let loc =
+        { Location.loc_start = create_position 5;
+          loc_end = create_position 0;
+          loc_ghost = false
+        }
+      in
+      let interval =
+        Overrides_interval_tree.Interval.create ~loc ~payload:"invalid"
+      in
+      let is_ok = Result.is_ok interval in
+      check bool "should be equal" is_ok false)
+
+let test_find ~input ~expected =
+  (*
+    0 1 2 3 4 5 6 7 8 9 10
+    ----------e----------
+    ----d---- -----f-----
+    ---b---   --g-- --h--
+    -a- c             -i-
+   *)
+  let tree =
+    create_tree
+      [ ((0, 1), "a");
+        ((0, 3), "b");
+        ((2, 2), "c");
+        ((0, 4), "d");
+        ((0, 10), "e");
+        ((5, 10), "f");
+        ((5, 6), "g");
+        ((8, 10), "h");
+        ((9, 10), "i")
+      ]
+  in
+  let open Alcotest in
+  test_case
+    ("test find on input " ^ Int.to_string input)
+    `Quick
+    (fun () ->
+      let pos = create_position input in
+      let payload = Overrides_interval_tree.find tree pos in
+      check (option string) "should be equal" expected payload)
+
+let _test_find_first =
+  let tree = create_tree [ ((0, 4), "0"); ((2, 3), "1"); ((2, 3), "2") ] in
+  let open Alcotest in
+  test_case "test find on input with duplicate intervals" `Quick (fun () ->
+      let expected = Some "1" in
+      let pos = create_position 2 in
+      let payload = Overrides_interval_tree.find tree pos in
+      check (option string) "should be equal" expected payload)
+
+let test_find_empty =
+  let tree = create_tree [] in
+  let open Alcotest in
+  test_case "test find on empty tree" `Quick (fun () ->
+      let expected = None in
+      let pos = create_position 0 in
+      let payload = Overrides_interval_tree.find tree pos in
+      check (option string) "should be equal" expected payload)
+
+let cases =
+  ( "overrides-interval-tree",
+    [ test_of_alist_exn;
+      test_invalid_interval;
+      test_find ~input:0 ~expected:(Some "a");
+      test_find ~input:1 ~expected:(Some "a");
+      test_find ~input:2 ~expected:(Some "c");
+      test_find ~input:3 ~expected:(Some "b");
+      test_find ~input:4 ~expected:(Some "d");
+      test_find ~input:5 ~expected:(Some "g");
+      test_find ~input:6 ~expected:(Some "g");
+      test_find ~input:7 ~expected:(Some "f");
+      test_find ~input:8 ~expected:(Some "h");
+      test_find ~input:9 ~expected:(Some "i");
+      test_find ~input:10 ~expected:(Some "i");
+      test_find ~input:11 ~expected:None;
+      test_find_empty
+    ] )
diff --git a/tests/test-units/analysis/overrides_interval_tree_test.mli b/tests/test-units/analysis/overrides_interval_tree_test.mli
@@ -0,0 +1 @@
+val cases : string * unit Alcotest.test_case list
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		let () =
		Alcotest.run "merlin-lib.analysis" [ Overrides_interval_tree_test.cases ]
liam923 marked this conversation as resolved. Show resolved Hide resolved
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		val cases : string * unit Alcotest.test_case list