Source file location_check.ml

open Import

module Non_intersecting_ranges : sig
  type t

  val empty : t

  val insert : node_name:string -> Location.t -> t -> t

  val union : t -> t -> t

  val covered_by : t -> loc:Location.t -> bool
  (** [covered_by t ~loc = true] iff [t] is covered by [loc] *)

  val find_outside : Location.t -> t -> string * Location.t
end = struct
  type t =
    { min_pos: Lexing.position option
    ; max_pos: Lexing.position option
    ; ranges : (string * Location.t) list
    }

  let empty = { min_pos = None; max_pos = None; ranges = [] }

  let rec insert ranges (node_name, node_loc as node) =
    match ranges with
    | [] -> [ node ]
    | (x_name, x_loc) as x :: xs ->
      let open Location in
      if compare_pos node_loc.loc_start x_loc.loc_end >= 0 then
        node :: x :: xs
      else if compare_pos x_loc.loc_start node_loc.loc_end >= 0 then
        x :: insert xs node
      else
        raise_errorf ~loc:node_loc
          "invalid output from ppx, %s overlaps with %s at location:@.%a"
          node_name x_name Location.print x_loc

  let min_pos p1 p2 =
    match p1, p2 with
    | None, None -> None
    | (Some _ as p), None
    | None, (Some _ as p) -> p
    | Some p1, Some p2 -> Some (Location.min_pos p1 p2)

  let max_pos p1 p2 =
    match p1, p2 with
    | None, None -> None
    | (Some _ as p), None
    | None, (Some _ as p) -> p
    | Some p1, Some p2 -> Some (Location.max_pos p1 p2)

  let longest_first l1 l2 ~stop_after =
    let rec loop xs ys n =
      match xs, ys, n with
      | [], _, _
      | _, _, 0 -> l2, l1
      | _, [], _ -> l1, l2
      | _ :: xs, _ :: ys, n -> loop xs ys (n - 1)
    in
    loop l1 l2 stop_after

  let union t1 t2 =
    let init, l = longest_first t1.ranges t2.ranges ~stop_after:42 in
    let ranges = List.fold_left l ~init ~f:insert in
    { min_pos = min_pos t1.min_pos t2.min_pos
    ; max_pos = max_pos t1.max_pos t2.max_pos
    ; ranges }

  let insert ~node_name loc t =
    { min_pos = min_pos (Some loc.loc_start) t.min_pos
    ; max_pos = max_pos (Some loc.loc_end) t.max_pos
    ; ranges = insert t.ranges (node_name, loc)
    }

  let covered_by t ~loc =
    match t.min_pos, t.max_pos with
    | None, None -> true
    | Some min_pos, Some max_pos ->
      Location.compare_pos min_pos loc.loc_start >= 0 &&
      Location.compare_pos max_pos loc.loc_end <= 0
    | _, _ -> (* there are no open ranges *)
      assert false

  let find_outside loc t =
    List.find t.ranges ~f:(fun (_, l) ->
      Location.compare_pos loc.loc_start l.loc_start > 0 ||
      Location.compare_pos loc.loc_end l.loc_end < 0
    )
end

let reloc_pmty_functors x =
  let outmost_loc = x.pmty_loc in
  let rec aux x =
    match x.pmty_desc with
    | Pmty_functor (Unit, initial_res) ->
      let res = aux initial_res in
      if res == initial_res then
        x
      else
        { x with pmty_desc = Pmty_functor (Unit, res) }
    | Pmty_functor (Named (id, mty), initial_res) ->
      let res = aux initial_res in
      if Location.compare outmost_loc res.pmty_loc = 0 then
        let loc_start = mty.pmty_loc.loc_end in
        let res = { res with pmty_loc = { res.pmty_loc with loc_start } } in
        { x with pmty_desc = Pmty_functor (Named (id, mty), res) }
      else if res == initial_res then
        x
      else
        { x with pmty_desc = Pmty_functor (Named (id, mty), res) }
    | _ -> x
  in
  aux x

let reloc_pmod_functors x =
  let outmost_loc = x.pmod_loc in
  let rec aux x =
    match x.pmod_desc with
    | Pmod_functor (Unit, initial_res) ->
      let res = aux initial_res in
      if res == initial_res then
        x
      else
        { x with pmod_desc = Pmod_functor (Unit, res) }
    | Pmod_functor (Named (id, mty), initial_res) ->
      let res = aux initial_res in
      if Location.compare outmost_loc res.pmod_loc = 0 then
        let loc_start = mty.pmty_loc.loc_end in
        let res = { res with pmod_loc = { res.pmod_loc with loc_start } } in
        { x with pmod_desc = Pmod_functor (Named (id, mty), res) }
      else if res == initial_res then
        x
      else
        { x with pmod_desc = Pmod_functor (Named (id, mty), res) }
    | _ -> x
  in
  aux x

let all_payloads_inside_parent ~loc =
  List.for_all
    ~f:(fun attr -> Location.compare_pos loc.loc_end attr.attr_loc.loc_end >= 0)

let file : string option ref = ref None
let same_file_so_far = ref true

let stayed_in_the_same_file =
  fun fname ->
    (* TODO: remove uses of Location.none from the ppxes. *)
    if String.equal fname "_none_" then
      true (* do nothing for now. *)
    else
      match !file with
      | None -> file := Some fname; true
      | Some orig_fname ->
        String.equal orig_fname fname || (same_file_so_far := false; false)

let should_ignore loc attrs =
  (* If the filename changed, then there were line directives, and the locations
     are all messed up. *)
  not (stayed_in_the_same_file loc.loc_start.pos_fname) ||
  (* Ignore things explicitely marked. *)
  List.exists ~f:(fun attr ->
    String.equal attr.attr_name.txt Merlin_helpers.hide_attribute.attr_name.txt
  ) attrs

let rec extract_constraint e =
  match e.pexp_desc with
  | Pexp_constraint (e, ct)
  | Pexp_coerce (e, None, ct) -> Some (e, ct)
  | Pexp_newtype (name, exp) ->
    Option.map (extract_constraint exp) ~f:(fun (exp, ct) ->
      { e with
        pexp_desc = Pexp_newtype (name, exp);
        pexp_loc = { e.pexp_loc with loc_ghost = true }
      }, ct
    )
  | _ -> None

let do_check ~node_name node_loc childrens_locs siblings_locs =
  if not !same_file_so_far then
    Non_intersecting_ranges.empty
  else if node_loc.loc_ghost then
    Non_intersecting_ranges.union childrens_locs siblings_locs
  else if Non_intersecting_ranges.covered_by childrens_locs ~loc:node_loc then
    Non_intersecting_ranges.insert ~node_name node_loc siblings_locs
  else
    let child_name, child_loc =
      Non_intersecting_ranges.find_outside node_loc childrens_locs
    in
    Location.raise_errorf ~loc:node_loc
      "invalid output from ppx:@ this %s is built from a%s whose location is outside \
       of this node's.@.Child %s found at:@ %a"
      node_name
      ((match String.unsafe_get child_name 0 with
         | 'a' | 'e' | 'i' | 'o' | 'u' -> "n "
         | _ -> " ") ^ child_name)
      child_name Location.print child_loc

let enforce_invariants fname =
  let () = file := fname in
  object(self)
    inherit [Non_intersecting_ranges.t] Ast_traverse.fold as super

    (* TODO: we should generate a class which enforces the location invariant.
       And then we should only override the methods where we need an escape
       hatch because the parser isn't doing the right thing.

       That would ensure that we stay up to date as the AST changes. *)

    method! longident_loc x siblings =
      if x.loc.loc_ghost then
        siblings
      else
        Non_intersecting_ranges.insert ~node_name:"ident" x.loc siblings

    method! row_field x siblings_locs =
      if should_ignore x.prf_loc x.prf_attributes then
        siblings_locs
      else
        let childrens_locs = super#row_field x Non_intersecting_ranges.empty in
        do_check ~node_name:"row field" x.prf_loc childrens_locs siblings_locs

    method! object_field x siblings_locs =
      if should_ignore x.pof_loc x.pof_attributes then
        siblings_locs
      else
        let childrens_locs = super#object_field x Non_intersecting_ranges.empty in
        do_check ~node_name:"object field" x.pof_loc childrens_locs siblings_locs

    method! binding_op x siblings_locs =
      let childrens_locs = super#binding_op x Non_intersecting_ranges.empty in
      do_check ~node_name:"binding operator" x.pbop_loc childrens_locs siblings_locs

    method! value_description x siblings_locs =
      if should_ignore x.pval_loc x.pval_attributes then
        siblings_locs
      else
        let childrens_locs = super#value_description x Non_intersecting_ranges.empty in
        do_check ~node_name:"value description" x.pval_loc childrens_locs siblings_locs

    method! type_declaration x siblings_locs =
      if should_ignore x.ptype_loc x.ptype_attributes then
        siblings_locs
      else
        let childrens_locs = super#type_declaration x Non_intersecting_ranges.empty in
        do_check ~node_name:"type declaration" x.ptype_loc childrens_locs siblings_locs

    method! label_declaration x siblings_locs =
      if should_ignore x.pld_loc x.pld_attributes then
        siblings_locs
      else
        let childrens_locs = super#label_declaration x Non_intersecting_ranges.empty in
        do_check ~node_name:"label declaration" x.pld_loc childrens_locs siblings_locs

    method! constructor_declaration x siblings_locs =
      if should_ignore x.pcd_loc x.pcd_attributes then
        siblings_locs
      else
        let childrens_locs =
          super#constructor_declaration x Non_intersecting_ranges.empty
        in
        do_check ~node_name:"constructor declaration" x.pcd_loc childrens_locs
          siblings_locs

    method! type_extension x siblings_locs =
      if should_ignore x.ptyext_loc x.ptyext_attributes then
        siblings_locs
      else
        let childrens_locs = super#type_extension x Non_intersecting_ranges.empty in
        do_check ~node_name:"type extension" x.ptyext_loc childrens_locs siblings_locs

    method! extension_constructor x siblings_locs =
      if should_ignore x.pext_loc x.pext_attributes then
        siblings_locs
      else
        let childrens_locs = super#extension_constructor x Non_intersecting_ranges.empty in
        do_check ~node_name:"extension constructor" x.pext_loc childrens_locs siblings_locs

    method! class_type x siblings_locs =
      if should_ignore x.pcty_loc x.pcty_attributes then
        siblings_locs
      else
        let childrens_locs = super#class_type x Non_intersecting_ranges.empty in
        do_check ~node_name:"class type" x.pcty_loc childrens_locs siblings_locs

    method! class_type_field x siblings_locs =
      if should_ignore x.pctf_loc x.pctf_attributes then
        siblings_locs
      else
        let childrens_locs = super#class_type_field x Non_intersecting_ranges.empty in
        do_check ~node_name:"class type field" x.pctf_loc childrens_locs siblings_locs

    method! class_infos f x siblings_locs =
      if should_ignore x.pci_loc x.pci_attributes then
        siblings_locs
      else
        let childrens_locs = super#class_infos f x Non_intersecting_ranges.empty in
        do_check ~node_name:"class" x.pci_loc childrens_locs siblings_locs

    method! class_expr x siblings_locs =
      if should_ignore x.pcl_loc x.pcl_attributes then
        siblings_locs
      else
        let childrens_locs = super#class_expr x Non_intersecting_ranges.empty in
        do_check ~node_name:"class expression" x.pcl_loc childrens_locs siblings_locs

    method! class_field x siblings_locs =
      if should_ignore x.pcf_loc x.pcf_attributes then
        siblings_locs
      else
        let childrens_locs = super#class_field x Non_intersecting_ranges.empty in
        do_check ~node_name:"class field" x.pcf_loc childrens_locs siblings_locs

    method! signature_item x siblings_locs =
      if should_ignore x.psig_loc [] then
        siblings_locs
      else
        let childrens_locs = super#signature_item x Non_intersecting_ranges.empty in
        do_check ~node_name:"signature item" x.psig_loc childrens_locs siblings_locs

    method! module_declaration x siblings_locs =
      if should_ignore x.pmd_loc x.pmd_attributes then
        siblings_locs
      else
        let childrens_locs = super#module_declaration x Non_intersecting_ranges.empty in
        do_check ~node_name:"module declaration" x.pmd_loc childrens_locs siblings_locs

    method! module_substitution x siblings_locs =
      if should_ignore x.pms_loc x.pms_attributes then
        siblings_locs
      else
        let childrens_locs = super#module_substitution x Non_intersecting_ranges.empty in
        do_check ~node_name:"module substitution" x.pms_loc childrens_locs siblings_locs

    method! module_type_declaration x siblings_locs =
      if should_ignore x.pmtd_loc x.pmtd_attributes then
        siblings_locs
      else
        let childrens_locs =
          super#module_type_declaration x Non_intersecting_ranges.empty
        in
        do_check ~node_name:"module type declaration" x.pmtd_loc childrens_locs siblings_locs

    method! open_infos f x siblings_locs =
      if should_ignore x.popen_loc x.popen_attributes then
        siblings_locs
      else
        let childrens_locs = super#open_infos f x Non_intersecting_ranges.empty in
        do_check ~node_name:"open" x.popen_loc childrens_locs siblings_locs

    method! include_infos f x siblings_locs =
      if should_ignore x.pincl_loc x.pincl_attributes then
        siblings_locs
      else
        let childrens_locs = super#include_infos f x Non_intersecting_ranges.empty in
        do_check ~node_name:"include" x.pincl_loc childrens_locs siblings_locs

    method! structure_item x siblings_locs =
      if should_ignore x.pstr_loc [] then
        siblings_locs
      else
        let childrens_locs = super#structure_item x Non_intersecting_ranges.empty in
        do_check ~node_name:"structure item" x.pstr_loc childrens_locs siblings_locs

    method! module_binding x siblings_locs =
      if should_ignore x.pmb_loc x.pmb_attributes then
        siblings_locs
      else
        let childrens_locs = super#module_binding x Non_intersecting_ranges.empty in
        do_check ~node_name:"module binding" x.pmb_loc childrens_locs siblings_locs

    (******************************************)
    (* The following is special cased because *)
    (* the type constraint is duplicated.     *)
    (******************************************)

    method! value_binding x siblings_locs =
      if should_ignore x.pvb_loc x.pvb_attributes then
        siblings_locs
      else
        let childrens_locs =
          match x.pvb_pat.ppat_desc, extract_constraint x.pvb_expr with
          | (* let x : type a b c. ct = e *)
            Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly (_ :: _, ctp); _ }),
            Some (pvb_expr, cte)
          | (* let x :  ct = e
               let x :> ct = e *)
            Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly ([], ctp); _ }),
            Some (pvb_expr, cte)
            when Location.compare ctp.ptyp_loc cte.ptyp_loc = 0 ->
            let acc = Non_intersecting_ranges.empty in
            let acc = self#pattern pvb_pat acc in
            let _acc = self#core_type ctp acc in
            let acc = self#expression pvb_expr acc in
            let acc = self#attributes x.pvb_attributes acc in
            acc
          | _ ->
            super#value_binding x Non_intersecting_ranges.empty
        in
        do_check ~node_name:"value binding" x.pvb_loc childrens_locs siblings_locs

    (**********************************************)
    (* The following is special cased because of: *)
    (*     MT [@attr payload]                     *)
    (* where the loc of payload is outside the    *)
    (* loc of the module type....                 *)
    (* and                                        *)
    (*     functor (A : S) (B : S) ...            *)
    (* where the loc of [(B : S) ...] is the same *)
    (* as the loc of the outermost module type.   *)
    (**********************************************)

    method! module_type x siblings_locs =
      if should_ignore x.pmty_loc x.pmty_attributes then
        siblings_locs
      else
        let x = reloc_pmty_functors x in
        let childrens_locs =
          if all_payloads_inside_parent ~loc:x.pmty_loc x.pmty_attributes then
            super#module_type x Non_intersecting_ranges.empty
          else
            let acc = self#module_type_desc x.pmty_desc Non_intersecting_ranges.empty in
            let _ = self#attributes x.pmty_attributes acc in
            acc
        in
        do_check ~node_name:"module type" x.pmty_loc childrens_locs siblings_locs

    (**********************************************)
    (* The following is special cased because of: *)
    (*     ME [@attr payload]                     *)
    (* where the loc of payload is outside the    *)
    (* loc of the module expr....                 *)
    (* and                                        *)
    (*     functor (A : S) (B : S) ...            *)
    (* where the loc of [(B : S) ...] is the same *)
    (* as the loc of the outermost module expr.   *)
    (**********************************************)

    method! module_expr x siblings_locs =
      if should_ignore x.pmod_loc x.pmod_attributes then
        siblings_locs
      else
        let x = reloc_pmod_functors x in
        let childrens_locs =
          if all_payloads_inside_parent ~loc:x.pmod_loc x.pmod_attributes then
            super#module_expr x Non_intersecting_ranges.empty
          else
            let acc = self#module_expr_desc x.pmod_desc Non_intersecting_ranges.empty in
            let _ = self#attributes x.pmod_attributes acc in
            acc
        in
        do_check ~node_name:"module expression" x.pmod_loc childrens_locs siblings_locs

    (*********************)
    (* Same as above ... *)
    (*********************)

    method! core_type x siblings_locs =
      if should_ignore x.ptyp_loc x.ptyp_attributes then
        siblings_locs
      else
        let childrens_locs =
          if all_payloads_inside_parent ~loc:x.ptyp_loc x.ptyp_attributes then
            super#core_type x Non_intersecting_ranges.empty
          else
            let acc = self#core_type_desc x.ptyp_desc Non_intersecting_ranges.empty in
            let _ = self#attributes x.ptyp_attributes acc in
            acc
        in
        do_check ~node_name:"core type" x.ptyp_loc childrens_locs siblings_locs

    (*****************)
    (* And again ... *)
    (*****************)

    method! expression x siblings_locs =
      if should_ignore x.pexp_loc x.pexp_attributes then
        siblings_locs
      else
        let childrens_locs =
          if all_payloads_inside_parent ~loc:x.pexp_loc x.pexp_attributes then
            super#expression x Non_intersecting_ranges.empty
          else
            let acc = self#expression_desc x.pexp_desc Non_intersecting_ranges.empty in
            let _ = self#attributes x.pexp_attributes acc in
            acc
        in
        do_check ~node_name:"expression" x.pexp_loc childrens_locs siblings_locs

    (*****************)
    (* ... and again *)
    (*****************)

    method! pattern x siblings_locs =
      if should_ignore x.ppat_loc x.ppat_attributes then
        siblings_locs
      else
        let childrens_locs =
          if all_payloads_inside_parent ~loc:x.ppat_loc x.ppat_attributes then
            super#pattern x Non_intersecting_ranges.empty
          else
            let acc = self#pattern_desc x.ppat_desc Non_intersecting_ranges.empty in
            let _ = self#attributes x.ppat_attributes acc in
            acc
        in
        do_check ~node_name:"pattern" x.ppat_loc childrens_locs siblings_locs


    (***********************************************************)
    (* The following is special cased because the location of  *)
    (* the construct equals the location of the type_exception *)
    (* (and so covers the location of the attributes).         *)
    (***********************************************************)

    method! type_exception x siblings_locs =
      if should_ignore x.ptyexn_loc x.ptyexn_attributes then
        siblings_locs
      else
        let init = Non_intersecting_ranges.empty in
        let childs_locs = self#extension_constructor x.ptyexn_constructor init in
        let attrs_locs = self#attributes x.ptyexn_attributes init in
        ignore (do_check ~node_name:"exception" x.ptyexn_loc attrs_locs siblings_locs);
        do_check ~node_name:"exception" x.ptyexn_loc childs_locs siblings_locs

    (******************************************)
    (* The following is overriden because the *)
    (* lhs is sometimes included in the rhs.  *)
    (******************************************)

    method! with_constraint x siblings_loc =
      match x with
      | Pwith_type (_, tdecl)
      | Pwith_typesubst (_, tdecl) ->
        self#type_declaration tdecl siblings_loc
      | _ ->
        super#with_constraint x siblings_loc


    (******************************************)
    (* The following is overriden because of: *)
    (* - Foo.{ bar; ... }                     *)
    (* - Foo.[ bar; ... ]                     *)
    (* - Foo.( bar; ... )                     *)
    (* - method x : type a. ... = ...         *)
    (* - foo.@(bar)                           *)
    (* - foo.@(bar) <- baz                    *)
    (* - foo.%.{bar}                          *)
    (* - foo.%.{bar} <- baz                   *)
    (* - foo.%.[bar]                          *)
    (* - foo.%.[bar] <- baz                   *)
    (******************************************)

    method! expression_desc x acc =
      match x with
      | Pexp_record (labels, expr_o) ->
        let acc =
          self#list
            (fun (lid, e) acc->
               if Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0 then
                 if Location.compare lid.loc e.pexp_loc = 0 then
                   (* punning. *)
                   self#longident_loc lid acc
                 else
                   match e.pexp_desc with
                   | Pexp_constraint (e, c) ->
                     (* { foo : int } and { foo : int = x } ... *)
                     let _ = self#core_type c acc in
                     self#expression e acc
                   | _ ->
                     (* No idea what's going on there. *)
                     self#expression e acc
               else
                 let acc = self#longident_loc lid acc in
                 let acc = self#expression e acc in acc) labels acc
        in
        self#option self#expression expr_o acc
      | Pexp_open ({ popen_expr = { pmod_desc = Pmod_ident lid; _ }; _ } as opn, e)
        when Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0
          && Location.compare_pos lid.loc.loc_end e.pexp_loc.loc_end <> 0 ->
        (* let's relocate ... *)
        let e_loc = { e.pexp_loc with loc_start = lid.loc.loc_end } in
        super#expression_desc (Pexp_open (opn, { e with pexp_loc = e_loc })) acc
      | Pexp_poly (e, Some { ptyp_desc = Ptyp_poly (_, ct); _ }) ->
        begin match extract_constraint e with
        | Some (e, cte) when Location.compare cte.ptyp_loc ct.ptyp_loc = 0 ->
          let acc = self#expression e acc in
          let acc = self#core_type ct acc in
          acc
        | _ ->
          super#expression_desc x acc
        end
      | Pexp_apply ({ pexp_desc = Pexp_ident { txt = lid; _ }; _ }, args) ->
        begin match Longident.last_exn lid with
        | id when String.is_prefix id ~prefix:"."
               && (String.is_suffix id ~suffix:"()" ||
                   String.is_suffix id ~suffix:"()<-" ||
                   String.is_suffix id ~suffix:"[]" ||
                   String.is_suffix id ~suffix:"[]<-" ||
                   String.is_suffix id ~suffix:"{}" ||
                   String.is_suffix id ~suffix:"{}<-") ->
          self#list (fun (_, e) -> self#expression e) args acc
        | exception _ -> super#expression_desc x acc
        | _ -> super#expression_desc x acc
        end
      | _ ->
        super#expression_desc x acc

    (*******************************************************)
    (* The following is overriden because of:              *)
    (* - punning.                                          *)
    (* - record field with type constraint.                *)
    (* - unpack locations being incorrect when constrained *)
    (*******************************************************)

    method! pattern_desc x acc =
      match x with
      | Ppat_record (labels, _) ->
        self#list
          (fun (lid, pat) acc ->
             if Location.compare_pos lid.loc.loc_start pat.ppat_loc.loc_start = 0 then
               if Location.compare lid.loc pat.ppat_loc = 0 then
                 (* simple punning! *)
                 self#longident_loc lid acc
               else
                 match pat.ppat_desc with
                 | Ppat_constraint (p, c) ->
                   (* { foo : int } and { foo : int = x } ... *)
                   let _ = self#core_type c acc in
                   self#pattern p acc
                 | _ ->
                   (* No idea what's going on there. *)
                   self#pattern pat acc
             else
               let acc = self#longident_loc lid acc in
               let acc = self#pattern pat acc in acc) labels acc
      | Ppat_constraint ({ ppat_desc = Ppat_unpack a; _ }, b) ->
        let acc = self#loc (self#option self#string) a acc in
        self#core_type b acc
      | _ ->
        super#pattern_desc x acc

    (**********************************************************)
    (* The following is overriden because the location of the *)
    (* fake structure for a generative argument covers the    *)
    (* location of the functor.                               *)
    (**********************************************************)

    method! module_expr_desc x acc =
      match x with
      | Pmod_apply (m, { pmod_desc = Pmod_structure []; pmod_loc; _ })
        when Location.compare_pos m.pmod_loc.loc_start pmod_loc.loc_start = 0 ->
        super#module_expr m acc
      | _ ->
        super#module_expr_desc x acc

    (**********************************************************)
    (* The following is overriden because the location of the *)
    (* open_infos for Pcl_open only covers the "open" keyword *)
    (* and not the module opened.                             *)
    (**********************************************************)

    method! class_expr_desc x acc =
      match x with
      | Pcl_open (od, ce) ->
        (* inline of open_description (which effectively makes that node
           disappear) *)
        let acc = self#longident_loc od.popen_expr acc in
        let acc = self#override_flag od.popen_override acc in
        let acc = self#location od.popen_loc acc in
        let acc = self#attributes od.popen_attributes acc in
        (* continue *)
        let acc = self#class_expr ce acc in
        acc
      | _ ->
        super#class_expr_desc x acc

    (*********************)
    (* Same as above ... *)
    (*********************)

    method! class_type_desc x acc =
      match x with
      | Pcty_open (od, ct) ->
        (* inline of open_description (which effectively makes that node
           disappear) *)
        let acc = self#longident_loc od.popen_expr acc in
        let acc = self#override_flag od.popen_override acc in
        let acc = self#location od.popen_loc acc in
        let acc = self#attributes od.popen_attributes acc in
        (* continue *)
        let acc = self#class_type ct acc in
        acc
      | _ ->
        super#class_type_desc x acc

    (**********************************************************)
    (* The following is overriden because docstrings have the *)
    (* same location as the item they get attached to.        *)
    (**********************************************************)

    method! attribute x acc =
      match x.attr_name.txt with
      | "ocaml.doc"
      | "ocaml.text" ->
        acc
      | _ -> super#attribute x acc

  end