Ray/findall naive

findall.ml

@@ -0,0 +1,108 @@
+(** * Finding All Matches  *)
+(* Given a regex and a string, returns every non-overlapping match instead of *)
+(* only the leftmost one.                                                     *)
+(* Several algorithms can be used to do so: they are selected on the command  *)
+(* line with [-all <algorithm>] and represented by the [algo] variant below   *)
+
+open Regex
+open Bytecode
+open Compiler
+open Interpreter
+open Flags
+
+
+(** * The Find-All Algorithms  *)
+
+type algo =
+  | Naive
+  | NimReg
+
+let all_algos : algo list = [Naive; NimReg]
+let default_algo : algo = Naive
+
+let string_of_algo (a:algo) : string =
+  match a with
+  | Naive -> "naive"
+  | NimReg -> "nimreg"
+
+let algo_names : (string * algo) list =
+  List.map (fun a -> (string_of_algo a, a)) all_algos
+
+
+type match_result = int Array.t
+
+
+(** * The Find-All Engine  *)
+module type FINDALL = sig
+  val find_all : algo -> raw_regex -> string -> match_result list
+  val get_all_result : algo -> raw_regex -> string -> string
+end
+
+module FindAll (I:INTERP) : FINDALL = struct
+  (* the boundaries of the entire match (group 0) *)
+  let match_bounds (c:match_result) : (int * int) option =
+    match (I.get_op c (start_reg 0)), (I.get_op c (end_reg 0)) with
+    | Some mstart, Some mend -> Some (mstart, mend)
+    | _, _ -> None
+
+  let shift_regs (offset:int) (regs:match_result) : match_result =
+    Array.map (fun v -> if v < 0 then v else v + offset) regs
+
+  let find_all_naive (cr:compiled_regex) (str:string) : match_result list =
+    let len = String.length str in
+    let rec loop (idx:int) (acc:match_result list) : match_result list =
+      if (idx > len) then List.rev acc
+      else
+        let remaining = String.sub str idx (len - idx) in
+        if !debug then
+          Printf.printf "\027[35mFindall:\027[0m searching from %d in %S\n%!" idx remaining;
+        match I.matcher cr remaining with
+        | None -> List.rev acc      (* no match left in the suffix: we are done *)
+        | Some regs ->
+           let regs = shift_regs idx regs in
+           begin match match_bounds regs with
+           | None -> List.rev acc
+           | Some (mstart, mend) ->
+              if !verbose then
+                Printf.printf "\027[35mFindall:\027[0m match at [%d,%d[\n%!" mstart mend;
+              let next = if (mend > mstart) then mend else mend + 1 in
+              loop next (regs::acc)
+           end
+    in
+    loop 0 []
+
+
+  (** ** NimReg: TODO  *)
+  let find_all_nimreg (_cr:compiled_regex) (_str:string) : match_result list =
+    failwith "findall: algorithm 'nimreg' is not implemented yet"
+
+  let find_all (a:algo) (raw:raw_regex) (str:string) : match_result list =
+    if !verbose then
+      Printf.printf "\027[33mFind-all algorithm:\027[0m %s\n" (string_of_algo a);
+    let cr = full_compilation (annotate raw) in
+    match a with
+    | Naive -> find_all_naive cr str
+    | NimReg -> find_all_nimreg cr str
+
+  let get_all_result (a:algo) (raw:raw_regex) (str:string) : string =
+    match find_all a raw str with
+    | [] -> "NoMatch\n"
+    | l ->
+       let max_groups = max_group (annotate raw) in
+       let nb = List.length l in
+       let b = Buffer.create 256 in
+       Buffer.add_string b
+         (Printf.sprintf "%d match%s\n" nb (if nb = 1 then "" else "es"));
+       List.iteri
+         (fun i c ->
+           let position =
+             match match_bounds c with
+             | Some (mstart, mend) -> Printf.sprintf " [%d,%d]" mstart mend
+             | None -> ""
+           in
+           Buffer.add_string b (Printf.sprintf "\nMatch %d%s:\n" (i+1) position);
+           Buffer.add_string b (I.print_cap_regs c max_groups str))
+         l;
+       Buffer.contents b
+
+end

interpreter.ml

@@ -17,6 +17,8 @@ open Flags
 
 module type INTERP = sig
   val regs_name : unit -> string
+  val get_op : int array -> int -> int option
+  val print_cap_regs : int Array.t -> int -> string -> string
   val build_oracle : compiled_regex -> string -> oracle
   val build_capture : compiled_regex -> string -> oracle -> (int Array.t) option
   val matcher : compiled_regex -> string -> (int Array.t) option

main.ml

@@ -4,6 +4,7 @@ open Bytecode
 open Compiler
 open Cdn
 open Interpreter
+open Findall
 open Tojs
 open Charclasses
 open Flags
@@ -23,7 +24,9 @@ let str_set = ref false
 let rgx_set = ref false
 let compare_js = ref false
 let reg_implem = ref RegList    (* by default, use lists *)
-
+let find_all = ref false
+let all_algo = ref default_algo
+
 (* fails if the regex is not correct *)
 let parse_raw (str:string) : raw_regex =
   let r:raw_regex = Regex_parser.main Regex_lexer.token (Lexing.from_string str) in
@@ -60,6 +63,17 @@ let linear (ri:reg_impl) : raw_regex -> string -> string =
   | RegTree -> let module INT = Interpreter(Regs.Map_Regs) in
                INT.get_linear_result
 
+let linear_all (ri:reg_impl) : algo -> raw_regex -> string -> string =
+  match ri with
+  | RegArray -> let module INT = Interpreter(Regs.Array_Regs) in
+                let module ALL = Findall.FindAll(INT) in
+                ALL.get_all_result
+  | RegList -> let module INT = Interpreter(Regs.List_Regs) in
+               let module ALL = Findall.FindAll(INT) in
+               ALL.get_all_result
+  | RegTree -> let module INT = Interpreter(Regs.Map_Regs) in
+               let module ALL = Findall.FindAll(INT) in
+               ALL.get_all_result
 
 
 let main =
@@ -73,9 +87,13 @@ let main =
      ("-array", Arg.Unit (fun _ -> reg_implem := RegArray), "Use Array registers");
      ("-tree", Arg.Unit (fun _ -> reg_implem := RegTree), "Use Tree registers");
      ("-list", Arg.Unit (fun _ -> reg_implem := RegList), "Use List registers");
+     ("-all", Arg.Symbol (List.map fst algo_names,
+                          fun s -> all_algo := List.assoc s algo_names; find_all := true),
+      " Return all matches, using the given algorithm");
     ] in
 
-  let usage = "./main.native [-regex \"(b)|.*\"] [-string \"abc\"] [-v] [-d] [-cmp]" in
+  let usage = "./main.native [-regex \"(b)|.*\"] [-string \"abc\"] [-v] [-d] [-cmp] [-all "
+              ^ string_of_algo default_algo ^ "]" in
   Arg.parse speclist (fun _ -> ()) usage;
 
   (* if no regex or string were provided, ask the user to input them *)
@@ -95,5 +113,7 @@ let main =
 
   if !compare_js then
     ignore ((compare !reg_implem) regex !input_str)
+  else if !find_all then
+    Printf.printf "%s" ((linear_all !reg_implem) !all_algo regex !input_str)
   else
     Printf.printf "%s" ((linear !reg_implem) regex !input_str)