comby-tools/comby
1
1
Fork 0
mirror of https://github.com/comby-tools/comby.git synced 2024-10-04 00:34:32 +03:00
Code Issues Packages Projects Releases Wiki Activity

apply ocamlformat (#345)

Browse Source
This commit is contained in:
Rijnard van Tonder 2022-07-25 21:13:56 -07:00 committed by GitHub
parent 02c7a195f0
commit a36c63fb1e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
128 changed files with 4620 additions and 5348 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.ocamlformat Normal file
View File

@ -0,0 +1,6 @@
profile = janestreet
version = 0.24.1
margin = 100
let-binding-spacing = compact
if-then-else = fit-or-vertical

2
.ocamlformat-ignore Normal file
View File

@ -0,0 +1,2 @@
lib/app/vendored/**
lib/kernel/vendored/**

5
Makefile
View File

@ -37,7 +37,10 @@ uninstall:
promote:
@dune promote
format:
@dune build @fmt --auto-promote
docker-test-build:
docker build -t comby-local-test-build .
.PHONY: all build build-with-coverage release install doc test coverage clean uninstall promote docker-test-build
.PHONY: all build build-with-coverage release install doc test coverage clean uninstall promote format docker-test-build

8
dune
View File

@ -1,6 +1,8 @@
(env
(dev
(flags (:standard -w A-3-4-32-34-37-39-40-41-42-44-45-48-49-50-57-60-66-67-70)))
(flags
(:standard -w A-3-4-32-34-37-39-40-41-42-44-45-48-49-50-57-60-66-67-70)))
(release
(flags (:standard -w A-3-4-32-34-37-39-40-41-42-44-45-48-49-50-57-60-66-67-70))
(ocamlopt_flags (-O3))))
(flags
(:standard -w A-3-4-32-34-37-39-40-41-42-44-45-48-49-50-57-60-66-67-70))
(ocamlopt_flags (-O3))))

612
lib/app/configuration/command_configuration.ml
View File

@ -1,39 +1,32 @@
open Core
open Camlzip
open Polymorphic_compare
open Comby_kernel
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
(* skip or continue directory descent *)
type 'a next =
| Skip of 'a
| Continue of 'a
let fold_directory ?(sorted=false) root ~init ~f =
let fold_directory ?(sorted = false) root ~init ~f =
let rec aux acc absolute_path depth =
if Sys.is_file absolute_path = `Yes then
if Sys.is_file absolute_path = `Yes then (
match f acc ~depth ~absolute_path ~is_file:true with
| Continue acc
| Skip acc -> acc
else if Sys.is_directory absolute_path = `Yes then
| Continue acc | Skip acc -> acc)
else if Sys.is_directory absolute_path = `Yes then (
match f acc ~depth ~absolute_path ~is_file:false with
| Skip acc -> acc
| Continue acc ->
let dir_contents =
if Option.is_some (Sys.getenv "COMBY_TEST") || sorted then
Sys.ls_dir absolute_path
|> List.sort ~compare:String.compare
|> List.rev
Sys.ls_dir absolute_path |> List.sort ~compare:String.compare |> List.rev
else
Sys.ls_dir absolute_path
in
List.fold dir_contents ~init:acc ~f:(fun acc subdir ->
aux acc (Filename.concat absolute_path subdir) (depth + 1))
aux acc (Filename.concat absolute_path subdir) (depth + 1)))
else
acc
in
@ -41,57 +34,60 @@ let fold_directory ?(sorted=false) root ~init ~f =
aux init root (-1)
let parse_source_directories
?(file_filters = [])
exclude_directory_prefix
exclude_file_prefix
target_directory
directory_depth =
?(file_filters = [])
exclude_directory_prefix
exclude_file_prefix
target_directory
directory_depth
=
let max_depth = Option.value directory_depth ~default:Int.max_value in
let exact_file_paths, file_patterns =
List.partition_map file_filters ~f:(fun path ->
let is_exact path =
(String.contains path '/' && Sys.is_file path = `Yes)
|| (Sys.is_file ("." ^/ path) = `Yes) (* See if it matches something in the current directory *)
in
if is_exact path then Either.First path else Either.Second path)
let is_exact path =
(String.contains path '/' && Sys.is_file path = `Yes) || Sys.is_file ("." ^/ path) = `Yes
(* See if it matches something in the current directory *)
in
if is_exact path then Either.First path else Either.Second path)
in
let f acc ~depth ~absolute_path ~is_file =
if depth > max_depth then
Skip acc
else if is_file then (
match file_patterns with
| [] ->
let files =
if
List.exists exclude_file_prefix ~f:(fun prefix ->
String.is_prefix (Filename.basename absolute_path) ~prefix)
then
acc
else
absolute_path :: acc
in
Continue files
| suffixes when List.exists suffixes ~f:(fun suffix -> String.is_suffix ~suffix absolute_path)
->
let files =
if
List.exists exclude_file_prefix ~f:(fun prefix ->
String.is_prefix (Filename.basename absolute_path) ~prefix)
then
acc
else
absolute_path :: acc
in
Continue files
| _ -> Continue acc)
else if
List.exists exclude_directory_prefix ~f:(fun prefix ->
String.is_prefix (Filename.basename absolute_path) ~prefix)
then
Skip acc
else
begin
if is_file then
match file_patterns with
| [] ->
let files =
if List.exists exclude_file_prefix ~f:(fun prefix -> String.is_prefix (Filename.basename absolute_path) ~prefix) then
acc
else
absolute_path::acc
in
Continue files
| suffixes when List.exists suffixes ~f:(fun suffix -> String.is_suffix ~suffix absolute_path) ->
let files =
if List.exists exclude_file_prefix ~f:(fun prefix -> String.is_prefix (Filename.basename absolute_path) ~prefix) then
acc
else
absolute_path::acc
in
Continue files
| _ ->
Continue acc
else
begin
if List.exists exclude_directory_prefix
~f:(fun prefix -> String.is_prefix (Filename.basename absolute_path) ~prefix) then
Skip acc
else
Continue acc
end
end
Continue acc
in
let source_paths =
if not (List.is_empty file_patterns) || List.is_empty file_filters then
if (not (List.is_empty file_patterns)) || List.is_empty file_filters then
fold_directory target_directory ~init:[] ~f
else
[]
@ -100,15 +96,13 @@ let parse_source_directories
let read filename =
In_channel.read_all filename
|> fun template ->
String.chop_suffix template ~suffix:"\n"
|> Option.value ~default:template
|> fun template -> String.chop_suffix template ~suffix:"\n" |> Option.value ~default:template
let create_rule ~metasyntax rule =
match Option.map rule ~f:(Matchers.Rule.create ?metasyntax) with
| None -> None
| Some Ok rule -> Some rule
| Some Error error ->
| Some (Ok rule) -> Some rule
| Some (Error error) ->
Format.eprintf "Rule parse error: %s@." (Error.to_string_hum error);
exit 1
@ -123,7 +117,7 @@ let parse_toml ?metasyntax path =
| TTable t ->
let to_string = function
| None -> None
| Some TString s -> Some s
| Some (TString s) -> Some s
| Some v ->
Format.eprintf "TOML value not a string: %s@." (Toml.Printer.string_of_value v);
exit 1
@ -138,7 +132,7 @@ let parse_toml ?metasyntax path =
let rule = Table.find_opt (Toml.Min.key "rule") t |> to_string |> create_rule ~metasyntax 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, (Matchers.Specification.create ~match_template ?rule ?rewrite_template ()))::acc
(name, Matchers.Specification.create ~match_template ?rule ?rewrite_template ()) :: acc
| v ->
Format.eprintf "Unexpected format, could not parse ->%s<-@." (Toml.Printer.string_of_value v);
exit 1
@ -156,32 +150,32 @@ let parse_templates ?metasyntax ?(warn_for_missing_file_in_dir = false) paths =
in
match read_optional (path ^/ "match") with
| None ->
if warn_for_missing_file_in_dir then Format.eprintf "WARNING: Could not read required match file in %s@." path;
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 ~metasyntax @@ read_optional (path ^/ "rule") in
let rewrite_template = read_optional (path ^/ "rewrite") in
Matchers.Specification.create ~match_template ?rule ?rewrite_template ()
|> Option.some
Matchers.Specification.create ~match_template ?rule ?rewrite_template () |> Option.some
in
let f acc ~depth:_ ~absolute_path ~is_file =
let is_leaf_directory absolute_path =
not is_file &&
Sys.ls_dir absolute_path
|> List.for_all ~f:(fun path -> Sys.is_directory (absolute_path ^/ path) = `No)
(not is_file)
&& Sys.ls_dir absolute_path
|> List.for_all ~f:(fun path -> Sys.is_directory (absolute_path ^/ path) = `No)
in
if is_leaf_directory absolute_path then
if is_leaf_directory absolute_path then (
match parse_directory absolute_path with
| Some spec -> Continue (spec::acc)
| None -> Continue acc
| Some spec -> Continue (spec :: acc)
| None -> Continue acc)
else
Continue acc
in
List.concat_map paths ~f:(fun path ->
if Sys.is_directory path = `Yes then
fold_directory path ~sorted:true ~init:[] ~f
else
parse_toml ?metasyntax path)
if Sys.is_directory path = `Yes then
fold_directory path ~sorted:true ~init:[] ~f
else
parse_toml ?metasyntax path)
type interactive_review =
{ editor : string
@ -258,7 +252,6 @@ type input_source =
| Tar
module Printer = struct
type printable_result =
| Matches of
{ source_path : string option
@ -275,7 +268,6 @@ module Printer = struct
type t = printable_result -> unit
module Match : sig
type match_only_kind =
| Contents
| Count
@ -286,11 +278,8 @@ module Printer = struct
| Match_only of match_only_kind
val convert : output_options -> match_output
val print : match_output -> string -> string option -> Match.t list -> unit
end = struct
type match_only_kind =
| Contents
| Count
@ -302,7 +291,7 @@ module Printer = struct
let convert output_options =
match output_options with
| { chunk_matches = (Some _ as n); _ } -> Match_only (Chunk_matches n)
| { chunk_matches = Some _ as n; _ } -> Match_only (Chunk_matches n)
| { json_lines = true; _ } -> Json_lines
| { count = true; _ } -> Match_only Count
| _ -> Match_only Contents
@ -310,22 +299,18 @@ module Printer = struct
let print (match_output : match_output) source_content source_path matches =
if List.length matches = 0 then
()
else
else (
let ppf = Format.std_formatter in
match match_output with
| Match_only Contents ->
Format.fprintf ppf "%a%!" Match.pp (source_path, matches)
| Match_only Count ->
Format.fprintf ppf "%a%!" Match.pp_match_count (source_path, matches)
| Json_lines ->
Format.fprintf ppf "%a%!" Match.pp_json_lines (source_path, matches)
| Match_only Chunk_matches threshold ->
| Match_only Contents -> Format.fprintf ppf "%a%!" Match.pp (source_path, matches)
| Match_only Count -> Format.fprintf ppf "%a%!" Match.pp_match_count (source_path, matches)
| Json_lines -> Format.fprintf ppf "%a%!" Match.pp_json_lines (source_path, matches)
| Match_only (Chunk_matches threshold) ->
let chunk_matches = Match.to_chunks ?threshold source_content matches in
Format.fprintf ppf "%a%!" Match.pp_chunk_matches (source_path, chunk_matches)
Format.fprintf ppf "%a%!" Match.pp_chunk_matches (source_path, chunk_matches))
end
module Rewrite : sig
type json_kind =
| Everything
| Only_diff
@ -345,11 +330,8 @@ module Printer = struct
| Match_only
val convert : output_options -> output_format
val print : output_format -> string option -> Replacement.t list -> string -> string -> unit
end = struct
type diff_kind = Diff_configuration.kind
type json_kind =
@ -380,25 +362,27 @@ module Printer = struct
Json_lines Only_diff
else
Json_lines Everything
| { diff = true; color = false; _ } ->
Diff Plain
| { color = true; _ }
| _ ->
Diff Colored
| { diff = true; color = false; _ } -> Diff Plain
| { color = true; _ } | _ -> Diff Colored
let print output_format path replacements rewritten_source source_content =
let ppf = Format.std_formatter in
let print_if_some output = Option.value_map output ~default:() ~f:(Format.fprintf ppf "%s@.") in
let print_if_some output =
Option.value_map output ~default:() ~f:(Format.fprintf ppf "%s@.")
in
match output_format with
| Stdout ->
if not (String.equal "\n" rewritten_source) then (* FIXME: somehow newlines are entering here. *)
if not (String.equal "\n" rewritten_source) then
(* FIXME: somehow newlines are entering here. *)
Format.fprintf ppf "%s" rewritten_source
| Overwrite_file ->
if (replacements <> []) then
if replacements <> [] then
Out_channel.write_all ~data:rewritten_source (Option.value path ~default:"/dev/null")
| Interactive_review -> () (* Handled after (potentially parallel) processing *)
| Diff kind -> print_if_some @@ Diff_configuration.get_diff kind path source_content rewritten_source
| Match_only -> print_if_some @@ Diff_configuration.get_diff Match_only path rewritten_source source_content
| Diff kind ->
print_if_some @@ Diff_configuration.get_diff kind path source_content rewritten_source
| Match_only ->
print_if_some @@ Diff_configuration.get_diff Match_only path rewritten_source source_content
| Json_lines kind ->
let open Option in
let to_json diff =
@ -409,7 +393,7 @@ module Printer = struct
in
print_if_some
(Diff_configuration.get_diff Plain path source_content rewritten_source
>>| fun diff -> Yojson.Safe.to_string @@ to_json diff)
>>| fun diff -> Yojson.Safe.to_string @@ to_json diff)
end
end
@ -428,157 +412,161 @@ let parse_metasyntax metasyntax_path =
match metasyntax_path with
| None -> Matchers.Metasyntax.default_metasyntax
| Some metasyntax_path ->
match Sys.file_exists metasyntax_path with
| `No | `Unknown ->
Format.eprintf "Could not open file: %s@." metasyntax_path;
exit 1
| `Yes ->
Yojson.Safe.from_file metasyntax_path
|> Matchers.Metasyntax.of_yojson
|> function
| Ok c -> c
| Error error ->
Format.eprintf "%s@." error;
exit 1
(match Sys.file_exists metasyntax_path with
| `No | `Unknown ->
Format.eprintf "Could not open file: %s@." metasyntax_path;
exit 1
| `Yes ->
Yojson.Safe.from_file metasyntax_path
|> Matchers.Metasyntax.of_yojson
|> (function
| Ok c -> c
| Error error ->
Format.eprintf "%s@." error;
exit 1))
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."
; output_options.stdout && output_options.diff
, "-stdout may not be used with -diff. Note: -stdout outputs the changed \
file contents and -diff outputs a unified diff. Choose one of these."
; output_options.overwrite_file_in_place && is_some input_options.zip_file
, "-in-place may not be used with -zip."
; output_options.overwrite_file_in_place && input_options.tar
, "-in-place may not be used with -tar."
; output_options.overwrite_file_in_place && output_options.stdout
, "-in-place may not be used with -stdout."
; output_options.overwrite_file_in_place && output_options.diff
, "-in-place may not be used with -diff."
; Option.is_some output_options.interactive_review
&& (input_options.stdin || Option.is_some input_options.zip_file || input_options.match_only || input_options.tar)
, "-review cannot be used with one or more of the following input flags: -stdin, -zip, -match-only, -tar."
; Option.is_some output_options.interactive_review
&& (output_options.json_lines
|| output_options.json_only_diff
|| output_options.stdout
|| output_options.diff
|| output_options.overwrite_file_in_place
|| output_options.count)
, "-review cannot be used with one or more of the following output flags: -json-lines, -json-only-diff, -stdout, -in-place, -count"
; input_options.anonymous_arguments = None &&
(input_options.templates = None
|| input_options.templates = Some [])
, "No templates specified. \
See -h to specify on the command line, or \
use -templates \
<directory-containing-templates>."
; Option.is_some input_options.directory_depth
&& Option.value_exn (input_options.directory_depth) < 0
, "-depth must be 0 or greater."
; Sys.is_directory input_options.target_directory = `No
, "Directory specified with -d or -directory is not a directory."
; output_options.json_only_diff && not output_options.json_lines
, "-json-only-diff can only be supplied with -json-lines."
; (Option.is_some output_options.chunk_matches) && Option.is_some input_options.zip_file
, "chunk-matches output format is not supported for zip files."
; Option.is_some output_options.interactive_review &&
(not (String.equal input_options.target_directory (Sys.getcwd ())))
, "Please remove the -d option and `cd` to the directory where you want to \
review from. The -review, -editor, or -default-no options should only be run \
at the root directory of the project files to patch."
[ ( input_options.stdin && Option.is_some input_options.zip_file
, "-zip may not be used with -stdin." )
; ( output_options.stdout && output_options.diff
, "-stdout may not be used with -diff. Note: -stdout outputs the changed file contents and \
-diff outputs a unified diff. Choose one of these." )
; ( output_options.overwrite_file_in_place && is_some input_options.zip_file
, "-in-place may not be used with -zip." )
; ( output_options.overwrite_file_in_place && input_options.tar
, "-in-place may not be used with -tar." )
; ( output_options.overwrite_file_in_place && output_options.stdout
, "-in-place may not be used with -stdout." )
; ( output_options.overwrite_file_in_place && output_options.diff
, "-in-place may not be used with -diff." )
; ( Option.is_some output_options.interactive_review
&& (input_options.stdin
|| Option.is_some input_options.zip_file
|| input_options.match_only
|| input_options.tar)
, "-review cannot be used with one or more of the following input flags: -stdin, -zip, \
-match-only, -tar." )
; ( Option.is_some output_options.interactive_review
&& (output_options.json_lines
|| output_options.json_only_diff
|| output_options.stdout
|| output_options.diff
|| output_options.overwrite_file_in_place
|| output_options.count)
, "-review cannot be used with one or more of the following output flags: -json-lines, \
-json-only-diff, -stdout, -in-place, -count" )
; ( input_options.anonymous_arguments = None
&& (input_options.templates = None || input_options.templates = Some [])
, "No templates specified. See -h to specify on the command line, or use -templates \
<directory-containing-templates>." )
; ( Option.is_some input_options.directory_depth
&& Option.value_exn input_options.directory_depth < 0
, "-depth must be 0 or greater." )
; ( Sys.is_directory input_options.target_directory = `No
, "Directory specified with -d or -directory is not a directory." )
; ( output_options.json_only_diff && not output_options.json_lines
, "-json-only-diff can only be supplied with -json-lines." )
; ( Option.is_some output_options.chunk_matches && Option.is_some input_options.zip_file
, "chunk-matches output format is not supported for zip files." )
; ( Option.is_some output_options.interactive_review
&& not (String.equal input_options.target_directory (Sys.getcwd ()))
, "Please remove the -d option and `cd` to the directory where you want to review from. The \
-review, -editor, or -default-no options should only be run at the root directory of the \
project files to patch." )
; (let message =
match input_options.templates with
| Some inputs ->
List.find_map inputs ~f:(fun input ->
if Sys.is_file input = `Yes then
(match Toml.Parser.from_filename input with
| `Error (s, _) -> Some s
| _ -> None)
else if not (Sys.is_directory input = `Yes) then
Some (Format.sprintf "Directory %S specified with -templates is not a directory." input)
else
None)
if Sys.is_file input = `Yes then (
match Toml.Parser.from_filename input with
| `Error (s, _) -> Some s
| _ -> None)
else if not (Sys.is_directory input = `Yes) then
Some
(Format.sprintf "Directory %S specified with -templates is not a directory." input)
else
None)
| _ -> None
in
Option.is_some message
, if Option.is_some message then
Option.value_exn message
else
"UNREACHABLE")
; (let result = Matchers.Rule.create ~metasyntax:(parse_metasyntax input_options.custom_metasyntax) input_options.rule in
Or_error.is_error result
, if Or_error.is_error result then
Format.sprintf "Match rule parse error: %s@." @@
Error.to_string_hum (Option.value_exn (Result.error result))
else
"UNREACHABLE")
( Option.is_some message
, if Option.is_some message then
Option.value_exn message
else
"UNREACHABLE" ))
; (let result =
Matchers.Rule.create
~metasyntax:(parse_metasyntax input_options.custom_metasyntax)
input_options.rule
in
( Or_error.is_error result
, if Or_error.is_error result then
Format.sprintf "Match rule parse error: %s@."
@@ Error.to_string_hum (Option.value_exn (Result.error result))
else
"UNREACHABLE" ))
]
in
List.filter_map error_on ~f:(function
| true, message -> Some (Or_error.error_string message)
| _ -> None)
| true, message -> Some (Or_error.error_string message)
| _ -> None)
|> Or_error.combine_errors_unit
|> Result.map_error ~f:(fun error ->
let message =
let rec to_string acc =
function
| Sexp.Atom s -> s
| List [] -> ""
| List (x::[]) -> to_string acc x
| List (x::xs) ->
(List.fold xs ~init:acc ~f:to_string) ^ "\nNext error: " ^ to_string acc x
in
Error.to_string_hum error
|> Sexp.of_string
|> to_string ""
in
Error.of_string message)
let message =
let rec to_string acc = function
| Sexp.Atom s -> s
| List [] -> ""
| List (x :: []) -> to_string acc x
| List (x :: xs) ->
List.fold xs ~init:acc ~f:to_string ^ "\nNext error: " ^ to_string acc x
in
Error.to_string_hum error |> Sexp.of_string |> to_string ""
in
Error.of_string message)
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; _ } : anonymous_arguments) ->
[ match_template ]
| Some templates, _ ->
List.map (parse_templates ~metasyntax:(parse_metasyntax input_options.custom_metasyntax) templates) ~f:(fun { match_template; _ } -> match_template)
| _ -> assert false
in
List.exists match_templates ~f:(fun match_template ->
Pcre.(pmatch ~rex:(regexp "^:\\[[[:alnum:]]+\\]") match_template))),
"The match template starts with a :[hole]. You almost never want to start \
a template with :[hole], since it matches everything including newlines \
up to the part that comes after it. This can make things slow. :[[hole]] \
might be what you're looking for instead, like when you want to match an \
assignment foo = bar(args) on a line, use :[[var]] = bar(args). :[hole] is \
typically useful inside balanced delimiters."
; is_some input_options.templates
&& is_some input_options.anonymous_arguments,
"Templates specified on the command line AND using -templates. Ignoring match
and rewrite templates on the command line and only using those in directories."
; output_options.color
&& (output_options.stdout
|| output_options.json_lines
|| output_options.overwrite_file_in_place)
, "-color only works with -diff."
; output_options.count && not input_options.match_only
, "-count only works with -match-only. Performing -match-only -count."
; input_options.stdin && output_options.overwrite_file_in_place
, "-in-place has no effect when -stdin is used. Ignoring -in-place."
; output_options.count && output_options.json_lines
, "-count and -json-lines is specified. Ignoring -count."
; input_options.stdin && input_options.tar
, "-tar implies -stdin. Ignoring -stdin."
; (Option.is_some output_options.chunk_matches) && (not (input_options.stdin || input_options.tar))
, "printing chunk match format for output option that is NOT -stdin nor \
-tar. This is very inefficient!"
[ ( (let match_templates =
match input_options.templates, input_options.anonymous_arguments with
| None, Some ({ match_template; _ } : anonymous_arguments) -> [ match_template ]
| Some templates, _ ->
List.map
(parse_templates
~metasyntax:(parse_metasyntax input_options.custom_metasyntax)
templates)
~f:(fun { match_template; _ } -> match_template)
| _ -> assert false
in
List.exists match_templates ~f:(fun match_template ->
Pcre.(pmatch ~rex:(regexp "^:\\[[[:alnum:]]+\\]") match_template)))
, "The match template starts with a :[hole]. You almost never want to start a template with \
:[hole], since it matches everything including newlines up to the part that comes after \
it. This can make things slow. :[[hole]] might be what you're looking for instead, like \
when you want to match an assignment foo = bar(args) on a line, use :[[var]] = bar(args). \
:[hole] is typically useful inside balanced delimiters." )
; ( is_some input_options.templates && is_some input_options.anonymous_arguments
, "Templates specified on the command line AND using -templates. Ignoring match\n\
\ and rewrite templates on the command line and only using those in directories." )
; ( output_options.color
&& (output_options.stdout
|| output_options.json_lines
|| output_options.overwrite_file_in_place)
, "-color only works with -diff." )
; ( output_options.count && not input_options.match_only
, "-count only works with -match-only. Performing -match-only -count." )
; ( input_options.stdin && output_options.overwrite_file_in_place
, "-in-place has no effect when -stdin is used. Ignoring -in-place." )
; ( output_options.count && output_options.json_lines
, "-count and -json-lines is specified. Ignoring -count." )
; input_options.stdin && input_options.tar, "-tar implies -stdin. Ignoring -stdin."
; ( Option.is_some output_options.chunk_matches && not (input_options.stdin || input_options.tar)
, "printing chunk match format for output option that is NOT -stdin nor -tar. This is very \
inefficient!" )
]
in
List.iter warn_on ~f:(function
| true, message -> Format.eprintf "WARNING: %s@." message
| _ -> ());
| true, message -> Format.eprintf "WARNING: %s@." message
| _ -> ());
Ok ()
let with_zip zip_file ~f =
@ -595,34 +583,34 @@ let filter_zip_entries file_filters exclude_directory_prefix exclude_file_prefix
List.exists prefixes ~f:(fun prefix -> String.is_prefix ~prefix filename)
in
match file_filters with
| Some [] | None -> List.filter (Zip.entries zip) ~f:(fun { is_directory; filename; _ } ->
not is_directory
&& not (exclude_the_directory exclude_directory_prefix filename)
| Some [] | None ->
List.filter (Zip.entries zip) ~f:(fun { is_directory; filename; _ } ->
(not is_directory)
&& (not (exclude_the_directory exclude_directory_prefix filename))
&& not (exclude_the_file exclude_file_prefix (Filename.basename filename)))
| Some suffixes ->
let has_acceptable_suffix filename =
List.exists suffixes ~f:(fun suffix -> String.is_suffix ~suffix filename)
in
List.filter (Zip.entries zip) ~f:(fun { is_directory; filename; _ } ->
not is_directory
&& not (exclude_the_directory exclude_directory_prefix filename)
&& not (exclude_the_file exclude_file_prefix (Filename.basename filename))
&& has_acceptable_suffix filename)
(not is_directory)
&& (not (exclude_the_directory exclude_directory_prefix filename))
&& (not (exclude_the_file exclude_file_prefix (Filename.basename filename)))
&& has_acceptable_suffix filename)
let syntax custom_matcher_path =
match
Sys.file_exists custom_matcher_path with
match Sys.file_exists custom_matcher_path with
| `No | `Unknown ->
Format.eprintf "Could not open file: %s@." custom_matcher_path;
exit 1
| `Yes ->
Yojson.Safe.from_file custom_matcher_path
|> Matchers.Language.Syntax.of_yojson
|> function
|> (function
| Ok c -> c
| Error error ->
Format.eprintf "%s@." error;
exit 1
exit 1)
let force_language language =
match Matchers.Languages.select_with_extension language with
@ -635,12 +623,16 @@ let force_language language =
let extension file_filters =
match file_filters with
| None | Some [] -> ".generic"
| Some (filter::_) ->
match Filename.split_extension filter with
| _, Some extension -> "." ^ extension
| extension, None -> "." ^ extension
| Some (filter :: _) ->
(match Filename.split_extension filter with
| _, Some extension -> "." ^ extension
| extension, None -> "." ^ extension)
let of_extension (module Engine : Matchers.Engine.S) (module External : Matchers.External.S) file_filters =
let of_extension
(module Engine : Matchers.Engine.S)
(module External : Matchers.External.S)
file_filters
=
let external_handler = External.handler in
let extension = extension file_filters in
match Engine.select_with_extension extension ~external_handler with
@ -654,7 +646,10 @@ let select_matcher custom_metasyntax custom_matcher override_matcher file_filter
else
(module Matchers.Alpha)
in
let module External = struct let handler = External_semantic.lsif_hover end in
let module External = struct
let handler = External_semantic.lsif_hover
end
in
if debug then Format.printf "Set custom external@.";
match custom_matcher, override_matcher, custom_metasyntax with
| Some custom_matcher, _, custom_metasyntax ->
@ -669,14 +664,18 @@ let select_matcher custom_metasyntax custom_matcher override_matcher file_filter
let (module Metasyntax) = Matchers.Metasyntax.create metasyntax in
let (module Language) = force_language language in
if debug then Format.printf "Engine.Make@.";
(module (Engine.Make (Language) (Metasyntax) (External)) : Matchers.Matcher.S), None, Some metasyntax
( (module Engine.Make (Language) (Metasyntax) (External) : Matchers.Matcher.S)
, None
, Some metasyntax )
| _, _, Some custom_metasyntax ->
(* infer language from file filters, definite custom metasyntax *)
let metasyntax = parse_metasyntax (Some custom_metasyntax) in
let (module Metasyntax) = Matchers.Metasyntax.create metasyntax in
let (module Language) = force_language (extension file_filters) in
if debug then Format.printf "Engine.Make2@.";
(module (Engine.Make (Language) (Metasyntax) (External)) : Matchers.Matcher.S), None, Some metasyntax
( (module Engine.Make (Language) (Metasyntax) (External) : Matchers.Matcher.S)
, None
, Some metasyntax )
| _, _, None ->
(* infer language from file filters, use default metasyntax *)
if debug then Format.printf "Engine.Infer@.";
@ -690,12 +689,11 @@ let regex_of_specifications specifications =
let ripgrep_file_filters specifications args : string list =
let regex = regex_of_specifications specifications in
let args =
String.split_on_chars args ~on:[' '; '\t'; '\r'; '\n']
|> List.filter ~f:(String.(<>) "")
String.split_on_chars args ~on:[ ' '; '\t'; '\r'; '\n' ] |> List.filter ~f:(String.( <> ) "")
in
let result = Ripgrep.run ~pattern:regex ~args in
match result with
| Ok Some result ->
| Ok (Some result) ->
if debug then Format.printf "Ripgrep result: %s@." @@ String.concat ~sep:"\n" result;
result
| Ok None ->
@ -706,41 +704,41 @@ let ripgrep_file_filters specifications args : string list =
exit 1
let create
({ input_options =
{ rule
; templates
; anonymous_arguments
; file_filters
; zip_file
; match_only
; stdin
; tar
; target_directory
; directory_depth
; exclude_directory_prefix
; exclude_file_prefix
; custom_metasyntax
; custom_matcher
; override_matcher
; regex_pattern
; ripgrep_args
; omega
}
; run_options
; output_options =
({ overwrite_file_in_place
; color
; count
; interactive_review
; substitute_in_place
; _
} as output_options)
} as configuration)
: t Or_error.t =
({ input_options =
{ rule
; templates
; anonymous_arguments
; file_filters
; zip_file
; match_only
; stdin
; tar
; target_directory
; directory_depth
; exclude_directory_prefix
; exclude_file_prefix
; custom_metasyntax
; custom_matcher
; override_matcher
; regex_pattern
; ripgrep_args
; omega
}
; run_options
; output_options =
{ overwrite_file_in_place; color; count; interactive_review; substitute_in_place; _ } as
output_options
} as configuration)
: t Or_error.t
=
let open Or_error in
emit_errors configuration >>= fun () ->
emit_warnings configuration >>= fun () ->
let rule = Matchers.Rule.create ~metasyntax:(parse_metasyntax custom_metasyntax) rule |> Or_error.ok_exn in
emit_errors configuration
>>= fun () ->
emit_warnings configuration
>>= fun () ->
let rule =
Matchers.Rule.create ~metasyntax:(parse_metasyntax custom_metasyntax) rule |> Or_error.ok_exn
in
let specifications =
match templates, anonymous_arguments with
| None, Some { match_template; rewrite_template; _ } ->
@ -748,28 +746,27 @@ let create
[ Matchers.Specification.create ~match_template ~rule () ]
else
[ Matchers.Specification.create ~match_template ~rewrite_template ~rule () ]
| Some templates, _ ->
parse_templates ~warn_for_missing_file_in_dir:true templates
| Some templates, _ -> parse_templates ~warn_for_missing_file_in_dir:true templates
| _ -> assert false
in
let specifications =
if match_only then
List.map specifications ~f:(fun { match_template; rule; _ } ->
Matchers.Specification.create ~match_template ?rule ())
Matchers.Specification.create ~match_template ?rule ())
else
specifications
in
if regex_pattern then (Format.printf "%s@." (regex_of_specifications specifications); exit 0);
if regex_pattern then (
Format.printf "%s@." (regex_of_specifications specifications);
exit 0);
let file_filters_from_anonymous_args =
match anonymous_arguments with
| None -> file_filters
| Some { file_filters = None; _ } -> file_filters
| Some { file_filters = Some anonymous_file_filters; _ } ->
match file_filters with
| Some additional_file_filters ->
Some (additional_file_filters @ anonymous_file_filters)
| None ->
Some anonymous_file_filters
(match file_filters with
| Some additional_file_filters -> Some (additional_file_filters @ anonymous_file_filters)
| None -> Some anonymous_file_filters)
in
let file_filters =
match ripgrep_args with
@ -790,7 +787,10 @@ let create
| Zip ->
let zip_file = Option.value_exn zip_file in
let paths : Zip.entry list =
with_zip zip_file ~f:(filter_zip_entries file_filters exclude_directory_prefix exclude_file_prefix) in
with_zip
zip_file
~f:(filter_zip_entries file_filters exclude_directory_prefix exclude_file_prefix)
in
`Zip (zip_file, paths)
| Directory ->
let target_directory =
@ -821,8 +821,7 @@ let create
match printable with
| Matches { source_path; matches; source_content } ->
Printer.Match.convert output_options
|> fun match_output ->
Printer.Match.print match_output source_content source_path matches
|> fun match_output -> Printer.Match.print match_output source_content source_path matches
| Replacements { source_path; replacements; result; source_content } ->
Printer.Rewrite.convert output_options
|> fun replacement_output ->
@ -831,8 +830,9 @@ let create
else
Printer.Rewrite.print replacement_output source_path replacements result source_content
in
let (module M) as matcher, _, metasyntax =
select_matcher custom_metasyntax custom_matcher override_matcher file_filters omega in
let ((module M) as matcher), _, metasyntax =
select_matcher custom_metasyntax custom_matcher override_matcher file_filters omega
in
return
{ matcher
; sources

3
lib/app/configuration/command_configuration.mli
View File

@ -1,5 +1,4 @@
open Core
open Comby_kernel
module Printer : sig
@ -94,7 +93,7 @@ type t =
; output_printer : Printer.t
; interactive_review : interactive_review option
; matcher : (module Matchers.Matcher.S)
; metasyntax : Matchers.Metasyntax.t option
; metasyntax : Matchers.Metasyntax.t option
; substitute_in_place : bool
}

3
lib/app/configuration/command_input.ml
View File

@ -13,7 +13,6 @@ type t =
| `Tar
]
let show_input_kind =
function
let show_input_kind = function
| String _ -> "A long string..."
| Path path -> Format.sprintf "A path: %s" path

8
lib/app/configuration/diff_configuration.ml
View File

@ -39,7 +39,8 @@ let default context =
((prefix ((text "@|") (style ((bg bright_black) (fg black)))))
(suffix ((text " ============================================================") (style ())))
(style (bold))))
)|} context
)|}
context
let terminal ?(context = 16) () =
Patdiff.Configuration.On_disk.t_of_sexp (Sexp.of_string (default context))
@ -145,14 +146,11 @@ let get_diff kind source_path source_content result =
let configuration =
match kind with
| Plain -> plain ()
| Colored
| Html
| Default -> terminal ~context:3 ()
| Colored | Html | Default -> terminal ~context:3 ()
| Match_only -> match_diff ()
in
let prev = Patdiff.Diff_input.{ name = source_path; text = source_content } in
let next = Patdiff.Diff_input.{ name = source_path; text = result } in
Compare_core.diff_strings ~print_global_header:true configuration ~prev ~next
|> function
| `Different diff -> Some diff

24
lib/app/configuration/dune
View File

@ -1,6 +1,20 @@
(library
(name configuration)
(public_name comby.configuration)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving.show ppx_sexp_conv ppx_sexp_message ppx_deriving_yojson))
(libraries comby-kernel comby-semantic comby.patdiff comby.camlzip core yojson ppx_deriving_yojson toml lwt lwt.unix tar tar-unix))
(name configuration)
(public_name comby.configuration)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving.show ppx_sexp_conv ppx_sexp_message ppx_deriving_yojson))
(libraries
comby-kernel
comby-semantic
comby.patdiff
comby.camlzip
core
yojson
ppx_deriving_yojson
toml
lwt
lwt.unix
tar
tar-unix))

4
lib/app/configuration/external_semantic.ml
View File

@ -1,5 +1,4 @@
open Core_kernel
open Comby_semantic
let debug =
@ -8,7 +7,8 @@ let debug =
| _ -> true
let lsif_hover ~name:_ ~filepath ~line ~column =
String.chop_prefix_if_exists filepath ~prefix:(Sys.getcwd ()) |> fun filepath_relative_root ->
String.chop_prefix_if_exists filepath ~prefix:(Sys.getcwd ())
|> fun filepath_relative_root ->
if debug then Format.printf "File relative root: %s@." filepath;
if debug then Format.printf "Querying type at %d::%d@." line column;
let context =

27
lib/app/configuration/ripgrep.ml
View File

@ -1,28 +1,27 @@
open Core
open Lwt
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
let run ~pattern ~args =
let options = ["--files-with-matches"; "--multiline"] in
let options = [ "--files-with-matches"; "--multiline" ] in
let pattern = Format.sprintf {|'%s'|} pattern in
let command = ("rg" :: options @ args @ [pattern]) |> String.concat ~sep:" " in
let command = ("rg" :: options) @ args @ [ pattern ] |> String.concat ~sep:" " in
if debug then Format.printf "Executing: %s@." command;
let lwt_command = Lwt_process.shell command in
let recv proc =
let ic = proc#stdout in
Lwt.finalize
(fun () -> Lwt_io.read ic)
(fun () -> Lwt_io.close ic)
Lwt.finalize (fun () -> Lwt_io.read ic) (fun () -> Lwt_io.close ic)
in
let f () =
Lwt_process.with_process_in lwt_command (fun proc ->
recv proc >>= fun result ->
proc#status >>= function
| WEXITED v when v = 1 -> return (Ok None) (* no matches *)
| WEXITED v when v <> 0 -> return @@ Or_error.errorf "Error executing rg, exit status %d." v
| _ -> return (Ok (Some (String.split ~on:'\n' result |> List.filter ~f:(String.(<>) "")))))
recv proc
>>= fun result ->
proc#status
>>= function
| WEXITED v when v = 1 -> return (Ok None) (* no matches *)
| WEXITED v when v <> 0 -> return @@ Or_error.errorf "Error executing rg, exit status %d." v
| _ -> return (Ok (Some (String.split ~on:'\n' result |> List.filter ~f:(String.( <> ) "")))))
in
try Lwt_main.run (f ()) with Sys.Break -> exit 0
try Lwt_main.run (f ()) with
| Sys.Break -> exit 0

15
lib/app/dune
View File

@ -1,9 +1,8 @@
(library
(name comby)
(public_name comby)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries
core
comby-kernel
comby.pipeline))
(name comby)
(public_name comby)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries core comby-kernel comby.pipeline))

15
lib/app/interactive/dune
View File

@ -1,5 +1,12 @@
(library
(name interactive)
(public_name comby.interactive)
(preprocess (pps ppx_sexp_conv))
(libraries comby-kernel comby.configuration core shell.filename_extended lwt lwt.unix))
(name interactive)
(public_name comby.interactive)
(preprocess
(pps ppx_sexp_conv))
(libraries
comby-kernel
comby.configuration
core
shell.filename_extended
lwt
lwt.unix))

260
lib/app/interactive/interactive.ml
View File

@ -1,11 +1,8 @@
open Core
open Lwt
open Configuration
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
module Diff = struct
open Patdiff
@ -15,28 +12,14 @@ module Diff = struct
open Patdiff_core
(* Useful unexposed function Taken from Compare_core. *)
let compare_lines
{ float_tolerance
; context
; line_big_enough
; ext_cmp
; keep_ws
; _
}
~prev
~next =
let compare_lines { float_tolerance; context; line_big_enough; ext_cmp; keep_ws; _ } ~prev ~next =
(* Create the diff *)
let hunks =
let transform = if keep_ws then Fn.id else Patdiff_core.remove_ws in
(* Use external compare program? *)
match ext_cmp with
| None ->
Patience_diff.String.get_hunks
~transform
~context
~big_enough:line_big_enough
~prev
~next
Patience_diff.String.get_hunks ~transform ~context ~big_enough:line_big_enough ~prev ~next
| Some prog ->
let compare x y =
let cmd = sprintf "%s %S %S" prog x y in
@ -45,7 +28,8 @@ module Diff = struct
| Error (`Exit_non_zero 1) -> 1
| Error _ -> failwithf "External compare %S failed!" prog ()
in
let module P = Patience_diff.Make (struct
let module P =
Patience_diff.Make (struct
type t = string [@@deriving sexp]
let hash = String.hash
@ -59,18 +43,20 @@ module Diff = struct
| Some tolerance -> Float_tolerance.apply hunks tolerance ~context
let stylize_hunks
{ unrefined
; rules
; output
; produce_unified_lines
; interleave
; word_big_enough
; keep_ws
; split_long_lines
; _
}
hunks =
if unrefined then Patience_diff.Hunks.unified hunks
{ unrefined
; rules
; output
; produce_unified_lines
; interleave
; word_big_enough
; keep_ws
; split_long_lines
; _
}
hunks
=
if unrefined then
Patience_diff.Hunks.unified hunks
else
Without_unix.refine
~rules
@ -85,24 +71,24 @@ module Diff = struct
let get_hunks config prev next =
let lines { Patdiff.Diff_input.name = _; text } = String.split_lines text |> Array.of_list in
let hunks =
Comparison_result.create config
~prev
~next
~compare_assuming_text:(fun config ~prev ~next ->
compare_lines config ~prev:(lines prev) ~next:(lines next))
Comparison_result.create config ~prev ~next ~compare_assuming_text:(fun config ~prev ~next ->
compare_lines config ~prev:(lines prev) ~next:(lines next))
in
if Comparison_result.has_no_diff hunks then [] else
if Comparison_result.has_no_diff hunks then
[]
else (
match hunks with
| Hunks h -> h
| _ -> []
| _ -> [])
let hunk_to_string
hunks
(style : Patdiff.Configuration.t) (*{ output; rules; location_style; _ }*)
?print_global_header
~(prev : Patdiff.Diff_input.t)
~(next : Patdiff.Diff_input.t)
() =
hunks
(style : Patdiff.Configuration.t) (*{ output; rules; location_style; _ }*)
?print_global_header
~(prev : Patdiff.Diff_input.t)
~(next : Patdiff.Diff_input.t)
()
=
Without_unix.output_to_string
hunks
?print_global_header
@ -119,31 +105,29 @@ module Diff = struct
in
let one_hunk = stylize_hunks with_style hunks in
hunk_to_string one_hunk with_style ~print_global_header:true ~prev ~next ()
end
let clear_screen () =
Lwt_io.print "\027[2J" >>= fun () ->
Lwt_io.print "\027[H"
let clear_screen () = Lwt_io.print "\027[2J" >>= fun () -> Lwt_io.print "\027[H"
let handle_editor_errors = function
| Lwt_unix.WEXITED 0 -> return `Ok
| WEXITED e | WSIGNALED e | WSTOPPED e ->
clear_screen () >>= fun () ->
clear_screen ()
>>= fun () ->
let message =
Format.sprintf
"Error opening editor (error code %d)\n.
Press any key to continue, or exit now (Ctrl-C).\n" e in
Lwt_io.print message >>= fun () ->
Lwt_io.read Lwt_io.stdin >>= fun _input ->
return `Ok
"Error opening editor (error code %d)\n\
.\n\
\ Press any key to continue, or exit now (Ctrl-C).\n"
e
in
Lwt_io.print message >>= fun () -> Lwt_io.read Lwt_io.stdin >>= fun _input -> return `Ok
let handle_patch_errors = function
| Lwt_unix.WEXITED 0 -> return `Ok
| WEXITED e
| WSIGNALED e
| WSTOPPED e ->
clear_screen () >>= fun () ->
| WEXITED e | WSIGNALED e | WSTOPPED e ->
clear_screen ()
>>= fun () ->
let hint =
if e = 127 then
"Maybe the 'patch' command is not on your path?\n"
@ -153,63 +137,91 @@ let handle_patch_errors = function
let message =
Format.sprintf
"Error attempting patch, command exited with %d.\n\
%s\
Press any key to continue, or exit now (Ctrl-C).\n" e hint in
Lwt_io.print message >>= fun _input ->
Lwt_io.read_line Lwt_io.stdin >>= fun _input ->
return `Ok
%sPress any key to continue, or exit now (Ctrl-C).\n"
e
hint
in
Lwt_io.print message
>>= fun _input -> Lwt_io.read_line Lwt_io.stdin >>= fun _input -> return `Ok
let apply_patch hunk_patch =
let cmd = Lwt_process.shell "patch -p 0" in
(return (Lwt_process.open_process_full cmd)) >>= fun process ->
Lwt_io.write_line process#stdin hunk_patch >>= fun () ->
Lwt_io.close process#stdin >>= fun () ->
Lwt_io.read process#stdout >>= fun stdout ->
Lwt_io.read process#stderr >>= fun stderr ->
(if debug then Lwt_io.printf "[debug] %s,%s\n" stdout stderr else return ()) >>= fun () ->
process#close
return (Lwt_process.open_process_full cmd)
>>= fun process ->
Lwt_io.write_line process#stdin hunk_patch
>>= fun () ->
Lwt_io.close process#stdin
>>= fun () ->
Lwt_io.read process#stdout
>>= fun stdout ->
Lwt_io.read process#stderr
>>= fun stderr ->
(if debug then Lwt_io.printf "[debug] %s,%s\n" stdout stderr else return ())
>>= fun () -> process#close
let drop_into_editor editor path ~at_line =
let command = Format.sprintf "%s +%d %s" editor at_line path in
Lwt_unix.system command
let process_input default_is_accept hunk_patch prev_start next_start editor path ~continue =
let prompt =
if default_is_accept then
[ "Accept change ("
; "\x1b[32m"; "y = yes"; "\x1b[0m"; "\x1b[1m"; " [default], "; "\x1b[0m"
; "\x1b[31m"; "n = no"; "\x1b[0m"; ", "
; "\x1b[33m"; "e = edit original"; "\x1b[0m"; ", "
; "\x1b[33m"; "E = apply+edit"; "\x1b[0m"; ", "
; "\x1b[32m"
; "y = yes"
; "\x1b[0m"
; "\x1b[1m"
; " [default], "
; "\x1b[0m"
; "\x1b[31m"
; "n = no"
; "\x1b[0m"
; ", "
; "\x1b[33m"
; "e = edit original"
; "\x1b[0m"
; ", "
; "\x1b[33m"
; "E = apply+edit"
; "\x1b[0m"
; ", "
; "q = quit)?"
]
else
[ "Accept change ("
; "\x1b[32m"; "y = yes"; "\x1b[0m"; ", "
; "\x1b[31m"; "n = no"; "\x1b[0m"; "\x1b[1m"; " [default], "; "\x1b[0m"
; "\x1b[33m"; "e = edit original"; "\x1b[0m"; ", "
; "\x1b[33m"; "E = apply+edit"; "\x1b[0m"; ", "
; "\x1b[32m"
; "y = yes"
; "\x1b[0m"
; ", "
; "\x1b[31m"
; "n = no"
; "\x1b[0m"
; "\x1b[1m"
; " [default], "
; "\x1b[0m"
; "\x1b[33m"
; "e = edit original"
; "\x1b[0m"
; ", "
; "\x1b[33m"
; "E = apply+edit"
; "\x1b[0m"
; ", "
; "q = quit)?"
]
in
let prompt = String.concat prompt in
Lwt_io.printl prompt >>= fun () ->
Lwt_io.printl prompt
>>= fun () ->
let rec try_again () =
Lwt_io.read_line Lwt_io.stdin >>= fun input ->
Lwt_io.read_line Lwt_io.stdin
>>= fun input ->
match input with
| "y" ->
apply_patch hunk_patch
>>= handle_patch_errors
>>= fun _ -> continue ()
| "y" -> apply_patch hunk_patch >>= handle_patch_errors >>= fun _ -> continue ()
| "" when default_is_accept ->
apply_patch hunk_patch
>>= handle_patch_errors
>>= fun _ -> continue ()
| "n" ->
continue ()
| "" when not default_is_accept ->
continue ()
apply_patch hunk_patch >>= handle_patch_errors >>= fun _ -> continue ()
| "n" -> continue ()
| "" when not default_is_accept -> continue ()
| "e" ->
drop_into_editor editor path ~at_line:prev_start
>>= handle_editor_errors
@ -217,14 +229,12 @@ let process_input default_is_accept hunk_patch prev_start next_start editor path
| "E" ->
apply_patch hunk_patch
>>= handle_patch_errors
>>= fun _ -> drop_into_editor editor path ~at_line:next_start
>>= fun _ ->
drop_into_editor editor path ~at_line:next_start
>>= handle_editor_errors
>>= fun _ -> continue ()
| "q" ->
raise Sys.Break
| _ ->
Lwt_io.printl "Uh, I don't know that one. Try again."
>>= try_again
| "q" -> raise Sys.Break
| _ -> Lwt_io.printl "Uh, I don't know that one. Try again." >>= try_again
in
try_again ()
@ -237,21 +247,34 @@ let run editor default_is_accept count rewrites =
let thread () =
let size = List.length rewrites in
let text =
["There "] @
(if count = 1 then ["is "; "\x1b[32m"; "1"; "\x1b[0m"; " match"]
else ["are "; "\x1b[32m"; Format.sprintf "%d" count; "\x1b[0m"; " matches"]) @
[" in total, "] @
(if size = 1 then ["in "; "\x1b[32m"; "1"; "\x1b[0m"; " file"]
else ["spread across "; "\x1b[32m"; Format.sprintf "%d" size; "\x1b[0m"; " files"]) @
[" to review.\n\
Press "; "\x1b[32m"; "any key"; "\x1b[0m";
" to continue on this patching adventure \
("; "\x1b[31m"; "Ctrl-C to cancel"; "\x1b[0m"; ")."]
[ "There " ]
@ (if count = 1 then
[ "is "; "\x1b[32m"; "1"; "\x1b[0m"; " match" ]
else
[ "are "; "\x1b[32m"; Format.sprintf "%d" count; "\x1b[0m"; " matches" ])
@ [ " in total, " ]
@ (if size = 1 then
[ "in "; "\x1b[32m"; "1"; "\x1b[0m"; " file" ]
else
[ "spread across "; "\x1b[32m"; Format.sprintf "%d" size; "\x1b[0m"; " files" ])
@ [ " to review.\nPress "
; "\x1b[32m"
; "any key"
; "\x1b[0m"
; " to continue on this patching adventure ("
; "\x1b[31m"
; "Ctrl-C to cancel"
; "\x1b[0m"
; ")."
]
in
let text = String.concat text in
clear_screen () >>= fun () ->
Lwt_io.printl text >>= fun () ->
Lwt_io.read_line Lwt_io.stdin >>= fun _input ->
clear_screen ()
>>= fun () ->
Lwt_io.printl text
>>= fun () ->
Lwt_io.read_line Lwt_io.stdin
>>= fun _input ->
let do_one_file path rewritten_source =
let open Patdiff in
let source_content = In_channel.read_all path in
@ -266,13 +289,15 @@ let run editor default_is_accept count rewrites =
let rec next_hunk = function
| [] -> return ()
| hunk :: hunks ->
let one_hunk = [hunk] in
let one_hunk = [ hunk ] in
let hunk_pretty, hunk_patch =
let apply = Diff.apply_style one_hunk prev next in
apply ~with_style:(`Pretty context), apply ~with_style:`Plain
in
clear_screen () >>= fun () ->
Lwt_io.printl hunk_pretty >>= fun () ->
clear_screen ()
>>= fun () ->
Lwt_io.printl hunk_pretty
>>= fun () ->
let prev_start = hunk.prev_start + context in
let next_start = hunk.next_start + context in
process_input
@ -288,4 +313,5 @@ let run editor default_is_accept count rewrites =
in
Lwt_list.iter_s (fun { path; rewritten_source } -> do_one_file path rewritten_source) rewrites
in
try Lwt_main.run (thread ()) with Sys.Break -> exit 0
try Lwt_main.run (thread ()) with
| Sys.Break -> exit 0

32
lib/app/pipeline/dune
View File

@ -1,11 +1,23 @@
(library
(name pipeline)
(public_name comby.pipeline)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_sexp_conv ppx_deriving_yojson))
(libraries comby-kernel comby.statistics comby.configuration comby.interactive comby.camlzip core core.uuid yojson ppx_deriving_yojson parany
(select parallel_hack.ml from
(hack_parallel -> parallel_hack.available.ml)
(!hack_parallel -> parallel_hack.parany_fallback.ml))
))
(name pipeline)
(public_name comby.pipeline)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_sexp_conv ppx_deriving_yojson))
(libraries
comby-kernel
comby.statistics
comby.configuration
comby.interactive
comby.camlzip
core
core.uuid
yojson
ppx_deriving_yojson
parany
(select
parallel_hack.ml
from
(hack_parallel -> parallel_hack.available.ml)
(!hack_parallel -> parallel_hack.parany_fallback.ml))))

43
lib/app/pipeline/fold.ml
View File

@ -1,14 +1,19 @@
open Core
open Camlzip
open Configuration
open Command_input
let paths ~init ~f bound_count paths =
match bound_count with
| None -> List.fold paths ~init ~f:(fun count path -> count + f ~input:(Path path) ~output_path:(Some path))
| None ->
List.fold paths ~init ~f:(fun count path ->
count + f ~input:(Path path) ~output_path:(Some path))
| Some bound_count ->
List.fold_until paths ~init ~finish:(fun x -> x) ~f:(fun acc path ->
List.fold_until
paths
~init
~finish:(fun x -> x)
~f:(fun acc path ->
if acc > bound_count then
Stop acc
else
@ -16,9 +21,7 @@ let paths ~init ~f bound_count paths =
let loc_paths paths =
List.fold paths ~init:0 ~f:(fun acc paths ->
In_channel.read_lines paths
|> List.length
|> (+) acc)
In_channel.read_lines paths |> List.length |> ( + ) acc)
let with_zip zip_file ~f =
let zip_in = Zip.open_in zip_file in
@ -30,26 +33,28 @@ let zip_paths ~init ~f zip paths bound_count =
match bound_count with
| None ->
List.fold paths ~init ~f:(fun count ({ Zip.filename; _ } as entry) ->
let source = Zip.read_entry zip entry in
count + f ~input:(String source) ~output_path:(Some filename))
let source = Zip.read_entry zip entry in
count + f ~input:(String source) ~output_path:(Some filename))
| Some max_count ->
List.fold_until paths ~init ~finish:(fun x -> x) ~f:(fun count ({ Zip.filename; _ } as entry) ->
List.fold_until
paths
~init
~finish:(fun x -> x)
~f:(fun count ({ Zip.filename; _ } as entry) ->
if count > max_count then
Stop count
else
else (
let source = Zip.read_entry zip entry in
Continue (count + f ~input:(String source) ~output_path:(Some filename)))
Continue (count + f ~input:(String source) ~output_path:(Some filename))))
let loc_zip zip_file paths =
with_zip zip_file ~f:(fun zip ->
List.fold paths ~init:0 ~f:(fun acc entry ->
let source = Zip.read_entry zip entry in
acc + (List.length (String.split_lines source))))
List.fold paths ~init:0 ~f:(fun acc entry ->
let source = Zip.read_entry zip entry in
acc + List.length (String.split_lines source)))
let interactive ~init ~f paths =
List.fold ~init paths ~f:(fun (acc, c) path ->
match f ~input:(Path path) ~path:(Some path) with
| Some rewritten_source, c' ->
Interactive.{ path; rewritten_source }::acc, c+c'
| None, c' ->
acc, c+c')
match f ~input:(Path path) ~path:(Some path) with
| Some rewritten_source, c' -> Interactive.{ path; rewritten_source } :: acc, c + c'
| None, c' -> acc, c + c')

31
lib/app/pipeline/parallel_hack.available.ml
View File

@ -1,30 +1,29 @@
open Core
open Hack_parallel
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
let with_scheduler scheduler ~f =
let result = f scheduler in
begin
try Scheduler.destroy scheduler
with Unix.Unix_error (_,"kill",_) -> Format.printf "UH OH@."; ()
end;
(try Scheduler.destroy scheduler with
| Unix.Unix_error (_, "kill", _) ->
Format.printf "UH OH@.";
());
result
let try_or_skip f scheduler ~default =
try f scheduler with End_of_file -> default
try f scheduler with
| End_of_file -> default
let process_interactive ~f paths number_of_workers =
if debug then Format.printf "[*] Hack_parallel available. Using it.@.";
let scheduler = Scheduler.create ~number_of_workers () in
let process_bucket ~init paths = Fold.interactive ~init ~f paths in
let map acc bucket_of_paths = process_bucket ~init:acc bucket_of_paths in
let reduce (acc', c') (acc, c) = (List.append acc acc'), (c' + c) in
let init = ([], 0) in
let map_reduce ~init ~map ~reduce data scheduler = (* TODO: simplify this *)
let reduce (acc', c') (acc, c) = List.append acc acc', c' + c in
let init = [], 0 in
let map_reduce ~init ~map ~reduce data scheduler =
(* TODO: simplify this *)
Scheduler.map_reduce scheduler ~init ~map ~reduce data
in
let f = map_reduce ~init ~map ~reduce paths in
@ -36,11 +35,13 @@ let process ~f number_of_workers bound_count sources =
| `Paths paths ->
let scheduler = Scheduler.create ~number_of_workers () in
let map acc bucket_of_paths = Fold.paths ~init:acc ~f bound_count bucket_of_paths in
let f scheduler = Scheduler.map_reduce scheduler ~init:0 ~map ~reduce:(+) paths in
let f scheduler = Scheduler.map_reduce scheduler ~init:0 ~map ~reduce:( + ) paths in
with_scheduler scheduler ~f:(try_or_skip f ~default:0)
| `Zip (zip_file, paths) ->
let scheduler = Scheduler.create ~number_of_workers () in
let map acc bucket_of_paths =
Fold.with_zip zip_file ~f:(fun zip -> Fold.zip_paths ~init:acc ~f zip bucket_of_paths bound_count) in
let f scheduler = Scheduler.map_reduce scheduler ~init:0 ~map ~reduce:(+) paths in
Fold.with_zip zip_file ~f:(fun zip ->
Fold.zip_paths ~init:acc ~f zip bucket_of_paths bound_count)
in
let f scheduler = Scheduler.map_reduce scheduler ~init:0 ~map ~reduce:( + ) paths in
with_scheduler scheduler ~f:(try_or_skip f ~default:0)

21
lib/app/pipeline/parallel_hack.parany_fallback.ml
View File

@ -1,22 +1,17 @@
open Core
open Configuration
open Command_input
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
let process_interactive ~f paths number_of_workers =
if debug then Format.printf "[*] Hack_parallel unavailable. Using parany.@.";
let reduce (acc, c) (path, result) =
match result with
| Some rewritten_source, c' ->
Interactive.{path; rewritten_source}::acc, c+c'
| None, c' ->
acc, c+c'
| Some rewritten_source, c' -> Interactive.{ path; rewritten_source } :: acc, c + c'
| None, c' -> acc, c + c'
in
let init = ([], 0) in
let init = [], 0 in
let map path = path, f ~input:(Path path) ~path:(Some path) in
Parany.Parmap.parfold ~csize:16 number_of_workers map reduce init paths
@ -24,5 +19,11 @@ let process ~f number_of_workers _bound_count sources =
if debug then Format.printf "[*] Hack_parallel unavailable. Using parany.@.";
match sources with
| `Paths paths ->
Parany.Parmap.parfold ~csize:16 number_of_workers (fun path -> f ~input:(Path path) ~output_path:(Some path)) (+) 0 paths
Parany.Parmap.parfold
~csize:16
number_of_workers
(fun path -> f ~input:(Path path) ~output_path:(Some path))
( + )
0
paths
| `Zip _ -> failwith "Not supported"

16
lib/app/pipeline/parallel_parany.ml
View File

@ -4,17 +4,21 @@ open Command_input
let process_interactive ~f paths number_of_workers =
let reduce (acc, c) (path, result) =
match result with
| Some rewritten_source, c' ->
Interactive.{path; rewritten_source}::acc, c+c'
| None, c' ->
acc, c+c'
| Some rewritten_source, c' -> Interactive.{ path; rewritten_source } :: acc, c + c'
| None, c' -> acc, c + c'
in
let init = ([], 0) in
let init = [], 0 in
let map path = path, f ~input:(Path path) ~path:(Some path) in
Parany.Parmap.parfold ~csize:16 number_of_workers map reduce init paths
let process ~f number_of_workers _bound_count sources =
match sources with
| `Paths paths ->
Parany.Parmap.parfold ~csize:16 number_of_workers (fun path -> f ~input:(Path path) ~output_path:(Some path)) (+) 0 paths
Parany.Parmap.parfold
~csize:16
number_of_workers
(fun path -> f ~input:(Path path) ~output_path:(Some path))
( + )
0
paths
| `Zip _ -> failwith "Not supported"

397
lib/app/pipeline/pipeline.ml
View File

@ -1,30 +1,25 @@
open Core
open Comby_kernel
open Configuration
open Command_configuration
open Command_input
open Statistics
open Matchers
let verbose_out_file = "/tmp/comby.out"
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
let timed_run
(module Matcher : Matcher.S)
?(fast_offset_conversion = false)
?filepath
~configuration
~source
~specification:(Specification.{ match_template = template; rule; rewrite_template })
() =
(module Matcher : Matcher.S)
?(fast_offset_conversion = false)
?filepath
~configuration
~source
~specification:Specification.{ match_template = template; rule; rewrite_template }
()
=
(match rewrite_template with
| Some template -> Matcher.set_rewrite_template template;
| Some template -> Matcher.set_rewrite_template template
| None -> ());
Matcher.all ~configuration ?filepath ?rule ~template ~source ()
|> List.map ~f:(Match.convert_offset ~fast:fast_offset_conversion ~source)
@ -35,28 +30,30 @@ type output =
| Nothing
let with_timeout timeout source ~f =
try Statistics.Time.time_out ~after:timeout f ();
with Statistics.Time.Time_out ->
try Statistics.Time.time_out ~after:timeout f () with
| Statistics.Time.Time_out ->
Format.eprintf "Timeout for input: %s!@." (show_input_kind source);
Out_channel.with_file ~append:true verbose_out_file ~f:(fun out_channel ->
Out_channel.output_lines out_channel [Format.sprintf "TIMEOUT: %s@." (show_input_kind source) ]);
Out_channel.output_lines
out_channel
[ Format.sprintf "TIMEOUT: %s@." (show_input_kind source) ]);
[]
let log_to_file path =
Out_channel.with_file ~append:true verbose_out_file ~f:(fun out_channel ->
Out_channel.output_lines out_channel [Format.sprintf "Processing %s%!" path])
Out_channel.output_lines out_channel [ Format.sprintf "Processing %s%!" path ])
let process_single_source
matcher
?(fast_offset_conversion = false)
?(verbose = false)
?(timeout = 3)
?metasyntax
?fresh
?(substitute_in_place = true)
configuration
source
(Specification.{ rewrite_template; _ } as specification)
matcher
?(fast_offset_conversion = false)
?(verbose = false)
?(timeout = 3)
?metasyntax
?fresh
?(substitute_in_place = true)
configuration
source
(Specification.{ rewrite_template; _ } as specification)
=
try
let filepath, input_text =
@ -68,33 +65,42 @@ let process_single_source
in
let matches =
with_timeout timeout source ~f:(fun () ->
timed_run
matcher
~fast_offset_conversion
~configuration
~specification
?filepath
~source:input_text
())
timed_run
matcher
~fast_offset_conversion
~configuration
~specification
?filepath
~source:input_text
())
in
match rewrite_template with
| None -> Matches (matches, List.length matches)
| Some rewrite_template ->
match matches with
| [] ->
(* If there are no matches, return the original source (for editor support) if substitute_in_place is active. *)
if substitute_in_place then
Replacement ([], input_text, 0)
else
Nothing
| matches ->
(* FIXME this should be configured where it's done in command_configuration.ml *)
let external_handler = External_semantic.lsif_hover in
let source = if substitute_in_place then Some input_text else None in
match Rewrite.all ?source ?metasyntax ?fresh ?filepath ~external_handler ~rewrite_template matches with
| None -> Nothing
| Some { rewritten_source; in_place_substitutions } ->
Replacement (in_place_substitutions, rewritten_source, List.length matches)
(match matches with
| [] ->
(* If there are no matches, return the original source (for editor support) if substitute_in_place is active. *)
if substitute_in_place then
Replacement ([], input_text, 0)
else
Nothing
| matches ->
(* FIXME this should be configured where it's done in command_configuration.ml *)
let external_handler = External_semantic.lsif_hover in
let source = if substitute_in_place then Some input_text else None in
(match
Rewrite.all
?source
?metasyntax
?fresh
?filepath
~external_handler
~rewrite_template
matches
with
| None -> Nothing
| Some { rewritten_source; in_place_substitutions } ->
Replacement (in_place_substitutions, rewritten_source, List.length matches)))
with
| exn ->
if debug then Format.eprintf "Big error: %s@." (Exn.to_string exn);
@ -111,7 +117,7 @@ let output_result output_printer source_path source_content result =
in the file again to output this format--the only efficient case is
when -stdin or -tar is used right now. We warn on it in command
configuration. *)
| Path path -> In_channel.read_all path
| Path path -> In_channel.read_all path
in
output_printer (Printer.Matches { source_path; source_content; matches })
| Replacement (replacements, result, _) ->
@ -132,54 +138,41 @@ type run_mode =
let run_on_specifications mode specifications process (input : single_source) =
let result =
List.fold specifications ~init:Nothing ~f:(fun result specification ->
let input =
match result with
| Nothing
| Matches _ -> input
| Replacement (_, content, _) -> String content
in
match result, process input specification with
| any, Nothing
| Nothing, any -> any
| Matches (l, n), Matches (l', n') ->
Matches (l@l', n+n')
| Replacement (l, _, n), Replacement (l', content, n') ->
Replacement (l@l', content, n+n')
| Matches _, Replacement (l, content, n)
| Replacement (l, content, n), Matches _ ->
Format.eprintf
"WARNING: input configuration specifies both rewrite \
and match templates. I am choosing to only process the \
configurations with both a 'match' and 'rewrite' part. \
If you only want to see matches, add -match-only to \
suppress this warning@.";
Replacement (l, content, n)
)
let input =
match result with
| Nothing | Matches _ -> input
| Replacement (_, content, _) -> String content
in
match result, process input specification with
| any, Nothing | Nothing, any -> any
| Matches (l, n), Matches (l', n') -> Matches (l @ l', n + n')
| Replacement (l, _, n), Replacement (l', content, n') -> Replacement (l @ l', content, n + n')
| Matches _, Replacement (l, content, n) | Replacement (l, content, n), Matches _ ->
Format.eprintf
"WARNING: input configuration specifies both rewrite and match templates. I am choosing \
to only process the configurations with both a 'match' and 'rewrite' part. If you only \
want to see matches, add -match-only to suppress this warning@.";
Replacement (l, content, n))
in
let count =
match result with
| Nothing -> 0
| Matches (_, n)
| Replacement (_, _, n) -> n
| Matches (_, n) | Replacement (_, _, n) -> n
in
match mode with
| Command_line { output_printer; output_path } ->
output_result output_printer output_path input result;
None, count
| Interactive ->
match result with
| Replacement (_, content, _) -> Some content, count
| _ -> None, 0
(match result with
| Replacement (_, content, _) -> Some content, count
| _ -> None, 0)
let write_statistics number_of_matches sources start_time =
let total_time = Statistics.Time.stop start_time in
let lines_of_code, number_of_files =
match sources with
| `String source ->
List.length (String.split_lines source), 1
| `String source -> List.length (String.split_lines source), 1
| `Paths paths ->
let lines_of_code = Fold.loc_paths paths in
lines_of_code, List.length paths
@ -188,51 +181,43 @@ let write_statistics number_of_matches sources start_time =
lines_of_code, List.length paths
| _ -> failwith "No statistics for this input kind"
in
let statistics =
{ number_of_files
; lines_of_code
; number_of_matches
; total_time = total_time
}
in
Format.eprintf "%s@."
@@ Yojson.Safe.pretty_to_string
@@ Statistics.to_yojson statistics
let statistics = { number_of_files; lines_of_code; number_of_matches; total_time } in
Format.eprintf "%s@." @@ Yojson.Safe.pretty_to_string @@ Statistics.to_yojson statistics
let run_batch ~f:per_unit sources compute_mode bound_count =
match compute_mode with
| `Sequential ->
Sequential.process ~f:per_unit bound_count sources
| `Sequential -> Sequential.process ~f:per_unit bound_count sources
| `Parany number_of_workers ->
Parallel_parany.process ~f:per_unit number_of_workers bound_count sources
| `Hack_parallel number_of_workers ->
Parallel_hack.process ~f:per_unit number_of_workers bound_count sources
let run_interactive
specifications
matcher
fast_offset_conversion
match_configuration
substitute_in_place
verbose
timeout
sources
compute_mode
interactive_review =
specifications
matcher
fast_offset_conversion
match_configuration
substitute_in_place
verbose
timeout
sources
compute_mode
interactive_review
=
let with_rewrites ~input ~path:_ =
run_on_specifications
Interactive
specifications
(fun (input : single_source) specification ->
process_single_source
matcher
~fast_offset_conversion
~verbose
~timeout
~substitute_in_place
match_configuration
input
specification)
process_single_source
matcher
~fast_offset_conversion
~verbose
~timeout
~substitute_in_place
match_configuration
input
specification)
input
in
let paths =
@ -243,8 +228,10 @@ let run_interactive
let rewrites, count =
match compute_mode with
| `Sequential -> Sequential.process_interactive ~f:with_rewrites paths
| `Parany number_of_workers -> Parallel_parany.process_interactive ~f:with_rewrites paths number_of_workers
| `Hack_parallel number_of_workers -> Parallel_hack.process_interactive ~f:with_rewrites paths number_of_workers
| `Parany number_of_workers ->
Parallel_parany.process_interactive ~f:with_rewrites paths number_of_workers
| `Hack_parallel number_of_workers ->
Parallel_hack.process_interactive ~f:with_rewrites paths number_of_workers
in
let { editor; default_is_accept } = interactive_review in
Interactive.run editor default_is_accept count rewrites;
@ -252,53 +239,55 @@ let run_interactive
module TarReader = struct
open Lwt
type in_channel = Lwt_unix.file_descr
type 'a t = 'a Lwt.t
let really_read fd = Lwt_cstruct.(complete (read fd))
let skip (ifd: Lwt_unix.file_descr) (n: int) =
let skip (ifd : Lwt_unix.file_descr) (n : int) =
let buffer_size = 32768 in
let buffer = Cstruct.create buffer_size in
let rec loop (n: int) =
if n <= 0 then Lwt.return_unit
else
let rec loop (n : int) =
if n <= 0 then
Lwt.return_unit
else (
let amount = min n buffer_size in
let block = Cstruct.sub buffer 0 amount in
really_read ifd block >>= fun () ->
loop (n - amount) in
really_read ifd block >>= fun () -> loop (n - amount))
in
loop n
let read_content ifd n =
let buffer = Cstruct.create n in
really_read ifd buffer >>= fun () ->
return (Cstruct.to_string buffer)
really_read ifd buffer >>= fun () -> return (Cstruct.to_string buffer)
end
let run
{ matcher
; sources
; specifications
; substitute_in_place
; run_options =
{ verbose
; match_timeout = timeout
; dump_statistics
; disable_substring_matching
; fast_offset_conversion
; match_newline_toplevel
; bound_count
; compute_mode
}
; output_printer
; interactive_review
; metasyntax
}
{ matcher
; sources
; specifications
; substitute_in_place
; run_options =
{ verbose
; match_timeout = timeout
; dump_statistics
; disable_substring_matching
; fast_offset_conversion
; match_newline_toplevel
; bound_count
; compute_mode
}
; output_printer
; interactive_review
; metasyntax
}
=
let fresh = match compute_mode with
let fresh =
match compute_mode with
| `Sequential -> None
| _ -> Some (fun () -> Uuid_unix.(Fn.compose Uuid.to_string create ()))
in
let match_configuration =
Matchers.Configuration.create
~disable_substring_matching
@ -309,61 +298,68 @@ let run
()
in
let start_time = Statistics.Time.start () in
let per_unit ~(input : single_source) ~output_path =
run_on_specifications
(Command_line { output_printer; output_path })
specifications
(fun input specification ->
process_single_source
matcher
~fast_offset_conversion
~verbose
~timeout
?metasyntax
?fresh
~substitute_in_place
match_configuration
input
specification)
process_single_source
matcher
~fast_offset_conversion
~verbose
~timeout
?metasyntax
?fresh
~substitute_in_place
match_configuration
input
specification)
input
|> snd (* only count result for Command_line *)
in
let count =
match interactive_review with
| None ->
begin match sources with
| `String source -> per_unit ~input:(String source) ~output_path:None
| `Tar ->
let open Lwt.Infix in
let fd = Lwt_unix.stdin in
let f =
let rec loop () =
Tar_lwt_unix.get_next_header fd >>= function
| None -> Lwt.return 0
| Some header ->
let debug () =
if debug then
Lwt_io.eprintf "Reading file %s\n Size %d\n" header.file_name (Int64.to_int_exn header.Tar.Header.file_size)
else
Lwt.return ()
in
debug () >>= fun () ->
let file_size = Int64.to_int_exn header.Tar.Header.file_size in
if file_size = 0 then
TarReader.skip fd (Tar.Header.compute_zero_padding_length header) >>= fun () ->
loop ()
else
TarReader.read_content fd file_size >>= fun source ->
let n = per_unit ~input:(String source) ~output_path:(Some header.file_name) in
TarReader.skip fd (Tar.Header.compute_zero_padding_length header) >>= fun () ->
loop () >>= fun n' -> Lwt.return (n+n')
in
loop ()
in
(try Lwt_main.run f with err -> Format.printf "Tar processing error: %s@." (Exn.to_string err); 0)
| #batch_input as sources -> run_batch ~f:per_unit sources compute_mode bound_count
end
(match sources with
| `String source -> per_unit ~input:(String source) ~output_path:None
| `Tar ->
let open Lwt.Infix in
let fd = Lwt_unix.stdin in
let f =
let rec loop () =
Tar_lwt_unix.get_next_header fd
>>= function
| None -> Lwt.return 0
| Some header ->
let debug () =
if debug then
Lwt_io.eprintf
"Reading file %s\n Size %d\n"
header.file_name
(Int64.to_int_exn header.Tar.Header.file_size)
else
Lwt.return ()
in
debug ()
>>= fun () ->
let file_size = Int64.to_int_exn header.Tar.Header.file_size in
if file_size = 0 then
TarReader.skip fd (Tar.Header.compute_zero_padding_length header)
>>= fun () -> loop ()
else
TarReader.read_content fd file_size
>>= fun source ->
let n = per_unit ~input:(String source) ~output_path:(Some header.file_name) in
TarReader.skip fd (Tar.Header.compute_zero_padding_length header)
>>= fun () -> loop () >>= fun n' -> Lwt.return (n + n')
in
loop ()
in
(try Lwt_main.run f with
| err ->
Format.printf "Tar processing error: %s@." (Exn.to_string err);
0)
| #batch_input as sources -> run_batch ~f:per_unit sources compute_mode bound_count)
| Some interactive_review ->
run_interactive
specifications
@ -380,14 +376,15 @@ let run
if dump_statistics then write_statistics count sources start_time
let execute
matcher
?timeout
?metasyntax
?fresh
?(configuration = Matchers.Configuration.create ())
?substitute_in_place
source
specification =
matcher
?timeout
?metasyntax
?fresh
?(configuration = Matchers.Configuration.create ())
?substitute_in_place
source
specification
=
process_single_source
matcher
~fast_offset_conversion:false

2
lib/app/pipeline/pipeline.mli
View File

@ -1,5 +1,4 @@
open Comby_kernel
open Configuration
open Command_input
@ -33,5 +32,4 @@ val execute
-> output
val with_timeout : int -> Command_input.single_source -> f:(unit -> 'a list) -> 'a list
val run : Command_configuration.t -> unit

6
lib/app/pipeline/sequential.ml
View File

@ -1,6 +1,6 @@
let process_interactive ~f paths =
Fold.interactive ~init:([], 0) ~f paths
let process_interactive ~f paths = Fold.interactive ~init:([], 0) ~f paths
let process ~f bound_count = function
| `Paths paths -> Fold.paths ~init:0 ~f bound_count paths
| `Zip (zip_file, paths) -> Fold.with_zip zip_file ~f:(fun zip -> Fold.zip_paths ~init:0 ~f zip paths bound_count)
| `Zip (zip_file, paths) ->
Fold.with_zip zip_file ~f:(fun zip -> Fold.zip_paths ~init:0 ~f zip paths bound_count)

12
lib/app/statistics/dune
View File

@ -1,6 +1,8 @@
(library
(name statistics)
(public_name comby.statistics)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving_yojson))
(libraries yojson ppx_deriving_yojson ppx_deriving_yojson.runtime))
(name statistics)
(public_name comby.statistics)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving_yojson))
(libraries yojson ppx_deriving_yojson ppx_deriving_yojson.runtime))

24
lib/app/statistics/statistics.ml
View File

@ -9,24 +9,16 @@ type t =
}
[@@deriving yojson]
let empty =
{ number_of_files = 0
; lines_of_code = 0
; number_of_matches = 0
; total_time = 0.0
}
let empty = { number_of_files = 0; lines_of_code = 0; number_of_matches = 0; total_time = 0.0 }
let merge
{ number_of_files
; lines_of_code
; number_of_matches
; total_time
}
{ number_of_files = number_of_files'
; lines_of_code = lines_of_code'
; number_of_matches = number_of_matches'
; total_time = total_time'
} =
{ number_of_files; lines_of_code; number_of_matches; total_time }
{ number_of_files = number_of_files'
; lines_of_code = lines_of_code'
; number_of_matches = number_of_matches'
; total_time = total_time'
}
=
{ number_of_files = number_of_files + number_of_files'
; lines_of_code = lines_of_code + lines_of_code'
; number_of_matches = number_of_matches + number_of_matches'

1
lib/app/statistics/statistics.mli
View File

@ -10,5 +10,4 @@ type t =
[@@deriving yojson]
val empty : t
val merge : t -> t -> t

8
lib/app/statistics/time.ml
View File

@ -1,14 +1,10 @@
let start () = Unix.gettimeofday ()
let stop start =
(Unix.gettimeofday () -. start) *. 1000.0
let stop start = (Unix.gettimeofday () -. start) *. 1000.0
exception Time_out
let time_out ~after f args =
let behavior =
Sys.(signal sigalrm @@ Signal_handle (fun _ -> raise Time_out))
in
let behavior = Sys.(signal sigalrm @@ Signal_handle (fun _ -> raise Time_out)) in
let cancel_alarm () =
Unix.alarm 0 |> ignore;
Sys.(set_signal sigalrm behavior)

12
lib/app/vendored/camlzip/dune
View File

@ -7,7 +7,9 @@
; as long as the unix parts are not needed, but I want it to
; compile executables for tests
(libraries unix)
(foreign_stubs (language c) (names zlibstubs))
(foreign_stubs
(language c)
(names zlibstubs))
(c_library_flags
(:include c_flags.sexp)
(:include c_library_flags.sexp)))
@ -21,7 +23,9 @@
(env
(dev
(flags (:standard -w A-3-4-27-29-32-34-35-39-40-41-42-44-45-48-49-50-57-60-69-70)))
(flags
(:standard -w A-3-4-27-29-32-34-35-39-40-41-42-44-45-48-49-50-57-60-69-70)))
(release
(flags (:standard -w A-3-4-27-29-32-34-35-39-40-41-42-44-45-48-49-50-57-60-69-70))
(ocamlopt_flags (-O3))))
(flags
(:standard -w A-3-4-27-29-32-34-35-39-40-41-42-44-45-48-49-50-57-60-69-70))
(ocamlopt_flags (-O3))))

7
lib/app/vendored/patdiff/kernel/src/dune
View File

@ -1,3 +1,6 @@
(library (name patdiff_kernel) (public_name comby.patdiff_kernel)
(library
(name patdiff_kernel)
(public_name comby.patdiff_kernel)
(libraries core_kernel.composition_infix core_kernel patience_diff re)
(preprocess (pps ppx_jane)))
(preprocess
(pps ppx_jane)))

13
lib/app/vendored/patdiff/lib/src/dune
View File

@ -1,4 +1,11 @@
(library (name patdiff) (public_name comby.patdiff)
(libraries core_kernel.composition_infix core core.linux_ext comby.patdiff_kernel
(library
(name patdiff)
(public_name comby.patdiff)
(libraries
core_kernel.composition_infix
core
core.linux_ext
comby.patdiff_kernel
patience_diff)
(preprocess (pps ppx_jane)))
(preprocess
(pps ppx_jane)))

14
lib/kernel/comby_kernel.ml
View File

@ -1,42 +1,40 @@
module Match = Match
type match' = Match.t
module Replacement = Replacement
type replacement = Replacement.result
module Matchers = struct
module Engine = Matchers.Engine
module Language = Matchers.Language
module Matcher = Matchers.Matcher
module Configuration = Matchers.Configuration
type configuration = Configuration.t
module Hole = Matchers.Hole
module Metasyntax = Matchers.Metasyntax
type metasyntax = Matchers.Metasyntax.t
module External = Matchers.External
module Alpha = Matchers.Alpha
module Omega = Matchers.Omega
module Languages = Matchers.Languages
module Template = Matchers.Template
module Ast = Matchers.Ast
module Rule = struct
include Matchers.Rule
include Matchers.Evaluate
end
type rule = Rule.t
module Specification = Matchers.Specification
type specification = Specification.t
module Rewrite = Matchers.Rewriter

80
lib/kernel/comby_kernel.mli
View File

@ -19,12 +19,10 @@ module Match : sig
val to_yojson : t -> Yojson.Safe.t
val of_yojson : Yojson.Safe.t -> (t, string) Result.t
val default : t
end
type location = Location.t
[@@deriving eq, sexp]
type location = Location.t [@@deriving eq, sexp]
module Range : sig
type t =
@ -35,19 +33,16 @@ module Match : sig
val to_yojson : t -> Yojson.Safe.t
val of_yojson : Yojson.Safe.t -> (t, string) Result.t
val default : t
end
type range = Range.t
[@@deriving eq, sexp]
type range = Range.t [@@deriving eq, sexp]
(** {3 Environment}
A match environment maps metavariables to values for a given match. *)
module Environment : sig
type t
[@@deriving eq]
type t [@@deriving eq]
val to_yojson : t -> Yojson.Safe.t
val of_yojson : Yojson.Safe.t -> (t, string) Result.t
@ -78,13 +73,9 @@ module Match : sig
val update_range : t -> string -> range -> t
val equal : t -> t -> bool
val copy : t -> t
val merge : t -> t -> t
val to_string : t -> string
val exists : t -> string -> bool
end
@ -120,9 +111,7 @@ module Match : sig
val chunk_match_to_yojson : chunk_match -> Yojson.Safe.t
val chunk_match_of_yojson : Yojson.Safe.t -> (chunk_match, string) Result.t
val to_chunks : ?threshold:int -> string -> t list -> chunk_match list
val pp_chunk_matches : Format.formatter -> string option * chunk_match list -> unit
(** [pp] is a grep-like formatted printer for matches. It accepts a (optional
@ -134,7 +123,6 @@ module Match : sig
val pp_json_lines : Format.formatter -> string option * t list -> unit
val pp_match_count : Format.formatter -> string option * t list -> unit
end
type match' = Match.t
@ -170,7 +158,6 @@ module Replacement : sig
}
val result_to_yojson : result -> Yojson.Safe.t
end
type replacement = Replacement.result
@ -180,7 +167,6 @@ type replacement = Replacement.result
Defines modules for matching a pattern in input sources to produce
matches. *)
module Matchers : sig
(** {3 Configuration}
Defines some parameters for changing match behavior. *)
@ -404,13 +390,12 @@ module Matchers : sig
| Constant of string
[@@deriving sexp]
type t = atom list
[@@deriving sexp]
type t = atom list [@@deriving sexp]
module Make : Metasyntax.S -> External.S -> sig
val parse : string -> t
val variables : string -> syntax list
end
module Make (_ : Metasyntax.S) (_ : External.S) : sig
val parse : string -> t
val variables : string -> syntax list
end
end
(** {3 AST}
@ -422,8 +407,7 @@ module Matchers : sig
| String of string
[@@deriving sexp]
type antecedent = atom
[@@deriving sexp]
type antecedent = atom [@@deriving sexp]
type expression =
| True
@ -433,8 +417,8 @@ module Matchers : sig
| Not_equal of atom * atom
| Match of atom * (antecedent * consequent) list
| Rewrite of atom * (antecedent * atom)
and consequent = expression list
[@@deriving sexp]
and consequent = expression list [@@deriving sexp]
end
(** {3 Matcher}
@ -480,9 +464,7 @@ module Matchers : sig
Defines types and operations for match rules. *)
and Rule : sig
type t = Ast.expression list
[@@deriving sexp]
type t = Ast.expression list [@@deriving sexp]
type options =
{ nested : bool
@ -514,13 +496,13 @@ module Matchers : sig
-> ?metasyntax:Metasyntax.t
-> ?external_handler:External.t
-> ?filepath:string
-> match_all:(
?configuration:Configuration.t
-> ?filepath:string
-> template:string
-> source:string
-> unit
-> Match.t list)
-> match_all:
(?configuration:Configuration.t
-> ?filepath:string
-> template:string
-> source:string
-> unit
-> Match.t list)
-> Ast.expression list
-> Match.Environment.t
-> result
@ -552,18 +534,15 @@ module Matchers : sig
type specification = Specification.t
(** {3 Language}
Language definitions *)
module Language : sig
(** {4 Syntax}
Defines the syntax structures for the target language (C, Go, etc.) that
are significant for matching. *)
module Syntax : sig
(** Defines a set of quoted syntax for strings based on one or more
delimiters and associated escape chracter.
@ -571,7 +550,7 @@ module Matchers : sig
as: { delimiters = [ {|"|}, {|'|} ]; escape_character = '\\' } *)
type escapable_string_literals =
{ delimiters : string list
; escape_character: char
; escape_character : char
}
(** Defines comment syntax as one of Multiline, Nested_multiline with
@ -679,16 +658,16 @@ module Matchers : sig
module C_nested_comments : Language.S
val all : (module Language.S) list
val select_with_extension : string -> (module Language.S) option
end
module Engine : sig
module type S = sig
module Make : Language.S -> Metasyntax.S -> External.S -> Matcher.S
module Make (_ : Language.S) (_ : Metasyntax.S) (_ : External.S) : Matcher.S
(** {4 Supported Matchers} *)
module Text : Matcher.S
module Paren : Matcher.S
module Dyck : Matcher.S
module JSON : Matcher.S
@ -735,10 +714,10 @@ module Matchers : sig
module Haskell : Matcher.S
module HCL : Matcher.S
module Elm : Matcher.S
module Zig: Matcher.S
module Coq: Matcher.S
module Move: Matcher.S
module Solidity: Matcher.S
module Zig : Matcher.S
module Coq : Matcher.S
module Move : Matcher.S
module Solidity : Matcher.S
module C_nested_comments : Matcher.S
(** [all] returns all default matchers. *)
@ -758,13 +737,16 @@ module Matchers : sig
-> string
-> (module Matcher.S) option
(** [create metasyntax external syntax] creates a matcher for a language
defined by [syntax]. If [metasyntax] is specified, the matcher will use
a custom metasyntax definition instead of the default. An experimental
[external] callback is a general callback for handling external
properties in the rewrite template. *)
val create : ?metasyntax:metasyntax -> ?external_handler:External.t -> Language.Syntax.t -> (module Matcher.S)
val create
: ?metasyntax:metasyntax
-> ?external_handler:External.t
-> Language.Syntax.t
-> (module Matcher.S)
end
end

22
lib/kernel/dune
View File

@ -1,11 +1,13 @@
(library
(name comby_kernel)
(public_name comby-kernel)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries
core_kernel
comby-kernel.match
comby-kernel.matchers
comby-kernel.replacement
yojson))
(name comby_kernel)
(public_name comby-kernel)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries
core_kernel
comby-kernel.match
comby-kernel.matchers
comby-kernel.replacement
yojson))

16
lib/kernel/match/dune
View File

@ -1,6 +1,12 @@
(library
(name match)
(public_name comby-kernel.match)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving.eq ppx_sexp_conv ppx_deriving_yojson))
(libraries core_kernel yojson ppx_deriving_yojson ppx_deriving_yojson.runtime))
(name match)
(public_name comby-kernel.match)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving.eq ppx_sexp_conv ppx_deriving_yojson))
(libraries
core_kernel
yojson
ppx_deriving_yojson
ppx_deriving_yojson.runtime))

88
lib/kernel/match/environment.ml
View File

@ -9,16 +9,12 @@ module Data = struct
end
open Data
type data = Data.t
[@@deriving yojson, eq, sexp]
type data = Data.t [@@deriving yojson, eq, sexp]
type t = (string, data, Base.String.comparator_witness) Base.Map.t
let create () : t =
Map.empty (module String)
let vars (env : t) : string list =
Map.keys env
let create () : t = Map.empty (module String)
let vars (env : t) : string list = Map.keys env
let add ?(range = Range.default) (env : t) (var : string) (value : string) : t =
Map.add env ~key:var ~data:{ value; range }
@ -27,15 +23,12 @@ let add ?(range = Range.default) (env : t) (var : string) (value : string) : t =
| `Ok env -> env
let lookup (env : t) (var : string) : string option =
Map.find env var
|> Option.map ~f:(fun { value; _ } -> value)
Map.find env var |> Option.map ~f:(fun { value; _ } -> value)
let lookup_range (env : t) (var : string) : Range.t option =
Map.find env var
|> Option.map ~f:(fun { range; _ } -> range)
Map.find env var |> Option.map ~f:(fun { range; _ } -> range)
let fold (env : t) =
Map.fold env
let fold (env : t) = Map.fold env
let update env var value =
Map.change env var ~f:(Option.map ~f:(fun result -> { result with value }))
@ -45,39 +38,28 @@ let update_range env var range =
let to_string env =
Map.fold env ~init:"" ~f:(fun ~key:variable ~data:{ value; _ } acc ->
Format.sprintf "%s |-> %s\n%s" variable value acc)
Format.sprintf "%s |-> %s\n%s" variable value acc)
let furthest_match env =
Map.fold
env
~init:0
~f:(fun ~key:_ ~data:{ range = { match_start = { offset; _ }; _ }; _ } max ->
Int.max offset max)
Map.fold env ~init:0 ~f:(fun ~key:_ ~data:{ range = { match_start = { offset; _ }; _ }; _ } max ->
Int.max offset max)
let equal env1 env2 =
Map.equal Data.equal env1 env2
let merge env1 env2 =
Map.merge_skewed env1 env2 ~combine:(fun ~key:_ v1 _ -> v1)
let equal env1 env2 = Map.equal Data.equal env1 env2
let merge env1 env2 = Map.merge_skewed env1 env2 ~combine:(fun ~key:_ v1 _ -> v1)
let copy env =
fold env ~init:(create ()) ~f:(fun ~key ~data:{ value; range } env' ->
add ~range env' key value)
fold env ~init:(create ()) ~f:(fun ~key ~data:{ value; range } env' -> add ~range env' key value)
let exists env key =
Option.is_some (lookup env key)
let exists env key = Option.is_some (lookup env key)
let to_yojson env : Yojson.Safe.t =
let s =
Map.fold_right env ~init:[] ~f:(fun ~key:variable ~data:{value; range} acc ->
let item =
`Assoc
[ ("variable", `String variable)
; ("value", `String value)
; ("range", Range.to_yojson range)
]
in
item::acc)
Map.fold_right env ~init:[] ~f:(fun ~key:variable ~data:{ value; range } acc ->
let item =
`Assoc
[ "variable", `String variable; "value", `String value; "range", Range.to_yojson range ]
in
item :: acc)
in
`List s
@ -87,22 +69,20 @@ let of_yojson (json : Yojson.Safe.t) =
match json with
| `List l ->
List.fold l ~init:env ~f:(fun env json ->
let variable = member "variable" json |> to_string_option in
let value = member "value" json |> to_string_option in
let range =
member "range" json
|> function
| `Null -> Some Range.default
| json ->
Range.of_yojson json
|> function
| Ok range -> Some range
| Error _ -> None
in
match variable, value with
| Some variable, Some value ->
add env ?range variable value
| _ ->
env)
let variable = member "variable" json |> to_string_option in
let value = member "value" json |> to_string_option in
let range =
member "range" json
|> function
| `Null -> Some Range.default
| json ->
Range.of_yojson json
|> (function
| Ok range -> Some range
| Error _ -> None)
in
match variable, value with
| Some variable, Some value -> add env ?range variable value
| _ -> env)
|> Result.return
| _ -> Error "Invalid JSON for environment"

14
lib/kernel/match/environment.mli
View File

@ -1,26 +1,14 @@
type t
[@@deriving yojson]
type t [@@deriving yojson]
val create : unit -> t
val vars : t -> string list
val add : ?range:Range.t -> t -> string -> string -> t
val lookup : t -> string -> string option
val update : t -> string -> string -> t
val lookup_range : t -> string -> Range.t option
val update_range : t -> string -> Range.t -> t
val equal : t -> t -> bool
val merge : t -> t -> t
val copy : t -> t
val exists : t -> string -> bool
val to_string : t -> string

6
lib/kernel/match/location.ml
View File

@ -7,8 +7,4 @@ type t =
}
[@@deriving yojson, eq, sexp]
let default =
{ offset = -1
; line = -1
; column = -1
}
let default = { offset = -1; line = -1; column = -1 }

1
lib/kernel/match/match.ml
View File

@ -2,7 +2,6 @@ module Location = Location
module Range = Range
module Environment = Environment
module Offset = Offset
include Types
include Match_context
include Match_chunk

31
lib/kernel/match/match.mli
View File

@ -9,8 +9,7 @@ module Location : sig
val default : t
end
type location = Location.t
[@@deriving yojson, eq, sexp]
type location = Location.t [@@deriving yojson, eq, sexp]
module Range : sig
type t =
@ -22,50 +21,33 @@ module Range : sig
val default : t
end
type range = Range.t
[@@deriving yojson, eq, sexp]
type range = Range.t [@@deriving yojson, eq, sexp]
module Environment : sig
type t
[@@deriving yojson, eq]
type t [@@deriving yojson, eq]
val create : unit -> t
val vars : t -> string list
val add : ?range:range -> t -> string -> string -> t
val lookup : t -> string -> string option
val update : t -> string -> string -> t
val lookup_range : t -> string -> range option
val update_range : t -> string -> range -> t
val equal : t -> t -> bool
val copy : t -> t
val merge : t -> t -> t
val to_string : t -> string
val exists : t -> string -> bool
end
type environment = Environment.t
[@@deriving yojson]
type environment = Environment.t [@@deriving yojson]
module Offset : sig
type index_t
val empty : index_t
val index : source:string -> index_t
val convert_fast : offset:int -> index_t -> int * int
val convert_slow : offset:int -> source:string -> int * int
end
@ -77,13 +59,9 @@ type t =
[@@deriving yojson]
val create : ?range:range -> unit -> t
val convert_offset : fast:bool -> source:string -> t -> t
val pp : Format.formatter -> string option * t list -> unit
val pp_json_lines : Format.formatter -> string option * t list -> unit
val pp_match_count : Format.formatter -> string option * t list -> unit
type chunk_match =
@ -94,5 +72,4 @@ type chunk_match =
[@@deriving yojson]
val to_chunks : ?threshold:int -> string -> t list -> chunk_match list
val pp_chunk_matches : Format.formatter -> string option * chunk_match list -> unit

40
lib/kernel/match/match_chunk.ml
View File

@ -11,65 +11,55 @@ type chunk_match =
let slice_source source { match_start = { offset = start; _ }; match_end = { offset = _end; _ } } =
let open Option in
let index f o = f source o '\n' in
let first_line = Option.value ~default:0 (index String.rindex_from start >>| (+) 1) in
let first_line = Option.value ~default:0 (index String.rindex_from start >>| ( + ) 1) in
let last_line = Option.value ~default:(String.length source) (index String.index_from _end) in
(first_line, String.slice source first_line last_line)
first_line, String.slice source first_line last_line
let to_range_chunk source (cover, ranges) =
let offset, content = slice_source source cover in
{ content
; start =
{ offset
; line = cover.match_start.line
; column = 1
}
; ranges
}
{ content; start = { offset; line = cover.match_start.line; column = 1 }; ranges }
let compare left right =
Int.compare left.match_start.offset right.match_start.offset
let compare left right = Int.compare left.match_start.offset right.match_start.offset
let to_chunks ?(threshold = 0) source (l : Match_context.t list) =
let _threshold = threshold in (* FIXME: suppress unused *)
let _threshold = threshold in
(* FIXME: suppress unused *)
List.map l ~f:(fun { range; _ } -> range)
|> List.sort ~compare
|> function
| [] -> []
| hd :: tl ->
List.fold ~init:[(hd, [hd])] tl ~f:(fun acc current ->
List.fold
~init:[ hd, [ hd ] ]
tl
~f:(fun acc current ->
let cover, ranges, rest =
match acc with
| (cover, ranges) :: tl -> cover, ranges, tl
| _ -> assert false
in
if cover.match_end.line >= current.match_start.line then
if cover.match_end.line >= current.match_start.line then (
let cover =
if current.match_end.offset > cover.match_end.offset then
{ cover with match_end = current.match_end }
else
cover
in
(cover, ranges @ [current]) :: rest
(cover, ranges @ [ current ]) :: rest)
else
(current, [current]) :: acc)
(current, [ current ]) :: acc)
|> List.rev_map ~f:(to_range_chunk source)
let to_json source_path matches =
let json_matches matches =
matches
|> List.map ~f:chunk_match_to_yojson
|> fun matches ->
`List matches
matches |> List.map ~f:chunk_match_to_yojson |> fun matches -> `List matches
in
let uri =
match source_path with
| Some path -> `String path
| None -> `Null
in
`Assoc
[ ("uri", uri)
; ("matches", json_matches matches)
]
`Assoc [ "uri", uri; "matches", json_matches matches ]
let pp_chunk_matches ppf (source_path, matches) =
Format.fprintf ppf "%s\n" @@ Yojson.Safe.to_string @@ to_json source_path matches

54
lib/kernel/match/match_context.ml
View File

@ -8,10 +8,7 @@ type t =
[@@deriving yojson]
let create ?(range = Range.default) () =
{ range
; environment = Environment.create ()
; matched = ""
}
{ range; environment = Environment.create (); matched = "" }
let update_range f range =
let open Range in
@ -26,13 +23,11 @@ let update_range f range =
let update_environment f env =
List.fold (Environment.vars env) ~init:env ~f:(fun env var ->
let open Option in
let updated =
Environment.lookup_range env var
>>| update_range f
>>| Environment.update_range env var
in
Option.value_exn updated)
let open Option in
let updated =
Environment.lookup_range env var >>| update_range f >>| Environment.update_range env var
in
Option.value_exn updated)
let update_match f m =
let range = update_range f m.range in
@ -56,52 +51,39 @@ let convert_offset ~fast ~source match_ =
let update_environment f env =
List.fold (Environment.vars env) ~init:env ~f:(fun env var ->
let open Option in
let updated =
Environment.lookup env var
>>| f
>>| Environment.update env var
in
Option.value_exn updated)
let open Option in
let updated = Environment.lookup env var >>| f >>| Environment.update env var in
Option.value_exn updated)
let to_json source_path matches =
let json_matches matches =
matches
|> List.map ~f:to_yojson
|> fun matches ->
`List matches
in
let json_matches matches = matches |> List.map ~f:to_yojson |> fun matches -> `List matches in
let uri =
match source_path with
| Some path -> `String path
| None -> `Null
in
`Assoc
[ ("uri", uri)
; ("matches", json_matches matches)
]
`Assoc [ "uri", uri; "matches", json_matches matches ]
let pp_source_path ppf source_path =
match source_path with
| Some path -> Format.fprintf ppf "%s:" path
| None -> Format.fprintf ppf ""
let pp_line_number ppf start_line =
Format.fprintf ppf "%d:" start_line
let pp_line_number ppf start_line = Format.fprintf ppf "%d:" start_line
let pp ppf (source_path, matches) =
if List.is_empty matches then
()
else
else (
let matched =
List.map matches ~f:(fun { matched; range; _ } ->
let matched = String.substr_replace_all matched ~pattern:"\n" ~with_:"\\n" in
let matched = String.substr_replace_all matched ~pattern:"\r" ~with_:"\\r" in
let line = range.match_start.line in
Format.asprintf "%a%a%s" pp_source_path source_path pp_line_number line matched)
let matched = String.substr_replace_all matched ~pattern:"\n" ~with_:"\\n" in
let matched = String.substr_replace_all matched ~pattern:"\r" ~with_:"\\r" in
let line = range.match_start.line in
Format.asprintf "%a%a%s" pp_source_path source_path pp_line_number line matched)
|> String.concat ~sep:"\n"
in
Format.fprintf ppf "%s@." matched
Format.fprintf ppf "%s@." matched)
let pp_match_count ppf (source_path, matches) =
let l = List.length matches in

35
lib/kernel/match/offset.ml
View File

@ -9,7 +9,7 @@ let empty = [||]
in lines, and column offset. *)
let index ~source =
let total_len = String.length source in
let num_lines = List.length @@ String.split_on_chars source ~on:['\n'] in
let num_lines = List.length @@ String.split_on_chars source ~on:[ '\n' ] in
(* Add one, where a[0] is empty, which is not used, so that everything is 1-based. *)
let len = num_lines + 1 in
let a = Array.create ~len Int.max_value in
@ -18,11 +18,14 @@ let index ~source =
let f char =
match char with
| '\n' ->
offset := !offset + 1; (* Add one to offset for \n. *)
a.(!line_index) <- !offset; (* Add to line count. *)
line_index := !line_index + 1; (* Do next line. *)
offset := !offset + 1;
(* Add one to offset for \n. *)
a.(!line_index) <- !offset;
(* Add to line count. *)
line_index := !line_index + 1 (* Do next line. *)
| _ ->
if !offset = total_len then (* If it's the last char and wasn't a newline, record this offset. *)
if !offset = total_len then
(* If it's the last char and wasn't a newline, record this offset. *)
a.(!line_index) <- !offset
else
offset := !offset + 1
@ -32,18 +35,18 @@ let index ~source =
let rec binary_search a value low high =
if high <= low then
(if value >= a.(low) && value < a.(low+1) then
low+1
else
low)
else let mid = (low + high) / 2 in
if value >= a.(low) && value < a.(low + 1) then
low + 1
else
low
else (
let mid = (low + high) / 2 in
if a.(mid) > value then
binary_search a value low (mid - 1)
else if a.(mid) < value then
binary_search a value (mid + 1) high
else
(* if mid is exactly equal, then return line + 1 *)
mid + 1
else (* if mid is exactly equal, then return line + 1 *)
mid + 1)
(* Offset is 0 based, line map is 1-based. Output is 1-based for line and col. *)
let convert_fast ~offset index =
@ -54,9 +57,9 @@ let convert_fast ~offset index =
let convert_slow ~offset ~source =
let f (offset, line, col) char =
match offset, char with
| 0, _ -> (0, line, col)
| _, '\n' -> (offset - 1, line + 1, 1)
| _ -> (offset - 1, line, col + 1)
| 0, _ -> 0, line, col
| _, '\n' -> offset - 1, line + 1, 1
| _ -> offset - 1, line, col + 1
in
let _, line, col = String.fold ~init:(offset, 1, 1) ~f source in
line, col

3
lib/kernel/match/offset.mli
View File

@ -1,9 +1,6 @@
type index_t
val empty : index_t
val index : source:string -> index_t
val convert_fast : offset:int -> index_t -> int * int
val convert_slow : offset:int -> source:string -> int * int

5
lib/kernel/match/range.ml
View File

@ -4,7 +4,4 @@ type t =
}
[@@deriving yojson, eq, sexp]
let default =
{ match_start = Location.default
; match_end = Location.default
}
let default = { match_start = Location.default; match_end = Location.default }

11
lib/kernel/match/types.ml
View File

@ -1,8 +1,3 @@
type location = Location.t
[@@deriving yojson, eq, sexp]
type range = Range.t
[@@deriving yojson, eq, sexp]
type environment = Environment.t
[@@deriving yojson]
type location = Location.t [@@deriving yojson, eq, sexp]
type range = Range.t [@@deriving yojson, eq, sexp]
type environment = Environment.t [@@deriving yojson]

1215
lib/kernel/matchers/alpha.ml
View File

File diff suppressed because it is too large Load Diff

3
lib/kernel/matchers/alpha.mli
View File

@ -1,3 +1,2 @@
open Types
module Make : Language.S -> Metasyntax.S -> External.S -> Matcher.S
module Make (_ : Language.S) (_ : Metasyntax.S) (_ : External.S) : Matcher.S

5
lib/kernel/matchers/ast.ml
View File

@ -1,5 +1,4 @@
open Types.Ast
let (=) left right = Equal (left, right)
let (<>) left right = Not_equal (left, right)
let ( = ) left right = Equal (left, right)
let ( <> ) left right = Not_equal (left, right)

15
lib/kernel/matchers/configuration.ml
View File

@ -18,13 +18,14 @@ let counter =
Format.sprintf "!@#$%012d" !uuid_for_id_counter
let create
?(disable_substring_matching = false)
?(match_kind = Fuzzy)
?(significant_whitespace = false)
?(match_newline_toplevel = true)
?(fresh = counter)
?(substitute_in_place = true)
() =
?(disable_substring_matching = false)
?(match_kind = Fuzzy)
?(significant_whitespace = false)
?(match_newline_toplevel = true)
?(fresh = counter)
?(substitute_in_place = true)
()
=
{ match_kind
; significant_whitespace
; disable_substring_matching

22
lib/kernel/matchers/dune
View File

@ -1,6 +1,18 @@
(library
(name matchers)
(public_name comby-kernel.matchers)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_here ppx_sexp_conv ppx_sexp_message ppx_deriving_yojson))
(libraries comby-kernel.replacement comby-kernel.parsers comby-kernel.match comby-kernel.vangstrom core_kernel mparser mparser-pcre re yojson ppx_deriving_yojson))
(name matchers)
(public_name comby-kernel.matchers)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_here ppx_sexp_conv ppx_sexp_message ppx_deriving_yojson))
(libraries
comby-kernel.replacement
comby-kernel.parsers
comby-kernel.match
comby-kernel.vangstrom
core_kernel
mparser
mparser-pcre
re
yojson
ppx_deriving_yojson))

47
lib/kernel/matchers/engine.ml
View File

@ -1,19 +1,20 @@
open Core_kernel
open Languages
module Make (Make : Types.Language.S -> Types.Metasyntax.S -> Types.External.S -> Types.Matcher.S) : Types.Engine.S = struct
module Make
(Make : functor
(_ : Types.Language.S)
(_ : Types.Metasyntax.S)
(_ : Types.External.S)
-> Types.Matcher.S) : Types.Engine.S = struct
module Make = Make
let create
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
Types.Language.Syntax.
{ user_defined_delimiters
; escapable_string_literals
; raw_string_literals
; comments
} =
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
Types.Language.Syntax.
{ user_defined_delimiters; escapable_string_literals; raw_string_literals; comments }
=
let module Info = struct
let name = "User_defined_language"
let extensions = []
@ -32,7 +33,10 @@ module Make (Make : Types.Language.S -> Types.Metasyntax.S -> Types.External.S -
end
in
let (module Metasyntax : Metasyntax.S) = Metasyntax.(create metasyntax) in
let module External = struct let handler = external_handler end in
let module External = struct
let handler = external_handler
end
in
(module Make (User_language) (Metasyntax) (External) : Types.Matcher.S)
module Text = Make (Text) (Metasyntax.Default) (External.Default)
@ -83,7 +87,7 @@ module Make (Make : Types.Language.S -> Types.Metasyntax.S -> Types.External.S -
module HCL = Make (HCL) (Metasyntax.Default) (External.Default)
module Elm = Make (Elm) (Metasyntax.Default) (External.Default)
module Zig = Make (Zig) (Metasyntax.Default) (External.Default)
module Coq = Make (Coq) (Metasyntax.Default) (External.Default)
module Coq = Make (Coq) (Metasyntax.Default) (External.Default)
module Move = Make (Move) (Metasyntax.Default) (External.Default)
module Solidity = Make (Solidity) (Metasyntax.Default) (External.Default)
module C_nested_comments = Make (C_nested_comments) (Metasyntax.Default) (External.Default)
@ -143,13 +147,18 @@ module Make (Make : Types.Language.S -> Types.Metasyntax.S -> Types.External.S -
]
let select_with_extension
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
extension
: (module Types.Matcher.S) option =
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
extension
: (module Types.Matcher.S) option
=
let open Option in
Languages.select_with_extension extension >>| fun (module Language : Types.Language.S) ->
Languages.select_with_extension extension
>>| fun (module Language : Types.Language.S) ->
let (module Metasyntax) = Metasyntax.(create metasyntax) in
let module External = struct let handler = external_handler end in
(module (Make (Language) (Metasyntax) (External)) : Types.Matcher.S)
let module External = struct
let handler = external_handler
end
in
(module Make (Language) (Metasyntax) (External) : Types.Matcher.S)
end

3
lib/kernel/matchers/engine.mli
View File

@ -1,3 +1,4 @@
open Types
module Make : (Language.S -> Metasyntax.S -> External.S -> Matcher.S) -> Engine.S
module Make (_ : functor (_ : Language.S) (_ : Metasyntax.S) (_ : External.S) -> Matcher.S) :
Engine.S

96
lib/kernel/matchers/evaluate.ml
View File

@ -1,5 +1,4 @@
open Core_kernel
open Match
open Types.Ast
@ -11,45 +10,48 @@ let debug =
type result = bool * Match.environment option
let sat = fst
let result_env = snd
let merge_match_environments matches environment' =
List.map matches ~f:(fun { environment; _ } ->
Environment.merge environment environment')
List.map matches ~f:(fun { environment; _ } -> Environment.merge environment environment')
let apply
?(substitute_in_place = true)
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
?filepath
~(match_all:(?configuration:Configuration.t -> ?filepath:string -> template:string -> source:string -> unit -> Match.t list))
rule
env =
?(substitute_in_place = true)
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
?filepath
~(match_all :
?configuration:Configuration.t
-> ?filepath:string
-> template:string
-> source:string
-> unit
-> Match.t list)
rule
env
=
let (module Metasyntax) = Metasyntax.create metasyntax in
let module External = struct let handler = external_handler end in
let (module Template : Types.Template.S) = (module (Template.Make(Metasyntax)(External))) in
let module External = struct
let handler = external_handler
end
in
let (module Template : Types.Template.S) = (module Template.Make (Metasyntax) (External)) in
let match_configuration_of_syntax template =
(* decide match configuration based on whether there are holes *)
match Template.variables template with
| [] -> Configuration.create ~match_kind:Exact ()
| _ -> Configuration.create ~match_kind:Fuzzy ()
in
let rewrite_substitute template env =
Rewrite.substitute ~metasyntax ~external_handler ?filepath template env in
Rewrite.substitute ~metasyntax ~external_handler ?filepath template env
in
let substitute env v =
match v with
| Template t ->
rewrite_substitute (Template.to_string t) env
| Template t -> rewrite_substitute (Template.to_string t) env
| String s -> s
in
(* accepts only one expression *)
let rec eval env =
function
let rec eval env = function
(* true *)
| True -> true, Some env
(* false *)
@ -57,8 +59,7 @@ let apply
(* option *)
| Option _ -> true, Some env
(* ==, != *)
| Equal (Template t, String value)
| Equal (String value, Template t) ->
| Equal (Template t, String value) | Equal (String value, Template t) ->
let other = rewrite_substitute (Template.to_string t) env in
let result = String.equal value other in
result, Some env
@ -73,7 +74,6 @@ let apply
| Not_equal (left, right) ->
let sat, env = eval env (Equal (left, right)) in
not sat, env
(* match ... { ... } *)
| Match (source, cases) ->
let source = substitute env source in
@ -82,28 +82,26 @@ let apply
let configuration = match_configuration_of_syntax template in
let configuration = { configuration with substitute_in_place } in
if debug then Format.printf "Running for template %s source %s@." template source;
match_all ~configuration ~template ~source () |> function
| [] ->
None
match_all ~configuration ~template ~source ()
|> function
| [] -> None
| matches ->
(* merge environments. overwrite behavior is undefined *)
if debug then Format.printf "Matches: %a@." Match.pp (None, matches);
let fold_matches (sat, out) { environment; _ } =
let fold_cases (sat, out) predicate =
if sat then
if sat then (
let env' = Environment.merge env environment in
eval env' predicate
eval env' predicate)
else
(sat, out)
sat, out
in
List.fold case_expression ~init:(sat, out) ~f:fold_cases
in
List.fold matches ~init:(true, None) ~f:fold_matches
|> Option.some
List.fold matches ~init:(true, None) ~f:fold_matches |> Option.some
in
List.find_map cases ~f:(fun (template, case_expression) -> evaluate template case_expression)
|> Option.value_map ~f:ident ~default:(false, Some env)
(* rewrite ... { ... } *)
| Rewrite (Template t, (match_template, rewrite_template)) ->
let rewrite_template = substitute env rewrite_template in
@ -115,12 +113,12 @@ let apply
let source = if substitute_in_place then Some source else None in
let result = Rewrite.all ~metasyntax ?filepath ?source ~rewrite_template matches in
if Option.is_empty result then
(if substitute_in_place then
(* rewrites are always sat for in-place. always unsat for newline-sep. *)
true, Some env
else
false, Some env)
else
if substitute_in_place then
(* rewrites are always sat for in-place. always unsat for newline-sep. *)
true, Some env
else
false, Some env
else (
let Replacement.{ rewritten_source; _ } = Option.value_exn result in
(* substitute for variables that are in the outside scope *)
let rewritten_source = rewrite_substitute rewritten_source env in
@ -130,18 +128,12 @@ let apply
| _ -> failwith "Cannot substitute for this template"
in
let env = Environment.update env variable rewritten_source in
true, Some env
true, Some env)
| Rewrite _ -> failwith "TODO/Invalid: Have not decided whether rewrite \":[x]\" is useful."
in
List.fold rule ~init:(true, None) ~f:(fun (sat, out) predicate ->
if sat then
let env =
Option.value_map out
~f:(fun out -> Environment.merge out env)
~default:env
in
eval env predicate
else
(sat, out))
if sat then (
let env = Option.value_map out ~f:(fun out -> Environment.merge out env) ~default:env in
eval env predicate)
else
sat, out)

3
lib/kernel/matchers/external.ml
View File

@ -1,7 +1,6 @@
include Types.External
let default_external =
fun ~name:_ ~filepath:_ ~line:_ ~column:_ -> None
let default_external ~name:_ ~filepath:_ ~line:_ ~column:_ = None
let default =
let module External = struct

2
lib/kernel/matchers/external.mli
View File

@ -1,9 +1,7 @@
open Types
include module type of External
val default_external : External.t
val default : (module External.S)
module Default : External.S

480
lib/kernel/matchers/languages.ml
View File

File diff suppressed because it is too large Load Diff

2
lib/kernel/matchers/languages.mli
View File

@ -1,5 +1,4 @@
open Types
module Text : Language.S
module Paren : Language.S
module Dyck : Language.S
@ -54,5 +53,4 @@ module Solidity : Language.S
module C_nested_comments : Language.S
val all : (module Language.S) list
val select_with_extension : string -> (module Language.S) option

9
lib/kernel/matchers/matchers.ml
View File

@ -3,21 +3,20 @@ module Languages = Languages
module Metasyntax = Metasyntax
module External = External
module Rule = Rule
module Ast = struct
include Types.Ast
include Ast
end
module Evaluate = Evaluate
module Alpha = Engine.Make(Alpha.Make)
module Omega = Engine.Make(Omega.Make)
module Alpha = Engine.Make (Alpha.Make)
module Omega = Engine.Make (Omega.Make)
module Engine = Types.Engine
module Matcher = Types.Matcher
module Hole = Types.Hole
module Language = Types.Language
module Script = Script
module Specification = Specification
module Template = struct

3
lib/kernel/matchers/matchers.mli
View File

@ -7,16 +7,13 @@ module Rule = Rule
(* Only need to expose Types.Ast. module type of to export sexp. *)
module Ast : module type of Types.Ast
module Evaluate = Evaluate
module Alpha : Types.Engine.S
module Omega : Types.Engine.S
module Engine = Types.Engine
module Matcher = Types.Matcher
module Hole = Types.Hole
module Language = Types.Language
module Script : module type of Script
module Specification : module type of Specification
module Template : sig

49
lib/kernel/matchers/metasyntax.ml
View File

@ -7,26 +7,42 @@ let default_syntax =
; Hole (Non_space, Delimited (Some ":[", Some ".]"))
; Hole (Line, Delimited (Some ":[", Some "\\n]"))
; Hole (Blank, Delimited (Some ":[ ", Some "]"))
; Hole (Expression, Reserved_identifiers ["α"; "β"; "γ"; "δ"; "ε"; "ζ"; "η"; "θ"; "ι"; "κ"; "λ"; "μ"; "ξ"; "π"; "ρ"; "ς"; "σ"; "τ"; "υ"; "φ"; "χ"; "ψ"; "ω"])
; Hole (Everything, Reserved_identifiers ["Γ"; "Δ"; "Θ"; "Λ"; "Ξ"; "Π"; "Σ"; "Φ"; "Ψ"; "Ω"])
; Hole
( Expression
, Reserved_identifiers
[ "α"
; "β"
; "γ"
; "δ"
; "ε"
; "ζ"
; "η"
; "θ"
; "ι"
; "κ"
; "λ"
; "μ"
; "ξ"
; "π"
; "ρ"
; "ς"
; "σ"
; "τ"
; "υ"
; "φ"
; "χ"
; "ψ"
; "ω"
] )
; Hole (Everything, Reserved_identifiers [ "Γ"; "Δ"; "Θ"; "Λ"; "Ξ"; "Π"; "Σ"; "Φ"; "Ψ"; "Ω" ])
; Regex (":[", '~', "]")
]
let default_identifier =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"
let default_aliases =
[ { pattern = "..."
; match_template = ":[_]"
; rule = None
}
]
let default_identifier = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"
let default_aliases = [ { pattern = "..."; match_template = ":[_]"; rule = None } ]
let default_metasyntax =
{ syntax = default_syntax
; identifier = default_identifier
; aliases = default_aliases
}
{ syntax = default_syntax; identifier = default_identifier; aliases = default_aliases }
let create { syntax; identifier; aliases } =
let module Metasyntax = struct
@ -42,5 +58,4 @@ let default = create default_metasyntax
module Default = (val default)
(* In utop: Format.printf "%s@." @@ Matchers.Metasyntax.(json Matchers.Metasyntax.default_metasyntax);; *)
let json metasyntax =
Yojson.Safe.pretty_to_string @@ to_yojson metasyntax
let json metasyntax = Yojson.Safe.pretty_to_string @@ to_yojson metasyntax

3
lib/kernel/matchers/metasyntax.mli
View File

@ -1,11 +1,8 @@
open Types
include module type of Metasyntax
val default_metasyntax : Metasyntax.t
val create : Metasyntax.t -> (module Metasyntax.S)
val default : (module Metasyntax.S)
module Default : Metasyntax.S

973
lib/kernel/matchers/omega.ml
View File

File diff suppressed because it is too large Load Diff

3
lib/kernel/matchers/omega.mli
View File

@ -1,3 +1,2 @@
open Types
module Make : Language.S -> Metasyntax.S -> External.S -> Matcher.S
module Make (_ : Language.S) (_ : Metasyntax.S) (_ : External.S) : Matcher.S

67
lib/kernel/matchers/omega_parser_helper.ml
View File

@ -1,38 +1,24 @@
open Core_kernel
open Vangstrom
let skip p = p *> return ()
let up_to p =
many1 (not_followed_by p *> any_char)
let between left right p =
left *> p <* right
let zero : 'a Vangstrom.t =
fail ""
let up_to p = many1 (not_followed_by p *> any_char)
let between left right p = left *> p <* right
let zero : 'a Vangstrom.t = fail ""
let cons x xs = x :: xs
let many_till p t =
fix (fun m -> (t *> return []) <|> (lift2 cons p m))
let many1_till p t =
lift2 cons p (many_till p t)
let ignore p =
p *> return ()
let many_till p t = fix (fun m -> t *> return [] <|> lift2 cons p m)
let many1_till p t = lift2 cons p (many_till p t)
let ignore p = p *> return ()
let many_till_stop p t =
let stop = ref false in
let set_stop v = stop := v in
let get_stop () = !stop in
fix (fun m ->
choice
[ (t >>= fun _ -> (return (set_stop true)) >>= fun _ -> fail "stop")
; (return () >>= fun _ -> if get_stop () then return [] else lift2 cons p m)
])
choice
[ (t >>= fun _ -> return (set_stop true) >>= fun _ -> fail "stop")
; (return () >>= fun _ -> if get_stop () then return [] else lift2 cons p m)
])
let many1_till_stop p t =
let stop = ref false in
@ -41,42 +27,27 @@ let many1_till_stop p t =
(* one needs to fail if p isn't successful so that it doesn't consume and advance one char *)
let one =
choice
[ (t >>= fun _ -> (return (set_stop true)) >>= fun _ -> fail "stop")
[ (t >>= fun _ -> return (set_stop true) >>= fun _ -> fail "stop")
; (return () >>= fun _ -> if get_stop () then fail "stop" else p)
]
in
lift2 cons one (many_till_stop p t)
let alphanum =
satisfy (function
| 'a' .. 'z'
| 'A' .. 'Z'
| '0' .. '9' -> true
| _ -> false)
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
| _ -> false)
let is_whitespace = function
| ' ' | '\t' | '\r' | '\n' -> true
| _ -> false
let blank =
choice
[ char ' '
; char '\t'
]
let space1 =
satisfy is_whitespace
let spaces =
take_while is_whitespace >>= fun s ->
return s
let blank = choice [ char ' '; char '\t' ]
let space1 = satisfy is_whitespace
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)
satisfy is_whitespace
>>= fun c -> take_while is_whitespace >>= fun s -> return (Format.sprintf "%c%s" c s)
let identifier_parser () =
many (alphanum <|> char '_')
>>| String.of_char_list
let identifier_parser () = many (alphanum <|> char '_') >>| String.of_char_list

63
lib/kernel/matchers/preprocess.ml
View File

@ -12,7 +12,7 @@ let append_rule (module Parser : Types.Rule.S) rule parent_rule =
>>| Parser.create
>>| function
| Ok rule -> rule
| Error e -> failwith @@ "Could not parse rule for alias entry:"^(Error.to_string_hum e)
| Error e -> failwith @@ "Could not parse rule for alias entry:" ^ Error.to_string_hum e
in
match parent_rule, rule with
| Some parent_rule, Some rule -> Some (parent_rule @ rule)
@ -29,37 +29,40 @@ let map_template (module Parser : Types.Rule.S) template pattern match_template
let rec map_atom (rule : Types.Ast.expression list) f =
let open Types.Ast in
List.map rule ~f:(function
| Equal (l, r) -> Equal (f l, f r)
| Not_equal (l, r) -> Not_equal (f l, f r)
| Match (e, l) ->
Match (f e, List.map l ~f:(fun (a, l) -> (f a, map_atom l f)))
| Rewrite (e, (l, r)) ->
Rewrite (f e, (f l, f r))
| t -> t)
| Equal (l, r) -> Equal (f l, f r)
| Not_equal (l, r) -> Not_equal (f l, f r)
| Match (e, l) -> Match (f e, List.map l ~f:(fun (a, l) -> f a, map_atom l f))
| Rewrite (e, (l, r)) -> Rewrite (f e, (f l, f r))
| t -> t)
let map_aliases
(module Metasyntax : Metasyntax.S)
(module External : External.S)
template
parent_rule =
(module Metasyntax : Metasyntax.S)
(module External : External.S)
template
parent_rule
=
let module Parser = Rule.Make (Metasyntax) (External) in
List.fold Metasyntax.aliases
List.fold
Metasyntax.aliases
~init:(template, parent_rule)
~f:(fun (template, parent_rule) Types.Metasyntax.{ pattern; match_template; rule } ->
let template', parent_rule' =
match String.substr_index template ~pattern with
| None -> template, parent_rule
| Some _ -> map_template (module Parser) template pattern match_template rule parent_rule
in
let parent_rule' =
let open Option in
parent_rule' >>| fun parent_rule' ->
map_atom parent_rule' (function
| Template t ->
Template (Parser.Template.parse
(String.substr_replace_all
(Parser.Template.to_string t) ~pattern ~with_:match_template))
| String s ->
String (String.substr_replace_all s ~pattern ~with_:match_template))
in
template', parent_rule')
let template', parent_rule' =
match String.substr_index template ~pattern with
| None -> template, parent_rule
| Some _ -> map_template (module Parser) template pattern match_template rule parent_rule
in
let parent_rule' =
let open Option in
parent_rule'
>>| fun parent_rule' ->
map_atom parent_rule' (function
| Template t ->
Template
(Parser.Template.parse
(String.substr_replace_all
(Parser.Template.to_string t)
~pattern
~with_:match_template))
| String s -> String (String.substr_replace_all s ~pattern ~with_:match_template))
in
template', parent_rule')

88
lib/kernel/matchers/regexp.ml
View File

@ -9,13 +9,10 @@ module type Regexp_engine_intf = sig
type t
type substrings
val make: string -> t
val get_substring: substrings -> int -> string option
val get_all_substrings: substrings -> string array
val exec: rex:t -> pos:int -> Bytes.t -> substrings option
val make : string -> t
val get_substring : substrings -> int -> string option
val get_all_substrings : substrings -> string array
val exec : rex:t -> pos:int -> Bytes.t -> substrings option
end
type t =
@ -25,13 +22,10 @@ type t =
(* I think I should just implement the analog of string_ for regex with some bounded buffer size. *)
module Make (Regexp: Regexp_engine_intf) = struct
module Make (Regexp : Regexp_engine_intf) = struct
(* https://sourcegraph.com/github.com/comby-tools/mparser/-/blob/src/mParser_Char_Stream.ml#L231:8 *)
let match_regexp s pos rex =
Regexp.exec ~rex ~pos:(pos - s.buffer_pos) s.buffer
let make_regexp pat =
Regexp.make pat
let match_regexp s pos rex = Regexp.exec ~rex ~pos:(pos - s.buffer_pos) s.buffer
let make_regexp pat = Regexp.make pat
(* TODO: tests and blit thing below *)
@ -41,24 +35,25 @@ module Make (Regexp: Regexp_engine_intf) = struct
let regexp rex =
(* Why do Unsafe if I can just do peek_string? => So I don't allocate on copy of buffer. *)
(* But it looks like we can't avoid allocation in converting bigstringaf to bytes *)
Unsafe.peek 1 (fun buffer ~off ~len:_ -> Bigstringaf.length buffer - off) >>= fun n ->
Unsafe.peek 1 (fun buffer ~off ~len:_ -> Bigstringaf.length buffer - off)
>>= fun n ->
Unsafe.peek n (fun buffer ~off ~len ->
(* This still does a copy :( *)
let bytes = Bytes.create len in
Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:0 ~len;
if debug then Format.printf "Matching regex against string: %S@." @@ Bytes.to_string bytes;
match Regexp.exec ~rex ~pos:0 bytes with
| None ->
if debug then Format.printf "None (1)@.";
None
| Some substrings ->
match Regexp.get_substring substrings 0 with
| None ->
if debug then Format.printf "None (2)@.";
None
| Some result ->
if debug then Format.printf "Matchy Matchy (3)@.";
Some (result, String.length result))
(* This still does a copy :( *)
let bytes = Bytes.create len in
Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:0 ~len;
if debug then Format.printf "Matching regex against string: %S@." @@ Bytes.to_string bytes;
match Regexp.exec ~rex ~pos:0 bytes with
| None ->
if debug then Format.printf "None (1)@.";
None
| Some substrings ->
(match Regexp.get_substring substrings 0 with
| None ->
if debug then Format.printf "None (2)@.";
None
| Some result ->
if debug then Format.printf "Matchy Matchy (3)@.";
Some (result, String.length result)))
>>= function
| Some (result, n) ->
(* if empty string matches, this hole like for optionals (x?), advance 1. *)
@ -68,10 +63,8 @@ module Make (Regexp: Regexp_engine_intf) = struct
(* let n = if n > 0 then n else 1 in
advance n >>= fun () -> *)
if debug then Format.printf "Result indeed: %S len %d@." result n;
advance n >>= fun () ->
return result
| None ->
fail "No match"
advance n >>= fun () -> return result
| None -> fail "No match"
end
module PCRE = struct
@ -79,20 +72,15 @@ module PCRE = struct
type t = Pcre.regexp
type substrings = Pcre.substrings
let compile_flags =
Pcre.cflags [ `ANCHORED ]
let make pattern =
Pcre.regexp ~iflags:compile_flags pattern
let compile_flags = Pcre.cflags [ `ANCHORED ]
let make pattern = Pcre.regexp ~iflags:compile_flags pattern
let get_substring s idx =
match Pcre.get_substring s idx with
| result -> Some result
| exception Not_found
| exception Invalid_argument _ -> None
| (exception Not_found) | (exception Invalid_argument _) -> None
let get_all_substrings s =
Pcre.get_substrings s
let get_all_substrings s = Pcre.get_substrings s
let exec ~rex ~pos b =
match Pcre.exec ~pos ~rex (Bytes.unsafe_to_string b) with
@ -100,7 +88,7 @@ module PCRE = struct
| exception Not_found -> None
end
include Make(Engine)
include Make (Engine)
end
module RE = struct
@ -108,19 +96,15 @@ module RE = struct
type t = Re.re
type substrings = Re.substrings
let compile_flags =
[ `Anchored ]
let make pattern =
Re.Perl.(compile (re ~opts:compile_flags pattern))
let compile_flags = [ `Anchored ]
let make pattern = Re.Perl.(compile (re ~opts:compile_flags pattern))
let get_substring s idx =
match Re.get s idx with
| result -> Some result
| exception Not_found -> None
let get_all_substrings s =
Re.get_all s
let get_all_substrings s = Re.get_all s
let exec ~rex ~pos b =
match Re.exec ~pos rex (Bytes.unsafe_to_string b) with
@ -128,5 +112,5 @@ module RE = struct
| exception Not_found -> None
end
include Make(Engine)
include Make (Engine)
end

17
lib/kernel/matchers/regexp.mli
View File

@ -2,13 +2,10 @@ module type Regexp_engine_intf = sig
type t
type substrings
val make: string -> t
val get_substring: substrings -> int -> string option
val get_all_substrings: substrings -> string array
val exec: rex:t -> pos:int -> Bytes.t -> substrings option
val make : string -> t
val get_substring : substrings -> int -> string option
val get_all_substrings : substrings -> string array
val exec : rex:t -> pos:int -> Bytes.t -> substrings option
end
(** Represents character stream right now.
@ -17,12 +14,10 @@ end
*)
type t
module Make (Regexp : Regexp_engine_intf): sig
module Make (Regexp : Regexp_engine_intf) : sig
(* do not use this, use regexp. *)
val match_regexp: t -> int -> Regexp.t -> Regexp.substrings option
val match_regexp : t -> int -> Regexp.t -> Regexp.substrings option
val make_regexp : string -> Regexp.t
val regexp : Regexp.t -> string Vangstrom.t
end

173
lib/kernel/matchers/rewrite.ml
View File

@ -1,6 +1,5 @@
open Vangstrom
open Core_kernel
open Match
open Replacement
@ -18,41 +17,44 @@ let counter =
let replacement_sentinel metasyntax =
let open Types.Metasyntax in
List.find_map metasyntax.syntax ~f:(function
| Hole (Everything, Delimited (left, right)) ->
let left = Option.value left ~default:"" in
let right = Option.value right ~default:"" in
Some (left, right)
| Hole (Alphanum, Delimited (left, right)) ->
let left = Option.value left ~default:"" in
let right = Option.value right ~default:"" in
Some (left, right)
| Regex (left, _, right) ->
Some (left, right)
| _ -> None)
| Hole (Everything, Delimited (left, right)) ->
let left = Option.value left ~default:"" in
let right = Option.value right ~default:"" in
Some (left, right)
| Hole (Alphanum, Delimited (left, right)) ->
let left = Option.value left ~default:"" in
let right = Option.value right ~default:"" in
Some (left, right)
| Regex (left, _, right) -> Some (left, right)
| _ -> None)
|> function
| Some v -> v
| None -> failwith "A custom metasyntax must define syntax for an Everything or Alphanum hole or Regex to customize rewriting"
| None ->
failwith
"A custom metasyntax must define syntax for an Everything or Alphanum hole or Regex to \
customize rewriting"
(** Parse the first :[id(label)] label encountered in the template. *)
let parse_first_label ?(metasyntax = Metasyntax.default_metasyntax) template =
let label = take_while (function | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false) in
let label =
take_while (function
| '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true
| _ -> false)
in
let left, right = replacement_sentinel metasyntax in
let parser =
many @@
choice
[ lift3 (fun _ label _ -> Some label) (string (left^"id(")) label (string (")"^right))
; any_char >>| fun _ -> None
]
many
@@ choice
[ lift3 (fun _ label _ -> Some label) (string (left ^ "id(")) label (string (")" ^ right))
; (any_char >>| fun _ -> None)
]
in
parse_string ~consume:All parser template
|> function
| Ok label -> List.find_map label ~f:ident
| Error _ -> None
let substitute_fresh
?(metasyntax = Metasyntax.default_metasyntax)
?(fresh = counter)
template =
let substitute_fresh ?(metasyntax = Metasyntax.default_metasyntax) ?(fresh = counter) template =
let label_table = String.Table.create () in
let template_ref = ref template in
let current_label_ref = ref (parse_first_label ~metasyntax !template_ref) in
@ -69,87 +71,108 @@ let substitute_fresh
let left, right = replacement_sentinel metasyntax in
let pattern = left ^ "id(" ^ label ^ ")" ^ right in
template_ref := String.substr_replace_first !template_ref ~pattern ~with_:id;
current_label_ref := parse_first_label ~metasyntax !template_ref;
current_label_ref := parse_first_label ~metasyntax !template_ref
done;
!template_ref
let substitute_in_rewrite_template
?fresh
?(external_handler = External.default_external)
?(metasyntax = Metasyntax.default_metasyntax)
?filepath
template
environment =
?fresh
?(external_handler = External.default_external)
?(metasyntax = Metasyntax.default_metasyntax)
?filepath
template
environment
=
let (module M) = Metasyntax.create metasyntax in
let module External = struct let handler = external_handler end in
let module Template_parser = Template.Make(M)(External) in (* FIXME factor out Template_parser *)
let module External = struct
let handler = external_handler
end
in
let module Template_parser = Template.Make (M) (External) in
(* FIXME factor out Template_parser *)
let template = substitute_fresh ~metasyntax ?fresh template in
let terms = Template_parser.parse template in
let replacement_content, environment = Template_parser.substitute ?filepath terms environment in
{ replacement_content
; environment
; range =
{ match_start = { Location.default with offset = 0 }
; match_end = Location.default
}
; range = { match_start = { Location.default with offset = 0 }; match_end = Location.default }
}
let substitute
?(metasyntax = Metasyntax.default_metasyntax)
?external_handler
?fresh
?filepath
template
env =
?(metasyntax = Metasyntax.default_metasyntax)
?external_handler
?fresh
?filepath
template
env
=
let { replacement_content; _ } =
substitute_in_rewrite_template ~metasyntax ?external_handler ?fresh ?filepath template env
in replacement_content
in
replacement_content
let substitute_matches (matches: Match.t list) source replacements =
if debug then Format.printf "Matches: %d | Replacements: %d@." (List.length matches) (List.length replacements);
let substitute_matches (matches : Match.t list) source replacements =
if debug then
Format.printf
"Matches: %d | Replacements: %d@."
(List.length matches)
(List.length replacements);
let rewritten_source, in_place_substitutions, _ =
(* shift adjusts the difference of the matched part and the replacement part to the matched offsets *)
List.fold2_exn matches replacements ~init:(source, [], 0) ~f:(fun (rolling_result, replacements, shift) { range; _ } ({ replacement_content; _ } as r) ->
let start_index = range.match_start.offset + shift in
let end_index = range.match_end.offset + shift in
let before = if start_index = 0 then "" else String.slice rolling_result 0 start_index in
let after = String.slice rolling_result end_index (String.length rolling_result) in
let match_length = end_index - start_index in
let difference = String.length replacement_content - match_length in
let range = Range.{ match_start = Location.{ default with offset = start_index }; match_end = Location.{ default with offset = end_index + difference } } in
let replacements = { r with range }::replacements in
String.concat [before; replacement_content; after], replacements, shift + difference)
List.fold2_exn
matches
replacements
~init:(source, [], 0)
~f:(fun (rolling_result, replacements, shift) { range; _ } ({ replacement_content; _ } as r)
->
let start_index = range.match_start.offset + shift in
let end_index = range.match_end.offset + shift in
let before = if start_index = 0 then "" else String.slice rolling_result 0 start_index in
let after = String.slice rolling_result end_index (String.length rolling_result) in
let match_length = end_index - start_index in
let difference = String.length replacement_content - match_length in
let range =
Range.
{ match_start = Location.{ default with offset = start_index }
; match_end = Location.{ default with offset = end_index + difference }
}
in
let replacements = { r with range } :: replacements in
String.concat [ before; replacement_content; after ], replacements, shift + difference)
in
{ rewritten_source
; in_place_substitutions
}
{ rewritten_source; in_place_substitutions }
(* FIXME: all the functors help nothing if we end up calling this without parameterizing by metasyntax, etc. *)
let all ?source ?metasyntax ?external_handler ?fresh ?filepath ~rewrite_template rev_matches : result option =
Option.some_if (not (List.is_empty rev_matches)) @@
let all ?source ?metasyntax ?external_handler ?fresh ?filepath ~rewrite_template rev_matches
: result option
=
Option.some_if (not (List.is_empty rev_matches))
@@
match source with
(* in-place substitution *)
| Some source ->
rev_matches
|> List.map ~f:(fun Match.{ environment; _ } ->
substitute_in_rewrite_template
?filepath
?metasyntax
?external_handler
?fresh rewrite_template
environment)
substitute_in_rewrite_template
?filepath
?metasyntax
?external_handler
?fresh
rewrite_template
environment)
|> substitute_matches rev_matches source
(* no in place substitution, emit result separated by newlines *)
| None ->
let buf = Buffer.create 20 in
List.iter rev_matches ~f:(fun m ->
substitute_in_rewrite_template
?filepath
?metasyntax
?external_handler
?fresh
rewrite_template m.environment
|> fun { replacement_content; _ } ->
Buffer.add_string buf replacement_content;
Buffer.add_char buf '\n');
substitute_in_rewrite_template
?filepath
?metasyntax
?external_handler
?fresh
rewrite_template
m.environment
|> fun { replacement_content; _ } ->
Buffer.add_string buf replacement_content;
Buffer.add_char buf '\n');
{ rewritten_source = Buffer.contents buf; in_place_substitutions = [] }

159
lib/kernel/matchers/rule.ml
View File

@ -1,30 +1,21 @@
open Core_kernel
open Vangstrom
open Types.Ast
module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = struct
module Template = Template.Make (Metasyntax) (External)
let is_whitespace = function
| ' ' | '\t' | '\r' | '\n' -> true
| _ -> false
let spaces =
take_while is_whitespace
let spaces1 =
satisfy is_whitespace *>
take_while is_whitespace
let spaces = take_while is_whitespace
let spaces1 = satisfy is_whitespace *> take_while is_whitespace
let alphanum =
satisfy (function
| 'a' .. 'z'
| 'A' .. 'Z'
| '0' .. '9' -> true
| _ -> false)
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
| _ -> false)
let to_atom s =
match Template.parse s with
@ -34,29 +25,22 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
(** 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)
<|> (lift String.of_char any_char)
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)
<|> lift String.of_char any_char
(** With escape sequences *)
let quote s =
lift2 (fun _ v -> String.concat v)
(string s)
(many_till char_token_s (string s))
let quote s = lift2 (fun _ v -> String.concat v) (string s) (many_till char_token_s (string s))
let raw s =
lift2 (fun _ v -> String.of_char_list v)
(string s)
(many_till any_char (string s))
let raw s = lift2 (fun _ v -> String.of_char_list v) (string s) (many_till any_char (string s))
let quoted_parser =
choice ~failure_msg:"could not parse quoted value"
[ quote {|"|}; quote {|'|}; raw {|`|} ]
choice ~failure_msg:"could not parse quoted value" [ quote {|"|}; quote {|'|}; raw {|`|} ]
let map_special s =
if String.is_prefix s ~prefix:"~" then
@ -66,57 +50,48 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
else
to_atom s
let up_to p =
many1 (not_followed_by p *> any_char)
let up_to p = many1 (not_followed_by p *> any_char)
let atom_up_to_spaces () =
choice
[ (lift to_atom quoted_parser)
[ lift to_atom quoted_parser
; lift (fun v -> to_atom (String.of_char_list v)) (up_to spaces1)
]
let atom_up_to_terminal () =
choice
[ (lift to_atom quoted_parser)
; (lift
(fun v -> to_atom (String.of_char_list v))
(up_to
(choice
[ spaces1 *> return ()
; char ',' *> return ()
; char '}' *> return ()
])))
[ lift to_atom quoted_parser
; lift
(fun v -> to_atom (String.of_char_list v))
(up_to (choice [ spaces1 *> return (); char ',' *> return (); char '}' *> return () ]))
]
let antecedent_parser () =
choice ~failure_msg:"could not parse LHS of ->"
[ (lift to_atom quoted_parser)
; (lift (fun v -> map_special (String.of_char_list v)) (up_to (spaces *> string Syntax.arrow)))
choice
~failure_msg:"could not parse LHS of ->"
[ lift to_atom quoted_parser
; lift (fun v -> map_special (String.of_char_list v)) (up_to (spaces *> string Syntax.arrow))
]
let value_to_open_brace () =
choice
[ (lift to_atom quoted_parser)
; (lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char '{')))
[ lift to_atom quoted_parser
; lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char '{'))
]
let value_to_comma () =
choice
[ (lift to_atom quoted_parser)
; (lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char ',')))
[ lift to_atom quoted_parser
; lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char ','))
]
let rewrite_consequent_parser () =
choice
[ (lift to_atom quoted_parser)
; (lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char '}')))
[ lift to_atom quoted_parser
; lift (fun v -> to_atom (String.of_char_list v)) (up_to (spaces *> char '}'))
]
let operator_parser =
choice
[ string Syntax.equal
; string Syntax.not_equal
]
let operator_parser = choice [ string Syntax.equal; string Syntax.not_equal ]
let make_equality_expression left operator right =
if String.equal operator Syntax.equal then
@ -128,12 +103,11 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
let option_parser =
choice
[ lift (fun _ -> Option "nested") (spaces *> (string Syntax.option_nested) <* spaces)
; lift (fun _ -> Option "strict") (spaces *> (string Syntax.option_strict) <* spaces)
[ 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)
let false' = lift (fun _ -> False) (spaces *> string Syntax.false' <* spaces)
(** <atom> [==, !=] <atom> *)
@ -152,8 +126,10 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
let rewrite_pattern_parser =
lift3
make_rewrite_expression
(string Syntax.start_rewrite_pattern
*> spaces*> value_to_open_brace () <* spaces <* char '{' <* spaces)
(string Syntax.start_rewrite_pattern *> spaces *> value_to_open_brace ()
<* spaces
<* char '{'
<* spaces)
(antecedent_parser () <* spaces <* string Syntax.arrow <* spaces)
(rewrite_consequent_parser () <* spaces <* char '}')
@ -165,19 +141,18 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
(** [|] <match_arrow> *)
let first_case_parser expression_parser =
spaces *> option () (Omega_parser_helper.ignore @@ string Syntax.pipe_operator *> spaces) *>
match_arrow_parser expression_parser
spaces
*> option () (Omega_parser_helper.ignore @@ (string Syntax.pipe_operator *> spaces))
*> match_arrow_parser expression_parser
(** | <match_arrow> *)
let case_parser expression_parser =
spaces *> string Syntax.pipe_operator *> spaces *>
match_arrow_parser expression_parser
spaces *> string Syntax.pipe_operator *> spaces *> match_arrow_parser expression_parser
(** [|] <match_arrow> | <match_arrow> *)
let case_block expression_parser =
first_case_parser expression_parser >>= fun case ->
many (case_parser expression_parser) >>= fun cases ->
return (case :: cases)
first_case_parser expression_parser
>>= fun case -> many (case_parser expression_parser) >>= fun cases -> return (case :: cases)
(** match <atom> { <case_parser> } *)
let match_pattern_parser expression_parser =
@ -189,19 +164,22 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
let expression_parser =
fix (fun expression_parser ->
choice ~failure_msg:"could not parse expression"
[ match_pattern_parser expression_parser
; rewrite_pattern_parser
; compare_parser
; true'
; false'
; option_parser
])
choice
~failure_msg:"could not parse expression"
[ match_pattern_parser expression_parser
; rewrite_pattern_parser
; compare_parser
; true'
; false'
; option_parser
])
(** where <expression> [,] *)
let parse =
spaces *> string Syntax.rule_prefix *>
spaces1 *> sep_by1 (spaces *> char ',' <* spaces) expression_parser
spaces
*> string Syntax.rule_prefix
*> spaces1
*> sep_by1 (spaces *> char ',' <* spaces) expression_parser
<* optional_trailing ','
<* spaces
@ -211,16 +189,19 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
| Error error -> Or_error.error_string error
end
type t = Types.Rule.t
[@@deriving sexp]
type t = Types.Rule.t [@@deriving sexp]
let create
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
rule =
?(metasyntax = Metasyntax.default_metasyntax)
?(external_handler = External.default_external)
rule
=
let (module Metasyntax) = Metasyntax.create metasyntax in
let module External = struct let handler = external_handler end in
let (module Rule : Types.Rule.S) = (module (Make (Metasyntax) (External))) in
let module External = struct
let handler = external_handler
end
in
let (module Rule : Types.Rule.S) = (module Make (Metasyntax) (External)) in
Rule.create rule
type options =
@ -230,9 +211,9 @@ type options =
let options rule =
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)
| 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

81
lib/kernel/matchers/script.ml
View File

@ -1,14 +1,11 @@
open Core_kernel
open Vangstrom
open Types.Ast
module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = struct
module Parser = Rule.Make (Metasyntax) (External)
type spec = Specification.t
[@@deriving sexp]
type spec = Specification.t [@@deriving sexp]
type op =
| And
@ -21,67 +18,85 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
| Spec of spec
[@@deriving sexp]
type t = exp list
[@@deriving sexp]
type t = exp list [@@deriving sexp]
let ignore p =
p *> return ()
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 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
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 template_parser until =
choice
[ (lift Parser.to_atom Parser.quoted_parser)
; (lift (fun v -> Parser.to_atom (String.of_char_list v)) (Omega_parser_helper.many1_till any_char until))
[ lift Parser.to_atom Parser.quoted_parser
; lift
(fun v -> Parser.to_atom (String.of_char_list v))
(Omega_parser_helper.many1_till any_char until)
]
let spec =
let match_rewrite_parser =
both
(spaces *> template_parser (spaces *> string "->"))
(option None (spaces *> string Syntax.arrow *> spaces *> template_parser (spaces1 *> string "where" *> spaces1) >>| fun v -> Some v))
(option
None
(spaces
*> string Syntax.arrow
*> spaces
*> template_parser (spaces1 *> string "where" *> spaces1)
>>| fun v -> Some v))
in
match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) ->
(option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule ->
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))
| 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 }))]
return [ Spec Specification.{ match_template; rule; rewrite_template } ]
let unop syntax exp_parser =
choice (List.map ~f:string syntax) *> spaces *> exp_parser >>| fun exp -> [Exp (Not, exp)]
choice (List.map ~f:string syntax) *> spaces *> exp_parser >>| fun exp -> [ Exp (Not, exp) ]
let binop syntax op =
spaces *> choice (List.map ~f:string syntax) *> spaces *> return (fun left right -> [Exp (op, left@right)])
spaces
*> choice (List.map ~f: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 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 (sexp_of_t exp)
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 (sexp_of_t exp)
end

87
lib/kernel/matchers/specification.ml
View File

@ -8,12 +8,8 @@ type t =
}
[@@deriving sexp]
let create ?rewrite_template ?rule ~match_template () =
{ match_template; rule; rewrite_template }
let identifier_parser () =
many (Omega_parser_helper.alphanum <|> char '_')
>>| String.of_char_list
let create ?rewrite_template ?rule ~match_template () = { match_template; rule; rewrite_template }
let identifier_parser () = many (Omega_parser_helper.alphanum <|> char '_') >>| String.of_char_list
let single_hole_parser () =
string ":[[" *> identifier_parser () <* string "]]" >>| fun _ -> Some {|(\w+)|}
@ -31,23 +27,20 @@ let line_hole_parser () =
string ":[" *> identifier_parser () <* string "\\n]" >>| fun _ -> Some {|(\n|.)*?|}
let blank_hole_parser () =
string ":["
*> many1 Omega_parser_helper.blank
*> identifier_parser ()
string ":[" *> many1 Omega_parser_helper.blank *> identifier_parser ()
<* string "]"
>>| fun _ -> Some {|(\ |\t|\s|\r|\n)+|}
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))
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
@ -55,28 +48,24 @@ let any_char_except ~reserved =
let regex_body () =
fix (fun expr ->
(choice
[ ((char '[' *> (many1 expr) <* char ']')
>>| fun char_class -> Format.sprintf "[%s]" @@ String.concat char_class)
; (char '\\' *> any_char >>| fun c -> (Format.sprintf "\\%c" c))
; ((any_char_except ~reserved:["]"])) >>| Char.to_string
]
))
choice
[ (char '[' *> many1 expr
<* char ']'
>>| fun char_class -> Format.sprintf "[%s]" @@ String.concat char_class)
; (char '\\' *> any_char >>| fun c -> Format.sprintf "\\%c" c)
; any_char_except ~reserved:[ "]" ] >>| Char.to_string
])
let regex_hole_parser () =
string ":["
*> identifier_parser ()
*> char '~'
*> (many1 @@ regex_body ()) >>= fun regex ->
string "]" >>= fun _ -> return (Some (String.concat regex))
string ":[" *> identifier_parser () *> char '~' *> (many1 @@ regex_body ())
>>= fun regex -> string "]" >>= fun _ -> return (Some (String.concat regex))
type extracted =
| Regex of string
| Contiguous_whitespace of string
| Non_space of string
let up_to p =
many1 (not_followed_by p *> any_char)
let up_to p = many1 (not_followed_by p *> any_char)
let extract : extracted list Vangstrom.t =
let hole =
@ -90,13 +79,14 @@ let extract : extracted list Vangstrom.t =
; regex_hole_parser ()
]
in
many @@ choice
[ (hole >>| fun v -> Option.map v ~f:(fun v -> Regex v))
; (Omega_parser_helper.spaces1 >>| fun s -> Some (Contiguous_whitespace s))
; (lift
(fun v -> Some (Non_space (String.of_char_list v)))
(up_to (choice [hole *> return (); Omega_parser_helper.spaces1 *> return ()])))
]
many
@@ choice
[ (hole >>| fun v -> Option.map v ~f:(fun v -> Regex v))
; (Omega_parser_helper.spaces1 >>| fun s -> Some (Contiguous_whitespace s))
; lift
(fun v -> Some (Non_space (String.of_char_list v)))
(up_to (choice [ hole *> return (); Omega_parser_helper.spaces1 *> return () ]))
]
>>| fun result -> List.filter_opt result
let escape s =
@ -104,13 +94,12 @@ let escape s =
match chars with
| [] -> []
| x :: xs ->
match x with
| '\\' | '.' | '+' | '*' | '?' | '(' | ')' | '|' | '[' | ']' | '{' | '}' | '^' | '$' as c ->
'\\' :: c :: (aux xs)
| c -> c :: (aux xs)
(match x with
| ('\\' | '.' | '+' | '*' | '?' | '(' | ')' | '|' | '[' | ']' | '{' | '}' | '^' | '$') as c
-> '\\' :: c :: aux xs
| c -> c :: aux xs)
in
aux (String.to_list s)
|> String.of_char_list
aux (String.to_list s) |> String.of_char_list
let to_regex { match_template; _ } =
let extracted = parse_string ~consume:All extract match_template |> Result.ok_or_failwith in
@ -118,8 +107,8 @@ let to_regex { match_template; _ } =
let b = Buffer.create 10 in
Buffer.add_string b "(";
List.iter extracted ~f:(function
| Regex s -> Buffer.add_string b s
| Non_space s -> Buffer.add_string b (escape s)
| Contiguous_whitespace _ -> Buffer.add_string b {|\s+|});
| Regex s -> Buffer.add_string b s
| Non_space s -> Buffer.add_string b (escape s)
| Contiguous_whitespace _ -> Buffer.add_string b {|\s+|});
Buffer.add_string b ")";
Buffer.contents b

1
lib/kernel/matchers/specification.mli
View File

@ -6,5 +6,4 @@ type t =
[@@deriving sexp]
val create : ?rewrite_template:string -> ?rule:Rule.t -> match_template:string -> unit -> t
val to_regex : t -> string

1
lib/kernel/matchers/syntax.ml
View File

@ -9,5 +9,4 @@ let option_nested = "nested"
let option_strict = "strict"
let pipe_operator = "|"
let arrow = "->"
let separator = "---"

367
lib/kernel/matchers/template.ml
View File

@ -1,6 +1,5 @@
open Vangstrom
open Core_kernel
open Match
open Types.Template
@ -9,38 +8,31 @@ let debug =
| exception Not_found -> false
| _ -> true
module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Types.Template.S = struct
let up_to p =
many1 (not_followed_by p *> any_char)
module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Types.Template.S =
struct
let up_to p = many1 (not_followed_by p *> any_char)
let optional d = Option.value d ~default:""
let character () =
choice @@ List.map ~f:char (String.to_list Metasyntax.identifier)
let identifier () =
many1 @@ character () >>| String.of_char_list
let character () = choice @@ List.map ~f:char (String.to_list Metasyntax.identifier)
let identifier () = many1 @@ character () >>| String.of_char_list
let regex_expression suffix =
lift String.concat
(many1 @@
fix (fun expr ->
lift
String.concat
(many1
@@ fix (fun expr ->
choice
[ lift (fun x -> Format.sprintf "[%s]" @@ String.concat x) (char '[' *> many1 expr <* char ']')
[ lift
(fun x -> Format.sprintf "[%s]" @@ String.concat x)
(char '[' *> many1 expr <* char ']')
; lift (fun c -> Format.sprintf {|\%c|} c) (char '\\' *> any_char)
; lift String.of_char_list (up_to (string suffix))
])
)
]))
let regex_body separator suffix =
both
(option "" (identifier ()))
(char separator *> regex_expression suffix)
both (option "" (identifier ())) (char separator *> regex_expression suffix)
(** Parsers for Matching. Different from rewrite templates which can have :[x].attribute *)
module Matching = struct
(** Folds left to respect order of definitions in custom metasyntax for
matching, where we attempt to parse in order. Note this is significant if a
syntax like $X~regex should be tried before shortcircuiting on $X, in which
@ -49,47 +41,40 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
let hole_parsers =
(* hole parsers for match templates only *)
List.fold ~init:[] Metasyntax.syntax ~f:(fun acc v ->
let result = match v with
| Hole (sort, Delimited (left, right)) ->
sort,
lift3
let result =
match v with
| Hole (sort, Delimited (left, right)) ->
( sort
, lift3
(fun _left v _right -> v)
(string (optional left))
(identifier ())
(string (optional right))
| Hole (sort, Reserved_identifiers l) ->
sort,
choice (List.map l ~f:string)
| Regex (left, separator, right) ->
Regex,
(* matcher wants <identifier><sep><expr> and splits it later. Fix
(string (optional right)) )
| Hole (sort, Reserved_identifiers l) -> sort, choice (List.map l ~f:string)
| Regex (left, separator, right) ->
( Regex
, (* matcher wants <identifier><sep><expr> and splits it later. Fix
this later to give v and pattern only *)
lift3
(fun _left (v, expr) _right -> Format.sprintf "%s%c%s" v separator expr)
(string left)
(regex_body separator right)
(string right)
in
result::acc)
(string right) )
in
result :: acc)
end
let attribute_to_kind = function
| "value" -> Value
| "length" -> Length
| "lines" -> Lines
| "offset"
| "offset.start" -> OffsetStart
| "offset" | "offset.start" -> OffsetStart
| "offset.end" -> OffsetEnd
| "line"
| "line.start" -> LineStart
| "line" | "line.start" -> LineStart
| "line.end" -> LineEnd
| "column"
| "column.start" -> ColumnStart
| "column" | "column.start" -> ColumnStart
| "column.end" -> ColumnEnd
| "file"
| "file.path" -> FilePath
| "file" | "file.path" -> FilePath
| "file.name" -> FileName
| "file.directory" -> FileDirectory
| "lowercase" -> Lowercase
@ -104,34 +89,35 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
| s -> failwith @@ Format.sprintf "invalid attribute %S" s
let attribute_access () =
char '.' *> choice
[ string "value"
; string "length"
; string "lines"
; string "offset.start"
; string "offset.end"
; string "offset"
; string "line.start"
; string "line.end"
; string "line"
; string "column.start"
; string "column.end"
; string "column"
; string "file.path"
; string "file.name"
; string "file.directory"
; string "file"
; string "lowercase"
; string "UPPERCASE"
; string "Capitalize"
; string "uncapitalize"
; string "UpperCamelCase"
; string "lowerCamelCase"
; string "UPPER_SNAKE_CASE"
; string "lower_snake_case"
; string "lsif.hover"
]
<* not_followed_by (Omega_parser_helper.alphanum)
char '.'
*> choice
[ string "value"
; string "length"
; string "lines"
; string "offset.start"
; string "offset.end"
; string "offset"
; string "line.start"
; string "line.end"
; string "line"
; string "column.start"
; string "column.end"
; string "column"
; string "file.path"
; string "file.name"
; string "file.directory"
; string "file"
; string "lowercase"
; string "UPPERCASE"
; string "Capitalize"
; string "uncapitalize"
; string "UpperCamelCase"
; string "lowerCamelCase"
; string "UPPER_SNAKE_CASE"
; string "lower_snake_case"
; string "lsif.hover"
]
<* not_followed_by Omega_parser_helper.alphanum
(** Folds left to respect order of definitions in custom metasyntax for
matching, where we attempt to parse in order. Note this is significant if a
@ -140,73 +126,74 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
first). *)
let rewrite_hole_parsers =
List.fold ~init:[] Metasyntax.syntax ~f:(fun acc v ->
let result =
match v with
| Hole (_, Delimited (left, right)) ->
lift4
(fun left v right kind ->
let dot_attribute = if String.(kind = "value") then "" else "."^kind in
Format.sprintf "%s%s%s%s" left v right dot_attribute, v, kind)
(string (optional left))
(identifier ())
(string (optional right))
(option "value" (attribute_access ()))
| Hole (_, Reserved_identifiers l) ->
lift2
(fun v kind ->
let dot_attribute = if String.(kind = "value") then "" else "."^kind in
Format.sprintf "%s%s" v dot_attribute, v, kind)
(choice (List.map l ~f:string))
(option "value" (attribute_access ()))
| Regex (left, separator, right) ->
lift4
(fun left (v, expr) right kind ->
let dot_attribute = if String.(kind = "value") then "" else "."^kind in
Format.sprintf "%s%s%c%s%s%s"
left v separator expr right dot_attribute, v, kind)
(string left)
(regex_body separator right)
(string right)
(option "value" (attribute_access ()))
in
result::acc)
let result =
match v with
| Hole (_, Delimited (left, right)) ->
lift4
(fun left v right kind ->
let dot_attribute = if String.(kind = "value") then "" else "." ^ kind in
Format.sprintf "%s%s%s%s" left v right dot_attribute, v, kind)
(string (optional left))
(identifier ())
(string (optional right))
(option "value" (attribute_access ()))
| Hole (_, Reserved_identifiers l) ->
lift2
(fun v kind ->
let dot_attribute = if String.(kind = "value") then "" else "." ^ kind in
Format.sprintf "%s%s" v dot_attribute, v, kind)
(choice (List.map l ~f:string))
(option "value" (attribute_access ()))
| Regex (left, separator, right) ->
lift4
(fun left (v, expr) right kind ->
let dot_attribute = if String.(kind = "value") then "" else "." ^ kind in
Format.sprintf "%s%s%c%s%s%s" left v separator expr right dot_attribute, v, kind)
(string left)
(regex_body separator right)
(string right)
(option "value" (attribute_access ()))
in
result :: acc)
let parse_template =
let hole = choice rewrite_hole_parsers in
many @@ choice
[ (pos >>= fun offset -> hole >>| fun (pattern, variable, kind) ->
Hole { pattern; variable; offset; kind = attribute_to_kind kind })
; (up_to (choice rewrite_hole_parsers) >>| fun c -> Constant (String.of_char_list c))
]
many
@@ choice
[ (pos
>>= fun offset ->
hole
>>| fun (pattern, variable, kind) ->
Hole { pattern; variable; offset; kind = attribute_to_kind kind })
; (up_to (choice rewrite_hole_parsers) >>| fun c -> Constant (String.of_char_list c))
]
let parse template =
match parse_string ~consume:All parse_template template with
| Ok result -> result
| Error e -> failwith ("No rewrite template parse: "^e)
| Error e -> failwith ("No rewrite template parse: " ^ e)
let variables template =
parse template
|> List.filter_map ~f:(function
| Hole { pattern; variable; offset; kind } ->
Some { pattern; variable; offset; kind }
| _ -> None)
| Hole { pattern; variable; offset; kind } -> Some { pattern; variable; offset; kind }
| _ -> None)
let to_string template =
let buf = Buffer.create 10 in
List.iter template ~f:(function
| Constant c -> Buffer.add_string buf c
| Hole { pattern; _ } -> Buffer.add_string buf pattern);
| Constant c -> Buffer.add_string buf c
| Hole { pattern; _ } -> Buffer.add_string buf pattern);
Buffer.contents buf
let camel_to_snake s =
let rec aux i = function
| [] -> []
| ('A'..'Z' as c)::tl when i = 0 -> (Char.lowercase c)::aux (i+1) tl
| ('A'..'Z' as c)::tl when i <> 0 -> '_'::(Char.lowercase c)::aux (i+1) tl
| c::tl -> c::aux (i+1) tl
| ('A' .. 'Z' as c) :: tl when i = 0 -> Char.lowercase c :: aux (i + 1) tl
| ('A' .. 'Z' as c) :: tl when i <> 0 -> '_' :: Char.lowercase c :: aux (i + 1) tl
| c :: tl -> c :: aux (i + 1) tl
in
aux 0 (String.to_list s)
|> String.of_char_list
aux 0 (String.to_list s) |> String.of_char_list
let substitute_kind ?filepath { variable; kind; _ } env =
let open Option in
@ -216,68 +203,62 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
| Length -> Environment.lookup env variable >>| length_to_string
| Lines ->
Environment.lookup env variable
>>| String.count ~f:(Char.(=) '\n')
>>| String.count ~f:(Char.( = ) '\n')
>>| (fun v -> if v = 0 then 1 else v)
>>| Int.to_string
| OffsetStart ->
Environment.lookup_range env variable
>>| fun { match_start = { offset; _ }; _ } ->
Int.to_string offset
>>| fun { match_start = { offset; _ }; _ } -> Int.to_string offset
| OffsetEnd ->
Environment.lookup_range env variable
>>| fun { match_end = { offset; _ }; _ } ->
Int.to_string offset
>>| fun { match_end = { offset; _ }; _ } -> Int.to_string offset
| LineStart ->
filepath >>= fun filepath ->
filepath
>>= fun filepath ->
Environment.lookup_range env variable
>>| fun { match_start = { offset; _ }; _ } ->
let source = In_channel.read_all filepath in (* Inefficient. *)
let source = In_channel.read_all filepath in
(* Inefficient. *)
let index = Match.Offset.index ~source in
let line, _ = Match.Offset.convert_fast ~offset index in
Int.to_string line
| LineEnd ->
filepath >>= fun filepath ->
filepath
>>= fun filepath ->
Environment.lookup_range env variable
>>| fun { match_end = { offset; _ }; _ } ->
let source = In_channel.read_all filepath in (* Inefficient. *)
let source = In_channel.read_all filepath in
(* Inefficient. *)
let index = Match.Offset.index ~source in
let line, _ = Match.Offset.convert_fast ~offset index in
Int.to_string line
| ColumnStart ->
filepath >>= fun filepath ->
filepath
>>= fun filepath ->
Environment.lookup_range env variable
>>| fun { match_start = { offset; _ }; _ } ->
let source = In_channel.read_all filepath in (* Inefficient. *)
let source = In_channel.read_all filepath in
(* Inefficient. *)
let index = Match.Offset.index ~source in
let _, column = Match.Offset.convert_fast ~offset index in
Int.to_string column
| ColumnEnd ->
filepath >>= fun filepath ->
filepath
>>= fun filepath ->
Environment.lookup_range env variable
>>| fun { match_end = { offset; _ }; _ } ->
let source = In_channel.read_all filepath in (* Inefficient. *)
let source = In_channel.read_all filepath in
(* Inefficient. *)
let index = Match.Offset.index ~source in
let _, column = Match.Offset.convert_fast ~offset index in
Int.to_string column
| FilePath -> filepath
| FileName -> filepath >>| Filename.basename
| FileDirectory -> filepath >>| Filename.dirname
| Lowercase ->
Environment.lookup env variable
>>| String.lowercase
| Uppercase ->
Environment.lookup env variable
>>| String.uppercase
| Capitalize ->
Environment.lookup env variable
>>| String.capitalize
| Uncapitalize ->
Environment.lookup env variable
>>| String.uncapitalize
| Lowercase -> Environment.lookup env variable >>| String.lowercase
| Uppercase -> Environment.lookup env variable >>| String.uppercase
| Capitalize -> Environment.lookup env variable >>| String.capitalize
| Uncapitalize -> Environment.lookup env variable >>| String.uncapitalize
| UpperCamelCase ->
Environment.lookup env variable
>>| String.split ~on:'_'
@ -290,53 +271,52 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
>>| List.map ~f:String.capitalize
>>| String.concat
>>| String.uncapitalize
| UpperSnakeCase ->
Environment.lookup env variable
>>| camel_to_snake
>>| String.uppercase
| LowerSnakeCase ->
Environment.lookup env variable
>>| camel_to_snake
>>| String.lowercase
| UpperSnakeCase -> Environment.lookup env variable >>| camel_to_snake >>| String.uppercase
| LowerSnakeCase -> Environment.lookup env variable >>| camel_to_snake >>| String.lowercase
| External "lsif.hover" ->
filepath >>= fun filepath ->
filepath
>>= fun filepath ->
if debug then Format.printf "File for lsif.hover lookup: %s@." filepath;
Environment.lookup env variable >>= fun value ->
Environment.lookup env variable
>>= fun value ->
Environment.lookup_range env variable
>>= fun { match_start = { offset; _ }; _ } ->
let source = In_channel.read_all filepath in (* Inefficient. *)
let source = In_channel.read_all filepath in
(* Inefficient. *)
if debug then Format.printf "Read filepath, source len is %d@." @@ String.length source;
let index = Match.Offset.index ~source in
let line, column = Match.Offset.convert_fast ~offset index in
let line, column = line - 1, column - 1 + String.length value - 1 in
if debug then Format.printf "Var offset:%d line:%d col:%d @." offset line column;
External.handler ~name:"lsif.hover" ~filepath ~line ~column
| External _ -> assert false
let substitute ?filepath template environment =
let replacement_content, environment', _ =
List.fold template ~init:([], Environment.create (), 0) ~f:(fun (result, env, pos) -> function
| Constant c -> c::result, env, pos + String.length c
| Hole ({ variable; pattern; _ } as h) ->
match substitute_kind ?filepath h environment with
| None -> pattern::result, env, pos + String.length variable
| Some value ->
let advance = pos + String.length value in
let range =
Range.
{ match_start = Location.{ default with offset = pos }
; match_end = Location.{ default with offset = advance }
}
in
(* FIXME: here we should probably use pattern, or hole. We don't
List.fold
template
~init:([], Environment.create (), 0)
~f:
(fun (result, env, pos) -> function
| Constant c -> c :: result, env, pos + String.length c
| Hole ({ variable; pattern; _ } as h) ->
(match substitute_kind ?filepath h environment with
| None -> pattern :: result, env, pos + String.length variable
| Some value ->
let advance = pos + String.length value in
let range =
Range.
{ match_start = Location.{ default with offset = pos }
; match_end = Location.{ default with offset = advance }
}
in
(* FIXME: here we should probably use pattern, or hole. We don't
want to substitute var x for length value if it's used as :[x]
vs :[x].length in the same rewrite template. This will only
affect the replacement values, which won't clobber the actual
result. *)
let env = Environment.add ~range env variable value in
value::result, env, advance)
let env = Environment.add ~range env variable value in
value :: result, env, advance))
in
String.concat (List.rev replacement_content), environment'
@ -346,26 +326,29 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) : Ty
let substitute' template environment =
let vars =
List.filter_map template ~f:(function
| Hole { pattern; variable; offset; kind } -> Some { pattern; variable; offset; kind }
| _ -> None)
| Hole { pattern; variable; offset; kind } -> Some { pattern; variable; offset; kind }
| _ -> None)
in
let template_string = to_string template in
let replacement_content, environment =
List.fold vars ~init:(template_string, Environment.create ()) ~f:(fun (template, env) { variable; pattern; _ } ->
List.fold
vars
~init:(template_string, Environment.create ())
~f:(fun (template, env) { variable; pattern; _ } ->
match Environment.lookup environment variable with
| None -> template, env
| Some value ->
match String.substr_index template_string ~pattern with
| None -> template, env
| Some offset ->
let range =
Range.
{ match_start = Location.{ default with offset }
; match_end = Location.{ default with offset = offset + String.length value }
}
in
let env = Environment.add ~range env variable value in
String.substr_replace_all template ~pattern ~with_:value, env)
(match String.substr_index template_string ~pattern with
| None -> template, env
| Some offset ->
let range =
Range.
{ match_start = Location.{ default with offset }
; match_end = Location.{ default with offset = offset + String.length value }
}
in
let env = Environment.add ~range env variable value in
String.substr_replace_all template ~pattern ~with_:value, env))
in
replacement_content, environment
end

3
lib/kernel/matchers/template.mli
View File

@ -1,3 +1,2 @@
open Types
module Make : Metasyntax.S -> External.S -> Template.S
module Make (_ : Metasyntax.S) (_ : External.S) : Template.S

61
lib/kernel/matchers/types.ml
View File

@ -4,7 +4,7 @@ module Language = struct
module Syntax = struct
type escapable_string_literals =
{ delimiters : string list
; escape_character: char
; escape_character : char
}
[@@deriving yojson]
@ -53,7 +53,6 @@ type including = char list
type until = char option
module Hole = struct
type sort =
| Everything
| Expression
@ -71,15 +70,7 @@ module Hole = struct
; at_depth : int option
}
let sorts () =
[ Everything
; Expression
; Alphanum
; Non_space
; Line
; Blank
; Regex
]
let sorts () = [ Everything; Expression; Alphanum; Non_space; Line; Blank; Regex ]
end
type hole = Hole.t
@ -155,8 +146,8 @@ module Template = struct
[@@deriving sexp]
type syntax =
{ variable: string (* E.g., x *)
; pattern: string (* E.g., the entire :[x] part *)
{ variable : string (* E.g., x *)
; pattern : string (* E.g., the entire :[x] part *)
; offset : int
; kind : kind (* The kind of hole, to inform substitution *)
}
@ -167,22 +158,17 @@ module Template = struct
| Constant of string
[@@deriving sexp]
type t = atom list
[@@deriving sexp]
type t = atom list [@@deriving sexp]
module type S = sig
module Matching : sig
val hole_parsers : (Hole.sort * string Vangstrom.t) list
end
val parse : string -> t
val variables : string -> syntax list
val to_string : t -> string
val substitute : ?filepath:string -> t -> Match.Environment.t -> (string * Match.Environment.t)
val substitute : ?filepath:string -> t -> Match.Environment.t -> string * Match.Environment.t
end
end
@ -192,8 +178,7 @@ module Ast = struct
| String of string
[@@deriving sexp]
type antecedent = atom
[@@deriving sexp]
type antecedent = atom [@@deriving sexp]
type expression =
| True
@ -203,13 +188,12 @@ module Ast = struct
| Not_equal of atom * atom
| Match of atom * (antecedent * consequent) list
| Rewrite of atom * (antecedent * atom)
and consequent = expression list
[@@deriving sexp]
and consequent = expression list [@@deriving sexp]
end
module Rule = struct
type t = Ast.expression list
[@@deriving sexp]
type t = Ast.expression list [@@deriving sexp]
module type S = sig
val create : string -> (Ast.expression list, Error.t) result
@ -243,8 +227,7 @@ end
module Engine = struct
module type S = sig
module Make : Language.S -> Metasyntax.S -> External.S -> Matcher.S
module Make (_ : Language.S) (_ : Metasyntax.S) (_ : External.S) : Matcher.S
module Text : Matcher.S
module Paren : Matcher.S
module Dyck : Matcher.S
@ -292,14 +275,24 @@ module Engine = struct
module Haskell : Matcher.S
module HCL : Matcher.S
module Elm : Matcher.S
module Zig: Matcher.S
module Coq: Matcher.S
module Move: Matcher.S
module Solidity: Matcher.S
module Zig : Matcher.S
module Coq : Matcher.S
module Move : Matcher.S
module Solidity : Matcher.S
module C_nested_comments : Matcher.S
val all : (module Matcher.S) list
val select_with_extension : ?metasyntax:Metasyntax.t -> ?external_handler:External.t -> string -> (module Matcher.S) option
val create : ?metasyntax:Metasyntax.t -> ?external_handler:External.t -> Language.Syntax.t -> (module Matcher.S)
val select_with_extension
: ?metasyntax:Metasyntax.t
-> ?external_handler:External.t
-> string
-> (module Matcher.S) option
val create
: ?metasyntax:Metasyntax.t
-> ?external_handler:External.t
-> Language.Syntax.t
-> (module Matcher.S)
end
end

55
lib/kernel/parsers/alpha_comments.ml
View File

@ -1,65 +1,56 @@
open Core_kernel
open MParser
let to_string from until between : string =
from ^ (String.of_char_list between) ^ until
let to_string from until between : string = from ^ String.of_char_list between ^ until
let anything_including_newlines ~until =
(many
(not_followed_by (string until) ""
>>= fun () -> any_char_or_nl))
many (not_followed_by (string until) "" >>= fun () -> any_char_or_nl)
let anything_excluding_newlines ~until =
(many
(not_followed_by (string until) ""
>>= fun () -> any_char))
many (not_followed_by (string until) "" >>= fun () -> any_char)
(** a parser for comments with delimiters [from] and [until] that do not nest *)
let non_nested_comment from until s =
(between
(string from)
(string until)
(anything_including_newlines ~until)
|>> to_string from until
) s
(between (string from) (string until) (anything_including_newlines ~until)
|>> to_string from until)
s
let until_newline start s =
(string start >> anything_excluding_newlines ~until:"\n"
|>> fun l -> start^(String.of_char_list l)) s
(string start
>> anything_excluding_newlines ~until:"\n"
|>> fun l -> start ^ String.of_char_list l)
s
let any_newline comment_string s =
(string comment_string >> anything_excluding_newlines ~until:"\n" |>> fun l -> (comment_string^String.of_char_list l)) s
(string comment_string
>> anything_excluding_newlines ~until:"\n"
|>> fun l -> comment_string ^ String.of_char_list l)
s
let is_not p s =
if is_ok (p s) then
Empty_failed (unknown_error s)
else
else (
match read_char s with
| Some c ->
Consumed_ok (c, advance_state s 1, No_error)
| None ->
Empty_failed (unknown_error s)
| Some c -> Consumed_ok (c, advance_state s 1, No_error)
| None -> Empty_failed (unknown_error s))
(** A nested comment parser *)
let nested_comment from until s =
let reserved = skip ((string from) <|> (string until)) in
let reserved = skip (string from <|> string until) in
let rec grammar s =
((comment_delimiters >>= fun string -> return string)
<|>
(is_not reserved >>= fun c -> return (Char.to_string c)))
(comment_delimiters
>>= (fun string -> return string)
<|> (is_not reserved >>= fun c -> return (Char.to_string c)))
s
and comment_delimiters s =
(between
(string from)
(string until)
((many grammar) >>= fun result ->
return (String.concat result)))
(many grammar >>= fun result -> return (String.concat result)))
s
in
(comment_delimiters |>> fun content ->
from ^ content ^ until) s
(comment_delimiters |>> fun content -> from ^ content ^ until) s
(** a parser for, e.g., /* ... */ style block comments. Non-nested. *)
module Multiline = struct

33
lib/kernel/parsers/alpha_string_literals.ml
View File

@ -1,5 +1,4 @@
open Core_kernel
open MParser
(** Assumes the left and right delimiter are the same, and that these can be
@ -13,21 +12,20 @@ module Escapable = struct
module Make (M : S) = struct
(* delimiters can be escaped and parsing continues within the string body *)
let escaped_char_s s =
any_char s
let escaped_char_s s = any_char s
let char_token_s s =
((char M.escape >> escaped_char_s >>= fun c -> return (Format.sprintf {|%c%c|} M.escape c))
<|> (any_char |>> String.of_char)
)
(char M.escape
>> escaped_char_s
>>= (fun c -> return (Format.sprintf {|%c%c|} M.escape c))
<|> (any_char |>> String.of_char))
s
let base_string_literal s =
((string M.delimiter >> (many_until char_token_s (string M.delimiter))
|>> String.concat)
>>= fun result ->
return (Format.sprintf {|%s%s%s|} M.delimiter result M.delimiter)
)
(string M.delimiter
>> many_until char_token_s (string M.delimiter)
|>> String.concat
>>= fun result -> return (Format.sprintf {|%s%s%s|} M.delimiter result M.delimiter))
s
end
end
@ -43,15 +41,14 @@ module Raw = struct
end
module Make (M : S) = struct
let char_token_s s =
(any_char_or_nl |>> String.of_char) s
let char_token_s s = (any_char_or_nl |>> String.of_char) s
let base_string_literal s =
((
string M.left_delimiter >> (many_until char_token_s (string M.right_delimiter))
|>> String.concat <?> "raw string literal body")
>>= fun result ->
return (Format.sprintf {|%s%s%s|} M.left_delimiter result M.right_delimiter)
(string M.left_delimiter
>> many_until char_token_s (string M.right_delimiter)
|>> String.concat
<?> "raw string literal body"
>>= fun result -> return (Format.sprintf {|%s%s%s|} M.left_delimiter result M.right_delimiter)
)
s
end

12
lib/kernel/parsers/dune
View File

@ -1,6 +1,8 @@
(library
(name parsers)
(public_name comby-kernel.parsers)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_sexp_conv))
(libraries core_kernel comby-kernel.vangstrom mparser))
(name parsers)
(public_name comby-kernel.parsers)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_sexp_conv))
(libraries core_kernel comby-kernel.vangstrom mparser))

48
lib/kernel/parsers/omega_comments.ml
View File

@ -1,45 +1,30 @@
open Core_kernel
open Vangstrom
let (|>>) p f =
p >>= fun x -> return (f x)
let ( |>> ) p f = p >>= fun x -> return (f x)
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))
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 between left right p =
left *> p <* right
let to_string from until between : string =
from ^ (String.of_char_list between) ^ until
let anything_including_newlines ~until =
many (any_char_except ~reserved:[until])
let anything_excluding_newlines () =
anything_including_newlines ~until:"\n"
let between left right p = left *> p <* right
let to_string from until between : string = from ^ String.of_char_list between ^ until
let anything_including_newlines ~until = many (any_char_except ~reserved:[ until ])
let anything_excluding_newlines () = anything_including_newlines ~until:"\n"
let non_nested_comment from until =
between
(string from)
(string until)
(anything_including_newlines ~until)
|>> to_string from until
between (string from) (string until) (anything_including_newlines ~until) |>> to_string from until
module Multiline = struct
module type S = sig
@ -55,8 +40,7 @@ end
(* Consumes the newline if we don't reintroduce it. This can be improved, we
shouldn't need to reintroduce it.*)
let until_newline start =
(string start *> anything_excluding_newlines ()
|>> fun l -> start^(String.of_char_list l))
string start *> anything_excluding_newlines () |>> fun l -> start ^ String.of_char_list l
module Until_newline = struct
module type S = sig

33
lib/kernel/parsers/omega_string_literals.ml
View File

@ -1,9 +1,7 @@
open Core_kernel
open Vangstrom
let (|>>) p f =
p >>= fun x -> return (f x)
let ( |>> ) p f = p >>= fun x -> return (f x)
module Escapable = struct
module type S = sig
@ -13,20 +11,17 @@ module Escapable = struct
module Make (M : S) = struct
(* delimiters can be escaped and parsing continues within the string body *)
let escaped_char_s =
any_char
let escaped_char_s = any_char
let char_token_s =
((char M.escape *> escaped_char_s >>= fun c -> return (Format.sprintf {|%c%c|} M.escape c))
<|> (any_char |>> String.of_char)
)
char M.escape *> escaped_char_s
>>= (fun c -> return (Format.sprintf {|%c%c|} M.escape c))
<|> (any_char |>> String.of_char)
let base_string_literal =
((string M.delimiter *> (many_till char_token_s (string M.delimiter))
|>> String.concat)
>>= fun result ->
return (Format.sprintf {|%s%s%s|} M.delimiter result M.delimiter)
)
string M.delimiter *> many_till char_token_s (string M.delimiter)
|>> String.concat
>>= fun result -> return (Format.sprintf {|%s%s%s|} M.delimiter result M.delimiter)
end
end
@ -37,15 +32,11 @@ module Raw = struct
end
module Make (M : S) = struct
let char_token_s =
(any_char |>> String.of_char)
let char_token_s = any_char |>> String.of_char
let base_string_literal =
((
string M.left_delimiter *> (many_till char_token_s (string M.right_delimiter))
|>> String.concat)
>>= fun result ->
return (Format.sprintf {|%s%s%s|} M.left_delimiter result M.right_delimiter)
)
string M.left_delimiter *> many_till char_token_s (string M.right_delimiter)
|>> String.concat
>>= fun result -> return (Format.sprintf {|%s%s%s|} M.left_delimiter result M.right_delimiter)
end
end

17
lib/kernel/replacement/dune
View File

@ -1,6 +1,13 @@
(library
(name replacement)
(public_name comby-kernel.replacement)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving_yojson))
(libraries comby-kernel.match core_kernel yojson ppx_deriving_yojson ppx_deriving_yojson.runtime))
(name replacement)
(public_name comby-kernel.replacement)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving_yojson))
(libraries
comby-kernel.match
core_kernel
yojson
ppx_deriving_yojson
ppx_deriving_yojson.runtime))

13
lib/kernel/replacement/replacement.ml
View File

@ -1,5 +1,4 @@
open Core_kernel
open Match
type t =
@ -15,11 +14,7 @@ type result =
}
[@@deriving yojson]
let empty_result =
{ rewritten_source = ""
; in_place_substitutions = []
}
[@@deriving yojson]
let empty_result = { rewritten_source = ""; in_place_substitutions = [] } [@@deriving yojson]
let to_json ?path ?replacements ?rewritten_source ~diff () =
let uri =
@ -35,8 +30,4 @@ let to_json ?path ?replacements ?rewritten_source ~diff () =
; "in_place_substitutions", `List (List.map ~f:to_yojson replacements)
; "diff", `String diff
]
| _ ->
`Assoc
[ "uri", uri
; "diff", `String diff
]
| _ -> `Assoc [ "uri", uri; "diff", `String diff ]

17
lib/semantic/dune
View File

@ -1,11 +1,8 @@
(library
(name comby_semantic)
(public_name comby-semantic)
(instrumentation (backend bisect_ppx))
(preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries
core_kernel
lwt
cohttp
cohttp-lwt-unix
yojson))
(name comby_semantic)
(public_name comby-semantic)
(instrumentation
(backend bisect_ppx))
(preprocess
(pps ppx_deriving.show ppx_deriving.eq ppx_sexp_conv))
(libraries core_kernel lwt cohttp cohttp-lwt-unix yojson))

28
lib/semantic/lsif.ml
View File

@ -20,14 +20,10 @@ module Formatting = struct
let lines = text |> String.split_lines |> List.rev in
let rec aux acc collect = function
| [] -> acc
| hd::_ when String.is_prefix hd ~prefix:start ->
acc
| hd::tl when String.is_prefix hd ~prefix:stop ->
aux acc true tl
| hd::tl when collect ->
aux (hd::acc) collect tl
| _::tl ->
aux acc collect tl
| hd :: _ when String.is_prefix hd ~prefix:start -> acc
| hd :: tl when String.is_prefix hd ~prefix:stop -> aux acc true tl
| hd :: tl when collect -> aux (hd :: acc) collect tl
| _ :: tl -> aux acc collect tl
in
aux [] false lines |> String.concat ~sep:"\n"
end
@ -41,7 +37,9 @@ module Context = struct
end
let body Context.{ repository; lsif_endpoint; _ } filepath line character =
let query = {|{"query":"query Hover($repository: String!, $commit: String!, $path: String!, $line: Int!, $character: Int!) {\n repository(name: $repository) {\n commit(rev: $commit) {\n blob(path: $path) {\n lsif {\n hover(line: $line, character: $character) {\n markdown {\n text\n }\n range {\n start {\n line\n character\n }\n end {\n line\n character\n }\n }\n }\n }\n }\n }\n }\n}"|} in
let query =
{|{"query":"query Hover($repository: String!, $commit: String!, $path: String!, $line: Int!, $character: Int!) {\n repository(name: $repository) {\n commit(rev: $commit) {\n blob(path: $path) {\n lsif {\n hover(line: $line, character: $character) {\n markdown {\n text\n }\n range {\n start {\n line\n character\n }\n end {\n line\n character\n }\n }\n }\n }\n }\n }\n }\n}"|}
in
let variables =
Format.sprintf
{|"variables":{"line":%d,"character":%d,"commit":"HEAD","path":"%s","repository":"%s"},"operationName":"Hover"}|}
@ -51,16 +49,17 @@ let body Context.{ repository; lsif_endpoint; _ } filepath line character =
repository
in
let request = Format.sprintf {|%s,%s|} query variables in
Lwt_unix.sleep 0.25 >>= fun _ ->
Client.post ~body:(Cohttp_lwt.Body.of_string request) (Uri.of_string lsif_endpoint) >>= fun (resp, body) ->
Lwt_unix.sleep 0.25
>>= fun _ ->
Client.post ~body:(Cohttp_lwt.Body.of_string request) (Uri.of_string lsif_endpoint)
>>= fun (resp, body) ->
let code = resp |> Response.status |> Code.code_of_status in
if debug then Printf.printf "Response code: %d\n" code;
body |> Cohttp_lwt.Body.to_string
(** {"data":{"repository":{"commit":{"blob":{"lsif":{"hover":{"markdown":{"text":"```go\nvar tr *Trace\n```"},"range":{"start":{"line":64,"character":1},"end":{"line":64,"character":3}}}}}}}}} *)
let hover_at context ~filepath ~line ~column =
let body =
Lwt_main.run (body context filepath line column) in
let body = Lwt_main.run (body context filepath line column) in
try
let response = Yojson.Safe.from_string body in
if debug then Format.printf "Response: %s@." @@ Yojson.Safe.pretty_to_string response;
@ -79,4 +78,5 @@ let hover_at context ~filepath ~line ~column =
|> Formatting.hover context.formatting
in
Some text
with _ -> None
with
| _ -> None

21
src/dune
View File

@ -1,10 +1,16 @@
(executables
(libraries comby core ppx_deriving_yojson ppx_deriving_yojson.runtime
(select if_hack_parallel.ml from
(hack_parallel -> if_hack_parallel.available.ml)
(!hack_parallel -> if_hack_parallel.unavailable.ml))
)
(preprocess (pps ppx_deriving_yojson ppx_let ppx_deriving.show ppx_sexp_conv))
(libraries
comby
core
ppx_deriving_yojson
ppx_deriving_yojson.runtime
(select
if_hack_parallel.ml
from
(hack_parallel -> if_hack_parallel.available.ml)
(!hack_parallel -> if_hack_parallel.unavailable.ml)))
(preprocess
(pps ppx_deriving_yojson ppx_let ppx_deriving.show ppx_sexp_conv))
(modules main if_hack_parallel)
(modes byte exe)
(names main))
@ -20,4 +26,5 @@
(install
(package comby)
(section bin)
(files (main.exe as comby)))
(files
(main.exe as comby)))

3
src/if_hack_parallel.available.ml
View File

@ -1,2 +1 @@
let check_entry_point () =
Scheduler.Daemon.check_entry_point ()
let check_entry_point () = Scheduler.Daemon.check_entry_point ()

3
src/if_hack_parallel.unavailable.ml
View File

@ -1,2 +1 @@
let check_entry_point () =
()
let check_entry_point () = ()

383
src/main.ml
View File

@ -1,28 +1,25 @@
open Core
open Command.Let_syntax
open Comby_kernel
open Configuration
open Command_configuration
let verbose_out_file = "/tmp/comby.out"
let debug =
Sys.getenv "DEBUG_COMBY"
|> Option.is_some
let debug = Sys.getenv "DEBUG_COMBY" |> Option.is_some
let paths_with_file_size paths =
List.map paths ~f:(fun path ->
let length =
In_channel.create path
|> fun channel ->
In_channel.length channel
|> Int64.to_int
|> (fun value -> Option.value_exn value)
|> (fun value -> In_channel.close channel; value)
in
(path, length))
let length =
In_channel.create path
|> fun channel ->
In_channel.length channel
|> Int64.to_int
|> (fun value -> Option.value_exn value)
|> fun value ->
In_channel.close channel;
value
in
path, length)
let list_supported_languages_and_exit omega =
let (module Matcher : Matchers.Engine.S) =
@ -33,8 +30,8 @@ let list_supported_languages_and_exit omega =
in
let list =
List.map Matcher.all ~f:(fun (module M) ->
let ext = List.hd_exn M.extensions in
Format.sprintf " -matcher %-10s%-10s\n" ext M.name)
let ext = List.hd_exn M.extensions in
Format.sprintf " -matcher %-10s%-10s\n" ext M.name)
|> String.concat
in
Format.printf "%-20s%-10s@." "Option" "Language";
@ -47,124 +44,265 @@ let substitute_environment_only_and_exit metasyntax_path anonymous_arguments jso
match metasyntax_path with
| None -> Matchers.Metasyntax.default_metasyntax
| Some metasyntax_path ->
match Sys.file_exists metasyntax_path with
| `No | `Unknown ->
Format.eprintf "Could not open file: %s@." metasyntax_path;
exit 1
| `Yes ->
Yojson.Safe.from_file metasyntax_path
|> Matchers.Metasyntax.of_yojson
|> function
| Ok c -> c
| Error error ->
Format.eprintf "%s@." error;
exit 1
(match Sys.file_exists metasyntax_path with
| `No | `Unknown ->
Format.eprintf "Could not open file: %s@." metasyntax_path;
exit 1
| `Yes ->
Yojson.Safe.from_file metasyntax_path
|> Matchers.Metasyntax.of_yojson
|> (function
| Ok c -> c
| Error error ->
Format.eprintf "%s@." error;
exit 1))
in
let rewrite_template =
match anonymous_arguments with
| Some { rewrite_template; _ } -> rewrite_template
| None ->
Format.eprintf
"When the -substitute-only argument is active, a rewrite template must \
be in the second anonymous argument. For example: `comby 'ignored' \
'rewrite_template' -substitute-only 'JSON-for-the-environment'`.";
"When the -substitute-only argument is active, a rewrite template must be in the second \
anonymous argument. For example: `comby 'ignored' 'rewrite_template' -substitute-only \
'JSON-for-the-environment'`.";
exit 1
in
match Yojson.Safe.from_string (Option.value_exn json_environment) with
| json ->
begin
Match.Environment.of_yojson json
|> function
| Ok environment ->
let substituted = Matchers.Rewrite.substitute ~metasyntax rewrite_template environment in
Format.printf "%s@." substituted;
exit 0
| Error err ->
Format.eprintf "Error, could not convert input to environment: %s@." err;
exit 1
end
Match.Environment.of_yojson json
|> (function
| Ok environment ->
let substituted = Matchers.Rewrite.substitute ~metasyntax rewrite_template environment in
Format.printf "%s@." substituted;
exit 0
| Error err ->
Format.eprintf "Error, could not convert input to environment: %s@." err;
exit 1)
| exception Yojson.Json_error err ->
Format.eprintf "Error, could not parse JSON to environment: %s@." err;
exit 1
let base_command_parameters : (unit -> 'result) Command.Param.t =
[%map_open
(* flags. *)
(* flags. *)
let sequential = flag "sequential" no_arg ~doc:"Run sequentially"
and match_only = flag "match-only" no_arg ~aliases:["only-matching"; "o"] ~doc:"Only perform matching. Put an empty rewrite template as the second argument on the CLI (it is ignored)"
and match_only =
flag
"match-only"
no_arg
~aliases:[ "only-matching"; "o" ]
~doc:
"Only perform matching. Put an empty rewrite template as the second argument on the CLI \
(it is ignored)"
and verbose = flag "verbose" no_arg ~doc:(Format.sprintf "Log to %s" verbose_out_file)
and rule = flag "rule" (optional_with_default "where true" string) ~doc:"rule Apply rules to matches."
and match_timeout = flag "timeout" (optional_with_default 3 int) ~doc:"seconds Set match timeout on a source. Default: 3 seconds"
and target_directory = flag "directory" ~aliases:["d"] (optional_with_default (Sys.getcwd ()) string) ~doc:(Format.sprintf "path Run recursively on files in a directory relative to the root. Default is current directory: %s" @@ Sys.getcwd ())
and directory_depth = flag "depth" (optional int) ~doc:"n Depth to recursively descend into directories"
and templates = flag "templates" ~aliases:["config"; "configuration"] (optional (Arg_type.comma_separated string)) ~doc:"paths CSV of directories containing templates, or TOML configuration files"
and file_filters = flag "extensions" ~aliases:["e"; "file-extensions"; "f"] (optional (Arg_type.comma_separated string)) ~doc:"extensions Comma-separated extensions to include, like \".go\" or \".c,.h\". It is just a file suffix, so you can use it to filter file names like \"main.go\". The extension will be used to infer a matcher, unless -custom-matcher or -matcher is specified"
and override_matcher = flag "matcher" ~aliases:["m"; "lang"; "l"; "language"] (optional string) ~doc:"extension Use this matcher on all files regardless of their file extension, unless a -custom-matcher is specified"
and custom_metasyntax = flag "custom-metasyntax" (optional string) ~doc:"path Path to a JSON file that contains a custom metasyntax definition"
and custom_matcher = flag "custom-matcher" (optional string) ~doc:"path Path to a JSON file that contains a custom matcher"
and zip_file = flag "zip" ~aliases:["z"] (optional string) ~doc:"zipfile A zip file containing files to rewrite"
and rule =
flag "rule" (optional_with_default "where true" string) ~doc:"rule Apply rules to matches."
and match_timeout =
flag
"timeout"
(optional_with_default 3 int)
~doc:"seconds Set match timeout on a source. Default: 3 seconds"
and target_directory =
flag
"directory"
~aliases:[ "d" ]
(optional_with_default (Sys.getcwd ()) string)
~doc:
(Format.sprintf
"path Run recursively on files in a directory relative to the root. Default is \
current directory: %s"
@@ Sys.getcwd ())
and directory_depth =
flag "depth" (optional int) ~doc:"n Depth to recursively descend into directories"
and templates =
flag
"templates"
~aliases:[ "config"; "configuration" ]
(optional (Arg_type.comma_separated string))
~doc:"paths CSV of directories containing templates, or TOML configuration files"
and file_filters =
flag
"extensions"
~aliases:[ "e"; "file-extensions"; "f" ]
(optional (Arg_type.comma_separated string))
~doc:
"extensions Comma-separated extensions to include, like \".go\" or \".c,.h\". It is just \
a file suffix, so you can use it to filter file names like \"main.go\". The extension \
will be used to infer a matcher, unless -custom-matcher or -matcher is specified"
and override_matcher =
flag
"matcher"
~aliases:[ "m"; "lang"; "l"; "language" ]
(optional string)
~doc:
"extension Use this matcher on all files regardless of their file extension, unless a \
-custom-matcher is specified"
and custom_metasyntax =
flag
"custom-metasyntax"
(optional string)
~doc:"path Path to a JSON file that contains a custom metasyntax definition"
and custom_matcher =
flag
"custom-matcher"
(optional string)
~doc:"path Path to a JSON file that contains a custom matcher"
and zip_file =
flag
"zip"
~aliases:[ "z" ]
(optional string)
~doc:"zipfile A zip file containing files to rewrite"
and json_lines = flag "json-lines" no_arg ~doc:"Output JSON line format"
and json_only_diff = flag "json-only-diff" no_arg ~doc:"Output only the URI and diff in JSON line format"
and json_only_diff =
flag "json-only-diff" no_arg ~doc:"Output only the URI and diff in JSON line format"
and overwrite_file_in_place = flag "in-place" no_arg ~doc:"Rewrite files on disk, in place"
and number_of_workers = flag "jobs" (optional_with_default 4 int) ~doc:"n Number of worker processes. Default: 4"
and dump_statistics = flag "statistics" ~aliases:["stats"] no_arg ~doc:"Dump statistics to stderr"
and number_of_workers =
flag "jobs" (optional_with_default 4 int) ~doc:"n Number of worker processes. Default: 4"
and dump_statistics =
flag "statistics" ~aliases:[ "stats" ] no_arg ~doc:"Dump statistics to stderr"
and stdin = flag "stdin" no_arg ~doc:"Read source from stdin"
and stdout = flag "stdout" no_arg ~doc:"Print changed content to stdout. Useful to editors for reading in changed content."
and substitute_environment = flag "substitute-only" (optional string) ~doc:"JSON Substitute the environment specified in JSON into the rewrite template and output the substitution. Do not match or rewrite anything (match templates and inputs are ignored)."
and stdout =
flag
"stdout"
no_arg
~doc:"Print changed content to stdout. Useful to editors for reading in changed content."
and substitute_environment =
flag
"substitute-only"
(optional string)
~doc:
"JSON Substitute the environment specified in JSON into the rewrite template and output \
the substitution. Do not match or rewrite anything (match templates and inputs are \
ignored)."
and diff = flag "diff" no_arg ~doc:"Output diff"
and color = flag "color" no_arg ~doc:"Color matches or replacements (patience diff)."
and newline_separated_rewrites = flag "newline-separated" no_arg ~doc:"Instead of rewriting in place, output rewrites separated by newlines."
and newline_separated_rewrites =
flag
"newline-separated"
no_arg
~doc:"Instead of rewriting in place, output rewrites separated by newlines."
and count = flag "count" no_arg ~doc:"Display a count of matches in a file."
and list = flag "list" no_arg ~doc:"Display supported languages and extensions"
and exclude_directory_prefix = flag "exclude-dir" (optional_with_default ["."] (Arg_type.comma_separated ~strip_whitespace:true string)) ~doc:"prefixes Comma-separated prefixes of directories to exclude. Do not put whitespace between commas unless the string is quoted. Default: '.' (ignore directories starting with dot)"
and exclude_file_prefix = flag "exclude" (optional_with_default [] (Arg_type.comma_separated ~strip_whitespace:true string)) ~doc:"prefixes Comma-separated prefixes of file names or file paths to exclude. Do not put whitespace between commas unless the string is quoted."
and interactive_review = flag "review" ~aliases:["r"] no_arg ~doc:"Review each patch and accept, reject, or modify it with your editor of choice. Defaults to $EDITOR. If $EDITOR is unset, defaults to \"vim\". Override $EDITOR with the -editor flag."
and editor = flag "editor" (optional string) ~doc:"editor Perform manual review with [editor]. This activates -review mode."
and editor_default_is_reject = flag "default-no" no_arg ~doc:"If set, the default action in review (pressing return) will NOT apply the change. Setting this option activates -review mode."
and disable_substring_matching = flag "disable-substring-matching" no_arg ~doc:"Allow :[holes] to match substrings"
and omega = flag "omega" no_arg ~doc:"Use Omega matcher engine."
and fast_offset_conversion = flag "fast-offset-conversion" no_arg ~doc:"Enable fast offset conversion. This is experimental and will become the default once vetted."
and match_newline_toplevel = flag "match-newline-at-toplevel" no_arg ~aliases:[] ~doc:"Enable matching newlines at the top level for :[hole]."
and regex_pattern = flag "regex" no_arg ~doc:"print a regex that a file must satisfy in order for a pattern to be run"
and ripgrep_args = flag "ripgrep" (optional string) ~aliases:["rg"] ~doc:"flags Activate ripgrep for filtering files. Add flags like '-g *.go' to include or exclude file extensions."
and bound_count = flag "bound-count" (optional int) ~doc:"num Stop running when at least num matches are found (possibly more are returned for parallel jobs)."
and parany = flag "parany" no_arg ~doc:"force comby to use the alternative parany parallel processing library."
and exclude_directory_prefix =
flag
"exclude-dir"
(optional_with_default [ "." ] (Arg_type.comma_separated ~strip_whitespace:true string))
~doc:
"prefixes Comma-separated prefixes of directories to exclude. Do not put whitespace \
between commas unless the string is quoted. Default: '.' (ignore directories starting \
with dot)"
and exclude_file_prefix =
flag
"exclude"
(optional_with_default [] (Arg_type.comma_separated ~strip_whitespace:true string))
~doc:
"prefixes Comma-separated prefixes of file names or file paths to exclude. Do not put \
whitespace between commas unless the string is quoted."
and interactive_review =
flag
"review"
~aliases:[ "r" ]
no_arg
~doc:
"Review each patch and accept, reject, or modify it with your editor of choice. Defaults \
to $EDITOR. If $EDITOR is unset, defaults to \"vim\". Override $EDITOR with the -editor \
flag."
and editor =
flag
"editor"
(optional string)
~doc:"editor Perform manual review with [editor]. This activates -review mode."
and editor_default_is_reject =
flag
"default-no"
no_arg
~doc:
"If set, the default action in review (pressing return) will NOT apply the change. \
Setting this option activates -review mode."
and disable_substring_matching =
flag "disable-substring-matching" no_arg ~doc:"Allow :[holes] to match substrings"
and omega = flag "omega" no_arg ~doc:"Use Omega matcher engine."
and fast_offset_conversion =
flag
"fast-offset-conversion"
no_arg
~doc:
"Enable fast offset conversion. This is experimental and will become the default once \
vetted."
and match_newline_toplevel =
flag
"match-newline-at-toplevel"
no_arg
~aliases:[]
~doc:"Enable matching newlines at the top level for :[hole]."
and regex_pattern =
flag
"regex"
no_arg
~doc:"print a regex that a file must satisfy in order for a pattern to be run"
and ripgrep_args =
flag
"ripgrep"
(optional string)
~aliases:[ "rg" ]
~doc:
"flags Activate ripgrep for filtering files. Add flags like '-g *.go' to include or \
exclude file extensions."
and bound_count =
flag
"bound-count"
(optional int)
~doc:
"num Stop running when at least num matches are found (possibly more are returned for \
parallel jobs)."
and parany =
flag
"parany"
no_arg
~doc:"force comby to use the alternative parany parallel processing library."
and tar = flag "tar" no_arg ~doc:"read tar format from stdin."
and chunk_matches = flag "chunk-matches" (optional int) ~aliases:[] ~doc:"line threshold Return content bounded by the min and max line numbers of match ranges. Optionally specify the threshold (number of lines) for grouping content together. Implies -match-only and -json-lines."
and chunk_matches =
flag
"chunk-matches"
(optional int)
~aliases:[]
~doc:
"line threshold Return content bounded by the min and max line numbers of match ranges. \
Optionally specify the threshold (number of lines) for grouping content together. \
Implies -match-only and -json-lines."
and anonymous_arguments =
anon
(maybe
(t3
("MATCH_TEMPLATE" %: string)
("REWRITE_TEMPLATE" %: string)
(sequence ("FULL_FILE_PATHS_OR_FILE_SUFFIXES" %: string))
)
)
(sequence ("FULL_FILE_PATHS_OR_FILE_SUFFIXES" %: string))))
in
let file_filters_to_paths file_filters =
match file_filters with
| [] -> None
| l ->
List.map l ~f:(fun pattern ->
if String.contains pattern '/' then
match Filename.realpath pattern with
| exception Unix.Unix_error _ ->
Format.eprintf
"No such file or directory: %s. Comby interprets \
patterns containing '/' as file paths. If a pattern \
does not contain '/' (like '.ml'), it is considered a \
pattern where file endings must match the pattern. \
Please supply only valid file paths or patterns.@." pattern;
exit 1
| path -> path
else
pattern)
if String.contains pattern '/' then (
match Filename.realpath pattern with
| exception Unix.Unix_error _ ->
Format.eprintf
"No such file or directory: %s. Comby interprets patterns containing '/' as file \
paths. If a pattern does not contain '/' (like '.ml'), it is considered a pattern \
where file endings must match the pattern. Please supply only valid file paths or \
patterns.@."
pattern;
exit 1
| path -> path)
else
pattern)
|> Option.some
in
let anonymous_arguments =
Option.map anonymous_arguments ~f:(fun (match_template, rewrite_template, file_filters) ->
let file_filters = file_filters_to_paths file_filters in
{ match_template; rewrite_template; file_filters })
let file_filters = file_filters_to_paths file_filters in
{ match_template; rewrite_template; file_filters })
in
let file_filters =
if Option.is_some zip_file then
@ -174,7 +312,10 @@ let base_command_parameters : (unit -> 'result) Command.Param.t =
in
if list then list_supported_languages_and_exit omega;
if Option.is_some substitute_environment then
substitute_environment_only_and_exit custom_metasyntax anonymous_arguments substitute_environment;
substitute_environment_only_and_exit
custom_metasyntax
anonymous_arguments
substitute_environment;
let interactive_review =
let default_editor =
let f = Option.some in
@ -191,12 +332,9 @@ let base_command_parameters : (unit -> 'result) Command.Param.t =
None
in
match editor with
| Some editor ->
Some { editor; default_is_accept = not editor_default_is_reject }
| Some editor -> Some { editor; default_is_accept = not editor_default_is_reject }
| None when editor_default_is_reject ->
Some { editor = (Option.value_exn default_editor)
; default_is_accept = false
}
Some { editor = Option.value_exn default_editor; default_is_accept = false }
| None -> None
in
let substitute_in_place = not newline_separated_rewrites in
@ -205,11 +343,10 @@ let base_command_parameters : (unit -> 'result) Command.Param.t =
let fast_offset_conversion_env = Option.is_some @@ Sys.getenv "FAST_OFFSET_CONVERSION_COMBY" in
let fast_offset_conversion = fast_offset_conversion_env || fast_offset_conversion in
let arch = Unix.Utsname.machine (Core.Unix.uname ()) in
let compute_mode = match sequential, parany, arch with
let compute_mode =
match sequential, parany, arch with
| true, _, _ -> `Sequential
| _, true, _
| _, _, "arm32"
| _, _, "arm64" -> `Parany number_of_workers
| _, true, _ | _, _, "arm32" | _, _, "arm64" -> `Parany number_of_workers
| _, false, _ -> `Hack_parallel number_of_workers
in
let match_only = match_only || Option.is_some chunk_matches in
@ -270,32 +407,38 @@ let base_command_parameters : (unit -> 'result) Command.Param.t =
match M.name with
| "Generic" when Option.is_none override_matcher ->
Format.eprintf
"@.WARNING: the GENERIC matcher was used, because a language could not \
be inferred from the file extension(s). The GENERIC matcher may miss \
matches. See '-list' to set a matcher for a specific language and to \
remove this warning, or add -matcher .generic to suppress this warning.@."
"@.WARNING: the GENERIC matcher was used, because a language could not be inferred from \
the file extension(s). The GENERIC matcher may miss matches. See '-list' to set a \
matcher for a specific language and to remove this warning, or add -matcher .generic to \
suppress this warning.@."
| "Generic" when Option.is_some override_matcher -> ()
| _ when Option.is_none override_matcher ->
if debug then Format.eprintf
"@.NOTE: the %s matcher was inferred from the file extension. See \
'-list' to set a matcher for a specific language.@." M.name
| _ -> ()
]
if debug then
Format.eprintf
"@.NOTE: the %s matcher was inferred from the file extension. See '-list' to set a \
matcher for a specific language.@."
M.name
| _ -> ()]
let default_command =
Command.basic ~summary:"Run a rewrite pass. Comby runs in current directory by default. The '-stdin' option rewrites input on stdin." base_command_parameters
Command.basic
~summary:
"Run a rewrite pass. Comby runs in current directory by default. The '-stdin' option \
rewrites input on stdin."
base_command_parameters
let parse_comby_dot_file () =
let open Toml.Types in
match Toml.Parser.from_filename ".comby" with
| `Error (s, _) -> Format.eprintf "TOML parse error in .comby file: %s@." s; exit 1
| `Error (s, _) ->
Format.eprintf "TOML parse error in .comby file: %s@." s;
exit 1
| `Ok toml ->
let flags = Table.find_opt (Toml.Min.key "flags") toml in
let to_flags = function
| None -> []
| Some TString s ->
String.split_on_chars s ~on:[' '; '\t'; '\r'; '\n']
|> List.filter ~f:(String.(<>) "")
| Some (TString s) ->
String.split_on_chars s ~on:[ ' '; '\t'; '\r'; '\n' ] |> List.filter ~f:(String.( <> ) "")
| Some v ->
Format.eprintf "TOML value not a string: %s@." (Toml.Printer.string_of_value v);
exit 1
@ -305,6 +448,6 @@ let parse_comby_dot_file () =
let () =
If_hack_parallel.check_entry_point ();
Command.run default_command ~version:"1.8.1" ~extend:(fun _ ->
match Sys.file_exists ".comby" with
| `Yes -> parse_comby_dot_file ()
| _ -> [])
match Sys.file_exists ".comby" with
| `Yes -> parse_comby_dot_file ()
| _ -> [])

19
test/alpha/dune
View File

@ -1,17 +1,14 @@
(library
(name alpha_test_integration)
(package comby)
(modules
test_special_matcher_cases
test_substring_disabled)
(modules test_special_matcher_cases test_substring_disabled)
(inline_tests)
(preprocess (pps ppx_expect ppx_sexp_message ppx_deriving_yojson))
(libraries
comby
cohttp-lwt-unix
core
camlzip))
(preprocess
(pps ppx_expect ppx_sexp_message ppx_deriving_yojson))
(libraries comby cohttp-lwt-unix core camlzip))
(alias
(name runtest)
(deps (source_tree example) (source_tree example/src/.ignore-me)))
(name runtest)
(deps
(source_tree example)
(source_tree example/src/.ignore-me)))

74
test/alpha/test_special_matcher_cases.ml
View File

@ -1,13 +1,17 @@
open Core
open Comby_kernel
open Matchers
open Matchers.Alpha
let configuration = Configuration.create ~match_kind:Fuzzy ()
let run ?(configuration = configuration) (module M : Matchers.Matcher.S) source match_template rewrite_template =
let run
?(configuration = configuration)
(module M : Matchers.Matcher.S)
source
match_template
rewrite_template
=
M.all ~configuration ~template:match_template ~source ()
|> function
| [] -> print_string "No matches."
@ -20,7 +24,6 @@ let%expect_test "parse_rust_apostrophe_ok" =
let source = {|width="1280"|} in
let match_template = {|width=":[1]"|} in
let rewrite_template = {|:[1]|} in
run (module Generic) source match_template rewrite_template;
[%expect_exact {|1280|}]
@ -28,7 +31,6 @@ let%expect_test "parse_rust_apostrophe_ok" =
let source = {|pub struct GlobBuilder<'a> {}|} in
let match_template = {|{}|} in
let rewrite_template = {|{} // success|} in
run (module Rust) source match_template rewrite_template;
[%expect_exact {|pub struct GlobBuilder<'a> {} // success|}]
@ -36,7 +38,6 @@ let%expect_test "parse_ocaml_apostrophe_ok" =
let source = {|type 'a t = Poly of 'a | Int of int |} in
let match_template = {|type :[v] t = :[_] Int of :[i]|} in
let rewrite_template = {|:[v], :[i]|} in
run (module OCaml) source match_template rewrite_template;
[%expect_exact {|'a, int |}]
@ -44,7 +45,6 @@ let%expect_test "strict_nested_matching" =
let source = {|({})|} in
let match_template = {|(:[1])|} in
let rewrite_template = {|:[1]|} in
run (module Dyck) source match_template rewrite_template;
[%expect_exact {|{}|}]
@ -52,12 +52,12 @@ let%expect_test "strict_nested_matching" =
let source = {|(})|} in
let match_template = {|(:[1])|} in
let rewrite_template = {|:[1]|} in
run (module Dyck) source match_template rewrite_template;
[%expect_exact {|No matches.|}]
let%expect_test "ocaml_blocks" =
let source = {|
let source =
{|
module M : sig
type t
end = struct
@ -71,7 +71,6 @@ let%expect_test "ocaml_blocks" =
in
let match_template = {|struct :[1] end|} in
let rewrite_template = {|struct <deleted> end|} in
run (module OCaml) source match_template rewrite_template;
[%expect_exact {|
module M : sig
@ -80,7 +79,8 @@ let%expect_test "ocaml_blocks" =
|}]
let%expect_test "ocaml_complex_blocks_with_same_end" =
let source = {|
let source =
{|
begin
match x with
| _ ->
@ -96,9 +96,9 @@ let%expect_test "ocaml_complex_blocks_with_same_end" =
in
let match_template = {|begin :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module OCaml) source match_template rewrite_template;
[%expect_exact {|
[%expect_exact
{|
<1>match x with
| _ ->
let module M = struct type t end
@ -111,7 +111,8 @@ let%expect_test "ocaml_complex_blocks_with_same_end" =
|}]
let%expect_test "ruby_blocks" =
let source = {|
let source =
{|
class ActionController::Base
before_filter :generate_css_from_less
@ -123,9 +124,9 @@ end
in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|
[%expect_exact
{|
<1>ActionController::Base
before_filter :generate_css_from_less
@ -138,7 +139,6 @@ let%expect_test "erlang_blocks" =
let source = {|Big = fun(X) -> if X > 10 -> true; true -> false end end.|} in
let match_template = {|fun(:[1]) :[rest] end|} in
let rewrite_template = {|<rest>:[rest]</rest>|} in
run (module Erlang) source match_template rewrite_template;
[%expect_exact {|Big = <rest>-> if X > 10 -> true; true -> false end</rest>.|}]
@ -146,7 +146,6 @@ let%expect_test "ruby_blocks" =
let source = {|class x end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>x</1>|}]
@ -154,7 +153,6 @@ let%expect_test "ruby_blocks_1" =
let source = {|class class def body1 end def body2 end end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>class def body1 end def body2 end end</1>|}]
@ -162,7 +160,6 @@ let%expect_test "ruby_blocks_2" =
let source = {|class class (def body1 end) (def body2 end) end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>class (def body1 end) (def body2 end) end</1>|}]
@ -170,7 +167,6 @@ let%expect_test "ruby_blocks_3" =
let source = {| def (def b end)(def b end) end |} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {| <1>(def b end)(def b end)</1> |}]
@ -178,7 +174,6 @@ let%expect_test "ruby_blocks_4" =
let source = {| def (def a end) f (def b end)end |} in
let match_template = {|def :[1]end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {| <1>(def a end) f (def b end)</1> |}]
@ -187,7 +182,6 @@ let%expect_test "ruby_blocks_5" =
let source = {| def (def a end) f (def b end) end |} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {| <1>(def a end) f (def b end)</1> |}]
@ -195,7 +189,6 @@ let%expect_test "ruby_blocks_5" =
let source = {| def(df b ed) (df b ed)end |} in
let match_template = {|def:[1]end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {| <1>(df b ed) (df b ed)</1> |}]
@ -203,7 +196,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class class ((def (x) end) f (def body end)) end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>class ((def (x) end) f (def body end)) end</1>|}]
@ -211,7 +203,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class class (def body1 end) (def body2 end) end end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|class class (<1>body1</1>) (<1>body2</1>) end end|}]
@ -219,7 +210,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class class (def body1 end) (def body2 end) end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>class (def body1 end) (def body2 end) end</1>|}]
@ -227,7 +217,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class class def (def body1 end) (def body2 end) end end end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|class class <1>(def body1 end) (def body2 end)</1> end end|}]
@ -235,7 +224,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class class def () (def body2 end) end end end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|class class <1>() (def body2 end)</1> end end|}]
@ -243,7 +231,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (def end) (def end) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(def end) (def end)</1>|}]
@ -251,7 +238,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (def end) a (def end) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(def end) a (def end)</1>|}]
@ -259,7 +245,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (defa aend) (adef aend) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(defa aend) (adef aend)</1>|}]
@ -267,7 +252,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (defa aend) a (adef aend) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(defa aend) a (adef aend)</1>|}]
@ -275,7 +259,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (adef a endq) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(adef a endq)</1>|}]
@ -283,7 +266,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def adef a endq end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>adef a endq</1>|}]
@ -291,7 +273,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def def foo end end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def foo end</1>|}]
@ -299,7 +280,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def def end endq|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|No matches.|}]
@ -307,7 +287,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def adef a endq end |} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>adef a endq</1> |}]
@ -315,7 +294,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def fadef a qendq end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>fadef a qendq</1>|}]
@ -323,7 +301,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def defa aend end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>defa aend</1>|}]
@ -331,7 +308,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|(adef a endq)|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|No matches.|}]
@ -339,7 +315,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def adef a endq end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>adef a endq</1>|}]
@ -347,7 +322,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def (adef a endq) end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(adef a endq)</1>|}]
@ -355,7 +329,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class (def ( body )end) end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(def ( body )end)</1>|}]
@ -363,16 +336,13 @@ let%expect_test "ruby_blocks_5" =
let source = {|class def ( body )end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def ( body )end</1>|}]
let%expect_test "ruby_blocks_5" =
let source = {|class def( body ) end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def( body ) end</1>|}]
@ -380,7 +350,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class def() end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def() end</1>|}]
@ -388,7 +357,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class def () end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def () end</1>|}]
@ -396,7 +364,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class def( body )end end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>def( body )end</1>|}]
@ -404,7 +371,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class ( def( body )end) end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>( def( body )end)</1>|}]
@ -412,7 +378,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|class (def( body )end) end|} in
let match_template = {|class :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>(def( body )end)</1>|}]
@ -420,7 +385,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|(def a endq)|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|No matches.|}]
@ -428,7 +392,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|def end|} in
let match_template = {|def :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|No matches.|}]
@ -436,7 +399,6 @@ let%expect_test "ruby_blocks_5" =
let source = {|(def foo end)|} in
let match_template = {|(def :[1] end)|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module Ruby) source match_template rewrite_template;
[%expect_exact {|<1>foo</1>|}]
@ -444,7 +406,6 @@ let%expect_test "ocaml_struct_end" =
let source = {|= struct Something end|} in
let match_template = {|= struct :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module OCaml) source match_template rewrite_template;
[%expect_exact {|<1>Something</1>|}]
@ -452,6 +413,5 @@ let%expect_test "ocaml_struct_end_2" =
let source = {|= struct include Something end|} in
let match_template = {|= struct :[1] end|} in
let rewrite_template = {|<1>:[1]</1>|} in
run (module OCaml) source match_template rewrite_template;
[%expect_exact {|<1>include Something</1>|}]

94
test/alpha/test_substring_disabled.ml
View File

@ -1,5 +1,4 @@
open Core
open Comby_kernel
open Matchers
open Matchers.Alpha
@ -8,7 +7,9 @@ let configuration = Configuration.create ~disable_substring_matching:true ~match
let format s =
let s = String.chop_prefix_exn ~prefix:"\n" s in
let leading_indentation = Option.value_exn (String.lfindi s ~f:(fun _ c -> not (Char.equal c ' '))) in
let leading_indentation =
Option.value_exn (String.lfindi s ~f:(fun _ c -> not (Char.equal c ' ')))
in
s
|> String.split ~on:'\n'
|> List.map ~f:(Fn.flip String.drop_prefix leading_indentation)
@ -19,7 +20,7 @@ let run ?(configuration = configuration) source match_template rewrite_template
Generic.first ~configuration match_template source
|> function
| Ok result ->
Rewrite.all ~source ~rewrite_template [result]
Rewrite.all ~source ~rewrite_template [ result ]
|> (fun x -> Option.value_exn x)
|> (fun { rewritten_source; _ } -> rewritten_source)
|> print_string
@ -42,61 +43,51 @@ let%expect_test "basic" =
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b c d|}];
let source = {|a b c d|} in
let match_template = {|a :[1] c d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b|}];
let source = {|a b c d|} in
let match_template = {|a :[1] d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b c|}];
let source = {|a b c d|} in
let match_template = {|a :[1]|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b c d|}];
let source = {|a b c d|} in
let match_template = {|:[1] c d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b|}];
let source = {|a b c d|} in
let match_template = {|:[1] :[2]|} in
let rewrite_template = {|(:[1]) (:[2])|} in
run source match_template rewrite_template;
[%expect_exact {|(a) (b c d)|}];
let source = {|a b c d|} in
let match_template = {|:[2] :[1]|} in
let rewrite_template = {|(:[2]) (:[1])|} in
run source match_template rewrite_template;
[%expect_exact {|(a) (b c d)|}];
let source = {|a b c d|} in
let match_template = {|a :[2] :[1] d|} in
let rewrite_template = {|(:[2]) (:[1])|} in
run source match_template rewrite_template;
[%expect_exact {|(b) (c)|}];
let source = {|a b c d|} in
let match_template = {|a :[2] :[1]|} in
let rewrite_template = {|(:[2]) (:[1])|} in
run source match_template rewrite_template;
[%expect_exact {|(b) (c d)|}];
let source = {|a b c d|} in
let match_template = {|a :[2] c :[1]|} in
let rewrite_template = {|(:[2]) (:[1])|} in
run source match_template rewrite_template;
[%expect_exact {|(b) (d)|}];
let source = {|x:|} in
let match_template = {|:[1]:|} in
let rewrite_template = {|:[1]|} in
@ -109,14 +100,11 @@ let%expect_test "basic_failures" =
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {||}];
let source = {|a b c d|} in
let match_template = {|a :[2] d :[1]|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact
{||}];
[%expect_exact {||}];
let source = {|a b c d|} in
let match_template = {|a :[2] b :[1]|} in
let rewrite_template = {|:[1]|} in
@ -129,235 +117,200 @@ let%expect_test "delimiter_matching" =
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b c|}];
let source = {|(a b c) d|} in
let match_template = {|(:[1] b :[2]) d|} in
let rewrite_template = {|(:[1]) (:[2])|} in
run source match_template rewrite_template;
[%expect_exact {|(a) (c)|}];
let source = {|q(a b c) d|} in
let match_template = {|q(:[1] b :[2]) d|} in
let rewrite_template = {|(:[1]) (:[2])|} in
run source match_template rewrite_template;
[%expect_exact {|(a) (c)|}];
let source = {|((a) b)|} in
let match_template = {|(:[1] b)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|(a)|}];
let source = {|((a b c)) d|} in
let match_template = {|(:[1]) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|(a b c)|}];
let source = {|((a b c)) d|} in
let match_template = {|(:[1]) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|(a b c)|}];
let source = {|((a b c) q) d|} in
let match_template = {|((:[1]) q) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b c|}];
let source = {|((a b c) q) d|} in
let match_template = {|((:[1] c) q) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b|}];
let source = {|((a b () c) q) d|} in
let match_template = {|((:[1] () c) q) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a b|}];
let source = {|((a ((x) d) b c)) d|} in
let match_template = {|((a :[1] :[2] c)) d|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|((x) d)|}];
let source = {|((a ((x) d) b c)) d|} in
let match_template = {|((a (:[1]) :[2] c)) d|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|(x) d b|}];
let source = {|(b (c) d)|} in
let match_template = {|(:[1])|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b (c) d|}];
let source = {|(b (c) d.)|} in
let match_template = {|(:[1].)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b (c) d|}];
let source = {|(b (c.) d.)|} in
let match_template = {|(:[1].)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b (c.) d|}];
let source = {|(b. (c) d.)|} in
let match_template = {|(:[1].)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b. (c) d|}];
let source = {|(b (c) d.)|} in
let match_template = {|(b :[1] d.)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|(c)|}];
let source = {|outer(inner(dst,src),src)|} in
let match_template = {|outer(:[1],src)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|inner(dst,src)|}];
let source = {|(b ((c)) d.)|} in
let match_template = {|(b :[1] d.)|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|((c))|}];
let source = {|a b c|} in
let match_template = {|a :[1] c|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|b|}];
let source = {|x = foo;|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|foo|}];
let source = {|((a {{x} d} b c)) d|} in
let match_template = {|((a {:[1] d} :[2] c)) d|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|{x} b|}];
let source = {|((a {([{x}]) d} b c)) d|} in
let match_template = {|((a {:[1] d} :[2] c)) d|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|([{x}]) b|}];
let source = {|(((((x)))))|} in
let match_template = {|(((:[1])))|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|((x))|}];
let source = {|((((y(x)z))))|} in
let match_template = {|(((:[1])))|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|(y(x)z)|}];
let source = {|((((y(x)z))))|} in
let match_template = {|(((:[1]):[2]))|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|(y(x)z) |}];
let source = {|(((x)z))|} in
let match_template = {|(((:[1]):[2]))|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|x z|}];
let source = {|((((x))z))|} in
let match_template = {|(((:[1]):[2]))|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|(x) z|}];
let source = {|lolwtfbbq|} in
let match_template = {|lol:[1]bbq|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {||}];
let source = {|x = foo; x = bar;|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|foo x = bar;|}];
let source = {|[ no match prefix ] x = foo; [ no match suffix ]|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|[ no match prefix ] foo [ no match suffix ]|}];
let source = {|x = a; x = b; x = c|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|a x = b; x = c|}];
let source = {|x = ( x = x; );|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|( x = x; )|}];
let source = {|( x = x = x; )|} in
let match_template = {|x = :[1];|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|( x = x )|}];
let source = {|xxx a b d c 1 2 3 b d d blah|} in
let match_template = {|a :[1] c :[2] d|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|xxx b d 1 2 3 b d blah|}];
let source = {|howevenlolwtfbbqispossible|} in
let match_template = {|lol:[1]bbq|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {||}];
let source = {|lolhowevenlolwtfbbqispossiblebbq|} in
let match_template = {|lol:[1]bbq|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {||}];
let source = {|hello my name is bob the builder|} in
let match_template = {|:[alongidentifiername] :[2] :[3] :[xyz] :[5] :[6]|} in
let rewrite_template = {|:[alongidentifiername] :[2] :[3] :[xyz] :[5] :[6]|} in
run source match_template rewrite_template;
[%expect_exact {|hello my name is bob the builder|}];
let source = {|www.testdofooname.com/picsinsideit/stunningpictureofkays1381737242g8k4n-280x428.jpg|} in
let source =
{|www.testdofooname.com/picsinsideit/stunningpictureofkays1381737242g8k4n-280x428.jpg|}
in
let match_template = {|www.:[1]-:[2].jpg|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|testdofooname.com/picsinsideit/stunningpictureofkays1381737242g8k4n 280x428|}];
let source = {|https://api.github.com/repos/dmjacobsen/slurm/commits/716c1499695c68afcab848a1b49653574b4fc167|} in
let source =
{|https://api.github.com/repos/dmjacobsen/slurm/commits/716c1499695c68afcab848a1b49653574b4fc167|}
in
let match_template = {|:[1]api.:[2]/repos/:[3]s/:[4]|} in
let rewrite_template = {|:[1] :[2] :[3] :[4]|} in
run source match_template rewrite_template;
[%expect_exact {||}];
let source =
{|
assert(stream->md_len + md_len -
@ -366,12 +319,14 @@ let%expect_test "delimiter_matching" =
mad_bit_nextbyte(&stream->ptr),
frame_used = md_len - si.foo_data_begin);
stream->md_len += frame_used;
|} |> format
|}
|> format
in
let match_template = {|memcpy(:[1], :[2], :[3]);|} in
let rewrite_template = {|:[1], :[2], :[3]|} in
run source match_template rewrite_template;
[%expect_exact {|assert(stream->md_len + md_len -
[%expect_exact
{|assert(stream->md_len + md_len -
si.foo_data_begin <= MAD_BUFFER_MDLEN);
*stream->foo_data + stream->md_len, mad_bit_nextbyte(&stream->ptr), frame_used = md_len - si.foo_data_begin
stream->md_len += frame_used;|}]
@ -379,13 +334,11 @@ stream->md_len += frame_used;|}]
let%expect_test "significant_whitespace" =
let configuration = Configuration.create ~match_kind:Fuzzy ~significant_whitespace:true () in
let run = run ~configuration in
let source = {|two spaces|} in
let match_template = {|:[1] :[2]|} in
let rewrite_template = {|:[1] :[2]|} in
run source match_template rewrite_template;
[%expect_exact {|two spaces|}];
(* FIXME: this should fail. also test case where separators do or do not need
whitespace. e.g., strict about strcpy(src,dst) matching a template
strcpy(:[1],:[2]) versus strcpy(:[1], :[2]) *)
@ -397,13 +350,11 @@ let%expect_test "significant_whitespace" =
let%expect_test "contextual_matching" =
let run = run_all in
let source = {|memcpy(dst1, src1, 1); memcpy(dst2, src2, 2);|} in
let match_template = {|memcpy(:[1], :[2], :[3])|} in
let rewrite_template = {|:[1]|} in
run source match_template rewrite_template;
[%expect_exact {|dst1; dst2;|}];
let source = {|memcpy(dst1, src1, 1); memcpy(dst2, src2, 2);|} in
let match_template = {|memcpy(:[1], :[2], :[3])|} in
let rewrite_template = {|:[1]|} in
@ -412,7 +363,6 @@ let%expect_test "contextual_matching" =
let%expect_test "contextual_matching_with_short_hole_syntax" =
let run = run_all in
let source = {|memcpy(dst1, src1, 1); memcpy(dst2, src2, 2);|} in
let match_template = {|memcpy(:[[1]], :[2], :[3])|} in
let rewrite_template = {|:[[1]]|} in
@ -422,11 +372,9 @@ let%expect_test "contextual_matching_with_short_hole_syntax" =
let%expect_test "trivial_empty_case" =
let source = "" in
let match_template = "" in
begin
Generic.all ~configuration ~template:match_template ~source ()
|> function
| [] -> print_string "No matches."
| hd :: _ ->
print_string (Yojson.Safe.to_string (Match.to_yojson hd))
end;
[%expect_exact {|{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":0,"line":1,"column":1}},"environment":[],"matched":""}|}]
(Generic.all ~configuration ~template:match_template ~source ()
|> function
| [] -> print_string "No matches."
| hd :: _ -> print_string (Yojson.Safe.to_string (Match.to_yojson hd)));
[%expect_exact
{|{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":0,"line":1,"column":1}},"environment":[],"matched":""}|}]

18
test/common/dune
View File

@ -36,16 +36,14 @@
test_regex_holes
test_template_constraints
test_custom_metasyntax
test_rewrite_attributes
)
test_rewrite_attributes)
(inline_tests)
(preprocess (pps ppx_expect ppx_sexp_message ppx_deriving_yojson))
(libraries
comby
cohttp-lwt-unix
core
camlzip))
(preprocess
(pps ppx_expect ppx_sexp_message ppx_deriving_yojson))
(libraries comby cohttp-lwt-unix core camlzip))
(alias
(name runtest)
(deps (source_tree example) (source_tree example/src/.ignore-me)))
(name runtest)
(deps
(source_tree example)
(source_tree example/src/.ignore-me)))

6
test/common/test_bash.ml
View File

@ -1,5 +1,4 @@
open Core
open Test_helpers
open Comby_kernel
open Matchers
@ -20,18 +19,15 @@ let%expect_test "custom_long_delimiters" =
in
let match_template = {|case :[1] esac|} in
let rewrite_template = {|case nuked blocks esac|} in
run (module Alpha.Bash) source match_template rewrite_template;
[%expect_exact {|
case nuked blocks esac
|}];
run (module Omega.Bash) source match_template rewrite_template;
[%expect_exact {|
case nuked blocks esac
|}]
let%expect_test "custom_long_delimiters_doesn't_work_in_go" =
let source =
{|
@ -48,7 +44,6 @@ let%expect_test "custom_long_delimiters_doesn't_work_in_go" =
in
let match_template = {|case :[1] esac|} in
let rewrite_template = {|case nuked blocks esac|} in
run (module Alpha.Go) source match_template rewrite_template;
[%expect_exact {|
case nuked blocks esac
@ -56,7 +51,6 @@ let%expect_test "custom_long_delimiters_doesn't_work_in_go" =
case nuked blocks esac
esac
|}];
run (module Omega.Go) source match_template rewrite_template;
[%expect_exact {|
case nuked blocks esac

12
test/common/test_c.ml
View File

@ -1,5 +1,4 @@
open Core
open Test_helpers
open Comby_kernel
open Matchers
@ -8,7 +7,6 @@ let%expect_test "comments_1" =
let source = {|match this /**/ expect end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|expect|}];
run (module Omega.C) source match_template rewrite_template;
@ -18,7 +16,6 @@ let%expect_test "comments_2" =
let source = {|match this /* */ expect end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|expect|}];
run (module Omega.C) source match_template rewrite_template;
@ -28,7 +25,6 @@ let%expect_test "comments_3" =
let source = {|match this /* blah blah */ expect /**/ end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|expect|}];
run (module Omega.C) source match_template rewrite_template;
@ -38,7 +34,6 @@ let%expect_test "comments_4" =
let source = {|match this expect/**/end|} in
let match_template = {|match this :[1]end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|expect|}];
run (module Omega.C) source match_template rewrite_template;
@ -48,7 +43,6 @@ let%expect_test "comments_5" =
let source = {|match this expect /**/end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|expect|}];
run (module Omega.C) source match_template rewrite_template;
@ -58,7 +52,6 @@ let%expect_test "comments_6" =
let source = {|/* don't match this (a) end */|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|nothing matches|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|No matches.|}];
run (module Omega.C) source match_template rewrite_template;
@ -68,7 +61,6 @@ let%expect_test "comments_7" =
let source = {|/* don't match /**/ this (a) end */|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|nothing matches|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|No matches.|}];
run (module Omega.C) source match_template rewrite_template;
@ -78,7 +70,6 @@ let%expect_test "comments_8" =
let source = {|(/* don't match this (a) end */)|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|nothing matches|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|No matches.|}];
run (module Omega.C) source match_template rewrite_template;
@ -88,7 +79,6 @@ let%expect_test "comments_9" =
let source = {|/* don't match this (a) end */ do match this (b) end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|/* don't match this (a) end */ do (b)|}];
run (module Omega.C) source match_template rewrite_template;
@ -98,7 +88,6 @@ let%expect_test "comments_10" =
let source = {|/* don't match this (a) end */ do match this () end|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|/* don't match this (a) end */ do ()|}];
run (module Omega.C) source match_template rewrite_template;
@ -108,7 +97,6 @@ let%expect_test "comments_11" =
let source = {|do match this (b) end /* don't match this (a) end */|} in
let match_template = {|match this :[1] end|} in
let rewrite_template = {|:[1]|} in
run (module Alpha.C) source match_template rewrite_template;
[%expect_exact {|do (b) /* don't match this (a) end */|}];
run (module Omega.C) source match_template rewrite_template;

3
test/common/test_c_separators.ml
View File

@ -1,5 +1,4 @@
open Core
open Test_helpers
open Comby_kernel
open Matchers
@ -12,7 +11,6 @@ let%expect_test "whitespace_should_not_matter_between_separators" =
[%expect_exact {|p|}];
run (module Omega.C) source match_template rewrite_template;
[%expect_exact {|p|}];
let source = {|* p|} in
let match_template = {|*:[1]|} in
let rewrite_template = {|:[1]|} in
@ -20,7 +18,6 @@ let%expect_test "whitespace_should_not_matter_between_separators" =
[%expect_exact {| p|}];
run (module Omega.C) source match_template rewrite_template;
[%expect_exact {| p|}];
let source = {|* p|} in
let match_template = {|* :[1]|} in
let rewrite_template = {|:[1]|} in

142
test/common/test_c_style_comments.ml
View File

@ -1,5 +1,4 @@
open Core
open Test_helpers
open Comby_kernel
open Matchers
@ -8,19 +7,15 @@ let%expect_test "rewrite_comments_1" =
let template = "replace this :[1] end" in
let source = "/* don't replace this () end */ do replace this () end" in
let rewrite_template = "X" in
run (module Alpha.C) source template rewrite_template;
[%expect_exact "/* don't replace this () end */ do X"];
run (module Omega.C) source template rewrite_template;
[%expect_exact "/* don't replace this () end */ do X"]
let%expect_test "rewrite_comments_2" =
let template =
{|
let template = {|
if (:[1]) { :[2] }
|}
in
|} in
let source =
{|
/* if (fake_condition_body_must_be_non_empty) { fake_body; } */
@ -31,74 +26,50 @@ let%expect_test "rewrite_comments_2" =
}
|}
in
let rewrite_template =
{|
let rewrite_template = {|
if (:[1]) {}
|}
in
|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
if (real_condition_body_must_be_empty) {}
|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
if (real_condition_body_must_be_empty) {}
|}]
let%expect_test "capture_comments" =
let template = {|if (:[1]) { :[2] }|} in
let source = {|if (true) { /* some comment */ console.log(z); }|} in
run_all_matches (module Alpha.C) source template;
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":48,"line":1,"column":49}},"environment":[{"variable":"1","value":"true","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":8,"line":1,"column":9}}},{"variable":"2","value":"console.log(z);","range":{"start":{"offset":31,"line":1,"column":32},"end":{"offset":46,"line":1,"column":47}}}],"matched":"if (true) { /* some comment */ console.log(z); }"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":48,"line":1,"column":49}},"environment":[{"variable":"1","value":"true","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":8,"line":1,"column":9}}},{"variable":"2","value":"console.log(z);","range":{"start":{"offset":31,"line":1,"column":32},"end":{"offset":46,"line":1,"column":47}}}],"matched":"if (true) { /* some comment */ console.log(z); }"}]}
|}];
run_all_matches (module Omega.C) source template;
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":48,"line":1,"column":49}},"environment":[{"variable":"1","value":"true","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":8,"line":1,"column":9}}},{"variable":"2","value":"console.log(z);","range":{"start":{"offset":31,"line":1,"column":32},"end":{"offset":46,"line":1,"column":47}}}],"matched":"if (true) { /* some comment */ console.log(z); }"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":48,"line":1,"column":49}},"environment":[{"variable":"1","value":"true","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":8,"line":1,"column":9}}},{"variable":"2","value":"console.log(z);","range":{"start":{"offset":31,"line":1,"column":32},"end":{"offset":46,"line":1,"column":47}}}],"matched":"if (true) { /* some comment */ console.log(z); }"}]}
|}]
let%expect_test "single_quote_in_comment" =
let template =
{| {:[1]} |}
in
let source =
{|
let template = {| {:[1]} |} in
let source = {|
/*'*/
{test}
|}
in
let rewrite_template =
{|
|} in
let rewrite_template = {|
{:[1]}
|}
in
|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
{test}
|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
{test}
|}]
let%expect_test "single_quote_in_comment" =
let template =
{| {:[1]} |}
in
let template = {| {:[1]} |} in
let source =
{|
{
@ -109,13 +80,9 @@ let%expect_test "single_quote_in_comment" =
}
|}
in
let rewrite_template =
{|
let rewrite_template = {|
{:[1]}
|}
in
|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|
@ -126,7 +93,6 @@ let%expect_test "single_quote_in_comment" =
for (i = 0; i < setsize; i++)
}
|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|
@ -138,12 +104,8 @@ let%expect_test "single_quote_in_comment" =
}
|}]
let%expect_test "single_quote_in_comment" =
let template =
{| {:[1]} |}
in
let template = {| {:[1]} |} in
let source =
{|
{
@ -153,13 +115,9 @@ let%expect_test "single_quote_in_comment" =
}
|}
in
let rewrite_template =
{|
let rewrite_template = {|
{:[1]}
|}
in
|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|
@ -169,7 +127,6 @@ let%expect_test "single_quote_in_comment" =
for (i = 0; i < setsize; i++)
}
|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|
@ -180,67 +137,42 @@ let%expect_test "single_quote_in_comment" =
}
|}]
let%expect_test "give_back_the_comment_characters_for_newline_comments_too" =
let template =
{| {:[1]} |}
in
let source =
{|
let template = {| {:[1]} |} in
let source = {|
{
// a comment
}
|}
in
let rewrite_template =
{|
|} in
let rewrite_template = {|
{:[1]}
|}
in
|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
{
// a comment
}
|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|
[%expect_exact {|
{
// a comment
}
|}]
let%expect_test "comments_in_templates_imply_whitespace" =
let template =
{|
let template = {|
/* f */
// q
a
|}
in
let source =
{|
|} in
let source = {|
// idgaf
/* fooo */
a
|}
in
let rewrite_template =
{|erased|}
in
|} in
let rewrite_template = {|erased|} in
run (module Alpha.C) source template rewrite_template;
[%expect_exact
{|erased|}];
[%expect_exact {|erased|}];
run (module Omega.C) source template rewrite_template;
[%expect_exact
{|erased|}]
[%expect_exact {|erased|}]

605
test/common/test_cli.ml
View File

File diff suppressed because it is too large Load Diff

10
test/common/test_cli_helper.ml
View File

@ -1,5 +1,4 @@
open Core
module Time = Core_kernel.Time_ns.Span
let binary_path = "../../../../comby"
@ -17,13 +16,12 @@ let read_with_timeout read_from_channels =
|> (fun { Unix.Select_fds.read; _ } -> read)
|> List.map ~f:Unix.in_channel_of_descr
in
List.map read_from_channels ~f:In_channel.input_all
|> String.concat ~sep:"\n"
List.map read_from_channels ~f:In_channel.input_all |> String.concat ~sep:"\n"
let read_output command =
let open Unix.Process_channels in
let { stdout; stderr; _ } =
Unix.open_process_full ~env:(Array.of_list ["COMBY_TEST=1"]) command
Unix.open_process_full ~env:(Array.of_list [ "COMBY_TEST=1" ]) command
in
let stdout_result = In_channel.input_all stdout in
let stderr_result = In_channel.input_all stderr in
@ -32,7 +30,7 @@ let read_output command =
let read_expect_stdin_and_stdout command source =
let open Unix.Process_channels in
let { stdin; stdout; stderr } =
Unix.open_process_full ~env:(Array.of_list ["COMBY_TEST=1"]) command
Unix.open_process_full ~env:(Array.of_list [ "COMBY_TEST=1" ]) command
in
Out_channel.output_string stdin source;
Out_channel.flush stdin;
@ -44,7 +42,7 @@ let read_expect_stdin_and_stdout command source =
let read_expect_stderr command source =
let open Unix.Process_channels in
let { stdin; stdout; stderr } =
Unix.open_process_full ~env:(Array.of_list ["COMBY_TEST=1"]) command
Unix.open_process_full ~env:(Array.of_list [ "COMBY_TEST=1" ]) command
in
Out_channel.output_string stdin source;
Out_channel.flush stdin;

3
test/common/test_cli_list.ml
View File

@ -5,7 +5,8 @@ let%expect_test "list_languages" =
let command = Format.sprintf "%s %s" binary_path command_args in
let result = read_output command in
print_string result;
[%expect_exact {|Option Language
[%expect_exact
{|Option Language
-matcher .s Assembly
-matcher .sh Bash
-matcher .c C

242
test/common/test_custom_metasyntax.ml
View File

@ -1,98 +1,92 @@
open Core
open Comby_kernel
open Test_helpers
let configuration = Matchers.Configuration.create ~match_kind:Fuzzy ()
let create (module E : Matchers.Engine.S) syntax =
let metasyntax = Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] } in
let metasyntax =
Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] }
in
Option.value_exn (E.select_with_extension ~metasyntax ".go")
let%expect_test "custom_metasyntax_everything" =
let matcher =
[ Matchers.Metasyntax.Hole (Everything, Delimited (Some "$", None))
]
in
let matcher = [ Matchers.Metasyntax.Hole (Everything, Delimited (Some "$", None)) ] in
let source = "simple(test)" in
run_all_matches (create (module Matchers.Alpha) matcher) source "simple($A)";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":12,"line":1,"column":13}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"simple(test)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":12,"line":1,"column":13}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"simple(test)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) source "simple($A)";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":12,"line":1,"column":13}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"simple(test)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":12,"line":1,"column":13}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"simple(test)"}]}
|}];
let source = "(nested(test))" in
run_all_matches (create (module Matchers.Alpha) matcher) source "($A)";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"nested(test)","range":{"start":{"offset":1,"line":1,"column":2},"end":{"offset":13,"line":1,"column":14}}}],"matched":"(nested(test))"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"nested(test)","range":{"start":{"offset":1,"line":1,"column":2},"end":{"offset":13,"line":1,"column":14}}}],"matched":"(nested(test))"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) source "($A)";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"nested(test)","range":{"start":{"offset":1,"line":1,"column":2},"end":{"offset":13,"line":1,"column":14}}}],"matched":"(nested(test))"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"nested(test)","range":{"start":{"offset":1,"line":1,"column":2},"end":{"offset":13,"line":1,"column":14}}}],"matched":"(nested(test))"}]}
|}];
let source = "flat stuff yeah" in
run_all_matches (create (module Matchers.Alpha) matcher) source "flat $A yeah";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":15,"line":1,"column":16}},"environment":[{"variable":"A","value":"stuff","range":{"start":{"offset":5,"line":1,"column":6},"end":{"offset":10,"line":1,"column":11}}}],"matched":"flat stuff yeah"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":15,"line":1,"column":16}},"environment":[{"variable":"A","value":"stuff","range":{"start":{"offset":5,"line":1,"column":6},"end":{"offset":10,"line":1,"column":11}}}],"matched":"flat stuff yeah"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) source "flat $A yeah";
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":15,"line":1,"column":16}},"environment":[{"variable":"A","value":"stuff","range":{"start":{"offset":5,"line":1,"column":6},"end":{"offset":10,"line":1,"column":11}}}],"matched":"flat stuff yeah"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":15,"line":1,"column":16}},"environment":[{"variable":"A","value":"stuff","range":{"start":{"offset":5,"line":1,"column":6},"end":{"offset":10,"line":1,"column":11}}}],"matched":"flat stuff yeah"}]}
|}]
let%expect_test "custom_metasyntax_regex" =
let matcher =
Matchers.Metasyntax.
[ Regex ("$", ':', " ")
]
in
let matcher = Matchers.Metasyntax.[ Regex ("$", ':', " ") ] in
let source = "simple(test)" in
run_all_matches (create (module Matchers.Alpha) matcher) source {|$A:\w+ |};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple"},{"range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"test"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple"},{"range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"test"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) source {|$A:\w+ |};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple"},{"range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"test"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple"},{"range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"test","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":11,"line":1,"column":12}}}],"matched":"test"}]}
|}]
let%expect_test "custom_metasyntax_multiple_holes" =
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Hole (Alphanum, Delimited (Some "?", None))
]
[ Hole (Everything, Delimited (Some "$", None)); Hole (Alphanum, Delimited (Some "?", None)) ]
in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)" {|$FOO(?BAR)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"FOO","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"FOO","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)" {|$FOO(?BAR)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"FOO","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"FOO","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
|}];
run_all_matches (create (module Matchers.Alpha) matcher) "foo(bar)" {|?FOO($BAR)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"FOO","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"FOO","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(bar)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "foo(bar)" {|?FOO($BAR)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"FOO","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"BAR","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"FOO","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(bar)"}]}
|}];
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Hole (Alphanum, Delimited (Some "$$", None))
]
in
run_all_matches (create (module Matchers.Alpha) matcher) "foo(bar.baz)" {|$$A|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"A","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"A","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "foo(bar.baz)" {|$$A|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"A","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"A","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
|}];
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
@ -100,14 +94,14 @@ let%expect_test "custom_metasyntax_multiple_holes" =
; Regex ("$", ':', " ")
]
in
run_all_matches (create (module Matchers.Alpha) matcher) "foo(bar.baz)" {|$M:\w+ |};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"M","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"M","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"M","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"M","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"M","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"M","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "foo(bar.baz)" {|$M:\w+ |};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"M","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"M","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"M","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}},"environment":[{"variable":"M","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo"},{"range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}},"environment":[{"variable":"M","value":"bar","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"bar"},{"range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"M","value":"baz","range":{"start":{"offset":8,"line":1,"column":9},"end":{"offset":11,"line":1,"column":12}}}],"matched":"baz"}]}
|}];
(* Expect no matches: Everything parser takes precedence. Allow folding over list to define order. *)
let matcher =
Matchers.Metasyntax.
@ -116,94 +110,89 @@ let%expect_test "custom_metasyntax_multiple_holes" =
; Hole (Alphanum, Delimited (Some "$$", None))
]
in
run_all_matches (create (module Matchers.Alpha) matcher) "foo(bar.baz)" {|$M:\w+ |};
[%expect_exact {|No matches.|}];
run_all_matches (create (module Matchers.Omega) matcher) "foo(bar.baz)" {|$M:\w+ |};
[%expect_exact {|No matches.|}]
let%expect_test "custom_metasyntax_underscore" =
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Hole (Alphanum, Delimited (Some "?", None))
]
[ Hole (Everything, Delimited (Some "$", None)); Hole (Alphanum, Delimited (Some "?", None)) ]
in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)" {|$_(?_)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"_","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"_","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}}],"matched":"simple(bar)"}]}
|}];
(* different because we record _ the first time and don't subsequently for implicit_equals *)
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)" {|$_(?_)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"_","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"_","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
|}]
let%expect_test "custom_metasyntax_equivalence" =
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Regex ("$", '~', "$")
]
Matchers.Metasyntax.[ Hole (Everything, Delimited (Some "$", None)); Regex ("$", '~', "$") ]
in
run_all_matches (create (module Matchers.Alpha) matcher) "foo(foo)" {|$A($A~\w+$)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}},{"variable":"A_equal_!@#$000000000011","value":"foo","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"foo(foo)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}},{"variable":"A_equal_!@#$000000000011","value":"foo","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}}],"matched":"foo(foo)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "foo(foo)" {|$A($A~\w+$)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"A_equal_!@#$000000000012","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(foo)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":8,"line":1,"column":9}},"environment":[{"variable":"A","value":"foo","range":{"start":{"offset":4,"line":1,"column":5},"end":{"offset":7,"line":1,"column":8}}},{"variable":"A_equal_!@#$000000000012","value":"foo","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":3,"line":1,"column":4}}}],"matched":"foo(foo)"}]}
|}]
let%expect_test "custom_metasyntax_definition_order" =
let matcher =
Matchers.Metasyntax.
[ Regex ("$", '~', "$")
; Hole (Everything, Delimited (Some "$", None))
]
Matchers.Metasyntax.[ Regex ("$", '~', "$"); Hole (Everything, Delimited (Some "$", None)) ]
in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)baz" {|$A($B)$C~\w+$|};
[%expect_exact {|No matches.|}];
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)baz" {|$A($B)$C~\w+$|};
[%expect_exact {|No matches.|}];
let matcher =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Regex ("$", '~', "$")
]
Matchers.Metasyntax.[ Hole (Everything, Delimited (Some "$", None)); Regex ("$", '~', "$") ]
in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)baz" {|$A($B)$C~\w+$|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"B","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"C","value":"baz","range":{"start":{"offset":11,"line":1,"column":12},"end":{"offset":14,"line":1,"column":15}}}],"matched":"simple(bar)baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"B","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"C","value":"baz","range":{"start":{"offset":11,"line":1,"column":12},"end":{"offset":14,"line":1,"column":15}}}],"matched":"simple(bar)baz"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)baz" {|$A($B)$C~\w+$|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"B","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"C","value":"baz","range":{"start":{"offset":11,"line":1,"column":12},"end":{"offset":14,"line":1,"column":15}}}],"matched":"simple(bar)baz"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":14,"line":1,"column":15}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"B","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}},{"variable":"C","value":"baz","range":{"start":{"offset":11,"line":1,"column":12},"end":{"offset":14,"line":1,"column":15}}}],"matched":"simple(bar)baz"}]}
|}]
let%expect_test "custom_metasyntax_rewrite_alpha" =
let syntax =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Hole (Alphanum, Delimited (Some "?", None))
]
[ Hole (Everything, Delimited (Some "$", None)); Hole (Alphanum, Delimited (Some "?", None)) ]
in
let metasyntax =
Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] }
in
let metasyntax = Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] } in
let matcher = Option.value_exn (Matchers.Alpha.select_with_extension ~metasyntax ".go") in
let specification = Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"??B -> $A$A" () in
let specification =
Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"??B -> $A$A" ()
in
let result = Pipeline.execute matcher ~metasyntax (String "simple(bar)") specification in
let output = match result with
let output =
match result with
| Replacement (_, result, _) -> result
| Matches _ -> "matches"
| Nothing -> "nothing"
in
print_string output;
[%expect_exact {|?bar -> simplesimple|}];
let specification = Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"$id() $id(a) $id(a)" () in
let specification =
Matchers.Specification.create
~match_template:"$A(?B)"
~rewrite_template:"$id() $id(a) $id(a)"
()
in
let result = Pipeline.execute matcher ~metasyntax (String "simple(bar)") specification in
let output = match result with
let output =
match result with
| Replacement (_, result, _) -> result
| Matches _ -> "matches"
| Nothing -> "nothing"
@ -214,26 +203,33 @@ let%expect_test "custom_metasyntax_rewrite_alpha" =
let%expect_test "custom_metasyntax_rewrite_omega" =
let syntax =
Matchers.Metasyntax.
[ Hole (Everything, Delimited (Some "$", None))
; Hole (Alphanum, Delimited (Some "?", None))
]
[ Hole (Everything, Delimited (Some "$", None)); Hole (Alphanum, Delimited (Some "?", None)) ]
in
let metasyntax =
Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] }
in
let metasyntax = Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] } in
let matcher = Option.value_exn (Matchers.Omega.select_with_extension ~metasyntax ".go") in
let specification = Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"??B -> $A$A" () in
let specification =
Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"??B -> $A$A" ()
in
let result = Pipeline.execute matcher ~metasyntax (String "simple(bar)") specification in
let output = match result with
let output =
match result with
| Replacement (_, result, _) -> result
| Matches _ -> "matches"
| Nothing -> "nothing"
in
print_string output;
[%expect_exact {|?bar -> simplesimple|}];
let specification = Matchers.Specification.create ~match_template:"$A(?B)" ~rewrite_template:"$id() $id(a) $id(a)" () in
let specification =
Matchers.Specification.create
~match_template:"$A(?B)"
~rewrite_template:"$id() $id(a) $id(a)"
()
in
let result = Pipeline.execute matcher ~metasyntax (String "simple(bar)") specification in
let output = match result with
let output =
match result with
| Replacement (_, result, _) -> result
| Matches _ -> "matches"
| Nothing -> "nothing"
@ -242,77 +238,73 @@ let%expect_test "custom_metasyntax_rewrite_omega" =
[%expect_exact {|3 4 4|}]
let%expect_test "custom_metasyntax_greek_letters" =
let matcher =
Matchers.Metasyntax.
[ Hole (Alphanum, Reserved_identifiers ["α"; "β"])
]
in
let matcher = Matchers.Metasyntax.[ Hole (Alphanum, Reserved_identifiers [ "α"; "β" ]) ] in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)" {|α(β)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"α","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"β","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"α","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"β","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)" {|α(β)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"α","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"β","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"α","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"β","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
|}]
let%expect_test "custom_metasyntax_alphanum_test" =
let matcher =
Matchers.Metasyntax.
[ Hole (Alphanum, Delimited (Some "[:", Some ":]"))
; Hole (Alphanum, Reserved_identifiers ["α"; "β"])
; Hole (Alphanum, Reserved_identifiers [ "α"; "β" ])
]
in
run_all_matches (create (module Matchers.Alpha) matcher) "simple(bar)" {|[:A:](α)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"α","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"α","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
|}];
run_all_matches (create (module Matchers.Omega) matcher) "simple(bar)" {|[:A:](α)|};
[%expect_exact {|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"α","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
[%expect_exact
{|{"uri":null,"matches":[{"range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":11,"line":1,"column":12}},"environment":[{"variable":"A","value":"simple","range":{"start":{"offset":0,"line":1,"column":1},"end":{"offset":6,"line":1,"column":7}}},{"variable":"α","value":"bar","range":{"start":{"offset":7,"line":1,"column":8},"end":{"offset":10,"line":1,"column":11}}}],"matched":"simple(bar)"}]}
|}]
let%expect_test "custom_metasyntax_rewrite_length" =
let syntax =
Matchers.Metasyntax.
[ Hole (Alphanum, Delimited (Some "[:", Some ":]"))
; Hole (Alphanum, Reserved_identifiers ["α"; "β"])
; Hole (Alphanum, Reserved_identifiers [ "α"; "β" ])
]
in
let metasyntax = Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] } in
run ~metasyntax (create (module Matchers.Alpha) syntax) "simple(bar)" {|[:A:](α)|} {|[:A:].length (α.length)|};
let metasyntax =
Matchers.Metasyntax.{ syntax; identifier = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"; aliases = [] }
in
run
~metasyntax
(create (module Matchers.Alpha) syntax)
"simple(bar)"
{|[:A:](α)|}
{|[:A:].length (α.length)|};
[%expect_exact {|6 (3)|}];
run ~metasyntax (create (module Matchers.Omega) syntax) "simple(bar)" {|[:A:](α)|} {|[:A:].length (α.length)|};
run
~metasyntax
(create (module Matchers.Omega) syntax)
"simple(bar)"
{|[:A:](α)|}
{|[:A:].length (α.length)|};
[%expect_exact {|6 (3)|}]
let%expect_test "custom_metasyntax_test_alias" =
let aliases =
Matchers.Metasyntax.
[ { pattern = "_1"
; match_template = ":[x1]"
; rule = Some "where :[x1].length == '1'"
}
; { pattern = "_2"
; match_template = ":[x2]"
; rule = Some "where :[x2].length == '2'"
}
; { pattern = "_3"
; match_template = ":[x3]"
; rule = Some "where :[x3].length == '3'"
}
[ { pattern = "_1"; match_template = ":[x1]"; rule = Some "where :[x1].length == '1'" }
; { pattern = "_2"; match_template = ":[x2]"; rule = Some "where :[x2].length == '2'" }
; { pattern = "_3"; match_template = ":[x3]"; rule = Some "where :[x3].length == '3'" }
]
in
(* Need to use default metasyntax because rules don't yet support arbitrary metasyntax *)
let metasyntax = { Matchers.Metasyntax.default_metasyntax with aliases } in
let alpha = Option.value_exn (Matchers.Alpha.select_with_extension ~metasyntax ".go") in
let omega = Option.value_exn (Matchers.Omega.select_with_extension ~metasyntax ".go") in
run ~metasyntax alpha "foo(a) foo(ab) foo(abc) foo(abcd)" "foo(_2)" "matched";
[%expect_exact {|foo(a) matched foo(abc) foo(abcd)|}];
run ~metasyntax omega "foo(a) foo(ab) foo(abc) foo(abcd)" "foo(_2)" "matched";
[%expect_exact {|foo(a) matched foo(abc) foo(abcd)|}];
run ~metasyntax alpha "foo(a) foo(ab) foo(abc) foo(abcd)" "foo(_3)" "matched";
[%expect_exact {|foo(a) foo(ab) matched foo(abcd)|}];
run ~metasyntax omega "foo(a) foo(ab) foo(abc) foo(abcd)" "foo(_3)" "matched";

Some files were not shown because too many files have changed in this diff Show More