├── .gitignore ├── test ├── pp │ ├── pp.ml │ └── dune ├── dune ├── test.ml └── pp.expected ├── examples ├── ret.ml ├── lib.ml ├── simple.ml ├── dune └── example.ml ├── CHANGES.md ├── Makefile ├── ppx ├── dune └── ppx_interact.ml ├── .ocamlformat ├── runtime ├── dune ├── unstable.cppo.ml └── ppx_interact_runtime.ml ├── dune-project ├── docs.md ├── ppx_interact.opam ├── LICENSE └── readme.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.json 4 | -------------------------------------------------------------------------------- /test/pp/pp.ml: -------------------------------------------------------------------------------- 1 | Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /examples/ret.ml: -------------------------------------------------------------------------------- 1 | let x = [%interact: int] in 2 | Format.printf "x = %d@." x 3 | -------------------------------------------------------------------------------- /examples/lib.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | A of string 3 | | B 4 | 5 | let info = "hello" 6 | let t = A info 7 | let succ x = x + 1 -------------------------------------------------------------------------------- /test/pp/dune: -------------------------------------------------------------------------------- 1 | ; a standalone driver 2 | 3 | (executable 4 | (name pp) 5 | (modules pp) 6 | (libraries ppx_interact ppxlib)) 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.2.0 2 | 3 | Move to ppxlib 0.36.0, for 5.2 AST bump 4 | 5 | # 0.1.1 6 | 7 | Support OCaml 5.2.0 8 | 9 | # 0.1.0 10 | 11 | Initial release! 12 | -------------------------------------------------------------------------------- /examples/simple.ml: -------------------------------------------------------------------------------- 1 | let succ x = x + 1 2 | 3 | let () = 4 | let xs = [1; 2; 3] in 5 | let f (a : int) = [%interact] in 6 | print_endline "hello!"; 7 | f 2; 8 | print_endline "goodbye!" -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: all 3 | all: 4 | OCAMLRUNPARAM=b dune test --display=short 5 | 6 | .PHONY: example 7 | example: 8 | OCAMLRUNPARAM=b dune exec examples/example.bc 9 | 10 | .PHONY: doc 11 | doc: 12 | dune build @doc 13 | open _build/default/_doc/_html/index.html 14 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_interact) 3 | (kind ppx_rewriter) 4 | (libraries ppxlib) 5 | (ppx_runtime_libraries ppx_interact.runtime) 6 | (preprocess 7 | (pps ppxlib.metaquot))) 8 | 9 | (env 10 | (dev 11 | (flags 12 | (:standard -warn-error -A)))) 13 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names example simple ret) 3 | ; the containers dependency isn't strictly needed, 4 | ; it's just to show that third-party libraries can be used 5 | (libraries containers) 6 | (modes byte) 7 | (link_flags -linkall) 8 | (preprocess 9 | (pps ppx_interact))) 10 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | ; generates ppx result 2 | 3 | (rule 4 | (targets pp.result) 5 | (deps test.ml) 6 | (action 7 | (run ./pp/pp.exe --impl %{deps} -o %{targets}))) 8 | 9 | ; checks ppx result, enables promotion 10 | 11 | (rule 12 | (alias runtest) 13 | (action 14 | (diff pp.expected pp.result))) 15 | -------------------------------------------------------------------------------- /examples/example.ml: -------------------------------------------------------------------------------- 1 | let z = Lib.t 2 | 3 | let () = 4 | let xs = [1; 2; 3] in 5 | let y = ref 1 in 6 | let f (_a : int) = [%interact: int] in 7 | print_endline "hello!"; 8 | let x = f 2 in 9 | Format.printf "x is: %d@." x; 10 | Format.printf "y is now: %d@." !y; 11 | print_endline "goodbye!" 12 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.21.0 3 | 4 | type-decl=sparse 5 | break-separators=after 6 | space-around-lists=false 7 | dock-collection-brackets=true 8 | field-space=loose 9 | indicate-multiline-delimiters=no 10 | cases-exp-indent=2 11 | leading-nested-match-parens=true 12 | sequence-style=terminator 13 | exp-grouping=preserve 14 | doc-comments=before 15 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_interact_runtime) 3 | (public_name ppx_interact.runtime) 4 | (libraries compiler-libs.toplevel unix linenoise)) 5 | 6 | (env 7 | (dev 8 | (flags 9 | (:standard -warn-error -A)))) 10 | 11 | (rule 12 | (targets unstable.ml) 13 | (deps unstable.cppo.ml) 14 | (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) -------------------------------------------------------------------------------- /runtime/unstable.cppo.ml: -------------------------------------------------------------------------------- 1 | 2 | module Misc = struct 3 | let find_in_path_uncap = 4 | #if OCAML_VERSION < (5,2,0) 5 | Misc.find_in_path_uncap 6 | #else 7 | Misc.find_in_path_normalized 8 | #endif 9 | end 10 | 11 | let get_load_paths cmt_infos = 12 | #if OCAML_VERSION < (5,2,0) 13 | cmt_infos.Cmt_format.cmt_loadpath 14 | #else 15 | cmt_infos.Cmt_format.cmt_loadpath.visible @ 16 | cmt_infos.cmt_loadpath.hidden 17 | #endif -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.7) 2 | 3 | (name ppx_interact) 4 | (generate_opam_files true) 5 | 6 | (source 7 | (github dariusf/ppx_interact)) 8 | 9 | (authors "Darius Foo") 10 | 11 | (maintainers "darius.foo.tw@gmail.com") 12 | (license MIT) 13 | 14 | (package 15 | (name ppx_interact) 16 | (synopsis "Opens a REPL in context") 17 | (description "The pry/pdb experience via a toplevel") 18 | (depends 19 | (ocaml (>= 4.14)) 20 | (cppo :build) 21 | (ppxlib (>= 0.36.0)) 22 | (linenoise (>= 1.4.0)))) 23 | -------------------------------------------------------------------------------- /docs.md: -------------------------------------------------------------------------------- 1 | 2 | # Optional features 3 | 4 | Integration with down and bat may be disabled using the `NO_DOWN` and `NO_BAT` environment variables respectively. 5 | 6 | Set `VERBOSE` for extra logging. 7 | 8 | # UTop 9 | 10 | An early version used a patched utop as a runtime dependency, but that caused some problems: 11 | 12 | - [Transitive dependencies can't (yet) be vendored easily without manually mangling names](https://github.com/ocaml/dune/issues/3335) 13 | - utop's completion system doesn't pick up some bindings, for unknown reasons -------------------------------------------------------------------------------- /ppx_interact.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Opens a REPL in context" 4 | description: "The pry/pdb experience via a toplevel" 5 | maintainer: ["darius.foo.tw@gmail.com"] 6 | authors: ["Darius Foo"] 7 | license: "MIT" 8 | homepage: "https://github.com/dariusf/ppx_interact" 9 | bug-reports: "https://github.com/dariusf/ppx_interact/issues" 10 | depends: [ 11 | "dune" {>= "3.7"} 12 | "ocaml" {>= "4.14"} 13 | "cppo" {build} 14 | "ppxlib" {>= "0.36.0"} 15 | "linenoise" {>= "1.4.0"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/dariusf/ppx_interact.git" 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Darius Foo 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (* module SMap = struct 2 | include Map.Make (struct 3 | type t = string 4 | 5 | let compare = compare 6 | end) 7 | 8 | let pp pp_v fmt map = 9 | (* Format.fprintf fmt "{@[<2>@,%a@]@,}" *) 10 | (* ???? *) 11 | Format.fprintf fmt "{@[<-23>@,%a@]@,}" 12 | (Format.pp_print_list 13 | ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@,") 14 | (fun fmt (k, v) -> 15 | (* Format.fprintf fmt "%s -> %s" k (sprintf_ "%a" pp_v v))) *) 16 | Format.fprintf fmt "%s: %a" k pp_v v)) 17 | (bindings map) 18 | 19 | let update_ k f m = 20 | update k (function None -> failwith "invalid" | Some v -> Some (f v)) m 21 | end *) 22 | 23 | module A = struct 24 | let one = 1 25 | 26 | module C = struct 27 | let nested = 1 28 | end 29 | end 30 | 31 | let a () = 32 | let e = 1 in 33 | 2 34 | 35 | let () = 36 | let _ = 37 | let d = 3 in 38 | [%interact] 39 | in 40 | let b = 2 in 41 | let f a = [%interact] in 42 | [%interact]; 43 | f 2 44 | 45 | module B = struct 46 | let inside = 2 47 | let () = [%interact] 48 | end 49 | -------------------------------------------------------------------------------- /test/pp.expected: -------------------------------------------------------------------------------- 1 | module A = struct let one = 1 2 | module C = struct let nested = 1 end end 3 | let a () = let e = 1 in 2 4 | let () = 5 | let _ = 6 | let d = 3 in 7 | Ppx_interact_runtime.view_file 38 "test.ml"; 8 | Ppx_interact_runtime.interact ~unit:__MODULE__ ~loc:__POS__ 9 | ~values:[V ("d", d); 10 | V ("a", a); 11 | V ("nested", A.C.nested); 12 | V ("one", A.one)] () in 13 | let b = 2 in 14 | let f a = 15 | Ppx_interact_runtime.view_file 41 "test.ml"; 16 | Ppx_interact_runtime.interact ~unit:__MODULE__ ~loc:__POS__ 17 | ~values:[V ("a", a); 18 | V ("b", b); 19 | V ("a", a); 20 | V ("nested", A.C.nested); 21 | V ("one", A.one)] () in 22 | (Ppx_interact_runtime.view_file 42 "test.ml"; 23 | Ppx_interact_runtime.interact ~unit:__MODULE__ ~loc:__POS__ 24 | ~values:[V ("f", f); 25 | V ("b", b); 26 | V ("a", a); 27 | V ("nested", A.C.nested); 28 | V ("one", A.one)] ()); 29 | f 2 30 | module B = 31 | struct 32 | let inside = 2 33 | let () = 34 | Ppx_interact_runtime.view_file 47 "test.ml"; 35 | Ppx_interact_runtime.interact ~unit:__MODULE__ ~loc:__POS__ 36 | ~values:[V ("inside", inside); 37 | V ("a", a); 38 | V ("nested", A.C.nested); 39 | V ("one", A.one)] () 40 | end 41 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | 2 | # ppx_interact 3 | 4 | Interactive breakpoints! 5 | 6 | Use the extension node `[%interact]` to set a breakpoint, like the `debugger` statement in JavaScript. 7 | 8 | ```ocaml 9 | let succ x = x + 1 10 | 11 | let () = 12 | let xs = [1; 2; 3] in 13 | let f (a : int) = 14 | [%interact] 15 | in 16 | print_endline "hello!"; 17 | f 2; 18 | print_endline "goodbye!" 19 | ``` 20 | 21 | A REPL will start when it is evaluated, allowing arbitrary expressions to be evaluated using variables in scope. 22 | 23 | ``` 24 | $ dune exec examples/simple.bc 25 | hello! 26 | ──────────────────────────────────────────────────────────── 27 | examples/simple.ml 28 | ───┬──────────────────────────────────────────────────────── 29 | 1 │ let succ x = x + 1 30 | 2 │ 31 | 3 │ let () = 32 | 4 │ let xs = [1; 2; 3] in 33 | 5 │ let f (a : int) = [%interact] in 34 | 6 │ print_endline "hello!"; 35 | 7 │ f 2; 36 | ───┴──────────────────────────────────────────────────────── 37 | > succ 38 | - : int -> int = 39 | > List.length xs + succ a 40 | - : int = 6 41 | > ^D 42 | goodbye! 43 | ``` 44 | 45 | External libraries work as well. 46 | 47 | ``` 48 | > CCList.map CCInt.succ xs;; 49 | - : CCInt.t CCList.t = [2; 3; 4] 50 | ``` 51 | 52 | Use a type payload to specify the return type of the extension node. The return value is given by assigning to the write-only ref `_ret`. 53 | 54 | ```ocaml 55 | let x = [%interact: int] in 56 | Format.printf "x = %d@." x 57 | ``` 58 | 59 | ``` 60 | > _ret := 3 61 | - : unit = () 62 | > ^D 63 | x = 3 64 | ``` 65 | 66 | Toplevel directives are available. Standard things like `#use "topfind"` to `#require` and `#show` the module signatures of a package are possible. 67 | 68 | It is also possible to `#trace` functions and call them on values in context. This persists across breakpoints, so use `#untrace_all` to disable tracing. 69 | 70 | .ocamlinit files are loaded, so if you use one to `#install_printer`s and open modules for `dune utop`, everything should work the same. 71 | 72 | [down](https://github.com/dbuenzli/down) works and will be automatically loaded if available. Otherwise, a simpler [linenoise](https://github.com/ocaml-community/ocaml-linenoise/) REPL with support for completions will be used. 73 | 74 | If [bat](https://github.com/sharkdp/bat) is installed, it will be invoked to show the context with syntax highlighting. 75 | 76 | See the [docs](docs.md) for more details. 77 | 78 | # Usage 79 | 80 | ```sh 81 | opam install ppx_interact 82 | ``` 83 | 84 | Build a bytecode executable using the following setup: 85 | 86 | ```diff 87 | (executable 88 | - (name example)) 89 | + (name example) 90 | + (modes byte) 91 | + (link_flags -linkall) 92 | + (preprocess (pps ppx_interact))) 93 | ``` 94 | 95 | - The executable must be built in bytecode mode (this may be relaxed when the [native toplevel](https://github.com/ocaml/RFCs/pull/15) is mature) 96 | - `-linkall` is typical for [building custom toplevels](https://dune.readthedocs.io/en/stable/quick-start.html#building-a-custom-toplevel) and allows the use of external libraries 97 | 98 | See the [example project](example) for the full setup. 99 | 100 | Currently this only works with executables, and not expect tests in libraries ([open PR](https://github.com/ocaml/dune/pull/5622)). 101 | 102 | The runtime library of this project can also be used standalone to support scripting use cases, e.g. in [ppx_debug](https://github.com/dariusf/ppx_debug). 103 | 104 | # Background 105 | 106 | Unlike many interactive debuggers (pdb, pry, jdb, node inspect, ...), ocamldebug has limited support for evaluating code when stopped at breakpoints, [only allowing field and variable values to be read](https://v2.ocaml.org/manual/debugger.html#s%3Adebugger-examining-values). 107 | 108 | The idea to use a toplevel to support this [originated](https://sympa.inria.fr/sympa/arc/caml-list/2017-05/msg00124.html) [in](https://github.com/ocaml-community/utop/issues/158) [utop](https://github.com/ocaml-community/utop/tree/master/examples/interact): 109 | 110 | > utop interact: this is an experimental feature that has existed for a while. However it is a bit painful to setup so it is currently undocumented. However, properly packaged and maybe with the help of a compiler plugin this could be a killer feature. 111 | > 112 | > What it allows you to do is call `UTop_main.interact ()` somewhere in your program. When the execution reaches this point, you get a toplevel in the context of the call to `UTop_main.interact`, allowing you to inspect the environment to understand what is happening 113 | 114 | ppx_interact implements this idea. 115 | -------------------------------------------------------------------------------- /ppx/ppx_interact.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ast = Ast_builder.Default 3 | 4 | type string = label 5 | 6 | let ret_name = "_ret" 7 | 8 | let get_name p = 9 | match p.ppat_desc with Ppat_var { txt = s; _ } -> [s] | _ -> [] 10 | 11 | let build_list ~loc xs = 12 | List.fold_right (fun c t -> [%expr [%e c] :: [%e t]]) xs [%expr []] 13 | 14 | let build_qmodule xs = 15 | match xs with 16 | | [] -> failwith "invalid empty identifier" 17 | | [x] -> Lident x 18 | | x :: xs -> List.fold_left (fun t c -> Ldot (t, c)) (Lident x) xs 19 | 20 | type env = { 21 | bindings : (string * string list * Longident.t) list; 22 | module_context : string list; 23 | } 24 | 25 | let empty_env = { module_context = []; bindings = [] } 26 | 27 | (* copied from Ast_traverse *) 28 | let var_names_of = 29 | object 30 | inherit [string list] Ast_traverse.fold as super 31 | 32 | method! pattern p acc = 33 | let acc = super#pattern p acc in 34 | match p.ppat_desc with Ppat_var { txt; _ } -> txt :: acc | _ -> acc 35 | end 36 | 37 | let traverse () = 38 | object 39 | inherit [env] Ast_traverse.fold_map as super 40 | 41 | method! value_binding vb env = 42 | let v, _ = super#value_binding vb env in 43 | let name = get_name v.pvb_pat in 44 | ( v, 45 | { 46 | env with 47 | bindings = 48 | List.map 49 | (fun n -> 50 | let ident = 51 | match env.module_context with 52 | | [] -> Lident n 53 | | _ -> build_qmodule (List.rev (n :: env.module_context)) 54 | in 55 | (n, env.module_context, ident)) 56 | name 57 | @ env.bindings; 58 | } ) 59 | 60 | method! structure_item s env = 61 | match s.pstr_desc with 62 | | Pstr_module { pmb_name = { txt = Some name; _ }; _ } -> 63 | let s, env1 = 64 | super#structure_item s 65 | { env with module_context = name :: env.module_context } 66 | in 67 | (* restore the old module context as we exit *) 68 | (s, { env1 with module_context = env.module_context }) 69 | | Pstr_value (_, _) -> 70 | (* TODO mutually recursive bindings *) 71 | super#structure_item s env 72 | | _ -> super#structure_item s env 73 | 74 | method! expression e env = 75 | let open Ast_helper in 76 | match e.pexp_desc with 77 | | Pexp_function (params, _, _) -> 78 | let vs = List.fold_left (fun acc -> function 79 | | { pparam_desc = Pparam_val (_, _, pat); _ } -> (var_names_of#pattern pat []) :: acc 80 | | { pparam_desc = Pparam_newtype _; _ } -> acc) [] params in 81 | (* update env, and only then recurse into subexpressions *) 82 | let env1 = 83 | List.fold_right 84 | (fun cs t -> 85 | let new_bindings = 86 | List.map (fun c -> (c, env.module_context, Lident c)) cs 87 | in 88 | { 89 | t with 90 | bindings = new_bindings @ t.bindings; 91 | }) 92 | vs env 93 | in 94 | let e, env = super#expression e env1 in 95 | (e, env) 96 | | Pexp_extension ({ txt = s; _ }, payload) when String.equal s "interact" 97 | -> 98 | let loc = e.pexp_loc in 99 | let elt (name, original_ctx, ident) = 100 | let s = Exp.constant ~loc (Const.string ~loc name) in 101 | let id = 102 | Exp.ident ~loc 103 | { 104 | txt = 105 | (* check at the use site if we're still in that module, if so don't qualify *) 106 | (if env.module_context != original_ctx then ident 107 | else Lident name); 108 | loc; 109 | } 110 | in 111 | [%expr V ([%e s], [%e id])] 112 | in 113 | let dump_variables = false in 114 | let count_variables = false in 115 | let debug = 116 | if dump_variables then 117 | Ast.estring ~loc 118 | ("\n\n" 119 | ^ String.concat ", " 120 | (env.bindings |> List.rev |> List.map (fun (a, _, _) -> a)) 121 | ^ "\n\n") 122 | else [%expr ""] 123 | in 124 | let variable_stats = 125 | if count_variables then 126 | [%expr 127 | Format.sprintf ", with %d variables in scope" 128 | [%e Exp.constant ~loc (Const.int (List.length env.bindings))]] 129 | else [%expr ""] 130 | in 131 | let _status_print = 132 | [%expr 133 | Format.printf "At line %d in module %s%s.%s@." __LINE__ __MODULE__ 134 | [%e variable_stats] [%e debug]] 135 | in 136 | (* turning this back on requires utop to be added as a runtime dependency *) 137 | let utop = false in 138 | let return_type = match payload with PTyp t -> Some t | _ -> None in 139 | let all_bindings = 140 | match return_type with 141 | | None -> env.bindings 142 | | Some _ -> (ret_name, [], Lident ret_name) :: env.bindings 143 | in 144 | let elts = List.map elt all_bindings in 145 | let toplevel_call = 146 | match utop with 147 | | true -> 148 | [%expr 149 | Ppx_interact.UTop_main.interact ~unit:__MODULE__ ~loc:__POS__ 150 | ~values:[%e build_list ~loc elts] ()] 151 | | false -> 152 | [%expr 153 | Ppx_interact_runtime.interact ~unit:__MODULE__ ~loc:__POS__ 154 | ~values:[%e build_list ~loc elts] ()] 155 | in 156 | let show_source = 157 | let file_name = loc.loc_start.pos_fname in 158 | let line = loc.loc_start.pos_lnum in 159 | [%expr 160 | Ppx_interact_runtime.view_file [%e Ast.eint ~loc line] 161 | [%e Ast.estring ~loc file_name]] 162 | in 163 | 164 | let breakpoint = 165 | [%expr 166 | (* [%e status_print]; *) 167 | [%e show_source]; 168 | [%e toplevel_call]] 169 | in 170 | let breakpoint_ret = 171 | let ret_pat = Ast.ppat_var ~loc { loc; txt = ret_name } in 172 | let ret_var = Ast.pexp_ident ~loc { loc; txt = Lident ret_name } in 173 | let ref_type t = 174 | Ast.ptyp_constr ~loc { loc; txt = Lident "ref" } [t] 175 | in 176 | match return_type with 177 | | Some t -> 178 | [%expr 179 | let ([%p ret_pat] : [%t ref_type t]) = ref (Obj.magic ()) in 180 | [%e breakpoint]; 181 | ![%e ret_var]] 182 | | None -> breakpoint 183 | in 184 | (breakpoint_ret, env) 185 | | _ -> super#expression e env 186 | end 187 | 188 | let transform_impl ctxt str = 189 | let _file = Expansion_context.Base.code_path ctxt |> Code_path.file_path in 190 | let s, _ = (traverse ())#structure str empty_env in 191 | s 192 | 193 | let () = Driver.V2.register_transformation ~impl:transform_impl "ppx_interact" 194 | -------------------------------------------------------------------------------- /runtime/ppx_interact_runtime.ml: -------------------------------------------------------------------------------- 1 | (* box-drawing characters *) 2 | let box_h = "─" 3 | let box_v = "│" 4 | let box_t = "┬" 5 | let box_bot = "┴" 6 | 7 | let view_file ?(context = (4, 2)) line file = 8 | let before, after = context in 9 | let show () = 10 | let ic = open_in file in 11 | let rec loop skip left = 12 | if left <= 0 then [] 13 | else 14 | try 15 | let line = input_line ic in 16 | if skip > 0 then loop (skip - 1) left 17 | else 18 | let line = if skip = 0 then line else line in 19 | line :: loop 0 (left - 1) 20 | with End_of_file -> [] 21 | in 22 | let lines = loop (max 0 (line - before - 1)) (before + after + 1) in 23 | let line_number_width = 24 | 2 + (log10 (line + after |> float_of_int) |> int_of_float) 25 | in 26 | let title_width = line_number_width + 3 in 27 | let divider joint = 28 | List.init 60 (fun i -> if i = line_number_width + 1 then joint else box_h) 29 | |> String.concat "" 30 | in 31 | Format.printf "%s@." (divider box_h); 32 | Format.printf "%s@." (String.init title_width (fun _ -> ' ') ^ file); 33 | Format.printf "%s@." (divider box_t); 34 | List.iteri 35 | (fun i l -> 36 | Format.printf "%*d %s %s\n" line_number_width 37 | (i + max 1 (line - before)) 38 | box_v l) 39 | lines; 40 | Format.printf "%s@." (divider box_bot); 41 | close_in ic 42 | in 43 | match Sys.getenv_opt "NO_BAT" with 44 | | Some _ -> show () 45 | | None -> 46 | let open Unix in 47 | (match 48 | create_process "bat" 49 | [| 50 | "--paging=never"; 51 | "--line-range"; 52 | Format.asprintf "%d:%d" (line - before) (line + after); 53 | "--highlight-line"; 54 | string_of_int line; 55 | file; 56 | "--style"; 57 | "header,numbers,grid"; 58 | |] 59 | stdin stdout stderr 60 | |> waitpid [] |> snd 61 | with 62 | | WEXITED 0 -> () 63 | | WEXITED _ | WSIGNALED _ | WSTOPPED _ 64 | | (exception Unix_error (ENOENT, "create_process", "bat")) -> 65 | show ()) 66 | 67 | let eval ~show text = 68 | let lexbuf = Lexing.from_string text in 69 | let phrase = !Toploop.parse_toplevel_phrase lexbuf in 70 | ignore (Toploop.execute_phrase show Format.std_formatter phrase) 71 | 72 | exception Found of Env.t 73 | exception Term of int 74 | 75 | type value = V : string * _ -> value 76 | 77 | let walk dir ~init ~f = 78 | let rec loop dir acc = 79 | let acc = f dir acc in 80 | ArrayLabels.fold_left (Sys.readdir dir) ~init:acc ~f:(fun acc fn -> 81 | let fn = Filename.concat dir fn in 82 | match Unix.lstat fn with 83 | | { st_kind = S_DIR; _ } -> loop fn acc 84 | | _ -> acc) 85 | in 86 | match Unix.lstat dir with 87 | | exception Unix.Unix_error (ENOENT, _, _) -> init 88 | | _ -> loop dir init 89 | 90 | (** https://github.com/ocaml/ocaml/blob/trunk/toplevel/toploop.ml *) 91 | module Toploop2 = struct 92 | exception PPerror 93 | 94 | let phrase_buffer = Buffer.create 1024 95 | 96 | let loop () = 97 | let ppf = Format.std_formatter in 98 | Clflags.debug := true; 99 | Location.formatter_for_warnings := ppf; 100 | (* don't initialize the toplevel environment, as we don't want to clear bindings passed in *) 101 | let lb = Lexing.from_function Topcommon.refill_lexbuf in 102 | Location.init lb "//toplevel//"; 103 | Location.input_name := "//toplevel//"; 104 | Location.input_lexbuf := Some lb; 105 | Location.input_phrase_buffer := Some phrase_buffer; 106 | Sys.catch_break true; 107 | (* loading ocamlinit is done elsewhere *) 108 | try 109 | while true do 110 | let snap = Btype.snapshot () in 111 | try 112 | Lexing.flush_input lb; 113 | Buffer.reset phrase_buffer; 114 | Location.reset (); 115 | Warnings.reset_fatal (); 116 | Topcommon.first_line := true; 117 | let phr = 118 | try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror 119 | in 120 | let phr = Toploop.preprocess_phrase ppf phr in 121 | Env.reset_cache_toplevel (); 122 | ignore (Toploop.execute_phrase true ppf phr) 123 | with 124 | | Sys.Break -> 125 | Btype.backtrack snap; 126 | raise End_of_file 127 | | PPerror -> () 128 | | x -> 129 | Location.report_exception ppf x; 130 | Btype.backtrack snap 131 | done 132 | with End_of_file -> () 133 | 134 | (* modified to return all .ocamlinit files, in order *) 135 | let find_ocamlinit () = 136 | let exists_in_dir dir file = 137 | match dir with 138 | | None -> None 139 | | Some dir -> 140 | let file = Filename.concat dir file in 141 | if Sys.file_exists file then Some file else None 142 | in 143 | let home_dir () = Sys.getenv_opt "HOME" in 144 | let config_dir () = 145 | if Sys.win32 then None 146 | else 147 | match Sys.getenv_opt "XDG_CONFIG_HOME" with 148 | | Some _ as v -> v 149 | | None -> 150 | (match home_dir () with 151 | | None -> None 152 | | Some dir -> Some (Filename.concat dir ".config")) 153 | in 154 | let init_ml = Filename.concat "ocaml" "init.ml" in 155 | let ocamlinit = ".ocamlinit" in 156 | let local = if Sys.file_exists ocamlinit then [ocamlinit] else [] in 157 | let global = 158 | match exists_in_dir (config_dir ()) init_ml with 159 | | Some v -> [v] 160 | | None -> 161 | (match exists_in_dir (home_dir ()) ocamlinit with 162 | | Some v -> [v] 163 | | None -> []) 164 | in 165 | (* load global first, then local *) 166 | global @ local 167 | end 168 | 169 | let linenoise_prompt completion_words = 170 | let rec user_input prompt f = 171 | match LNoise.linenoise prompt with 172 | | None -> () 173 | | Some v -> 174 | f v; 175 | user_input prompt f 176 | in 177 | (* this goes from front-to-back, which is the right order, so more recent bindings are suggested first *) 178 | LNoise.set_hints_callback (fun inp -> 179 | match inp with 180 | | "" -> None 181 | | _ -> 182 | Option.bind 183 | (List.find_opt (String.starts_with ~prefix:inp) completion_words) 184 | (fun sugg -> 185 | let sl = String.length sugg in 186 | let il = String.length inp in 187 | if il < sl then 188 | let s = String.sub sugg il (sl - il) in 189 | Some (s, LNoise.White, false) 190 | else None)); 191 | LNoise.set_completion_callback (fun so_far ln_completions -> 192 | List.filter (String.starts_with ~prefix:so_far) completion_words 193 | |> List.iter (LNoise.add_completion ln_completions)); 194 | user_input "> " (fun s -> 195 | let s = String.trim s in 196 | let doesn't_end_with_semicolons s = 197 | let l = String.length s in 198 | l < 2 || String.sub s (l - 2) 2 <> ";;" 199 | in 200 | let s = if doesn't_end_with_semicolons s then s ^ ";;" else s in 201 | LNoise.history_add s |> ignore; 202 | (* LNoise.history_save ~filename:"history.txt" |> ignore; *) 203 | try eval ~show:true s 204 | with exn -> Location.report_exception Format.err_formatter exn) 205 | 206 | (** see https://github.com/ocaml-community/utop/blob/master/src/lib/uTop_main.ml *) 207 | let interact ?(search_path = []) ?(build_dir = "_build") ~unit 208 | ~loc:(fname, lnum, cnum, _) ?(init = []) ~values () = 209 | let verbose = Sys.getenv_opt "VERBOSE" |> Option.is_some in 210 | Toploop.initialize_toplevel_env (); 211 | let search_path = 212 | walk build_dir ~init:search_path ~f:(fun dir acc -> dir :: acc) 213 | in 214 | let cmt_fname = 215 | try Unstable.Misc.find_in_path_uncap search_path (unit ^ ".cmt") 216 | with Not_found -> 217 | Printf.ksprintf failwith "%s.cmt not found in search path!" unit 218 | in 219 | let cmt_infos = Cmt_format.read_cmt cmt_fname in 220 | let get_required_label name args = 221 | match List.find (fun (lab, _) -> lab = Asttypes.Labelled name) args with 222 | | _, x -> x 223 | | exception Not_found -> None 224 | in 225 | let expr next (e : Typedtree.expression) = 226 | match e.exp_desc with 227 | | Texp_apply (_, args) -> 228 | begin 229 | try 230 | match 231 | (get_required_label "loc" args, get_required_label "values" args) 232 | with 233 | | Some l, Some v -> 234 | let pos = l.exp_loc.loc_start in 235 | if 236 | pos.pos_fname = fname && pos.pos_lnum = lnum 237 | && pos.pos_cnum - pos.pos_bol = cnum 238 | then raise (Found v.exp_env) 239 | | _ -> next e 240 | with Not_found -> next e 241 | end 242 | | _ -> next e 243 | in 244 | let next iterator e = Tast_iterator.default_iterator.expr iterator e in 245 | let expr iterator = expr (next iterator) in 246 | let iter = { Tast_iterator.default_iterator with expr } in 247 | let search = iter.structure iter in 248 | try 249 | begin 250 | match cmt_infos.cmt_annots with 251 | | Implementation st -> search st 252 | | _ -> () 253 | end; 254 | failwith "Couldn't find location in cmt file" 255 | with Found env -> 256 | (try 257 | List.iter Topdirs.dir_directory (search_path @ Unstable.get_load_paths cmt_infos); 258 | let env = Envaux.env_of_only_summary env in 259 | List.iter 260 | (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) 261 | values; 262 | Toploop.toplevel_env := env; 263 | (* let idents = Env.diff Env.empty env in *) 264 | (* List.iter print_endline (List.map Ident.name idents); *) 265 | let names = List.map (fun (V (name, _)) -> name) values in 266 | 267 | List.iter 268 | (fun line -> 269 | try eval ~show:verbose line 270 | with exn -> 271 | Format.printf "initialization failed: %s@." line; 272 | Location.report_exception Format.err_formatter exn) 273 | init; 274 | 275 | List.iter 276 | (fun oi -> 277 | let ic = open_in oi in 278 | let s = really_input_string ic (in_channel_length ic) in 279 | begin 280 | try eval ~show:verbose s with 281 | | End_of_file -> () 282 | | exn -> Location.report_exception Format.err_formatter exn 283 | end; 284 | close_in_noerr ic; 285 | if verbose then Format.printf "Loaded %s@." oi) 286 | (Toploop2.find_ocamlinit ()); 287 | 288 | let use_linenoise = 289 | Option.is_some (Sys.getenv_opt "NO_DOWN") 290 | || 291 | try 292 | Load_path.find "down.top" |> ignore; 293 | Toploop.use_file Format.std_formatter "down.top" |> not 294 | with Not_found -> true 295 | in 296 | 297 | (* eval "b;;"; *) 298 | (* eval "let c = b + 1;;"; *) 299 | (* let v : int = Obj.obj (Toploop.getvalue "c") in *) 300 | (* Format.printf "v = %d@." v; *) 301 | match use_linenoise with 302 | | false -> Toploop2.loop () 303 | | true -> linenoise_prompt names 304 | with exn -> 305 | Location.report_exception Format.err_formatter exn; 306 | exit 2) 307 | --------------------------------------------------------------------------------