camlspotter avatar camlspotter committed a3b5276

Region is now with a file path

Comments (0)

Files changed (11)

-.*\.(cm.*|annot|o|opt)$
+.*\.(cm.*|annot|o|opt|orig)$
 .*~$
 ocamlspot$
 
 INCLUDES_DEP=-I +compiler-libs
 
 # Requires unix!
-COMPFLAGS= $(INCLUDES_DEP) -I +unix
+COMPFLAGS= -g $(INCLUDES_DEP) -I +unix
 
 MODULES= utils checksum dotfile xset treeset command typeexpand \
 	xlongident name xident xpath locident typeFix xprinttyp ext ttfold cmt spot spoteval spotconfig_intf spotconfig spotfile pathreparse ocamlspot
   (if (file-exists-p path)
       (find-file-other-window path)
     (ocamlspot-message-add (format "ERROR: source file %s was not found" path))
-    nil))
+    (error (format "ERROR: source file %s was not found" path))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Queries
 
     try Some (File.find_path_in_flat file (kind, path)) with Not_found -> None
   ;;
 
+  (* CR jfuruse: In the case of a.mll => a.ml => a.cmt,
+     a.ml often does not exist. ocamlspot should warn you when a.ml
+     does not exist and propose creation of a.ml from a.mll. *)
   let print_query_result kind = function
     | None -> printf "Spot: no spot@."
     | Some (pident, res) -> match res with
 	| File.File_itself ->
             printf "Spot: <%s:all>@." pident.PIdent.path
 	| File.Found_at region ->
-            printf "Spot: <%s:%s>@."
-              pident.PIdent.path
+            printf "Spot: <%s>@."
+              (* pident.PIdent.path *)
               (Region.to_string region)
 	| File.Predefined ->
             printf "Spot: %a: predefined %s@."
               (Kind.name kind);
   ;;
     
-  let query_by_pos file pos = 
-    let probe = Region.point pos in
+  let query_by_pos file orig_path pos = 
+    (* CR jfuruse: probe should be created outside *)
+    let probe = Region.point orig_path pos in
+    Debug.format "probing by %s@." (Region.to_string probe);
     let treepath = 
       List.map fst (Tree.find_path_contains probe !!(file.Unit.tree))
     in
 	  | None -> annots, r
 	  | Some (annots, r) -> annots, r
 	in
-	  
         List.iter (printf "@[<v>%a@]@." Annot.format) annots;
 
 	(* 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.Unit.path (Region.to_string r);
+        printf "Tree: %s@." (Region.to_string_no_path r);
+        printf "XTree: <%s>@." (* file.Unit.path *) (Region.to_string r);
 
 	(* Find the innermost module *)
         let find_module_path treepath = List.concat_map (fun { Regioned.value = annots } ->
 	annots
   ;;
 
-  let query path spec = 
+  let query orig_path spec = 
     (* CR jfuruse: dup *)
-    Debug.format "ocamlspot %s%s@." path (C.SearchSpec.to_string spec);
+    Debug.format "ocamlspot %s%s@." orig_path (C.SearchSpec.to_string spec);
     Debug.format "cwd: %s@." (Sys.getcwd ());
-    let path = Cmt.of_path path in
+    let path = Cmt.of_path orig_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
     begin match spec with
     | C.SearchSpec.Kind (k,path) -> query_kind_path k path
     | C.SearchSpec.Pos pos -> 
-	let annots = query_by_pos file pos in
+	let annots = query_by_pos file orig_path pos in
         if not C.no_definition_analysis then begin
           List.iter (function
             | Annot.Use (k, path) -> query_kind_path k path
 	    | None -> None
 	    end
 	| Annot.Use (kind, path) -> Some (`Use (kind, path))
-	| _ -> None) (query_by_pos file pos)
+	| _ -> None) (query_by_pos file file.Unit.path pos)
       with
       | Some (`Def (k, id))   -> by_kind_path file k (Path.Pident id)
       | Some (`Use (k, path)) -> by_kind_path file k path
    [path] : the path of the whole region
 *)
 let get mlpath region pos path = 
-  let region = Region.complete mlpath region in
-  let str = snd (Region.substring mlpath region) in
   try
-    let pos = Position.complete mlpath pos in
-    let pos = 
-      match pos.Position.bytes, region.Region.start.Position.bytes with 
-      | Some pos_bytes, Some start_bytes -> pos_bytes - start_bytes
-      | _ -> failwith "The given position is not clear enough"
-    in
-    
-    let lexbuf = Lexing.from_string str in
-    let locid = Parser.locident Lexer.token lexbuf in
-    let loc_in locid =
-      locid.lident_loc.Location.loc_start.Lexing.pos_cnum <= pos 
-      && pos < locid.lident_loc.Location.loc_end.Lexing.pos_cnum
-    in
-    let position_add pos_start diff =
-      { Position.line_column = 
-	  Option.map pos_start.Position.line_column ~f:(fun (line,col) ->
-	    if diff.Lexing.pos_lnum = 1 then (* no new line *)
-	      (line, col + diff.Lexing.pos_cnum)
-	    else
-	      (line + diff.Lexing.pos_lnum - 1, diff.Lexing.pos_cnum));
-        bytes = 
-	  Option.map pos_start.Position.bytes ~f:(fun bytes ->
-	    bytes + diff.Lexing.pos_cnum ) }
-    in
-    let subregion locid =
-      { Region.start = position_add region.Region.start locid.lident_loc.Location.loc_start;
-        end_ = position_add region.Region.start locid.lident_loc.Location.loc_end }
-    in
-    let search path locid = 
-      (* The last id name can be different. For example,
-	   module M = struct type t = Foo end
-	   let x = M.Foo
-	 M.Foo is not recorded as a use of M.Foo for now but as a use of M.t.
-      *)
-      let rec search ignore_suffix_diff path locid =
-	match path, locid.lident_desc with
-	| Pident _, LLident _ -> path, locid
-	| Pdot (path', pname, _), LLdot (locid', lname) ->
-	    if ignore_suffix_diff || pname = lname then
- 	      if loc_in locid' then search false path' locid'
-	      else path, locid
-	    else failwith "mismatch"
-	| Papply (path1, path2), LLapply (locid1, locid2) ->
- 	    if loc_in locid1 then search false path1 locid1
- 	    else if loc_in locid2 then search false path2 locid2
-	    else path, locid
-	| Pdot (_, pname, _), LLident lname -> 
-	    if pname = lname then path, locid
-	    else failwith "mismatch"
-	| _ -> assert false
+    let region = Region.complete mlpath region in
+    let str = snd (Region.substring mlpath region) in
+    try
+      let pos = Position.complete mlpath pos in
+      let pos = 
+        match pos.Position.bytes, region.Region.start.Position.bytes with 
+        | Some pos_bytes, Some start_bytes -> pos_bytes - start_bytes
+        | _ -> failwith "The given position is not clear enough"
       in
-      try search true path locid with
-      | Failure s -> 
-	  Format.eprintf "Error: pathreparse: %s (path) <> %a (from source)@."
-	    (Path.name path) 
-	    Locident.format locid;
-	  failwith s
-    in
-    if loc_in locid then 
-      let path, locid = search path locid in
-      Some (path, subregion locid)
-    else None
+      
+      let lexbuf = Lexing.from_string str in
+      let locid = Parser.locident Lexer.token lexbuf in
+      let loc_in locid =
+        locid.lident_loc.Location.loc_start.Lexing.pos_cnum <= pos 
+        && pos < locid.lident_loc.Location.loc_end.Lexing.pos_cnum
+      in
+      let position_add pos_start diff =
+        { Position.line_column = 
+  	  Option.map pos_start.Position.line_column ~f:(fun (line,col) ->
+  	    if diff.Lexing.pos_lnum = 1 then (* no new line *)
+  	      (line, col + diff.Lexing.pos_cnum)
+  	    else
+  	      (line + diff.Lexing.pos_lnum - 1, diff.Lexing.pos_cnum));
+          bytes = 
+  	  Option.map pos_start.Position.bytes ~f:(fun bytes ->
+  	    bytes + diff.Lexing.pos_cnum ) }
+      in
+      let subregion locid =
+        { region with
+          Region.start = position_add region.Region.start locid.lident_loc.Location.loc_start;
+          end_ = position_add region.Region.start locid.lident_loc.Location.loc_end }
+      in
+      let search path locid = 
+        (* The last id name can be different. For example,
+  	   module M = struct type t = Foo end
+  	   let x = M.Foo
+  	 M.Foo is not recorded as a use of M.Foo for now but as a use of M.t.
+        *)
+        let rec search ignore_suffix_diff path locid =
+  	match path, locid.lident_desc with
+  	| Pident _, LLident _ -> path, locid
+  	| Pdot (path', pname, _), LLdot (locid', lname) ->
+  	    if ignore_suffix_diff || pname = lname then
+   	      if loc_in locid' then search false path' locid'
+  	      else path, locid
+  	    else failwith "mismatch"
+  	| Papply (path1, path2), LLapply (locid1, locid2) ->
+   	    if loc_in locid1 then search false path1 locid1
+   	    else if loc_in locid2 then search false path2 locid2
+  	    else path, locid
+  	| Pdot (_, pname, _), LLident lname -> 
+  	    if pname = lname then path, locid
+  	    else failwith "mismatch"
+  	| _ -> assert false
+        in
+        try search true path locid with
+        | Failure s -> 
+  	  Format.eprintf "Error: pathreparse: %s (path) <> %a (from source)@."
+  	    (Path.name path) 
+  	    Locident.format locid;
+  	  failwith s
+      in
+      if loc_in locid then 
+        let path, locid = search path locid in
+        Some (path, subregion locid)
+      else None
+    with
+    | e -> 
+        Format.printf  "Pathreparse: not supported: %s (%s)@." 
+  	str
+  	(Printexc.to_string e);
+        None;
   with
-  | e -> 
-      Format.printf  "Pathreparse: not supported: %s (%s)@." 
-	str
-	(Printexc.to_string e);
-      None;
+  | e ->
+        Format.printf  "Pathreparse: not supported: (%s)@." 
+  	(Printexc.to_string e);
+        None;
 ;;
 
 module Region = struct
   type t = { 
+    fname : string;
     start : Position.t;
     end_ : Position.t
   }
 
   let to_string t =
+    Printf.sprintf "%s:%s:%s"
+      t.fname
+      (Position.to_string t.start)
+      (Position.to_string t.end_)
+
+  let to_string_no_path t =
     Printf.sprintf "%s:%s"
       (Position.to_string t.start)
       (Position.to_string t.end_)
 
-  let of_parsing l =
+  let of_parsing builddir l =
+    let fname1 = l.Location.loc_start.Lexing.pos_fname in
+    let fname2 = l.Location.loc_end.Lexing.pos_fname in
+    if fname1 <> fname2 then
+      Format.eprintf "Warning: A location contains strange file names %s and %s@." fname1 fname2;
+    let fname = match fname1 with
+      | "_none_" -> fname1
+      | _ when Filename.is_relative fname1 -> builddir ^/ fname1 
+      | _ -> fname1 
+    in
     let start = Position.of_lexing_position l.Location.loc_start in
     let end_ = Position.of_lexing_position l.Location.loc_end in
     match Position.compare start end_ with
-    | -1 | 0 -> { start = start; end_ = end_ }
-    | _ -> { start = end_; end_ = start }
+    | -1 | 0 -> { fname; start = start; end_ = end_ }
+    | _ -> { fname; start = end_; end_ = start }
 
   let compare l1 l2 = 
-    if Position.compare l1.start l2.start = 0 
-       && Position.compare l2.end_ l1.end_ = 0 then `Same
-    else if Position.compare l1.start l2.start <= 0 
-         && Position.compare l2.end_ l1.end_ <= 0 then `Includes
-    else if Position.compare l2.start l1.start <= 0 
-         && Position.compare l1.end_ l2.end_ <= 0 then `Included
-    else if Position.compare l1.end_ l2.start <= 0 then `Left
-    else if Position.compare l2.end_ l1.start <= 0 then `Right
-    else `Overwrap
+    match compare l1.fname l2.fname with
+    | 1 -> `Left
+    | -1 -> `Right
+    | _ ->
+        if Position.compare l1.start l2.start = 0 
+           && Position.compare l2.end_ l1.end_ = 0 then `Same
+        else if Position.compare l1.start l2.start <= 0 
+                && Position.compare l2.end_ l1.end_ <= 0 then `Includes
+        else if Position.compare l2.start l1.start <= 0 
+                && Position.compare l1.end_ l2.end_ <= 0 then `Included
+        else if Position.compare l1.end_ l2.start <= 0 then `Left
+        else if Position.compare l2.end_ l1.start <= 0 then `Right
+        else `Overwrap
 
 (*
   let position_prev pos = { pos with pos_cnum = pos.pos_cnum - 1 }
 
   open Position
 
-  let point_by_byte pos =
-    { start = { line_column = None;
+  let point_by_byte fname pos =
+    { fname;
+      start = { line_column = None;
  		bytes = Some pos };
       end_ = { line_column = None;
                bytes = Some (pos + 1)} }
 
-  let point pos = { start = pos; end_ = Position.next pos }
+  let point fname pos = { fname; start = pos; end_ = Position.next pos }
 
   let length_in_bytes t =
     let bytes = function
   let is_complete t = 
     Position.is_complete t.start && Position.is_complete t.end_
 
+  (* CR jfuruse: fname is overwritten. Strange. *)      
   let complete mlpath t =
-    { start = Position.complete mlpath t.start;
+    { fname = mlpath;
+      start = Position.complete mlpath t.start;
       end_ = Position.complete mlpath t.end_ }
 
   let substring mlpath t =
 
   let of_file ({ F.loc_annots; } as f) = 
     let rannots = lazy (Hashtbl.fold (fun loc annots st -> 
-      { Regioned.region = Region.of_parsing loc;  value = annots } :: st) 
+      { Regioned.region = Region.of_parsing f.F.builddir loc;  value = annots } :: st) 
                           loc_annots [])
     in
     let id_def_regions = lazy (
         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))
+                Hashtbl.add tbl id (Region.of_parsing f.F.builddir 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 })
+        Tree.add st { Regioned.region = Region.of_parsing f.F.builddir loc; value = annots })
         loc_annots Tree.empty 
     end in
     (* CR jfuruse: it is almost the same as id_def_regions_list *)
 
 module Region : sig
 
-  type t = { start : Position.t; end_ : Position.t; }
+  type t = { fname : string; start : Position.t; end_ : Position.t; }
   
   val compare : t -> t -> [> `Included | `Includes | `Left | `Overwrap | `Right | `Same ]
 
   val to_string : t -> string
-  val of_parsing : Location.t -> t
+  val to_string_no_path : t -> string
+  val of_parsing : string -> Location.t -> t
   val split : t -> by:t -> (t * t) option
-  val point_by_byte : int -> t  
+  val point_by_byte : string -> int -> t  
     (** works only if bytes are available *)
-  val point : Position.t -> t
+  val point : string -> Position.t -> t
   val length_in_bytes : t -> int
   val is_complete : t -> bool
   val complete : string -> t -> t
 end = struct
 
   let check_time_stamp ~cmt source =
+    (* CR jfuruse: aaa.mll creates cmt with aaa.ml as source, but
+       aaa.ml often does not exist.
+    *)
     let stat_cmt = Unix.stat cmt in
     try
       let stat_source = Unix.stat source in
 depend: beforedepend
 	$(OCAMLDEP) $(INCLUDES) -I dir1 -I dir2 *.mli *.ml */*.mli */*.ml > .depend
 
-Makefile.targets: *.ml *.mli */*.ml
+Makefile.targets: *.ml *.mll *.mli */*.ml
 	echo TARGETS= \\ > $@
-	ls *.ml *.mli | sed -e 's/mli$$/cmi/' -e 's/ml$$/cmo/' -e 's/$$/ \\/'	 >> $@
+	ls *.ml *.mli *.mll | sed -e 's/mli$$/cmi/' -e 's/ml$$/cmo/' -e 's/mll$$/cmo/' -e 's/$$/ \\/'	 >> $@
 
 .PHONY: clean install installopt beforedepend depend
 

tests/Makefile.targets

 interface.cmo \
 intermodule.cmo \
 let_open.cmo \
+lex.cmo \
+lex.cmo \
 localvar.cmo \
 module.cmo \
 module_alias.cmo \
+{
+open Lexing
+
+exception Error of int * int * string
+
+let error lexbuf s =
+  raise (Error (lexeme_start lexbuf, lexeme_end lexbuf, s))
+}
+
+rule exp st = parse
+  | "}" { st }
+  | "\\}" { exp (st ^ "}") lexbuf }
+  | "\\" { exp (st ^ "\\") lexbuf }
+  | ([^ '\\' '}']+ as s) { exp (st ^ s) lexbuf }
+  | _ as c { 
+      error lexbuf (Printf.sprintf "illegal char in ${exp}: %C" c) }
+  | eof { 
+      error lexbuf "unterminated ${exp}"
+    }
+
+{
+
+(* CR jfuruse: the test script only provides byte position, 
+   which does not work well for .mll *)
+let from_string s = exp (* ? exp *) "" (Lexing.from_string s)
+
+}
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.