Commits

camlspotter committed 0bc33fa

spot file and unit cleanup

  • Participants
  • Parent commits 678dc6f
  • Branches dev

Comments (0)

Files changed (5)

 module Dump = struct
   (* mainly debugging purpose *)
 
-  let file = File.dump
+  let file = Spot.File.dump
+  let unit = Spot.Unit.dump
 
-  let rannots_full file = 
+  let rannots_full unit = 
     eprintf "@[<2>rannots =@ [ @[<v>%a@]@] ]@."
       (Format.list ";@ " (Regioned.format (Format.list ";@ " Annot.format)))
-      !!(file.File.rannots)
+      !!(unit.Unit.rannots)
   ;;
   
-  let rannots_summary file = 
+  let rannots_summary unit = 
     eprintf "@[<2>rannots =@ [ @[<v>%a@]@] ]@."
       (Format.list ";@ " (Regioned.format (Format.list ";@ " Annot.summary)))
-      !!(file.File.rannots)
+      !!(unit.Unit.rannots)
   ;;
   
-  let tree file = Tree.dump !!(file.File.tree)
+  let tree unit = Tree.dump !!(unit.Unit.tree)
   ;;
 
   let top file = 
     eprintf "@[<2>top =@ @[%a@]@]@." 
-      Abstraction.format_structure file.File.top;
+      Abstraction.format_structure file.Unit.top;
     let str = 
-      Eval.structure (File.empty_env file) file.File.top
+      Eval.structure (File.empty_env file) file.Unit.top
     in
     if C.eager_dump then begin
       let module Enforcer = Value.Enforcer(struct end) in
 
   let flat file = 
     eprintf "@[<2>flat =@ @[%a@]@]@." 
-      Abstraction.format_structure file.File.flat;
+      Abstraction.format_structure !!(file.Unit.flat);
     let str = 
       let env = File.invalid_env file in
-      let str = Eval.structure env file.File.flat in
+      let str = Eval.structure env !!(file.Unit.flat) in
       Binding.set env.Env.binding str; (* dirty hack (dup code) *)
       str
     in
 
     let file = File.load ~load_paths: ["."] path in
     
-    if C.dump_file then Dump.file file;
+    if C.dump_file then Dump.unit file; (* CR jfuruse: to be fixed *)
     if C.dump_rannots = `Full then Dump.rannots_full file;
     if C.dump_rannots = `Summary then Dump.rannots_summary file;
     if C.dump_tree then Dump.tree file;
   ;;
 
   let info path =
-    let file = load (File.Cmt.of_path path) in
+    let file = load (Cmt.of_path path) in
     printf "Compile: %s@."
       (String.concat " " 
          (List.map Command.escaped_for_shell 
-            (Array.to_list file.File.args)));
+            (Array.to_list file.Unit.args)));
     printf "@[<v2>Included_dirs:@ %a@]@."
       (Format.list "" pp_print_string)
-      file.File.loadpath
+      file.Unit.loadpath
 
   let query_by_kind_path file kind path = 
     try Some (File.find_path_in_flat file (kind, path)) with Not_found -> None
     let probe = Region.point pos in
     let treepath = 
       (* subtree is not used *)
-      List.map fst (Tree.find_path_contains probe !!(file.File.tree))
+      List.map fst (Tree.find_path_contains probe !!(file.Unit.tree))
     in
     match treepath with
     | [] -> failwith (Printf.sprintf "nothing at %s" (Position.to_string pos))
 	    List.find_map_opt (function
 	      | Annot.Use (_, path) -> 
 		  (* Find subpath *)
-		  begin match Pathreparse.get file.File.path r pos path with    
+		  begin match Pathreparse.get file.Unit.path r pos path with    
 		  | None -> None
 		  | Some (path', r) -> 
 		      if path = path' then None (* as original *)
 
 	(* Tree is an older format. XTree is a newer which is the same as one for Spot *)
         printf "Tree: %s@." (Region.to_string r);
-        printf "XTree: <%s:%s>@." file.File.path (Region.to_string r);
+        printf "XTree: <%s:%s>@." file.Unit.path (Region.to_string r);
 
 	(* Find the innermost module *)
         let find_module_path treepath = List.concat_map (fun { Regioned.value = annots } ->
           match List.filter (function Annot.Type _ -> true | _ -> false) annots with
           (* CR jfuruse: Sometimes more than one Annot.Type are found at the same place... *)
           | Annot.Type (typ, env, `Expr) :: _ -> 
-              printf "Expand: @[%a@]@." Typeexpand.format_as_expr (Typeexpand.expand file.File.loadpath env typ)
+              printf "Expand: @[%a@]@." Typeexpand.format_as_expr (Typeexpand.expand file.Unit.loadpath env typ)
           | Annot.Type (typ, env, `Pattern) :: _ -> 
-              printf "Expand: @[%a@]@." Typeexpand.format_as_pattern (Typeexpand.expand file.File.loadpath env typ)
+              printf "Expand: @[%a@]@." Typeexpand.format_as_pattern (Typeexpand.expand file.Unit.loadpath env typ)
           | Annot.Type (_typ, _env, `Val) :: _ -> ()
           | _ -> ()
         end;
     (* CR jfuruse: dup *)
     Debug.format "ocamlspot %s%s@." path (C.SearchSpec.to_string spec);
     Debug.format "cwd: %s@." (Sys.getcwd ());
-    let path = File.Cmt.of_path path in
+    let path = Cmt.of_path path in
     let file = load path in
 
     let query_kind_path k path = print_query_result k (query_by_kind_path file k path) in
     (* CR jfuruse: dup *)
     Debug.format "ocamlspot %s%s@." path (C.SearchSpec.to_string spec);
     Debug.format "cwd: %s@." (Sys.getcwd ());
-    let path = File.Cmt.of_path path in
+    let path = Cmt.of_path path in
     let file = load path in
 
     let find_by_kind_path k path found =
 	              begin match query_by_kind_path file k' path' with
 	              | Some found' when found = found' ->
 		          printf "<%s:%s>: %s@." 
-		            file.File.path
+		            file.Unit.path
 		            (Region.to_string region)
 		            (Path.name path)
 	              | None | Some _ -> ()
 	              end
-                  | _ -> ()) annots) !!(file.File.rannots)
+                  | _ -> ()) annots) !!(file.Unit.rannots)
 	| _ -> ());
     in
 
     let by_kind_path file k path =
       Debug.format "Searching %s:%s:%s ...@." 
-	file.File.path 
+	file.Unit.path 
 	(Kind.to_string k) 
 	(Path.name path); 
       let res = query_by_kind_path file k path in
 
     let by_pos file pos = 
       eprintf "Searching %s:%s ...@." 
-	file.File.path 
+	file.Unit.path 
 	(Position.to_string pos);
       match List.find_map_opt (function 
 	| Annot.Str str_item -> 
   let recheck files =
     let recheck mlpath =
       Debug.format "cwd: %s@." (Sys.getcwd ());
-      let path = File.Cmt.of_path mlpath in
-      let file = File.load ~load_paths: ["."] path in
+      let path = Cmt.of_path mlpath in
+      let file = Unit.load ~load_paths: ["."] path in
     
       printf "Compile: %s@."
         (String.concat " " 
           (List.map Command.escaped_for_shell 
-            (Array.to_list file.File.argv)));
+            (Array.to_list file.Unit.argv)));
       let command = 
-	Sys.argv.(0) :: List.tl (Array.to_list file.File.argv) 
+	Sys.argv.(0) :: List.tl (Array.to_list file.Unit.argv) 
       in
       Xmain.main (Array.of_list command)
     in
     loc_annots     : (Location.t, Annot.t list) Hashtbl.t
   }
 
+  let dump file =
+    eprintf "@[<v2>{ module= %S;@ path= %S;@ builddir= %S;@ loadpath= [ @[%a@] ];@ argv= [| @[%a@] |];@ ... }@]@."
+      file.modname
+      file.path
+      file.builddir
+      (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) file.loadpath
+      (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) (Array.to_list file.args)
+
   let save path t =
     let oc = open_out_bin path in
     output_string oc "spot";
       Format.eprintf "Aiee %s@." (Printexc.to_string e);
       raise e
 
-  let of_cmt path (* the output file *) cmt =
+  let of_cmt path (* the cmt file path *) cmt =
     let path = Option.default (Cmt.source_path cmt) (fun () -> 
       let ext = if Cmt.is_opt cmt then ".cmx" else ".cmo" in
       Filename.chop_extension path ^ ext)
     args           : string array;
     path           : string; (** source path. If packed, the .cmo itself *)
     top            : Abstraction.structure;
+    loc_annots     : (Location.t, Annot.t list) Hashtbl.t;
 
     flat           : Abstraction.structure lazy_t;
     id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
     rannots        : Annot.t list Regioned.t list lazy_t;
     tree           : Tree.t lazy_t
   }
+
+  (* same as File.dump, ignoring new additions in Unit *)
+  let dump file =
+    eprintf "@[<v2>{ module= %S;@ path= %S;@ builddir= %S;@ loadpath= [ @[%a@] ];@ argv= [| @[%a@] |];@ ... }@]@."
+      file.modname
+      file.path
+      file.builddir
+      (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) file.loadpath
+      (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) (Array.to_list file.args)
+
+  let to_file { modname; builddir; loadpath; args; path; top ; loc_annots } = 
+    { File.modname;
+      builddir;
+      loadpath;
+      args;
+      path;
+      top;
+      loc_annots;
+    }
+
+  let of_file ({ File.loc_annots; } as f) = 
+    let rannots = lazy (Hashtbl.fold (fun loc annots st -> 
+      { Regioned.region = Region.of_parsing loc;  value = annots } :: st) 
+                          loc_annots [])
+    in
+    let id_def_regions = lazy (
+      let tbl = Hashtbl.create 1023 in
+      Hashtbl.iter (fun loc annots ->
+        List.iter (function
+          | Annot.Str sitem ->
+              Option.iter (Abstraction.ident_of_structure_item sitem) ~f:(fun (_kind, id) ->
+                Hashtbl.add tbl id (Region.of_parsing loc))
+          | _ -> ()) annots) loc_annots;
+      tbl)
+    in
+    let tree = lazy begin
+      Hashtbl.fold (fun loc annots st ->
+        Tree.add st { Regioned.region = Region.of_parsing loc; value = annots })
+        loc_annots Tree.empty 
+    end in
+    (* CR jfuruse: it is almost the same as id_def_regions_list *)
+    let flat = lazy (Hashtbl.fold (fun _loc annots st -> 
+      List.filter_map (function
+        | Annot.Str sitem -> Some sitem
+        | _ -> None) annots @ st) loc_annots [])
+    in
+    { modname    = f.File.modname;
+      builddir   = f.File.builddir;
+      loadpath   = f.File.loadpath;
+      args       = f.File.args;
+      path       = f.File.path;
+      top        = f.File.top;
+      loc_annots = f.File.loc_annots;
+      
+      flat; id_def_regions; rannots; tree; 
+    }
 end
-
   val dump : t -> unit
 end
 
+module File : sig
+  type t = {
+    modname    : string;
+    builddir   : string;
+    loadpath   : string list;
+    args       : string array;
+    path       : string;
+    top        : Abstraction.structure;
+    loc_annots : (Location.t, Annot.t list) Utils.Hashtbl.t;
+  }
+
+  val dump : t -> unit
+  val save : string -> t -> unit
+  val load : string -> t
+
+  val of_cmt 
+    : string (* the cmt file path name *)
+      -> Cmt_format.cmt_infos -> t
+end
+
+module Unit : sig
+  type t = {
+    modname    : string;
+    builddir   : string;
+    loadpath   : string list;
+    args       : string array;
+    path       : string;
+    top        : Abstraction.structure;
+    loc_annots : (Location.t, Annot.t list) Hashtbl.t;
+
+    (* the following fields are computed from the above, the fields from File.t *) 
+
+    flat           : Abstraction.structure lazy_t;
+    id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
+    rannots        : Annot.t list Regioned.t list lazy_t;
+    tree           : Tree.t lazy_t;
+  }
+  val dump : t -> unit (** just same as File.dump. Ignores the added fields *)
+  val of_file : File.t -> t
+  val to_file : t -> File.t
+end
 open Spoteval
 open Cmt_format
 
-(*
-type file = {
-  modname        : string;
-  builddir       : string; 
-  loadpath       : string list;
-  args           : string array;
-  path           : string; (** source path. If packed, the .cmo itself *)
-  structure      : Spot.Abstraction.structure;
-  loc_annots     : (Location.t, Spot.Annot.t list) Hashtbl.t
-}
-*)
-
-type t = {
-  modname        : string;
-  builddir       : string; 
-  loadpath       : string list;
-  args           : string array;
-  path           : string; (** source path. If packed, the .cmo itself *)
-  flat           : Abstraction.structure;
-  top            : Abstraction.structure;
-  id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
-  rannots        : Annot.t list Regioned.t list lazy_t;
-  tree           : Tree.t lazy_t
-}
-
-module Cmt = struct
-
-  let source_path file = match file.cmt_sourcefile with 
-    | Some f -> Some (file.cmt_builddir ^/ f)
-    | None -> None
-
-  (* xxx.{ml,cmo,cmx,spot} => xxx.spot 
-     xxx.{mli,cmi,spit} => xxx.spit *)
-  let of_path path =
-    let dirname, filename =
-      try
-        let slash = String.rindex path '/' in
-        Some (String.sub path 0 slash),
-        String.sub path (slash + 1) (String.length path - slash - 1)
-      with
-      | Not_found -> None, path
-    in
-    let filename =
-      match Filename.split_extension filename with
-      | body, (".cmi" | ".mli" | ".cmti") -> body ^ ".cmti"
-      | body, _ -> body ^ ".cmt"
-    in
-    match dirname with
-    | None -> filename
-    | Some d -> d ^/ filename
-
-    (* CR jfuruse: this is a dirty workaround. It should be nice if we could know cmt is created by opt or byte *)          
-    let is_opt cmt = 
-      List.exists (fun x -> match Filename.split_extension x with (_, ".cmx") -> true | _ -> false) (Array.to_list cmt.cmt_args)
-
-  let abstraction cmt = match cmt.cmt_annots with
-    | Implementation str -> 
-        let loc_annots = Spot.Annot.record_structure str in
-        begin match Abstraction.structure str with
-        | Abstraction.AMod_structure str -> str, loc_annots
-        | _ -> assert false
-        end
-    | Interface sg -> 
-        let loc_annots = Spot.Annot.record_signature sg in
-        begin match Abstraction.signature sg with
-        | Abstraction.AMod_structure str -> str, loc_annots
-        | _ -> assert false
-        end
-    | Packed (_sg, files) ->
-        (List.map (fun file ->
-          let fullpath = if Filename.is_relative file then cmt.cmt_builddir ^/ file else file in
-          let modname = match Filename.split_extension (Filename.basename file) with 
-            | modname, (".cmo" | ".cmx") -> String.capitalize modname
-            | _ -> assert false
-          in
-          Abstraction.AStr_module (Ident.create modname (* stamp is bogus *),
-                                   Abstraction.AMod_packed fullpath)) files),
-        (Hashtbl.create 1 (* empty *))
-    | Partial_implementation _parts | Partial_interface _parts -> assert false
-  
-  let abstraction cmt = 
-    try abstraction cmt with e -> 
-      Format.eprintf "Aiee %s@." (Printexc.to_string e);
-      raise e
-end
-
-let dump file =
-  eprintf "@[<v2>{ module= %S;@ path= %S;@ builddir= %S;@ loadpath= [ @[%a@] ];@ argv= [| @[%a@] |];@ ... }@]@."
-    file.modname
-    file.path
-    file.builddir
-    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) file.loadpath
-    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) (Array.to_list file.args)
-
 module Make(Spotconfig : Spotconfig_intf.S) = struct
   (* open Abstraction *)
 
   module Load : sig
     exception Old_cmt of string (* cmt *) * string (* source *)
-    val load : load_paths:string list -> string -> t
-    val load_module : ?spit:bool -> load_paths:string list -> string -> t
+    val load : load_paths:string list -> string -> Unit.t
+    val load_module : ?spit:bool -> load_paths:string list -> string -> Unit.t
   end = struct
 
     let check_time_stamp ~cmt source =
 
     let load_cmt_file file = snd (Cmt_format.read file)
 
-    let load_directly path : t =
+    let load_directly path : Unit.t =
       Debug.format "cmt loading from %s@." path;
       match load_cmt_file path with
-      | Some cmt -> 
-          (* CR jfuruse: all things are not always required. so inefficient *)
-          Debug.format "cmt loaded from %s@." path;
-          Debug.format "cmt loaded now extracting things from %s ...@." path;
-          let top, loc_annots = Cmt.abstraction cmt in
-          Debug.format "cmt loaded: abstraction extracted from %s@." path;
-
-          let path = Option.default (Cmt.source_path cmt) (fun () ->
-            Filename.chop_extension path ^ if Cmt.is_opt cmt then ".cmx" else ".cmo") in
-          let rannots = lazy (Hashtbl.fold (fun loc annots st -> 
-            { Regioned.region = Region.of_parsing loc;  value = annots } :: st) loc_annots [])
-          in
-          Debug.format "cmt loaded: rannots created from %s@." path;
-          let id_def_regions = lazy (
-            let tbl = Hashtbl.create 1023 in
-            Hashtbl.iter (fun loc annots ->
-              List.iter (function
-                | Annot.Str sitem ->
-                    Option.iter (Abstraction.ident_of_structure_item sitem) ~f:(fun (_kind, id) ->
-                      Hashtbl.add tbl id (Region.of_parsing loc))
-                | _ -> ()) annots) loc_annots;
-            tbl)
-          in
-          Debug.format "cmt loaded: id_def_regions created from %s@." path;
-          let tree = lazy begin
-            Hashtbl.fold (fun loc annots st ->
-              Tree.add st { Regioned.region = Region.of_parsing loc; value = annots })
-              loc_annots Tree.empty 
-          end in
-          (* CR jfuruse: it is almost the same as id_def_regions_list *)
-          let flat = Hashtbl.fold (fun _loc annots st -> 
-            List.filter_map (function
-              | Annot.Str sitem -> Some sitem
-              | _ -> None) annots @ st) loc_annots []
-          in
-          Debug.format "cmt loaded: flat created from %s@." path;
-          Debug.format "cmt analysis done from %s@." path;
-          { modname  = cmt.cmt_modname;
-            builddir = cmt.cmt_builddir;
-            loadpath = cmt.cmt_loadpath;
-            args     = cmt.cmt_args;
-            path;
-            top;
-            flat;
-            id_def_regions;
-            rannots;
-            tree;
-          }
+      | Some cmt -> Spot.Unit.of_file (Spot.File.of_cmt path cmt)
       | None -> failwith (sprintf "load_directly failed: %s" path)
 
     exception Old_cmt of string (* cmt *) * string (* source *)
 
     (* CR jfuruse: exception *)
     (* CRv2 jfuruse: add and check cache time stamp *)
-    let load_directly_with_cache : string -> t = 
+    let load_directly_with_cache : string -> Unit.t = 
       let cache = Hashtbl.create 17 in
       fun path ->
         try 
         | Not_found ->
               try
                 let file = load_directly path in
-                if not (check_time_stamp ~cmt:path file.path) then 
+                if not (check_time_stamp ~cmt:path file.Unit.path) then 
                   if Spotconfig.strict_time_stamp then 
-                    raise (Old_cmt (path, file.path))
+                    raise (Old_cmt (path, file.Unit.path))
                   else
-                    eprintf "Warning: source %s is newer than the cmt@." file.path;
+                    eprintf "Warning: source %s is newer than the cmt@." file.Unit.path;
                 Hashtbl.replace cache path file;
                 file
               with
         | _ -> failwith (Printf.sprintf "cmt file not found: %s" body_ext)
       
 
-    let load ~load_paths cmtname : t =
+    let load ~load_paths cmtname : Unit.t =
       Debug.format "@[<2>cmt searching %s in@ paths [@[%a@]]@]@." 
           cmtname
           (Format.list "; " (fun ppf x -> fprintf ppf "%S" x)) 
       let path = find_in_path load_paths body ext in
       load_directly_with_cache path
 
-    let load ~load_paths cmtname : t =
+    let load ~load_paths cmtname : Unit.t =
       let alternate_cmtname = 
         if Filename.is_relative cmtname then None
         else
   include Load
 
   let empty_env file =
-    { Env.path = file.path;
-      cwd = file.builddir;
-      load_paths = file.loadpath;
+    { Env.path = file.Unit.path;
+      cwd = file.Unit.builddir;
+      load_paths = file.Unit.loadpath;
       binding = Binding.empty }
 
   let invalid_env file =
-    { Env.path = file.path;
-      cwd = file.builddir;
-      load_paths = file.loadpath;
+    { Env.path = file.Unit.path;
+      cwd = file.Unit.builddir;
+      load_paths = file.Unit.loadpath;
       binding = Binding.invalid }
       
   type result =
   let find_path_in_flat file path : PIdent.t * result =
     let env = 
       let env = invalid_env file in
-      let str = Eval.structure env file.flat in
+      let str = Eval.structure env !!(file.Unit.flat) in
       Binding.set env.Env.binding str; (* dirty hack *)
       env
     in
           | None -> File_itself (* the whole file *)
           | Some id -> 
               Found_at begin try
-                Hashtbl.find !!(file.id_def_regions) id
+                Hashtbl.find !!(file.Unit.id_def_regions) id
               with
               | Not_found ->
                   eprintf "Error: find location of id %a failed@."
   let str_of_global_ident ~load_paths id =
     assert (Ident.global id);
     let file = Load.load_module ~spit:Spotconfig.print_interface ~load_paths (Ident0.name id) in
-    file.path,
-    Eval.structure (empty_env file) file.top
+    file.Unit.path,
+    Eval.structure (empty_env file) file.Unit.top
 
   let _ = Eval.str_of_global_ident := str_of_global_ident
 
   let eval_packed env file =
     let f = Load.load ~load_paths:[""] (Cmt.of_path (env.Env.cwd ^/ file)) in
-    Value.Structure ({ PIdent.path = f.path; ident = None },
-                    Eval.structure (empty_env f) f.top,
+    Value.Structure ({ PIdent.path = f.Unit.path; ident = None },
+                    Eval.structure (empty_env f) f.Unit.top,
                     None (* packed has no .mli *))
 
   let _ = Eval.packed := eval_packed
 open Cmt_format
 open Spoteval
 
-type t = {
-  modname        : string;
-  builddir       : string; 
-  loadpath       : string list;
-  args           : string array;
-
-  path           : string; (** cmt file itself if packed *)
-  flat           : Abstraction.structure;
-  top            : Abstraction.structure;
-  id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
-  rannots        : Annot.t list Regioned.t list lazy_t;
-  tree           : Tree.t lazy_t
-}
-
-module Cmt : sig
-  val of_path : string -> string
-end
-
-val dump : t -> unit
-
 module Make(Spotconfig : Spotconfig_intf.S) : sig
   exception Old_cmt of string * string
-  val load : load_paths:string list -> string -> t
-  val load_module : ?spit:bool -> load_paths:string list -> string -> t (* CR jfuruse: spit *)
+  val load : load_paths:string list -> string -> Unit.t
+  val load_module : ?spit:bool -> load_paths:string list -> string -> Unit.t (* CR jfuruse: spit *)
 
-  val empty_env   : t -> Env.t
-  val invalid_env : t -> Env.t
+  val empty_env   : Unit.t -> Env.t
+  val invalid_env : Unit.t -> Env.t
 
   type result = File_itself | Found_at of Region.t | Predefined
 
-  val find_path_in_flat : t -> Kind.t * Path.t -> PIdent.t * result
+  val find_path_in_flat : Unit.t -> Kind.t * Path.t -> PIdent.t * result
   val str_of_global_ident : load_paths:string list -> Ident.t -> string * Value.structure
   val eval_packed : Env.t -> string -> Value.t
 end