From b1e29ce3390534e39df21dd7b9b750fd8d13a1db Mon Sep 17 00:00:00 2001 From: Rijnard van Tonder Date: Sat, 10 Apr 2021 19:36:59 -0700 Subject: [PATCH] simple script parser and rule syntax additions (#273) --- lib/app/comby.ml | 2 +- .../configuration/command_configuration.ml | 50 ++--- lib/kernel/comby_kernel.ml | 3 +- lib/kernel/language/alpha_parser.ml | 25 --- lib/kernel/language/alpha_rule.ml | 82 -------- lib/kernel/language/ast.ml | 28 +++ lib/kernel/language/omega_parser.ml | 47 ----- lib/kernel/language/omega_rule.ml | 90 +------- lib/kernel/language/parser.ml | 195 +++++++++++++++++ lib/kernel/language/rule.ml | 2 + lib/kernel/language/rule.mli | 4 + lib/kernel/language/script.ml | 59 ++++++ lib/kernel/language/syntax.ml | 2 + lib/kernel/language/types.ml | 4 - test/alpha/test_regex_holes.ml | 4 +- test/common/dune | 4 +- test/common/test_alpha.ml | 1 + test/common/test_go_alpha.ml | 2 +- test/common/test_go_omega.ml | 2 +- test/common/test_match_rule_alpha.ml | 93 ++------- test/common/test_match_rule_omega.ml | 93 ++------- test/common/test_nested_matches_alpha.ml | 2 +- test/common/test_nested_matches_omega.ml | 2 +- test/common/test_omega.ml | 1 + test/common/test_parse_rule.ml | 196 ++++++++++++++++++ test/common/test_rewrite_rule_alpha.ml | 32 ++- test/common/test_rewrite_rule_omega.ml | 32 ++- test/common/test_script.ml | 101 +++++++++ test/common/test_statistics.ml | 2 +- 29 files changed, 712 insertions(+), 448 deletions(-) delete mode 100644 lib/kernel/language/alpha_parser.ml delete mode 100644 lib/kernel/language/omega_parser.ml create mode 100644 lib/kernel/language/parser.ml create mode 100644 lib/kernel/language/script.ml create mode 100644 test/common/test_parse_rule.ml create mode 100644 test/common/test_script.ml diff --git a/lib/app/comby.ml b/lib/app/comby.ml index f390182..1691150 100644 --- a/lib/app/comby.ml +++ b/lib/app/comby.ml @@ -27,7 +27,7 @@ module Rule = struct let sat = Rule.Alpha.sat let result_env = Rule.Alpha.result_env - let create = Rule.Alpha.create + let create = Rule.create let apply = Rule.Alpha.apply end type rule = Rule.t diff --git a/lib/app/configuration/command_configuration.ml b/lib/app/configuration/command_configuration.ml index 7f969ab..3d1e2c0 100644 --- a/lib/app/configuration/command_configuration.ml +++ b/lib/app/configuration/command_configuration.ml @@ -1,5 +1,4 @@ open Core -open Toml open Camlzip open Polymorphic_compare @@ -105,23 +104,17 @@ let read filename = String.chop_suffix template ~suffix:"\n" |> Option.value ~default:template -let create_rule omega rule = - let create = - if omega then - Rule.Omega.create - else - Rule.Alpha.create - in - match Option.map rule ~f:create with +let create_rule rule = + match Option.map rule ~f:Rule.create with | None -> None | Some Ok rule -> Some rule | Some Error error -> Format.eprintf "Rule parse error: %s@." (Error.to_string_hum error); exit 1 -let parse_toml omega path = +let parse_toml path = let open Toml.Types in - let toml = Parser.(from_filename path |> unsafe) in + let toml = Toml.Parser.(from_filename path |> unsafe) in let toml = Table.remove (Toml.Min.key "flags") toml in let to_specification (key : Table.key) (value : Toml.Types.value) acc = let name = Table.Key.to_string key in @@ -142,7 +135,7 @@ let parse_toml omega path = Format.eprintf "A 'match' key is required for entry %s@." name; exit 1 in - let rule = Table.find_opt (Toml.Min.key "rule") t |> to_string |> create_rule omega in + let rule = Table.find_opt (Toml.Min.key "rule") t |> to_string |> create_rule in let rewrite_template = Table.find_opt (Toml.Min.key "rewrite") t |> to_string in if debug then Format.printf "Processed ->%s<-@." match_template; (name, (Specification.create ~match_template ?rule ?rewrite_template ()))::acc @@ -154,7 +147,7 @@ let parse_toml omega path = |> List.sort ~compare:(fun x y -> String.compare (fst x) (fst y)) |> List.map ~f:snd -let parse_templates ?(warn_for_missing_file_in_dir = false) omega paths = +let parse_templates ?(warn_for_missing_file_in_dir = false) paths = let parse_directory path = let read_optional filename = match read filename with @@ -166,7 +159,7 @@ let parse_templates ?(warn_for_missing_file_in_dir = false) omega paths = if warn_for_missing_file_in_dir then Format.eprintf "WARNING: Could not read required match file in %s@." path; None | Some match_template -> - let rule = create_rule omega @@ read_optional (path ^/ "rule") in + let rule = create_rule @@ read_optional (path ^/ "rule") in let rewrite_template = read_optional (path ^/ "rewrite") in Specification.create ~match_template ?rule ?rewrite_template () |> Option.some @@ -188,7 +181,7 @@ let parse_templates ?(warn_for_missing_file_in_dir = false) omega paths = if Sys.is_directory path = `Yes then fold_directory path ~sorted:true ~init:[] ~f else - parse_toml omega path) + parse_toml path) type interactive_review = { editor : string @@ -444,7 +437,7 @@ type t = ; metasyntax : Matchers.Metasyntax.t option } -let emit_errors { input_options; run_options; output_options } = +let emit_errors { input_options; output_options; _ } = let error_on = [ input_options.stdin && Option.is_some input_options.zip_file , "-zip may not be used with -stdin." @@ -492,7 +485,7 @@ let emit_errors { input_options; run_options; output_options } = | Some inputs -> List.find_map inputs ~f:(fun input -> if Sys.is_file input = `Yes then - (match Parser.from_filename input with + (match Toml.Parser.from_filename input with | `Error (s, _) -> Some s | _ -> None) else if not (Sys.is_directory input = `Yes) then @@ -506,12 +499,7 @@ let emit_errors { input_options; run_options; output_options } = Option.value_exn message else "UNREACHABLE") - ; (let result = - if run_options.omega then - Rule.Omega.create input_options.rule - else - Rule.Alpha.create input_options.rule - in + ; (let result = Rule.create input_options.rule in Or_error.is_error result , if Or_error.is_error result then Format.sprintf "Match rule parse error: %s@." @@ @@ -540,14 +528,14 @@ let emit_errors { input_options; run_options; output_options } = in Error.of_string message) -let emit_warnings { input_options; run_options; output_options } = +let emit_warnings { input_options; output_options; _ } = let warn_on = [ (let match_templates = match input_options.templates, input_options.anonymous_arguments with | None, Some { match_template; _ } -> [ match_template ] | Some templates, _ -> - List.map (parse_templates run_options.omega templates) ~f:(fun { match_template; _ } -> match_template) + List.map (parse_templates templates) ~f:(fun { match_template; _ } -> match_template) | _ -> assert false in List.exists match_templates ~f:(fun match_template -> @@ -744,14 +732,8 @@ let create emit_errors configuration >>= fun () -> emit_warnings configuration >>= fun () -> let rule = - let create = - if omega then - Rule.Omega.create - else - Rule.Alpha.create - in let rule = String.substr_replace_all rule ~pattern:"..." ~with_:":[_]" in - create rule |> Or_error.ok_exn + Rule.create rule |> Or_error.ok_exn in let specifications = match templates, anonymous_arguments with @@ -761,7 +743,7 @@ let create else [ Specification.create ~match_template ~rewrite_template ~rule () ] | Some templates, _ -> - parse_templates ~warn_for_missing_file_in_dir:true omega templates + parse_templates ~warn_for_missing_file_in_dir:true templates | _ -> assert false in let specifications = @@ -771,7 +753,7 @@ let create in let specifications = if match_only then - List.map specifications ~f:(fun {match_template; rule; _ } -> + List.map specifications ~f:(fun { match_template; rule; _ } -> Specification.create ~match_template ?rule ()) else specifications diff --git a/lib/kernel/comby_kernel.ml b/lib/kernel/comby_kernel.ml index 3912365..0fc5e17 100644 --- a/lib/kernel/comby_kernel.ml +++ b/lib/kernel/comby_kernel.ml @@ -27,9 +27,10 @@ module Rule = struct let sat = Rule.Alpha.sat let result_env = Rule.Alpha.result_env - let create = Rule.Alpha.create + let create = Rule.create let apply = Rule.Alpha.apply end + type rule = Rule.t module Replacement = Replacement diff --git a/lib/kernel/language/alpha_parser.ml b/lib/kernel/language/alpha_parser.ml deleted file mode 100644 index 807980e..0000000 --- a/lib/kernel/language/alpha_parser.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Core_kernel - -open MParser -open MParser_PCRE.Tokens - -open Ast - -let variable_parser s = - (string Syntax.variable_left_delimiter - >> (many (alphanum <|> char '_') |>> String.of_char_list) - << string Syntax.variable_right_delimiter) s - -let value_parser s = - string_literal s - -let operator_parser s = - ((string Syntax.equal) - <|> (string Syntax.not_equal)) s - -let atom_parser s = - ((variable_parser >>= fun variable -> return (Variable variable)) - <|> (value_parser >>= fun value -> return (String value))) s - -let rewrite_template_parser s = - (value_parser >>= fun value -> return (RewriteTemplate value)) s diff --git a/lib/kernel/language/alpha_rule.ml b/lib/kernel/language/alpha_rule.ml index b3f5546..2596b35 100644 --- a/lib/kernel/language/alpha_rule.ml +++ b/lib/kernel/language/alpha_rule.ml @@ -1,12 +1,9 @@ open Core_kernel -open MParser -open MParser_PCRE.Tokens open Match open Rewriter open Ast -open Alpha_parser module Configuration = Matchers.Configuration @@ -167,82 +164,3 @@ let rec apply rule_match env predicate else (sat, out)) - - -let make_equality_expression operator left right = - if String.equal operator Syntax.equal then - return (Equal (left, right)) - else if - String.equal operator Syntax.not_equal then - return (Not_equal (left, right)) - else - let message = - Format.sprintf - "Unhandled operator %s. Did you mean %s or %s?" - operator - Syntax.equal - Syntax.not_equal in - fail message - -let create rule = - let operator_parser = - spaces >> atom_parser >>= fun left -> - spaces >> operator_parser >>= fun operator -> - spaces >> atom_parser << spaces >>= fun right -> - make_equality_expression operator left right << spaces - in - let true' = spaces >> string Syntax.true' << spaces |>> fun _ -> True in - let false' = spaces >> string Syntax.false' << spaces |>> fun _ -> False in - let option_parser = spaces >> string Syntax.option_nested << spaces |>> fun _ -> Option "nested" in - let rec expression_parser s = - choice - [ match_pattern_parser - ; rewrite_pattern_parser - (* string literals are ambiguous, so attempt to parse operator first *) - ; attempt operator_parser - ; true' - ; false' - ; option_parser - ] - s - and match_pattern_parser s = - let case_parser : (atom * expression list, unit) parser = - spaces >> string Syntax.pipe_operator >> - spaces >> atom_parser << spaces << string Syntax.arrow << spaces >>= fun antecedent -> - spaces >> comma_sep expression_parser << spaces |>> fun consequent -> - antecedent, consequent - in - let match_pattern = - let pattern keyword = - string keyword << spaces >> atom_parser << spaces << char '{' << spaces - >>= fun atom -> - many1 case_parser - << char '}' << spaces - >>= fun cases -> return (atom, cases) - in - pattern Syntax.start_match_pattern |>> fun (atom, cases) -> - Match (atom, cases) - in - match_pattern s - and rewrite_pattern_parser s = - let rewrite_pattern = - string Syntax.start_rewrite_pattern << spaces >> atom_parser << spaces << char '{' << spaces - >>= fun atom -> - atom_parser << spaces << string Syntax.arrow << spaces >>= fun match_template -> - spaces >> rewrite_template_parser << char '}' << spaces - |>> fun rewrite_template -> - Rewrite (atom, (match_template, rewrite_template)) - in - rewrite_pattern s - in - let rule_parser s = - (spaces - >> string Syntax.rule_prefix - >> spaces1 - >> comma_sep1 expression_parser - << eof) - s - in - match parse_string rule_parser rule () with - | Success rule -> Ok rule - | Failed (error, _) -> Or_error.error_string error diff --git a/lib/kernel/language/ast.ml b/lib/kernel/language/ast.ml index 5af5471..838b37f 100644 --- a/lib/kernel/language/ast.ml +++ b/lib/kernel/language/ast.ml @@ -26,3 +26,31 @@ let (<>) left right = Not_equal (left, right) type t = expression list [@@deriving sexp] + +module Script = struct + module Specification = struct + type t = + { match_template : string + ; rule : expression list option + ; rewrite_template : string option + } + [@@deriving sexp] + end + + type spec = Specification.t + [@@deriving sexp] + + type op = + | And + | Or + | Not + [@@deriving sexp] + + type exp = + | Exp of op * exp list + | Spec of spec + [@@deriving sexp] + + type t = exp list + [@@deriving sexp] +end diff --git a/lib/kernel/language/omega_parser.ml b/lib/kernel/language/omega_parser.ml deleted file mode 100644 index 2ff854a..0000000 --- a/lib/kernel/language/omega_parser.ml +++ /dev/null @@ -1,47 +0,0 @@ -open Core_kernel - -open Angstrom - -open Ast - -let (|>>) p f = - p >>= fun x -> return (f x) - -let alphanum = - satisfy (function - | 'a' .. 'z' - | 'A' .. 'Z' - | '0' .. '9' -> true - | _ -> false) - -let variable_parser = - (string Syntax.variable_left_delimiter - *> (many (alphanum <|> char '_') |>> String.of_char_list) - <* string Syntax.variable_right_delimiter) - -let escaped_char_s = - any_char - -let char_token_s = - (char '\\' *> escaped_char_s >>= fun c -> return (Format.sprintf {|\%c|} c)) - <|> (any_char |>> String.of_char) - -let value_parser = - (string {|"|} - *> (many_till char_token_s (string {|"|}))) - |>> String.concat - -let operator_parser = - choice - [ string Syntax.equal - ; string Syntax.not_equal - ] - -let atom_parser = - choice - [ (variable_parser >>= fun variable -> return (Variable variable)) - ; (value_parser >>= fun value -> return (String value)) - ] - -let rewrite_template_parser = - value_parser >>= fun value -> return (RewriteTemplate value) diff --git a/lib/kernel/language/omega_rule.ml b/lib/kernel/language/omega_rule.ml index 0662750..9a089f1 100644 --- a/lib/kernel/language/omega_rule.ml +++ b/lib/kernel/language/omega_rule.ml @@ -1,11 +1,11 @@ open Core_kernel open Angstrom +open Ast + open Match open Rewriter -open Ast -open Omega_parser module Configuration = Matchers.Configuration @@ -169,89 +169,3 @@ let rec apply rule_match env predicate else (sat, out)) - - -let make_equality_expression operator left right = - if String.equal operator Syntax.equal then - return (Equal (left, right)) - else if - String.equal operator Syntax.not_equal then - return (Not_equal (left, right)) - else - let message = - Format.sprintf - "Unhandled operator %s. Did you mean %s or %s?" - operator - Syntax.equal - Syntax.not_equal in - fail message - -let is_whitespace = function - | ' ' | '\t' | '\r' | '\n' -> true - | _ -> false - -let spaces = - take_while is_whitespace >>= fun s -> - return s - -let spaces1 = - satisfy is_whitespace >>= fun c -> - take_while is_whitespace >>= fun s -> - return (Format.sprintf "%c%s" c s) - -let create rule = - let operator_parser = - spaces *> atom_parser >>= fun left -> - spaces *> operator_parser >>= fun operator -> - spaces *> atom_parser >>= fun right -> - make_equality_expression operator left right <* spaces - in - let true' = spaces *> string Syntax.true' <* spaces |>> fun _ -> True in - let false' = spaces *> string Syntax.false' <* spaces |>> fun _ -> False in - let option_parser = spaces *> string Syntax.option_nested <* spaces |>> fun _ -> Option "nested" in - let expression_parser = - fix (fun expression_parser -> - let match_pattern_parser = - let case_parser = - spaces *> string Syntax.pipe_operator *> - spaces *> atom_parser <* spaces <* string Syntax.arrow <* spaces >>= fun antecedent -> - spaces *> sep_by (char ',') expression_parser <* spaces |>> fun consequent -> - antecedent, consequent - in - let pattern keyword = - string keyword *> spaces *> atom_parser <* spaces <* char '{' <* spaces - >>= fun atom -> - many1 case_parser - <* char '}' <* spaces - >>= fun cases -> return (atom, cases) - in - pattern Syntax.start_match_pattern |>> fun (atom, cases) -> - Match (atom, cases) - in - let rewrite_pattern_parser = - string Syntax.start_rewrite_pattern *> spaces *> atom_parser <* spaces <* char '{' <* spaces - >>= fun atom -> - atom_parser <* spaces <* string Syntax.arrow <* spaces >>= fun match_template -> - spaces *> rewrite_template_parser <* spaces <* char '}' <* spaces - |>> fun rewrite_template -> - Rewrite (atom, (match_template, rewrite_template)) - in - choice - [ match_pattern_parser - ; rewrite_pattern_parser - ; operator_parser - ; true' - ; false' - ; option_parser - ]) - in - let rule_parser = - spaces - *> string Syntax.rule_prefix - *> spaces1 - *> sep_by1 (spaces *> char ',' <* spaces) expression_parser - <* end_of_input - in - match parse_string ~consume:All rule_parser rule with - | Ok rule -> Ok rule - | Error error -> Or_error.error_string error diff --git a/lib/kernel/language/parser.ml b/lib/kernel/language/parser.ml new file mode 100644 index 0000000..f811904 --- /dev/null +++ b/lib/kernel/language/parser.ml @@ -0,0 +1,195 @@ +open Core_kernel +open Angstrom + +open Ast + +let alphanum = + satisfy (function + | 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' -> true + | _ -> false) + +let variable_parser = + (string Syntax.variable_left_delimiter + *> (many (alphanum <|> char '_') >>| String.of_char_list) + <* string Syntax.variable_right_delimiter) + +(** Interpret escape sequences inside quotes *) +let char_token_s = + (char '\\' *> any_char >>| + function + | 'r' -> Char.to_string '\r' + | 'n' -> Char.to_string '\n' + | 't' -> Char.to_string '\t' + | '\\' -> Char.to_string '\\' + | c -> Format.sprintf {|\%c|} c) + <|> (any_char >>| String.of_char) + +(** With escape sequences *) +let quote s = + (string s *> (many_till char_token_s (string s))) + >>| String.concat + +let raw s = + (string s *> (many_till any_char (string s))) + >>| String.of_char_list + +let quoted_parser = + choice [ quote {|"|}; quote {|'|}; raw {|`|} ] + +let operator_parser = + choice + [ string Syntax.equal + ; string Syntax.not_equal + ] + +let any_char_except ~reserved = + List.fold reserved + ~init:(return `OK) + ~f:(fun acc reserved_sequence -> + option `End_of_input + (peek_string (String.length reserved_sequence) + >>= fun s -> + if String.equal s reserved_sequence then + return `Reserved_sequence + else + acc)) + >>= function + | `OK -> any_char + | `End_of_input -> any_char + | `Reserved_sequence -> fail "reserved sequence hit" + +let value_parser ~reserved () = + match reserved with + | [] -> fail "no value allowed to scan here" + | reserved -> many (any_char_except ~reserved) + +let map_special s = + if String.is_prefix s ~prefix:"~" then + Variable (Format.sprintf ":[%s]" s) + else if String.equal s "_" then + Variable ":[_]" + else + String s + +let antecedent_parser ?(reserved = []) () = + choice + [ (quoted_parser >>| fun value -> String value) + ; (value_parser ~reserved () >>| fun value -> map_special (String.of_char_list value)) + ] + +let atom_parser ?(reserved = []) () = + choice + [ (variable_parser >>| fun variable -> Variable variable) + ; (quoted_parser >>| fun value -> String value) + ; (value_parser ~reserved () >>| fun value -> String (String.of_char_list value)) + ] + +let rewrite_template_parser = + quoted_parser >>| fun value -> RewriteTemplate value + +let ignore p = + p *> return () + +let make_equality_expression left operator right = + if String.equal operator Syntax.equal then + Equal (left, right) + else + Not_equal (left, right) + +let is_whitespace = function + | ' ' | '\t' | '\r' | '\n' -> true + | _ -> false + +let spaces = + take_while is_whitespace + +let spaces1 = + satisfy is_whitespace *> + take_while is_whitespace *> + return () + +let optional_trailing c = option () (skip (Char.equal c)) + +let option_parser = spaces *> string Syntax.option_nested <* spaces >>| fun _ -> Option "nested" + +let true' = lift (fun _ -> True) (spaces *> string Syntax.true' <* spaces) + +let false' = lift (fun _ -> False) (spaces *> string Syntax.false' <* spaces) + +(** [==, !=] *) +let operator_parser = + lift3 + make_equality_expression + (spaces *> atom_parser ()) + (spaces *> operator_parser) + (spaces *> atom_parser ()) + <* spaces + +let make_rewrite_expression atom match_template rewrite_template = + Rewrite (atom, (match_template, rewrite_template)) + +let make_match_expression atom cases = + Match (atom, cases) + +(** rewrite { -> } *) +let rewrite_pattern_parser = + lift3 + make_rewrite_expression + (string Syntax.start_rewrite_pattern *> spaces *> atom_parser () <* spaces <* char '{' <* spaces) + (antecedent_parser ~reserved:[" ->"] () <* spaces <* string Syntax.arrow <* spaces) + (spaces *> rewrite_template_parser <* spaces <* char '}' <* spaces) + +(** -> atom [, ], [,] *) +let match_arrow_parser expression_parser = + both + (antecedent_parser ~reserved:[" ->"] () <* spaces <* string Syntax.arrow <* spaces) + (spaces *> sep_by (char ',') expression_parser <* spaces <* optional_trailing ',' <* spaces) + +(** [|] *) +let first_case_parser expression_parser = + spaces *> option () (ignore @@ string Syntax.pipe_operator *> spaces) *> + match_arrow_parser expression_parser + +(** | *) +let case_parser expression_parser = + spaces *> string Syntax.pipe_operator *> spaces *> + match_arrow_parser expression_parser + +(** [|] | *) +let case_block expression_parser = + first_case_parser expression_parser >>= fun case -> + many (case_parser expression_parser) >>= fun cases -> + return (case :: cases) + +(** match { } *) +let match_pattern_parser expression_parser = + string Syntax.start_match_pattern *> spaces *> + lift2 + make_match_expression + (atom_parser () <* spaces <* char '{' <* spaces) + (case_block expression_parser <* char '}' <* spaces) + +let expression_parser = + fix (fun expression_parser -> + choice + [ match_pattern_parser expression_parser + ; rewrite_pattern_parser + ; operator_parser + ; true' + ; false' + ; option_parser + ]) + +(** where [,] *) +let parse = + spaces *> string Syntax.rule_prefix *> + spaces1 *> sep_by1 (spaces *> char ',' <* spaces) expression_parser + <* optional_trailing ',' + <* spaces + +let create rule = + match parse_string ~consume:All (parse <* end_of_input) rule with + | Ok rule -> Ok rule + | Error error -> Or_error.error_string error diff --git a/lib/kernel/language/rule.ml b/lib/kernel/language/rule.ml index 4bca565..fed748f 100644 --- a/lib/kernel/language/rule.ml +++ b/lib/kernel/language/rule.ml @@ -1,4 +1,6 @@ include Types +let create = Parser.create + module Alpha = Alpha_rule module Omega = Omega_rule diff --git a/lib/kernel/language/rule.mli b/lib/kernel/language/rule.mli index e3b63dd..d0c91a6 100644 --- a/lib/kernel/language/rule.mli +++ b/lib/kernel/language/rule.mli @@ -1,4 +1,8 @@ +open Core_kernel + include module type of Types +val create : string -> t Or_error.t + module Alpha : Engine module Omega : Engine diff --git a/lib/kernel/language/script.ml b/lib/kernel/language/script.ml new file mode 100644 index 0000000..6f5890d --- /dev/null +++ b/lib/kernel/language/script.ml @@ -0,0 +1,59 @@ +open Angstrom + +open Parser + +open Ast +open Script + +let ignore p = + p *> return () + +let spaces = many @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false) +let spaces1 = many1 @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false) + +let optional s = option () (ignore @@ string s) + +let chainl1 e op = + let rec parse acc = (lift2 (fun f x -> f acc x) op e >>= parse) <|> return acc in + e >>= fun init -> parse init + +let parens p = char '(' *> (p <|> return []) <* char ')' + +let spec = + let match_rewrite_parser = + both + (spaces *> atom_parser ()) + (option None (spaces *> string Syntax.arrow *> spaces *> atom_parser () >>| fun x -> Some x)) + in + match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) -> + (option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule -> + let match_template = Sexplib.Sexp.to_string_hum (sexp_of_atom match_template_atom) in + let rewrite_template = + match rewrite_template_atom with + | Some rewrite_template_atom -> Some (Sexplib.Sexp.to_string_hum (sexp_of_atom rewrite_template_atom)) + | None -> None + in + return [(Spec (Specification.{ match_template; rule; rewrite_template }))] + +let unop syntax exp_parser = + choice (List.map string syntax) *> spaces *> exp_parser >>| fun exp -> [Exp (Not, exp)] + +let binop syntax op = + spaces *> choice (List.map string syntax) *> spaces *> return (fun left right -> [Exp (op, left@right)]) + +let exp_parser = + fix (fun exp -> + let exp_parser = fix (fun exp' -> parens exp <|> unop ["NOT"; "not"] exp' <|> spec) in + let and_parser = chainl1 exp_parser @@ binop ["AND"; "and"] And in + let seq_parser = chainl1 and_parser @@ binop ["OR"; "or"] Or in + sep_by1 (spaces *> string Syntax.separator <* spaces) seq_parser >>| List.concat) + +let parser = + spaces *> optional Syntax.separator *> + exp_parser <* optional Syntax.separator <* spaces <* end_of_input + +let parse script = + parse_string ~consume:All parser script + +let to_string exp = + Sexplib.Sexp.to_string_hum (Script.sexp_of_t exp) diff --git a/lib/kernel/language/syntax.ml b/lib/kernel/language/syntax.ml index d25fb4e..cfa4f34 100644 --- a/lib/kernel/language/syntax.ml +++ b/lib/kernel/language/syntax.ml @@ -10,3 +10,5 @@ let false' = "false" let option_nested = "nested" let pipe_operator = "|" let arrow = "->" + +let separator = "---" diff --git a/lib/kernel/language/types.ml b/lib/kernel/language/types.ml index 0aa0261..de502a6 100644 --- a/lib/kernel/language/types.ml +++ b/lib/kernel/language/types.ml @@ -1,5 +1,3 @@ -open Core_kernel - open Matchers open Match @@ -16,8 +14,6 @@ module type Engine = sig val result_env : result -> environment option - val create : string -> t Or_error.t - val apply : ?matcher:(module Matcher.S) -> ?substitute_in_place:bool diff --git a/test/alpha/test_regex_holes.ml b/test/alpha/test_regex_holes.ml index f3b34e7..faba212 100644 --- a/test/alpha/test_regex_holes.ml +++ b/test/alpha/test_regex_holes.ml @@ -9,8 +9,8 @@ let configuration = Matchers.Configuration.create ~match_kind:Fuzzy () let run ?(configuration = configuration) (module M : Matchers.Matcher.S) source match_template ?rule rewrite_template = let rule = match rule with - | Some rule -> Language.Rule.Alpha.create rule |> Or_error.ok_exn - | None -> Language.Rule.Alpha.create "where true" |> Or_error.ok_exn + | Some rule -> Language.Rule.create rule |> Or_error.ok_exn + | None -> Language.Rule.create "where true" |> Or_error.ok_exn in M.all ~configuration ~template:match_template ~source () |> List.filter ~f:(fun { Match.environment; _ } -> Language.Rule.Alpha.(sat @@ apply rule environment)) diff --git a/test/common/dune b/test/common/dune index 158f540..b77a4f8 100644 --- a/test/common/dune +++ b/test/common/dune @@ -2,8 +2,9 @@ (name common_test_integration) (package comby) (modules - test_cli_helper test_helpers + test_cli_helper + test_script test_extract_regex test_alpha test_omega @@ -12,6 +13,7 @@ ; test_server test_statistics test_offset_conversion + test_parse_rule test_rewrite_rule_alpha test_rewrite_rule_omega diff --git a/test/common/test_alpha.ml b/test/common/test_alpha.ml index 2ba58c9..b668f13 100644 --- a/test/common/test_alpha.ml +++ b/test/common/test_alpha.ml @@ -1,4 +1,5 @@ open Language include Matchers.Alpha +let create = Language.Rule.create module Rule = Rule.Alpha diff --git a/test/common/test_go_alpha.ml b/test/common/test_go_alpha.ml index 4723b7c..ccb67c5 100644 --- a/test/common/test_go_alpha.ml +++ b/test/common/test_go_alpha.ml @@ -8,7 +8,7 @@ open Test_helpers include Test_alpha let run ?(rule = "where true") source match_template rewrite_template = - let rule = Rule.create rule |> Or_error.ok_exn in + let rule = Language.Rule.create rule |> Or_error.ok_exn in Go.first ~configuration match_template source |> function | Ok ({environment; _ } as result) -> diff --git a/test/common/test_go_omega.ml b/test/common/test_go_omega.ml index 968e791..dbe6c38 100644 --- a/test/common/test_go_omega.ml +++ b/test/common/test_go_omega.ml @@ -8,7 +8,7 @@ open Test_helpers include Test_omega let run ?(rule = "where true") source match_template rewrite_template = - let rule = Rule.create rule |> Or_error.ok_exn in + let rule = Language.Rule.create rule |> Or_error.ok_exn in Go.first ~configuration match_template source |> function | Ok ({environment; _ } as result) -> diff --git a/test/common/test_match_rule_alpha.ml b/test/common/test_match_rule_alpha.ml index 31eb0e1..9ece4a7 100644 --- a/test/common/test_match_rule_alpha.ml +++ b/test/common/test_match_rule_alpha.ml @@ -1,6 +1,5 @@ open Core -open Language open Matchers open Match @@ -8,62 +7,8 @@ open Test_helpers include Test_alpha -let rule_parses rule = - match Rule.create rule with - | Ok _ -> "true" - | Error _ -> "false" - -let%expect_test "parse_rule" = - let rule = {| where :[1] == :[2], :[3] == "y" |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}]; - - let rule = {| where :[1] == :[2], :[3] != "x" |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}]; - - let rule = {| where :[1] != :[3] |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}] - -let%expect_test "parse_basic" = - Rule.create {|where "a" == "a"|} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact {|(rule ((Equal (String a) (String a)))) -|}] - -let%expect_test "parse_option_nested" = - Rule.create {|where nested, "a" == "a" |} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact {|(rule ((Option nested) (Equal (String a) (String a)))) -|}] - -let%expect_test "parse_match_one_case" = - Rule.create {|where match "match_me" { | "case_one" -> true }|} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact "(rule ((Match (String match_me) (((String case_one) (True)))))) -"] - -let%expect_test "parse_match_multi_case" = - Rule.create - {| where - match "match_me" { - | "case_one" -> true - | "case_two" -> false - } - |} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact "(rule - ((Match (String match_me) - (((String case_one) (True)) ((String case_two) (False)))))) -"] - let sat ?(env = Environment.create ()) rule = - let rule = Rule.create rule |> Or_error.ok_exn in + let rule = create rule |> Or_error.ok_exn in Format.sprintf "%b" (Rule.(sat @@ apply rule env)) let make_env bindings = @@ -146,7 +91,7 @@ let%expect_test "where_true" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -195,7 +140,7 @@ let%expect_test "match_sat" = | ":[_],:[_]" -> false } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -211,7 +156,7 @@ let%expect_test "match_sat" = | ":[_],:[_]" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -254,7 +199,7 @@ let%expect_test "match_sat" = | ":[_]" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -290,7 +235,7 @@ let%expect_test "match_sat" = | ":[_]" -> :[1] == "a" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -325,7 +270,7 @@ let%expect_test "match_sat" = | ":[_]" -> :[1] == "b" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -344,7 +289,7 @@ let%expect_test "match_s_suffix" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -380,7 +325,7 @@ let%expect_test "match_s_suffix" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -418,7 +363,7 @@ let%expect_test "configuration_choice_based_on_case" = | "ame" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -437,7 +382,7 @@ let%expect_test "configuration_choice_based_on_case" = | "names" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -474,7 +419,7 @@ let%expect_test "configuration_choice_based_on_case" = | "names" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -495,7 +440,7 @@ let%expect_test "match_using_environment_merge" = let rule = {| where match :[1] { | "{ :[x] : :[y] }" -> :[x] == :[y] } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -530,7 +475,7 @@ let%expect_test "match_using_environment_merge" = let rule = {| where match :[1] { | "{ :[x] : :[y] }" -> :[x] == :[y] } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -555,7 +500,7 @@ let%expect_test "nested_matches" = } } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -596,7 +541,7 @@ let%expect_test "nested_matches" = } } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -617,7 +562,7 @@ let%expect_test "match_on_template" = | "poodles" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -654,7 +599,7 @@ let%expect_test "match_on_template" = | "poodles" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -691,7 +636,7 @@ let%expect_test "match_on_template" = | "poodle" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in diff --git a/test/common/test_match_rule_omega.ml b/test/common/test_match_rule_omega.ml index ec0aa64..7746399 100644 --- a/test/common/test_match_rule_omega.ml +++ b/test/common/test_match_rule_omega.ml @@ -1,6 +1,5 @@ open Core -open Language open Matchers open Match @@ -8,62 +7,8 @@ open Test_helpers include Test_omega -let rule_parses rule = - match Rule.create rule with - | Ok _ -> "true" - | Error _ -> "false" - -let%expect_test "parse_rule" = - let rule = {| where :[1] == :[2], :[3] == "y" |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}]; - - let rule = {| where :[1] == :[2], :[3] != "x" |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}]; - - let rule = {| where :[1] != :[3] |} in - rule_parses rule |> print_string; - [%expect_exact {|true|}] - -let%expect_test "parse_basic" = - Rule.create {|where "a" == "a"|} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact {|(rule ((Equal (String a) (String a)))) -|}] - -let%expect_test "parse_option_nested" = - Rule.create {|where nested, "a" == "a" |} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact {|(rule ((Option nested) (Equal (String a) (String a)))) -|}] - -let%expect_test "parse_match_one_case" = - Rule.create {|where match "match_me" { | "case_one" -> true }|} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact "(rule ((Match (String match_me) (((String case_one) (True)))))) -"] - -let%expect_test "parse_match_multi_case" = - Rule.create - {| where - match "match_me" { - | "case_one" -> true - | "case_two" -> false - } - |} - |> Or_error.ok_exn - |> fun rule -> print_s [%message (rule : Ast.expression list)]; - [%expect_exact "(rule - ((Match (String match_me) - (((String case_one) (True)) ((String case_two) (False)))))) -"] - let sat ?(env = Environment.create ()) rule = - let rule = Rule.create rule |> Or_error.ok_exn in + let rule = create rule |> Or_error.ok_exn in Format.sprintf "%b" (Rule.(sat @@ apply rule env)) let make_env bindings = @@ -146,7 +91,7 @@ let%expect_test "where_true" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -195,7 +140,7 @@ let%expect_test "match_sat" = | ":[_],:[_]" -> false } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -211,7 +156,7 @@ let%expect_test "match_sat" = | ":[_],:[_]" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -254,7 +199,7 @@ let%expect_test "match_sat" = | ":[_]" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -290,7 +235,7 @@ let%expect_test "match_sat" = | ":[_]" -> :[1] == "a" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -325,7 +270,7 @@ let%expect_test "match_sat" = | ":[_]" -> :[1] == "b" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -344,7 +289,7 @@ let%expect_test "match_s_suffix" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -380,7 +325,7 @@ let%expect_test "match_s_suffix" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -418,7 +363,7 @@ let%expect_test "configuration_choice_based_on_case" = | "ame" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -437,7 +382,7 @@ let%expect_test "configuration_choice_based_on_case" = | "names" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -474,7 +419,7 @@ let%expect_test "configuration_choice_based_on_case" = | "names" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -495,7 +440,7 @@ let%expect_test "match_using_environment_merge" = let rule = {| where match :[1] { | "{ :[x] : :[y] }" -> :[x] == :[y] } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -530,7 +475,7 @@ let%expect_test "match_using_environment_merge" = let rule = {| where match :[1] { | "{ :[x] : :[y] }" -> :[x] == :[y] } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -555,7 +500,7 @@ let%expect_test "nested_matches" = } } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -596,7 +541,7 @@ let%expect_test "nested_matches" = } } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -617,7 +562,7 @@ let%expect_test "match_on_template" = | "poodles" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -654,7 +599,7 @@ let%expect_test "match_on_template" = | "poodles" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -691,7 +636,7 @@ let%expect_test "match_on_template" = | "poodle" -> true } |} - |> Rule.create + |> create |> Or_error.ok_exn in diff --git a/test/common/test_nested_matches_alpha.ml b/test/common/test_nested_matches_alpha.ml index 233b2d9..e4549df 100644 --- a/test/common/test_nested_matches_alpha.ml +++ b/test/common/test_nested_matches_alpha.ml @@ -16,7 +16,7 @@ let run match rule with | None -> true | Some rule -> - let options = Rule.create rule |> Or_error.ok_exn |> Rule.options in + let options = create rule |> Or_error.ok_exn |> Rule.options in options.nested in M.all ~configuration ~nested ~template:match_template ~source () diff --git a/test/common/test_nested_matches_omega.ml b/test/common/test_nested_matches_omega.ml index 3f0c08c..8e5e73f 100644 --- a/test/common/test_nested_matches_omega.ml +++ b/test/common/test_nested_matches_omega.ml @@ -16,7 +16,7 @@ let run match rule with | None -> true | Some rule -> - let options = Rule.create rule |> Or_error.ok_exn |> Rule.options in + let options = create rule |> Or_error.ok_exn |> Rule.options in options.nested in M.all ~configuration ~nested ~template:match_template ~source () diff --git a/test/common/test_omega.ml b/test/common/test_omega.ml index 7b8cb46..0bb0459 100644 --- a/test/common/test_omega.ml +++ b/test/common/test_omega.ml @@ -1,4 +1,5 @@ open Language include Matchers.Omega +let create = Language.Rule.create module Rule = Rule.Omega diff --git a/test/common/test_parse_rule.ml b/test/common/test_parse_rule.ml new file mode 100644 index 0000000..5661b20 --- /dev/null +++ b/test/common/test_parse_rule.ml @@ -0,0 +1,196 @@ +open Core + +open Language + +let rule_parses rule = + match Rule.create rule with + | Ok _ -> "true" + | Error _ -> "false" + +let%expect_test "parse_rule" = + let rule = {| where :[1] == :[2], :[3] == "y" |} in + rule_parses rule |> print_string; + [%expect_exact {|true|}]; + + let rule = {| where :[1] == :[2], :[3] != "x" |} in + rule_parses rule |> print_string; + [%expect_exact {|true|}]; + + let rule = {| where :[1] != :[3] |} in + rule_parses rule |> print_string; + [%expect_exact {|true|}]; + + let rule = {| where :[1] != :[3], |} in + rule_parses rule |> print_string; + [%expect_exact {|true|}] + +let%expect_test "parse_basic" = + Rule.create {|where "a" == "a"|} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact {|(rule ((Equal (String a) (String a)))) +|}] + +let%expect_test "parse_option_nested" = + Rule.create {|where nested, "a" == "a" |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact {|(rule ((Option nested) (Equal (String a) (String a)))) +|}] + +let%expect_test "parse_match_one_case" = + Rule.create {|where match "match_me" { | "case_one" -> true }|} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule ((Match (String match_me) (((String case_one) (True)))))) +"] + +let%expect_test "parse_match_multi_case" = + Rule.create + {| where + match "match_me" { + | "case_one" -> true + | "case_two" -> false + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String case_one) (True)) ((String case_two) (False)))))) +"] + +let%expect_test "parse_case_optional_trailing" = + Rule.create + {| where + match "match_me" { + | "case_one" -> true, + | "case_two" -> false + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String case_one) (True)) ((String case_two) (False)))))) +"] + +let%expect_test "parse_case_optional_trailing" = + Rule.create + {| where + match "match_me" { + | "case_one" -> true, + | "case_two" -> false + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String case_one) (True)) ((String case_two) (False)))))) +"] + +let%expect_test "parse_freeform_antecedent_pattern" = + Rule.create + {| where + match "match_me" { + | case one -> true, + | case two -> false + | :[template] :[example] -> false + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String \"case one\") (True)) ((String \"case two\") (False)) + ((String \":[template] :[example]\") (False)))))) +"] + +let%expect_test "optional_first_pipe_one_case" = + Rule.create + {| + where match "match_me" { thing -> true, } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule ((Match (String match_me) (((String thing) (True)))))) +"] + +let%expect_test "optional_first_pipe_multiple_cases" = + Rule.create + {| + where match "match_me" { thing -> true, | other -> true } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) (((String thing) (True)) ((String other) (True)))))) +"] + +let%expect_test "parse_freeform_antecedent_pattern_single_quote" = + Rule.create + {| + where match "match_me" { + '"ni\'ce"' -> true + | `multi +line +` -> true + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String \"\\\"ni\\\\'ce\\\"\") (True)) ((String \"multi\\ + \\nline\\ + \\n\") (True)))))) +"] + +let%expect_test "parse_freeform_antecedent_pattern_map_regex" = + Rule.create + {| where + match "match_me" { + | ~match_me -> true, + | _ -> false, + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((Variable :[~match_me]) (True)) ((Variable :[_]) (False)))))) +"] + +let%expect_test "parse_regex_hole" = + Rule.create + {| + where match :[1] { + | ":[~^\\d+$]" -> false + | ":[_]" -> true + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (Variable 1) + (((String \":[~^\\\\d+$]\") (False)) ((String :[_]) (True)))))) +"] + +let%expect_test "parse_interpreting_escapes" = + Rule.create + {| where + match "match_me" { + | "\n\\" -> true, + | `a\n\heh +b` -> false, + } + |} + |> Or_error.ok_exn + |> fun rule -> print_s [%message (rule : Ast.expression list)]; + [%expect_exact "(rule + ((Match (String match_me) + (((String \"\\ + \\n\\\\\") (True)) ((String \"a\\\\n\\\\heh\\ + \\nb\") (False)))))) +"] diff --git a/test/common/test_rewrite_rule_alpha.ml b/test/common/test_rewrite_rule_alpha.ml index 51a9efe..b0c8ee6 100644 --- a/test/common/test_rewrite_rule_alpha.ml +++ b/test/common/test_rewrite_rule_alpha.ml @@ -34,7 +34,7 @@ let%expect_test "rewrite_rule" = {| where rewrite :[1] { "int" -> "expect" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -52,7 +52,7 @@ let%expect_test "sequenced_rewrite_rule" = rewrite :[a] { "a" -> "qqq" }, rewrite :[rest] { "{ b : { :[other] } }" -> "{ :[other] }" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -68,7 +68,7 @@ let%expect_test "rewrite_rule_for_list" = {| where rewrite :[contents] { ":[[x]]," -> ":[[x]];" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -84,7 +84,7 @@ let%expect_test "rewrite_rule_for_list_strip_last" = {| where rewrite :[contents] { ":[x], " -> ":[x]; " } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -105,7 +105,7 @@ let%expect_test "haskell_example" = {| where rewrite :[contents] { "," -> "++" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -115,3 +115,25 @@ let%expect_test "haskell_example" = ++ "blah" ) |}] + +let%expect_test "rewrite_freeform_antecedent_pattern" = + let source = {| + (concat + [ "blah blah blah" + , "blah" + ]) +|} in + let match_template = {|:[contents]|} in + let rewrite_template = {|(:[contents])|} in + let rule = + {| + where rewrite :[contents] { concat [:[x]] -> "nice" } + |} + |> create + |> Or_error.ok_exn + in + + run_rule source match_template rewrite_template rule; + [%expect_exact {|( + (nice) +)|}] diff --git a/test/common/test_rewrite_rule_omega.ml b/test/common/test_rewrite_rule_omega.ml index 508066a..4ef6f76 100644 --- a/test/common/test_rewrite_rule_omega.ml +++ b/test/common/test_rewrite_rule_omega.ml @@ -34,7 +34,7 @@ let%expect_test "rewrite_rule" = {| where rewrite :[1] { "int" -> "expect" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -52,7 +52,7 @@ let%expect_test "sequenced_rewrite_rule" = rewrite :[a] { "a" -> "qqq" }, rewrite :[rest] { "{ b : { :[other] } }" -> "{ :[other] }" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -68,7 +68,7 @@ let%expect_test "rewrite_rule_for_list" = {| where rewrite :[contents] { ":[[x]]," -> ":[[x]];" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -84,7 +84,7 @@ let%expect_test "rewrite_rule_for_list_strip_last" = {| where rewrite :[contents] { ":[x], " -> ":[x]; " } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -105,7 +105,7 @@ let%expect_test "haskell_example" = {| where rewrite :[contents] { "," -> "++" } |} - |> Rule.create + |> create |> Or_error.ok_exn in @@ -115,3 +115,25 @@ let%expect_test "haskell_example" = ++ "blah" ) |}] + +let%expect_test "rewrite_freeform_antecedent_pattern" = + let source = {| + (concat + [ "blah blah blah" + , "blah" + ]) +|} in + let match_template = {|:[contents]|} in + let rewrite_template = {|(:[contents])|} in + let rule = + {| + where rewrite :[contents] { concat [:[x]] -> "nice" } + |} + |> create + |> Or_error.ok_exn + in + + run_rule source match_template rewrite_template rule; + [%expect_exact {|( + (nice) +)|}] diff --git a/test/common/test_script.ml b/test/common/test_script.ml new file mode 100644 index 0000000..6029371 --- /dev/null +++ b/test/common/test_script.ml @@ -0,0 +1,101 @@ +let run input = + let result = + match Language.Script.parse input with + | Ok result -> Language.Script.to_string result + | Error _ -> "ERROR" + in + print_string result + +let%expect_test "test_script_basic_sequence" = + let script = {|:[x] -> :[y] where nested---|} in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))))|}]; + + let script = {|:[x] -> :[y] where nested --- |} in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))))|}]; + + let script = {|:[x] -> :[y] where nested|} in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))))|}]; + + let script = {| + :[x] -> :[y] where nested --- + :[x] -> :[y] where nested + |} + in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))) + (Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))))|}] + +let%expect_test "test_script_optional_rewrite" = + let script = {|:[x] where nested|} in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ()))))|}]; + + let script = {|:[x] where nested--- :[y] where nested|} in + run script; + [%expect_exact {|((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ()))) + (Spec + ((match_template "(Variable y)") (rule (((Option nested)))) + (rewrite_template ()))))|}] + +let%expect_test "test_script_optional_rule" = + let script = {|:[x]|} in + run script; + [%expect_exact {|((Spec ((match_template "(Variable x)") (rule ()) (rewrite_template ()))))|}]; + + let script = {|:[x]--- :[y]--- :[z] -> :[q]|} in + run script; + [%expect_exact {|((Spec ((match_template "(Variable x)") (rule ()) (rewrite_template ()))) + (Spec ((match_template "(Variable y)") (rule ()) (rewrite_template ()))) + (Spec + ((match_template "(Variable z)") (rule ()) + (rewrite_template ("(Variable q)")))))|}] + +let%expect_test "test_spec_expressions" = + let script = {|:[x] -> :[y] where nested or :[y] -> :[t] where nested---|} in + run script; + [%expect_exact {|((Exp Or + ((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ("(Variable y)")))) + (Spec + ((match_template "(Variable y)") (rule (((Option nested)))) + (rewrite_template ("(Variable t)")))))))|}]; + + let script = {| + --- + :[x] where nested or :[y] -> :[t] where nested + --- + not :[x] and :[y] or :[z] + |} in + run script; + [%expect_exact {|((Exp Or + ((Spec + ((match_template "(Variable x)") (rule (((Option nested)))) + (rewrite_template ()))) + (Spec + ((match_template "(Variable y)") (rule (((Option nested)))) + (rewrite_template ("(Variable t)")))))) + (Exp Or + ((Exp And + ((Exp Not + ((Spec + ((match_template "(Variable x)") (rule ()) (rewrite_template ()))))) + (Spec ((match_template "(Variable y)") (rule ()) (rewrite_template ()))))) + (Spec ((match_template "(Variable z)") (rule ()) (rewrite_template ()))))))|}] diff --git a/test/common/test_statistics.ml b/test/common/test_statistics.ml index 2806254..fa8d476 100644 --- a/test/common/test_statistics.ml +++ b/test/common/test_statistics.ml @@ -28,7 +28,7 @@ let %expect_test "statistics" = let rule = {| where true |} - |> Rule.create + |> create |> Or_error.ok_exn in Go.all ~configuration ~template ~source ()