(* This file is part of Bisect_ppx, released under the MIT license. See
   LICENSE.md for details, or visit
   https://github.com/aantron/bisect_ppx/blob/master/LICENSE.md. *)



(* Overview

   This is the core of Bisect_ppx: the instrumenter that runs on ASTs is defined
   here. The instrumenter is divided into two major pieces:

   1. The class [instrumenter] traverses ASTs. It decides where instrumentation
      should be inserted.
   2. The module [Generated_code] provides the helpers that actually insert the
      instrumentation. In other words, they insert new leaves into the AST at
      the places chosen by [instrumenter].

   The code is structured to strongly reflect this division. It is recommended
   to read this file with code folding.

   Instrumented locations are called {e points}. When the instrumentation code
   is executed, the point is {e visited}. Points appear as highlighted
   characters in coverage reports.

   All state is contained within instances of [instrumenter].

   Instances are actually created in [register.ml], which is the "top-level"
   side-effecting module of Bisect_ppx, when Bisect_ppx used as a PPX library
   (i.e. by PPX drivers).

   When Bisect_ppx is used as a standalone executable PPX, the top-level entry
   point is in [bisect_ppx.ml]. It's basically a PPX driver that registers only
   this instrumenter with itself, using [register.ml], and then runs it. *)



module Parsetree = Ppxlib.Parsetree
module Location = Ppxlib.Location
module Ast_builder = Ppxlib.Ast_builder
module Longident = Ppxlib.Longident

module Pat = Ppxlib.Ast_helper.Pat
module Exp = Ppxlib.Ast_helper.Exp
module Str = Ppxlib.Ast_helper.Str
module Cl = Ppxlib.Ast_helper.Cl
module Cf = Ppxlib.Ast_helper.Cf



(* Can be removed once Bisect_ppx requires OCaml >= 4.08. *)
module Option =
struct
  let map f = function
    | Some v -> Some (f v)
    | None -> None
end



module Coverage_attributes :
sig
  val recognize : Parsetree.attribute -> [ `None | `On | `Off | `Exclude_file ]
  val has_off_attribute : Parsetree.attributes -> bool
  val has_exclude_file_attribute : Parsetree.structure -> bool
end =
struct
  let recognize {Parsetree.attr_name; attr_payload; attr_loc} =
    if attr_name.txt <> "coverage" then
      `None
    else
      match attr_payload with
      | Parsetree.PStr [%str off] ->
        `Off
      | PStr [%str on] ->
        `On
      | PStr [%str exclude_file] ->
        `Exclude_file
      | _ ->
        Location.raise_errorf ~loc:attr_loc "Bad payload in coverage attribute."

  let has_off_attribute attributes =
    (* Don't short-circuit the search, because we want to error-check all
       attributes. *)
    List.fold_left
      (fun found_off attribute ->
        match recognize attribute with
        | `None ->
          found_off
        | `Off ->
          true
        | `On ->
          Location.raise_errorf
            ~loc:attribute.attr_loc "coverage on is not allowed here."
        | `Exclude_file ->
          (* The only place where [@@@coverage exclude_file] is allowed is the
             top-level module of the file. However, if it is there, it will
             already have been found by a prescan, Bisect will not be
             instrumenting the file, and this function [has_off_attribute] won't
             be called. So, if this function ever finds this attribute, it is in
             a nested module, or elsewhere where it is not allowed. *)
          Location.raise_errorf
            ~loc:attribute.attr_loc
            "coverage exclude_file is not allowed here.")
      false attributes

  let has_exclude_file_attribute structure =
    structure |>
    List.exists (function
      | {Parsetree.pstr_desc = Pstr_attribute attribute; _}
        when recognize attribute = `Exclude_file -> true
      | _ -> false)
end



let bisect_file = ref None

let bisect_silent = ref None

let bisect_sigterm = ref false

module Generated_code :
sig
  type points

  val init : unit -> points

  val instrument_expr :
    points ->
    ?override_loc:Location.t ->
    ?use_loc_of:Parsetree.expression ->
    ?at_end:bool ->
    ?post:bool ->
    Parsetree.expression ->
      Parsetree.expression

  val instrument_cases :
    points -> ?use_aliases:bool -> Parsetree.case list ->
      Parsetree.case list
      * Parsetree.case list
      * Parsetree.value_binding list
      * bool

  val runtime_initialization :
    points -> string -> Parsetree.structure_item list
end =
struct
  type points = {
    mutable offsets : int list;
    mutable count : int;
  }

  let init () = {
    offsets = [];
    count = 0;
  }

  (* Given an AST for an expression [e], replaces it by the sequence expression
     [instrumentation; e], where [instrumentation] is some code that tells
     Bisect_ppx, at runtime, that [e] has been visited. *)
  let instrument_expr
      points ?override_loc ?use_loc_of ?(at_end = false) ?(post = false) e =

    let rec outline () =
      let loc = choose_location_of_point ~override_loc ~use_loc_of e in
      if expression_should_not_be_instrumented ~point_loc:loc ~use_loc_of then
        e
      else
        let point_index = get_index_of_point_at_location ~point_loc:loc in
        let open Parsetree in
        if not post then
          [%expr
            ___bisect_visit___ [%e point_index];
            [%e e]]
        else
          [%expr
            ___bisect_post_visit___ [%e point_index] [%e e]]

    and choose_location_of_point ~override_loc ~use_loc_of e =
      match use_loc_of with
      | Some e -> Parsetree.(e.pexp_loc)
      | None ->
        match override_loc with
        | Some override_loc -> override_loc
        | _ -> Parsetree.(e.pexp_loc)

    and expression_should_not_be_instrumented ~point_loc:loc ~use_loc_of =
      let e =
        match use_loc_of with
        | Some e -> e
        | None -> e
      in
      Location.(loc.loc_ghost) ||
      Coverage_attributes.has_off_attribute e.pexp_attributes

    and get_index_of_point_at_location ~point_loc:loc =
      let point_offset =
        if not at_end then
          Location.(Lexing.(loc.loc_start.pos_cnum))
        else
          Location.(Lexing.(loc.loc_end.pos_cnum - 1))
      in
      let point =
        let rec find_point points offset index offsets =
          match offsets with
          | offset'::_ when offset' = offset -> index
          | _::rest -> find_point points offset (index - 1) rest
          | [] ->
            let index = points.count in
            points.offsets <- offset::points.offsets;
            points.count <- points.count + 1;
            index
        in
        find_point points point_offset (points.count - 1) points.offsets
      in
      Ast_builder.Default.eint ~loc point

    in

    outline ()

  (* Instruments a case, as found in [match] and [function] expressions. Cases
     contain patterns.

     Bisect_ppx treats or-patterns specially. For example, suppose you have

       match foo with
       | A -> bar
       | B -> baz

     Both [bar] and [baz] get separate instrumentation points, so that if [A]
     is passed, but [B] is never passed, during testing, you will know that [B]
     was not tested with.

     However, if you refactor to use an or-pattern,

       match foo with
       | A | B -> bar

     and nothing is special is done, the instrumentation point on [bar] covers
     both [A] and [B], so you lose the information that [B] is not tested.

     The fix for this is a bit tricky, because patterns are not expressions. So,
     they can't be instrumented directly. Bisect_ppx instead inserts a special
     secondary [match] expression right in front of [bar]:

       match foo with
       | A | B as ___bisect_matched_value___ ->
         (match ___bisect_matched_value___ with
         | A -> visited "A"
         | B -> visited "B");
         bar

     So, Bisect_ppx takes that or-pattern [A | B], rotates the "or" out to the
     top level (it already is there), splits it into indepedent cases, and
     creates a new [match] expression out of them, that allows it to
     distinguish, after the fact, which branch was actually taken to reach
     [bar].

     There are actually several complications to this. The first is that the
     generated [match] expression is generally not exhaustive: it only includes
     the patterns from the case for which it was generated. This is solved by
     adding a catch-all case, and locally suppressing a bunch of warnings:

       match foo with
       | A | B as ___bisect_matched_value___ ->
         (match ___bisect_matched_value___ with
         | A -> visited "A"
         | B -> visited "B"
         | _ (* for C, D, which can't happen here *) -> ())
           [@ocaml.warning "..."];
         bar
       | C | D as ___bisect_matched_value___ ->
         (match ___bisect_matched_value___ with
         | C -> visited "C"
         | D -> visited "D"
         | _ (* for A, B, which can't happen here *) -> ())
           [@ocaml.warning "..."];;
         baz

      Next, or-patterns might not be at the top level:

        match foo with
        | C (A | B) -> bar

      has to become

        match foo with
        | C (A | B) as ___bisect_matched_value___ ->
          (match ___bisect_matched_value___ with
          | C A -> visited "A"
          | C B -> visited "B"
          | _ -> ());
          bar

      This is done by "rotating" the or-pattern to the top level. In this
      example, [C (A | B)] is equivalent to [C A | C B]. The latter pattern can
      easily be split into cases. This could also be done by aliasing individual
      or-patterns, but we did not investigate it.

      There might be multiple or-patterns:

        match foo with
        | C (A | B), D (A | B) -> bar

      should become

        match foo with
        | C (A | B), D (A | B) as ___bisect_matched_value___ ->
          (match ___bisect_matched_value___ with
          | C A, D A -> visited "A1"; visited "A2"
          | C A, D B -> visited "A1"; visited "B2"
          | C B, D A -> visited "B1"; visited "A2"
          | C B, D B -> visited "B1"; visited "B2"
          | _ -> ());
          bar

      as you can see, or-patterns under and-like patterns (tuples, arrays,
      records) get multiplied combinatorially.

      The above example also shows that Bisect_ppx needs to mark visisted a
      whole list of points in each of the generated cases. For that, the
      function that rotates or-patterns to the top level also keeps track of the
      original locations of each case of each or-pattern. Each of the resulting
      top-level patterns is paired with the list of locations of the or-cases it
      contains, visualised above as ["A1"; "A2"], ["A1"; "B2"], etc. These are
      termed *location traces*.

      Finally, there are some corner cases. First is the exception pattern:

        match foo with
        | exception (Exit | Failure _) -> bar

      should become

        match foo with
        | exception ((Exit | Failure _) as ___bisect_matched_value___) ->
          (match ___bisect_matched_value___ with
          | Exit -> visited "Exit"
          | Failure _ -> visited "Failure"
          | _ -> ());
          bar

      note that the [as] alias is attached to the payload of [exception], not to
      the outer pattern! The latter would be syntactically invalid. Also, we
      don't want to generate [exception] cases in the nested [match]: the
      exception has already been caught, we are not re-raising and re-catching
      it, which just need to know which constructor it was. To deal with this,
      we just need to check for the [exception] pattern, and work on its inside
      if it is present.

      The last corner case is the trivial one. If there no or-patterns, there is
      no point in generating a nested [match]:

        match foo with
        | A as ___bisect_matched_value___ ->
          (match ___bisect_matched_value___ with
          | A -> visited "A"   (* totally redundant *)
          | _ -> ());
          bar

      It's enough to just do

        match foo with
        | A -> visited "A"; bar

      which is pretty much just normal expression instrumentation, though with
      location overridden to the location of the pattern.

      This is detected when there is only one case after rotating all
      or-patterns to the top. If there had been an or-pattern, there would be at
      least two cases after rotation.

      Handling or-patterns is the most challening thing done here. There are a
      few simpler things to consider:

      - Pattern guards ([when] clauses) should be instrumented if present.
      - We don't instrument [assert false] cases.
      - We also don't instrument refutation cases ([| -> .]).

      So, without further ado, here is the function that does all this magic: *)

  let case_should_not_be_instrumented (case : Parsetree.case) =
    match case.pc_rhs with
    | [%expr assert false] -> true
    | {pexp_desc = Pexp_unreachable; _} -> true
    | {pexp_attributes; _}
      when Coverage_attributes.has_off_attribute pexp_attributes -> true
    | _ -> false

  let insert_instrumentation points (case : Parsetree.case) f =
    match case.pc_guard with
    | None ->
      {case with
        pc_rhs = f case.pc_rhs;
      }
    | Some guard ->
      {case with
        pc_guard = Some (f guard);
        pc_rhs = instrument_expr points case.pc_rhs;
      }

  let instrumentation_for_location_trace points location_trace e =
    location_trace
    |> List.sort_uniq (fun l l' ->
      l.Location.loc_start.Lexing.pos_cnum -
      l'.Location.loc_start.Lexing.pos_cnum)
    |> List.fold_left (fun e l ->
      instrument_expr points ~override_loc:l e) e

  let add_bisect_matched_value_alias loc p =
    let open Parsetree in
    [%pat? [%p p] as ___bisect_matched_value___]

  let generate_nested_match points loc rotated_cases =
    rotated_cases
    |> List.map (fun (location_trace, rotated_pattern) ->
      Exp.case
        rotated_pattern
        (instrumentation_for_location_trace points location_trace [%expr ()]))
    |> fun nested_match_cases ->
      nested_match_cases @ [Exp.case [%pat? _] [%expr ()]]
    |> Exp.match_ ~loc ([%expr ___bisect_matched_value___])
    |> fun nested_match ->
      Exp.attr
        nested_match
        {
          attr_name = {txt = "ocaml.warning"; loc};
          attr_payload = PStr [[%stri "-4-8-9-11-26-27-28-33"]];
          attr_loc = loc
        }

  (* This function works recursively. It should be called with a pattern [p]
     (second argument) and its location (first argument).

     It evaluates to a list of patterns. Each of these resulting patterns
     contains no nested or-patterns. Joining the resulting patterns in a single
     or-pattern would create a pattern equivalent to [p].

     Each pattern in the list is paired with a list of locations. These are the
     locations of the original cases of or-patterns in [p] that were chosen for
     the corresponding result pattern. For example:

       C (A | B), D (E | F)

     becomes the list of pairs

       (C A, D E), [loc A, loc E]
       (C A, D F), [loc A, loc F]
       (C B, D E), [loc B, loc E]
       (C B, D F), [loc B, loc F]

     During recursion, the invariant on the location is that it is the location
     of the nearest enclosing or-pattern, or the entire pattern, if there is no
     enclosing or-pattern. *)
  let rotate_or_patterns_to_top loc p =
    let rec recur ~enclosing_loc p =
      let loc = Parsetree.(p.ppat_loc) in
      let attrs = Parsetree.(p.ppat_attributes) in

      match p.ppat_desc with

      (* If the pattern ends with something trivial, that is not an or-pattern,
         and has no nested patterns (so can't have a nested or-pattern), then
         that pattern is the only top-level case. The location trace is just the
         location of the overall pattern.

         Here are some examples of how this plays out. Let's say the entire
         pattern was "x". Then the case list will be just "x", with its own
         location for the trace.

         If the entire pattern was "x as y", this recursive call will return
         just "x" with the location of "x as y" for the trace. The wrapping
         recursive call will turn the "x" back into "x as y".

         If the entire pattern was "A x | B", this recursive call will return
         just "x" with the location of "A" (not the whole pattern!). The
         wrapping recursive call, for constructor "A", will turn the "x" into
         "A x". A yet-higher wrapping recursive call, for the actual or-pattern,
         will concatenate this with a second top-level case, corresponding to
         "B". *)
      | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
      | Ppat_construct (_, None) | Ppat_variant (_, None) | Ppat_type _
      | Ppat_unpack _ | Ppat_extension _ ->
        [([enclosing_loc], p)]

      (* Recursively rotate or-patterns in [p'] to the top. Then, for each one,
         re-wrap it in an alias pattern. The location traces are not
         affected. *)
      | Ppat_alias (p', x) ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.alias ~loc ~attrs p'' x))

      | Ppat_construct (c, Some (ts, p')) ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace,
          Pat.mk ~loc ~attrs (Ppat_construct (c, Some (ts, p'')))))

      | Ppat_variant (c, Some p') ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.variant ~loc ~attrs c (Some p'')))

      | Ppat_constraint (p', t) ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.constraint_ ~loc ~attrs p'' t))

      | Ppat_lazy p' ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.lazy_ ~loc ~attrs p''))

      | Ppat_open (c, p') ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.open_ ~loc ~attrs c p''))

      | Ppat_exception p' ->
        recur ~enclosing_loc p'
        |> List.map (fun (location_trace, p'') ->
          (location_trace, Pat.exception_ ~loc ~attrs p''))

      (* Recursively rotate or-patterns in each pattern in [ps] to the top.
         Then, take a Cartesian product of the cases, and re-wrap each row in a
         replacement tuple pattern.

         For example, suppose we have the pair pattern

           (A | B, C | D)

         The recursive calls will produce lists of rotated cases for each
         component pattern:

           A | B   =>   [A, loc A]; [B, loc B]
           C | D   =>   [C, loc C]; [D, loc D]

         We now need every possible combination of one case from the first
         component, one case from the second, and so on, and to concatenate all
         the location traces accordingly:

           [A; C, loc A; loc C]
           [A; D, loc A; loc D]
           [B; C, loc B; loc C]
           [B; D, loc B; loc D]

         This is performed by [all_combinations].

         Finally, we need to take each one of these rows, and re-wrap the
         pattern lists (on the left side) into tuples.

         This is typical of "and-patterns", i.e. those that match various
         product types (those that carry multiple pieces of data
         simultaneously). *)
      | Ppat_tuple ps ->
        ps
        |> List.map (recur ~enclosing_loc)
        |> all_combinations
        |> List.map (fun (location_trace, ps') ->
          (location_trace, Pat.tuple ~loc ~attrs ps'))

      | Ppat_record (entries, closed) ->
        let labels, ps = List.split entries in
        ps
        |> List.map (recur ~enclosing_loc)
        |> all_combinations
        |> List.map (fun (location_trace, ps') ->
          (location_trace,
            Pat.record ~loc ~attrs (List.combine labels ps') closed))

      | Ppat_array ps ->
        ps
        |> List.map (recur ~enclosing_loc)
        |> all_combinations
        |> List.map (fun (location_trace, ps') ->
          location_trace, Pat.array ~loc ~attrs ps')

      (* For or-patterns, recur into each branch. Then, concatenate the
          resulting case lists. Don't reassemble an or-pattern. *)
      | Ppat_or (p_1, p_2) ->
        let ps_1 = recur ~enclosing_loc:p_1.ppat_loc p_1 in
        let ps_2 = recur ~enclosing_loc:p_2.ppat_loc p_2 in
        ps_1 @ ps_2

    (* Performs the Cartesian product operation described at [Ppat_tuple] above,
       concatenating location traces along the way.

       The argument is rows of top-level case lists (so a list of lists), each
       case list resulting from rotating some nested pattern. Since tuples,
       arrays, etc., have lists of nested patterns, we have a list of case
       lists. *)
    and all_combinations = function
      | [] -> []
      | cases::more ->
        let multiply product cases =
          product |> List.map (fun (location_trace_1, ps) ->
            cases |> List.map (fun (location_trace_2, p) ->
              location_trace_1 @ location_trace_2, ps @ [p]))
          |> List.flatten
        in

        let initial =
          cases
          |> List.map (fun (location_trace, p) -> location_trace, [p])
        in

        List.fold_left multiply initial more
    in

    recur ~enclosing_loc:loc p

  let rec partition_exceptions (p : Parsetree.pattern) =
    match p.ppat_desc with
    | Ppat_any | Ppat_var _ | Ppat_alias _ | Ppat_constant _ | Ppat_interval _
    | Ppat_tuple _ | Ppat_construct _ | Ppat_variant _ | Ppat_record _
    | Ppat_array _ | Ppat_type _ | Ppat_lazy _ | Ppat_unpack _
    | Ppat_extension _ ->
      Some p, None

    | Ppat_exception _ ->
      None, Some p

    | Ppat_constraint (p', t) ->
      let reassemble p' = {p with ppat_desc = Ppat_constraint (p', t)} in
      let p_value, p_exception = partition_exceptions p' in
      Option.map reassemble p_value, Option.map reassemble p_exception

    | Ppat_open (m, p') ->
      let reassemble p' = {p with ppat_desc = Ppat_open (m, p')} in
      let p_value, p_exception = partition_exceptions p' in
      Option.map reassemble p_value, Option.map reassemble p_exception

    | Ppat_or (p1, p2) ->
      let reassemble p1' p2' =
        match p1', p2' with
        | None, None -> None
        | (Some _ as p1'), None -> p1'
        | None, (Some _ as p2') -> p2'
        | Some p1', Some p2' -> Some {p with ppat_desc = Ppat_or (p1', p2')}
      in
      let p1_value, p1_exception = partition_exceptions p1 in
      let p2_value, p2_exception = partition_exceptions p2 in
      reassemble p1_value p2_value, reassemble p1_exception p2_exception

  let rec alias_exceptions loc p =
    match Parsetree.(p.ppat_desc) with
    | Ppat_any | Ppat_var _ | Ppat_alias _ | Ppat_constant _ | Ppat_interval _
    | Ppat_tuple _ | Ppat_construct _ | Ppat_variant _ | Ppat_record _
    | Ppat_array _ | Ppat_type _ | Ppat_lazy _ | Ppat_unpack _
    | Ppat_extension _ ->
      p

    | Ppat_or (p_1, p_2) ->
      {p with ppat_desc =
        Ppat_or (alias_exceptions loc p_1, alias_exceptions loc p_2)}

    | Ppat_constraint (p', t) ->
      {p with ppat_desc =
        Ppat_constraint (alias_exceptions loc p', t)}

    | Ppat_exception p' ->
      {p with ppat_desc =
        Ppat_exception (add_bisect_matched_value_alias loc p')}

    | Ppat_open (m, p') ->
      {p with ppat_desc =
        Ppat_open (m, alias_exceptions loc p')}

  let rec drop_exception_patterns p =
    match Parsetree.(p.ppat_desc) with
    | Ppat_any | Ppat_var _ | Ppat_alias _ | Ppat_constant _ | Ppat_interval _
    | Ppat_tuple _ | Ppat_construct _ | Ppat_variant _ | Ppat_record _
    | Ppat_array _ | Ppat_type _ | Ppat_lazy _ | Ppat_unpack _
    | Ppat_extension _ ->
      p (* Should be unreachable. *)

    | Ppat_or _ ->
      p (* Should be unreachable. *)

    (* Dropping exception patterns will change the meaning of type constraints
       on them, so drop the type constraints along the way. *)
    | Ppat_constraint (p', _) ->
      drop_exception_patterns p'

    | Ppat_exception p' ->
      p'

    | Ppat_open (m, p') ->
      {p with ppat_desc =
        Ppat_open (m, drop_exception_patterns p')}

  let rec bound_variables p =
    match Parsetree.(p.ppat_desc) with
    | Ppat_any | Ppat_constant _ | Ppat_interval _ | Ppat_construct (_, None)
    | Ppat_variant (_, None) | Ppat_type _ | Ppat_unpack _ | Ppat_extension _ ->
      []

    | Ppat_var x ->
      [x]

    | Ppat_alias (p', x) ->
      x::(bound_variables p')

    | Ppat_tuple ps | Ppat_array ps ->
      List.map bound_variables ps
      |> List.flatten

    | Ppat_record (fields, _) ->
      List.map (fun (_, p') -> bound_variables p') fields
      |> List.flatten

    | Ppat_construct (_, Some (_, p')) | Ppat_variant (_, Some p')
    | Ppat_constraint (p', _) | Ppat_lazy p' | Ppat_exception p'
    | Ppat_open (_, p') ->
      bound_variables p'

    | Ppat_or (p_1, _) ->
      bound_variables p_1 (* Should be unreachable. *)

  let rec has_polymorphic_variant p =
    match Parsetree.(p.ppat_desc) with
    | Ppat_any | Ppat_constant _ | Ppat_interval _ | Ppat_construct (_, None)
    | Ppat_unpack _ | Ppat_extension _ | Ppat_var _ ->
      false

    | Ppat_type _ | Ppat_variant _ ->
      true

    | Ppat_alias (p', _) | Ppat_construct (_, Some (_, p'))
    | Ppat_constraint (p', _) | Ppat_lazy p' | Ppat_exception p'
    | Ppat_open (_, p') ->
      has_polymorphic_variant p'

    | Ppat_tuple ps | Ppat_array ps ->
      List.exists has_polymorphic_variant ps

    | Ppat_record (fields, _) ->
      List.exists (fun (_, p') -> has_polymorphic_variant p') fields

    | Ppat_or (p1, p2) ->
      has_polymorphic_variant p1 || has_polymorphic_variant p2

  let rec make_function loc body = function
    | [] ->
      Exp.fun_
        ~loc Ppxlib.Nolabel None [%pat? ()] body
    | x::rest ->
      Exp.fun_
        ~loc Ppxlib.Nolabel None (Pat.var ~loc x) (make_function loc body rest)

  let instrument_cases
      points ?(use_aliases = false) (cases : Parsetree.case list) =
    let cases =
      List.map (fun case ->
        case, partition_exceptions case.Parsetree.pc_lhs) cases
    in
    let use_aliases =
      use_aliases || (cases |> List.exists (function
        | (_, (Some p, _)) when has_polymorphic_variant p -> true
        | _ -> false))
    in
    cases
    |> List.fold_left begin fun
        (value_cases, exception_cases, functions, need_binding, index)
        ((case : Parsetree.case), (value_pattern, exception_pattern)) ->
      let loc = case.pc_lhs.ppat_loc in

      let case, functions =
        match value_pattern, exception_pattern with
        | Some p, Some _ ->
          let variables = bound_variables p in
          let apply loc name =
            Exp.apply ~loc
              (Exp.ident ~loc {txt = Longident.parse name; loc})
              (List.map (fun {Location.loc; txt} ->
                Ppxlib.Nolabel,
                Exp.ident ~loc {txt = Longident.parse txt; loc})
                variables
              @ [Ppxlib.Nolabel, [%expr ()]])
          in

          let case, functions =
            match case.pc_guard with
            | None ->
              case, functions
            | Some guard ->
              let guard_name = Printf.sprintf "___bisect_guard_%i___" index in
              let guard_function =
                Ppxlib.Ast_helper.Vb.mk ~loc
                  (Pat.var ~loc {Location.loc; txt = guard_name})
                  (make_function loc guard variables)
              in
              {case with pc_guard = Some (apply guard.pexp_loc guard_name)},
              guard_function::functions
          in

          let case_name = Printf.sprintf "___bisect_case_%i___" index in
          let case_function =
            Ppxlib.Ast_helper.Vb.mk ~loc
              (Pat.var ~loc {Location.loc; txt = case_name})
              (make_function loc case.pc_rhs variables)
          in
          {case with pc_rhs = apply case.pc_rhs.pexp_loc case_name},
          case_function::functions
        | _ ->
          case, functions
      in

      let value_cases, need_binding =
        match value_pattern with
        | None -> value_cases, need_binding
        | Some p ->
          let loc = p.ppat_loc in
          let case = {case with pc_lhs = p} in
          if case_should_not_be_instrumented case then
            case::value_cases, need_binding
          else
            let case, need_binding =
              match rotate_or_patterns_to_top loc p with
              | [] ->
                insert_instrumentation points
                  case
                  (fun e -> instrument_expr points e),
                need_binding
              | [(location_trace, _)] ->
                insert_instrumentation points
                  case
                  (instrumentation_for_location_trace points location_trace),
                need_binding
              | rotated_cases ->
                let case =
                  if use_aliases then
                    {case with pc_lhs =
                      add_bisect_matched_value_alias loc case.pc_lhs}
                  else
                    case
                in
                let nested_match =
                  generate_nested_match points loc rotated_cases in
                insert_instrumentation points
                  case
                  (fun e -> [%expr [%e nested_match]; [%e e]]),
                true
            in
            case::value_cases, need_binding
      in

      let exception_cases =
        match exception_pattern with
        | None -> exception_cases
        | Some p ->
          let loc = p.Parsetree.ppat_loc in
          let case = {case with pc_lhs = p} in
          if case_should_not_be_instrumented case then
            case::exception_cases
          else
            let case =
              match rotate_or_patterns_to_top loc p with
              | [] ->
                insert_instrumentation points
                  case
                  (fun e -> instrument_expr points e)
              | [(location_trace, _)] ->
                insert_instrumentation points
                  case
                  (instrumentation_for_location_trace points location_trace)
              | rotated_cases ->
                let nested_match =
                  rotated_cases
                  |> List.map (fun (trace, p) ->
                    trace, drop_exception_patterns p)
                  |> generate_nested_match points loc
                in
                insert_instrumentation points
                  {case with pc_lhs = alias_exceptions loc p}
                  (fun e -> [%expr [%e nested_match]; [%e e]])
            in
            case::exception_cases
      in

      value_cases, exception_cases, functions, need_binding, index + 1
    end ([], [], [], false, 0)
    |> fun (v, e, f, n, _) ->
      List.rev v, List.rev e, List.rev f, n && not use_aliases

  let runtime_initialization points file =
    let loc = Location.in_file file in

    let mangled_module_name =
      let buffer = Buffer.create ((String.length file) * 2) in
      file |> String.iter (function
        | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c ->
          Buffer.add_char buffer c
        | _ ->
          Buffer.add_string buffer "___");
      "Bisect_visit___" ^ (Buffer.contents buffer)
    in

    let points_data =
      Ast_builder.Default.pexp_array ~loc
        (List.map
          (fun offset -> Ast_builder.Default.eint ~loc offset)
          (List.rev points.offsets))
    in
    let filename = Ast_builder.Default.estring ~loc file in

    let ast_convenience_str_opt = function
      | None ->
        Exp.construct ~loc {txt = Longident.parse "None"; loc} None
      | Some v ->
        Some (Ast_builder.Default.estring ~loc v)
        |> Exp.construct ~loc {txt = Longident.parse "Some"; loc}
    in
    let bisect_file = ast_convenience_str_opt !bisect_file in
    let bisect_silent = ast_convenience_str_opt !bisect_silent in
    let bisect_sigterm =
      let open Parsetree in
      if !bisect_sigterm then [%expr true] else [%expr false]
    in

    (* ___bisect_visit___ is a function with a reference to a point count array.
       It is called every time a point is visited.

       It is scoped in a local module, to ensure that each compilation unit
       calls its own ___bisect_visit___ function. In particular, if
       ___bisect_visit___ is unscoped, the following interaction is possible
       between a.ml and b.ml:


       a.ml:

       let ___bisect_visit___ = (* ... *)

       b.ml:

       let ___bisect_visit___ = (* ... *)

       open A
       (* Further calls to ___bisect_visit___ are to A's instance of it! *)


       To prevent this, Bisect_ppx generates:


       a.ml:

       module Bisect_visit___ =
       struct
         let ___bisect_visit___ = (* ... *)
       end
       open Bisect_visit___ (* Scope of open is only a.ml. *)

       b.ml:

       module Bisect_visit___ =
       struct
         let ___bisect_visit___ = (* ... *)
       end
       open Bisect_visit___
       (* Since this open is prepended to b.ml, it is guaranteed to precede any
          open A. At the same time, open A introduces Bisect_visit___ into
          scope, not ___bisect_visit___. So, after this point, any unqualified
          reference to ___bisect_visit___ is to b.ml's instance. *)

       open A


       Bisect_ppx needs to mangle the generated module names, to make them
       unique. Otherwise, including A in B triggers a duplicate module
       Bisect_visit___ error. This is better than mangling ___bisect_visit___
       itself for two reasons:

       1. A collision of mangled module names (due to include) is a compile-time
          error. By comparison, a collusion of mangled function names will
          result in one silently shadowing the other, which *may* produce a
          runtime error if (1) the shadowing function has a smaller points array
          than the shadowed function and (2) the shadowing function is actually
          called with a large enough point index during testing. If shadowing
          does not produce a runtime error, it can result in inaccurate coverage
          statistics being silently accumulated.
       2. ___bisect_visit___, sprinked throughout the code, can be kept
          unmangled. This keeps the mangling generation code local to this
          instrumentation function, which generates only the top of each
          instrumented module. That keeps the instrumenter relatively simple.


       For discussion, see

         https://github.com/aantron/bisect_ppx/issues/160 *)
    let generated_module =
      let bisect_visit_function =
        let open Parsetree in
        [%stri
          let ___bisect_visit___ =
            let points = [%e points_data] in
            let `Visit visit =
              Bisect.Runtime.register_file
                ~bisect_file:[%e bisect_file]
                ~bisect_silent:[%e bisect_silent]
                ~filename:[%e filename]
                ~points
                ~bisect_sigterm:[%e bisect_sigterm]
            in
            visit
        ]
      in

      let bisect_post_visit =
        let open Parsetree in
        [%stri
          let ___bisect_post_visit___ point_index result =
            ___bisect_visit___ point_index;
            result
        ]
      in

      let open Ppxlib.Ast_helper in
      Str.module_ ~loc @@
        Mb.mk ~loc
          {txt = Some mangled_module_name; loc}
          (Mod.structure ~loc [
            bisect_visit_function;
            bisect_post_visit;
          ])
    in

    let module_open =
      let open Ppxlib.Ast_helper in

      (* This requires the assumption that the mangled module name doesn't have
         any periods. *)
      Str.open_ ~loc @@
        Opn.mk ~loc @@
          Mod.ident ~loc {txt = Longident.parse mangled_module_name; loc}
    in

    let open Parsetree in
    let stop_comment = [%stri [@@@ocaml.text "/*"]] in

    [stop_comment; generated_module; module_open; stop_comment]
end

let (>>=) = Ppxlib.With_errors.(>>=)
let (>>|) = Ppxlib.With_errors.(>>|)
let collect_errors = Ppxlib.With_errors.combine_errors
let return = Ppxlib.With_errors.return

(* The actual "instrumenter" object, instrumenting expressions. *)
class instrumenter =
  let points = Generated_code.init () in
  let instrument_expr = Generated_code.instrument_expr points in
  let instrument_cases = Generated_code.instrument_cases points in

  object (self)
    inherit Ppxlib.Ast_traverse.map_with_expansion_context_and_errors as super

    method! class_expr ctxt ce =
      let loc = ce.pcl_loc in
      let attrs = ce.pcl_attributes in
      super#class_expr ctxt ce
      >>| fun ce ->

      match ce.pcl_desc with
      | Pcl_fun (l, e, p, ce) ->
        Cl.fun_ ~loc ~attrs l (Option.map instrument_expr e) p ce

      | _ ->
        ce

    method! class_field ctxt cf =
      let loc = cf.pcf_loc in
      let attrs = cf.pcf_attributes in
      super#class_field ctxt cf
      >>| fun cf ->

      match cf.pcf_desc with
      | Pcf_method (name, private_, cf) ->
        Cf.method_ ~loc ~attrs
          name private_
          (match cf with
          | Cfk_virtual _ -> cf
          | Cfk_concrete (o, e) ->
            Cf.concrete o (instrument_expr e))

      | Pcf_initializer e ->
        Cf.initializer_ ~loc ~attrs (instrument_expr e)

      | _ ->
        cf

    method! expression ctxt e =
      let is_trivial_function = Parsetree.(function
        | [%expr (&&)]
        | [%expr (&)]
        | [%expr not]
        | [%expr (=)]
        | [%expr (<>)]
        | [%expr (<)]
        | [%expr (<=)]
        | [%expr (>)]
        | [%expr (>=)]
        | [%expr (==)]
        | [%expr (!=)]
        | [%expr ref]
        | [%expr (!)]
        | [%expr (:=)]
        | [%expr (@)]
        | [%expr (^)]
        | [%expr (+)]
        | [%expr (-)]
        | [%expr ( * )]
        | [%expr (/)]
        | [%expr (+.)]
        | [%expr (-.)]
        | [%expr ( *. )]
        | [%expr (/.)]
        | [%expr (mod)]
        | [%expr (land)]
        | [%expr (lor)]
        | [%expr (lxor)]
        | [%expr (lsl)]
        | [%expr (lsr)]
        | [%expr (asr)]
        | [%expr raise]
        | [%expr raise_notrace]
        | [%expr failwith]
        | [%expr ignore]
        | [%expr Sys.opaque_identity]
        | [%expr Obj.magic]
        | [%expr (##)]
        | [%expr React.forwardRef]
        | [%expr React.memo] -> true
        | _ -> false)
      in

      let rec traverse ?(successor = `None) ~is_in_tail_position e =
        let attrs = e.Parsetree.pexp_attributes in
        if Coverage_attributes.has_off_attribute attrs then
          return e

        else begin
          let loc = e.pexp_loc in

          match e.pexp_desc with
          (* Expressions that invoke arbitrary code, and may not terminate. *)
          | Pexp_apply
              ([%expr (|>)] | [%expr (|.)] as operator, [(l, e); (l', e')]) ->
            traverse
              ~successor:(`Expression e') ~is_in_tail_position:false e
            >>= fun e_traversed ->
            traverse
              ~successor:`Redundant ~is_in_tail_position:false e'
            >>| fun e'_traversed ->
            let apply =
              Exp.apply
                ~loc ~attrs operator [(l, e_traversed); (l', e'_traversed)]
            in
            if is_in_tail_position then
              apply
            else
              begin match successor with
              | `None ->
                let rec fn e' =
                  match e'.Parsetree.pexp_desc with
                  | Pexp_apply (e'', _) ->
                    let attributes = e'.pexp_attributes in
                    if Coverage_attributes.has_off_attribute attributes then
                      e'
                    else
                      fn e''
                  | _ -> e'
                in
                instrument_expr
                  ~use_loc_of:(fn e') ~at_end:true ~post:true apply
              | `Redundant ->
                apply
              | `Expression e ->
                instrument_expr ~use_loc_of:e ~post:true apply
              end

          | Pexp_apply (([%expr (||)] | [%expr (or)]), [(_l, e); (_l', e')]) ->
            let e_mark =
              instrument_expr ~use_loc_of:e ~at_end:true [%expr true] in
            begin match e'.pexp_desc with
            | Pexp_apply (([%expr (||)] | [%expr (or)]), _) ->
              traverse ~is_in_tail_position e'
            | Pexp_apply (e'', _)
              when is_in_tail_position && not (is_trivial_function e'') ->
              traverse ~is_in_tail_position:true e'
            | Pexp_send _ | Pexp_new _ when is_in_tail_position ->
              traverse ~is_in_tail_position:true e'
            | _ ->
              traverse ~is_in_tail_position:false e'
              >>| fun condition ->
              let open Parsetree in
              [%expr
                if [%e condition] then
                  [%e
                    instrument_expr ~use_loc_of:e' ~at_end:true [%expr true]]
                else
                  false]
            end
            >>= fun e'_new ->
            let open Parsetree in
            traverse ~is_in_tail_position:false e
            >>| fun e_new ->
            [%expr
              if [%e e_new] then
                [%e e_mark]
              else
                [%e e'_new]]

          | Pexp_apply (e, arguments) ->
            begin match e, arguments with
            | ([%expr (&&)] | [%expr (&)]),
              [(ll, el); (lr, er)] ->
              traverse ~is_in_tail_position:false el
              >>= fun el_new ->
              traverse ~is_in_tail_position er
              >>| fun er_new ->
              [(ll, el_new); (lr, instrument_expr er_new)]

            | [%expr (@@)],
              [(ll, ({pexp_desc = Pexp_apply _; _} as el)); (lr, er)] ->
              traverse ~successor:`Redundant ~is_in_tail_position:false el
              >>= fun el_new ->
              traverse ~is_in_tail_position:false er
              >>| fun er_new ->
              [(ll, el_new); (lr, er_new)]

            | _ ->
              arguments
              |> List.map (fun (label, e) ->
                traverse ~is_in_tail_position:false e
                >>| fun e_new ->
                (label, e_new))
              |> collect_errors
            end
            >>= fun arguments ->
            begin match e.pexp_desc with
            | Pexp_new _ ->
              return e
            | Pexp_send _ ->
              traverse ~successor:`Redundant ~is_in_tail_position:false e
            | _ ->
              traverse ~is_in_tail_position:false e
            end
            >>| fun e ->
            let apply = Exp.apply ~loc ~attrs e arguments in
            let all_arguments_labeled =
              arguments
              |> List.for_all (fun (label, _) -> label <> Ppxlib.Nolabel)
            in
            if is_in_tail_position || all_arguments_labeled then
              apply
            else
              if is_trivial_function e then
                apply
              else
                begin match successor with
                | `None ->
                  let use_loc_of =
                    match e, arguments with
                    | [%expr (@@)], [(_, e'); _] ->
                      e'
                    | _ ->
                      e
                  in
                  instrument_expr ~use_loc_of ~at_end:true ~post:true apply
                | `Redundant ->
                  apply
                | `Expression e' ->
                  instrument_expr ~use_loc_of:e' ~at_end:false ~post:true apply
                end

          | Pexp_send (e, m) ->
            traverse ~is_in_tail_position:false e
            >>| fun e_new ->
            let apply = Exp.send ~loc ~attrs e_new m in
            if is_in_tail_position then
              apply
            else
              begin match successor with
              | `None ->
                instrument_expr ~at_end:true ~post:true apply
              | `Redundant ->
                apply
              | `Expression e' ->
                instrument_expr ~use_loc_of:e' ~post:true apply
              end

          | Pexp_new _ ->
            return @@
            if is_in_tail_position then
              e
            else
              begin match successor with
              | `None ->
                instrument_expr ~at_end:true ~post:true e
              | `Redundant ->
                e
              | `Expression e' ->
                instrument_expr ~use_loc_of:e' ~post:true e
              end

          | Pexp_assert [%expr false] ->
            return e

          | Pexp_assert e ->
            traverse ~is_in_tail_position:false e
            >>| fun e_new ->
            instrument_expr ~use_loc_of:e ~post:true (Exp.assert_ e_new)

          (* Expressions that have subexpressions that might not get visited. *)
          | Pexp_function cases ->
            traverse_cases ~is_in_tail_position:true cases
            >>| fun cases_new ->
            let cases, _, _, need_binding = instrument_cases cases_new in
            if need_binding then
              Exp.fun_ ~loc ~attrs
                Ppxlib.Nolabel None ([%pat? ___bisect_matched_value___])
                (Exp.match_ ~loc
                  ([%expr ___bisect_matched_value___]) cases)
            else
              Exp.function_ ~loc ~attrs cases

          | Pexp_fun (label, default_value, p, e) ->
            begin match default_value with
            | None ->
              return None
            | Some e ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              Some (instrument_expr e)
            end
            >>= fun default_value ->
            traverse ~is_in_tail_position:true e
            >>| fun e ->
            let e =
              match e.pexp_desc with
              | Pexp_function _ | Pexp_fun _ -> e
              | Pexp_constraint (e', t) ->
                {e with pexp_desc = Pexp_constraint (instrument_expr e', t)}
              | _ -> instrument_expr e
            in
            Exp.fun_ ~loc ~attrs label default_value p e

          | Pexp_match (e, cases) ->
            traverse_cases ~is_in_tail_position cases
            >>= fun cases ->
            let value_cases, exception_cases, functions, need_binding =
              instrument_cases cases in
            let top_level_cases =
              if need_binding then
                let value_case = Parsetree.{
                  pc_lhs = [%pat? ___bisect_matched_value___];
                  pc_guard = None;
                  pc_rhs =
                    Exp.match_ ~loc ~attrs
                      ([%expr ___bisect_matched_value___])
                      value_cases;
                }
                in
                exception_cases @ [value_case]
              else
                exception_cases @ value_cases
            in
            traverse ~successor:`Redundant ~is_in_tail_position:false e
            >>| fun e ->
            let match_ = Exp.match_ ~loc ~attrs e top_level_cases in
            begin match functions with
            | [] -> match_
            | _ -> Exp.let_ ~loc Nonrecursive functions match_
            end

          | Pexp_try (e, cases) ->
            traverse_cases ~is_in_tail_position cases
            >>= fun cases ->
            let cases, _, _, _ = instrument_cases ~use_aliases:true cases in
            traverse ~is_in_tail_position:false e
            >>| fun e ->
            Exp.try_ ~loc ~attrs e cases

          | Pexp_ifthenelse (if_, then_, else_) ->
            traverse ~successor:`Redundant ~is_in_tail_position:false if_
            >>= fun if_ ->
            traverse ~is_in_tail_position then_
            >>= fun then_ ->
            begin match else_ with
            | None ->
              return None
            | Some else_ ->
              traverse ~is_in_tail_position else_
              >>| fun else_ ->
              Some (instrument_expr else_)
            end
            >>| fun else_ ->
            Exp.ifthenelse ~loc ~attrs if_ (instrument_expr then_) else_

          | Pexp_while (while_, do_) ->
            traverse ~is_in_tail_position:false while_
            >>= fun while_ ->
            traverse ~is_in_tail_position:false do_
            >>| fun do_ ->
            Exp.while_ ~loc ~attrs while_ (instrument_expr do_)

          | Pexp_for (v, init, to_, direction, do_) ->
            traverse ~is_in_tail_position:false init
            >>= fun init ->
            traverse ~is_in_tail_position:false to_
            >>= fun to_ ->
            traverse ~is_in_tail_position:false do_
            >>| fun do_ ->
            Exp.for_ ~loc ~attrs v init to_ direction (instrument_expr do_)

          | Pexp_lazy e ->
            let rec is_trivial_syntactic_value e =
              match e.Parsetree.pexp_desc with
              | Pexp_function _ | Pexp_fun _ | Pexp_poly _ | Pexp_ident _
              | Pexp_constant _ | Pexp_construct (_, None) ->
                true
              | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) ->
                is_trivial_syntactic_value e
              | _ ->
                false
            in
            traverse ~is_in_tail_position:true e
            >>| fun e ->
            let e =
              (* lazy applied to certain syntactic values is compiled as already
                 forced. Since inserting instrumentation under such a lazy would
                 make the nested expression not a syntactic value, it would
                 change the compilation of the lazy. See
                 https://github.com/aantron/bisect_ppx/issues/398. *)
              if is_trivial_syntactic_value e then
                e
              else
                instrument_expr e
            in
            Exp.lazy_ ~loc ~attrs e

          | Pexp_poly (e, t) ->
            traverse ~is_in_tail_position:true e
            >>| fun e ->
            let e =
              match e.pexp_desc with
              | Pexp_function _ | Pexp_fun _ -> e
              | _ -> instrument_expr e
            in
            Exp.poly ~loc ~attrs e t

          | Pexp_letop {let_; ands; body} ->
            let traverse_binding_op binding_op =
              traverse ~is_in_tail_position:false binding_op.Parsetree.pbop_exp
              >>| fun pbop_exp ->
              {binding_op with Parsetree.pbop_exp}
            in
            traverse_binding_op let_
            >>= fun let_ ->
            List.map traverse_binding_op ands |> collect_errors
            >>= fun ands ->
            traverse ~is_in_tail_position:true body
            >>| fun body ->
            Exp.letop ~loc ~attrs let_ ands (instrument_expr body)

          (* Expressions that don't fit either of the above categories. These
             don't need to be instrumented. *)
          | Pexp_ident _ | Pexp_constant _ ->
            return e

          | Pexp_let (rec_flag, bindings, e) ->
            let successor =
              match bindings with
              | [_one] -> `Expression e
              | _ -> `None
            in
            bindings
            |> List.map (fun binding ->
              traverse
                ~successor
                ~is_in_tail_position:false
                binding.Parsetree.pvb_expr
            >>| fun e ->
            Parsetree.{binding with pvb_expr = e})
            |> collect_errors
            >>= fun bindings ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.let_ ~loc ~attrs rec_flag bindings e

          | Pexp_tuple es ->
            List.map (traverse ~is_in_tail_position:false) es
            |> collect_errors
            >>| fun es ->
            Exp.tuple ~loc ~attrs es

          | Pexp_construct (c, e) ->
            begin match e with
            | None ->
              return None
            | Some e ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              Some e
            end
            >>| fun e ->
            Exp.construct ~loc ~attrs c e

          | Pexp_variant (c, e) ->
            begin match e with
            | None ->
              return None
            | Some e ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              Some e
            end
            >>| fun e ->
            Exp.variant ~loc ~attrs c e

          | Pexp_record (fields, e) ->
            fields
            |> List.map (fun (f, e) ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              (f, e))
            |> collect_errors
            >>= fun fields ->
            begin match e with
            | None ->
              return None
            | Some e ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              Some e
            end
            >>| fun e ->
            Exp.record ~loc ~attrs fields e

          | Pexp_field (e, f) ->
            traverse ~is_in_tail_position:false e
            >>| fun e ->
            Exp.field ~loc ~attrs e f

          | Pexp_setfield (e, f, e') ->
            traverse ~is_in_tail_position:false e
            >>= fun e ->
            traverse ~is_in_tail_position:false e'
            >>| fun e' ->
            Exp.setfield ~loc ~attrs e f e'

          | Pexp_array es ->
            List.map (traverse ~is_in_tail_position:false) es
            |> collect_errors
            >>| fun es ->
            Exp.array ~loc ~attrs es

          | Pexp_sequence (e, e') ->
            traverse ~is_in_tail_position e'
            >>= fun e' ->
            let e' =
              match e.pexp_desc with
              | Pexp_ifthenelse (_, _, None) -> instrument_expr e'
              | _ -> e'
            in
              traverse
                ~successor:(`Expression e') ~is_in_tail_position:false e
            >>| fun e ->
            Exp.sequence ~loc ~attrs e e'

          | Pexp_constraint (e, t) ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.constraint_ ~loc ~attrs e t

          | Pexp_coerce (e, t, t') ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.coerce ~loc ~attrs e t t'

          | Pexp_setinstvar (f, e) ->
            traverse ~is_in_tail_position:false e
            >>| fun e ->
            Exp.setinstvar ~loc ~attrs f e

          | Pexp_override fs ->
            fs
            |> List.map (fun (f, e) ->
              traverse ~is_in_tail_position:false e
              >>| fun e ->
              (f, e))
            |> collect_errors
            >>| fun fs ->
            Exp.override ~loc ~attrs fs

          | Pexp_letmodule (m, e, e') ->
            self#module_expr ctxt e
            >>= fun e ->
            traverse ~is_in_tail_position e'
            >>| fun e' ->
            Exp.letmodule ~loc ~attrs m e e'

          | Pexp_letexception (c, e) ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.letexception ~loc ~attrs c e

          | Pexp_open (m, e) ->
            self#open_declaration ctxt m
            >>= fun m ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.open_ ~loc ~attrs m e

          | Pexp_newtype (t, e) ->
            traverse ~is_in_tail_position e
            >>| fun e ->
            Exp.newtype ~loc ~attrs t e

          (* Expressions that don't need instrumentation, and where AST
             traversal leaves the expression language. *)
          | Pexp_object c ->
            self#class_structure ctxt c
            >>| fun c ->
            Exp.object_ ~loc ~attrs c

          | Pexp_pack m ->
            self#module_expr ctxt m
            >>| fun m ->
            Exp.pack ~loc ~attrs m

          (* Expressions that are not recursively traversed at all. *)
          | Pexp_extension _ | Pexp_unreachable ->
            return e
        end

      and traverse_cases ~is_in_tail_position cases =
        cases
        |> List.map begin fun case ->
          begin match case.Parsetree.pc_guard with
          | None ->
            return None
          | Some guard ->
            traverse ~is_in_tail_position:false guard
            >>| fun guard ->
            Some guard
          end
          >>= fun pc_guard ->
          traverse ~is_in_tail_position case.pc_rhs
          >>| fun pc_rhs ->
          {case with pc_guard; pc_rhs}
        end
        |> collect_errors

      in

      traverse ~is_in_tail_position:false e

    (* Set to [true] upon encountering [[@@@coverage.off]], and back to
       [false] again upon encountering [[@@@coverage.on]]. *)
    val mutable structure_instrumentation_suppressed = false

    method! structure_item ctxt si =
      let loc = si.pstr_loc in

      match si.pstr_desc with
      | Pstr_value (rec_flag, bindings) ->
        if structure_instrumentation_suppressed then
          return si

        else
          bindings
          |> List.map begin fun binding ->
            (* Only instrument things not excluded. *)
            let maybe_name =
              let open Parsetree in
              match binding.pvb_pat.ppat_desc with
              | Ppat_var ident
              | Ppat_constraint ({ppat_desc = Ppat_var ident; _}, _) ->
                Some ident
              | _ ->
                None
            in
            let do_not_instrument =
              match maybe_name with
              | Some name ->
                Exclusions.contains_value
                  Location.(Lexing.(name.loc.loc_start.pos_fname))
                  name.txt
              | None ->
                false
            in
            let do_not_instrument =
              do_not_instrument ||
                Coverage_attributes.has_off_attribute binding.pvb_attributes
            in
            if do_not_instrument then
              return binding
            else begin
              self#expression ctxt binding.pvb_expr
              >>| fun e ->
              {binding with pvb_expr = e}
            end
          end
          |> collect_errors
          >>| fun bindings ->
          Str.value ~loc rec_flag bindings

      | Pstr_eval (e, a) ->
        if structure_instrumentation_suppressed then
          return si
        else begin
          self#expression ctxt e
          >>| fun e ->
          Str.eval ~loc ~attrs:a e
        end

      | Pstr_attribute attribute ->
        let kind = Coverage_attributes.recognize attribute in
        begin match kind with
        | `None ->
          ()
        | `Off ->
          if structure_instrumentation_suppressed then
            Location.raise_errorf
              ~loc:attribute.attr_loc "Coverage is already off.";
          structure_instrumentation_suppressed <- true
        | `On ->
          if not structure_instrumentation_suppressed then
            Location.raise_errorf
              ~loc:attribute.attr_loc "Coverage is already on.";
          structure_instrumentation_suppressed <- false
        | `Exclude_file ->
          (* See comment in [Coverage_attributes.has_off_attribute] for
             reasoning. *)
          Location.raise_errorf
            ~loc:attribute.attr_loc "coverage exclude_file is not allowed here."
        end;
        return si

      | _ ->
        super#structure_item ctxt si

    (* Don't instrument payloads of extensions and attributes. *)
    method! extension _ e =
      return e

    method! attribute _ a =
      return a

    method! structure ctxt ast =
      let saved_structure_instrumentation_suppressed =
        structure_instrumentation_suppressed in
      let result = super#structure ctxt ast in
      structure_instrumentation_suppressed <-
        saved_structure_instrumentation_suppressed;
      result

    method transform_impl_file ctxt ast =
      let saved_structure_instrumentation_suppressed =
        structure_instrumentation_suppressed in

      let result =
        let path = Ppxlib.Expansion_context.Base.input_name ctxt in
        let file_should_not_be_instrumented =
          (* Bisect_ppx is hardcoded to ignore files with certain names. If we
             have one of these, return the AST uninstrumented. In particular,
             do not recurse into it. *)
          let always_ignore_paths = ["//toplevel//"; "(stdin)"] in
          let always_ignore_basenames = [".ocamlinit"; "topfind"] in

          List.mem path always_ignore_paths ||
          List.mem (Filename.basename path) always_ignore_basenames ||
          Exclusions.contains_file path ||
          Coverage_attributes.has_exclude_file_attribute ast
        in

        if file_should_not_be_instrumented then
          ast

        else begin
          let (instrumented_ast, errors) = super#structure ctxt ast in
          let errors =
            errors
            |> List.map (fun error ->
              Ast_builder.Default.pstr_extension
                ~loc:(Location.Error.get_location error)
                (Location.Error.to_extension error)
                [])
          in
          let runtime_initialization =
            Generated_code.runtime_initialization points path in
          errors @ runtime_initialization @ instrumented_ast
        end
      in

      structure_instrumentation_suppressed <-
        saved_structure_instrumentation_suppressed;

      result
end
