camlspotter avatar camlspotter committed e3ce35d

big change is ongoing

Comments (0)

Files changed (7)

 locident.cmi :
 name.cmi :
 pathreparse.cmi : spot.cmi
-spot.cmi : utils.cmi ttfold.cmo
+spot.cmi : utils.cmi
 spotconfig.cmi : spotconfig_intf.cmo
 spoteval.cmi : utils.cmi spot.cmi
 spotfile.cmi : spoteval.cmi spot.cmi
     spotconfig.cmx spot.cmx ext.cmx command.cmx cmt.cmx
 pathreparse.cmo : utils.cmi spot.cmi locident.cmi ext.cmo pathreparse.cmi
 pathreparse.cmx : utils.cmx spot.cmx locident.cmx ext.cmx pathreparse.cmi
-spot.cmo : utils.cmi ttfold.cmo treeset.cmi ext.cmo cmt.cmi checksum.cmo \
-    spot.cmi
-spot.cmx : utils.cmx ttfold.cmx treeset.cmx ext.cmx cmt.cmx checksum.cmx \
-    spot.cmi
+spot.cmo : spot.cmi
+spot.cmx : spot.cmi
 spotconfig.cmo : utils.cmi spot.cmi ext.cmo spotconfig.cmi
 spotconfig.cmx : utils.cmx spot.cmx ext.cmx spotconfig.cmi
 spotconfig_intf.cmo : spot.cmi ext.cmo
     cmt.cmx spotfile.cmi
 treeset.cmo : xset.cmi treeset.cmi
 treeset.cmx : xset.cmx treeset.cmi
-ttfold.cmo :
-ttfold.cmx :
 typeFix.cmo : utils.cmi name.cmi typeFix.cmi
 typeFix.cmx : utils.cmx name.cmx typeFix.cmi
 typeexpand.cmo : utils.cmi typeexpand.cmi
 COMPFLAGS= -g $(INCLUDES_DEP) -I +unix
 
 MODULES= utils checksum fileident filepath dotfile compdir xset treeset command typeexpand \
-	xlongident name xident xpath locident typeFix xprinttyp ext ttfold cmt spot spoteval spotconfig_intf spotconfig spotfile ocamlspot # pathreparse 
+	xlongident name xident xpath locident typeFix xprinttyp ext cmt spot spoteval spotconfig_intf spotconfig spotfile ocamlspot # pathreparse 
 
 OBJS=		$(addsuffix .cmo, $(MODULES))
 
 typedtreefold.cmo: typedtreefold.ml
 	$(OCAMLC) -I +compiler-libs -pp 'camlp4o Camlp4FoldGenerator.cmo' typedtreefold.ml
 
-ttfold.out.ml: typedtreefold.ml
-	camlp4o -printer Camlp4OCamlPrinter Camlp4FoldGenerator.cmo typedtreefold.ml > $@
-
 .ml.cmo:
 	$(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
 
     include M
     module Table = Hashtbl.Make(M)
   end
+end
 
+module Annot = struct
+  type t =
+    | Use               of Kind.t * Path.t
+    | Type              of Types.type_expr * Env.t * [`Expr of Path.t option | `Pattern of Ident.t option ]
+    | Mod_type          of Types.module_type
+    | Str_item          of Abstraction.structure_item
+    | Module            of Abstraction.module_expr
+    | Functor_parameter of Ident.t
+    | Non_expansive     of bool
+
+  let _equal t1 t2 = match t1, t2 with
+    | Type (t1, _, _), Type (t2, _, _) -> t1 == t2
+    | Mod_type mty1, Mod_type mty2 -> mty1 == mty2
+    | Str_item sitem1, Str_item sitem2 -> Abstraction.Structure_item.equal sitem1 sitem2
+    | Module mexp1, Module mexp2 -> mexp1 == mexp2
+    | Use (k1,p1), Use (k2,p2) -> k1 = k2 && p1 = p2
+    | Non_expansive b1, Non_expansive b2 -> b1 = b2
+    | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
+    | (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
+          | Mod_type _),
+      (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
+          | Mod_type _) -> false
+
+  let string_of_at = function
+    | `Expr _ -> "Expr"
+    | `Pattern _ -> "Pattern"
+
+  let format ppf = function
+    | Type (typ, _env, at) ->
+	Printtyp.reset ();
+	Printtyp.mark_loops typ;
+        (* CR jfuruse: not fancy having @. *)
+	fprintf ppf "Type: %a;@ " (Printtyp.type_scheme ~with_pos:false) typ;
+	fprintf ppf "XType: %a;@ " (Printtyp.type_scheme ~with_pos:true) typ;
+        fprintf ppf "At: %s;" (string_of_at at)
+    | Mod_type mty ->
+	fprintf ppf "Type: %a;@ " (Printtyp.modtype ~with_pos:false) mty;
+	fprintf ppf "XType: %a;" (Printtyp.modtype ~with_pos:true) mty
+    | Str_item str ->
+	fprintf ppf "Str_item: %a"
+	  Abstraction.format_structure_item str
+    | Use (use, path) ->
+	fprintf ppf "Use: %s, %s"
+	  (String.capitalize (Kind.name use)) (Path.name path)
+    | Module mexp ->
+	fprintf ppf "Module: %a"
+          Abstraction.format_module_expr mexp
+    | Functor_parameter id ->
+	fprintf ppf "Functor_parameter: %s" (Ident.name id)
+    | Non_expansive b ->
+        fprintf ppf "Non_expansive: %b" b
+
+  let summary ppf = function
+    | Type (_typ, _env, at) ->
+        (* CR jfuruse: not fancy having @. *)
+	fprintf ppf "Type: ...@ ";
+	fprintf ppf "XType: ...@ ";
+        fprintf ppf "At: %s" (string_of_at at)
+    | Mod_type _mty ->
+	fprintf ppf "Type: ...@ ";
+	fprintf ppf "XType: ..."
+    | Str_item _str ->
+	fprintf ppf "Str_item: ..."
+    | Use (use, path) ->
+	fprintf ppf "Use: %s, %s"
+	  (String.capitalize (Kind.name use)) (Path.name path)
+    | Module _mexp ->
+	fprintf ppf "Module: ..."
+    | Functor_parameter id ->
+	fprintf ppf "Functor_parameter: %s" (Ident.name id)
+    | Non_expansive b ->
+        fprintf ppf "Non_expansive: %b" b
+
+  let dummy = Use (Kind.Value, Path.Pident (Ident.create_persistent "dummy"))
+end
+
+  module Record = struct
+    open Typedtree
+    open Abstraction
+    open Location
+    open Annot
+
+    (* CR jfuruse: A Location.t contains a filename, though it is always
+       unique. Waste of 4xn bytes. *)
+    (*
+    let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)
+    let clear () = Hashtbl.clear recorded
+    *)
+
+    type location_property = Wellformed | Flipped | Over_files | Illformed
+
+    let check_location loc =
+      if loc.loc_start == Lexing.dummy_pos || loc.loc_end == Lexing.dummy_pos then Illformed
+      else if loc.loc_start = Lexing.dummy_pos || loc.loc_end = Lexing.dummy_pos then Illformed
+      else
+        (* If the file name is different between the start and the end, we cannot tell the wellformedness. *)
+        if loc.loc_start.Lexing.pos_fname <> loc.loc_end.Lexing.pos_fname then Over_files
+        else
+          (* P4 creates some flipped locations where loc_start > loc_end *)
+          match compare loc.loc_start.Lexing.pos_cnum loc.loc_end.Lexing.pos_cnum
+          with
+          | -1 | 0 -> Wellformed
+          | _ -> Flipped
+
+    let record tbl loc t =
+      let really_record () =
+        let records = try Hashtbl.find tbl loc with Not_found -> [] in
+(*
+        (* CR jfuruse: I am not really sure the below is correct now,
+           but I remember the huge compilation slow down... *)
+        (* This caching works horribly when too many things are defined
+           at the same location. For example, a type definition of more than
+           3000 variants, with sexp camlp4 extension, the compile time explodes
+           from 10secs to 4mins! Therefore this works
+           only if [num_records <= 10]
+        *)
+        if num_records <= 10 && List.exists (equal t) records then ()
+        else Hashtbl.replace tbl loc (num_records + 1, t :: records)
+*)
+        Hashtbl.replace tbl loc (t :: records)
+      in
+      match check_location loc with
+      | Wellformed -> really_record ()
+      | Flipped | Illformed ->
+          if not loc.loc_ghost then Format.eprintf "%aWarning: Ill-formed location.@." Location.print loc
+      | Over_files -> ()
+
+    let record_record tbl loc typ =
+      let open Types in
+      let open Ctype in
+      match (repr typ).desc with
+      | Tconstr (path, _, _) -> record tbl loc (Use (Kind.Type, path))
+      | _ -> (* strange.. *) assert false
+
+    let record_construct tbl loc cdesc =
+      let open Types in
+      match cdesc.cstr_tag with
+      | Cstr_exception (path,_) -> record tbl loc (Use (Kind.Exception, path))
+      | _ -> 
+          let path = 
+            let ty = cdesc.cstr_res in
+            match (Ctype.repr ty).desc with
+            | Tconstr (p, _, _) -> p
+            | _ -> assert false
+          in
+          record tbl loc (Use (Kind.Type, path))
+
+
+  let structure o str =
+    ignore (o#structure str);
+    o#report
+
+  let signature o sg =
+    ignore (o#signature sg);
+    o#report
+
+(*
+  let record_structure str =
+    protect' "Spot.Annot.record_structure" (fun () ->
+      let tbl = Hashtbl.create 1023 in
+      let o = new Record.fold tbl in
+      structure o str;
+      o#table)
+      ()
+
+  let record_signature sg =
+    protect' "Spot.Annot.record_signature" (fun () ->
+      let tbl = Hashtbl.create 1023 in
+      let o = new Record.fold tbl in
+      signature o sg;
+      o#table)
+      ()
+*)
+
+ end
+
+module EXTRACT = struct
   open Types
-  open Typedtree
+  open! Typedtree
   open Asttypes
+  open Abstraction
+  open Annot
 
   let cache_module_expr = Module_expr.Table.create 31
   let cache_structure_item = Structure_item.Table.create 31
     Module_expr.Table.clear cache_module_expr;
     Structure_item.Table.clear cache_structure_item
 
+  let tbl = Hashtbl.create 1023 (* CR jfuruse: global *)
+
+  type location_property = Wellformed | Flipped | Over_files | Illformed
+
+  let check_location loc =
+    let open Location in
+    let open Lexing in
+    if loc.loc_start == dummy_pos || loc.loc_end == dummy_pos then Illformed
+    else if loc.loc_start = dummy_pos || loc.loc_end = dummy_pos then Illformed
+    else
+      (* If the file name is different between the start and the end, we cannot tell the wellformedness. *)
+      if loc.loc_start.pos_fname <> loc.loc_end.pos_fname then Over_files
+      else
+        (* P4 creates some flipped locations where loc_start > loc_end *)
+        match compare loc.loc_start.pos_cnum loc.loc_end.pos_cnum
+        with
+        | -1 | 0 -> Wellformed
+        | _ -> Flipped
+
+  let record loc t =
+    let really_record () =
+      let records = try Hashtbl.find tbl loc with Not_found -> [] in
+(*
+        (* CR jfuruse: I am not really sure the below is correct now,
+           but I remember the huge compilation slow down... *)
+        (* This caching works horribly when too many things are defined
+           at the same location. For example, a type definition of more than
+           3000 variants, with sexp camlp4 extension, the compile time explodes
+           from 10secs to 4mins! Therefore this works
+           only if [num_records <= 10]
+        *)
+        if num_records <= 10 && List.exists (equal t) records then ()
+        else Hashtbl.replace tbl loc (num_records + 1, t :: records)
+*)
+      Hashtbl.replace tbl loc (t :: records)
+    in
+    match check_location loc with
+    | Wellformed -> really_record ()
+    | Flipped | Illformed ->
+        if not loc.loc_ghost then Format.eprintf "%aWarning: Ill-formed location.@." Location.print loc
+    | Over_files -> ()
+
+  let record_def loc sitem = record loc (Str_item sitem)
+  let record_use loc kind path = record loc (Use (kind, path))
+
+  let record_use_construct loc kind path name = 
+    (* Note, this is different from record_record and record_construct *)
+    assert (match kind with Kind.Constructor | Field -> true | _ -> false);
+    record loc (Use (kind, Path.Pdot (path, name, -1 (* dummy *)))) 
+
+  let with_record_def loc sitem = record loc (Str_item sitem); sitem
+
   module T = struct
-(*
-    let kident_of_sigitem = function
-      | Sig_value (id, _)         -> Kind.Value       , id
-      | Sig_exception (id, _)     -> Kind.Exception   , id
-      | Sig_module (id, _, _)     -> Kind.Module      , id
-      | Sig_type (id, _, _)       -> Kind.Type        , id
-      | Sig_modtype (id, _)       -> Kind.Module_type , id
-      | Sig_class (id, _, _)      -> Kind.Class       , id
-      | Sig_class_type (id, _, _) -> Kind.Class_type  , id
-*)
 
     let rec signature sg = AMod_structure (List.flatten (List.map signature_item sg))
 
     in
     aliases_of_include' sg includer_sg
 
+  let class_infos f { ci_virt=_;
+                      ci_params; (* string loc list * Location.t; *)
+                      ci_id_name = {loc}; (* : string loc; *)
+                      ci_id_class; (* : Ident.t; *)
+                      ci_id_class_type; (*  : Ident.t; *)
+                      ci_id_object; (*  : Ident.t; *)
+                      ci_id_typesharp; (*  : Ident.t; *)
+                      ci_expr; (* : 'a; *)
+                      ci_decl=_; (* : Types.class_declaration; *)
+                      ci_type_decl=_; (*  : Types.class_type_declaration; *)
+                      ci_variance=_; (* : (bool * bool) list; *)
+                      ci_loc=_; (* : Location.t *) } =
+      f ci_expr;
+      List.map (with_record_def loc)
+        [ AStr_class ci_id_class;
+          AStr_class_type ci_id_class_type;
+          AStr_type (ci_id_object, []);
+          AStr_type (ci_id_typesharp, []) ]
+    
+
+  let get_constr_path typ = 
+    match (Ctype.repr typ).desc with
+    | Tconstr (path, _, _) -> path
+    | _ -> (* strange.. *) assert false
+
   let rec module_expr mexp =
     try
       match Module_expr.Table.find cache_module_expr mexp with
         res
 
   and module_expr_desc = function
-    | Tmod_ident (p, _) -> AMod_ident p
+    | Tmod_ident (p, {loc}) -> 
+        record_use loc Kind.Module p;
+        AMod_ident p
     | Tmod_structure str ->
 	(* This may recompute abstractions of structure_items.
 	   It sounds inefficient but not so much actually, since
 	   module_expr is nicely cached. *)
 	structure str
     | Tmod_functor (id, _, mty, mexp) ->
+        ignore & module_type mty;
 	AMod_functor(id, mty.mty_type, module_expr mexp)
     | Tmod_apply (mexp1, mexp2, _mcoercion) -> (* CR jfuruse ? *)
 	AMod_apply (module_expr mexp1, module_expr mexp2)
     | Tmod_constraint (mexp, mty_, _constraint, _mcoercion) ->
 	AMod_constraint (module_expr mexp, mty_)
-    | Tmod_unpack (_expr, mty_) ->
+    | Tmod_unpack (expr, mty_) ->
+        ignore & expression expr;
         AMod_unpack (T.module_type mty_) (* CR jfuruse: need to unpack, really? *)
 
   and structure str = AMod_structure (List.concat_map structure_item str.str_items)
 
   and structure_item sitem =
     (* it may recompute the same thing, but it is cheap *)
-    let sitems = structure_item_desc sitem.str_desc in
+    let sitems = structure_item_desc sitem.str_loc sitem.str_desc in
     (* eq consing *)
     let equalize sitem =
       try
     in
     List.map equalize sitems
 
-  and structure_item_desc = function
-    | Tstr_eval _ -> []
-    | Tstr_value (_, pat_exps) ->
-	List.map (fun id -> AStr_value id) (let_bound_idents pat_exps)
-    | Tstr_primitive (id, _, _vdesc) ->
-	[AStr_value id]
-    | Tstr_type id_descs -> List.map (fun (id, _, td) -> type_declaration id td) id_descs
-    | Tstr_exception (id ,_ , _) ->
-	[AStr_exception id]
-    | Tstr_exn_rebind (id, _, _path, _) -> (* CR jfuruse: path? *)
-	[AStr_exception id]
-    | Tstr_module (id, _, mexp) ->
-	[AStr_module (id, module_expr mexp)]
+  and structure_item_desc loc0 = function
+    | Tstr_eval e -> 
+        ignore & expression e; 
+        []
+    | Tstr_value (_flag, pat_exps) ->
+	List.map (fun (pat, exp) ->
+          expression exp;
+          pattern pat) pat_exps
+    | Tstr_primitive (id, {loc}, vdesc) ->
+        value_description vdesc;
+        [ with_record_def loc & AStr_value id ]
+    | Tstr_type id_descs -> 
+        List.map (fun (id, {loc}, td) -> 
+          with_record_def loc & type_declaration id td) id_descs
+    | Tstr_exception (id ,{loc} , exdecl) ->
+        ignore & exception_declaration exdecl;
+	[ with_record_def loc & AStr_exception id ]
+    | Tstr_exn_rebind (id, {loc}, path, {loc=loc'}) -> (* CR jfuruse: path? *)
+        record_use loc' Kind.Exception path;
+        [ with_record_def loc & AStr_exception id ]
+    | Tstr_module (id, {loc}, mexp) ->
+        record loc (Mod_type mexp.mod_type);
+        [ with_record_def loc & AStr_module (id, module_expr mexp) ]
     | Tstr_recmodule (idmexps) ->
-	List.map (fun (id, _, _, mexp) ->
-	  AStr_module (id, module_expr mexp)) idmexps
-    | Tstr_modtype (id, _, mty) -> [AStr_modtype (id, module_type mty)]
-    | Tstr_open _ -> []
+	List.map (fun (id, {loc}, _, mexp) ->
+	  with_record_def loc & AStr_module (id, module_expr mexp)) idmexps
+    | Tstr_modtype (id, {loc}, mty) -> 
+        [ with_record_def loc & AStr_modtype (id, module_type mty) ]
+    | Tstr_open (_, path, {loc}) -> 
+        record_use loc Kind.Module path;
+        []
     | Tstr_class classdescs ->
-	List.map (fun (cls, _names, _) -> AStr_class cls.ci_id_class) classdescs
+	List.concat_map (fun (clsdecl, _names, _) -> 
+          class_declaration clsdecl) classdescs
     | Tstr_class_type iddecls ->
-	List.map (fun (id, _, _) -> AStr_class_type id) iddecls
+	List.map (fun (id, {loc}, clstydecl) -> 
+          class_type_declaration clstydecl; (* no tree but we must go deep *)
+          with_record_def clstydecl.ci_expr.cltyp_loc & AStr_class_type id) iddecls
     | Tstr_include (mexp, sg) ->
         let idmap = try aliases_of_include mexp sg with e -> prerr_endline "structure_item include failed!!!"; raise e in
         let m = module_expr mexp in
         List.map (fun (id_includer, k, id_included) -> 
-          AStr_included (id_includer, m, k, id_included)) idmap
+          with_record_def loc0 & AStr_included (id_includer, m, k, id_included)
+        ) idmap
 
   (* CR jfuruse: TODO: caching like module_expr_sub *)
   and module_type mty = module_type_desc mty.mty_desc
 
   and module_type_desc = function
-    | Tmty_ident (p, _) -> AMod_ident p
+    | Tmty_ident (p, {loc}) -> 
+        record_use loc Kind.Module_type p;
+        AMod_ident p
     | Tmty_signature sg -> signature sg
-    | Tmty_functor (id, _, mty1, mty2) ->
+    | Tmty_functor (id, {loc}, mty1, mty2) ->
         (* CR jfuruse: need to scrape ? but how ? *)
+        record_def loc & AStr_module (id, module_type mty1);
+        ignore & module_type mty2;
         AMod_functor(id, mty1.mty_type, module_type mty2)
-    | Tmty_with (mty, _) -> module_type mty (* CR jfuruse: ?? *)
+    | Tmty_with (mty, lst) -> 
+        lst |> List.iter (fun (path, {loc}, with_constraint) ->
+          record loc (Use ( (match with_constraint with
+                             | Twith_type _      -> Kind.Type
+                             | Twith_module _    -> Kind.Module
+                             | Twith_typesubst _ -> Kind.Type
+                             | Twith_modsubst _  -> Kind.Module)
+                          , path)));
+        module_type mty (* CR jfuruse: ?? *)
     | Tmty_typeof mexp ->  (* CR jfuruse: ?? *)
         T.module_type mexp.mod_type
 
 
   and signature_item sitem =
     match sitem.sig_desc with
-    | Tsig_value (id, _, _) -> [AStr_value id]
-    | Tsig_exception (id, _, _) -> [AStr_exception id]
-    | Tsig_module (id, _ , mty) ->
-        [AStr_module (id, module_type mty)]
-    | Tsig_modtype (id, _, mty_decl) ->
-        [(* todo *) AStr_modtype (id, modtype_declaration mty_decl) (* sitem.sig_final_env can be used? *) ]
-
-    | Tsig_type typs -> List.map (fun (id, _, td) -> type_declaration id td) typs
-    | Tsig_class clses ->
-        (* CR jfuruse: still not sure which one is which *)
-        List.concat_map (fun cls ->
-          [ AStr_class cls.ci_id_class;
-            AStr_class_type  cls.ci_id_class_type;
-            AStr_type (cls.ci_id_object, []);
-            AStr_type (cls.ci_id_typesharp, [])]
-        ) clses
-    | Tsig_class_type clses -> List.map (fun cls -> AStr_class_type cls.ci_id_class) clses
-
+    | Tsig_value (id, {loc}, vdesc) -> 
+        value_description vdesc;
+        [ with_record_def loc & AStr_value id ]
+    | Tsig_type typs -> 
+        List.map (fun (id, {loc}, td) -> 
+          with_record_def loc & type_declaration id td) typs
+    | Tsig_exception (id, {loc}, excdecl) -> 
+        exception_declaration excdecl;
+        [ with_record_def loc & AStr_exception id ]
+    | Tsig_module (id, {loc} , mty) ->
+        [ with_record_def loc & AStr_module (id, module_type mty) ]
     | Tsig_recmodule lst ->
-        List.map (fun (id, _, mty) -> AStr_module (id, module_type mty)) lst
-    | Tsig_open _ -> []
+        List.map (fun (id, {loc}, mty) -> 
+          with_record_def loc & AStr_module (id, module_type mty)) lst
+    | Tsig_modtype (id, {loc}, mty_decl) ->
+        [ with_record_def loc & (* todo *) AStr_modtype (id, modtype_declaration mty_decl) ]
+        (* sitem.sig_final_env can be used? *)
+    | Tsig_open (_flag, p, {loc}) -> 
+        record_use loc Kind.Module p;
+        []
     | Tsig_include (mty, sg) ->
         let m = module_type mty in
         let sg0 = try match Mtype.scrape (Cmt.recover_env mty.mty_env) mty.mty_type with Mty_signature sg -> sg | _ -> assert false with _ -> assert false in
         let idmap = try aliases_of_include' sg0 sg with _ -> assert false in
-        List.map (fun (id, k, id') -> AStr_included (id, m, k, id')) idmap
+        List.map (fun (id, k, id') -> 
+          with_record_def sitem.sig_loc & AStr_included (id, m, k, id')) idmap
+    | Tsig_class clsdescrs ->
+        List.concat_map class_description clsdescrs
+    | Tsig_class_type clstydecls -> 
+        List.concat_map class_type_declaration clstydecls
+          (* AStr_class_type cls.ci_id_class)  *)
+
+  and class_declaration cd = class_infos class_expr cd
+
+  and class_description cd = class_infos class_type cd
+
+  and class_type_declaration cd = class_infos class_type cd
+
+  and class_expr ce = match ce.cl_desc with
+    | Tcl_ident (p, {loc}, core_types) ->
+        record_use loc Kind.Class p;
+        List.iter core_type core_types
+    | Tcl_structure cs -> class_structure cs
+    | Tcl_fun (_label, pat, _pv, clexpr, _partial) ->
+        ignore & pattern pat;
+        class_expr clexpr
+    | Tcl_apply (clexpr, args) ->
+        class_expr clexpr;
+        List.iter (fun (_label, expropt, _optional) ->
+          match expropt with
+          | None -> ()
+          | Some expr -> expression expr) args
+    | Tcl_let (_rec_flag, pat_exp_list, _pv, clexpr) ->
+        List.iter (fun (pat, expr) ->
+          ignore & pattern pat;
+          expression expr) pat_exp_list;
+        class_expr clexpr
+    | Tcl_constraint (clexpr, cltypeopt, _names, _names2, _concr) ->
+        class_expr clexpr;
+        match cltypeopt with
+        | Some cltyp -> class_type cltyp
+        | None -> ()
+
+  and class_type cltyp = match cltyp.cltyp_desc with
+    | Tcty_constr (p, {loc}, core_types) ->
+        record_use loc Kind.Class_type p;
+        List.iter core_type core_types
+    | Tcty_signature clsig ->
+        class_signature clsig
+    |Tcty_fun (_label, ctype, cltype) ->
+        core_type ctype;
+        class_type cltype
+
+  and class_signature { csig_self;
+                        csig_fields;
+                        csig_type=_;
+                        csig_loc=_;
+                      } =
+    core_type csig_self;
+    List.iter class_type_field csig_fields
+
+  and class_type_field { ctf_desc; ctf_loc=_ } = match ctf_desc with
+    | Tctf_inher cltyp -> class_type cltyp
+    | Tctf_val (_name, _mutable_flag, _virtual_flag, ctype) ->
+        core_type ctype
+    | Tctf_virt (_name, _private_flag, ctype) ->
+        core_type ctype
+    | Tctf_meth (_name, _private_flag, ctype) ->
+        core_type ctype
+    | Tctf_cstr (ctype1, ctype2) -> 
+        core_type ctype1;
+        core_type ctype2
+
+  and class_structure
+      { cstr_pat; (* : pattern; *)
+        cstr_fields; (* : class_field list; *)
+        cstr_type=_;
+        cstr_meths=_; (* ? *) (* : Ident.t Meths.t *) } =
+    ignore & pattern cstr_pat;
+    List.iter class_field cstr_fields
+
+  and class_field 
+      { cf_desc; (*  : class_field_desc; *)
+        cf_loc=_ } = match cf_desc with
+      | Tcf_inher (_override_flag, clexpr, _nameopt (* ? *), _fields1 (* ? *), fields2 (* ? *)) -> 
+          class_expr clexpr
+      | Tcf_val (_name (* ? *), {loc}, _mutable_flag, id, clfieldk, _bool) -> 
+          record_def loc & AStr_value id;
+          class_field_kind clfieldk
+      | Tcf_meth (_name, {loc=_loc}, _private_flag, clfieldk, _bool) ->
+          class_field_kind clfieldk
+      | Tcf_constr (cty1, cty2) ->
+          core_type cty1; 
+          core_type cty2
+      | Tcf_init expr -> expression expr
+
+  and class_field_kind = function
+    | Tcfk_virtual cty -> core_type cty
+    | Tcfk_concrete expr -> expression expr
 
   and modtype_declaration = function
     | Tmodtype_abstract -> AMod_abstract
     | Ttype_record lst -> 
         AStr_type (id, List.map (fun (id, {loc=_loc}, _, _, _) -> AStr_field id) lst)
 
-  let top_structure str = clear_cache (); structure str
-  let top_signature sg =  clear_cache (); signature sg
-end
+  and pat_expr_list xs = xs |> List.iter (fun (pat, expr) -> 
+    ignore & pattern pat;
+    expression expr)
 
-let protect' name f v = try f v with e ->
-  Format.eprintf "Error: %s: %s@." name (Printexc.to_string e); raise e
+  and label_description loc p ldesc =
+    record_use_construct loc Kind.Field p ldesc.lbl_name
 
-module Annot = struct
-  type t =
-    | Use               of Kind.t * Path.t
-    | Type              of Types.type_expr * Env.t * [`Expr of Path.t option | `Pattern of Ident.t option ]
-    | Mod_type          of Types.module_type
-    | Str_item          of Abstraction.structure_item
-    | Module            of Abstraction.module_expr
-    | Functor_parameter of Ident.t
-    | Non_expansive     of bool
+  and expression 
+      { exp_desc; (* : expression_desc; *)
+        exp_loc=loc0;
+        exp_extra; (*  : (exp_extra * Location.t) list; *)
+        exp_type; (* : type_expr; *)
+        exp_env; (* : Env.t *) } =
+    let popt = match exp_desc with
+      | Texp_ident (p, {loc}, _) -> Some p
+      | _ -> None
+    in
+    record loc0 (Type (exp_type, exp_env, `Expr popt)); (* `Expr is required? *)
+    match exp_desc with
+    | Texp_ident (p, {loc}, _) -> 
+        record_use loc Kind.Value p
+    | Texp_constant _constant -> ()
+    | Texp_let (_rec_flag, pes, expr) -> 
+        pat_expr_list pes;
+        expression expr
+    | Texp_function (_label, pes, _partial) -> 
+        pat_expr_list pes
+    | Texp_apply (expr, leos) ->
+        expression expr;
+        leos |> List.iter (fun (_label, expropt, _optional) ->
+          match expropt with
+          | None -> ()
+          | Some expr -> expression expr)
+    | Texp_match (expr, pes, _(*partial*))
+    | Texp_try (expr, pes) ->
+        expression expr;
+        pat_expr_list pes
+    | Texp_tuple exprs ->
+        List.iter expression exprs
+    | Texp_construct ({loc}, cdesc, exprs, _bool) -> 
+        begin match cdesc.Types.cstr_tag with
+        | Types.Cstr_exception (path, _) ->
+            record loc0 (* whole (Failure "xxx") *) (Use (Kind.Exception, path))
+        | _ ->
+            let path = get_constr_path cdesc.Types.cstr_res in
+            record_use_construct loc Kind.Constructor path cdesc.Types.cstr_name
+        end;
+        List.iter expression exprs
+    | Texp_variant (_name, None) -> ()
+    | Texp_variant (_name, Some e) -> expression e
+    | Texp_record (fields, expropt) ->
+        let p = get_constr_path exp_type in
+        record loc0 (Use (Kind.Type, p));
+        Option.iter ~f:expression expropt;
+        fields |> List.iter (fun ({loc}, ldesc, expr) ->
+          expression expr;
+          label_description loc p ldesc)
 
-  let _equal t1 t2 = match t1, t2 with
-    | Type (t1, _, _), Type (t2, _, _) -> t1 == t2
-    | Mod_type mty1, Mod_type mty2 -> mty1 == mty2
-    | Str_item sitem1, Str_item sitem2 -> Abstraction.Structure_item.equal sitem1 sitem2
-    | Module mexp1, Module mexp2 -> mexp1 == mexp2
-    | Use (k1,p1), Use (k2,p2) -> k1 = k2 && p1 = p2
-    | Non_expansive b1, Non_expansive b2 -> b1 = b2
-    | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
-    | (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
-          | Mod_type _),
-      (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
-          | Mod_type _) -> false
+    | Texp_field (expr, {loc}, ldesc) ->
+        expression expr;
+        let p = get_constr_path expr.exp_type in
+        label_description loc p ldesc
+    | Texp_setfield (expr, {loc}, ldesc, expr') ->
+        expression expr;
+        expression expr';
+        let p = get_constr_path expr.exp_type in
+        label_description loc p ldesc
+    | Texp_array es -> List.iter expression es
+    | Texp_ifthenelse (e1, e2, eopt) -> 
+        expression e1;
+        expression e2;
+        Option.iter ~f:expression eopt
+    | Texp_sequence (e1, e2)
+    | Texp_while (e1, e2) 
+    | Texp_when (e1, e2) ->
+        expression e1;
+        expression e2
+    | Texp_for (id, {loc}, e1, e2, _direction_flag, e3) ->
+        record loc (Type (Predef.type_int, Env.initial, `Pattern (Some id)));
+        record_def loc (AStr_value id);
+        List.iter expression [e1; e2; e3]
+    | Texp_send (e, m, eopt) ->
+        expression e;
+        meth m; (* Wow meth can have ident! *)
+        Option.iter ~f:expression eopt
+    | Texp_new (p, {loc}, _ (* Types.class_declaration *)) ->
+        record_use loc Kind.Class p
+    | Texp_instvar (_p1 (* class? *), p2, {loc}) ->
+        record_use loc Kind.Value p2
+    | Texp_setinstvar (_p1 (* class? *), p2, {loc}, expr) ->
+        record_use loc Kind.Value p2;
+        expression expr
+    | Texp_override (_P1 (* class? *), bindings) ->
+        bindings |> List.iter (fun (p, {loc}, expr) ->
+          record_use loc Kind.Value p; (* is it a method? *)
+          expression expr)
+    | Texp_letmodule (id, {loc}, mexp, expr) ->
+        record_def loc & AStr_module (id, module_expr mexp);
+        expression expr
+    | Texp_assert e 
+    | Texp_lazy e -> expression e
+    | Texp_assertfalse -> ()
+    | Texp_object (clstr, _names) -> class_structure clstr
+    | Texp_pack mexp -> ignore & module_expr mexp
 
-  module Record = struct
-    open Typedtree
-    open Abstraction
+  and pattern 
+      { pat_desc; (* : pattern_desc; *)
+        pat_loc=loc0;
+        pat_extra; (*  : (pat_extra * Location.t) list; *)
+        pat_type; (*: type_expr; *)
+        pat_env } = 
+    let idopt = match exp_desc with
+      | Tpat_var (id, _, _) -> Some id
+      | _ -> None
+    in
+    record loc0 (Type (pat_type, pat_env, `Pattern idopt)); (* `Expr is required? *)
+    match pat_desc with
+    | Tpat_any -> []
+    | Tpat_var (id, {loc}) -> 
+        [ with_record_def loc & AStr_value id ]
+    | Tpat_alias (pat, id, {loc}) ->
+        with_record_def loc (Astr_value id) ::  pattern pat
+    | Tpat_constant _constant -> []
+    | Tpat_tuple pats ->
+        List.concat_map pattern pats
+    | Tpat_construct ({loc}, cdesc, pats, _bool) ->
+        begin match cdesc.Types.cstr_tag with
+        | Types.Cstr_exception (path, _) ->
+            record loc0 (* whole (Failure "xxx") *) (Use (Kind.Exception, path))
+        | _ ->
+            let path = get_constr_path cdesc.Types.cstr_res in
+            record_use_construct loc Kind.Constructor path cdesc.Types.cstr_name
+        end;
+        List.concat_map pattern pats
+    | Tpat_variant (_label, patopt, {contents = row_desc}) ->
+        
+  | Tpat_record of
+      (Longident.t loc * label_description * pattern) list *
+        closed_flag
+  | Tpat_array of pattern list
+  | Tpat_or of pattern * pattern * row_desc option
+  | Tpat_lazy of pattern
+    mat
 
-    open Location
+  and meth = function
+    | Tmeth_name _name -> ()
+    | Tmeth_val _id -> (* record_use loc ...id ... Oh, we cannot have the loc of this id. 
+                          CR jfuruse: OCaml requires a fix
+                       *)
+        ()
 
-    (* CR jfuruse: A Location.t contains a filename, though it is always
-       unique. Waste of 4xn bytes. *)
-    (*
-    let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)
-    let clear () = Hashtbl.clear recorded
-    *)
+  and value_description
+      { val_desc;
+        val_val=_;
+        val_prim=_; (* string list; *)
+        val_loc=_;
+      } =
+    core_type val_desc
 
-    type location_property = Wellformed | Flipped | Over_files | Illformed
+  and exception_declaration 
+      { exn_params; (* core_type list; *)
+        exn_exn=_; (* : Types.exception_declaration; *)
+        exn_loc=_ } =
+    List.iter core_type exn_params
 
-    let check_location loc =
-      if loc.loc_start == Lexing.dummy_pos || loc.loc_end == Lexing.dummy_pos then Illformed
-      else if loc.loc_start = Lexing.dummy_pos || loc.loc_end = Lexing.dummy_pos then Illformed
-      else
-        (* If the file name is different between the start and the end, we cannot tell the wellformedness. *)
-        if loc.loc_start.Lexing.pos_fname <> loc.loc_end.Lexing.pos_fname then Over_files
-        else
-          (* P4 creates some flipped locations where loc_start > loc_end *)
-          match compare loc.loc_start.Lexing.pos_cnum loc.loc_end.Lexing.pos_cnum
-          with
-          | -1 | 0 -> Wellformed
-          | _ -> Flipped
+  and core_type 
+      { ctyp_desc;
+        ctyp_type=_;
+        ctyp_env=_;
+        ctyp_loc=_; } = match ctyp_desc with
+      | Ttyp_any 
+      | Ttyp_var _ -> ()
+      | Ttyp_arrow (_label, cty1, cty2) ->
+          core_type cty1; core_type cty2
+      | Ttyp_tuple ctys -> List.iter core_type ctys
+      | Ttyp_constr (p, {loc}, ctys) -> 
+          record_use loc Kind.Type p;
+          List.iter core_type ctys
+      | Ttyp_object core_field_types -> List.iter core_field_type core_field_types
+      | Ttyp_class (p, {loc}, ctys, _labels) ->
+          record_use loc Kind.Class p;
+          List.iter core_type ctys
+      | Ttyp_alias (cty, _string (* ? *)) -> core_type cty
+      | Ttyp_variant (row_fields, _bool, _labels) -> List.iter row_field row_fields
+      | Ttyp_poly (_vars (* ? *), cty) -> core_type cty
+      | Ttyp_package pty -> package_type pty
 
-    let record tbl loc t =
-      let really_record () =
-        let records = try Hashtbl.find tbl loc with Not_found -> [] in
-(*
-        (* CR jfuruse: I am not really sure the below is correct now,
-           but I remember the huge compilation slow down... *)
-        (* This caching works horribly when too many things are defined
-           at the same location. For example, a type definition of more than
-           3000 variants, with sexp camlp4 extension, the compile time explodes
-           from 10secs to 4mins! Therefore this works
-           only if [num_records <= 10]
-        *)
-        if num_records <= 10 && List.exists (equal t) records then ()
-        else Hashtbl.replace tbl loc (num_records + 1, t :: records)
-*)
-        Hashtbl.replace tbl loc (t :: records)
-      in
-      match check_location loc with
-      | Wellformed -> really_record ()
-      | Flipped ->
-          if not loc.loc_ghost then Format.eprintf "%aWarning: Flipped location.@." Location.print loc;
-          really_record ()
-      | Illformed ->
-          if not loc.loc_ghost then Format.eprintf "%aWarning: Ill-formed location.@." Location.print loc
-      | Over_files -> ()
+  and core_field_type 
+      { field_desc;
+        field_loc=_ } = match field_desc with
+      | Tcfield (_name, cty) -> core_type cty
+      | Tcfield_var -> ()
 
-    let record_record tbl loc typ =
-      let open Types in
-      let open Ctype in
-      match (repr typ).desc with
-      | Tconstr (path, _, _) -> record tbl loc (Use (Kind.Type, path))
-      | _ -> (* strange.. *) assert false
+  and row_field = function
+    | Ttag (_label, _bool, ctys) -> List.iter core_type ctys
+    | Tinherit cty -> core_type cty
 
-    let record_construct tbl loc cdesc =
-      let open Types in
-      match cdesc.cstr_tag with
-      | Cstr_exception (path,_) -> record tbl loc (Use (Kind.Exception, path))
-      | _ -> 
-          let path = 
-            let ty = cdesc.cstr_res in
-            match (Ctype.repr ty).desc with
-            | Tconstr (p, _, _) -> p
-            | _ -> assert false
-          in
-          record tbl loc (Use (Kind.Type, path))
+  and package_type 
+      { pack_name; (* : Path.t; *)
+        pack_fields; (* : (Longident.t loc * core_type) list; *)
+        pack_type=_; (* : Types.module_type; *)
+        pack_txt={loc} (*  : Longident.t loc; *) } =
+    record_use loc Kind.Module pack_name;
+    List.iter (fun (_lident_loc, cty) -> core_type cty) pack_fields
 
-    class fold tbl =
-      let record = record tbl in
-      let record_def loc sitem = record loc (Str_item sitem)
-      and record_use loc kind path = record loc (Use (kind, path))
-      and record_use_construct loc kind path name = 
-        (* Note, this is different from record_record and record_construct *)
-        assert (match kind with Kind.Constructor | Field -> true | _ -> false);
-        record loc (Use (kind, Path.Pdot (path, name, -1 (* dummy *)))) 
-      in
-    object
-      inherit Ttfold.ovisit as super
+  let top_structure str = 
+    clear_cache (); 
+    match structure str with
+    | AMod_structure str -> str, tbl
+    | _ -> assert false
 
-      method table = tbl
-      method size = Hashtbl.length tbl
-      val mutable last_report = 0
-      method report =
-        let size = Hashtbl.length tbl in
-        Debug.format "signature recorded: %d records@." (size - last_report);
-        last_report <- size
-
-      method! pattern p =
-        let ident_opt = match p.pat_desc with
-          | Tpat_var (id, _) -> Some id
-          | Tpat_alias (_, id, _) -> Some id
-          (* | Tpat_construct (path, {loc}, cdesc, _, _) ->  *)
-          | _ -> None
-        in
-        record p.pat_loc (Type (p.pat_type, p.pat_env, `Pattern ident_opt));
-        begin match p.pat_desc with
-        | Tpat_construct (_, cdesc, _, _) ->
-            record_construct tbl p.pat_loc cdesc
-        | Tpat_record _ -> 
-            record_record tbl p.pat_loc p.pat_type
-        | _ -> ()
-        end;
-        super#pattern p
-
-      (* CR jfuruse: pat_extra *)
-          
-      method! pattern_desc pd = 
-        begin match pd with 
-        | Tpat_var (id, {loc})
-        | Tpat_alias (_, id, {loc}) -> record_def loc (AStr_value id)
-        | Tpat_construct ({loc}, cdesc, _, _) ->
-            begin match cdesc.Types.cstr_tag with
-            | Types.Cstr_exception (_path,_) -> 
-                (* We have done it already for E e part. *)
-                (* record loc (Use (Kind.Exception, path)) *)
-                ()
-            | _ -> 
-                let path = 
-                  let ty = cdesc.Types.cstr_res in
-                  match (Ctype.repr ty).Types.desc with
-                  | Tconstr (p, _, _) -> p
-                  | _ -> assert false
-                in
-                record_use_construct loc Kind.Constructor path cdesc.Types.cstr_name
-            end
-
-        | Tpat_record (lst , _) ->
-            List.iter (fun ({loc}, ldesc, _) ->
-              let path = match (Ctype.repr ldesc.Types.lbl_res).desc with
-                | Tconstr (p, _, _) -> p
-                | _ -> assert false
-              in
-              record_use_construct loc Kind.Field path ldesc.lbl_name) lst
-        | Tpat_any | Tpat_constant _ | Tpat_tuple _
-        | Tpat_variant _ | Tpat_array _ | Tpat_or _ | Tpat_lazy _ -> ()
-        end;
-        super#pattern_desc pd
-
-      method! expression e =
-        let path_opt = match e.exp_desc with
-          | Texp_ident (path, _, _) -> 
-              Some path
-          (* | Texp_construct (path, {loc}, cdesc, _, _) -> *)
-          | Texp_instvar (_path, path, _)
-          | Texp_setinstvar (_path, path, _, _) -> Some path
-          | _ -> None
-        in
-        record e.exp_loc (Type (e.exp_type, e.exp_env, `Expr path_opt));
-
-        (* Workaround of strange ident position by Camlp4 *)
-        begin match e.exp_desc with
-        | Texp_ident (path, {loc=_i_am_strange}, _) -> 
-            record_use e.exp_loc Kind.Value path 
-        | _ -> ()
-        end;
-
-        begin match e.exp_desc with
-        | Texp_construct (_, cdesc, _, _) ->
-            begin match cdesc.Types.cstr_tag with
-              | Types.Cstr_exception (path, _) ->
-                  record e.exp_loc (Use (Kind.Exception, path))
-              | _ ->
-                  (* CR jfuruse: dupe at class fold *)
-                  let path = 
-                    let ty = cdesc.Types.cstr_res in
-                    match (Ctype.repr ty).Types.desc with
-                    | Tconstr (p, _, _) -> p
-                    | _ -> assert false
-                  in
-                  record_use_construct e.exp_loc Kind.Constructor path cdesc.Types.cstr_name
-            end
-        | Texp_record _ -> record_record tbl e.exp_loc e.exp_type
-        | _ -> ()
-        end;
-        super#expression e
-
-      method! exp_extra ee =
-        begin match ee with
-        | Texp_constraint _ -> ()
-        | Texp_open (_, path, {loc}, _) -> record_use loc Kind.Module path
-        | Texp_poly _ -> ()
-        | Texp_newtype _ -> ()
-        end;
-        super#exp_extra ee
-
-      method! expression_desc ed =
-        begin match ed with
-        | Texp_ident (_path, {loc=_loc}, _) ->
-            (* CR jfuruse: P4 has a bug and loc is only x of X.x, which is BAD. 
-               We do not record the use of path here, but in [expression],
-               with e.exp_loc.
-            *)
-            (* record_use loc Kind.Value path *)
-            ()
-        | Texp_construct _ -> () (* done in #expression *)
-        | Texp_record (lst, _) ->
-            (* CR jfuruse: duped *)
-            List.iter (fun ({loc}, ldesc, _) ->
-              (* CR jfuruse: we do not need to run this for all the fields *)
-              let path = match (Ctype.repr ldesc.Types.lbl_res).desc with
-                | Tconstr (p, _, _) -> p
-                | _ -> assert false
-              in
-              record_use_construct loc Kind.Field path ldesc.lbl_name) lst
-        | Texp_field (_, {loc}, ldesc)
-        | Texp_setfield (_, {loc}, ldesc, _) ->
-            (* CR jfuruse: duped *)
-            let path = match (Ctype.repr ldesc.Types.lbl_res).desc with
-              | Tconstr (p, _, _) -> p
-              | _ -> assert false
-            in
-            record_use_construct loc Kind.Field path ldesc.lbl_name
-        | Texp_for (id, {loc}, _, _, _, _) ->
-            (* CR jfuruse: add type int to id *)
-            record_def loc (AStr_value id)
-        | Texp_new (path, {loc}, _) ->
-            record_use loc Kind.Class path
-        | Texp_instvar (_path, path, {loc}) (* CR jfuruse: not sure! *)
-        | Texp_setinstvar (_path, path, {loc}, _) ->
-            record_use loc Kind.Value path
-        | Texp_override (_path, lst) ->  (* CR jfuruse: what todo with _path? *)
-            List.iter (fun (path, {loc}, _) ->
-              record_use loc Kind.Type path) lst
-        | Texp_letmodule (id, {loc}, mexp, _) ->
-            record_def loc (AStr_module (id, module_expr mexp))
-        | Texp_constant _ | Texp_let _ | Texp_function _
-        | Texp_apply _ | Texp_match _ | Texp_try _
-        | Texp_tuple _ | Texp_variant _ | Texp_array _
-        | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _
-        | Texp_when _ | Texp_send _ | Texp_assert _ | Texp_assertfalse
-        | Texp_lazy _ | Texp_object _ | Texp_pack _ -> ()
-        end;
-        super#expression_desc ed
-(*
-and meth =
-    Tmeth_name of string
-  | Tmeth_val of Ident.t
-*)
-
-(* CR jfuruse: Class_type
-      method! class_expr ce =
-        record ce.cl_loc (Class_type (ce.cl_type, ce.cl_env));
-        super#class_expr ce
-*)
-
-      method! class_expr_desc ced =
-        begin match ced with
-        | Tcl_ident (path, {loc}, _) -> record_use loc Kind.Class path
-        | Tcl_structure _ -> ()
-        | Tcl_fun (_, _, lst , _, _)
-        | Tcl_let (_, _, lst, _) ->
-            List.iter (fun (id, {loc}, _) -> record_def loc (AStr_value id)) lst
-        | Tcl_apply _ -> ()
-        | Tcl_constraint _ -> ()
-        end;
-        super#class_expr_desc ced
-(*
-
-and class_structure =
-  { cstr_pat : pattern; (* this is self *)
-    cstr_fields: class_field list;
-    cstr_type : Types.class_signature;
-    cstr_meths: Ident.t Meths.t (* CR jfuruse: to be done? *) }
-*)
-
-(*
-and class_field =
-   {
-    cf_desc : class_field_desc;
-    cf_loc : Location.t;
-  }
-*)
-
-(*
-and class_field_kind =
-  Tcfk_virtual of core_type
-| Tcfk_concrete of expression
-*)
-
-      method! class_field_desc cfd =
-        begin match cfd with
-        | Tcf_inher (_, ce, _, ivars, cmethods) ->
-            (* ce itself is processed by #class_expr *)
-            (* try to have better location *)
-            let rec find ce = match ce.cl_desc with
-              | Tcl_ident _
-              | Tcl_structure _
-              | Tcl_fun _
-              | Tcl_apply _
-              | Tcl_constraint _ -> ce
-              | Tcl_let (_, _, _, ce) -> find ce
-            in
-            let loc = (find ce).cl_loc in
-            List.iter (fun (_, id) -> record_def loc (AStr_value id)) ivars;
-            List.iter (fun (_, id) -> record_def loc (AStr_value id)) cmethods
-        | Tcf_val (_name, {loc}, _, id, _, _) -> record_def loc (AStr_value id)
-        | Tcf_meth (_name, {loc=_loc}, _, _, _) -> ()
-        | Tcf_constr _ -> ()
-        | Tcf_init _ -> ()
-        end;
-        super#class_field_desc cfd
-
-      method! module_expr me = (* CR jfuruse: me.mod_env *)
-        record me.mod_loc (Mod_type me.mod_type);
-        super#module_expr me
-
-(*
-and module_type_constraint =
-  Tmodtype_implicit
-| Tmodtype_explicit of module_type
-*)
-
-      method! module_expr_desc med =
-        begin match med with
-        | Tmod_ident (path, {loc}) ->
-            record_use loc Kind.Module path
-        | Tmod_functor (id, {loc}, _, _) ->
-            (* CR jfuruse: must rethink *)
-            record_def loc (AStr_module (id, AMod_functor_parameter));
-            record loc (Functor_parameter id); (* CR jfuruse: required? *)
-        | Tmod_structure _
-        | Tmod_apply _
-        | Tmod_constraint _
-        | Tmod_unpack _ -> ()
-        end;
-        super#module_expr_desc med
-
-(* CR jfuruse: I want to put the sig
-and structure = {
-  str_items : structure_item list;
-  str_type : Types.signature;
-  str_final_env : Env.t;
-}
-*)
-
-      method! structure_item sitem =
-        begin match sitem.str_desc with (* CR jfuruse; todo add env *)
-        | Tstr_include (mexp, sg) ->
-            let loc = sitem.str_loc in
-            let idmap = try aliases_of_include mexp sg with e -> prerr_endline "structure_item include failed!!!"; raise e in
-            let m = module_expr mexp in
-            List.iter (fun (id, k, id') ->
-              record_def loc (AStr_included (id, m, k, id'))) idmap
-        | _ -> ()
-        end;
-        super#structure_item sitem
-
-      method! structure_item_desc sid =
-        begin match sid with
-        | Tstr_primitive (id, {loc}, _) ->
-            record_def loc (AStr_value id)
-        | Tstr_type lst ->
-            (* CR jfuruse: this demonstrates inefficiency 
-               of the approach: AStr_constructor is created twice *)
-            lst |> List.iter (fun (id, {loc}, td) ->
-              record_def loc (Abstraction.type_declaration id td);
-              begin match td.typ_kind with
-              | Ttype_abstract -> ()
-              | Ttype_variant constrs ->
-                  List.iter (fun (id, {loc}, _, _) ->
-                    record_def loc (AStr_constructor id)) constrs;
-              | Ttype_record fields ->
-                  List.iter (fun (id, {loc}, _, _, _) ->
-                    record_def loc (AStr_field id)) fields
-              end)
-        | Tstr_exception (id, {loc}, _) ->
-            record_def loc (AStr_exception id)
-        | Tstr_exn_rebind (id, {loc}, path, {loc=loc'}) ->
-            record_def loc (AStr_exception id);
-            record_use loc' Kind.Exception path
-        | Tstr_module (id, {loc}, mexp) ->
-            record loc (Mod_type mexp.mod_type);
-            record_def loc (AStr_module (id, module_expr mexp))
-        | Tstr_recmodule lst ->
-            List.iter (fun (id, {loc}, _mty, mexp) ->
-              record loc (Mod_type mexp.mod_type);
-              record_def loc (AStr_module (id, module_expr mexp))) lst
-        | Tstr_modtype (id, {loc}, mty) ->
-            record_def loc (AStr_modtype (id, module_type mty))
-        | Tstr_open (_, path, {loc}) ->
-            record_use loc Kind.Module path
-        | Tstr_class_type lst ->
-            List.iter (fun (id, {loc}, _) ->
-              record_def loc (AStr_class_type id)) lst
-        | Tstr_include (_mexp, _idents) -> () (* done in #structure_item *)
-        | Tstr_eval _
-        | Tstr_value _
-        | Tstr_class _
-          -> ()
-        end;
-        super#structure_item_desc sid
-
-(*
-and module_coercion =
-    Tcoerce_none
-  | Tcoerce_structure of (int * module_coercion) list
-  | Tcoerce_functor of module_coercion * module_coercion
-  | Tcoerce_primitive of Primitive.description
-*)
-
-(* add env?
-and module_type =
-  { mty_desc: module_type_desc;
-    mty_type : Types.module_type;
-    mty_env : Env.t; (* BINANNOT ADDED *)
-    mty_loc: Location.t }
-*)
-
-      method! module_type_desc mtd =
-        begin match mtd with
-        | Tmty_ident (path, {loc}) ->
-            record_use loc Kind.Module_type path
-        | Tmty_functor (id, {loc}, mty, _mty) ->
-            record_def loc (AStr_module (id, module_type mty))
-        | Tmty_with (_mty, lst) ->
-            List.iter (fun (path, {loc}, with_constraint) ->
-              record loc (Use ( (match with_constraint with
-                                 | Twith_type _      -> Kind.Type
-                                 | Twith_module _    -> Kind.Module
-                                 | Twith_typesubst _ -> Kind.Type
-                                 | Twith_modsubst _  -> Kind.Module),
-                                path))) lst
-        | Tmty_typeof _
-        | Tmty_signature _ -> ()
-        end;
-        super#module_type_desc mtd
-
-(* add env
-and signature = {
-  sig_items : signature_item list;
-  sig_type : Types.signature;
-  sig_final_env : Env.t;
-}
-
- add env *)
-
-      method! signature_item si =
-        begin match si.sig_desc with (* CR jfuruse; todo add env *)
-        | Tsig_include (mty, sg) ->
-            let loc = si.sig_loc in
-            let m = Abstraction.module_type mty in
-            let sg0 = match Mtype.scrape (Cmt.recover_env mty.mty_env) mty.mty_type with
-              | Types.Mty_signature sg -> sg
-              | Types.Mty_functor _ -> assert false
-              | Types.Mty_ident _path ->
-                  (* Strange... failed to scrape? *)
-                  assert false
-            in
-            let idmap = try aliases_of_include' sg0 sg with _ -> assert false in
-            List.iter (fun (id, k, id') ->
-              record_def loc (AStr_included (id, m, k, id'))) idmap
-        | _ -> ()
-        end;
-        super#signature_item si
-
-(*
-and signature_item =
-  { sig_desc: signature_item_desc;
-    sig_env : Env.t; (* BINANNOT ADDED *)
-    sig_loc: Location.t }
-*)
-
-      method! signature_item_desc sid =
-        begin match sid with
-        | Tsig_value (id, {loc}, _) -> record_def loc (AStr_value id)
-        | Tsig_type lst ->
-            let record_td (id, {loc}, td) =
-              record_def loc (Abstraction.type_declaration id td)
-            in
-            List.iter record_td lst
-        | Tsig_exception (id, {loc}, _) -> record_def loc (AStr_exception id)
-        | Tsig_module (id, {loc}, mty) ->
-            record loc (Mod_type mty.mty_type);
-            record_def loc (AStr_module (id, module_type mty))
-        | Tsig_recmodule lst ->
-            List.iter (fun (id, {loc}, mty) ->
-              record loc (Mod_type mty.mty_type);
-              record_def loc (AStr_module (id, module_type mty))) lst
-        | Tsig_modtype (id, {loc}, mtd) ->
-            record_def loc (AStr_modtype (id, modtype_declaration mtd))
-        | Tsig_open (_, path, {loc}) -> record_use loc Kind.Module path
-        | Tsig_include _ -> () (* done in #signature_item *)
-        | Tsig_class _ -> ()
-        | Tsig_class_type _ -> ()
-        end;
-        super#signature_item_desc sid
-
-
-      method! with_constraint wc =
-        begin match wc with
-        | Twith_module (path, {loc}) -> record_use loc Kind.Module path
-        | Twith_modsubst (path, {loc}) -> record_use loc Kind.Module path  (*?*)
-        | Twith_type _ -> ()
-        | Twith_typesubst _ -> ()
-        end;
-        super#with_constraint wc
-
-(* add env?
-and core_type =
-(* mutable because of [Typeclass.declare_method] *)
-  { mutable ctyp_desc : core_type_desc;
-    mutable ctyp_type : type_expr;
-    ctyp_env : Env.t; (* BINANNOT ADDED *)
-    ctyp_loc : Location.t }
-*)
-
-      method! core_type_desc ctd =
-        begin match ctd with
-        | Ttyp_var _var -> () (* CR jfuruse: todo *)
-        | Ttyp_constr (path, {loc}, _) -> record_use loc Kind.Type path
-        | Ttyp_class (path, {loc}, _, _) -> record_use loc Kind.Class path
-            (* CR jfuruse: or class type? *)
-        | Ttyp_alias (_core_type, _var) -> () (* CR jfuruse: todo *)
-        | Ttyp_poly (_vars, _core_type) -> () (* CR jfuruse; todo *)
-        | Ttyp_any
-        | Ttyp_arrow _
-        | Ttyp_tuple _
-        | Ttyp_object _
-        | Ttyp_variant _
-        | Ttyp_package _
-            -> ()
-        end;
-        super#core_type_desc ctd
-
-      method! package_type pt =
-        record_use pt.pack_txt.loc Kind.Module_type pt.pack_name;
-        super#package_type pt
-(*
-and package_type = {
-  pack_name : Path.t;
-  pack_fields : (Longident.t loc * core_type) list;
-  pack_type : Types.module_type;
-  pack_txt : Longident.t loc;
-}
-
-and core_field_type =
-  { field_desc: core_field_desc;
-    field_loc: Location.t }
-
-and core_field_desc =
-    Tcfield of string * core_type
-  | Tcfield_var
-
-and row_field =
-    Ttag of label * bool * core_type list
-  | Tinherit of core_type
-
-and value_description =
-  { val_desc : core_type;
-    val_val : Types.value_description;
-    val_prim : string list;
-    val_loc : Location.t;
-    }
-
-and type_declaration =
-  { typ_params: string loc option list;
-    typ_type : Types.type_declaration;
-    typ_cstrs: (core_type * core_type * Location.t) list;
-    typ_kind: type_kind;
-    typ_private: private_flag;
-    typ_manifest: core_type option;
-    typ_variance: (bool * bool) list;
-    typ_loc: Location.t }
-*)
-
-(* This is now done in the upper level
-      method! type_kind tk =
-        begin match tk with
-        | Ttype_abstract -> ()
-        | Ttype_variant lst ->
-            List.iter (fun (id, {loc}, _, _loc(*?*)) ->
-              record_def loc (AStr_type id)) lst
-        | Ttype_record lst ->
-            List.iter (fun (id, {loc}, _, _, _loc(*?*)) ->
-              record_def loc (AStr_type id)) lst
-        end;
-        super#type_kind tk
-*)
-
-(*
-
-and exception_declaration =
-  { exn_params : core_type list;
-    exn_exn : Types.exception_declaration;
-    exn_loc : Location.t }
-
-and class_type =
-  { cltyp_desc: class_type_desc;
-    cltyp_type : Types.class_type;
-    cltyp_env : Env.t; (* BINANNOT ADDED *)
-    cltyp_loc: Location.t }
-*)
-
-      method! class_type_desc ctd =
-        begin match ctd with
-        | Tcty_constr (path, {loc}, _) -> record_use loc Kind.Class_type path
-        | Tcty_signature _
-        | Tcty_fun _ -> ()
-        end;
-        super#class_type_desc ctd
-
-(*
-
-and class_signature = {
-    csig_self : core_type;
-    csig_fields : class_type_field list;
-    csig_type : Types.class_signature;
-    csig_loc : Location.t;
-  }
-
-and class_type_field = {
-    ctf_desc : class_type_field_desc;
-    ctf_loc : Location.t;
-  }
-
-and class_type_field_desc =
-    Tctf_inher of class_type
-  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
-  | Tctf_virt  of (string * private_flag * core_type)
-  | Tctf_meth  of (string * private_flag * core_type)
-  | Tctf_cstr  of (core_type * core_type)
-
-and class_declaration =
-  class_expr class_infos
-
-and class_description =
-  class_type class_infos
-
-and class_type_declaration =
-  class_type class_infos
-*)
-
-      method! class_infos f ci =
-        let loc = ci.ci_id_name.loc in
-        (* CR jfuruse: are they correct? *)
-        record_def loc (AStr_class ci.ci_id_class);
-        record_def loc (AStr_class_type ci.ci_id_class_type);
-        record_def loc (AStr_type (ci.ci_id_object, []));
-        record_def loc (AStr_type (ci.ci_id_typesharp, []));
-        super#class_infos f ci
-
-    end
-  end
-
-  let structure o str =
-    ignore (o#structure str);
-    o#report
-
-  let signature o sg =
-    ignore (o#signature sg);
-    o#report
-
-  let record_structure str =
-    protect' "Spot.Annot.record_structure" (fun () ->
-      let tbl = Hashtbl.create 1023 in
-      let o = new Record.fold tbl in
-      structure o str;
-      o#table)
-      ()
-
-  let record_signature sg =
-    protect' "Spot.Annot.record_signature" (fun () ->
-      let tbl = Hashtbl.create 1023 in
-      let o = new Record.fold tbl in
-      signature o sg;
-      o#table)
-      ()
-
-  let string_of_at = function
-    | `Expr _ -> "Expr"
-    | `Pattern _ -> "Pattern"
-
-  let format ppf = function
-    | Type (typ, _env, at) ->
-	Printtyp.reset ();
-	Printtyp.mark_loops typ;
-        (* CR jfuruse: not fancy having @. *)
-	fprintf ppf "Type: %a;@ " (Printtyp.type_scheme ~with_pos:false) typ;
-	fprintf ppf "XType: %a;@ " (Printtyp.type_scheme ~with_pos:true) typ;
-        fprintf ppf "At: %s;" (string_of_at at)
-    | Mod_type mty ->
-	fprintf ppf "Type: %a;@ " (Printtyp.modtype ~with_pos:false) mty;
-	fprintf ppf "XType: %a;" (Printtyp.modtype ~with_pos:true) mty
-    | Str_item str ->
-	fprintf ppf "Str_item: %a"
-	  Abstraction.format_structure_item str
-    | Use (use, path) ->
-	fprintf ppf "Use: %s, %s"
-	  (String.capitalize (Kind.name use)) (Path.name path)
-    | Module mexp ->
-	fprintf ppf "Module: %a"
-          Abstraction.format_module_expr mexp
-    | Functor_parameter id ->
-	fprintf ppf "Functor_parameter: %s" (Ident.name id)
-    | Non_expansive b ->
-        fprintf ppf "Non_expansive: %b" b
-
-  let summary ppf = function
-    | Type (_typ, _env, at) ->
-        (* CR jfuruse: not fancy having @. *)
-	fprintf ppf "Type: ...@ ";
-	fprintf ppf "XType: ...@ ";
-        fprintf ppf "At: %s" (string_of_at at)
-    | Mod_type _mty ->
-	fprintf ppf "Type: ...@ ";
-	fprintf ppf "XType: ..."
-    | Str_item _str ->
-	fprintf ppf "Str_item: ..."
-    | Use (use, path) ->
-	fprintf ppf "Use: %s, %s"
-	  (String.capitalize (Kind.name use)) (Path.name path)
-    | Module _mexp ->
-	fprintf ppf "Module: ..."
-    | Functor_parameter id ->
-	fprintf ppf "Functor_parameter: %s" (Ident.name id)
-    | Non_expansive b ->
-        fprintf ppf "Non_expansive: %b" b
-
-  let dummy = Use (Kind.Value, Path.Pident (Ident.create_persistent "dummy"))
+  let top_signature sg =  
+    clear_cache (); 
+    match signature sg with
+    | AMod_structure str -> str, tbl
+    | _ -> assert false
 end
 
 module Position = struct
   (* it drops one byte at the end, but who cares? *)
   let complete mlpath t = match t with
     | { line_column = Some _ } ->
-        t (* already complete
- *)
+        t (* already complete *)
     (* Completing of the byte part from line-column is HARD,
        for the case of auto-generated source files.
        line_column : this is of the original file
 
 end = struct
 
+  open Location
+  open Lexing
+
   (* CR jfuruse: I heard that inode is not a good idea; mingw has no inode *)
   type t = {
     start : Position.t;
       (Position.to_string t.end_)
 
   let of_parsing l =
-    let fname1 = l.Location.loc_start.Lexing.pos_fname in
-    let fname2 = l.Location.loc_end.Lexing.pos_fname in
+    let fname1 = l.loc_start.pos_fname in
+    let fname2 = l.loc_end.pos_fname in
     if fname1 <> fname2 then
       Format.eprintf "Warning: A location contains strange file names %s and %s@." fname1 fname2;
     (* Flip locs if they are in opposite order. 
        Actually this never helps. Such strange poses are created by
        buggy P4. *)
-    let start = Position.of_lexing_position l.Location.loc_start in
-    let end_ = Position.of_lexing_position l.Location.loc_end in
+    let start = Position.of_lexing_position l.loc_start in
+    let end_ = Position.of_lexing_position l.loc_end in
     match Position.compare start end_ with
     | -1 | 0 -> fname1, { start; end_ }
     | _ -> fname1, { start = end_; end_ = start }
   open Cmt_format
 
   let abstraction cmt = match cmt.cmt_annots with
-    | Implementation str ->
-        let loc_annots = Annot.record_structure str in
-        begin match Abstraction.top_structure str with
-        | Abstraction.AMod_structure str -> str, loc_annots
-        | _ -> assert false
-        end
-    | Interface sg ->
-        let loc_annots = Annot.record_signature sg in
-        begin match Abstraction.top_signature sg with
-        | Abstraction.AMod_structure str -> str, loc_annots
-        | _ -> assert false
-        end
+    | Implementation str -> EXTRACT.top_structure str
+    | Interface sg -> EXTRACT.top_signature sg
     | Packed (_sg, files) ->
         (List.map (fun file ->
           let fullpath = if Filename.is_relative file then cmt.cmt_builddir ^/ file else file in
         Hashtbl.create 1 (* empty *)
     | Partial_implementation parts | Partial_interface parts -> 
         Format.eprintf "Warning: this file is made from compilation with errors@.";
-        let tbl = Hashtbl.create 1023 in
-        let o = new Annot.Record.fold tbl in
+        EXTRACT.clear_cache ();
+        let down_to_sitems = function
+          | Abstraction.AMod_structure str -> str
+          | _ -> assert false
+        in
         let part = function
-          | Partial_structure str -> o#structure str
-          | Partial_structure_item sitem -> o#structure_item sitem
-          | Partial_expression e -> o#expression e
-          | Partial_pattern p -> o#pattern p
-          | Partial_class_expr cexp -> o#class_expr cexp
-          | Partial_signature sg -> o#signature sg
-          | Partial_signature_item sgitem -> o#signature_item sgitem
-          | Partial_module_type mty -> o#module_type mty
+          | Partial_structure str -> down_to_sitems & EXTRACT.structure str
+          | Partial_structure_item sitem -> EXTRACT.structure_item sitem
+          | Partial_expression e -> EXTRACT.expression e; []
+          | Partial_pattern p -> EXTRACT.pattern p
+          | Partial_class_expr cexp -> EXTRACT.class_expr cexp
+          | Partial_signature sg -> EXTRACT.signature sg
+          | Partial_signature_item sgitem -> EXTRACT.signature_item sgitem
+          | Partial_module_type mty -> EXTRACT.module_type mty
         in
-        Array.iter (fun x -> ignore (part x)) parts;
-        (* fake top structure *)
-        Abstraction.clear_cache ();
-        let abst_strs = List.fold_right (fun pstr st -> 
-          let get_items = function
-            | Abstraction.AMod_structure items -> items
-            | _ -> []
-          in
-          let items = match pstr with
-            | Partial_structure str -> 
-                get_items (Abstraction.structure str)
-            | Partial_structure_item sitem -> 
-                Abstraction.structure_item sitem
-            | Partial_signature sg -> get_items (Abstraction.signature sg)
-            | Partial_signature_item sgitem -> Abstraction.signature_item sgitem
-            | _ -> []
-          in
-          items @ st) (Array.to_list parts) []
-        in
-        o#report;
-        abst_strs,
-        o#table
+        let tbl = EXTRACT.tbl in (* CR jfuruse: this is global! *)
+        let amods = List.concat_map (fun x -> ignore (part x)) & Array.to_list parts in
+        amods,
+        tbl
 
   let abstraction cmt =
     let load_path = List.map (fun p ->
     | Non_expansive of bool
 
   module Record : sig
+(*
     class fold : (Location.t, t list) Hashtbl.t -> object 
       inherit Ttfold.ovisit
       method table : (Location.t, t list) Hashtbl.t 
       method size : int
       method report : unit
     end
+*)
+    type fold
   end
 
   val structure : Record.fold -> Typedtree.structure -> unit

ttfold.ml

-(***********************************************************************)
-(*                                                                     *)
-(*                            OCamlSpotter                             *)
-(*                                                                     *)
-(*                             Jun FURUSE                              *)
-(*                                                                     *)
-(*   Copyright 2008-2012 Jun Furuse. All rights reserved.              *)
-(*   This file is distributed under the terms of the GNU Library       *)
-(*   General Public License, with the special exception on linking     *)
-(*   described in file LICENSE.                                        *)
-(*                                                                     *)
-(***********************************************************************)
-
-open Types
-open Typedtree
-  
-class virtual ovisit_pattern =
-  object (self)
-    method virtual ref : 'a1. ('a1 -> unit) -> 'a1 ref -> unit
-    method virtual option : 'a1. ('a1 -> unit) -> 'a1 option -> unit
-    method virtual list : 'a1. ('a1 -> unit) -> 'a1 list -> unit
-    method pattern : pattern -> unit =
-      fun __value ->
-        (self#pattern_desc __value.pat_desc;
-         self#list (fun (__x1, __x2) -> (self#pat_extra __x1; ()))
-           __value.pat_extra;
-         ())
-    method pat_extra : pat_extra -> unit =
-      fun __value ->
-        match __value with
-        | Tpat_constraint __x1 -> (self#core_type __x1; ())
-        | Tpat_type (__x1, __x2) -> ()
-        | Tpat_unpack -> ()
-    method pattern_desc : pattern_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tpat_any -> ()
-        | Tpat_var (__x1, __x2) -> ()
-        | Tpat_alias (__x1, __x2, __x3) -> (self#pattern __x1; ())
-        | Tpat_constant __x1 -> ()
-        | Tpat_tuple __x1 -> (self#list self#pattern __x1; ())
-        | Tpat_construct (__x1, __x2, __x3, __x4) ->
-            (self#list self#pattern __x3; ())
-        | Tpat_variant (__x1, __x2, __x3) ->
-            (self#option self#pattern __x2; self#ref (fun _ -> ()) __x3; ())
-        | Tpat_record (__x1, __x2) ->
-            (self#list (fun (__x1, __x2, __x3) -> (self#pattern __x3; ()))
-               __x1;
-             ())
-        | Tpat_array __x1 -> (self#list self#pattern __x1; ())
-        | Tpat_or (__x1, __x2, __x3) ->
-            (self#pattern __x1;
-             self#pattern __x2;
-             self#option (fun _ -> ()) __x3;
-             ())
-        | Tpat_lazy __x1 -> (self#pattern __x1; ())
-    method expression : expression -> unit =
-      fun __value ->
-        (self#expression_desc __value.exp_desc;
-         self#list (fun (__x1, __x2) -> (self#exp_extra __x1; ()))
-           __value.exp_extra;
-         ())
-    method exp_extra : exp_extra -> unit =
-      fun __value ->
-        match __value with
-        | Texp_constraint (__x1, __x2) ->
-            (self#option self#core_type __x1;
-             self#option self#core_type __x2;
-             ())
-        | Texp_open (__x1, __x2, __x3, __x4) -> ()
-        | Texp_poly __x1 -> (self#option self#core_type __x1; ())
-        | Texp_newtype __x1 -> ()
-    method expression_desc : expression_desc -> unit =
-      fun __value ->
-        match __value with
-        | Texp_ident (__x1, __x2, __x3) -> ()
-        | Texp_constant __x1 -> ()
-        | Texp_let (__x1, __x2, __x3) ->
-            (self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             self#expression __x3;
-             ())
-        | Texp_function (__x1, __x2, __x3) ->
-            (self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             ())
-        | Texp_apply (__x1, __x2) ->
-            (self#expression __x1;
-             self#list
-               (fun (__x1, __x2, __x3) ->
-                  (self#option self#expression __x2; ()))
-               __x2;
-             ())
-        | Texp_match (__x1, __x2, __x3) ->
-            (self#expression __x1;
-             self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             ())
-        | Texp_try (__x1, __x2) ->
-            (self#expression __x1;
-             self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             ())
-        | Texp_tuple __x1 -> (self#list self#expression __x1; ())
-        | Texp_construct (__x1, __x2, __x3, __x4) ->
-            (self#list self#expression __x3; ())
-        | Texp_variant (__x1, __x2) -> (self#option self#expression __x2; ())
-        | Texp_record (__x1, __x2) ->
-            (self#list (fun (__x1, __x2, __x3) -> (self#expression __x3; ()))
-               __x1;
-             self#option self#expression __x2;
-             ())
-        | Texp_field (__x1, __x2, __x3) -> (self#expression __x1; ())
-        | Texp_setfield (__x1, __x2, __x3, __x4) ->
-            (self#expression __x1; self#expression __x4; ())
-        | Texp_array __x1 -> (self#list self#expression __x1; ())
-        | Texp_ifthenelse (__x1, __x2, __x3) ->
-            (self#expression __x1;
-             self#expression __x2;
-             self#option self#expression __x3;
-             ())
-        | Texp_sequence (__x1, __x2) ->
-            (self#expression __x1; self#expression __x2; ())
-        | Texp_while (__x1, __x2) ->
-            (self#expression __x1; self#expression __x2; ())
-        | Texp_for (__x1, __x2, __x3, __x4, __x5, __x6) ->
-            (self#expression __x3;
-             self#expression __x4;
-             self#expression __x6;
-             ())
-        | Texp_when (__x1, __x2) ->
-            (self#expression __x1; self#expression __x2; ())
-        | Texp_send (__x1, __x2, __x3) ->
-            (self#expression __x1;
-             self#meth __x2;
-             self#option self#expression __x3;
-             ())
-        | Texp_new (__x1, __x2, __x3) -> ()
-        | Texp_instvar (__x1, __x2, __x3) -> ()
-        | Texp_setinstvar (__x1, __x2, __x3, __x4) ->
-            (self#expression __x4; ())
-        | Texp_override (__x1, __x2) ->
-            (self#list (fun (__x1, __x2, __x3) -> (self#expression __x3; ()))
-               __x2;
-             ())
-        | Texp_letmodule (__x1, __x2, __x3, __x4) ->
-            (self#module_expr __x3; self#expression __x4; ())
-        | Texp_assert __x1 -> (self#expression __x1; ())
-        | Texp_assertfalse -> ()
-        | Texp_lazy __x1 -> (self#expression __x1; ())
-        | Texp_object (__x1, __x2) ->
-            (self#class_structure __x1; self#list (fun _ -> ()) __x2; ())
-        | Texp_pack __x1 -> (self#module_expr __x1; ())
-    method meth : meth -> unit = fun __value -> ()
-    method class_expr : class_expr -> unit =
-      fun __value -> (self#class_expr_desc __value.cl_desc; ())
-    method class_expr_desc : class_expr_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tcl_ident (__x1, __x2, __x3) -> (self#list self#core_type __x3; ())
-        | Tcl_structure __x1 -> (self#class_structure __x1; ())
-        | Tcl_fun (__x1, __x2, __x3, __x4, __x5) ->
-            (self#pattern __x2;
-             self#list (fun (__x1, __x2, __x3) -> (self#expression __x3; ()))
-               __x3;
-             self#class_expr __x4;
-             ())
-        | Tcl_apply (__x1, __x2) ->
-            (self#class_expr __x1;
-             self#list
-               (fun (__x1, __x2, __x3) ->
-                  (self#option self#expression __x2; ()))
-               __x2;
-             ())
-        | Tcl_let (__x1, __x2, __x3, __x4) ->
-            (self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             self#list (fun (__x1, __x2, __x3) -> (self#expression __x3; ()))
-               __x3;
-             self#class_expr __x4;
-             ())
-        | Tcl_constraint (__x1, __x2, __x3, __x4, __x5) ->
-            (self#class_expr __x1;
-             self#option self#class_type __x2;
-             self#list (fun _ -> ()) __x3;
-             self#list (fun _ -> ()) __x4;
-             ())
-    method class_structure : class_structure -> unit =
-      fun __value ->
-        (self#pattern __value.cstr_pat;
-         self#list self#class_field __value.cstr_fields;
-         ())
-    method class_field : class_field -> unit =
-      fun __value -> (self#class_field_desc __value.cf_desc; ())
-    method class_field_kind : class_field_kind -> unit =
-      fun __value ->
-        match __value with
-        | Tcfk_virtual __x1 -> (self#core_type __x1; ())
-        | Tcfk_concrete __x1 -> (self#expression __x1; ())
-    method class_field_desc : class_field_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tcf_inher (__x1, __x2, __x3, __x4, __x5) ->
-            (self#class_expr __x2;
-             self#option (fun _ -> ()) __x3;
-             self#list (fun (__x1, __x2) -> ()) __x4;
-             self#list (fun (__x1, __x2) -> ()) __x5;
-             ())
-        | Tcf_val (__x1, __x2, __x3, __x4, __x5, __x6) ->
-            (self#class_field_kind __x5; ())
-        | Tcf_meth (__x1, __x2, __x3, __x4, __x5) ->
-            (self#class_field_kind __x4; ())
-        | Tcf_constr (__x1, __x2) ->
-            (self#core_type __x1; self#core_type __x2; ())
-        | Tcf_init __x1 -> (self#expression __x1; ())
-    method module_expr : module_expr -> unit =
-      fun __value -> (self#module_expr_desc __value.mod_desc; ())
-    method module_type_constraint : module_type_constraint -> unit =
-      fun __value ->
-        match __value with
-        | Tmodtype_implicit -> ()
-        | Tmodtype_explicit __x1 -> (self#module_type __x1; ())
-    method module_expr_desc : module_expr_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tmod_ident (__x1, __x2) -> ()
-        | Tmod_structure __x1 -> (self#structure __x1; ())
-        | Tmod_functor (__x1, __x2, __x3, __x4) ->
-            (self#module_type __x3; self#module_expr __x4; ())
-        | Tmod_apply (__x1, __x2, __x3) ->
-            (self#module_expr __x1;
-             self#module_expr __x2;
-             self#module_coercion __x3;
-             ())
-        | Tmod_constraint (__x1, __x2, __x3, __x4) ->
-            (self#module_expr __x1;
-             self#module_type_constraint __x3;
-             self#module_coercion __x4;
-             ())
-        | Tmod_unpack (__x1, __x2) -> (self#expression __x1; ())
-    method structure : structure -> unit =
-      fun __value -> (self#list self#structure_item __value.str_items; ())
-    method structure_item : structure_item -> unit =
-      fun __value -> (self#structure_item_desc __value.str_desc; ())
-    method structure_item_desc : structure_item_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tstr_eval __x1 -> (self#expression __x1; ())
-        | Tstr_value (__x1, __x2) ->
-            (self#list
-               (fun (__x1, __x2) ->
-                  (self#pattern __x1; self#expression __x2; ()))
-               __x2;
-             ())
-        | Tstr_primitive (__x1, __x2, __x3) ->
-            (self#value_description __x3; ())
-        | Tstr_type __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3) -> (self#type_declaration __x3; ()))
-               __x1;
-             ())
-        | Tstr_exception (__x1, __x2, __x3) ->
-            (self#exception_declaration __x3; ())
-        | Tstr_exn_rebind (__x1, __x2, __x3, __x4) -> ()
-        | Tstr_module (__x1, __x2, __x3) -> (self#module_expr __x3; ())
-        | Tstr_recmodule __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3, __x4) ->
-                  (self#module_type __x3; self#module_expr __x4; ()))
-               __x1;
-             ())
-        | Tstr_modtype (__x1, __x2, __x3) -> (self#module_type __x3; ())
-        | Tstr_open (__x1, __x2, __x3) -> ()
-        | Tstr_class __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3) ->
-                  (self#class_declaration __x1;
-                   self#list (fun _ -> ()) __x2;
-                   ()))
-               __x1;
-             ())
-        | Tstr_class_type __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3) ->
-                  (self#class_type_declaration __x3; ()))
-               __x1;
-             ())
-        | Tstr_include (__x1, __x2) -> (self#module_expr __x1; ())
-    method module_coercion : module_coercion -> unit =
-      fun __value ->
-        match __value with
-        | Tcoerce_none -> ()
-        | Tcoerce_structure __x1 ->
-            (self#list (fun (__x1, __x2) -> (self#module_coercion __x2; ()))
-               __x1;
-             ())
-        | Tcoerce_functor (__x1, __x2) ->
-            (self#module_coercion __x1; self#module_coercion __x2; ())
-        | Tcoerce_primitive __x1 -> ()
-    method module_type : module_type -> unit =
-      fun __value -> (self#module_type_desc __value.mty_desc; ())
-    method module_type_desc : module_type_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tmty_ident (__x1, __x2) -> ()
-        | Tmty_signature __x1 -> (self#signature __x1; ())
-        | Tmty_functor (__x1, __x2, __x3, __x4) ->
-            (self#module_type __x3; self#module_type __x4; ())
-        | Tmty_with (__x1, __x2) ->
-            (self#module_type __x1;
-             self#list
-               (fun (__x1, __x2, __x3) -> (self#with_constraint __x3; ()))
-               __x2;
-             ())
-        | Tmty_typeof __x1 -> (self#module_expr __x1; ())
-    method signature : signature -> unit =
-      fun __value -> (self#list self#signature_item __value.sig_items; ())
-    method signature_item : signature_item -> unit =
-      fun __value -> (self#signature_item_desc __value.sig_desc; ())
-    method signature_item_desc : signature_item_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tsig_value (__x1, __x2, __x3) -> (self#value_description __x3; ())
-        | Tsig_type __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3) -> (self#type_declaration __x3; ()))
-               __x1;
-             ())
-        | Tsig_exception (__x1, __x2, __x3) ->
-            (self#exception_declaration __x3; ())
-        | Tsig_module (__x1, __x2, __x3) -> (self#module_type __x3; ())
-        | Tsig_recmodule __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3) -> (self#module_type __x3; ())) __x1;
-             ())
-        | Tsig_modtype (__x1, __x2, __x3) ->
-            (self#modtype_declaration __x3; ())
-        | Tsig_open (__x1, __x2, __x3) -> ()
-        | Tsig_include (__x1, __x2) -> (self#module_type __x1; ())
-        | Tsig_class __x1 -> (self#list self#class_description __x1; ())
-        | Tsig_class_type __x1 ->
-            (self#list self#class_type_declaration __x1; ())
-    method modtype_declaration : modtype_declaration -> unit =
-      fun __value ->
-        match __value with
-        | Tmodtype_abstract -> ()
-        | Tmodtype_manifest __x1 -> (self#module_type __x1; ())
-    method with_constraint : with_constraint -> unit =
-      fun __value ->
-        match __value with
-        | Twith_type __x1 -> (self#type_declaration __x1; ())
-        | Twith_module (__x1, __x2) -> ()
-        | Twith_typesubst __x1 -> (self#type_declaration __x1; ())
-        | Twith_modsubst (__x1, __x2) -> ()
-    method core_type : core_type -> unit =
-      fun __value -> (self#core_type_desc __value.ctyp_desc; ())
-    method core_type_desc : core_type_desc -> unit =
-      fun __value ->
-        match __value with
-        | Ttyp_any -> ()
-        | Ttyp_var __x1 -> ()
-        | Ttyp_arrow (__x1, __x2, __x3) ->
-            (self#core_type __x2; self#core_type __x3; ())
-        | Ttyp_tuple __x1 -> (self#list self#core_type __x1; ())
-        | Ttyp_constr (__x1, __x2, __x3) ->
-            (self#list self#core_type __x3; ())
-        | Ttyp_object __x1 -> (self#list self#core_field_type __x1; ())
-        | Ttyp_class (__x1, __x2, __x3, __x4) ->
-            (self#list self#core_type __x3; self#list (fun _ -> ()) __x4; ())
-        | Ttyp_alias (__x1, __x2) -> (self#core_type __x1; ())
-        | Ttyp_variant (__x1, __x2, __x3) ->
-            (self#list self#row_field __x1;
-             self#option (self#list (fun _ -> ())) __x3;
-             ())
-        | Ttyp_poly (__x1, __x2) ->
-            (self#list (fun _ -> ()) __x1; self#core_type __x2; ())
-        | Ttyp_package __x1 -> (self#package_type __x1; ())
-    method package_type : package_type -> unit =
-      fun __value ->
-        (self#list (fun (__x1, __x2) -> (self#core_type __x2; ()))
-           __value.pack_fields;
-         ())
-    method core_field_type : core_field_type -> unit =
-      fun __value -> (self#core_field_desc __value.field_desc; ())
-    method core_field_desc : core_field_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tcfield (__x1, __x2) -> (self#core_type __x2; ())
-        | Tcfield_var -> ()
-    method row_field : row_field -> unit =
-      fun __value ->
-        match __value with
-        | Ttag (__x1, __x2, __x3) -> (self#list self#core_type __x3; ())
-        | Tinherit __x1 -> (self#core_type __x1; ())
-    method value_description : value_description -> unit =
-      fun __value ->
-        (self#core_type __value.val_desc;
-         self#list (fun _ -> ()) __value.val_prim;
-         ())
-    method type_declaration : type_declaration -> unit =
-      fun __value ->
-        (self#list (self#option (fun _ -> ())) __value.typ_params;
-         self#list
-           (fun (__x1, __x2, __x3) ->
-              (self#core_type __x1; self#core_type __x2; ()))
-           __value.typ_cstrs;
-         self#type_kind __value.typ_kind;
-         self#option self#core_type __value.typ_manifest;
-         self#list (fun (__x1, __x2) -> ()) __value.typ_variance;
-         ())
-    method type_kind : type_kind -> unit =
-      fun __value ->
-        match __value with
-        | Ttype_abstract -> ()
-        | Ttype_variant __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3, __x4) ->
-                  (self#list self#core_type __x3; ()))
-               __x1;
-             ())
-        | Ttype_record __x1 ->
-            (self#list
-               (fun (__x1, __x2, __x3, __x4, __x5) ->
-                  (self#core_type __x4; ()))
-               __x1;
-             ())
-    method exception_declaration : exception_declaration -> unit =
-      fun __value -> (self#list self#core_type __value.exn_params; ())
-    method class_type : class_type -> unit =
-      fun __value -> (self#class_type_desc __value.cltyp_desc; ())
-    method class_type_desc : class_type_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tcty_constr (__x1, __x2, __x3) ->
-            (self#list self#core_type __x3; ())
-        | Tcty_signature __x1 -> (self#class_signature __x1; ())
-        | Tcty_fun (__x1, __x2, __x3) ->
-            (self#core_type __x2; self#class_type __x3; ())
-    method class_signature : class_signature -> unit =
-      fun __value ->
-        (self#core_type __value.csig_self;
-         self#list self#class_type_field __value.csig_fields;
-         ())
-    method class_type_field : class_type_field -> unit =
-      fun __value -> (self#class_type_field_desc __value.ctf_desc; ())
-    method class_type_field_desc : class_type_field_desc -> unit =
-      fun __value ->
-        match __value with
-        | Tctf_inher __x1 -> (self#class_type __x1; ())
-        | Tctf_val __x1 ->
-            ((fun (__x1, __x2, __x3, __x4) -> (self#core_type __x4; ())) __x1;
-             ())
-        | Tctf_virt __x1 ->
-            ((fun (__x1, __x2, __x3) -> (self#core_type __x3; ())) __x1; ())
-        | Tctf_meth __x1 ->
-            ((fun (__x1, __x2, __x3) -> (self#core_type __x3; ())) __x1; ())
-        | Tctf_cstr __x1 ->
-            ((fun (__x1, __x2) ->
-                (self#core_type __x1; self#core_type __x2; ()))
-               __x1;
-             ())
-    method class_declaration : class_declaration -> unit =
-      fun __value -> self#class_infos self#class_expr __value
-    method class_description : class_description -> unit =
-      fun __value -> self#class_infos self#class_type __value
-    method class_type_declaration : class_type_declaration -> unit =
-      fun __value -> self#class_infos self#class_type __value
-    method class_infos : 'a. ('a -> unit) -> 'a class_infos -> unit =
-      fun __tv_a __value ->
-        ((fun (__x1, __x2) -> (self#list (fun _ -> ()) __x1; ()))
-           __value.ci_params;
-         __tv_a __value.ci_expr;
-         self#list (fun (__x1, __x2) -> ()) __value.ci_variance;
-         ())
-  end
-
-class ovisit = object
-  inherit ovisit_pattern
-  method ref f x = f !x
-  method option f = function
-    | None -> ()
-    | Some v -> f v
-  method list f xs = List.iter f xs
-end
-
   res
 ;;
 
+let protect' name f v = try f v with e ->
+  Format.eprintf "Error: %s: %s@." name (Printexc.to_string e); raise e
+
 let catch ~f v = try `Ok (f v) with e -> `Error e;;
 
 let failwithf fmt = Printf.kprintf failwith fmt
   let to_list set = fold (fun x y -> x::y) set []
 end
 
+external (&) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
+
 exception Finally of exn * exn
 
 val protect : f:('a -> 'b) -> 'a -> finally:('a -> unit) -> 'b
+val protect' : string -> ('a -> 'b) -> ('a -> 'b)
 val catch : f:('a -> 'b) -> 'a -> [> `Error of exn | `Ok of 'b ]
 val failwithf : ('a, unit, string, 'b) format4 -> 'a
 val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
   val of_list : int -> 'a list -> 'a t
   val to_list : 'a t -> 'a list
 end
+
+external (&) : ('a -> 'b) -> 'a -> 'b = "%apply"
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.