From deb923c24e24f4f29ca4a1fcc11984094e83c68c Mon Sep 17 00:00:00 2001 From: Darren Li Date: Fri, 13 Sep 2024 18:09:38 +1000 Subject: [PATCH] Added and operators --- lib/index.ml | 43 +++++++++++-- lib/search_exp.ml | 156 +++++++++++++++++++++++++++++++++++---------- lib/search_exp.mli | 7 +- 3 files changed, 169 insertions(+), 37 deletions(-) diff --git a/lib/index.ml b/lib/index.ml index e5cc8b4..75a0609 100644 --- a/lib/index.ml +++ b/lib/index.ml @@ -798,10 +798,45 @@ module Search = struct (exp : Search_exp.t) (t : t) : Search_result_heap.t = - Search_exp.flattened exp - |> List.to_seq - |> Seq.map (fun phrase -> search_single pool stop_signal ~within_same_line ~consider_edit_dist phrase t) - |> Seq.fold_left search_result_heap_merge_with_yield Search_result_heap.empty + let flattened = Search_exp.flattened exp in + let f phrase = + search_single + pool + stop_signal + ~within_same_line + ~consider_edit_dist + phrase + t + in + let hidden_phrase_collection_satisfied = + flattened.hidden + |> List.for_all (fun phrases -> + List.exists (fun phrase -> + not (Search_result_heap.is_empty (f phrase)) + ) + phrases + ) + in + if hidden_phrase_collection_satisfied then ( + let heaps = + flattened.visible + |> List.map (fun phrases -> + List.to_seq phrases + |> Seq.map f + |> Seq.fold_left search_result_heap_merge_with_yield Search_result_heap.empty + ) + in + if List.for_all (fun x -> not (Search_result_heap.is_empty x)) heaps then ( + List.fold_left + search_result_heap_merge_with_yield + Search_result_heap.empty + heaps + ) else ( + Search_result_heap.empty + ) + ) else ( + Search_result_heap.empty + ) end let search diff --git a/lib/search_exp.ml b/lib/search_exp.ml index 55c8360..2e1f546 100644 --- a/lib/search_exp.ml +++ b/lib/search_exp.ml @@ -1,14 +1,20 @@ type match_typ_marker = [ `Exact | `Prefix | `Suffix ] [@@deriving show] -type exp = [ +type exp = + | Sub of sub + | And_show_both of exp * exp + | And_hide_left of exp * exp +[@@deriving show] + +and sub = [ | `Word of string | `Match_typ_marker of match_typ_marker | `Explicit_spaces - | `List of exp list - | `Paren of exp - | `Binary_op of binary_op * exp * exp - | `Optional of exp + | `List of sub list + | `Paren of sub + | `Binary_op of binary_op * sub * sub + | `Optional of sub ] [@@deriving show] @@ -16,26 +22,46 @@ and binary_op = | Or [@@deriving show] +type flattened = { + hidden : Search_phrase.t list list; + visible : Search_phrase.t list list; +} +[@@deriving show] + type t = { exp : exp; - flattened : Search_phrase.t list; + flattened : flattened; } [@@deriving show] let flattened (t : t) = t.flattened +let empty_flattened : flattened = { + hidden = []; + visible = []; +} + +let flattened_is_empty (x : flattened) = + List.is_empty x.hidden + && + List.is_empty x.visible + let empty : t = { - exp = `List []; - flattened = []; + exp = Sub (`List []); + flattened = empty_flattened; } let is_empty (t : t) = - t.flattened = [] + flattened_is_empty t.flattened || - List.for_all Search_phrase.is_empty t.flattened + ( + List.for_all (List.for_all Search_phrase.is_empty) t.flattened.hidden + && + List.for_all (List.for_all Search_phrase.is_empty) t.flattened.visible + ) -let equal (t1 : t) (t2 : t) = - let rec aux (e1 : exp) (e2 : exp) = +let equal_sub (e1 : sub) (e2 : sub) = + let rec aux (e1 : sub) (e2 : sub) = match e1, e2 with | `Word x1, `Word x2 -> String.equal x1 x2 | `List l1, `List l2 -> List.equal aux l1 l2 @@ -45,15 +71,27 @@ let equal (t1 : t) (t2 : t) = | `Optional e1, `Optional e2 -> aux e1 e2 | _, _ -> false in + aux e1 e2 + +let equal (t1 : t) (t2 : t) = + let rec aux (e1 : exp) (e2 : exp) = + match e1, e2 with + | Sub s1, Sub s2 -> equal_sub s1 s2 + | And_show_both (x1, y1), And_show_both (x2, y2) -> + aux x1 x2 && aux y1 y2 + | And_hide_left (x1, y1), And_hide_left (x2, y2) -> + aux x1 x2 && aux y1 y2 + | _, _ -> false + in aux t1.exp t2.exp -let as_paren x : exp = `Paren x +let as_paren x : sub = `Paren x -let as_list l : exp = `List l +let as_list l : sub = `List l -let as_word s : exp = `Word s +let as_word s : sub = `Word s -let as_word_list (l : string list) : exp = `List (List.map as_word l) +let as_word_list (l : string list) : sub = `List (List.map as_word l) module Parsers = struct open Angstrom @@ -71,7 +109,8 @@ module Parsers = struct | '\'' | '^' | '$' - | '~' -> false + | '~' + | '&' -> false | _ -> true ) <|> @@ -85,8 +124,8 @@ module Parsers = struct let or_op = char '|' *> skip_spaces *> return (fun x y -> `Binary_op (Or, x, y)) - let p : exp Angstrom.t = - fix (fun (exp : exp Angstrom.t) : exp Angstrom.t -> + let sub : sub Angstrom.t = + fix (fun (sub : sub Angstrom.t) : sub Angstrom.t -> let base = choice [ (phrase >>| as_word_list); @@ -95,7 +134,7 @@ module Parsers = struct (char '$' *> return (`Match_typ_marker `Suffix)); (char '~' *> return (`Explicit_spaces)); (string "()" *> return (as_word_list [])); - (char '(' *> exp <* char ')' >>| as_paren); + (char '(' *> sub <* char ')' >>| as_paren); ] in let opt_base = @@ -119,29 +158,46 @@ module Parsers = struct chainl1 opt_bases or_op ) <* skip_spaces + + let and_show_both_op = + char '&' *> skip_spaces *> return (fun x y -> And_show_both (x, y)) + + let and_hide_left_op = + string "&>" *> skip_spaces *> return (fun x y -> And_hide_left (x, y)) + + let exp : exp Angstrom.t = + let base = sub >>| fun x -> Sub x in + chainl1 base (and_hide_left_op <|> and_show_both_op) + <* skip_spaces end let flatten_nested_lists (exp : exp) : exp = - let rec aux (exp : exp) = - match exp with + let rec aux_sub (sub : sub) = + match sub with | `Word _ | `Match_typ_marker _ - | `Explicit_spaces -> exp + | `Explicit_spaces -> sub | `List l -> ( `List (CCList.flat_map (fun e -> - match aux e with + match aux_sub e with | `List l -> l | x -> [ x ] ) l) ) - | `Paren e -> `Paren (aux e) - | `Binary_op (op, x, y) -> `Binary_op (op, aux x, aux y) - | `Optional e -> `Optional (aux e) + | `Paren e -> `Paren (aux_sub e) + | `Binary_op (op, x, y) -> `Binary_op (op, aux_sub x, aux_sub y) + | `Optional e -> `Optional (aux_sub e) + in + let rec aux (exp : exp) = + match exp with + | Sub x -> Sub (aux_sub x) + | And_show_both (x, y) -> And_show_both (aux x, aux y) + | And_hide_left (x, y) -> And_hide_left (aux x, aux y) in aux exp -let flatten (exp : exp) : Search_phrase.t list = +let flatten_sub (sub : sub) : Search_phrase.t list = let get_group_id = let counter = ref 0 in fun () -> @@ -149,8 +205,8 @@ let flatten (exp : exp) : Search_phrase.t list = counter := x + 1; x in - let rec aux group_id (exp : exp) : Search_phrase.annotated_token list Seq.t = - match exp with + let rec aux group_id (sub : sub) : Search_phrase.annotated_token list Seq.t = + match sub with | `Match_typ_marker x -> ( Seq.return [ Search_phrase.{ data = `Match_typ_marker x; group_id } @@ -183,18 +239,54 @@ let flatten (exp : exp) : Search_phrase.t list = Seq.cons [] (aux (get_group_id ()) x) ) in - aux (get_group_id ()) exp + aux (get_group_id ()) sub |> Seq.map (fun l -> List.to_seq l |> Search_phrase.of_annotated_tokens) |> List.of_seq |> List.sort_uniq Search_phrase.compare +let flatten (exp : exp) : flattened = + let rec aux (exp : exp) = + match exp with + | Sub sub -> ( + let l = flatten_sub sub in + { hidden = []; visible = [ l ] } + ) + | And_show_both (x, y) -> ( + let flattened_x = aux x in + let flattened_y = aux y in + { + hidden = List.flatten [ + flattened_x.hidden; + flattened_y.hidden; + ]; + visible = List.flatten [ + flattened_x.visible; + flattened_y.visible; + ] + } + ) + | And_hide_left (x, y) -> ( + let flattened_x = aux x in + let flattened_y = aux y in + { + hidden = List.flatten [ + flattened_x.hidden; + flattened_x.visible; + flattened_y.hidden; + ]; + visible = flattened_y.visible; + } + ) + in + aux exp + let make s = if String.length s = 0 || String.for_all Parser_components.is_space s then ( Some empty ) else ( - match Angstrom.(parse_string ~consume:Consume.All) Parsers.p s with + match Angstrom.(parse_string ~consume:Consume.All) Parsers.exp s with | Ok exp -> ( let exp = flatten_nested_lists exp in Some diff --git a/lib/search_exp.mli b/lib/search_exp.mli index f2a7f06..92e0d54 100644 --- a/lib/search_exp.mli +++ b/lib/search_exp.mli @@ -1,12 +1,17 @@ type t +type flattened = { + hidden : Search_phrase.t list list; + visible : Search_phrase.t list list; +} + val pp : Format.formatter -> t -> unit val empty : t val is_empty : t -> bool -val flattened : t -> Search_phrase.t list +val flattened : t -> flattened val make : string -> t option