├── .gitignore ├── .ocamlformat ├── LICENSE ├── Makefile ├── config.json ├── demo ├── app │ ├── app.ml │ └── dune ├── debug │ ├── debug.ml │ ├── dune │ └── repl.ml └── lib │ ├── dune │ ├── lib.ml │ └── other.ml ├── docs ├── docs.md └── insertion-sort.png ├── dune-project ├── ppx_debug.opam ├── ppx_debug ├── dune └── ppx_debug.ml ├── ppx_debug_common.opam ├── ppx_debug_common ├── dune ├── instrument.ml ├── interpret_cmt.ml ├── log.ml ├── pp.ml ├── ppx_debug_common.ml ├── unstable.cppo.ml └── unstable.mli ├── ppx_debug_interact.opam ├── ppx_debug_interact ├── dune └── ppx_debug_interact.ml ├── ppx_debug_runtime.opam ├── ppx_debug_runtime ├── chrome_trace.ml ├── config.ml ├── dune ├── main.ml ├── ppx_debug_runtime.ml └── trace.ml ├── ppx_debug_tool.opam ├── ppx_debug_tool ├── dune └── ppx_debug_tool.ml ├── readme.md └── test ├── dune ├── pp.expected ├── pp ├── dune └── pp.ml ├── test.expected └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.trace 4 | *.json 5 | debug1 6 | ppx_interact 7 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | export OCAMLRUNPARAM=b 3 | export PPX_DEBUG=$(shell cat config.json) 4 | #export PPX_DEBUG=$(shell jq -c < config.json) 5 | 6 | .PHONY: all 7 | all: 8 | dune test 9 | rm /tmp/ppx_debug* debugger.json chrome.json *.trace > /dev/null 2>&1 || true 10 | 11 | dune exec ./demo/app/app.exe 12 | dune exec ./demo/debug/debug.exe -- trace debug.trace > chrome.json 13 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f debugger > debugger.json 14 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f calls | head -n 6 15 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f tree | head -n 6 16 | 17 | ls chrome.json debugger.json *.trace /tmp/ppx_debug* || true 18 | 19 | .PHONY: debug 20 | debug: all 21 | dune exec ./demo/debug/repl.bc -- repl debug.trace -i 6 22 | -------------------------------------------------------------------------------- /config.json: -------------------------------------------------------------------------------- 1 | { 2 | "should_instrument": true, 3 | "instrument_modules": ".*", 4 | "instrument_functions": ".*", 5 | "do_not_instrument_functions": " ", 6 | "file": "debug.trace", 7 | "randomize_filename": false, 8 | "ppx_logging": true, 9 | "internal_log": "/tmp/ppx_debug.txt", 10 | "internal_tool_log": "/tmp/ppx_debug_tool.txt", 11 | "should_instrument_lambdas": true, 12 | "should_instrument_matches": true, 13 | "should_instrument_calls": true, 14 | "should_instrument_definitions": true, 15 | "should_not_instrument_definitions": [], 16 | "variant": ["Stdlib"], 17 | "mappings": {}, 18 | "opaque_type_names": [], 19 | "libraries": ["demo/lib"], 20 | "cmt_ignored_directories": [] 21 | } 22 | -------------------------------------------------------------------------------- /demo/app/app.ml: -------------------------------------------------------------------------------- 1 | let () = Lib.main () 2 | -------------------------------------------------------------------------------- /demo/app/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name app) 4 | (libraries lib) 5 | (preprocess (pps ppx_deriving.show))) 6 | 7 | (env 8 | (dev 9 | (flags 10 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /demo/debug/debug.ml: -------------------------------------------------------------------------------- 1 | [%%generate print_value] 2 | 3 | let () = Ppx_debug_runtime.Main.main ~print_value () 4 | -------------------------------------------------------------------------------- /demo/debug/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name debug) 4 | (modules debug) 5 | (libraries lib) 6 | (preprocessor_deps (env_var PPX_DEBUG) (source_tree ../lib) 7 | ; for development only; not needed in a real project 8 | (source_tree ../../ppx_debug) 9 | (source_tree ../../ppx_debug_tool) 10 | (source_tree ../../ppx_debug_common) 11 | ; end development 12 | ) 13 | (preprocess (pps ppx_debug_tool))) 14 | 15 | (executable 16 | (name repl) 17 | (modules repl) 18 | (libraries lib ppx_debug_interact) 19 | (modes native byte) 20 | (link_flags -linkall) 21 | (preprocessor_deps (env_var PPX_DEBUG) (source_tree ../lib) 22 | ; for development only; not needed in a real project 23 | (source_tree ../../ppx_debug) 24 | (source_tree ../../ppx_debug_tool) 25 | (source_tree ../../ppx_debug_common) 26 | ; end development 27 | ) 28 | (preprocess (pps ppx_debug_tool))) 29 | 30 | (env 31 | (dev 32 | (flags 33 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /demo/debug/repl.ml: -------------------------------------------------------------------------------- 1 | [%%generate print_value] 2 | 3 | let () = Ppx_debug_interact.main ~print_value () -------------------------------------------------------------------------------- /demo/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lib) 3 | (preprocessor_deps (env_var PPX_DEBUG)) 4 | (preprocess (pps ppx_debug ppx_deriving.show))) 5 | 6 | (env 7 | (dev 8 | (flags 9 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /demo/lib/lib.ml: -------------------------------------------------------------------------------- 1 | let rec fib n = 2 | match n with _ when n <= 0 -> 1 | _ -> fib (n - 1) + fib (n - 2) 3 | 4 | let rec fact n = match n with _ when n <= 0 -> 1 | _ -> n * fact (n - 1) 5 | 6 | type 'a tree = 7 | | Leaf of int 8 | | Node of 'a tree list 9 | [@@deriving show { with_path = false }] 10 | 11 | let rec depth t = 12 | match t with 13 | | Leaf _ -> 0 14 | | Node sub -> List.fold_right (fun c t -> max (depth c) t) sub 0 + 1 15 | 16 | let c f = f 1 17 | let sum xs = List.fold_right (fun c t -> c + t) xs 0 18 | let rec sum2 xs acc = match xs with [] -> acc | x :: xs -> sum2 xs (x + acc) 19 | 20 | (* this is so Other can be referenced through Lib *) 21 | module Other = Other 22 | 23 | let abstr_type (t : Other.Abstr.t) = t 24 | let prv_type (t : Other.Priv.t) = t 25 | let consume (t : Other.misc) = match t with Misc a -> a 26 | 27 | let rec insert x xs = 28 | match xs with 29 | | [] -> [(x : int)] 30 | | y :: ys -> if x < y then x :: y :: ys else y :: insert x ys 31 | 32 | let rec sort xs = 33 | match xs with [] -> ([] : int list) | x :: xs -> insert x (sort xs) 34 | 35 | let shuffle d = 36 | let nd = List.map (fun c -> (Random.bits (), c)) d in 37 | let sond = List.sort compare nd in 38 | (List.map snd sond : int list) 39 | 40 | let main () = 41 | Random.self_init (); 42 | let z = Node [Node [Leaf 1]; Leaf 2] in 43 | consume (Misc 1) |> ignore; 44 | depth z |> ignore; 45 | fact 5 |> ignore; 46 | fib 3 |> ignore; 47 | c (fun x -> x + 1) |> ignore; 48 | sum [1; 2; 3] |> ignore; 49 | sum2 [1; 2; 3] 0 |> ignore; 50 | sort (List.init 10 (fun i -> i) |> shuffle) |> ignore; 51 | abstr_type (Other.Abstr.of_int 1) |> ignore; 52 | prv_type (Other.Priv.of_int 1) |> ignore 53 | -------------------------------------------------------------------------------- /demo/lib/other.ml: -------------------------------------------------------------------------------- 1 | type misc = Misc of int [@@deriving show { with_path = false }] 2 | 3 | let func a = match a with Misc b -> b 4 | let get () = Misc 1 5 | 6 | module Int = struct 7 | type t = int 8 | 9 | let of_int x = x 10 | let to_int x = x 11 | let pp = Format.pp_print_int 12 | end 13 | 14 | module Priv : sig 15 | type t = private int 16 | 17 | val of_int : int -> t 18 | val to_int : t -> int 19 | val pp : Format.formatter -> t -> unit 20 | end = 21 | Int 22 | 23 | module Abstr : sig 24 | type t 25 | 26 | val of_int : int -> t 27 | val to_int : t -> int 28 | val pp : Format.formatter -> t -> unit 29 | end = 30 | Int 31 | -------------------------------------------------------------------------------- /docs/docs.md: -------------------------------------------------------------------------------- 1 | 2 | - [Getting started](#getting-started) 3 | - [The demo project](#the-demo-project) 4 | - [How do I use this in my project?](#how-do-i-use-this-in-my-project) 5 | - [Tips, FAQs, and known issues](#tips-faqs-and-known-issues) 6 | - [Other approaches](#other-approaches) 7 | - [Project structure](#project-structure) 8 | - [Bootstrapping](#bootstrapping) 9 | 10 | # Getting started 11 | 12 | Check out the links in the [readme](../readme.md) if you haven't already. 13 | 14 | We'll start by building ppx_debug, running tests, then running it on the demo project. 15 | 16 | ```sh 17 | git clone git@github.com:dariusf/ppx_debug.git 18 | cd ppx_debug 19 | opam install . --deps-only 20 | make 21 | ``` 22 | 23 | What just happened? We built, instrumented, and ran the demo project, and a record of its execution was written to the file debug.trace. If you peek inside it, you'll see that it contains binary data -- marshalled OCaml values. 24 | 25 | Several commands were then run to interpret this binary file and export it to various formats. 26 | 27 | Two of them, *calls* and *tree*, are human-readable. 28 | 29 | *calls* shows one function invocation per line, with inputs and outputs, ordering calls before their children. 30 | 31 | ```sh 32 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f calls | head -n 6 33 | 1 demo/lib/lib.ml:40 main = () 34 | 6 demo/lib/lib.ml:25 consume (t: (Misc 1)) = 1 35 | 13 demo/lib/lib.ml:11 depth (t: (Node [(Node [(Leaf 1)]); (Leaf 2)])) = 2 36 | 18 demo/lib/lib.ml:14 _lambda (c: (Leaf 2)), (t: 0) = 0 37 | 21 demo/lib/lib.ml:11 depth (t: (Leaf 2)) = 0 38 | 26 demo/lib/lib.ml:14 _lambda (c: (Node [(Leaf 1)])), (t: 0) = 1 39 | ``` 40 | 41 | *tree* is a call tree, using indentation to indicate nesting 42 | 43 | ```sh 44 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f tree | head -n 6 45 | (1) demo/lib/lib.ml:40 main 46 | (6) demo/lib/lib.ml:25 consume (t: (Misc 1)) 47 | (6) demo/lib/lib.ml:25 consume = 1 48 | (13) demo/lib/lib.ml:11 depth (t: (Node [(Node [(Leaf 1)]); (Leaf 2)])) 49 | (18) demo/lib/lib.ml:14 _lambda (c: (Leaf 2)), (t: 0) 50 | (21) demo/lib/lib.ml:11 depth (t: (Leaf 2)) 51 | ``` 52 | 53 | The numbers are _timestamps_, which identify points in the execution and can be used to navigate to them. 54 | 55 | The other two files are the inputs to tools. 56 | 57 | ```sh 58 | dune exec ./demo/debug/debug.exe -- trace debug.trace > chrome.json 59 | dune exec ./demo/debug/debug.exe -- trace debug.trace -f debugger > debugger.json 60 | ``` 61 | 62 | chrome.json is the execution in [Chrome Trace Format](https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/preview), which can be read by [chrome://tracing](chrome://tracing), [Perfetto](https://ui.perfetto.dev/), or [magic-trace](https://magic-trace.org/). 63 | Try opening it in one of these tools! 64 | 65 | ![](insertion-sort.png) 66 | 67 | debugger.json can be read by an [editor plugin](https://github.com/dariusf/ppx_debug-vscode) to enable an experience like that of interactive debugger, where you can navigate freely in time through the execution. 68 | 69 | Try installing the VS Code plugin and stepping through the execution! 70 | 71 | https://user-images.githubusercontent.com/4328341/192141194-2ab66ece-6e52-4eb7-8623-c6ceb82afa32.mov 72 | 73 | A toplevel can also be opened at a given point in the execution, allowing interaction with values in context. This requires a bit of additional setup for now: 74 | 75 | ```sh 76 | git clone git@github.com:dariusf/ppx_interact.git 77 | make debug 78 | ``` 79 | 80 | which gives us 81 | 82 | ``` 83 | dune exec ./demo/debug/repl.bc -- repl debug.trace -i 6 84 | val t : Lib.Other.misc = Lib.Other.Misc 1 85 | val _res : int = 1 86 | > open Lib.Other 87 | > let (Misc x) = t 88 | val x : int = 1 89 | ``` 90 | 91 | The event at timestamp 6 is the call to the `consume` function. 92 | We're able to destructure the argument like any value, and even call `consume` with a modified argument. 93 | 94 | ``` 95 | > open Lib 96 | > consume (Misc 2) 97 | - : int = 2 98 | ``` 99 | 100 | # The demo project 101 | 102 | To understand how all of this is set up, we'll now walk through the demo project. 103 | 104 | ``` 105 | $ tree demo 106 | demo 107 | ├── app 108 | │   ├── app.ml 109 | │   └── dune 110 | ├── debug 111 | │   ├── debug.ml 112 | │   ├── dune 113 | │   └── repl.ml 114 | └── lib 115 | ├── dune 116 | ├── lib.ml 117 | └── other.ml 118 | 119 | 3 directories, 8 files 120 | ``` 121 | 122 | It consists of a library (`lib`) and three executables (`app`, `debug`, `repl`). 123 | 124 | `lib` is where interesting user code would live and contains the modules that will be [instrumented](demo/lib/dune) via the ppx `ppx_debug`, which reads configuration from the environment variable PPX_DEBUG. 125 | 126 | `app` is the [entry point](demo/app/app.ml) of the program and [depends on lib](demo/app/dune). It's the means of running the instrumented `lib`, which will produce a binary trace. No special setup is required here. 127 | 128 | `debug` is an executable we'll add which can read binary trace files. First, we'll need an ml file with [two lines of boilerplate](demo/debug/debug.ml) to serve as its entry point. Next is the [build setup](demo/debug/dune), which sees `debug` depending on `lib` both at compile-time and runtime, and using a _second_ ppx `ppx_debug_tool`. 129 | 130 | Why is it set up this way? `debug` reads the cmt files of `lib` during compilation via the ppx, to figure out which types and printers to use at runtime to unmarshal values in recorded executions. 131 | 132 | The final executable, `repl`, is the entry point for opening a toplevel. 133 | The only difference in setup from `debug` is that it is built in bytecode mode. 134 | When the native toplevel is released, we'll no longer need it to be separate. 135 | 136 | Finally, the Makefile demonstrates how to build the demo project. 137 | Notably it also reads the config file config.json and makes its contents available in the environment variable PPX_DEBUG. Configuration options are documented [here](ppx_debug_runtime/config.ml). 138 | 139 | Now you're ready to use this! Next is (a recap on) how to set up your own project with this. 140 | 141 | # How do I use this in my project? 142 | 143 | 1. Structure your project so the code to be instrumented lives in one or more [libraries](demo/lib). If your project is a ppx, create [a library that contains the AST transformations](ppx_debug_common) and use it in another [executable that contains the driver](ppx_debug). 144 | 2. Ensure your libraries satisfy the assumptions detailed below. 145 | 3. [Add the ppx](demo/lib/dune) to any libraries you want to instrument. 146 | 4. Create [an executable](demo/debug) for interpreting executions. 147 | 5. Try to [build](Makefile) your project with an initial configuration (e.g. only instrument function definitions, and only for one simple module), record a trace, and see if you are able to see the values of arguments. 148 | 6. Once this works, tweak the configuration until you're able to instrument all the important modules and get the data you need. 149 | 150 | In order for instrumentation to work well, a number of things are assumed: 151 | 152 | - Your project uses dune. 153 | - Only libraries need to be instrumented/debugged. 154 | - There are no top-level side effects in libraries. This is because the debug executable loads libraries to call their printers, and any unexpected side effects at this point could generate trace events, clobbering debug.trace before it can be read. This is also [good practice in general](https://erratique.ch/software/logs/doc/Logs/index.html#setupreporter). If you have modules which require initialization, a workaround is to initialize lazily in the library's entry point. 155 | - Printers for types are defined following ppx_deriving's conventions: `pp` for a type named `t`, and `pp_type` otherwise. 156 | - The printers of all types used in instrumented modules must be accessible from the library entry point. 157 | 158 | # Tips, FAQs, and known issues 159 | 160 | **How scalable is this?** 161 | 162 | Logging every single event that happens in a nontrivial program under large input likely will not work -- the program will run too slowly and the trace will be massive. 163 | 164 | However, doing this is unnecessary for practical use cases. 165 | When debugging, having an inkling of where a bug might be allows one to be selective about which modules are instrumented. Minimizing the input to reproduce a bug also will contribute to a reduction in trace size. 166 | When exploring new code, what matters is control flow, so one can disable the printing of values entirely but instrument calls and matches. 167 | 168 | In principle it should be possible to instrument _any_ project, so knobs are provided for all these purposes. 169 | 170 | Also, different views of executions scale differently. Interactive stepping and grepping for specific arguments can still work well even if an execution is too large to render in magic-trace. 171 | 172 | **Concurrency?** 173 | 174 | There is no support for this at the moment, but it would be nice to add. 175 | 176 | **Why not use the Common Trace Format?** 177 | 178 | That would be ideal. The present trace format is a simple prototype. 179 | 180 | **Why does the REPL not take calling context into account and give access to all variables lexically in scope, instead of just those in the current frame?** 181 | 182 | This is also planned. 183 | 184 | **Unbound module during compilation of the debug executable, with puzzling line number** 185 | 186 | Our heuristics are probably not good enough to figure out how to access a type from outside a library in your case. Improvements are being worked on, but for now, to see the types involved, check the generated code using `dune describe pp `, or "Show Preprocessed Document" in VS Code. It may be possible to move modules around so the heuristics kick in. If all else fails, manually specify how to access the type from outside the library using `mappings`. Contacting us about your problem would also help us improve the heuristics. 187 | 188 | **Stack overflow when interpreting large (200 MB) executions** 189 | 190 | This is due to the use of scanf and is being worked on. 191 | 192 | 193 | 194 | 195 | 196 | 197 | **Why doesn't the VS Code extension use the debugger UI?** 198 | 199 | There is partial support in the extension for using it, but I found it less flexible and more complex than the ad hoc keybindings and overlays in the demo video, which cause minimal changes to the state of the editor. It could certainly be revived or made the default if it turns out to be nicer. 200 | 201 | # Other approaches 202 | 203 | **How does this compare to...** 204 | 205 | - **`#trace`, printf?** Both of these are subsumed, though with a more heavyweight build pipeline. 206 | - **ocamldebug?** Reverse execution is really useful, but like other interactive debuggers, interactions are limited to what the debugger can actually make the running program do. For example, ocamldebug cannot evaluate arbitrary code, and users are constrained to navigation along the single timeline of the program's execution, instead of being able to get an overview like with e.g. `#trace`. 207 | - **logging, testing, tracing ([Runtime Events](https://github.com/sadiqj/runtime_events_tools))?** The crucial distinction between what these provide and the needs of users when debugging is that in the latter case, *the user does not know a priori which parts of the program are relevant*. 208 | - **dtrace, rr, lldb, gdb via [libmonda](https://github.com/mshinwell/libmonda)?** It would be ideal if these tools understood native OCaml code, as they are fully-fledged and mature, but they don't today, and it is a significant amount of work to get them there. The main advantage of source-level instrumentation is that it is easier to convince ourselves of the fidelity of recorded traces under compiler optimizations, compared to the mapping of native code back to source-level constructs that these tools would require. 209 | - **[ocamli](https://github.com/johnwhitington/ocamli), [Furukawa's stepper](https://arxiv.org/abs/1906.11422)?** Custom interpreters are another means of understanding executions, by being able to show actual sequences of reductions performed. They are a large undertaking, however, and both of these only support a subset of OCaml. This is fine for teaching, but not for debugging and exploring arbitrary projects. 210 | - **[magic-trace](https://github.com/janestreet/magic-trace), [Landmarks](https://github.com/LexiFi/landmarks)?** Landmarks does similar instrumentation, and both provide tools for viewing executions. They are more oriented towards performance bugs and do not show the values of arguments and such. 211 | - **runtime type representations?** There are several libraries for reflection and generic programming, e.g. [dyntype](https://github.com/samoht/dyntype) (2013), [lrt](https://github.com/LexiFi/lrt) (2020), [repr](https://github.com/mirage/repr), [typerep](https://github.com/janestreet/typerep), [refl](https://github.com/thierry-martinez/refl) (2022). Perhaps the only problem is that none of these are standard. Nevertheless, if you are able to use one of these in your project, there wouldn't be a need for the custom build. 212 | 213 | [viztracer](https://github.com/gaogaotiantian/viztracer) is a similar project for Python. 214 | 215 | # Project structure 216 | 217 | - ppx_debug_runtime: like in ppx_deriving, is required at runtime and should contain minimal dependencies 218 | - ppx_debug_common: depends on runtime, contains side-effect-free AST transformation code for the ppxes which can be instrumented when bootstrapping 219 | - ppx_debug, ppx_debug_tool: depend on common and build ppx drivers 220 | - ppx_debug_interact: integration with ppx_interact for opening toplevels, also kept separate instead of being combined with ppx_debug_runtime because then the latter would fail to build in native mode 221 | - test: tests for instrumentation 222 | 223 | # Bootstrapping 224 | 225 | ppx_debug can be run on itself: 226 | 227 | - Clone the main repo locally. Apply the patch in branch `bootstrap1` to rename the ppx (appending 1 to the end of all conflicting names, as programmers do). 228 | - Symlink the clone into the main repo under `debug1`. 229 | - Develop in the main repo's `master` 230 | - To test a change, check out `bootstrap` (which contains a patch to enable bootstrapping) and rebase it onto master. Have the clone pull changes from `master`, which will rebase its patch. Run tests. 231 | -------------------------------------------------------------------------------- /docs/insertion-sort.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dariusf/ppx_debug/f5d51b29d5e466601c0f861e3fd7431ca6e5aa4a/docs/insertion-sort.png -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | 3 | (name ppx_debug) 4 | (generate_opam_files true) 5 | 6 | (source 7 | (github dariusf/ppx_debug)) 8 | 9 | (authors "Darius Foo") 10 | 11 | (maintainers "darius.foo.tw@gmail.com") 12 | 13 | (package 14 | (name ppx_debug) 15 | (version 0.1) 16 | (synopsis "A ppx for debugging") 17 | (description "Debug away") 18 | (depends 19 | (ppx_debug_runtime (= 0.1)))) 20 | 21 | (package 22 | (name ppx_debug_tool) 23 | (version 0.1) 24 | (synopsis "A ppx for debugging") 25 | (description "Debug away") 26 | (depends 27 | (ppx_debug_runtime (= 0.1)))) 28 | 29 | (package 30 | (name ppx_debug_runtime) 31 | (version 0.1) 32 | (synopsis "A ppx for debugging") 33 | (description "Debug away") 34 | (depends 35 | (cmdliner (>= 1.1.1)) 36 | (yojson (>= 1.7.0)) 37 | (linenoise (>= 1.3.1)))) 38 | 39 | (package 40 | (name ppx_debug_common) 41 | (version 0.1) 42 | (synopsis "A ppx for debugging") 43 | (description "Debug away") 44 | (depends 45 | (ppx_deriving_yojson (>= 3.6.1)) 46 | (ppx_deriving (>= 5.2.1)) 47 | (ppx_expect (>= v0.15.0)) 48 | (ppxlib (>= 0.25.0)) 49 | (containers (>= 3.7)))) 50 | 51 | (package 52 | (name ppx_debug_interact) 53 | (version 0.1) 54 | (synopsis "A ppx for debugging") 55 | (description "Debug away") 56 | (depends 57 | (ppx_debug_runtime (= 0.1)))) 58 | -------------------------------------------------------------------------------- /ppx_debug.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "A ppx for debugging" 5 | description: "Debug away" 6 | maintainer: ["darius.foo.tw@gmail.com"] 7 | authors: ["Darius Foo"] 8 | homepage: "https://github.com/dariusf/ppx_debug" 9 | bug-reports: "https://github.com/dariusf/ppx_debug/issues" 10 | depends: [ 11 | "dune" {>= "3.0"} 12 | "ppx_debug_runtime" {= "0.1"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/dariusf/ppx_debug.git" 30 | -------------------------------------------------------------------------------- /ppx_debug/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_debug) 3 | (kind ppx_rewriter) 4 | ; some code (config) is used at both compile- and runtime. 5 | ; the runtime library will always be available anyway. 6 | (libraries ppx_debug_common ppxlib containers) 7 | (ppx_runtime_libraries ppx_debug_runtime) 8 | (inline_tests) 9 | (preprocess 10 | (pps ppx_deriving.show ppx_expect))) 11 | 12 | (env 13 | (dev 14 | (flags 15 | (:standard -warn-error -A)))) 16 | -------------------------------------------------------------------------------- /ppx_debug/ppx_debug.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Config = Ppx_debug_runtime.Config 3 | 4 | let log = Ppx_debug_common.Instrument.log 5 | 6 | let () = 7 | let config = Config.read () in 8 | log "%a" Config.pp config; 9 | if not config.Config.should_instrument then 10 | log "not transforming: disabled via config" 11 | else 12 | Driver.register_transformation 13 | ~instrument: 14 | (Driver.Instrument.V2.make 15 | (fun ctxt s -> 16 | let cp = Expansion_context.Base.code_path ctxt in 17 | let filename = Code_path.file_path cp in 18 | let modname = Code_path.main_module_name cp in 19 | (* let file = 20 | match s with 21 | | [] -> failwith "nothing to translate" 22 | | { pstr_loc; _ } :: _ -> pstr_loc.loc_start.pos_fname 23 | in *) 24 | (* file *) 25 | Ppx_debug_common.Instrument.process filename modname config s) 26 | ~position:After) 27 | "ppx_debug" 28 | -------------------------------------------------------------------------------- /ppx_debug_common.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "A ppx for debugging" 5 | description: "Debug away" 6 | maintainer: ["darius.foo.tw@gmail.com"] 7 | authors: ["Darius Foo"] 8 | homepage: "https://github.com/dariusf/ppx_debug" 9 | bug-reports: "https://github.com/dariusf/ppx_debug/issues" 10 | depends: [ 11 | "dune" {>= "3.0"} 12 | "ppx_deriving_yojson" {>= "3.6.1"} 13 | "ppx_deriving" {>= "5.2.1"} 14 | "ppx_expect" {>= "v0.15.0"} 15 | "ppxlib" {>= "0.25.0"} 16 | "containers" {>= "3.7"} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/dariusf/ppx_debug.git" 34 | -------------------------------------------------------------------------------- /ppx_debug_common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_debug_common) 3 | (public_name ppx_debug_common) 4 | (libraries ppxlib containers ppx_debug_runtime str) 5 | (inline_tests) 6 | (preprocess (pps ppxlib.metaquot ppx_deriving.show ppx_deriving_yojson ppx_expect))) 7 | 8 | (rule 9 | (targets unstable.ml) 10 | (deps unstable.cppo.ml) 11 | (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) 12 | 13 | (env 14 | (dev 15 | (flags 16 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /ppx_debug_common/instrument.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | open Ppxlib 3 | module Config = Ppx_debug_runtime.Config 4 | 5 | module L = Log.Make (struct 6 | let name = (Config.read ()).internal_log 7 | end) 8 | 9 | let log = L.log 10 | let p_si si = Format.printf "structure_item %a@." Pprintast.structure_item si 11 | let p_s s = Format.printf "structure %a@." Pprintast.structure s 12 | let p_e e = Format.printf "expression %a@." Pprintast.expression e 13 | let p_p p = Format.printf "pattern %a@." Pprintast.pattern p 14 | let p_t t = Format.printf "type %a@." Pprintast.core_type t 15 | 16 | module A = Ast_builder.Default 17 | 18 | (* thrown when we can't transform this function for legitimate reasons *) 19 | exception NotTransforming of string 20 | 21 | let not_transforming fmt = 22 | Format.ksprintf ?margin:None ~f:(fun s -> raise (NotTransforming s)) fmt 23 | 24 | let fresh = 25 | let n = ref 0 in 26 | fun () -> 27 | let r = !n in 28 | incr n; 29 | r 30 | 31 | let fresh_v () = Format.sprintf "v%d" (fresh ()) 32 | let self_name = "_self" 33 | let lambda_name = "_lambda" 34 | let aux_fn_name = "aux__" 35 | 36 | type label = arg_label * expression option 37 | 38 | type param = { 39 | name : string; 40 | ignored : bool; 41 | label : label; 42 | pattern : pattern; 43 | call : arg_label * expression; 44 | } 45 | 46 | type func = { 47 | name : string; 48 | params : param list; 49 | body : expression; 50 | loc : location; 51 | } 52 | 53 | let get_fn_name pat = 54 | match pat with 55 | | { ppat_desc = Ppat_var { txt = fn_name; _ }; _ } -> fn_name 56 | | { 57 | ppat_desc = 58 | Ppat_constraint ({ ppat_desc = Ppat_var { txt = fn_name; _ }; _ }, _); 59 | _; 60 | } -> 61 | fn_name 62 | | _ -> not_transforming "%a is not a function pattern" Pprintast.pattern pat 63 | 64 | let normalize_fn f : func = 65 | let name = lambda_name in 66 | let loc = match f with { pexp_loc = loc; _ } -> loc in 67 | let rec aux f = 68 | match f with 69 | | { pexp_desc = Pexp_fun (lbl, lbl_e, arg_pat, rest); _ } -> 70 | let { ppat_desc = desc; ppat_loc = loc; _ } = arg_pat in 71 | let label = (lbl, lbl_e) in 72 | let func = aux rest in 73 | begin 74 | match desc with 75 | | Ppat_var { txt = name; _ } 76 | | Ppat_constraint ({ ppat_desc = Ppat_var { txt = name; _ }; _ }, _) -> 77 | (* the usual case *) 78 | let call = 79 | let lab = 80 | match (lbl, lbl_e) with 81 | | Optional s, Some _ -> Labelled s 82 | | _ -> lbl 83 | in 84 | (lab, A.pexp_ident ~loc { loc; txt = Lident name }) 85 | in 86 | let param = 87 | { name; label; ignored = false; pattern = arg_pat; call } 88 | in 89 | { func with params = param :: func.params } 90 | | Ppat_construct ({ txt = Lident "()"; _ }, None) -> 91 | (* ignore unit *) 92 | let call = 93 | (Nolabel, A.pexp_construct ~loc { loc; txt = Lident "()" } None) 94 | in 95 | let param = 96 | { name = "()"; label; ignored = true; pattern = arg_pat; call } 97 | in 98 | { func with params = param :: func.params } 99 | | Ppat_any -> 100 | let name = "_" ^ fresh_v () in 101 | let call = 102 | let lab = 103 | match (lbl, lbl_e) with 104 | | Optional s, Some _ -> Labelled s 105 | | _ -> lbl 106 | in 107 | (lab, A.pexp_ident ~loc { loc; txt = Lident name }) 108 | in 109 | let param = 110 | (* generate a name in the pattern *) 111 | { 112 | name; 113 | label; 114 | ignored = false; 115 | pattern = A.ppat_var ~loc { txt = name; loc }; 116 | call; 117 | } 118 | in 119 | { func with params = param :: func.params } 120 | | _ -> { body = f; params = []; name; loc } 121 | end 122 | | { pexp_desc = Pexp_constraint (e, _); _ } -> 123 | (* this is lossy. losing the constraint may change types *) 124 | aux e 125 | | _ -> 126 | (* this is incomplete for cases with e.g. wildcards inside constructors that then have to be reconstructed *) 127 | log "did not fully normalize non-function %a" Pprintast.expression f; 128 | { body = f; params = []; name; loc } 129 | in 130 | aux f 131 | 132 | (** somewhat-inverse of traverse_fn *) 133 | let rec build_fn ({ loc; params; body; _ } as func) = 134 | match params with 135 | | [] -> body 136 | | { label = lbl, lbl_e; pattern; _ } :: ps -> 137 | A.pexp_fun ~loc lbl lbl_e pattern (build_fn { func with params = ps }) 138 | 139 | let transform_fn_body f e = 140 | let func = normalize_fn e in 141 | build_fn { func with body = f func.body } 142 | 143 | let has_attr name attr = 144 | match attr with 145 | | { attr_name = Loc.{ txt = n; _ }; _ } when String.equal n name -> true 146 | | _ -> false 147 | 148 | let is_function_binding b = 149 | match b with 150 | | { pvb_expr = { pexp_desc = Pexp_fun _; _ }; _ } -> true 151 | | _ -> false 152 | 153 | let interesting_expr_binding rec_flag attrs binding = 154 | let has_attribute = 155 | match rec_flag with 156 | | Nonrecursive -> 157 | if List.exists (has_attr "tracerec") attrs then 158 | failwith "tracerec used on nonrecursive binding" 159 | else List.exists (has_attr "trace") attrs 160 | | Recursive -> 161 | List.exists (has_attr "trace") attrs 162 | || List.exists (has_attr "tracerec") attrs 163 | in 164 | has_attribute && is_function_binding binding 165 | 166 | let interesting_str_binding rec_flag binding = 167 | let attrs = binding.pvb_attributes in 168 | interesting_expr_binding rec_flag attrs binding 169 | 170 | let extract_binding_info b = 171 | let { pvb_pat = original_lhs; pvb_expr = original_rhs; _ } = b in 172 | let fn_name = get_fn_name original_lhs in 173 | let func = normalize_fn original_rhs in 174 | { func with name = fn_name } 175 | 176 | let replace_calls find replace = 177 | object 178 | inherit Ast_traverse.map as super 179 | 180 | method! expression expr = 181 | let expr = super#expression expr in 182 | (* only replace unqualified names, as those are more likely to be calls *) 183 | (* TODO this is not capture-avoiding *) 184 | match expr with 185 | | { pexp_desc = Pexp_ident { txt = Lident fn_name; loc }; _ } 186 | when String.equal fn_name find -> 187 | A.pexp_ident ~loc { txt = Lident replace; loc } 188 | | _ -> expr 189 | end 190 | 191 | let mangle fn_name = fn_name ^ "_original" 192 | let ident ~loc s = A.pexp_ident ~loc { txt = Lident s; loc } 193 | 194 | let qualified_ident ~loc ss = 195 | match ss with 196 | | [] -> failwith "qualified_ident requires a non-empty list" 197 | | [s] -> ident ~loc s 198 | | s :: ss -> 199 | let res = List.fold_left (fun t c -> Ldot (t, c)) (Lident s) ss in 200 | A.pexp_ident ~loc { txt = res; loc } 201 | 202 | let rec fun_wildcards ~loc n body = 203 | match n with 204 | | 0 -> body 205 | | _ -> 206 | A.pexp_fun ~loc Nolabel None (A.ppat_any ~loc) 207 | (fun_wildcards ~loc (n - 1) body) 208 | 209 | let app ~loc f args = 210 | A.pexp_apply ~loc f (List.map (fun a -> (Nolabel, a)) args) 211 | 212 | let str ~loc s = A.pexp_constant ~loc (Pconst_string (s, loc, None)) 213 | 214 | let rec show_longident l = 215 | match l with 216 | | Lident s -> s 217 | | Ldot (l, s) -> show_longident l ^ s 218 | | Lapply (a, b) -> 219 | Format.sprintf "apply %s %s" (show_longident a) (show_longident b) 220 | 221 | module Longident = struct 222 | include Longident 223 | 224 | let pp fmt l = Format.fprintf fmt "%s" (show_longident l) 225 | end 226 | 227 | type ptype = 228 | | PType of Longident.t * ptype list 229 | | PTuple of ptype list 230 | | PPoly of string 231 | | PPolyVariant 232 | [@@deriving show] 233 | 234 | let rec arrow_to_list t = 235 | match t.ptyp_desc with 236 | | Ptyp_poly (_, t) -> arrow_to_list t 237 | | Ptyp_constr ({ txt = name; _ }, params) -> 238 | [PType (name, List.concat_map arrow_to_list params)] 239 | | Ptyp_var name -> [PPoly name] 240 | | Ptyp_arrow (_, a, b) -> arrow_to_list a @ arrow_to_list b 241 | | Ptyp_tuple params -> [PTuple (params |> List.concat_map arrow_to_list)] 242 | | Ptyp_variant (_, _, _) -> [PPolyVariant] 243 | | _ -> 244 | p_t t; 245 | failwith "could not convert arrow to list" 246 | 247 | let interpret_type t = 248 | let a = arrow_to_list t in 249 | let l = List.length a in 250 | match l with 251 | | 0 -> failwith "empty type" 252 | | 1 -> failwith "not a function" 253 | | _ -> 254 | (* List.sub.arrow_to_list t *) 255 | let a, b = List.take_drop (l - 1) a in 256 | (a, List.hd b) 257 | 258 | (* for now, we get ppx_debug_file by reading the environment, but removing that allows users to configure it through changing source *) 259 | let generate_value ~loc cu v = 260 | [%expr 261 | let ppx_debug_file = Ppx_debug_runtime.Config.(get_file (read ())) in 262 | Ppx_debug_runtime.Trace.emit_value ~ppx_debug_file 263 | ~ppx_debug_id: 264 | { 265 | file = [%e A.estring ~loc cu]; 266 | id = [%e A.eint ~loc (fresh ())]; 267 | loc = 268 | ( ( [%e A.eint ~loc loc.loc_start.pos_lnum], 269 | [%e 270 | A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)] 271 | ), 272 | ( [%e A.eint ~loc loc.loc_end.pos_lnum], 273 | [%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)] ) 274 | ); 275 | } 276 | [%e A.estring ~loc v] 277 | [%e A.pexp_ident ~loc { loc; txt = Lident v }]] 278 | 279 | let generate_event ~loc cu typ name v = 280 | [%expr 281 | let ppx_debug_file = Ppx_debug_runtime.Config.(get_file (read ())) in 282 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 283 | ~ppx_debug_id: 284 | { 285 | file = [%e A.estring ~loc cu]; 286 | id = [%e A.eint ~loc (fresh ())]; 287 | loc = 288 | ( ( [%e A.eint ~loc loc.loc_start.pos_lnum], 289 | [%e 290 | A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)] 291 | ), 292 | ( [%e A.eint ~loc loc.loc_end.pos_lnum], 293 | [%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)] ) 294 | ); 295 | } 296 | [%e A.estring ~loc typ] [%e A.estring ~loc name] [%e v]] 297 | 298 | let generate_arg ~loc cu arg = 299 | [%expr 300 | let ppx_debug_file = Ppx_debug_runtime.Config.(get_file (read ())) in 301 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 302 | ~ppx_debug_id: 303 | { 304 | file = [%e A.estring ~loc cu]; 305 | id = [%e A.eint ~loc (fresh ())]; 306 | loc = 307 | ( ( [%e A.eint ~loc loc.loc_start.pos_lnum], 308 | [%e 309 | A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)] 310 | ), 311 | ( [%e A.eint ~loc loc.loc_end.pos_lnum], 312 | [%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)] ) 313 | ); 314 | } 315 | [%e A.estring ~loc arg] 316 | [%e A.pexp_ident ~loc { loc; txt = Lident arg }]] 317 | 318 | let generate_start ~loc cu what = 319 | [%expr 320 | let ppx_debug_file = Ppx_debug_runtime.Config.(get_file (read ())) in 321 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 322 | ~ppx_debug_id: 323 | { 324 | file = [%e A.estring ~loc cu]; 325 | id = [%e A.eint ~loc (fresh ())]; 326 | loc = 327 | ( ( [%e A.eint ~loc loc.loc_start.pos_lnum], 328 | [%e 329 | A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)] 330 | ), 331 | ( [%e A.eint ~loc loc.loc_end.pos_lnum], 332 | [%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)] ) 333 | ); 334 | } 335 | ~func:[%e A.estring ~loc what]] 336 | 337 | let generate_end ~loc cu what = 338 | [%expr 339 | let ppx_debug_file = Ppx_debug_runtime.Config.(get_file (read ())) in 340 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 341 | ~ppx_debug_id: 342 | { 343 | file = [%e A.estring ~loc cu]; 344 | id = [%e A.eint ~loc (fresh ())]; 345 | loc = 346 | ( ( [%e A.eint ~loc loc.loc_start.pos_lnum], 347 | [%e 348 | A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)] 349 | ), 350 | ( [%e A.eint ~loc loc.loc_end.pos_lnum], 351 | [%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)] ) 352 | ); 353 | } 354 | ~func:[%e A.estring ~loc what]] 355 | 356 | let run_invoc modname (config : Config.t) filename fn_expr func = 357 | let loc = func.loc in 358 | let start = generate_start ~loc filename func.name in 359 | let stop = generate_end ~loc filename func.name in 360 | let print_params = 361 | func.params 362 | |> List.filter_map (fun { name; ignored; _ } -> 363 | if ignored then None else Some (generate_arg ~loc filename name)) 364 | in 365 | let print_params = 366 | if 367 | (not config.should_instrument_definitions) 368 | || List.exists 369 | (fun (m, f) -> 370 | Str.string_match (Str.regexp m) modname 0 371 | && Str.string_match (Str.regexp f) func.name 0) 372 | config.should_not_instrument_definitions 373 | then [%expr ()] 374 | else List.fold_right (A.pexp_sequence ~loc) print_params [%expr ()] 375 | in 376 | let call_fn = 377 | A.pexp_apply ~loc fn_expr (func.params |> List.map (fun { call; _ } -> call)) 378 | in 379 | let print_res = 380 | if 381 | (not config.should_instrument_definitions) 382 | || List.exists 383 | (fun (m, f) -> 384 | Str.string_match (Str.regexp m) modname 0 385 | && Str.string_match (Str.regexp f) func.name 0) 386 | config.should_not_instrument_definitions 387 | then [%expr ()] 388 | else generate_arg ~loc filename "_res" 389 | in 390 | [%expr 391 | [%e start]; 392 | [%e print_params]; 393 | let _res = [%e call_fn] in 394 | [%e print_res]; 395 | [%e stop]; 396 | _res] 397 | 398 | let check_should_transform_module config modname = 399 | let mwl = Str.regexp config.Config.instrument_modules in 400 | if not (Str.string_match mwl modname 0) then 401 | not_transforming "%s is not in module whitelist" modname 402 | 403 | let check_should_transform_fn config fn = 404 | (* built-in blacklist. don't instrument printers and some generated code that can be identified syntactically *) 405 | if List.mem ~eq:String.equal fn ["pp"; "show"] then 406 | not_transforming "%s is a printer or generated" fn; 407 | if 408 | List.exists 409 | (fun prefix -> String.starts_with ~prefix fn) 410 | [ 411 | "pp_"; 412 | "show_"; 413 | (* ppx_deriving generates functions like __0 for printer arguments *) 414 | "__"; 415 | ] 416 | then not_transforming "%s is a printer or generated" fn; 417 | 418 | let fwl = Str.regexp config.Config.instrument_functions in 419 | let fbl = Str.regexp config.Config.do_not_instrument_functions in 420 | 421 | if not (Str.string_match fwl fn 0) then 422 | not_transforming "%s is not in function whitelist" fn; 423 | if Str.string_match fbl fn 0 then 424 | not_transforming "%s is not in function blacklist" fn 425 | 426 | let nonrecursive_rhs modname config filename func = 427 | let loc = func.loc in 428 | let func = 429 | { 430 | func with 431 | body = 432 | A.pexp_let ~loc Nonrecursive 433 | [ 434 | Ast_builder.Default.value_binding ~loc 435 | ~pat:(A.ppat_var ~loc { txt = mangle func.name; loc }) 436 | ~expr:(build_fn func); 437 | ] 438 | (run_invoc modname config filename 439 | (ident ~loc (mangle func.name)) 440 | func); 441 | } 442 | in 443 | build_fn func 444 | 445 | let transform_bound_func_nonrecursively config modname filename func = 446 | check_should_transform_fn config func.name; 447 | let func = 448 | { 449 | func with 450 | body = (replace_calls func.name (mangle func.name))#expression func.body; 451 | } 452 | in 453 | let new_rhs1 = nonrecursive_rhs modname config filename func in 454 | new_rhs1 455 | 456 | let transform_binding_nonrecursively config modname filename b = 457 | let func = extract_binding_info b in 458 | let new_rhs1 = 459 | transform_bound_func_nonrecursively config modname filename func 460 | in 461 | [{ b with pvb_expr = new_rhs1 }] 462 | 463 | let transform_binding_recursively modname config filename b = 464 | let loc = b.pvb_loc in 465 | let func = extract_binding_info b in 466 | check_should_transform_fn config func.name; 467 | let original_fn_body, loc = 468 | let body = (replace_calls func.name self_name)#expression func.body in 469 | let self = 470 | { 471 | name = self_name; 472 | label = (Nolabel, None); 473 | ignored = false; 474 | pattern = A.ppat_var ~loc { loc; txt = self_name }; 475 | call = (Nolabel, A.pexp_ident ~loc { loc; txt = Lident self_name }); 476 | } 477 | in 478 | (build_fn { func with body; params = self :: func.params }, func.loc) 479 | in 480 | 481 | (* the entire new rhs *) 482 | let new_rhs1 = 483 | let aux = ident ~loc aux_fn_name in 484 | let run = 485 | run_invoc modname config filename 486 | [%expr [%e ident ~loc (mangle func.name)] [%e aux]] 487 | func 488 | in 489 | let ps1 = func.params |> List.map (fun { call; _ } -> call) in 490 | build_fn 491 | { 492 | func with 493 | body = 494 | A.pexp_let ~loc Nonrecursive 495 | [ 496 | Ast_builder.Default.value_binding ~loc 497 | ~pat:(A.ppat_var ~loc { txt = mangle func.name; loc }) 498 | ~expr:original_fn_body; 499 | ] 500 | (A.pexp_let ~loc Recursive 501 | [ 502 | Ast_builder.Default.value_binding ~loc 503 | ~pat:(A.ppat_var ~loc { txt = aux_fn_name; loc }) 504 | ~expr:(build_fn { func with body = run }); 505 | ] 506 | (A.pexp_apply ~loc aux ps1)); 507 | } 508 | in 509 | 510 | [{ b with pvb_expr = new_rhs1 }] 511 | 512 | let all_function_bindings bs = 513 | let rec is_func e = 514 | match e.pexp_desc with 515 | | Pexp_fun _ | Pexp_function _ -> true 516 | | Pexp_constraint (e, _) -> 517 | (* (let f : t = fun x -> x) is actually (let f = ((fun x -> x) : t)) *) 518 | is_func e 519 | | _ -> false 520 | in 521 | List.for_all (fun b -> is_func b.pvb_expr) bs 522 | 523 | let transform_bindings modname filename config rec_flag bindings = 524 | if not (all_function_bindings bindings) then 525 | not_transforming "not all right sides are functions. left sides: %s" 526 | (List.map 527 | (fun b -> Format.asprintf "%a" Pprintast.pattern b.pvb_pat) 528 | bindings 529 | |> String.concat ","); 530 | match rec_flag with 531 | | Recursive -> 532 | List.concat_map 533 | (fun b -> transform_binding_recursively modname config filename b) 534 | bindings 535 | | Nonrecursive -> 536 | List.concat_map 537 | (fun b -> transform_binding_nonrecursively config modname filename b) 538 | bindings 539 | 540 | let truncate s = if String.length s > 10 then String.sub s 0 10 ^ "..." else s 541 | 542 | (** This looks for bindings in expression and structure contexts: 543 | 544 | let f x = 1 545 | 546 | let f x = 1 in 547 | b 548 | 549 | When we find such bindings, we first recurse in the body (1) to handle 550 | nested let expressions and lambdas. Then we try to transform the current 551 | binding; this may fail if e.g. it doesn't bind a function. 552 | 553 | *) 554 | let traverse modname filename config = 555 | object (self) 556 | inherit Ast_traverse.map (* _with_expansion_context *) as super 557 | 558 | method handle_method cf = 559 | match cf with 560 | | { pcf_desc = Pcf_method ({ txt = name; _ }, _, Cfk_virtual _); _ } -> 561 | not_transforming "virtual method %s" name 562 | | { 563 | pcf_desc = 564 | Pcf_method 565 | (({ txt = name; _ } as ident), priv, Cfk_concrete (over, mrhs)); 566 | _; 567 | } -> 568 | (* check_should_transform_fn config name; *) 569 | begin 570 | match mrhs with 571 | | { pexp_desc = Pexp_poly (fn, otyp); _ } -> 572 | (* figure out the function name from the method *) 573 | let func = { (normalize_fn fn) with name } in 574 | (* recursively transform only the body -- transforming the function itself would do the work twice *) 575 | let func = { func with body = self#expression func.body } in 576 | let e1 = 577 | transform_bound_func_nonrecursively config modname filename func 578 | in 579 | { 580 | cf with 581 | pcf_desc = 582 | Pcf_method 583 | ( ident, 584 | priv, 585 | Cfk_concrete 586 | (over, { mrhs with pexp_desc = Pexp_poly (e1, otyp) }) ); 587 | } 588 | | { pexp_desc = Pexp_fun _; _ } -> 589 | let func = { (normalize_fn mrhs) with name } in 590 | let func = { func with body = self#expression func.body } in 591 | let e1 = 592 | transform_bound_func_nonrecursively config modname filename func 593 | in 594 | { 595 | cf with 596 | pcf_desc = Pcf_method (ident, priv, Cfk_concrete (over, e1)); 597 | } 598 | | e -> 599 | log "unhandled %s: %a %a" name Pp.debug_pexpr e Pprintast.expression 600 | e; 601 | (* this is not exposed by ppxlib apparently *) 602 | (* log "unhandled Pcf_method: %a" (Ocaml_common.Printast.expression 0) e; *) 603 | cf 604 | end 605 | (* | { pcf_desc = Pcf_method (_, _, Cfk_concrete (_, e)); _ } -> *) 606 | | { pcf_desc = desc; _ } -> 607 | let name = 608 | match desc with 609 | | Pcf_inherit (_, _, _) -> "Pcf_inherit" 610 | | Pcf_val _ -> "Pcf_val" 611 | | Pcf_method _ -> 612 | failwith "Pcf_method should already have been handled" 613 | | Pcf_constraint _ -> "Pcf_constraint" 614 | | Pcf_initializer _ -> "Pcf_initializer" 615 | | Pcf_attribute _ -> "Pcf_attribute" 616 | | Pcf_extension _ -> "Pcf_extension" 617 | in 618 | log "unhandled: %s" name; 619 | cf 620 | 621 | method! expression e = 622 | match e with 623 | | { 624 | pexp_desc = 625 | Pexp_extension 626 | ( { txt = "trace"; _ }, 627 | PStr 628 | [ 629 | { 630 | pstr_desc = 631 | Pstr_eval 632 | ( { pexp_desc = Pexp_ident { txt = Lident id; _ }; _ }, 633 | _attrs ); 634 | _; 635 | }; 636 | ] ); 637 | pexp_loc = loc; 638 | _; 639 | } -> 640 | generate_value ~loc filename id 641 | | { pexp_desc = Pexp_match (scr, cases); _ } 642 | when config.Config.should_instrument_matches -> 643 | let loc = scr.pexp_loc in 644 | let matched = 645 | truncate (Format.asprintf "%a" Pprintast.expression scr) 646 | in 647 | let scr = self#expression scr in 648 | let cases = 649 | List.map 650 | (fun c -> 651 | { 652 | c with 653 | pc_guard = Option.map self#expression c.pc_guard; 654 | pc_rhs = 655 | (let rhs1 = self#expression c.pc_rhs in 656 | let loc = rhs1.pexp_loc in 657 | [%expr 658 | [%e 659 | generate_event ~loc filename "matchb" "matchb" 660 | (str ~loc matched)]; 661 | [%e rhs1]]); 662 | }) 663 | cases 664 | in 665 | let scr = 666 | A.pexp_sequence ~loc 667 | (generate_event ~loc filename "match" 668 | (* this can be extremely large, and also contain output *) 669 | matched scr) 670 | scr 671 | in 672 | { e with pexp_desc = Pexp_match (scr, cases) } 673 | | { pexp_desc = Pexp_apply (f, args); pexp_loc = loc; _ } 674 | when config.Config.should_instrument_calls -> 675 | (* TODO these aren't perfect as they may hit the beginnings/ends of lines *) 676 | (* they are also unintuitive *) 677 | (* let bloc = 678 | { 679 | loc with 680 | loc_end = 681 | { loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 1 }; 682 | } 683 | in 684 | let aloc = 685 | { 686 | loc with 687 | loc_start = { loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - 1 }; 688 | } 689 | in *) 690 | let before = 691 | generate_event ~loc filename "bcall" "bcall" [%expr "(before)"] 692 | in 693 | let after = 694 | generate_event ~loc filename "acall" "acall" [%expr "(after)"] 695 | in 696 | (* recurse *) 697 | let e = 698 | { 699 | e with 700 | pexp_desc = 701 | Pexp_apply 702 | ( self#expression f, 703 | List.map (fun (l, a) -> (l, self#expression a)) args ); 704 | } 705 | in 706 | [%expr 707 | [%e before]; 708 | let result__ = [%e e] in 709 | [%e after]; 710 | result__] 711 | | { pexp_desc = Pexp_fun _; _ } 712 | when config.Config.should_instrument_lambdas -> 713 | let func = normalize_fn e in 714 | (* TODO name more uniquely *) 715 | if CCEqual.physical func.body e then 716 | (* TODO skip transforming if we can't handle this, instead of going into a loop. 717 | the problem is the lossy param repr we use. 718 | normalize_fn should be guaranteed to return a smaller expression. *) 719 | e 720 | else 721 | let func = { func with body = self#expression func.body } in 722 | nonrecursive_rhs modname config filename func 723 | | { pexp_desc = Pexp_let (rec_flag, bindings, body); pexp_loc = loc; _ } 724 | -> 725 | let bindings = 726 | List.map 727 | (fun b -> 728 | try 729 | let func = extract_binding_info b in 730 | check_should_transform_fn config func.name; 731 | { 732 | b with 733 | pvb_expr = transform_fn_body self#expression b.pvb_expr; 734 | } 735 | with NotTransforming _ -> b) 736 | bindings 737 | in 738 | let body = self#expression body in 739 | (* rebuild this in case we end up not transforming the binding *) 740 | let e = { e with pexp_desc = Pexp_let (rec_flag, bindings, body) } in 741 | begin 742 | try 743 | { 744 | e with 745 | pexp_desc = 746 | Pexp_let 747 | ( rec_flag, 748 | transform_bindings modname filename config rec_flag bindings, 749 | body ); 750 | } 751 | with 752 | | NotTransforming s -> 753 | log "not transforming: %s" s; 754 | e 755 | | Failure s -> 756 | A.pexp_extension ~loc (Location.error_extensionf ~loc "%s" s) 757 | end 758 | | { pexp_desc = Pexp_object cls; _ } -> 759 | let ms = List.map self#handle_method cls.pcstr_fields in 760 | { e with pexp_desc = Pexp_object { cls with pcstr_fields = ms } } 761 | | _ -> super#expression e 762 | 763 | method! structure_item si = 764 | match si with 765 | | { pstr_desc = Pstr_value (rec_flag, bindings); pstr_loc = loc; _ } -> 766 | let bindings = 767 | List.map 768 | (fun b -> 769 | try 770 | let func = extract_binding_info b in 771 | check_should_transform_fn config func.name; 772 | { 773 | b with 774 | pvb_expr = transform_fn_body self#expression b.pvb_expr; 775 | } 776 | with NotTransforming _ -> b) 777 | bindings 778 | in 779 | (* rebuild this in case we end up not transforming the binding *) 780 | let si = { si with pstr_desc = Pstr_value (rec_flag, bindings) } in 781 | (* handle mutual recursion *) 782 | let flag = match bindings with [_] -> Nonrecursive | _ -> rec_flag in 783 | begin 784 | try 785 | let r = 786 | A.pstr_value ~loc flag 787 | (transform_bindings modname filename config rec_flag bindings) 788 | in 789 | r 790 | with 791 | | NotTransforming s -> 792 | log "not transforming: %s" s; 793 | si 794 | | Failure s -> 795 | A.pstr_extension ~loc (Location.error_extensionf ~loc "%s" s) [] 796 | (* A.pstr_value ~loc Nonrecursive 797 | [ 798 | A.value_binding ~loc ~pat:(A.ppat_any ~loc) 799 | ~expr:; 800 | ] *) 801 | end 802 | | { pstr_desc = Pstr_class cdecls; pstr_loc = loc; _ } -> 803 | let transform_class_structure cstr = 804 | match cstr with 805 | | Pcl_structure c_str -> 806 | Pcl_structure 807 | { 808 | c_str with 809 | pcstr_fields = List.map self#handle_method c_str.pcstr_fields; 810 | } 811 | | _ -> 812 | let constr = 813 | match cstr with 814 | | Pcl_structure _ -> 815 | failwith "Pcl_structure should already have been handled" 816 | | Pcl_constr (_, _) -> "Pcl_constr" 817 | | Pcl_fun (_, _, _, _) -> "Pcl_fun " 818 | | Pcl_apply (_, _) -> "Pcl_apply " 819 | | Pcl_let (_, _, _) -> "Pcl_let " 820 | | Pcl_constraint (_, _) -> "Pcl_constraint " 821 | | Pcl_extension _ -> "Pcl_extension " 822 | | Pcl_open (_, _) -> "_Pcl_open " 823 | in 824 | log "unhandled: %s" constr; 825 | cstr 826 | in 827 | let handle_si si = 828 | let cdecls = 829 | List.map 830 | (fun cdecl -> 831 | { 832 | cdecl with 833 | pci_expr = 834 | { 835 | cdecl.pci_expr with 836 | pcl_desc = 837 | transform_class_structure cdecl.pci_expr.pcl_desc; 838 | }; 839 | }) 840 | cdecls 841 | in 842 | { si with pstr_desc = Pstr_class cdecls } 843 | in 844 | begin 845 | try handle_si si with 846 | | NotTransforming s -> 847 | log "not transforming: %s" s; 848 | si 849 | | Failure s -> 850 | A.pstr_extension ~loc (Location.error_extensionf ~loc "%s" s) [] 851 | end 852 | | _ -> super#structure_item si 853 | end 854 | 855 | let process file modname config str = 856 | try 857 | check_should_transform_module config modname; 858 | (traverse modname file config)#structure str 859 | with NotTransforming s -> 860 | log "not transforming structure: %s" s; 861 | str 862 | -------------------------------------------------------------------------------- /ppx_debug_common/interpret_cmt.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | module Config = Ppx_debug_runtime.Config 3 | 4 | module L = Log.Make (struct 5 | let name = (Config.read ()).internal_tool_log 6 | end) 7 | 8 | let log = L.log 9 | 10 | (* we're not in ppxlib, because we're accessing the typedtree, which likely is out of scope. 11 | we probably aren't protected against breakage as well. *) 12 | open Ocaml_common 13 | module A = Ppxlib.Ast_builder.Default 14 | module C = Ppx_debug_runtime.Config 15 | 16 | let p_t expr = 17 | Format.printf "%a@." Pprintast.expression (Untypeast.untype_expression expr) 18 | 19 | module Id = Ppx_debug_runtime.Trace.Id 20 | 21 | type typ_info = { 22 | (* if none, it's a type we can't unmarshal *) 23 | typ : Ppxlib.core_type option; 24 | pp_fn : Ppxlib.expression; 25 | } 26 | 27 | let id_type_mappings : (Id.t * typ_info) list ref = ref [] 28 | let p_te t = Format.printf "type %a@." Printtyp.type_expr t 29 | 30 | open Result.Infix 31 | 32 | let with_ctx m res = 33 | match res with Error s -> Error (Format.asprintf "%s: %s" m s) | Ok _ -> res 34 | 35 | module LR = List.Traverse (struct 36 | type 'a t = ('a, string) result 37 | 38 | let return = Result.return 39 | let ( >>= ) = Result.( >>= ) 40 | end) 41 | 42 | let relativize ~against path = 43 | let regexp = Str.regexp (Format.asprintf {|^\(%s\)/?\(.*\)|} against) in 44 | Str.string_match regexp path 0 |> ignore; 45 | try Some (Str.matched_group 2 path) with Invalid_argument _ -> None 46 | 47 | let file_to_module = 48 | let dot_ml = Str.regexp {|\.ml|} in 49 | let slash = Str.regexp {|/|} in 50 | fun path -> 51 | let res = 52 | List.map String.capitalize_ascii 53 | (path |> Str.global_replace dot_ml "" |> Str.split slash) 54 | in 55 | match List.rev res with 56 | | a :: b :: c when String.equal a b -> List.rev (b :: c) 57 | | _ -> res 58 | 59 | let%expect_test _ = 60 | let show a = a |> [%derive.show: string option] |> print_endline in 61 | relativize ~against:"demo/lib" "demo/lib/lib.ml" |> show; 62 | relativize ~against:"a" "demo/lib/lib.ml" |> show; 63 | relativize ~against:"demo/lib/" "demo/lib/lib.ml" |> show; 64 | let show a = a |> [%derive.show: string list] |> print_endline in 65 | file_to_module "demo/lib/other.ml" |> show; 66 | file_to_module "demo/lib/lib.ml" |> show; 67 | file_to_module "lib.ml" |> show; 68 | [%expect 69 | {| 70 | (Some "lib.ml") 71 | None 72 | (Some "lib.ml") 73 | ["Demo"; "Lib"; "Other"] 74 | ["Demo"; "Lib"] 75 | ["Lib"] 76 | |}] 77 | 78 | let rec path_to_lident p = 79 | match p with 80 | | Path.Pdot (p, s) -> Longident.Ldot (path_to_lident p, s) 81 | | Pident i -> Lident (Ident.name i) 82 | | Papply _ -> failwith "no correspondence" 83 | 84 | let flatten_path p = 85 | match Path.flatten p with 86 | | `Ok (h, xs) -> Ident.name h :: xs 87 | | `Contains_apply -> failwith "does not work with apply" 88 | 89 | let path_to_s p = flatten_path p |> String.concat "." 90 | let demangle modname = List.concat_map (String.split ~by:"__") modname 91 | 92 | let mnl_to_lident modname = 93 | match modname with 94 | | [] -> failwith "modname cannot be empty" 95 | | m :: ms -> List.fold_left Ppxlib.(fun t c -> Ldot (t, c)) (Lident m) ms 96 | 97 | let first_matching f xs = 98 | List.fold_left (fun t c -> match t with None -> f c | Some _ -> t) None xs 99 | 100 | (* pp because show is non-compositional. 101 | file and qual are for the current compilation unit, i.e. where exp_type is used. 102 | *) 103 | let rec printer_and_type = 104 | let variant = (C.read ()).variant in 105 | fun ~loc env file modname exp_type -> 106 | (* undo the mangling dune does to get a path we can refer to values with *) 107 | let normal_type ?(args = []) name = 108 | A.ptyp_constr ~loc { txt = Ppxlib.Lident name; loc } args 109 | in 110 | let handle_result a b = 111 | (* TODO *) 112 | (* can't use this as it specializes the second arg to string *) 113 | (* (match containers with 114 | | true -> 115 | [%expr Result.pp [%e generate_printer_typ a] [%e generate_printer_typ b]] 116 | | _ -> *) 117 | let pp_a, ta = printer_and_type ~loc env file modname a in 118 | let pp_b, tb = printer_and_type ~loc env file modname b in 119 | ( Ppxlib.([%expr Format.pp_print_result ~ok:[%e pp_a] ~error:[%e pp_b]]), 120 | let* ta = 121 | with_ctx 122 | (Format.asprintf "type for %a failed" Ppxlib.Pprintast.expression 123 | pp_a) 124 | ta 125 | in 126 | let+ tb = 127 | with_ctx 128 | (Format.asprintf "type for %a failed" Ppxlib.Pprintast.expression 129 | pp_b) 130 | tb 131 | in 132 | normal_type ~args:[ta; tb] "result" ) 133 | (* ) *) 134 | in 135 | match Types.get_desc exp_type with 136 | | Tconstr (Pident ident, _, _) when String.equal (Ident.name ident) "int" -> 137 | ( Ppxlib.( 138 | match variant with 139 | | Containers -> [%expr CCInt.pp] 140 | | Stdlib -> [%expr Format.pp_print_int]), 141 | Ok (normal_type "int") ) 142 | | Tconstr (Pident ident, _, _) when String.equal (Ident.name ident) "char" 143 | -> 144 | ( Ppxlib.( 145 | match variant with 146 | | Containers -> [%expr CCChar.pp] 147 | | Stdlib -> [%expr Format.pp_print_char]), 148 | Ok (normal_type "char") ) 149 | | Tconstr (Pident ident, _, _) when String.equal (Ident.name ident) "float" 150 | -> 151 | ( (match variant with 152 | | Containers -> [%expr CCFloat.pp] 153 | | Stdlib -> [%expr Format.pp_print_float]), 154 | Ok (normal_type "float") ) 155 | | Tconstr (Pident ident, _, _) when String.equal (Ident.name ident) "bool" 156 | -> 157 | ( (match variant with 158 | | Containers -> [%expr CCString.pp] 159 | | Stdlib -> [%expr Format.pp_print_bool]), 160 | Ok (normal_type "bool") ) 161 | | Tconstr (Pident ident, _, _) when String.equal (Ident.name ident) "string" 162 | -> 163 | ( (match variant with 164 | | Containers -> [%expr CCString.pp] 165 | | Stdlib -> [%expr Format.pp_print_string]), 166 | Ok (normal_type "string") ) 167 | | Tconstr (Pident ident, [a], _) 168 | when String.equal (Ident.name ident) "option" -> 169 | let pp_a, ta = printer_and_type ~loc env file modname a in 170 | ( (match variant with 171 | | Containers -> [%expr CCOpt.pp [%e pp_a]] 172 | | Stdlib -> [%expr Format.pp_print_option [%e pp_a]]), 173 | let+ ta in 174 | normal_type ~args:[ta] "option" ) 175 | | Tconstr (Pident ident, [a; b], _) 176 | when String.equal (Ident.name ident) "result" -> 177 | handle_result a b 178 | | Tconstr (Pdot (Pident q, "result"), [a; b], _) 179 | when String.equal (Ident.name q) "Stdlib" -> 180 | handle_result a b 181 | | Tconstr (Pident ident, [a], _) when String.equal (Ident.name ident) "list" 182 | -> 183 | let pp_a, ta = printer_and_type ~loc env file modname a in 184 | ( (match variant with 185 | | Containers -> 186 | [%expr 187 | CCList.pp 188 | ~pp_start:(fun fmt () -> Format.fprintf fmt "[") 189 | ~pp_stop:(fun fmt () -> Format.fprintf fmt "]") 190 | ~pp_sep:(fun fmt () -> Format.fprintf fmt ";") 191 | [%e pp_a]] 192 | | Stdlib -> 193 | [%expr 194 | fun fmt xs -> 195 | Format.fprintf fmt "["; 196 | Format.pp_print_list 197 | ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") 198 | [%e pp_a] fmt xs; 199 | Format.fprintf fmt "]"]), 200 | let+ ta in 201 | normal_type ~args:[ta] "list" ) 202 | | Tconstr (Pident ident, [], _) when String.equal (Ident.name ident) "unit" 203 | -> 204 | ([%expr fun fmt () -> Format.fprintf fmt "()"], Ok (normal_type "unit")) 205 | | Tconstr (id, args, _) -> guess_named_type loc env file modname id args 206 | | Tvar v -> 207 | ( [%expr fun fmt _ -> Format.fprintf fmt ""], 208 | Ok (A.ptyp_var ~loc (v |> Option.get_or ~default:"a")) ) 209 | | Tarrow _ -> 210 | ([%expr fun fmt _ -> Format.fprintf fmt ""], Error "function") 211 | | Ttuple _ -> 212 | (* TODO *) 213 | ([%expr fun fmt _ -> Format.fprintf fmt ""], Error "tuple") 214 | | _ -> 215 | ( [%expr fun fmt _ -> Format.fprintf fmt ""], 216 | Error "unimplemented" ) 217 | 218 | and guess_named_type = 219 | let library_entrypoints = (C.read ()).libraries in 220 | fun loc env use_file use_modname id args -> 221 | let mappings = 222 | C.SMap.find_opt use_file (C.read ()).mappings 223 | |> Option.get_or ~default:C.SMap.empty 224 | in 225 | let opaque_regexes = (C.read ()).opaque_type_names |> List.map Str.regexp in 226 | match id with 227 | | _ 228 | when List.exists 229 | (fun r -> Str.string_match r (path_to_s id) 0) 230 | opaque_regexes 231 | || 232 | match C.SMap.find_opt (path_to_s id) mappings with 233 | | Some Opaque -> true 234 | | _ -> false -> 235 | log "opaque %s %b %b" (path_to_s id) 236 | (List.exists 237 | (fun r -> Str.string_match r (path_to_s id) 0) 238 | opaque_regexes) 239 | (match C.SMap.find_opt (path_to_s id) mappings with 240 | | Some Opaque -> true 241 | | _ -> false); 242 | ([%expr fun fmt _ -> Format.fprintf fmt ""], Error "opaque type") 243 | | _ -> 244 | let get_pp_name typ = match typ with "t" -> "pp" | _ -> "pp_" ^ typ in 245 | let qualifier, ident_name = 246 | (* figure out where some type is defined, then use that to point to the right printer *) 247 | let typdecl = Env.find_type id env in 248 | let decl_filename = typdecl.type_loc.loc_start.pos_fname in 249 | let def_prefix = 250 | match 251 | library_entrypoints 252 | |> first_matching (fun le -> 253 | match relativize ~against:le decl_filename with 254 | | None -> None 255 | | Some def_file -> 256 | (* assume that all path segments but the last are the directory hierarchy *) 257 | let e = file_to_module (Filename.basename le) in 258 | let m = file_to_module def_file in 259 | (* example: le = demo/lib, def_file = other.ml, e = Lib, m = Other *) 260 | (* if these are equal, e.g. Lib = Lib, we assume the use and def are in the same module, 261 | which must also be the entrypoint *) 262 | if List.equal String.equal e m then Some e else Some (e @ m)) 263 | with 264 | | None -> file_to_module use_file 265 | | Some p -> p 266 | in 267 | log "def_prefix: %a, id: %a" (List.pp String.pp) def_prefix Path.print 268 | id; 269 | let qual = mnl_to_lident def_prefix in 270 | let new1 = 271 | match id with 272 | | Path.Pdot (q, ident) -> 273 | ( List.fold_left 274 | (fun t c -> 275 | (* TODO heuristic. say a type is in demo/lib/other.ml, 276 | and we refer to the type as Other.Abstr.t. 277 | this drops Other, so we keep the internal module ref, 278 | which isn't apparent from filename. *) 279 | (* TODO can the cmt give us this? *) 280 | if not (List.mem ~eq:String.equal c def_prefix) then 281 | Longident.Ldot (t, c) 282 | else t) 283 | qual (flatten_path q), 284 | ident ) 285 | | Pident ident -> (qual, Ident.name ident) 286 | | _ -> failwith "not applicable" 287 | in 288 | log "new1: %a" (Pair.pp Pprintast.longident String.pp) new1; 289 | new1 290 | in 291 | log 292 | "printer name: (use_file = %s, use_modname = %a, id = %a) -guess-> \ 293 | (qualifier = %a, ident_name = %s)" 294 | use_file (List.pp String.pp) use_modname Path.print id 295 | Pprintast.longident qualifier ident_name; 296 | let printer = 297 | A.pexp_ident ~loc 298 | { loc; txt = Ldot (qualifier, get_pp_name ident_name) } 299 | in 300 | let tident args = 301 | A.ptyp_constr ~loc { loc; txt = Ldot (qualifier, ident_name) } args 302 | in 303 | (match args with 304 | | [] -> (printer, Ok (tident [])) 305 | | _ :: _ -> 306 | let p_args = 307 | List.map 308 | (fun a -> printer_and_type ~loc env use_file use_modname a) 309 | args 310 | in 311 | let p_args, types = List.split p_args in 312 | let p_args = p_args |> List.map (fun a -> (Ppxlib.Nolabel, a)) in 313 | let types = LR.sequence_m types in 314 | ( A.pexp_apply ~loc printer p_args, 315 | let* types in 316 | Ok (tident types) )) 317 | 318 | let handle_expr use_modname it expr = 319 | let loc = expr.Typedtree.exp_loc in 320 | match expr.Typedtree.exp_desc with 321 | | Texp_apply 322 | ( { 323 | exp_desc = 324 | Texp_ident 325 | ( _, 326 | { 327 | txt = Ldot (Ldot (Lident "Ppx_debug_runtime", "Trace"), name); 328 | _; 329 | }, 330 | _ ); 331 | _; 332 | }, 333 | args ) 334 | when String.equal name "emit_value" 335 | || String.equal name "emit_argument" 336 | || String.equal name "emit_raw" -> 337 | let site_id = 338 | args 339 | |> List.filter_map (function 340 | | Asttypes.Labelled "ppx_debug_id", Some tuple -> 341 | begin 342 | match tuple.Typedtree.exp_desc with 343 | | Texp_record 344 | { 345 | fields = 346 | [| 347 | ( _, 348 | Overridden 349 | ( _file, 350 | { 351 | exp_desc = 352 | Texp_constant (Const_string (file, _, _)); 353 | _; 354 | } ) ); 355 | ( _, 356 | Overridden 357 | ( _id, 358 | { exp_desc = Texp_constant (Const_int id); _ } ) 359 | ); 360 | ( _, 361 | Overridden 362 | ( _loc, 363 | { 364 | exp_desc = 365 | Texp_tuple 366 | [ 367 | { 368 | exp_desc = 369 | Texp_tuple 370 | [ 371 | { 372 | exp_desc = 373 | Texp_constant (Const_int sl); 374 | _; 375 | }; 376 | { 377 | exp_desc = 378 | Texp_constant (Const_int sc); 379 | _; 380 | }; 381 | ]; 382 | _; 383 | }; 384 | { 385 | exp_desc = 386 | Texp_tuple 387 | [ 388 | { 389 | exp_desc = 390 | Texp_constant (Const_int el); 391 | _; 392 | }; 393 | { 394 | exp_desc = 395 | Texp_constant (Const_int ec); 396 | _; 397 | }; 398 | ]; 399 | _; 400 | }; 401 | ]; 402 | _; 403 | } ) ); 404 | |]; 405 | _; 406 | } -> 407 | Some Id.{ file; id; loc = ((sl, sc), (el, ec)) } 408 | | _ -> 409 | (* this shouldn't happen as we're only expecting a triple here (generated by ppx_debug), but it's possible the pattern in the last branch is wrong/too strict *) 410 | p_t tuple; 411 | failwith "expecting a triple as argument to ppx_debug_id" 412 | end 413 | | _ -> None) 414 | |> List.head_opt 415 | |> Option.get_exn_or "no ppx_debug_id argument" 416 | in 417 | let exp_type = 418 | let e = 419 | args |> List.last_opt 420 | |> Option.get_exn_or "no arguments?" 421 | |> snd 422 | |> Option.get_exn_or "last argument had no value" 423 | in 424 | e.exp_type 425 | in 426 | let env = expr.exp_env in 427 | let pp_fn, typ = 428 | printer_and_type ~loc env site_id.file use_modname exp_type 429 | in 430 | log "file = %s, id = %d -> exp_type = %a | pp_fn = %a | typ = %a" 431 | site_id.file site_id.id Printtyp.type_expr exp_type 432 | Ppxlib.Pprintast.expression pp_fn 433 | (Result.pp Ppxlib.Pprintast.core_type) 434 | typ; 435 | let typ = Result.to_opt typ in 436 | id_type_mappings := (site_id, { pp_fn; typ }) :: !id_type_mappings 437 | | _ -> Tast_iterator.default_iterator.expr it expr 438 | 439 | let walk_build_dir () = 440 | assert (Filename.check_suffix (Sys.getcwd ()) "_build/default"); 441 | let should_process s = 442 | List.for_all 443 | (fun dir -> not (String.mem ~sub:dir s)) 444 | (C.read ()).cmt_ignored_directories 445 | in 446 | IO.File.walk_seq "." 447 | |> Seq.iter (function 448 | | `File, s when String.ends_with ~suffix:"cmt" s && should_process s -> 449 | let cmt = Cmt_format.read_cmt s in 450 | Unstable.Load_path.init cmt.cmt_loadpath; 451 | let modname = cmt.cmt_modname |> String.split ~by:"." in 452 | let str = 453 | match cmt.cmt_annots with 454 | | Implementation str -> 455 | let map = 456 | { 457 | Tast_mapper.default with 458 | env = (fun _ env -> Envaux.env_of_only_summary env); 459 | } 460 | in 461 | let str = map.structure map str in 462 | str 463 | | _ -> failwith "not a cmt file" 464 | in 465 | 466 | let iter_structure = 467 | Tast_iterator.( 468 | default_iterator.structure 469 | { default_iterator with expr = handle_expr modname }) 470 | in 471 | iter_structure str 472 | | `File, f when String.ends_with ~suffix:"cmt" f -> 473 | log "did not process %s" f 474 | | `File, _ -> () 475 | | `Dir, _ -> ()) 476 | 477 | open Ppxlib 478 | 479 | let str ~loc s = A.pexp_constant ~loc (Pconst_string (s, loc, None)) 480 | 481 | let g_print_value loc = 482 | let cases = 483 | A.pexp_match ~loc [%expr id] 484 | ((!id_type_mappings 485 | |> List.map (fun (Id.{ file; id; _ }, typ_info) -> 486 | let show_arg = 487 | match typ_info.typ with 488 | | None -> 489 | (* i.e. always work *) 490 | [%expr Marshal.from_string _content 0] 491 | | Some typ -> 492 | [%expr (Marshal.from_string _content 0 : [%t typ])] 493 | in 494 | A.case 495 | ~lhs: 496 | [%pat? 497 | Ppx_debug_runtime.Id. 498 | { 499 | file = [%p A.pstring ~loc file]; 500 | id = [%p A.pint ~loc id]; 501 | _; 502 | }] 503 | ~guard:None 504 | ~rhs: 505 | [%expr 506 | Format.asprintf "%a" [%e typ_info.pp_fn] [%e show_arg], 507 | [%e 508 | str ~loc 509 | (Format.asprintf "%a" Pprintast.expression show_arg)]]) 510 | ) 511 | @ [ 512 | A.case 513 | ~lhs:[%pat? Ppx_debug_runtime.Id.{ file; id; _ }] 514 | ~guard:None 515 | ~rhs:[%expr failwith (Format.sprintf "unknown type %s %d" file id)]; 516 | ]) 517 | in 518 | (* not sure why we have to prefix file with an underscore, or the compiler thinks it's unused *) 519 | let read = 520 | [%expr fun id (Ppx_debug_runtime.Trace.Bytestr _content) -> [%e cases]] 521 | in 522 | [%stri let print_value = [%e read]] 523 | 524 | let handle_si ~loc ~path:_ payload = 525 | walk_build_dir (); 526 | match payload with 527 | | PStr 528 | [ 529 | { 530 | pstr_desc = 531 | Pstr_eval 532 | ({ pexp_desc = Pexp_ident { txt = Lident s; _ }; _ }, _attrs); 533 | _; 534 | }; 535 | ] -> 536 | begin 537 | match s with 538 | | "print_value" -> g_print_value loc 539 | | _ -> failwith ("no such generator: " ^ s) 540 | end 541 | | _ -> failwith "invalid payload" 542 | -------------------------------------------------------------------------------- /ppx_debug_common/log.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | 3 | (* logging the low-tech way *) 4 | 5 | module Config = Ppx_debug_runtime.Config 6 | 7 | module Make (S : sig 8 | val name : string 9 | end) = 10 | struct 11 | let logfile = ref None 12 | 13 | let log fmt = 14 | let lf = 15 | match !logfile with 16 | | None -> 17 | let l = IO.File.make S.name in 18 | logfile := Some l; 19 | l 20 | | Some l -> l 21 | in 22 | Format.kasprintf 23 | (fun s -> 24 | if (Config.read ()).ppx_logging then IO.File.append_exn lf (s ^ "\n")) 25 | fmt 26 | end 27 | -------------------------------------------------------------------------------- /ppx_debug_common/pp.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let pexpr = Pprintast.expression 4 | let pstr = Pprintast.structure 5 | 6 | let debug_pexpr fmt { pexp_desc; _ } = 7 | let name = 8 | match pexp_desc with 9 | | Pexp_ident _ -> "Pexp_ident" 10 | | Pexp_constant _ -> "Pexp_constant" 11 | | Pexp_let (_, _, _) -> "Pexp_let" 12 | | Pexp_function _ -> "Pexp_function" 13 | | Pexp_fun (_, _, _, _) -> "Pexp_fun" 14 | | Pexp_apply (_, _) -> "Pexp_apply" 15 | | Pexp_match (_, _) -> "Pexp_match" 16 | | Pexp_try (_, _) -> "Pexp_try" 17 | | Pexp_tuple _ -> "Pexp_tuple" 18 | | Pexp_construct (_, _) -> "Pexp_construct" 19 | | Pexp_variant (_, _) -> "Pexp_variant" 20 | | Pexp_record (_, _) -> "Pexp_record" 21 | | Pexp_field (_, _) -> "Pexp_field" 22 | | Pexp_setfield (_, _, _) -> "Pexp_setfield" 23 | | Pexp_array _ -> "Pexp_array" 24 | | Pexp_ifthenelse (_, _, _) -> "Pexp_ifthenelse" 25 | | Pexp_sequence (_, _) -> "Pexp_sequence" 26 | | Pexp_while (_, _) -> "Pexp_while" 27 | | Pexp_for (_, _, _, _, _) -> "Pexp_for" 28 | | Pexp_constraint (_, _) -> "Pexp_constraint" 29 | | Pexp_coerce (_, _, _) -> "Pexp_coerce" 30 | | Pexp_send (_, _) -> "Pexp_send" 31 | | Pexp_new _ -> "Pexp_new" 32 | | Pexp_setinstvar (_, _) -> "Pexp_setinstvar" 33 | | Pexp_override _ -> "Pexp_override" 34 | | Pexp_letmodule (_, _, _) -> "Pexp_letmodule" 35 | | Pexp_letexception (_, _) -> "Pexp_letexception" 36 | | Pexp_assert _ -> "Pexp_assert" 37 | | Pexp_lazy _ -> "Pexp_lazy" 38 | | Pexp_poly (_, _) -> "Pexp_poly" 39 | | Pexp_object _ -> "Pexp_object" 40 | | Pexp_newtype (_, _) -> "Pexp_newtype" 41 | | Pexp_pack _ -> "Pexp_pack" 42 | | Pexp_open (_, _) -> "Pexp_open" 43 | | Pexp_letop _ -> "Pexp_letop" 44 | | Pexp_extension _ -> "Pexp_extension" 45 | | Pexp_unreachable -> "Pexp_unreachable" 46 | in 47 | Format.fprintf fmt "%s" name 48 | -------------------------------------------------------------------------------- /ppx_debug_common/ppx_debug_common.ml: -------------------------------------------------------------------------------- 1 | module Instrument = Instrument 2 | module Interpret_cmt = Interpret_cmt 3 | module Log = Log 4 | -------------------------------------------------------------------------------- /ppx_debug_common/unstable.cppo.ml: -------------------------------------------------------------------------------- 1 | 2 | module Load_path = struct 3 | let init p = 4 | Ocaml_common.Load_path.init 5 | #if OCAML_VERSION < (5,0,0) 6 | #else 7 | ~auto_include:Load_path.no_auto_include 8 | #endif 9 | p 10 | end -------------------------------------------------------------------------------- /ppx_debug_common/unstable.mli: -------------------------------------------------------------------------------- 1 | 2 | module Load_path : sig 3 | val init : string list -> unit 4 | end 5 | -------------------------------------------------------------------------------- /ppx_debug_interact.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "A ppx for debugging" 5 | description: "Debug away" 6 | maintainer: ["darius.foo.tw@gmail.com"] 7 | authors: ["Darius Foo"] 8 | homepage: "https://github.com/dariusf/ppx_debug" 9 | bug-reports: "https://github.com/dariusf/ppx_debug/issues" 10 | depends: [ 11 | "dune" {>= "3.0"} 12 | "ppx_debug_runtime" {= "0.1"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/dariusf/ppx_debug.git" 30 | -------------------------------------------------------------------------------- /ppx_debug_interact/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_debug_interact) 3 | (public_name ppx_debug_interact) 4 | (libraries ppx_interact_runtime ppx_debug_runtime)) 5 | 6 | (env 7 | (dev 8 | (flags 9 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /ppx_debug_interact/ppx_debug_interact.ml: -------------------------------------------------------------------------------- 1 | let backslash = Str.regexp {|\\|} 2 | let content_marker = Str.regexp "_content" 3 | 4 | open Ppx_debug_runtime.Trace 5 | 6 | let repl ~print_value filename find_i = 7 | let res = read ~print_value filename in 8 | let tree = to_call_tree res in 9 | let find f which = 10 | traverse (fun t i _c -> if which = i then f t else ()) tree 11 | in 12 | let z = 13 | let strs = ref [] in 14 | find 15 | (fun t -> 16 | match t with 17 | | Call { unmarshal; _ } -> 18 | strs := 19 | List.map 20 | (fun (k, (Bytestr r, v)) -> 21 | let content = 22 | "\"" 23 | ^ Str.global_replace backslash {|\\\\|} (String.escaped r) 24 | ^ "\"" 25 | in 26 | Format.asprintf "let %s = %s;;" k 27 | (Str.global_replace content_marker content v)) 28 | unmarshal 29 | @ !strs 30 | | Event { unmarshal; raw = Bytestr r; _ } -> 31 | let content = 32 | "\"" 33 | ^ Str.global_replace backslash {|\\\\|} (String.escaped r) 34 | ^ "\"" 35 | in 36 | strs := 37 | Format.asprintf "let v = %s;;" 38 | (Str.global_replace content_marker content unmarshal) 39 | :: !strs) 40 | find_i; 41 | !strs 42 | in 43 | let w = 10 in 44 | Ppx_interact_runtime.( 45 | interact ~init:z ~unit:__MODULE__ ~loc:__POS__ 46 | ~values: 47 | [ 48 | V ("y", 7); 49 | V ("w", w + 1); 50 | V ("res", res); 51 | V ("tree", tree); 52 | V ("find", find); 53 | ] 54 | ()) 55 | 56 | module Cli = struct 57 | open Cmdliner 58 | 59 | let repl_cmd print_value = 60 | let i = 61 | Arg.( 62 | value & opt int 0 63 | & info ["i"] ~docv:"timestamp" ~doc:"Timestamp to go to") 64 | in 65 | let file = 66 | let doc = "file" in 67 | Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc) 68 | in 69 | let info = 70 | Cmd.info "repl" ~doc:"start toplevel" 71 | ~man: 72 | [ 73 | `S Manpage.s_description; 74 | `P 75 | "Analyze a trace using the toplevel by loading the arguments and \ 76 | return value of the call at the given point in time"; 77 | ] 78 | in 79 | Cmd.v info Term.(const (repl ~print_value) $ file $ i) 80 | 81 | let main_cmd print_value = 82 | let info = 83 | Cmd.info "debug" ~version:"v0.1" 84 | ~doc:"Extracts information from ppx_debug traces" 85 | in 86 | let default = Term.(ret (const (`Ok ()))) in 87 | Cmd.group info ~default [repl_cmd print_value] 88 | end 89 | 90 | let main ~print_value () = exit (Cmdliner.Cmd.eval (Cli.main_cmd print_value)) -------------------------------------------------------------------------------- /ppx_debug_runtime.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "A ppx for debugging" 5 | description: "Debug away" 6 | maintainer: ["darius.foo.tw@gmail.com"] 7 | authors: ["Darius Foo"] 8 | homepage: "https://github.com/dariusf/ppx_debug" 9 | bug-reports: "https://github.com/dariusf/ppx_debug/issues" 10 | depends: [ 11 | "dune" {>= "3.0"} 12 | "cmdliner" {>= "1.1.1"} 13 | "yojson" {>= "1.7.0"} 14 | "linenoise" {>= "1.3.1"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/dariusf/ppx_debug.git" 32 | -------------------------------------------------------------------------------- /ppx_debug_runtime/chrome_trace.ml: -------------------------------------------------------------------------------- 1 | (* Incomplete but tiny implementation of 2 | 3 | https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/preview#heading=h.yr4qxyxotyw 4 | 5 | there are at least two other options for writing trace data in a way that allows one of https://magic-trace.org/, https://ui.perfetto.dev/#!/, or chrome://tracing to be used; see https://github.com/ocaml/dune/pull/5618 *) 6 | let rec call_tree_to_chrome (call : Trace.call) : Yojson.Safe.t list = 7 | match call with 8 | | Event { time; name; content; i; id = { file; loc; _ }; _ } -> 9 | ignore 10 | [ 11 | `Assoc 12 | [ 13 | ("ph", `String "i"); 14 | ("ts", `Float (float_of_int time)); 15 | ("pid", `Float 1.); 16 | ("tid", `Float 1.); 17 | ("name", `String name); 18 | ( "args", 19 | `Assoc 20 | [ 21 | ("_i", `Int i); 22 | ("_file", `String file); 23 | ("_loc", `String (Trace.Id.show_loc loc)); 24 | ("content", `String content); 25 | ] ); 26 | ]; 27 | ]; 28 | [] 29 | | Call 30 | { 31 | name = func; 32 | start_time; 33 | end_time; 34 | args; 35 | calls; 36 | i; 37 | id = { file; loc; _ }; 38 | _; 39 | } -> 40 | let start, end_ = 41 | match func with 42 | | _ when String.equal func Trace.top_level_node -> ([], []) 43 | | _ -> 44 | ( [ 45 | `Assoc 46 | [ 47 | ("name", `String func); 48 | ("ph", `String "B"); 49 | ("ts", `Float (float_of_int start_time)); 50 | ("pid", `Float 1.); 51 | ("tid", `Float 1.); 52 | ( "args", 53 | `Assoc 54 | ([ 55 | ("_i", `Int i); 56 | ("_file", `String file); 57 | ("_loc", `String (Trace.Id.show_loc loc)); 58 | ] 59 | @ List.map (fun (k, v) -> (k, `String v)) args) ); 60 | ]; 61 | ], 62 | [ 63 | `Assoc 64 | [ 65 | ("ph", `String "E"); 66 | ("ts", `Float (float_of_int end_time)); 67 | ("pid", `Float 1.); 68 | ("tid", `Float 1.); 69 | ]; 70 | ] ) 71 | in 72 | let rest = List.concat_map call_tree_to_chrome calls in 73 | List.concat [start; rest; end_] -------------------------------------------------------------------------------- /ppx_debug_runtime/config.ml: -------------------------------------------------------------------------------- 1 | type variant = 2 | | Containers 3 | | Stdlib 4 | [@@deriving yojson, show { with_path = false }] 5 | 6 | module SMap = struct 7 | module M = Map.Make (String) 8 | include M 9 | 10 | let pp pp_v fmt map = 11 | Format.fprintf fmt "@[{@;<0 2>@[%a@]@,}@]" 12 | (Format.pp_print_list 13 | ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") 14 | (fun fmt (k, v) -> Format.fprintf fmt "%s: %a" k pp_v v)) 15 | (bindings map) 16 | 17 | let update_ k f m = 18 | update k (function None -> failwith "invalid" | Some v -> Some (f v)) m 19 | 20 | let create xs = M.of_seq (List.to_seq xs) 21 | end 22 | 23 | type action = 24 | | Opaque 25 | | Rewrite of string 26 | [@@deriving yojson, show] 27 | 28 | type rewrites = action SMap.t SMap.t [@@deriving show] 29 | 30 | let rewrites_to_yojson m = 31 | `Assoc 32 | (m |> SMap.bindings 33 | |> List.map (fun (k, v) -> 34 | ( k, 35 | `Assoc 36 | (v |> SMap.bindings 37 | |> List.map (fun (k, v) -> (k, action_to_yojson v))) ))) 38 | 39 | let rewrites_of_yojson json = 40 | try 41 | match json with 42 | | `Assoc kvs -> 43 | Ok 44 | (kvs 45 | |> List.map (fun (k, v) -> 46 | match v with 47 | | `Assoc kvs1 -> 48 | let v = 49 | kvs1 50 | |> List.map (fun (k, v) -> 51 | match action_of_yojson v with 52 | | Ok v -> (k, v) 53 | | Error s -> 54 | failwith ("contents should be strings: " ^ s)) 55 | |> SMap.create 56 | in 57 | (k, v) 58 | | _ -> failwith "expected assoc") 59 | |> SMap.create) 60 | | _ -> failwith "not an assoc" 61 | with Failure s -> Error s 62 | 63 | type t = { 64 | (* whether to enable debug logging in the ppx itself, and the locations of its log files *) 65 | ppx_logging : bool; [@default true] 66 | internal_log : string; [@default "/tmp/ppx_debug.txt"] 67 | internal_tool_log : string; [@default "/tmp/ppx_debug_tool.txt"] 68 | (* whether to run the instrumentation ppx *) 69 | should_instrument : bool; [@default true] 70 | (* which functions/modules should be instrumented. *) 71 | instrument_modules : string; [@default ".*"] 72 | (* the function blacklist is applied on top of the whitelist *) 73 | instrument_functions : string; [@default ".*"] 74 | do_not_instrument_functions : string; [@default " "] 75 | (* file raw trace should be written to *) 76 | file : string; [@default "debug.trace"] 77 | (* TODO this needs more testing *) 78 | randomize_filename : bool; [@default false] 79 | (* whether to instrument the given syntactic constructs *) 80 | should_instrument_lambdas : bool; [@default true] 81 | should_instrument_matches : bool; [@default true] 82 | should_instrument_calls : bool; [@default true] 83 | (* again the blacklist is applied on top of the whitelist *) 84 | should_instrument_definitions : bool; [@default true] 85 | (* (module name, function name) pairs *) 86 | should_not_instrument_definitions : (string * string) list; [@default []] 87 | (* what sort of printers to generate *) 88 | variant : variant; [@default Stdlib] 89 | (* do not search these directories for cmt files *) 90 | cmt_ignored_directories : string list; [@default ["test/"]] 91 | (* if (dune) libraries are nested more than one directory deep, provide their entrypoint modules here, e.g. demo/lib *) 92 | libraries : string list; [@default []] 93 | (* do not search cmt files for printers of types whose names match these regexes *) 94 | opaque_type_names : string list; [@default []] 95 | (* mappings *) 96 | (* TODO needs more testing *) 97 | (* file -> from_name -> to_name *) 98 | mappings : rewrites; 99 | [@to_yojson rewrites_to_yojson] 100 | [@of_yojson rewrites_of_yojson] 101 | [@default SMap.empty] 102 | } 103 | [@@deriving yojson { strict = false }, show { with_path = false }] 104 | 105 | let get_file d = 106 | if d.randomize_filename then 107 | Format.asprintf "/tmp/%d_%s" (int_of_float (Unix.gettimeofday ())) d.file 108 | else d.file 109 | 110 | let default = of_yojson (`Assoc []) |> Result.get_ok 111 | 112 | let parse s = 113 | let x = s |> Yojson.Safe.from_string |> of_yojson in 114 | match x with 115 | | Ok y -> y 116 | | Error s -> failwith (Format.asprintf "failed to parse config: %s" s) 117 | 118 | (* memoize because this may be called many times and environment variables don't change *) 119 | let read = 120 | let config = ref None in 121 | fun () -> 122 | match !config with 123 | | None -> 124 | let c = 125 | match Sys.getenv_opt "PPX_DEBUG" with 126 | | None -> default 127 | | Some s -> parse s 128 | in 129 | config := Some c; 130 | c 131 | | Some c -> c 132 | -------------------------------------------------------------------------------- /ppx_debug_runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_debug_runtime) 3 | (public_name ppx_debug_runtime) 4 | (libraries str linenoise yojson unix cmdliner) 5 | (inline_tests) 6 | (preprocess (pps ppx_deriving.show ppx_deriving_yojson ppx_expect))) 7 | 8 | (env 9 | (dev 10 | (flags 11 | (:standard -warn-error -A)))) -------------------------------------------------------------------------------- /ppx_debug_runtime/main.ml: -------------------------------------------------------------------------------- 1 | type output = 2 | | Chrome 3 | | Debugger 4 | | Calls 5 | | Tree 6 | 7 | let strip_newlines = 8 | let nl = Str.regexp "\n" in 9 | fun v -> Str.global_replace nl " " v 10 | 11 | let rec print_tree data f tree = 12 | match tree with 13 | | Trace.Call { calls; name; args = []; _ } 14 | when String.equal name Trace.top_level_node -> 15 | List.iter (print_tree data f) calls 16 | | Trace.Call { i; calls; args; name; id = { file; loc = (line, _), _; _ }; _ } 17 | -> 18 | let res = List.assoc_opt "_res" args |> Option.map strip_newlines in 19 | let args = 20 | args |> List.filter (fun (n, _) -> not (String.starts_with ~prefix:"_" n)) 21 | in 22 | let argss = 23 | match args with 24 | | [] -> "" 25 | | _ -> 26 | args 27 | |> List.map (fun (k, v) -> 28 | Format.asprintf "(%s: %s)" k (strip_newlines v)) 29 | |> String.concat ", " |> ( ^ ) " " 30 | in 31 | let res = match res with None -> "" | Some r -> " = " ^ r in 32 | f 33 | (fun data -> List.iter (print_tree data f) calls) 34 | data i file line name argss res 35 | | Event _ -> () 36 | 37 | let act_on ~print_value file fmt = 38 | let trace = Trace.read ~print_value file in 39 | match fmt with 40 | | Some Calls -> 41 | let tree = Trace.to_call_tree trace in 42 | print_tree () 43 | (fun self data i file line name args res -> 44 | Format.printf "%5d %s:%d %s%s%s@." i file line name args res; 45 | self data) 46 | tree 47 | | Some Tree -> 48 | let tree = Trace.to_call_tree trace in 49 | print_tree 0 50 | (fun self data i file line name args res -> 51 | let indent = String.init data (fun _ -> ' ') in 52 | Format.printf "%s(%d) %s:%d %s%s@." indent i file line name args; 53 | self (data + 2); 54 | Format.printf "%s(%d) %s:%d %s%s@." indent i file line name res) 55 | tree 56 | | Some Debugger -> 57 | let tree = Trace.to_call_tree trace in 58 | let json = Trace.preprocess_for_debugging tree in 59 | print_endline (Yojson.Safe.to_string json) 60 | | Some Chrome | None -> 61 | let tree = Trace.to_call_tree trace in 62 | Chrome_trace.call_tree_to_chrome tree |> fun e -> 63 | `List e |> Yojson.Safe.to_string |> print_endline 64 | 65 | module Cli = struct 66 | open Cmdliner 67 | 68 | let trace_cmd print_value = 69 | let format = 70 | Arg.( 71 | value 72 | & opt 73 | (some 74 | (Arg.enum 75 | [ 76 | ("chrome", Chrome); 77 | ("debugger", Debugger); 78 | ("calls", Calls); 79 | ("tree", Tree); 80 | ])) 81 | (Some Chrome) 82 | & info ["f"; "format"] ~docv:"FORMAT" 83 | ~doc: 84 | "Specify output format. Allowed values: chrome, debugger, calls") 85 | in 86 | let file = 87 | let doc = "file" in 88 | Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc) 89 | (* non_empty *) 90 | in 91 | let info = 92 | Cmd.info "trace" ~doc:"render traces in various formats" 93 | ~man: 94 | [ 95 | `S Manpage.s_description; 96 | `P 97 | "Prints a trace in Chrome trace format, as a list of calls, or \ 98 | as JSON consumed by editor plugins."; 99 | ] 100 | in 101 | Cmd.v info Term.(const (act_on ~print_value) $ file $ format) 102 | 103 | let main_cmd print_value = 104 | let info = 105 | Cmd.info "debug" ~version:"v0.1" 106 | ~doc:"Extracts information from ppx_debug traces" 107 | in 108 | let default = Term.(ret (const (`Ok ()))) in 109 | Cmd.group info ~default [trace_cmd print_value] 110 | end 111 | 112 | let main ~print_value () = exit (Cmdliner.Cmd.eval (Cli.main_cmd print_value)) -------------------------------------------------------------------------------- /ppx_debug_runtime/ppx_debug_runtime.ml: -------------------------------------------------------------------------------- 1 | module Trace = Trace 2 | module Main = Main 3 | module Id = Trace.Id 4 | module Chrome_trace = Chrome_trace 5 | module Config = Config 6 | -------------------------------------------------------------------------------- /ppx_debug_runtime/trace.ml: -------------------------------------------------------------------------------- 1 | let open_channels : (string * out_channel) list ref = ref [] 2 | 3 | type bytestr = Bytestr of string [@@unboxed] 4 | 5 | let pp_bytestr fmt _b = Format.fprintf fmt "" 6 | 7 | module Id = struct 8 | type loc = (int * int) * (int * int) 9 | [@@deriving show { with_path = false }, yojson] 10 | 11 | type t = { 12 | (* the combination of file (compilation unit) and id is sufficiently unique *) 13 | file : string; 14 | id : int; 15 | (* extra fields *) 16 | (* func : string; *) 17 | (* modname : string; *) 18 | loc : loc; 19 | } 20 | [@@deriving show { with_path = false }, yojson] 21 | 22 | let dummy_loc = ((-1, -1), (-1, -1)) 23 | let dummy = { file = "_none"; id = -1; loc = dummy_loc } 24 | 25 | let serialize { file; id; loc = (sl, sc), (el, ec) } = 26 | Format.sprintf "%s:%d:%d:%d:%d:%d" file id sl sc el ec 27 | 28 | let deserialize file = 29 | Scanf.bscanf file "%s@:%d:%d:%d:%d:%d\n" @@ fun file id sl sc el ec -> 30 | { file; id; loc = ((sl, sc), (el, ec)) } 31 | 32 | let show { file; id; loc } = 33 | Format.asprintf "(file: %s, id: %d, loc: %a)" file id pp_loc loc 34 | end 35 | 36 | (* really simple internal trace format. this is written in binary mode (via the emit_* functions, which marshal ocaml values) and read together with type metadata to unmarshal values (producing text) *) 37 | type 'a eventx = 38 | | FrameStart of { 39 | time : int; 40 | id : Id.t; 41 | func : string; 42 | } 43 | | Value of { 44 | time : int; 45 | id : Id.t; 46 | name : string; 47 | content : 'a; 48 | unmarshal : string; 49 | raw : bytestr; 50 | } 51 | | Argument of { 52 | time : int; 53 | id : Id.t; 54 | name : string; 55 | content : 'a; 56 | unmarshal : string; 57 | raw : bytestr; 58 | } 59 | | MatchScrutinee of { 60 | time : int; 61 | id : Id.t; 62 | name : string; 63 | content : 'a; 64 | unmarshal : string; 65 | raw : bytestr; 66 | } 67 | | MatchBranch of { 68 | time : int; 69 | id : Id.t; 70 | name : string; 71 | content : 'a; 72 | unmarshal : string; 73 | raw : bytestr; 74 | } 75 | | BeforeCall of { 76 | time : int; 77 | id : Id.t; 78 | name : string; 79 | content : 'a; 80 | unmarshal : string; 81 | raw : bytestr; 82 | } 83 | | AfterCall of { 84 | time : int; 85 | id : Id.t; 86 | name : string; 87 | content : 'a; 88 | unmarshal : string; 89 | raw : bytestr; 90 | } 91 | | FrameEnd of { 92 | time : int; 93 | id : Id.t; 94 | func : string; 95 | } 96 | [@@deriving show { with_path = false }] 97 | 98 | type event = string eventx [@@deriving show { with_path = false }] 99 | type t = event list 100 | 101 | let to_file filename f = 102 | let file = open_out_bin filename in 103 | f file; 104 | close_out file 105 | 106 | let new_channel c = c 107 | 108 | let lazy_init c = 109 | if not (List.mem_assoc c !open_channels) then ( 110 | let f = open_out_bin c in 111 | at_exit (fun () -> close_out f); 112 | open_channels := (c, f) :: !open_channels; 113 | f) 114 | else List.assoc c !open_channels 115 | 116 | let get_time = 117 | (* hack to ensure time monotonically increases, so every event takes at least 1 ms *) 118 | let time_i = ref 0 in 119 | let last_time = ref 0 in 120 | fun () -> 121 | let get () = 122 | (* millisecond *) 123 | Float.to_int (Float.round (Unix.gettimeofday () *. 1000.)) 124 | in 125 | let t = get () in 126 | if t <= !last_time then begin 127 | incr time_i; 128 | last_time := !last_time + !time_i; 129 | !last_time 130 | end 131 | else begin 132 | time_i := 0; 133 | last_time := t; 134 | t 135 | end 136 | 137 | let sanity_check () = 138 | match Sys.getenv_opt "PPX_DEBUG_DEBUG" with 139 | | Some _ -> print_endline "this should not appear while tool is running" 140 | | None -> () 141 | 142 | let emit_start ~ppx_debug_file ~ppx_debug_id:id ~func = 143 | sanity_check (); 144 | Printf.fprintf (lazy_init ppx_debug_file) "start\n%s\n%d\n%s\n" 145 | (Id.serialize id) (get_time ()) func 146 | 147 | let emit_end ~ppx_debug_file ~ppx_debug_id:id ~func = 148 | sanity_check (); 149 | Printf.fprintf (lazy_init ppx_debug_file) "end\n%s\n%d\n%s\n" 150 | (Id.serialize id) (get_time ()) func 151 | 152 | let emit_raw ~ppx_debug_file ~ppx_debug_id:id typ what v = 153 | sanity_check (); 154 | (* if a function is given, instead of throwing an exception, output a string. 155 | this is okay because the printer for functions ignores its argument. *) 156 | let[@warning "-52"] s = 157 | try Marshal.to_string v [] with 158 | | Invalid_argument "output_value: functional value" -> 159 | Marshal.to_string "" [] 160 | | Invalid_argument "output_value: abstract value (Custom)" -> 161 | (* TODO not sure what this is *) 162 | Marshal.to_string "" [] 163 | in 164 | Printf.fprintf (lazy_init ppx_debug_file) "%s\n%s\n%s\n%d\n%d%s\n" typ 165 | (Id.serialize id) what (get_time ()) (String.length s) s 166 | 167 | (* for function parameters. collected when converting to call tree *) 168 | let emit_argument ~ppx_debug_file ~ppx_debug_id:id what v = 169 | emit_raw ~ppx_debug_file ~ppx_debug_id:id "arg" what v 170 | 171 | (* for extension nodes *) 172 | let emit_value ~ppx_debug_file ~ppx_debug_id:id what v = 173 | emit_raw ~ppx_debug_file ~ppx_debug_id:id "value" what v 174 | 175 | let read ~print_value filename = 176 | let read_n n file = 177 | Bytes.init n (fun _i -> Scanf.bscanf file "%c" Fun.id) |> Bytes.to_string 178 | in 179 | let file = Scanf.Scanning.open_in_bin filename in 180 | let rec loop all = 181 | let typ = Scanf.bscanf file "%s@\n" (fun typ -> typ) in 182 | match typ with 183 | | "start" -> 184 | let id = Id.deserialize file in 185 | let time = Scanf.bscanf file "%d\n" (fun t -> t) in 186 | let func = Scanf.bscanf file "%s@\n" (fun id -> id) in 187 | loop (FrameStart { id; time; func } :: all) 188 | | "end" -> 189 | let id = Id.deserialize file in 190 | let time = Scanf.bscanf file "%d\n" (fun t -> t) in 191 | let func = Scanf.bscanf file "%s@\n" (fun id -> id) in 192 | loop (FrameEnd { id; time; func } :: all) 193 | | "arg" | "value" | "match" | "matchb" | "acall" | "bcall" -> 194 | let id = Id.deserialize file in 195 | let what = Scanf.bscanf file "%s@\n" (fun what -> what) in 196 | let time = Scanf.bscanf file "%d\n" (fun t -> t) in 197 | let len = Scanf.bscanf file "%d" (fun t -> t) in 198 | let raw = Bytestr (read_n len file) in 199 | Scanf.bscanf file "\n" (); 200 | let v, unmarshal = print_value id raw in 201 | let next = 202 | match typ with 203 | | "arg" -> 204 | Argument { time; id; name = what; content = v; unmarshal; raw } 205 | | "value" -> 206 | Value { time; id; name = what; content = v; unmarshal; raw } 207 | | "match" -> 208 | MatchScrutinee { time; id; name = what; content = v; unmarshal; raw } 209 | | "matchb" -> 210 | MatchBranch { time; id; name = what; content = v; unmarshal; raw } 211 | | "acall" -> 212 | AfterCall { time; id; name = what; content = v; unmarshal; raw } 213 | | "bcall" -> 214 | BeforeCall { time; id; name = what; content = v; unmarshal; raw } 215 | | _ -> failwith "invalid" 216 | in 217 | loop (next :: all) 218 | | "" -> List.rev all 219 | | _ -> failwith ("invalid " ^ typ) 220 | in 221 | let res = loop [] in 222 | Scanf.Scanning.close_in file; 223 | res 224 | 225 | let top_level_node = "top level" 226 | 227 | (** converts a linear trace with start/end spans and point events into a call tree, numbering nodes chronologically *) 228 | let to_tree ?(toplevel = top_level_node) ~leaf ~node trace = 229 | let fresh = 230 | let i = ref 0 in 231 | fun () -> 232 | let r = !i in 233 | incr i; 234 | r 235 | in 236 | let rec build_tree trace = 237 | match trace with 238 | | (MatchScrutinee { time; id; name; content; unmarshal; raw } as e) :: es 239 | | (MatchBranch { time; id; name; content; unmarshal; raw } as e) :: es 240 | | (Value { time; id; name; content; unmarshal; raw } as e) :: es 241 | | (AfterCall { time; id; name; content; unmarshal; raw } as e) :: es 242 | | (BeforeCall { time; id; name; content; unmarshal; raw } as e) :: es -> 243 | (* it's possible for these to occur outside any call, e.g. if a non-instrumented function is called *) 244 | let tree, trace = build_tree es in 245 | let ev = leaf (fresh ()) e id name content time unmarshal raw in 246 | (ev :: tree, trace) 247 | | FrameStart { func; id; time = start_time; _ } :: es -> 248 | (* reserve an id first *) 249 | let i = fresh () in 250 | let trace, args, trees, end_time = look_for_end es [] [] in 251 | let subtree = node i func id args trees start_time end_time in 252 | ([subtree], trace) 253 | | e :: _ -> 254 | failwith (Format.asprintf "expected FrameStart, got %a" pp_event e) 255 | | [] -> failwith "empty trace" 256 | and look_for_end trace args res = 257 | match trace with 258 | | e :: es -> 259 | begin 260 | match e with 261 | | FrameEnd { time; _ } -> (es, List.rev args, List.rev res, time) 262 | | FrameStart _ -> 263 | (* note that we recurse on (e :: es), not es *) 264 | let tree, trace = build_tree (e :: es) in 265 | look_for_end trace args (tree @ res) 266 | | MatchScrutinee { id; content; name; time; unmarshal; raw } 267 | | MatchBranch { id; content; name; time; unmarshal; raw } 268 | | Value { id; content; name; time; unmarshal; raw } 269 | | AfterCall { id; content; name; time; unmarshal; raw } 270 | | BeforeCall { id; content; name; time; unmarshal; raw } -> 271 | look_for_end es args 272 | (leaf (fresh ()) e id name content time unmarshal raw :: res) 273 | | Argument { content; name; unmarshal; raw; _ } -> 274 | look_for_end es ((name, content, unmarshal, raw) :: args) res 275 | end 276 | | [] -> failwith "start without end" 277 | in 278 | (* build_tree returns the collected trees and the remaining trace, so we have to iterate it *) 279 | let rec collect_trees trace = 280 | match trace with 281 | | [] -> [] 282 | | _ :: _ -> 283 | let tree, trace = build_tree trace in 284 | tree @ collect_trees trace 285 | in 286 | (* reserve id first, so nodes chronologically earlier in the call tree get smaller ids *) 287 | let i = fresh () in 288 | (* most of the values of the top level node are dummy, including start and end time *) 289 | node i toplevel Id.dummy [] (collect_trees trace) 0 0 290 | 291 | (* a tree representation of traces that makes many operations easier *) 292 | type 'a callx = 293 | | Event of { 294 | i : int; 295 | name : string; 296 | content : 'a; 297 | time : int; 298 | id : Id.t; 299 | unmarshal : string; 300 | raw : bytestr; [@opaque] 301 | } 302 | | Call of { 303 | i : int; 304 | name : string; 305 | args : (string * 'a) list; 306 | unmarshal : (string * (bytestr * string)) list; 307 | calls : 'a callx list; 308 | start_time : int; 309 | end_time : int; 310 | id : Id.t; 311 | } 312 | 313 | type call = string callx 314 | 315 | let to_call_tree trace = 316 | to_tree 317 | ~node:(fun i f id args trees start_time end_time -> 318 | let unmarshal = List.map (fun (n, _, u, r) -> (n, (r, u))) args in 319 | let args = List.map (fun (n, a, _, _) -> (n, a)) args in 320 | Call 321 | { 322 | i; 323 | name = f; 324 | calls = trees; 325 | args; 326 | id; 327 | start_time; 328 | end_time; 329 | unmarshal; 330 | }) 331 | ~leaf:(fun i _e id name content time unmarshal raw -> 332 | Event { i; name; content; id; time; unmarshal; raw }) 333 | trace 334 | 335 | let rec traverse f tree = 336 | match tree with 337 | | Call { i; calls; args; _ } -> 338 | f tree i args; 339 | List.iter (traverse f) calls 340 | | Event { i; content; _ } -> f tree i [("val", content)] 341 | 342 | let group_sorted f xs = 343 | let rec loop res xs = 344 | match (xs, res) with 345 | | [], _ -> List.rev res 346 | | x :: xs, [] -> loop ([x] :: res) xs 347 | | x :: xs, (r :: rs) :: rs1 -> 348 | if f x = f r then loop ((x :: r :: rs) :: rs1) xs 349 | else loop ([x] :: (r :: rs) :: rs1) xs 350 | | _ :: _, [] :: _ -> 351 | (* this isn't possible as we can't create an empty group *) 352 | failwith "invalid" 353 | in 354 | loop [] xs 355 | 356 | let%expect_test _ = 357 | let show a = a |> [%derive.show: int list list] |> print_endline in 358 | group_sorted Fun.id [1; 1; 2; 3; 3; 4] |> show; 359 | [%expect {| [[1; 1]; [2]; [3; 3]; [4]] |}] 360 | 361 | let group_by ~key ~value ~group xs = 362 | xs 363 | |> List.sort (fun kv1 kv2 -> compare (key kv1) (key kv2)) 364 | |> group_sorted key 365 | |> List.map (fun g -> 366 | let k = 367 | match g with [] -> failwith "empty group" | kv :: _ -> key kv 368 | in 369 | let vs = List.map value g in 370 | group k vs) 371 | 372 | (** 373 | Walks the call tree as if it were being stepped through (depth-first, preorder, left-to-right), 374 | computing a few relations between nodes. 375 | 376 | Many relations are inverses (next/back, out/in, next_sibling/prev_sibling). 377 | Not all are useful, e.g. next subsumes in and would probably be used to implement a debugger's "step in" command. 378 | Not all correspond directly to debugger actions, e.g. "step out" would be done by composing out and next_sibling. 379 | 380 | Outputs JSON. Could be used for the zipper viewer but we would have to separate the JSON encoding phase. 381 | *) 382 | let preprocess_for_debugging tree : Yojson.Safe.t = 383 | let rec loop prev lineage nodes edges breakpoints t = 384 | (* this node's id *) 385 | let nid = match t with Event { i; _ } -> i | Call { i; _ } -> i in 386 | (* compute all the relations *) 387 | let step_out, step_in = 388 | match lineage with 389 | | [] -> ([], []) 390 | | n :: _ -> 391 | (* don't add an in node twice *) 392 | let in_ = [(n, ("in", nid))] in 393 | (* return the id of the current node, so it may be used as the previous node of the next one *) 394 | let out = [(nid, ("out", n))] in 395 | (out, in_) 396 | in 397 | let step_back, step_next = 398 | match prev with 399 | | None -> ([], []) 400 | | Some p -> 401 | let back = [(nid, ("back", p))] in 402 | let next = [(p, ("next", nid))] in 403 | (back, next) 404 | in 405 | let new_edges = step_in @ step_back @ step_out @ step_next in 406 | (* decide what to present for each kind of node *) 407 | match t with 408 | | Event { id; name; content; _ } -> 409 | let (line, _), _ = id.loc in 410 | let breakpoints = (line, nid) :: breakpoints in 411 | let this = 412 | `Assoc 413 | [ 414 | ("id", Id.to_yojson id); 415 | ("name", `String name); 416 | ("content", `String content); 417 | ] 418 | in 419 | (nid, nid, (nid, this) :: nodes, new_edges @ edges, breakpoints) 420 | | Call { id; name; calls; args; _ } -> 421 | let (line, _), _ = id.loc in 422 | let breakpoints = (line, nid) :: breakpoints in 423 | let this = 424 | `Assoc 425 | [ 426 | ("id", Id.to_yojson id); 427 | ("name", `String name); 428 | ("args", `Assoc (List.map (fun (k, v) -> (k, `String v)) args)); 429 | ] 430 | in 431 | let nodes, edges = ((nid, this) :: nodes, new_edges @ edges) in 432 | (* extend lineage once for all children *) 433 | let lin = nid :: lineage in 434 | (* pre-order traversal, left to right *) 435 | let _last_sib, cpid, ns, es, bs = 436 | List.fold_left 437 | (fun (prev_sib, prv, ns, es, bs) c -> 438 | (* previous node updates on each iteration *) 439 | let sid, cid, ns1, es1, bs1 = loop (Some prv) lin ns es bs c in 440 | (* track siblings *) 441 | let extra = 442 | match prev_sib with 443 | | None -> [] 444 | | Some s -> 445 | [(s, ("next_sibling", sid)); (sid, ("prev_sibling", s))] 446 | in 447 | (Some sid, cid, ns1, extra @ es1, bs1)) 448 | (None, nid, nodes, edges, breakpoints) 449 | calls 450 | in 451 | (* nid is our id. cpid is the id of the last thing that executed, which may be a child *) 452 | (nid, cpid, ns, es, bs) 453 | in 454 | let _sid, _nid, nodes, edges, breakpoints = loop None [] [] [] [] tree in 455 | (* encode into json *) 456 | let breakpoints = 457 | group_by ~key:fst ~value:snd 458 | ~group:(fun k vs -> 459 | (string_of_int k, `List (List.map (fun i -> `Int i) vs))) 460 | breakpoints 461 | in 462 | let nodes = 463 | nodes |> List.rev |> List.map (fun (id, n) -> (string_of_int id, n)) 464 | in 465 | let edges = 466 | group_by ~key:fst ~value:snd 467 | ~group:(fun gid kvs -> 468 | let kvs = 469 | (* fix in keys. there will be many because we keep track of all. keep only the minimum, which is correct because we do a pre-order traversal and generate fresh ids in that order *) 470 | let in_keys, non_in = List.partition (fun (k, _) -> k = "in") kvs in 471 | match in_keys with 472 | | [] -> non_in 473 | | _ -> 474 | let min_val = 475 | List.fold_right (fun (_, c) t -> min c t) in_keys Int.max_int 476 | in 477 | ("in", min_val) :: non_in 478 | in 479 | let kvs = List.map (fun (k, v) -> (k, `Int v)) kvs in 480 | (string_of_int gid, `Assoc kvs)) 481 | edges 482 | in 483 | let edges : Yojson.Safe.t = `Assoc edges in 484 | `Assoc 485 | [ 486 | ("nodes", `Assoc nodes); 487 | ("edges", edges); 488 | ("last", `Int (List.length nodes - 1)); 489 | (* this maps line to id *) 490 | ("breakpoints", `Assoc breakpoints); 491 | ] 492 | 493 | let%expect_test _ = 494 | let tree = 495 | Call 496 | { 497 | i = 0; 498 | name = "f"; 499 | id = Id.dummy; 500 | args = []; 501 | unmarshal = []; 502 | start_time = 0; 503 | end_time = 7; 504 | calls = 505 | [ 506 | Event 507 | { 508 | i = 1; 509 | name = "a"; 510 | content = "x"; 511 | id = Id.dummy; 512 | time = 1; 513 | unmarshal = "x"; 514 | raw = Bytestr "x"; 515 | }; 516 | Event 517 | { 518 | i = 2; 519 | name = "b"; 520 | content = "y"; 521 | id = Id.dummy; 522 | time = 2; 523 | unmarshal = "y"; 524 | raw = Bytestr "y"; 525 | }; 526 | Call 527 | { 528 | i = 3; 529 | name = "g"; 530 | id = Id.dummy; 531 | args = []; 532 | unmarshal = []; 533 | start_time = 3; 534 | end_time = 5; 535 | calls = 536 | [ 537 | Event 538 | { 539 | i = 4; 540 | name = "c"; 541 | content = "z"; 542 | id = Id.dummy; 543 | time = 4; 544 | unmarshal = "z"; 545 | raw = Bytestr "z"; 546 | }; 547 | ]; 548 | }; 549 | Event 550 | { 551 | i = 5; 552 | name = "d"; 553 | content = "w"; 554 | id = Id.dummy; 555 | time = 6; 556 | unmarshal = "w"; 557 | raw = Bytestr "w"; 558 | }; 559 | ]; 560 | } 561 | in 562 | let debug = preprocess_for_debugging tree in 563 | Yojson.Safe.pretty_to_string debug |> print_endline; 564 | [%expect 565 | {| 566 | { 567 | "nodes": { 568 | "0": { 569 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 570 | "name": "f", 571 | "args": {} 572 | }, 573 | "1": { 574 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 575 | "name": "a", 576 | "content": "x" 577 | }, 578 | "2": { 579 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 580 | "name": "b", 581 | "content": "y" 582 | }, 583 | "3": { 584 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 585 | "name": "g", 586 | "args": {} 587 | }, 588 | "4": { 589 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 590 | "name": "c", 591 | "content": "z" 592 | }, 593 | "5": { 594 | "id": { "file": "_none", "id": -1, "loc": [ [ -1, -1 ], [ -1, -1 ] ] }, 595 | "name": "d", 596 | "content": "w" 597 | } 598 | }, 599 | "edges": { 600 | "0": { "in": 1, "next": 1 }, 601 | "1": { "out": 0, "back": 0, "next": 2, "next_sibling": 2 }, 602 | "2": { 603 | "out": 0, 604 | "back": 1, 605 | "prev_sibling": 1, 606 | "next": 3, 607 | "next_sibling": 3 608 | }, 609 | "3": { 610 | "in": 4, 611 | "out": 0, 612 | "back": 2, 613 | "next": 4, 614 | "prev_sibling": 2, 615 | "next_sibling": 5 616 | }, 617 | "4": { "out": 3, "back": 3, "next": 5 }, 618 | "5": { "out": 0, "back": 4, "prev_sibling": 3 } 619 | }, 620 | "last": 5, 621 | "breakpoints": { "-1": [ 0, 1, 2, 3, 4, 5 ] } 622 | } 623 | |}] 624 | -------------------------------------------------------------------------------- /ppx_debug_tool.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "A ppx for debugging" 5 | description: "Debug away" 6 | maintainer: ["darius.foo.tw@gmail.com"] 7 | authors: ["Darius Foo"] 8 | homepage: "https://github.com/dariusf/ppx_debug" 9 | bug-reports: "https://github.com/dariusf/ppx_debug/issues" 10 | depends: [ 11 | "dune" {>= "3.0"} 12 | "ppx_debug_runtime" {= "0.1"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/dariusf/ppx_debug.git" 30 | -------------------------------------------------------------------------------- /ppx_debug_tool/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_debug_tool) 3 | (kind ppx_rewriter) 4 | (libraries ppxlib ppx_debug_common containers) 5 | (ppx_runtime_libraries ppx_debug_runtime) 6 | (inline_tests) 7 | (preprocess 8 | (pps ppx_deriving.show ppx_expect ppxlib.metaquot))) 9 | 10 | (env 11 | (dev 12 | (flags 13 | (:standard -warn-error -A)))) 14 | -------------------------------------------------------------------------------- /ppx_debug_tool/ppx_debug_tool.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let rule = 4 | Ppxlib.Context_free.Rule.extension 5 | (Extension.declare "generate" Structure_item 6 | Ast_pattern.(__) 7 | Ppx_debug_common.Interpret_cmt.handle_si) 8 | 9 | let () = 10 | let config = Ppx_debug_runtime.Config.read () in 11 | Ppx_debug_common.Interpret_cmt.log "%a" Ppx_debug_runtime.Config.pp config; 12 | Driver.register_transformation ~rules:[rule] "ppx_debug_tool" 13 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | 2 | # ppx_debug 3 | 4 | A collection of tools for record-and-replay debugging. 5 | 6 | https://user-images.githubusercontent.com/4328341/192141194-2ab66ece-6e52-4eb7-8623-c6ceb82afa32.mov 7 | 8 | This works by instrumenting a program using ppx, running the program to record an execution, then analyzing the execution using editor plugins (which provide an interface like that of an interactive debugger), [Perfetto](https://ui.perfetto.dev/)/[magic-trace](https://magic-trace.org/), the OCaml toplevel, or CLI tools. 9 | 10 | - [Tutorial and docs](docs/docs.md) 11 | - [Demo project](demo) 12 | - [OCaml 2022](https://icfp22.sigplan.org/details/ocaml-2022-papers/2/Tracing-OCaml-Programs) [talk](https://youtu.be/MwVeZrDyewU), [abstract](https://dariusf.github.io/tracing-ocaml22.pdf) 13 | 14 | **This is an early prototype. Feel free to try it on your projects, but expect rough edges. Contributions are very welcome!** 15 | -------------------------------------------------------------------------------- /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 | 16 | ; compiles and executes the test file, then compares the result 17 | 18 | (test 19 | (name test) 20 | (modules test) 21 | (libraries containers ppx_debug_runtime) 22 | (preprocess 23 | (pps ppx_debug))) 24 | -------------------------------------------------------------------------------- /test/pp.expected: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-34-37"] 2 | let value = 1 3 | let fact n = 4 | let fact_original _self n = 5 | match (let ppx_debug_file = 6 | let open Ppx_debug_runtime.Config in get_file (read ()) in 7 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 8 | ~ppx_debug_id:{ 9 | file = "test.ml"; 10 | id = 8; 11 | loc = ((4, 23), (4, 24)) 12 | } "match" "n" n); 13 | n 14 | with 15 | | 0 -> 16 | ((let ppx_debug_file = 17 | let open Ppx_debug_runtime.Config in get_file (read ()) in 18 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 19 | ~ppx_debug_id:{ 20 | file = "test.ml"; 21 | id = 0; 22 | loc = ((4, 35), (4, 36)) 23 | } "matchb" "matchb" "n"); 24 | 1) 25 | | n -> 26 | ((let ppx_debug_file = 27 | let open Ppx_debug_runtime.Config in get_file (read ()) in 28 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 29 | ~ppx_debug_id:{ 30 | file = "test.ml"; 31 | id = 7; 32 | loc = ((4, 44), (4, 60)) 33 | } "matchb" "matchb" "n"); 34 | (let ppx_debug_file = 35 | let open Ppx_debug_runtime.Config in get_file (read ()) in 36 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 37 | ~ppx_debug_id:{ 38 | file = "test.ml"; 39 | id = 1; 40 | loc = ((4, 44), (4, 60)) 41 | } "bcall" "bcall" "(before)"); 42 | (let result__ = 43 | n * 44 | ((let ppx_debug_file = 45 | let open Ppx_debug_runtime.Config in get_file (read ()) in 46 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 47 | ~ppx_debug_id:{ 48 | file = "test.ml"; 49 | id = 3; 50 | loc = ((4, 48), (4, 60)) 51 | } "bcall" "bcall" "(before)"); 52 | (let result__ = 53 | _self 54 | ((let ppx_debug_file = 55 | let open Ppx_debug_runtime.Config in 56 | get_file (read ()) in 57 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 58 | ~ppx_debug_id:{ 59 | file = "test.ml"; 60 | id = 5; 61 | loc = ((4, 53), (4, 60)) 62 | } "bcall" "bcall" "(before)"); 63 | (let result__ = n - 1 in 64 | (let ppx_debug_file = 65 | let open Ppx_debug_runtime.Config in 66 | get_file (read ()) in 67 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 68 | ~ppx_debug_id:{ 69 | file = "test.ml"; 70 | id = 6; 71 | loc = ((4, 53), (4, 60)) 72 | } "acall" "acall" "(after)"); 73 | result__)) in 74 | (let ppx_debug_file = 75 | let open Ppx_debug_runtime.Config in get_file (read ()) in 76 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 77 | ~ppx_debug_id:{ 78 | file = "test.ml"; 79 | id = 4; 80 | loc = ((4, 48), (4, 60)) 81 | } "acall" "acall" "(after)"); 82 | result__)) in 83 | (let ppx_debug_file = 84 | let open Ppx_debug_runtime.Config in get_file (read ()) in 85 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 86 | ~ppx_debug_id:{ 87 | file = "test.ml"; 88 | id = 2; 89 | loc = ((4, 44), (4, 60)) 90 | } "acall" "acall" "(after)"); 91 | result__)) in 92 | let rec aux__ n = 93 | (let ppx_debug_file = 94 | let open Ppx_debug_runtime.Config in get_file (read ()) in 95 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 96 | ~ppx_debug_id:{ file = "test.ml"; id = 9; loc = ((4, 13), (4, 60)) } 97 | ~func:"fact"); 98 | ((let ppx_debug_file = 99 | let open Ppx_debug_runtime.Config in get_file (read ()) in 100 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 101 | ~ppx_debug_id:{ file = "test.ml"; id = 11; loc = ((4, 13), (4, 60)) } 102 | "n" n); 103 | ()); 104 | (let _res = fact_original aux__ n in 105 | (let ppx_debug_file = 106 | let open Ppx_debug_runtime.Config in get_file (read ()) in 107 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 108 | ~ppx_debug_id:{ file = "test.ml"; id = 12; loc = ((4, 13), (4, 60)) } 109 | "_res" _res); 110 | (let ppx_debug_file = 111 | let open Ppx_debug_runtime.Config in get_file (read ()) in 112 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 113 | ~ppx_debug_id:{ file = "test.ml"; id = 10; loc = ((4, 13), (4, 60)) } 114 | ~func:"fact"); 115 | _res) in 116 | aux__ n 117 | let _ = fun () -> () 118 | type v = 119 | | Root of { 120 | value: int } 121 | let labelled ~l () = 122 | let labelled_original ~l () = l in 123 | (let ppx_debug_file = 124 | let open Ppx_debug_runtime.Config in get_file (read ()) in 125 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 126 | ~ppx_debug_id:{ file = "test.ml"; id = 13; loc = ((12, 13), (12, 22)) } 127 | ~func:"labelled"); 128 | ((let ppx_debug_file = 129 | let open Ppx_debug_runtime.Config in get_file (read ()) in 130 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 131 | ~ppx_debug_id:{ file = "test.ml"; id = 15; loc = ((12, 13), (12, 22)) } 132 | "l" l); 133 | ()); 134 | (let _res = labelled_original ~l () in 135 | (let ppx_debug_file = 136 | let open Ppx_debug_runtime.Config in get_file (read ()) in 137 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 138 | ~ppx_debug_id:{ file = "test.ml"; id = 16; loc = ((12, 13), (12, 22)) } 139 | "_res" _res); 140 | (let ppx_debug_file = 141 | let open Ppx_debug_runtime.Config in get_file (read ()) in 142 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 143 | ~ppx_debug_id:{ file = "test.ml"; id = 14; loc = ((12, 13), (12, 22)) } 144 | ~func:"labelled"); 145 | _res) 146 | let optional ?(l= 1) () = 147 | let optional_original ?(l= 1) () = l in 148 | (let ppx_debug_file = 149 | let open Ppx_debug_runtime.Config in get_file (read ()) in 150 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 151 | ~ppx_debug_id:{ file = "test.ml"; id = 17; loc = ((13, 13), (13, 28)) } 152 | ~func:"optional"); 153 | ((let ppx_debug_file = 154 | let open Ppx_debug_runtime.Config in get_file (read ()) in 155 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 156 | ~ppx_debug_id:{ file = "test.ml"; id = 19; loc = ((13, 13), (13, 28)) } 157 | "l" l); 158 | ()); 159 | (let _res = optional_original ~l () in 160 | (let ppx_debug_file = 161 | let open Ppx_debug_runtime.Config in get_file (read ()) in 162 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 163 | ~ppx_debug_id:{ file = "test.ml"; id = 20; loc = ((13, 13), (13, 28)) } 164 | "_res" _res); 165 | (let ppx_debug_file = 166 | let open Ppx_debug_runtime.Config in get_file (read ()) in 167 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 168 | ~ppx_debug_id:{ file = "test.ml"; id = 18; loc = ((13, 13), (13, 28)) } 169 | ~func:"optional"); 170 | _res) 171 | let optional_opt ?l () = 172 | let optional_opt_original ?l () = l in 173 | (let ppx_debug_file = 174 | let open Ppx_debug_runtime.Config in get_file (read ()) in 175 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 176 | ~ppx_debug_id:{ file = "test.ml"; id = 21; loc = ((14, 17), (14, 26)) } 177 | ~func:"optional_opt"); 178 | ((let ppx_debug_file = 179 | let open Ppx_debug_runtime.Config in get_file (read ()) in 180 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 181 | ~ppx_debug_id:{ file = "test.ml"; id = 23; loc = ((14, 17), (14, 26)) } 182 | "l" l); 183 | ()); 184 | (let _res = optional_opt_original ?l () in 185 | (let ppx_debug_file = 186 | let open Ppx_debug_runtime.Config in get_file (read ()) in 187 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 188 | ~ppx_debug_id:{ file = "test.ml"; id = 24; loc = ((14, 17), (14, 26)) } 189 | "_res" _res); 190 | (let ppx_debug_file = 191 | let open Ppx_debug_runtime.Config in get_file (read ()) in 192 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 193 | ~ppx_debug_id:{ file = "test.ml"; id = 22; loc = ((14, 17), (14, 26)) } 194 | ~func:"optional_opt"); 195 | _res) 196 | let succ : int -> int = 197 | fun n -> 198 | let succ_original n = 199 | (let ppx_debug_file = 200 | let open Ppx_debug_runtime.Config in get_file (read ()) in 201 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 202 | ~ppx_debug_id:{ 203 | file = "test.ml"; 204 | id = 25; 205 | loc = ((15, 33), (15, 38)) 206 | } "bcall" "bcall" "(before)"); 207 | (let result__ = n + 1 in 208 | (let ppx_debug_file = 209 | let open Ppx_debug_runtime.Config in get_file (read ()) in 210 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 211 | ~ppx_debug_id:{ 212 | file = "test.ml"; 213 | id = 26; 214 | loc = ((15, 33), (15, 38)) 215 | } "acall" "acall" "(after)"); 216 | result__) in 217 | (let ppx_debug_file = 218 | let open Ppx_debug_runtime.Config in get_file (read ()) in 219 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 220 | ~ppx_debug_id:{ file = "test.ml"; id = 27; loc = ((15, 4), (15, 38)) } 221 | ~func:"succ"); 222 | ((let ppx_debug_file = 223 | let open Ppx_debug_runtime.Config in get_file (read ()) in 224 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 225 | ~ppx_debug_id:{ file = "test.ml"; id = 29; loc = ((15, 4), (15, 38)) 226 | } "n" n); 227 | ()); 228 | (let _res = succ_original n in 229 | (let ppx_debug_file = 230 | let open Ppx_debug_runtime.Config in get_file (read ()) in 231 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 232 | ~ppx_debug_id:{ file = "test.ml"; id = 30; loc = ((15, 4), (15, 38)) 233 | } "_res" _res); 234 | (let ppx_debug_file = 235 | let open Ppx_debug_runtime.Config in get_file (read ()) in 236 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 237 | ~ppx_debug_id:{ file = "test.ml"; id = 28; loc = ((15, 4), (15, 38)) 238 | } ~func:"succ"); 239 | _res) 240 | let rec ping : int -> int = 241 | fun n -> 242 | let ping_original _self n = 243 | match (let ppx_debug_file = 244 | let open Ppx_debug_runtime.Config in get_file (read ()) in 245 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 246 | ~ppx_debug_id:{ 247 | file = "test.ml"; 248 | id = 37; 249 | loc = ((17, 43), (17, 44)) 250 | } "match" "n" n); 251 | n 252 | with 253 | | 0 -> 254 | ((let ppx_debug_file = 255 | let open Ppx_debug_runtime.Config in get_file (read ()) in 256 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 257 | ~ppx_debug_id:{ 258 | file = "test.ml"; 259 | id = 31; 260 | loc = ((17, 55), (17, 56)) 261 | } "matchb" "matchb" "n"); 262 | 1) 263 | | _ -> 264 | ((let ppx_debug_file = 265 | let open Ppx_debug_runtime.Config in get_file (read ()) in 266 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 267 | ~ppx_debug_id:{ 268 | file = "test.ml"; 269 | id = 36; 270 | loc = ((17, 64), (17, 76)) 271 | } "matchb" "matchb" "n"); 272 | (let ppx_debug_file = 273 | let open Ppx_debug_runtime.Config in get_file (read ()) in 274 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 275 | ~ppx_debug_id:{ 276 | file = "test.ml"; 277 | id = 32; 278 | loc = ((17, 64), (17, 76)) 279 | } "bcall" "bcall" "(before)"); 280 | (let result__ = 281 | pong 282 | ((let ppx_debug_file = 283 | let open Ppx_debug_runtime.Config in get_file (read ()) in 284 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 285 | ~ppx_debug_id:{ 286 | file = "test.ml"; 287 | id = 34; 288 | loc = ((17, 69), (17, 76)) 289 | } "bcall" "bcall" "(before)"); 290 | (let result__ = n - 1 in 291 | (let ppx_debug_file = 292 | let open Ppx_debug_runtime.Config in get_file (read ()) in 293 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 294 | ~ppx_debug_id:{ 295 | file = "test.ml"; 296 | id = 35; 297 | loc = ((17, 69), (17, 76)) 298 | } "acall" "acall" "(after)"); 299 | result__)) in 300 | (let ppx_debug_file = 301 | let open Ppx_debug_runtime.Config in get_file (read ()) in 302 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 303 | ~ppx_debug_id:{ 304 | file = "test.ml"; 305 | id = 33; 306 | loc = ((17, 64), (17, 76)) 307 | } "acall" "acall" "(after)"); 308 | result__)) in 309 | let rec aux__ n = 310 | (let ppx_debug_file = 311 | let open Ppx_debug_runtime.Config in get_file (read ()) in 312 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 313 | ~ppx_debug_id:{ file = "test.ml"; id = 45; loc = ((17, 8), (17, 76)) 314 | } ~func:"ping"); 315 | ((let ppx_debug_file = 316 | let open Ppx_debug_runtime.Config in get_file (read ()) in 317 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 318 | ~ppx_debug_id:{ 319 | file = "test.ml"; 320 | id = 47; 321 | loc = ((17, 8), (17, 76)) 322 | } "n" n); 323 | ()); 324 | (let _res = ping_original aux__ n in 325 | (let ppx_debug_file = 326 | let open Ppx_debug_runtime.Config in get_file (read ()) in 327 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 328 | ~ppx_debug_id:{ 329 | file = "test.ml"; 330 | id = 48; 331 | loc = ((17, 8), (17, 76)) 332 | } "_res" _res); 333 | (let ppx_debug_file = 334 | let open Ppx_debug_runtime.Config in get_file (read ()) in 335 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 336 | ~ppx_debug_id:{ 337 | file = "test.ml"; 338 | id = 46; 339 | loc = ((17, 8), (17, 76)) 340 | } ~func:"ping"); 341 | _res) in 342 | aux__ n 343 | and pong : int -> int = 344 | fun n -> 345 | let pong_original _self n = 346 | match (let ppx_debug_file = 347 | let open Ppx_debug_runtime.Config in get_file (read ()) in 348 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 349 | ~ppx_debug_id:{ 350 | file = "test.ml"; 351 | id = 44; 352 | loc = ((18, 39), (18, 40)) 353 | } "match" "n" n); 354 | n 355 | with 356 | | 0 -> 357 | ((let ppx_debug_file = 358 | let open Ppx_debug_runtime.Config in get_file (read ()) in 359 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 360 | ~ppx_debug_id:{ 361 | file = "test.ml"; 362 | id = 38; 363 | loc = ((18, 51), (18, 52)) 364 | } "matchb" "matchb" "n"); 365 | 1) 366 | | _ -> 367 | ((let ppx_debug_file = 368 | let open Ppx_debug_runtime.Config in get_file (read ()) in 369 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 370 | ~ppx_debug_id:{ 371 | file = "test.ml"; 372 | id = 43; 373 | loc = ((18, 60), (18, 72)) 374 | } "matchb" "matchb" "n"); 375 | (let ppx_debug_file = 376 | let open Ppx_debug_runtime.Config in get_file (read ()) in 377 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 378 | ~ppx_debug_id:{ 379 | file = "test.ml"; 380 | id = 39; 381 | loc = ((18, 60), (18, 72)) 382 | } "bcall" "bcall" "(before)"); 383 | (let result__ = 384 | ping 385 | ((let ppx_debug_file = 386 | let open Ppx_debug_runtime.Config in get_file (read ()) in 387 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 388 | ~ppx_debug_id:{ 389 | file = "test.ml"; 390 | id = 41; 391 | loc = ((18, 65), (18, 72)) 392 | } "bcall" "bcall" "(before)"); 393 | (let result__ = n - 1 in 394 | (let ppx_debug_file = 395 | let open Ppx_debug_runtime.Config in get_file (read ()) in 396 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 397 | ~ppx_debug_id:{ 398 | file = "test.ml"; 399 | id = 42; 400 | loc = ((18, 65), (18, 72)) 401 | } "acall" "acall" "(after)"); 402 | result__)) in 403 | (let ppx_debug_file = 404 | let open Ppx_debug_runtime.Config in get_file (read ()) in 405 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 406 | ~ppx_debug_id:{ 407 | file = "test.ml"; 408 | id = 40; 409 | loc = ((18, 60), (18, 72)) 410 | } "acall" "acall" "(after)"); 411 | result__)) in 412 | let rec aux__ n = 413 | (let ppx_debug_file = 414 | let open Ppx_debug_runtime.Config in get_file (read ()) in 415 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 416 | ~ppx_debug_id:{ file = "test.ml"; id = 49; loc = ((18, 4), (18, 72)) 417 | } ~func:"pong"); 418 | ((let ppx_debug_file = 419 | let open Ppx_debug_runtime.Config in get_file (read ()) in 420 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 421 | ~ppx_debug_id:{ 422 | file = "test.ml"; 423 | id = 51; 424 | loc = ((18, 4), (18, 72)) 425 | } "n" n); 426 | ()); 427 | (let _res = pong_original aux__ n in 428 | (let ppx_debug_file = 429 | let open Ppx_debug_runtime.Config in get_file (read ()) in 430 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 431 | ~ppx_debug_id:{ 432 | file = "test.ml"; 433 | id = 52; 434 | loc = ((18, 4), (18, 72)) 435 | } "_res" _res); 436 | (let ppx_debug_file = 437 | let open Ppx_debug_runtime.Config in get_file (read ()) in 438 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 439 | ~ppx_debug_id:{ 440 | file = "test.ml"; 441 | id = 50; 442 | loc = ((18, 4), (18, 72)) 443 | } ~func:"pong"); 444 | _res) in 445 | aux__ n 446 | let ext = 447 | let rec ping1 : int -> int = 448 | fun n -> 449 | let ping1_original _self n = 450 | match (let ppx_debug_file = 451 | let open Ppx_debug_runtime.Config in get_file (read ()) in 452 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 453 | ~ppx_debug_id:{ 454 | file = "test.ml"; 455 | id = 59; 456 | loc = ((22, 18), (22, 19)) 457 | } "match" "n" n); 458 | n 459 | with 460 | | 0 -> 461 | ((let ppx_debug_file = 462 | let open Ppx_debug_runtime.Config in get_file (read ()) in 463 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 464 | ~ppx_debug_id:{ 465 | file = "test.ml"; 466 | id = 53; 467 | loc = ((22, 30), (22, 31)) 468 | } "matchb" "matchb" "n"); 469 | 1) 470 | | _ -> 471 | ((let ppx_debug_file = 472 | let open Ppx_debug_runtime.Config in get_file (read ()) in 473 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 474 | ~ppx_debug_id:{ 475 | file = "test.ml"; 476 | id = 58; 477 | loc = ((22, 39), (22, 52)) 478 | } "matchb" "matchb" "n"); 479 | (let ppx_debug_file = 480 | let open Ppx_debug_runtime.Config in get_file (read ()) in 481 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 482 | ~ppx_debug_id:{ 483 | file = "test.ml"; 484 | id = 54; 485 | loc = ((22, 39), (22, 52)) 486 | } "bcall" "bcall" "(before)"); 487 | (let result__ = 488 | pong1 489 | ((let ppx_debug_file = 490 | let open Ppx_debug_runtime.Config in get_file (read ()) in 491 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 492 | ~ppx_debug_id:{ 493 | file = "test.ml"; 494 | id = 56; 495 | loc = ((22, 45), (22, 52)) 496 | } "bcall" "bcall" "(before)"); 497 | (let result__ = n - 1 in 498 | (let ppx_debug_file = 499 | let open Ppx_debug_runtime.Config in 500 | get_file (read ()) in 501 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 502 | ~ppx_debug_id:{ 503 | file = "test.ml"; 504 | id = 57; 505 | loc = ((22, 45), (22, 52)) 506 | } "acall" "acall" "(after)"); 507 | result__)) in 508 | (let ppx_debug_file = 509 | let open Ppx_debug_runtime.Config in get_file (read ()) in 510 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 511 | ~ppx_debug_id:{ 512 | file = "test.ml"; 513 | id = 55; 514 | loc = ((22, 39), (22, 52)) 515 | } "acall" "acall" "(after)"); 516 | result__)) in 517 | let rec aux__ n = 518 | (let ppx_debug_file = 519 | let open Ppx_debug_runtime.Config in get_file (read ()) in 520 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 521 | ~ppx_debug_id:{ 522 | file = "test.ml"; 523 | id = 69; 524 | loc = ((21, 10), (22, 52)) 525 | } ~func:"ping1"); 526 | ((let ppx_debug_file = 527 | let open Ppx_debug_runtime.Config in get_file (read ()) in 528 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 529 | ~ppx_debug_id:{ 530 | file = "test.ml"; 531 | id = 71; 532 | loc = ((21, 10), (22, 52)) 533 | } "n" n); 534 | ()); 535 | (let _res = ping1_original aux__ n in 536 | (let ppx_debug_file = 537 | let open Ppx_debug_runtime.Config in get_file (read ()) in 538 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 539 | ~ppx_debug_id:{ 540 | file = "test.ml"; 541 | id = 72; 542 | loc = ((21, 10), (22, 52)) 543 | } "_res" _res); 544 | (let ppx_debug_file = 545 | let open Ppx_debug_runtime.Config in get_file (read ()) in 546 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 547 | ~ppx_debug_id:{ 548 | file = "test.ml"; 549 | id = 70; 550 | loc = ((21, 10), (22, 52)) 551 | } ~func:"ping1"); 552 | _res) in 553 | aux__ n 554 | and pong1 : int -> int = 555 | fun n -> 556 | let pong1_original _self n = 557 | match (let ppx_debug_file = 558 | let open Ppx_debug_runtime.Config in get_file (read ()) in 559 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 560 | ~ppx_debug_id:{ 561 | file = "test.ml"; 562 | id = 66; 563 | loc = ((24, 18), (24, 19)) 564 | } "match" "n" n); 565 | n 566 | with 567 | | 0 -> 568 | ((let ppx_debug_file = 569 | let open Ppx_debug_runtime.Config in get_file (read ()) in 570 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 571 | ~ppx_debug_id:{ 572 | file = "test.ml"; 573 | id = 60; 574 | loc = ((24, 30), (24, 31)) 575 | } "matchb" "matchb" "n"); 576 | 1) 577 | | _ -> 578 | ((let ppx_debug_file = 579 | let open Ppx_debug_runtime.Config in get_file (read ()) in 580 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 581 | ~ppx_debug_id:{ 582 | file = "test.ml"; 583 | id = 65; 584 | loc = ((24, 39), (24, 52)) 585 | } "matchb" "matchb" "n"); 586 | (let ppx_debug_file = 587 | let open Ppx_debug_runtime.Config in get_file (read ()) in 588 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 589 | ~ppx_debug_id:{ 590 | file = "test.ml"; 591 | id = 61; 592 | loc = ((24, 39), (24, 52)) 593 | } "bcall" "bcall" "(before)"); 594 | (let result__ = 595 | ping1 596 | ((let ppx_debug_file = 597 | let open Ppx_debug_runtime.Config in get_file (read ()) in 598 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 599 | ~ppx_debug_id:{ 600 | file = "test.ml"; 601 | id = 63; 602 | loc = ((24, 45), (24, 52)) 603 | } "bcall" "bcall" "(before)"); 604 | (let result__ = n - 1 in 605 | (let ppx_debug_file = 606 | let open Ppx_debug_runtime.Config in 607 | get_file (read ()) in 608 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 609 | ~ppx_debug_id:{ 610 | file = "test.ml"; 611 | id = 64; 612 | loc = ((24, 45), (24, 52)) 613 | } "acall" "acall" "(after)"); 614 | result__)) in 615 | (let ppx_debug_file = 616 | let open Ppx_debug_runtime.Config in get_file (read ()) in 617 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 618 | ~ppx_debug_id:{ 619 | file = "test.ml"; 620 | id = 62; 621 | loc = ((24, 39), (24, 52)) 622 | } "acall" "acall" "(after)"); 623 | result__)) in 624 | let rec aux__ n = 625 | (let ppx_debug_file = 626 | let open Ppx_debug_runtime.Config in get_file (read ()) in 627 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 628 | ~ppx_debug_id:{ 629 | file = "test.ml"; 630 | id = 73; 631 | loc = ((23, 6), (24, 52)) 632 | } ~func:"pong1"); 633 | ((let ppx_debug_file = 634 | let open Ppx_debug_runtime.Config in get_file (read ()) in 635 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 636 | ~ppx_debug_id:{ 637 | file = "test.ml"; 638 | id = 75; 639 | loc = ((23, 6), (24, 52)) 640 | } "n" n); 641 | ()); 642 | (let _res = pong1_original aux__ n in 643 | (let ppx_debug_file = 644 | let open Ppx_debug_runtime.Config in get_file (read ()) in 645 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 646 | ~ppx_debug_id:{ 647 | file = "test.ml"; 648 | id = 76; 649 | loc = ((23, 6), (24, 52)) 650 | } "_res" _res); 651 | (let ppx_debug_file = 652 | let open Ppx_debug_runtime.Config in get_file (read ()) in 653 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 654 | ~ppx_debug_id:{ 655 | file = "test.ml"; 656 | id = 74; 657 | loc = ((23, 6), (24, 52)) 658 | } ~func:"pong1"); 659 | _res) in 660 | aux__ n in 661 | (let ppx_debug_file = 662 | let open Ppx_debug_runtime.Config in get_file (read ()) in 663 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 664 | ~ppx_debug_id:{ file = "test.ml"; id = 67; loc = ((26, 2), (26, 9)) } 665 | "bcall" "bcall" "(before)"); 666 | (let result__ = ping1 2 in 667 | (let ppx_debug_file = 668 | let open Ppx_debug_runtime.Config in get_file (read ()) in 669 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 670 | ~ppx_debug_id:{ file = "test.ml"; id = 68; loc = ((26, 2), (26, 9)) } 671 | "acall" "acall" "(after)"); 672 | result__) 673 | let a f = 674 | let a_original f = 675 | let b f = 676 | let b_original f = 677 | let c f = 678 | let c_original f = f in 679 | (let ppx_debug_file = 680 | let open Ppx_debug_runtime.Config in get_file (read ()) in 681 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 682 | ~ppx_debug_id:{ 683 | file = "test.ml"; 684 | id = 79; 685 | loc = ((30, 10), (30, 15)) 686 | } ~func:"c"); 687 | ((let ppx_debug_file = 688 | let open Ppx_debug_runtime.Config in get_file (read ()) in 689 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 690 | ~ppx_debug_id:{ 691 | file = "test.ml"; 692 | id = 81; 693 | loc = ((30, 10), (30, 15)) 694 | } "f" f); 695 | ()); 696 | (let _res = c_original f in 697 | (let ppx_debug_file = 698 | let open Ppx_debug_runtime.Config in get_file (read ()) in 699 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 700 | ~ppx_debug_id:{ 701 | file = "test.ml"; 702 | id = 82; 703 | loc = ((30, 10), (30, 15)) 704 | } "_res" _res); 705 | (let ppx_debug_file = 706 | let open Ppx_debug_runtime.Config in get_file (read ()) in 707 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 708 | ~ppx_debug_id:{ 709 | file = "test.ml"; 710 | id = 80; 711 | loc = ((30, 10), (30, 15)) 712 | } ~func:"c"); 713 | _res) in 714 | (let ppx_debug_file = 715 | let open Ppx_debug_runtime.Config in get_file (read ()) in 716 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 717 | ~ppx_debug_id:{ 718 | file = "test.ml"; 719 | id = 77; 720 | loc = ((31, 4), (31, 7)) 721 | } "bcall" "bcall" "(before)"); 722 | (let result__ = c f in 723 | (let ppx_debug_file = 724 | let open Ppx_debug_runtime.Config in get_file (read ()) in 725 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 726 | ~ppx_debug_id:{ 727 | file = "test.ml"; 728 | id = 78; 729 | loc = ((31, 4), (31, 7)) 730 | } "acall" "acall" "(after)"); 731 | result__) in 732 | (let ppx_debug_file = 733 | let open Ppx_debug_runtime.Config in get_file (read ()) in 734 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 735 | ~ppx_debug_id:{ file = "test.ml"; id = 85; loc = ((29, 8), (31, 7)) 736 | } ~func:"b"); 737 | ((let ppx_debug_file = 738 | let open Ppx_debug_runtime.Config in get_file (read ()) in 739 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 740 | ~ppx_debug_id:{ file = "test.ml"; id = 87; loc = ((29, 8), (31, 7)) 741 | } "f" f); 742 | ()); 743 | (let _res = b_original f in 744 | (let ppx_debug_file = 745 | let open Ppx_debug_runtime.Config in get_file (read ()) in 746 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 747 | ~ppx_debug_id:{ file = "test.ml"; id = 88; loc = ((29, 8), (31, 7)) 748 | } "_res" _res); 749 | (let ppx_debug_file = 750 | let open Ppx_debug_runtime.Config in get_file (read ()) in 751 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 752 | ~ppx_debug_id:{ file = "test.ml"; id = 86; loc = ((29, 8), (31, 7)) 753 | } ~func:"b"); 754 | _res) in 755 | (let ppx_debug_file = 756 | let open Ppx_debug_runtime.Config in get_file (read ()) in 757 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 758 | ~ppx_debug_id:{ file = "test.ml"; id = 83; loc = ((33, 2), (33, 5)) } 759 | "bcall" "bcall" "(before)"); 760 | (let result__ = b f in 761 | (let ppx_debug_file = 762 | let open Ppx_debug_runtime.Config in get_file (read ()) in 763 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 764 | ~ppx_debug_id:{ file = "test.ml"; id = 84; loc = ((33, 2), (33, 5)) } 765 | "acall" "acall" "(after)"); 766 | result__) in 767 | (let ppx_debug_file = 768 | let open Ppx_debug_runtime.Config in get_file (read ()) in 769 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 770 | ~ppx_debug_id:{ file = "test.ml"; id = 89; loc = ((28, 6), (33, 5)) } 771 | ~func:"a"); 772 | ((let ppx_debug_file = 773 | let open Ppx_debug_runtime.Config in get_file (read ()) in 774 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 775 | ~ppx_debug_id:{ file = "test.ml"; id = 91; loc = ((28, 6), (33, 5)) } 776 | "f" f); 777 | ()); 778 | (let _res = a_original f in 779 | (let ppx_debug_file = 780 | let open Ppx_debug_runtime.Config in get_file (read ()) in 781 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 782 | ~ppx_debug_id:{ file = "test.ml"; id = 92; loc = ((28, 6), (33, 5)) } 783 | "_res" _res); 784 | (let ppx_debug_file = 785 | let open Ppx_debug_runtime.Config in get_file (read ()) in 786 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 787 | ~ppx_debug_id:{ file = "test.ml"; id = 90; loc = ((28, 6), (33, 5)) } 788 | ~func:"a"); 789 | _res) 790 | let sum = 791 | (let ppx_debug_file = 792 | let open Ppx_debug_runtime.Config in get_file (read ()) in 793 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 794 | ~ppx_debug_id:{ file = "test.ml"; id = 93; loc = ((35, 10), (35, 56)) } 795 | "bcall" "bcall" "(before)"); 796 | (let result__ = 797 | List.fold_right 798 | (fun c -> 799 | fun t -> 800 | let _lambda_original c t = 801 | (let ppx_debug_file = 802 | let open Ppx_debug_runtime.Config in get_file (read ()) in 803 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 804 | ~ppx_debug_id:{ 805 | file = "test.ml"; 806 | id = 95; 807 | loc = ((35, 38), (35, 43)) 808 | } "bcall" "bcall" "(before)"); 809 | (let result__ = c + t in 810 | (let ppx_debug_file = 811 | let open Ppx_debug_runtime.Config in get_file (read ()) in 812 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 813 | ~ppx_debug_id:{ 814 | file = "test.ml"; 815 | id = 96; 816 | loc = ((35, 38), (35, 43)) 817 | } "acall" "acall" "(after)"); 818 | result__) in 819 | (let ppx_debug_file = 820 | let open Ppx_debug_runtime.Config in get_file (read ()) in 821 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 822 | ~ppx_debug_id:{ 823 | file = "test.ml"; 824 | id = 97; 825 | loc = ((35, 26), (35, 44)) 826 | } ~func:"_lambda"); 827 | ((let ppx_debug_file = 828 | let open Ppx_debug_runtime.Config in get_file (read ()) in 829 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 830 | ~ppx_debug_id:{ 831 | file = "test.ml"; 832 | id = 99; 833 | loc = ((35, 26), (35, 44)) 834 | } "c" c); 835 | (let ppx_debug_file = 836 | let open Ppx_debug_runtime.Config in get_file (read ()) in 837 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 838 | ~ppx_debug_id:{ 839 | file = "test.ml"; 840 | id = 100; 841 | loc = ((35, 26), (35, 44)) 842 | } "t" t); 843 | ()); 844 | (let _res = _lambda_original c t in 845 | (let ppx_debug_file = 846 | let open Ppx_debug_runtime.Config in get_file (read ()) in 847 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 848 | ~ppx_debug_id:{ 849 | file = "test.ml"; 850 | id = 101; 851 | loc = ((35, 26), (35, 44)) 852 | } "_res" _res); 853 | (let ppx_debug_file = 854 | let open Ppx_debug_runtime.Config in get_file (read ()) in 855 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 856 | ~ppx_debug_id:{ 857 | file = "test.ml"; 858 | id = 98; 859 | loc = ((35, 26), (35, 44)) 860 | } ~func:"_lambda"); 861 | _res)) [1; 2; 3] 0 in 862 | (let ppx_debug_file = 863 | let open Ppx_debug_runtime.Config in get_file (read ()) in 864 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 865 | ~ppx_debug_id:{ file = "test.ml"; id = 94; loc = ((35, 10), (35, 56)) } 866 | "acall" "acall" "(after)"); 867 | result__) 868 | let z = 869 | (let ppx_debug_file = 870 | let open Ppx_debug_runtime.Config in get_file (read ()) in 871 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 872 | ~ppx_debug_id:{ file = "test.ml"; id = 102; loc = ((38, 2), (42, 13)) } 873 | "bcall" "bcall" "(before)"); 874 | (let result__ = 875 | List.map 876 | (fun a -> 877 | let _lambda_original a = 878 | let f x = 879 | let f_original x = x in 880 | (let ppx_debug_file = 881 | let open Ppx_debug_runtime.Config in get_file (read ()) in 882 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 883 | ~ppx_debug_id:{ 884 | file = "test.ml"; 885 | id = 106; 886 | loc = ((40, 12), (40, 17)) 887 | } ~func:"f"); 888 | ((let ppx_debug_file = 889 | let open Ppx_debug_runtime.Config in get_file (read ()) in 890 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 891 | ~ppx_debug_id:{ 892 | file = "test.ml"; 893 | id = 108; 894 | loc = ((40, 12), (40, 17)) 895 | } "x" x); 896 | ()); 897 | (let _res = f_original x in 898 | (let ppx_debug_file = 899 | let open Ppx_debug_runtime.Config in get_file (read ()) in 900 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 901 | ~ppx_debug_id:{ 902 | file = "test.ml"; 903 | id = 109; 904 | loc = ((40, 12), (40, 17)) 905 | } "_res" _res); 906 | (let ppx_debug_file = 907 | let open Ppx_debug_runtime.Config in get_file (read ()) in 908 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 909 | ~ppx_debug_id:{ 910 | file = "test.ml"; 911 | id = 107; 912 | loc = ((40, 12), (40, 17)) 913 | } ~func:"f"); 914 | _res) in 915 | (let ppx_debug_file = 916 | let open Ppx_debug_runtime.Config in get_file (read ()) in 917 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 918 | ~ppx_debug_id:{ 919 | file = "test.ml"; 920 | id = 104; 921 | loc = ((41, 6), (41, 9)) 922 | } "bcall" "bcall" "(before)"); 923 | (let result__ = f a in 924 | (let ppx_debug_file = 925 | let open Ppx_debug_runtime.Config in get_file (read ()) in 926 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 927 | ~ppx_debug_id:{ 928 | file = "test.ml"; 929 | id = 105; 930 | loc = ((41, 6), (41, 9)) 931 | } "acall" "acall" "(after)"); 932 | result__) in 933 | (let ppx_debug_file = 934 | let open Ppx_debug_runtime.Config in get_file (read ()) in 935 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 936 | ~ppx_debug_id:{ 937 | file = "test.ml"; 938 | id = 110; 939 | loc = ((39, 4), (41, 10)) 940 | } ~func:"_lambda"); 941 | ((let ppx_debug_file = 942 | let open Ppx_debug_runtime.Config in get_file (read ()) in 943 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 944 | ~ppx_debug_id:{ 945 | file = "test.ml"; 946 | id = 112; 947 | loc = ((39, 4), (41, 10)) 948 | } "a" a); 949 | ()); 950 | (let _res = _lambda_original a in 951 | (let ppx_debug_file = 952 | let open Ppx_debug_runtime.Config in get_file (read ()) in 953 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 954 | ~ppx_debug_id:{ 955 | file = "test.ml"; 956 | id = 113; 957 | loc = ((39, 4), (41, 10)) 958 | } "_res" _res); 959 | (let ppx_debug_file = 960 | let open Ppx_debug_runtime.Config in get_file (read ()) in 961 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 962 | ~ppx_debug_id:{ 963 | file = "test.ml"; 964 | id = 111; 965 | loc = ((39, 4), (41, 10)) 966 | } ~func:"_lambda"); 967 | _res)) [1; 2; 3] in 968 | (let ppx_debug_file = 969 | let open Ppx_debug_runtime.Config in get_file (read ()) in 970 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 971 | ~ppx_debug_id:{ file = "test.ml"; id = 103; loc = ((38, 2), (42, 13)) } 972 | "acall" "acall" "(after)"); 973 | result__) 974 | let a () = 975 | let a_original () = 976 | let x = 1 in 977 | let ppx_debug_file = 978 | let open Ppx_debug_runtime.Config in get_file (read ()) in 979 | Ppx_debug_runtime.Trace.emit_value ~ppx_debug_file 980 | ~ppx_debug_id:{ file = "test.ml"; id = 114; loc = ((46, 2), (46, 12)) } 981 | "x" x in 982 | (let ppx_debug_file = 983 | let open Ppx_debug_runtime.Config in get_file (read ()) in 984 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 985 | ~ppx_debug_id:{ file = "test.ml"; id = 115; loc = ((44, 6), (46, 12)) } 986 | ~func:"a"); 987 | (); 988 | (let _res = a_original () in 989 | (let ppx_debug_file = 990 | let open Ppx_debug_runtime.Config in get_file (read ()) in 991 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 992 | ~ppx_debug_id:{ file = "test.ml"; id = 117; loc = ((44, 6), (46, 12)) } 993 | "_res" _res); 994 | (let ppx_debug_file = 995 | let open Ppx_debug_runtime.Config in get_file (read ()) in 996 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 997 | ~ppx_debug_id:{ file = "test.ml"; id = 116; loc = ((44, 6), (46, 12)) } 998 | ~func:"a"); 999 | _res) 1000 | let lambda_unhandled () = 1001 | let lambda_unhandled_original () = 1002 | (let ppx_debug_file = 1003 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1004 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1005 | ~ppx_debug_id:{ file = "test.ml"; id = 118; loc = ((48, 26), (48, 65)) 1006 | } "bcall" "bcall" "(before)"); 1007 | (let result__ = List.map (fun (a, b) -> a + b) [(1, 2)] in 1008 | (let ppx_debug_file = 1009 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1010 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1011 | ~ppx_debug_id:{ 1012 | file = "test.ml"; 1013 | id = 119; 1014 | loc = ((48, 26), (48, 65)) 1015 | } "acall" "acall" "(after)"); 1016 | result__) in 1017 | (let ppx_debug_file = 1018 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1019 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 1020 | ~ppx_debug_id:{ file = "test.ml"; id = 120; loc = ((48, 21), (48, 65)) } 1021 | ~func:"lambda_unhandled"); 1022 | (); 1023 | (let _res = lambda_unhandled_original () in 1024 | (let ppx_debug_file = 1025 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1026 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1027 | ~ppx_debug_id:{ file = "test.ml"; id = 122; loc = ((48, 21), (48, 65)) 1028 | } "_res" _res); 1029 | (let ppx_debug_file = 1030 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1031 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 1032 | ~ppx_debug_id:{ file = "test.ml"; id = 121; loc = ((48, 21), (48, 65)) 1033 | } ~func:"lambda_unhandled"); 1034 | _res) 1035 | let keep_type_annotations (t : int) = 1036 | let keep_type_annotations_original (t : int) = t in 1037 | (let ppx_debug_file = 1038 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1039 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 1040 | ~ppx_debug_id:{ file = "test.ml"; id = 123; loc = ((49, 26), (49, 39)) } 1041 | ~func:"keep_type_annotations"); 1042 | ((let ppx_debug_file = 1043 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1044 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1045 | ~ppx_debug_id:{ file = "test.ml"; id = 125; loc = ((49, 26), (49, 39)) 1046 | } "t" t); 1047 | ()); 1048 | (let _res = keep_type_annotations_original t in 1049 | (let ppx_debug_file = 1050 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1051 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1052 | ~ppx_debug_id:{ file = "test.ml"; id = 126; loc = ((49, 26), (49, 39)) 1053 | } "_res" _res); 1054 | (let ppx_debug_file = 1055 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1056 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 1057 | ~ppx_debug_id:{ file = "test.ml"; id = 124; loc = ((49, 26), (49, 39)) 1058 | } ~func:"keep_type_annotations"); 1059 | _res) 1060 | let obj n = 1061 | let obj_original n = 1062 | let a = 1063 | object 1064 | method f x = 1065 | let f_original x = 1066 | (let ppx_debug_file = 1067 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1068 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1069 | ~ppx_debug_id:{ 1070 | file = "test.ml"; 1071 | id = 127; 1072 | loc = ((54, 19), (54, 24)) 1073 | } "bcall" "bcall" "(before)"); 1074 | (let result__ = x + 1 in 1075 | (let ppx_debug_file = 1076 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1077 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1078 | ~ppx_debug_id:{ 1079 | file = "test.ml"; 1080 | id = 128; 1081 | loc = ((54, 19), (54, 24)) 1082 | } "acall" "acall" "(after)"); 1083 | result__) in 1084 | (let ppx_debug_file = 1085 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1086 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 1087 | ~ppx_debug_id:{ 1088 | file = "test.ml"; 1089 | id = 129; 1090 | loc = ((54, 15), (54, 24)) 1091 | } ~func:"f"); 1092 | ((let ppx_debug_file = 1093 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1094 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1095 | ~ppx_debug_id:{ 1096 | file = "test.ml"; 1097 | id = 131; 1098 | loc = ((54, 15), (54, 24)) 1099 | } "x" x); 1100 | ()); 1101 | (let _res = f_original x in 1102 | (let ppx_debug_file = 1103 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1104 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1105 | ~ppx_debug_id:{ 1106 | file = "test.ml"; 1107 | id = 132; 1108 | loc = ((54, 15), (54, 24)) 1109 | } "_res" _res); 1110 | (let ppx_debug_file = 1111 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1112 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 1113 | ~ppx_debug_id:{ 1114 | file = "test.ml"; 1115 | id = 130; 1116 | loc = ((54, 15), (54, 24)) 1117 | } ~func:"f"); 1118 | _res) 1119 | end in 1120 | (let ppx_debug_file = 1121 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1122 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1123 | ~ppx_debug_id:{ file = "test.ml"; id = 133; loc = ((57, 2), (57, 13)) 1124 | } "bcall" "bcall" "(before)"); 1125 | (let result__ = 1126 | a#f 1127 | ((let ppx_debug_file = 1128 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1129 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1130 | ~ppx_debug_id:{ 1131 | file = "test.ml"; 1132 | id = 135; 1133 | loc = ((57, 6), (57, 13)) 1134 | } "bcall" "bcall" "(before)"); 1135 | (let result__ = 2 + n in 1136 | (let ppx_debug_file = 1137 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1138 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1139 | ~ppx_debug_id:{ 1140 | file = "test.ml"; 1141 | id = 136; 1142 | loc = ((57, 6), (57, 13)) 1143 | } "acall" "acall" "(after)"); 1144 | result__)) in 1145 | (let ppx_debug_file = 1146 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1147 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1148 | ~ppx_debug_id:{ file = "test.ml"; id = 134; loc = ((57, 2), (57, 13)) 1149 | } "acall" "acall" "(after)"); 1150 | result__) in 1151 | (let ppx_debug_file = 1152 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1153 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 1154 | ~ppx_debug_id:{ file = "test.ml"; id = 137; loc = ((51, 8), (57, 13)) } 1155 | ~func:"obj"); 1156 | ((let ppx_debug_file = 1157 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1158 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1159 | ~ppx_debug_id:{ file = "test.ml"; id = 139; loc = ((51, 8), (57, 13)) } 1160 | "n" n); 1161 | ()); 1162 | (let _res = obj_original n in 1163 | (let ppx_debug_file = 1164 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1165 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1166 | ~ppx_debug_id:{ file = "test.ml"; id = 140; loc = ((51, 8), (57, 13)) } 1167 | "_res" _res); 1168 | (let ppx_debug_file = 1169 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1170 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 1171 | ~ppx_debug_id:{ file = "test.ml"; id = 138; loc = ((51, 8), (57, 13)) } 1172 | ~func:"obj"); 1173 | _res) 1174 | class virtual clz = 1175 | object 1176 | method g x = 1177 | let g_original x = 1178 | (let ppx_debug_file = 1179 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1180 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1181 | ~ppx_debug_id:{ 1182 | file = "test.ml"; 1183 | id = 141; 1184 | loc = ((61, 17), (61, 22)) 1185 | } "bcall" "bcall" "(before)"); 1186 | (let result__ = x * 2 in 1187 | (let ppx_debug_file = 1188 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1189 | Ppx_debug_runtime.Trace.emit_raw ~ppx_debug_file 1190 | ~ppx_debug_id:{ 1191 | file = "test.ml"; 1192 | id = 142; 1193 | loc = ((61, 17), (61, 22)) 1194 | } "acall" "acall" "(after)"); 1195 | result__) in 1196 | (let ppx_debug_file = 1197 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1198 | Ppx_debug_runtime.Trace.emit_start ~ppx_debug_file 1199 | ~ppx_debug_id:{ 1200 | file = "test.ml"; 1201 | id = 143; 1202 | loc = ((61, 13), (61, 22)) 1203 | } ~func:"g"); 1204 | ((let ppx_debug_file = 1205 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1206 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1207 | ~ppx_debug_id:{ 1208 | file = "test.ml"; 1209 | id = 145; 1210 | loc = ((61, 13), (61, 22)) 1211 | } "x" x); 1212 | ()); 1213 | (let _res = g_original x in 1214 | (let ppx_debug_file = 1215 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1216 | Ppx_debug_runtime.Trace.emit_argument ~ppx_debug_file 1217 | ~ppx_debug_id:{ 1218 | file = "test.ml"; 1219 | id = 146; 1220 | loc = ((61, 13), (61, 22)) 1221 | } "_res" _res); 1222 | (let ppx_debug_file = 1223 | let open Ppx_debug_runtime.Config in get_file (read ()) in 1224 | Ppx_debug_runtime.Trace.emit_end ~ppx_debug_file 1225 | ~ppx_debug_id:{ 1226 | file = "test.ml"; 1227 | id = 144; 1228 | loc = ((61, 13), (61, 22)) 1229 | } ~func:"g"); 1230 | _res) 1231 | end 1232 | -------------------------------------------------------------------------------- /test/pp/dune: -------------------------------------------------------------------------------- 1 | ; a standalone driver 2 | 3 | (executable 4 | (name pp) 5 | (modules pp) 6 | (libraries ppx_debug ppxlib)) 7 | -------------------------------------------------------------------------------- /test/pp/pp.ml: -------------------------------------------------------------------------------- 1 | ;; 2 | Ppxlib.Driver.standalone () 3 | -------------------------------------------------------------------------------- /test/test.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dariusf/ppx_debug/f5d51b29d5e466601c0f861e3fd7431ca6e5aa4a/test/test.expected -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-34-37"] 2 | 3 | let value = 1 4 | let rec fact n = match n with 0 -> 1 | n -> n * fact (n - 1) 5 | let _ = fun () -> () 6 | 7 | type v = Root of { value : int } 8 | 9 | (* TODO not capture-avoiding *) 10 | (* let value (Root { value }) = value *) 11 | 12 | let labelled ~l () = l 13 | let optional ?(l = 1) () = l 14 | let optional_opt ?l () = l 15 | let succ : int -> int = fun n -> n + 1 16 | 17 | let rec ping : int -> int = fun n -> match n with 0 -> 1 | _ -> pong (n - 1) 18 | and pong : int -> int = fun n -> match n with 0 -> 1 | _ -> ping (n - 1) 19 | 20 | let ext = 21 | let rec ping1 : int -> int = 22 | fun n -> match n with 0 -> 1 | _ -> pong1 (n - 1) 23 | and pong1 : int -> int = 24 | fun n -> match n with 0 -> 1 | _ -> ping1 (n - 1) 25 | in 26 | ping1 2 27 | 28 | let a f = 29 | let b f = 30 | let c f = f in 31 | c f 32 | in 33 | b f 34 | 35 | let sum = List.fold_right (fun c t -> c + t) [1; 2; 3] 0 36 | 37 | let z = 38 | List.map 39 | (fun a -> 40 | let f x = x in 41 | f a) 42 | [1; 2; 3] 43 | 44 | let a () = 45 | let x = 1 in 46 | [%trace x] 47 | 48 | let lambda_unhandled () = List.map (fun (a, b) -> a + b) [(1, 2)] 49 | let keep_type_annotations (t : int) = t 50 | 51 | let obj n = 52 | let a = 53 | object 54 | method f x = x + 1 55 | end 56 | in 57 | a#f (2 + n) 58 | 59 | class virtual clz = 60 | object 61 | method g x = x * 2 62 | end 63 | --------------------------------------------------------------------------------