├── dune-project ├── .gitignore ├── src ├── test │ ├── dune │ ├── Test.ml │ └── Test_trax.ml └── lib │ ├── dune │ ├── Trax.mli │ └── Trax.ml ├── Makefile ├── .circleci └── config.yml ├── trax.opam ├── .ocp-indent ├── LICENSE └── README.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name trax) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _build 3 | .merlin 4 | *.install 5 | -------------------------------------------------------------------------------- /src/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name Test) 3 | (libraries 4 | trax 5 | alcotest 6 | re 7 | ) 8 | ) 9 | -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trax) 3 | (public_name trax) 4 | (synopsis "Stack-independent exception tracing") 5 | ) 6 | -------------------------------------------------------------------------------- /src/test/Test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Entrypoint to run the unit tests from the command line. 3 | *) 4 | 5 | let test_suites : unit Alcotest.test list = [ 6 | "Trax", Test_trax.tests; 7 | ] 8 | 9 | let main () = Alcotest.run "trax" test_suites 10 | 11 | let () = main () 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | dune build @install 4 | 5 | .PHONY: test 6 | test: 7 | dune build src/test/Test.exe 8 | ./_build/default/src/test/Test.exe 9 | 10 | .PHONY: install 11 | install: 12 | dune install 13 | 14 | .PHONY: uninstall 15 | uninstall: 16 | dune uninstall 17 | 18 | .PHONY: clean 19 | clean: 20 | dune clean 21 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | # 2 | # Circle CI configuration. Runs each time we push a new commit to Github. 3 | # 4 | version: 2.1 5 | 6 | jobs: 7 | build: 8 | docker: 9 | - image: mjambon/mj-ocaml:alpine 10 | working_directory: ~/dune-deps 11 | steps: 12 | - checkout 13 | - run: 14 | name: Build 15 | command: opam exec -- make 16 | - run: 17 | name: Test 18 | command: opam exec -- make test 19 | -------------------------------------------------------------------------------- /trax.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "martin@mjambon.com" 3 | authors: ["Martin Jambon"] 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/mjambon/trax" 6 | bug-reports: "https://github.com/mjambon/trax/issues" 7 | dev-repo: "git+https://github.com/mjambon/trax.git" 8 | build: [ 9 | ["dune" "build" "-p" name "-j" jobs] 10 | ] 11 | depends: [ 12 | "ocaml" {>= "4.08.0"} 13 | "dune" {build} 14 | ] 15 | synopsis: "Stack-independent exception tracing" 16 | description: 17 | "Trax defines a special exception, which is used to store a trace of where the exception was raised and re-raised. This is done independently from the state of the call stack. It can be used with Lwt or other asynchronous computations in which exceptions no longer propagate simply to the calling function but may be caught, stored, and re-raised after a while and after other exceptions have occurred in unrelated computations." 18 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | # See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more 2 | 3 | # Indent for clauses inside a pattern-match (after the arrow): 4 | # match foo with 5 | # | _ -> 6 | # ^^^^bar 7 | # the default is 2, which aligns the pattern and the expression 8 | match_clause = 4 9 | 10 | # When nesting expressions on the same line, their indentation are in 11 | # some cases stacked, so that it remains correct if you close them one 12 | # at a line. This may lead to large indents in complex code though, so 13 | # this parameter can be used to set a maximum value. Note that it only 14 | # affects indentation after function arrows and opening parens at end 15 | # of line. 16 | # 17 | # for example (left: `none`; right: `4`) 18 | # let f = g (h (i (fun x -> # let f = g (h (i (fun x -> 19 | # x) # x) 20 | # ) # ) 21 | # ) # ) 22 | max_indent = 2 23 | -------------------------------------------------------------------------------- /src/test/Test_trax.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Unit tests for Trax 3 | 4 | There are not too many tests because we can't guarantee that 5 | stack backtraces won't change from one version of ocaml to another. 6 | *) 7 | 8 | let rec grow_stack n = 9 | if n > 0 then 10 | let _, res = grow_stack (n - 1) in 11 | n, res 12 | else 13 | n, Printexc.get_callstack max_int 14 | 15 | let test_deduplicate_trace () = 16 | let _n, raw = grow_stack 10 in 17 | let trace = Trax.raw_backtrace_to_string raw in 18 | print_string trace; 19 | let re = Re.str "... (skipping 9 duplicates)\n" |> Re.compile in 20 | match Re.matches re trace with 21 | | [_] -> () 22 | | [] -> Alcotest.fail "no matches, should have found one" 23 | | _ -> Alcotest.fail "multiple matches, should have found one" 24 | 25 | let test_manual_trace () = 26 | try 27 | Trax.raise "location 1" (Failure "uh oh") 28 | with e -> 29 | try 30 | Trax.raise "location 2" e 31 | with e -> 32 | let expected = "\ 33 | Failure(\"uh oh\") 34 | location 1 35 | location 2" 36 | in 37 | Alcotest.(check string) "equal" expected (Trax.to_string e) 38 | 39 | let tests = [ 40 | "deduplicate trace", `Quick, test_deduplicate_trace; 41 | "manual trace", `Quick, test_manual_trace; 42 | ] 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Martin Jambon 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /src/lib/Trax.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Trax: library for creating custom execution traces beyond just a single 3 | stack backtrace. 4 | *) 5 | 6 | (** The type of locations that make up the exception trace *) 7 | type location = Text of string 8 | | Raw_backtrace of Printexc.raw_backtrace 9 | 10 | (** Any exception and its trace *) 11 | exception Traced of exn * location list 12 | 13 | (** Add location to this exception's trace. 14 | If the input exception is not already wrapped, it gets wrapped into 15 | a [Traced] exception. If the original exception is already wrapped 16 | in a [Traced] exception, it gets unwrapped and rewrapped with 17 | the new, extended trace. 18 | 19 | Wrapping and unwrapping is not nested: calling 20 | [wrap loc (wrap loc e)] creates a single [Traced (e, ...)] node, 21 | not [Traced (Traced (e, ...), ...)]. 22 | *) 23 | val wrap : location -> exn -> exn 24 | 25 | (** Recover the original exception, for inspection purposes. 26 | For instance [Traced(Not_found, [...])] would become [Not_found]. *) 27 | val unwrap : exn -> exn 28 | 29 | (** Wrap an exception with the current exception backtrace 30 | (stack trace recorded at the point where 31 | the exception was raised, assuming no other exception was raised 32 | in-between). This is only guaranteed to work 33 | right after catching an exception with a try-with. *) 34 | val wrap_with_stack_trace : exn -> exn 35 | 36 | (** Raise or reraise an exception after adding a location to its trace. *) 37 | val raise_at : location -> exn -> 'a 38 | 39 | (** Raise or reraise an exception after adding a text location 40 | to its trace. Typical usage is [Trax.raise __LOC__ e]. *) 41 | val raise : string -> exn -> 'a 42 | 43 | (** Re-raise an exception after wrapping it with the current 44 | exception backtrace (stack trace recorded at the point where 45 | the exception was raised, assuming no other exception was raised 46 | in-between). This is only guaranteed to work 47 | right after catching an exception with a try-with. *) 48 | val reraise_with_stack_trace : exn -> 'a 49 | 50 | (** Convert a stack trace to readable lines. Duplicate lines are omitted 51 | and replaced by '...' or similar. 52 | 53 | This is a replacement for Printexc.raw_backtrace_to_string. *) 54 | val raw_backtrace_to_string : Printexc.raw_backtrace -> string 55 | 56 | (** Format the exception and its trace into text. *) 57 | val to_string : exn -> string 58 | 59 | (** Format the trace extracted from the exception into text. *) 60 | val get_trace : exn -> string 61 | 62 | (** Print the exception and its trace. *) 63 | val print : out_channel -> exn -> unit 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml exception tracing [![CircleCI badge](https://circleci.com/gh/mjambon/trax.svg?style=svg)](https://app.circleci.com/pipelines/github/mjambon/trax) 2 | == 3 | 4 | This small library is useful in OCaml programs that for some reason 5 | catch exceptions in one spot and reraise them later. 6 | 7 | The goal is to produce a useful _execution trace_ that tells the story 8 | of what code was executed and led to the error. 9 | 10 | While catching exceptions indiscriminately and reraising them later 11 | should generally be avoided if possible, there are cases where it is 12 | useful. Such cases include: 13 | 14 | * computation is sequential but possibly interleaved with other computations 15 | using many callbacks (promises, continuation-passing style). 16 | * execution of as many independent jobs as possible without 17 | failing. In such case, catching exceptions for each job and 18 | capturing a stack trace may be sufficient. If an exception is 19 | caught early and reraised at the very end, then this library may be 20 | useful. 21 | * code in which exception handling was not thought out well. 22 | 23 | For context, some examples of what works and what doesn't work with 24 | stack traces are given here: https://github.com/mjambon/backtrace 25 | 26 | API documentation 27 | -- 28 | 29 | See [`src/Trax.mli`](https://github.com/mjambon/trax/blob/master/src/lib/Trax.mli). 30 | 31 | Example 1: roll-your-own trace, no actual stack backtrace 32 | -- 33 | 34 | The following shows that we can add code locations to construct our 35 | own trace. This doesn't rely on recording stack backtraces. 36 | 37 | ```ocaml 38 | let foo x y z = 39 | ... 40 | (* some error occurred: add current location to the trace *) 41 | Trax.raise __LOC__ (Failure "uh oh") 42 | 43 | let bar x y z = 44 | try foo x y z 45 | with e -> 46 | (* inspect the exception; requires unwrapping *) 47 | match Trax.unwrap e with 48 | | Invalid_arg _ -> 49 | assert false 50 | | _ -> 51 | (* re-raise the exception, adding the current location to the trace *) 52 | Trax.raise __LOC__ e 53 | 54 | let main () = 55 | try 56 | ... 57 | bar x y z 58 | ... 59 | with e -> 60 | Trax.print stderr e 61 | ``` 62 | 63 | Example 2: catch exception and stack backtrace, re-raise it later 64 | -- 65 | 66 | The following relies on recording a stack backtrace using OCaml's 67 | `Printexc` module. In this case, an exception catch-all captures the 68 | stack trace as well and stores it with the exception. 69 | 70 | ```ocaml 71 | let foo x = 72 | ... 73 | (* Raise (Failure "uh oh") normally *) 74 | failwith "uh oh" 75 | 76 | let bar x = 77 | try Ok (foo x) 78 | with e -> 79 | (* Catch-all, records stack backtrace *) 80 | Error (Trax.wrap_with_stack_trace e) 81 | 82 | let split_results (res_list : ('a, 'b) Result.t list): 'a list * 'b list = 83 | let ok, errors = 84 | List.fold_left (fun (ok, errors) res -> 85 | match res with 86 | | Ok x -> (x :: ok, errors) 87 | | Error x -> (ok, x :: errors) 88 | ) ([], []) res_list 89 | in 90 | List.rev ok, List.rev errors 91 | 92 | let main () = 93 | Printexc.record_backtrace (); 94 | try 95 | ... 96 | let results = List.map bar jobs in 97 | let ok, errors = split_results results in 98 | (* Re-raise the first error, if any *) 99 | List.iter raise errors; 100 | ... 101 | with e -> 102 | (* Capture latest stack trace and append it to this exception's trace *) 103 | Trax.wrap_with_stack_trace e 104 | |> Trax.print stderr 105 | ``` 106 | -------------------------------------------------------------------------------- /src/lib/Trax.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Capture stack trace when catching an exception and make sure to 3 | not lose it. 4 | *) 5 | 6 | open Printf 7 | 8 | type location = Text of string 9 | | Raw_backtrace of Printexc.raw_backtrace 10 | 11 | exception Traced of exn * location list 12 | 13 | let wrap loc e = 14 | match e with 15 | | Traced (e, locs) -> Traced (e, loc :: locs) 16 | | e -> Traced (e, [loc]) 17 | 18 | let unwrap = function 19 | | Traced (e, _) -> e 20 | | e -> e 21 | 22 | let wrap_with_stack_trace e = 23 | wrap (Raw_backtrace (Printexc.get_raw_backtrace ())) e 24 | 25 | let raise_at loc e = 26 | raise (wrap loc e) 27 | 28 | let raise txt_loc e = 29 | raise_at (Text txt_loc) e 30 | 31 | let reraise_with_stack_trace e = 32 | raise_at (Raw_backtrace (Printexc.get_raw_backtrace ())) e 33 | 34 | (* 35 | Ideally, this should be in its own file but dune doesn't allow it 36 | because the library name matches the main module name ('trax') 37 | and we don't want to rename it for backward compatibility. 38 | *) 39 | module Dedup = struct 40 | (* 41 | Deduplicate stack traces for better readability 42 | *) 43 | 44 | open Printf 45 | 46 | type dedup_entry = 47 | (* number of entries skipped. 1 entry = multiple slots *) 48 | | Ellipsis of int 49 | (* original position, entry *) 50 | | Entry of int * Printexc.raw_backtrace_entry 51 | 52 | (* 53 | Skip groups of duplicate entries and replace them by an ellipsis. 54 | *) 55 | let dedup_entries entries = 56 | let already_seen = Hashtbl.create 100 in 57 | let rec dedup_entries entries acc num_skipped = 58 | match entries with 59 | | [] -> 60 | let acc = 61 | if num_skipped > 0 then 62 | Ellipsis num_skipped :: acc 63 | else 64 | acc 65 | in 66 | List.rev acc 67 | | (entry_pos, k) :: entries -> 68 | if Hashtbl.mem already_seen k then 69 | dedup_entries entries acc (num_skipped + 1) 70 | else ( 71 | Hashtbl.add already_seen k (); 72 | let acc = 73 | if num_skipped > 0 then 74 | Ellipsis num_skipped :: acc 75 | else 76 | acc 77 | in 78 | let acc = (Entry (entry_pos, k) :: acc) in 79 | dedup_entries entries acc 0 80 | ) 81 | in 82 | dedup_entries entries [] 0 83 | 84 | let string_of_dedup_entries (l : dedup_entry list) = 85 | let buf = Buffer.create 1000 in 86 | l |> 87 | List.iter (function 88 | | Ellipsis n -> 89 | bprintf buf "... (skipping %i duplicate%s)\n" 90 | n (if n = 1 then "" else "s") 91 | | Entry (entry_pos, entry) -> 92 | (match Printexc.backtrace_slots_of_raw_entry entry with 93 | | None -> () 94 | | Some a -> 95 | Array.iteri (fun slot_pos slot -> 96 | (* 97 | 0 -> print 'Raised by ...' 98 | 1 -> print 'Called from ...' 99 | *) 100 | let zero_of_one = 101 | if entry_pos = 0 && slot_pos = 0 then 0 102 | else 1 103 | in 104 | match Printexc.Slot.format zero_of_one slot with 105 | | None -> () 106 | | Some s -> bprintf buf "%s\n" s 107 | ) a 108 | ) 109 | ); 110 | Buffer.contents buf 111 | 112 | let raw_backtrace_to_string raw = 113 | Printexc.raw_backtrace_entries raw 114 | |> Array.mapi (fun i x -> (i, x)) 115 | |> Array.to_list 116 | |> dedup_entries 117 | |> string_of_dedup_entries 118 | end 119 | 120 | let raw_backtrace_to_string = Dedup.raw_backtrace_to_string 121 | 122 | let add_loc buf loc = 123 | match loc with 124 | | Text s -> 125 | bprintf buf "\n%s" s 126 | | Raw_backtrace x -> 127 | let s = raw_backtrace_to_string x in 128 | let len = String.length s in 129 | if len > 0 then 130 | let n = 131 | if s.[len-1] = '\n' then len - 1 132 | else len 133 | in 134 | Buffer.add_char buf '\n'; 135 | Buffer.add_substring buf s 0 n 136 | 137 | let to_string_aux with_exn e = 138 | match e with 139 | | Traced (e, locs) -> 140 | let buf = Buffer.create 500 in 141 | if with_exn then 142 | bprintf buf "%s" (Printexc.to_string e); 143 | List.iter (add_loc buf) (List.rev locs); 144 | Buffer.contents buf 145 | | e -> 146 | if with_exn then 147 | Printexc.to_string e 148 | else 149 | "" 150 | 151 | let to_string e = to_string_aux true e 152 | let get_trace e = to_string_aux false e 153 | 154 | let print oc e = 155 | output_string oc (to_string e) 156 | --------------------------------------------------------------------------------