diff --git a/lib/kernel/comby_kernel.mli b/lib/kernel/comby_kernel.mli index 8d75dfd..1e0eff8 100644 --- a/lib/kernel/comby_kernel.mli +++ b/lib/kernel/comby_kernel.mli @@ -486,6 +486,7 @@ module Matchers : sig type options = { nested : bool + ; strict : bool } val create diff --git a/lib/kernel/matchers/alpha.ml b/lib/kernel/matchers/alpha.ml index e31094d..d6116f7 100644 --- a/lib/kernel/matchers/alpha.ml +++ b/lib/kernel/matchers/alpha.ml @@ -960,7 +960,7 @@ module Make (Lang : Types.Language.S) (Meta : Types.Metasyntax.S) (Ext : Types.E let all ?configuration ?filepath ?(rule = [Types.Ast.True]) ~template ~source:original_source () : Match.t list = let _ : string option = filepath in - let Rule.{ nested } = Rule.options rule in + let Rule.{ nested; _ } = Rule.options rule in let template, rule = Preprocess.map_aliases (module Meta) @@ -1126,7 +1126,7 @@ module Make (Lang : Types.Language.S) (Meta : Types.Metasyntax.S) (Ext : Types.E ?filepath rule env = - let Rule.{ nested } = Rule.options rule in + let Rule.{ nested; _ } = Rule.options rule in let subrule = if nested then [Types.Ast.True; Option "nested"] else [Types.Ast.True] in Evaluate.apply ?substitute_in_place diff --git a/lib/kernel/matchers/omega.ml b/lib/kernel/matchers/omega.ml index 2eb148e..61cc69a 100644 --- a/lib/kernel/matchers/omega.ml +++ b/lib/kernel/matchers/omega.ml @@ -578,6 +578,35 @@ module Make (Language : Types.Language.S) (Meta : Metasyntax.S) (Ext : External. quoted string in the template to a parser list should \ not fail here" + let loose_whitespace g = + let loose_constants direction p = + match parse_string ~consume:All p "_signal_hole" with + | Ok (Hole _, _) -> p (* Hole: let it consume spaces *) + | Ok _ + | Error _ -> + match direction, parse_string ~consume:All p " " with + | _, Ok _ -> p (* Explicit space: let this consume spaces, don't inject stuff *) + | `Left, _ -> option "" spaces1 *> p + | `Right, _ -> p <* option "" spaces1 + in + let rec aux acc i = + function + | [] -> acc + | [last] -> + let p = loose_constants `Right last in + acc @ [p] + | hd::tl when i = 0 -> + let p = loose_constants `Left hd in + aux (acc @ [p]) (i + 1) tl + | hd::tl -> + aux (acc @ [hd]) (i + 1) tl + in + match g with + | [] -> g + | [p] -> + [loose_constants `Right (loose_constants `Left p)] + | l -> aux [] 0 l + let general_parser_generator rule : (production * 'a) t t = let spaces : (production * 'a) t t = lift @@ -593,6 +622,7 @@ module Make (Language : Types.Language.S) (Meta : Metasyntax.S) (Ext : External. |> List.map ~f:(fun (sort, _) -> hole_parser sort Code) |> choice in + let strict = Option.(value ~default:false (rule >>| Rule.is_strict)) in fix (fun (generator : (production * 'a) t list t) -> if debug then Format.printf "Descends@."; let nested = @@ -604,16 +634,16 @@ module Make (Language : Types.Language.S) (Meta : Metasyntax.S) (Ext : External. if debug then Format.printf "G size: %d; delim %s@." (List.length g) left_delimiter; return @@ sequence_chain' @@ - [string left_delimiter >>= fun result -> r acc (Template_string result)] - @ g + [ string left_delimiter >>= fun result -> r acc (Template_string result)] + @ (if strict then g else loose_whitespace g) @ [ string right_delimiter >>= fun result -> r acc (Template_string result)]) in many @@ choice [ code_holes ; raw_string_literal_parser (generate_hole_for_literal Raw_string_literal ()) ; escapable_string_literal_parser (generate_hole_for_literal Escapable_string_literal ()) - ; spaces ; nested + ; spaces ; other ] >>= fun x -> @@ -738,7 +768,7 @@ module Make (Language : Types.Language.S) (Meta : Metasyntax.S) (Ext : External. filepath_ref := filepath; push_matches_ref := !matches_ref; configuration_ref := Option.value configuration ~default:!configuration_ref; - let Rule.{ nested } = Rule.options rule in + let Rule.{ nested; _ } = Rule.options rule in let template, rule = Preprocess.map_aliases (module Meta) @@ -845,8 +875,16 @@ module Make (Language : Types.Language.S) (Meta : Metasyntax.S) (Ext : External. ?filepath rule env = - let Rule.{ nested } = Rule.options rule in - let subrule = if nested then [Types.Ast.True; Option "nested"] else [Types.Ast.True] in + let Rule.{ nested; strict } = Rule.options rule in + let subrule = + let open Types.Ast in + [ True ] @ + match nested, strict with + | true, true -> [ Option "nested"; Option "strict"] + | true, false -> [ Option "nested" ] + | false, true -> [ Option "strict" ] + | _ -> [] + in Evaluate.apply ?substitute_in_place ?metasyntax diff --git a/lib/kernel/matchers/rule.ml b/lib/kernel/matchers/rule.ml index e1d48c4..6e4a463 100644 --- a/lib/kernel/matchers/rule.ml +++ b/lib/kernel/matchers/rule.ml @@ -127,7 +127,10 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st let optional_trailing c = option () (skip (Char.equal c)) let option_parser = - lift (fun _ -> Option "nested") (spaces *> (string Syntax.option_nested) <* spaces) + choice + [ lift (fun _ -> Option "nested") (spaces *> (string Syntax.option_nested) <* spaces) + ; lift (fun _ -> Option "strict") (spaces *> (string Syntax.option_strict) <* spaces) + ] let true' = lift (fun _ -> True) (spaces *> string Syntax.true' <* spaces) @@ -222,9 +225,15 @@ let create type options = { nested : bool + ; strict : bool } let options rule = - List.fold rule ~init:{ nested = false } ~f:(fun acc -> function - | Types.Ast.Option name when String.(name = Syntax.option_nested) -> { nested = true } + List.fold rule ~init:{ nested = false; strict = false } ~f:(fun acc -> function + | Types.Ast.Option name when String.(name = Syntax.option_nested) -> { acc with nested = true } + | Types.Ast.Option name when String.(name = Syntax.option_strict) -> { acc with strict = true } | _ -> acc) + +let is_strict rule = + let { strict; _ } = options rule in + strict diff --git a/lib/kernel/matchers/syntax.ml b/lib/kernel/matchers/syntax.ml index 524943d..a82d57a 100644 --- a/lib/kernel/matchers/syntax.ml +++ b/lib/kernel/matchers/syntax.ml @@ -6,6 +6,7 @@ let not_equal = "!=" let true' = "true" let false' = "false" let option_nested = "nested" +let option_strict = "strict" let pipe_operator = "|" let arrow = "->" diff --git a/test/common/dune b/test/common/dune index 5db5368..6851f2e 100644 --- a/test/common/dune +++ b/test/common/dune @@ -17,6 +17,7 @@ test_rewrite_rule test_integration test_match_rule + test_rule_options test_python_string_literals test_hole_extensions test_match_offsets diff --git a/test/common/test_rule_options.ml b/test/common/test_rule_options.ml new file mode 100644 index 0000000..603af0f --- /dev/null +++ b/test/common/test_rule_options.ml @@ -0,0 +1,48 @@ +open Core + +open Test_helpers +open Comby_kernel +open Matchers + +let%expect_test "strict_rule_no_holes" = + let source = {| +foo( bar) foo(bar) foo( bar ) foo(bar ) +foo( + bar +) +|} in + let match_template = {|foo(bar)|} in + let rewrite_template = {|>yes<|} in + let rule = "where true" in + + run (module Omega.Generic) source match_template rewrite_template ~rule; + [%expect_exact {| +>yes< >yes< >yes< >yes< +>yes< +|}]; + + let rule = "where strict" in + run (module Omega.Generic) source match_template rewrite_template ~rule; + [%expect_exact {| +foo( bar) >yes< foo( bar ) foo(bar ) +foo( + bar +) +|}] + +let%expect_test "strict_rule_with_holes" = + let source = {|foo( bar )|} in + let match_template = {|foo(:[1])|} in + let rewrite_template = {|:[1]|} in + let rule = "where true" in + + run (module Omega.Generic) source match_template rewrite_template ~rule; + [%expect_exact {| bar |}]; + + let source = {|foo( bar,x )|} in + let match_template = {|foo(bar,:[1])|} in + let rewrite_template = {|:[1]|} in + let rule = "where true" in + + run (module Omega.Generic) source match_template rewrite_template ~rule; + [%expect_exact {|x |}];