|
| 1 | +open Ppxlib |
| 2 | + |
| 3 | +module Kind = struct |
| 4 | + type t = Signature | Structure | Expression | Pattern | Core_type |
| 5 | + |
| 6 | + let to_utils_kind = function |
| 7 | + | Structure -> Ppxlib_private.Utils.Kind.Impl |
| 8 | + | Signature -> Ppxlib_private.Utils.Kind.Intf |
| 9 | + | _ -> assert false |
| 10 | +end |
| 11 | + |
| 12 | +module Ast = struct |
| 13 | + type t = |
| 14 | + | Str of structure |
| 15 | + | Sig of signature |
| 16 | + | Exp of expression |
| 17 | + | Pat of pattern |
| 18 | + | Typ of core_type |
| 19 | +end |
| 20 | + |
| 21 | +module Input = struct |
| 22 | + type t = Stdin | File of string | Source of string |
| 23 | + |
| 24 | + let to_lexbuf t = |
| 25 | + let all_source = |
| 26 | + match t with |
| 27 | + | Stdin -> Stdppx.In_channel.input_all stdin |
| 28 | + | File fn -> Stdppx.In_channel.(with_file fn ~f:input_all) |
| 29 | + | Source s -> s |
| 30 | + in |
| 31 | + Lexing.from_string all_source |
| 32 | + |
| 33 | + let from_string = function |
| 34 | + | "-" -> Stdin |
| 35 | + | s when Sys.file_exists s -> File s |
| 36 | + | s -> Source s |
| 37 | + |
| 38 | + let to_driver_fn = function |
| 39 | + | Stdin -> "-" |
| 40 | + | File fn -> fn |
| 41 | + | Source _ -> assert false |
| 42 | +end |
| 43 | + |
| 44 | +let parse_node ~kind ~input_name input = |
| 45 | + let lexbuf = Input.to_lexbuf input in |
| 46 | + lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_name }; |
| 47 | + Astlib.Location.set_input_lexbuf (Some lexbuf); |
| 48 | + match (kind : Kind.t) with |
| 49 | + | Expression -> Ast.Exp (Parse.expression lexbuf) |
| 50 | + | Pattern -> Ast.Pat (Parse.pattern lexbuf) |
| 51 | + | Core_type -> Ast.Typ (Parse.core_type lexbuf) |
| 52 | + | Signature -> Ast.Str (Parse.implementation lexbuf) |
| 53 | + | Structure -> Ast.Sig (Parse.interface lexbuf) |
| 54 | + |
| 55 | +let load_input ~kind ~input_name input = |
| 56 | + match ((kind : Kind.t), (input : Input.t)) with |
| 57 | + | (Structure | Signature), (Stdin | File _) -> ( |
| 58 | + let kind = Kind.to_utils_kind kind in |
| 59 | + let fn = Input.to_driver_fn input in |
| 60 | + match Driver.load_input ~kind ~input_name ~relocate:false fn with |
| 61 | + | Error (loc_err, _ver) -> Location.Error.raise loc_err |
| 62 | + | Ok (_ast_input_name, _version, ast) -> ( |
| 63 | + match (ast : Ppxlib_private.Utils.Intf_or_impl.t) with |
| 64 | + | Impl str -> Ast.Str str |
| 65 | + | Intf sig_ -> Ast.Sig sig_)) |
| 66 | + | (Expression | Pattern | Core_type), _ | _, Source _ -> |
| 67 | + parse_node ~kind ~input_name input |
| 68 | + |
| 69 | +let pp_ast ~config ast = |
| 70 | + match (ast : Ast.t) with |
| 71 | + | Str str -> Pp_ast.structure ~config Format.std_formatter str |
| 72 | + | Sig sig_ -> Pp_ast.signature ~config Format.std_formatter sig_ |
| 73 | + | Exp exp -> Pp_ast.expression ~config Format.std_formatter exp |
| 74 | + | Pat pat -> Pp_ast.pattern ~config Format.std_formatter pat |
| 75 | + | Typ typ -> Pp_ast.core_type ~config Format.std_formatter typ |
| 76 | + |
| 77 | +let named f = Cmdliner.Term.(app (const f)) |
| 78 | + |
| 79 | +let show_attrs = |
| 80 | + let doc = "Show atributes in the pretty printed output" in |
| 81 | + named |
| 82 | + (fun x -> `Show_attrs x) |
| 83 | + Cmdliner.Arg.(value & flag & info ~doc [ "show-attrs" ]) |
| 84 | + |
| 85 | +let show_locs = |
| 86 | + let doc = "Show locations in the pretty printed output" in |
| 87 | + named |
| 88 | + (fun x -> `Show_locs x) |
| 89 | + Cmdliner.Arg.(value & flag & info ~doc [ "show-locs" ]) |
| 90 | + |
| 91 | +let loc_mode = |
| 92 | + let full_locs = |
| 93 | + let doc = |
| 94 | + "Display locations in long form. Has no effect without --show-locs." |
| 95 | + in |
| 96 | + (`Full, Cmdliner.Arg.info ~doc [ "full-locs" ]) |
| 97 | + in |
| 98 | + named (fun x -> `Loc_mode x) Cmdliner.Arg.(value & vflag `Short [ full_locs ]) |
| 99 | + |
| 100 | +let kind = |
| 101 | + let make_vflag (flag, (kind : Kind.t), doc) = |
| 102 | + (Some kind, Cmdliner.Arg.info ~doc [ flag ]) |
| 103 | + in |
| 104 | + let kinds = |
| 105 | + List.map make_vflag |
| 106 | + [ |
| 107 | + ("str", Structure, "Treat the input as a $(b,.ml) file"); |
| 108 | + ("sig", Signature, "Treat the input as a $(b,.mli) file"); |
| 109 | + ("exp", Expression, "Treat the input as a single OCaml expression"); |
| 110 | + ("pat", Pattern, "Treat the input as a single OCaml pattern"); |
| 111 | + ("typ", Core_type, "Treat the input as a single OCaml core_type"); |
| 112 | + ] |
| 113 | + in |
| 114 | + named (fun x -> `Kind x) Cmdliner.Arg.(value & vflag None kinds) |
| 115 | + |
| 116 | +let input = |
| 117 | + let docv = "INPUT" in |
| 118 | + let doc = |
| 119 | + "The $(docv) AST. Can be a binary AST file, a source file or a valid OCaml \ |
| 120 | + source string. Pass $(b,-) to read from stdin instead." |
| 121 | + in |
| 122 | + named |
| 123 | + (fun x -> `Input x) |
| 124 | + Cmdliner.Arg.(required & pos 0 (some string) None & info ~doc ~docv []) |
| 125 | + |
| 126 | +let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt |
| 127 | + |
| 128 | +let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) |
| 129 | + (`Kind kind) (`Input input) = |
| 130 | + let open Stdppx.Result in |
| 131 | + let kind = |
| 132 | + match kind with |
| 133 | + | Some k -> Ok k |
| 134 | + | None -> ( |
| 135 | + match Ppxlib_private.Utils.Kind.of_filename input with |
| 136 | + | Some Intf -> Ok Kind.Signature |
| 137 | + | Some Impl -> Ok Kind.Structure |
| 138 | + | None -> |
| 139 | + errorf |
| 140 | + "Could not guess kind from input %S. Please use relevant CLI \ |
| 141 | + flag." |
| 142 | + input) |
| 143 | + in |
| 144 | + kind >>= fun kind -> |
| 145 | + let input = Input.from_string input in |
| 146 | + let input_name = |
| 147 | + match input with Stdin -> "<stdin>" | File fn -> fn | Source _ -> "<cli>" |
| 148 | + in |
| 149 | + let ast = load_input ~kind ~input_name input in |
| 150 | + let config = Pp_ast.Config.make ~show_attrs ~show_locs ~loc_mode () in |
| 151 | + pp_ast ~config ast; |
| 152 | + Format.printf "%!\n"; |
| 153 | + Ok () |
| 154 | + |
| 155 | +let term = |
| 156 | + Cmdliner.Term.(const run $ show_attrs $ show_locs $ loc_mode $ kind $ input) |
| 157 | + |
| 158 | +let tool_name = "ppxlib-pp-ast" |
| 159 | + |
| 160 | +let info = |
| 161 | + let p fmt = Printf.ksprintf (fun s -> `P s) fmt in |
| 162 | + let open Cmdliner in |
| 163 | + Cmd.info tool_name ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults |
| 164 | + ~doc:"Pretty prints ppxlib's ASTs from OCaml sources" |
| 165 | + ~man: |
| 166 | + [ |
| 167 | + `S "DESCRIPTION"; |
| 168 | + p |
| 169 | + "$(b,%s) can be used to pretty print the OCaml AST for a given piece \ |
| 170 | + of source code." |
| 171 | + tool_name; |
| 172 | + `P |
| 173 | + "It prints the AST version used by ppxlib internally. This means the \ |
| 174 | + code will be parsed (or the AST unmarshalled) using the installed \ |
| 175 | + compiler and eventually migrated to ppxlib's expected version."; |
| 176 | + `P |
| 177 | + "It can read the source code directly from the command line or read \ |
| 178 | + it from a file/the standard input. In the latter case you can pass \ |
| 179 | + regular $(b,.ml) or $(b,.mli) files, marshalled AST files as the \ |
| 180 | + ones produced by the ppxlib driver or a fragment of OCaml source \ |
| 181 | + corresponding to an expression, a pattern or a core_type."; |
| 182 | + `P |
| 183 | + "When the input is not an $(b,.ml) or $(b,.mli) file you will have \ |
| 184 | + to explicitly pass the expected AST node using flags such as \ |
| 185 | + $(b,--str) or $(b,--exp)."; |
| 186 | + `P "By default the output looks like this:"; |
| 187 | + p "$(b,\\$ %s --exp \"x + 2\")" tool_name; |
| 188 | + `Noblank; |
| 189 | + `Pre |
| 190 | + (String.concat "\n" |
| 191 | + [ |
| 192 | + {|Pexp_apply|}; |
| 193 | + {| ( Pexp_ident (Lident "+")|}; |
| 194 | + {| , [ ( Nolabel, Pexp_ident (Lident "x"))|}; |
| 195 | + {| ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))|}; |
| 196 | + {| ]|}; |
| 197 | + {| )|}; |
| 198 | + ]); |
| 199 | + `P |
| 200 | + "If you are already familiar with the OCaml AST you will note that \ |
| 201 | + it prints a somewhat lighter version to keep the output concise. \ |
| 202 | + Locations and attributes are not printed. Some specific record \ |
| 203 | + types, such as $(b,expression) or $(b,pattern), are \"skipped\" to \ |
| 204 | + avoid too much nesting. This does not hurt comprehension of the \ |
| 205 | + underlying AST as these records only wrap a variant type to attach \ |
| 206 | + metadata to it. The tool supports a set of flags you can use to \ |
| 207 | + force printing of such metadata."; |
| 208 | + `S "EXAMPLES"; |
| 209 | + p "$(b,%s test.ml)" tool_name; |
| 210 | + p "$(b,cat test.ml | %s -)" tool_name; |
| 211 | + p "$(b,%s test.pp.ml)" tool_name; |
| 212 | + p "$(b,%s --exp \"x + 2\")" tool_name; |
| 213 | + p "$(b,%s --typ \"(int, string\\) Result.t\")" tool_name; |
| 214 | + p "$(b,%s --show-locs --full-locs --pat \"_::tl\")" tool_name; |
| 215 | + ] |
| 216 | + |
| 217 | +let () = |
| 218 | + let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in |
| 219 | + exit exit_code |
0 commit comments