-
Notifications
You must be signed in to change notification settings - Fork 37
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #15 from whitequark/rewriter
Add rewriter debugging tool
- Loading branch information
Showing
4 changed files
with
141 additions
and
17 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -11,4 +11,5 @@ | |
| dumpast | ||
| genlifter | ||
| ppx_metaquot | ||
| rewriter | ||
| ast_lifter.ml | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,105 @@ | ||
| (* This file is part of the ppx_tools package. It is released *) | ||
| (* under the terms of the MIT license (see LICENSE file). *) | ||
| (* Copyright 2014 Peter Zotov *) | ||
|
|
||
| let inputs : ([ `Struct | `Sig ] * [ `String | `Path ] * string) list ref = ref [] | ||
| let output_file : string ref = ref "-" | ||
| let tool_name = ref "ocamlc" | ||
|
|
||
| let args = | ||
| let open Arg in | ||
| align [ | ||
| "-ppx", String (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx), | ||
| "<cmd> Invoke <cmd> as a ppx preprocessor"; | ||
|
|
||
| "-str", String (fun s -> inputs := (`Struct, `String, s) :: !inputs), | ||
| "<str> Parse <str> as a structure"; | ||
|
|
||
| "-sig", String (fun s -> inputs := (`Sig, `String, s) :: !inputs), | ||
| "<str> Parse <str> as a signature"; | ||
|
|
||
| "-impl", String (fun s -> inputs := (`Struct, `Path, s) :: !inputs), | ||
| "<file> Parse <file> as an implementation (specify - for stdin)"; | ||
|
|
||
| "-intf", String (fun s -> inputs := (`Sig, `Path, s) :: !inputs), | ||
| "<file> Parse <file> as an interface (specify - for stdin)"; | ||
|
|
||
| "-o", Set_string output_file, | ||
| "<file> Write result into <file> (stdout by default)"; | ||
|
|
||
| "-tool-name", Set_string tool_name, | ||
| "<str> Set tool name to <str> (ocamlc by default)"; | ||
|
|
||
| "-I", String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs), | ||
| "<dir> Add <dir> to the list of include directories"; | ||
|
|
||
| "-open", String (fun s -> Clflags.open_modules := s :: !Clflags.open_modules), | ||
| "<module> Add <module> to the list of opened modules"; | ||
|
|
||
| "-for-pack", String (fun s -> Clflags.for_package := Some s), | ||
| "<ident> Preprocess code as if it will be packed inside <ident>"; | ||
|
|
||
| "-g", Set Clflags.debug, | ||
| " Request debug information from preprocessor"; | ||
| ] | ||
|
|
||
| let anon_arg s = | ||
| match !Clflags.all_ppx with | ||
| | [] -> Clflags.all_ppx := s :: !Clflags.all_ppx | ||
| | _ -> inputs := (`Struct, `Path, s) :: !inputs | ||
|
|
||
| let usage_msg = | ||
| Printf.sprintf | ||
| "Usage: %s [ppx-rewriter] [options...] [implementations...]\n\ | ||
| If no implementations are specified, parses stdin." | ||
| Sys.argv.(0) | ||
|
|
||
| let wrap_open fn file = | ||
| try fn file | ||
| with Sys_error msg -> | ||
| prerr_endline msg; | ||
| exit 1 | ||
|
|
||
| let make_lexer source_kind source = | ||
| match source_kind, source with | ||
| | `String, _ -> | ||
| Location.input_name := "//toplevel//"; | ||
| Lexing.from_string source | ||
| | `Path, "-" -> | ||
| Location.input_name := "//toplevel//"; | ||
| Lexing.from_channel stdin | ||
| | `Path, _ -> | ||
| Location.input_name := source; | ||
| Lexing.from_channel (wrap_open open_in source) | ||
|
|
||
| let () = | ||
| Arg.parse args anon_arg usage_msg; | ||
| if !Clflags.all_ppx = [] then begin | ||
| Arg.usage args usage_msg; | ||
| exit 1 | ||
| end; | ||
| if !inputs = [] then | ||
| inputs := [`Struct, `Path, "-"]; | ||
| let fmt = | ||
| match !output_file with | ||
| | "-" -> Format.std_formatter | ||
| | file -> Format.formatter_of_out_channel (wrap_open open_out file) | ||
| in | ||
| try | ||
| !inputs |> List.iter (fun (ast_kind, source_kind, source) -> | ||
| let lexer = make_lexer source_kind source in | ||
| match ast_kind with | ||
| | `Struct -> | ||
| let pstr = Parse.implementation lexer in | ||
| let pstr = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name | ||
| Config.ast_impl_magic_number pstr in | ||
| Pprintast.structure fmt pstr; | ||
| Format.pp_print_newline fmt () | ||
| | `Sig -> | ||
| let psig = Parse.interface lexer in | ||
| let psig = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name | ||
| Config.ast_intf_magic_number psig in | ||
| Pprintast.signature fmt psig; | ||
| Format.pp_print_newline fmt ()) | ||
| with exn -> | ||
| Location.report_exception Format.err_formatter exn |