Commits

camlspotter  committed b75a0de

fixed the issue of constructors and fields: their use sites lots Path.t and only Longident.t is available

  • Participants
  • Parent commits 8dbc0ed
  • Branches 4.01.0.2.1.3

Comments (0)

Files changed (5)

File ocamlspot.ml

 	  in
 	  let base = base_ident path in
 	  List.iter (fun { FileRegioned.file_region= (rpath, region); value= annots } -> 
-                List.iter (function
-                  | Annot.Use (k', path') when k = k' && base = base_ident path' ->
-	              begin match query_by_kind_path file k' path' with
-	              | Some found' when found = found' ->
-		          printf "<%s:%s:%s>: %s@." 
-		            file.Unit.path
-                            rpath
-		            (Region.to_string region)
-		            (Path.name path)
-	              | None | Some _ -> ()
-	              end
-                  | _ -> ()) annots) !!(file.Unit.rannots)
+            List.iter (function
+              | Annot.Use (k', path') when k = k' && base = base_ident path' ->
+	          begin match query_by_kind_path file k' path' with
+	          | Some found' when found = found' ->
+		      printf "<%s:%s:%s>: %s@." 
+		        file.Unit.path
+                        rpath
+		        (Region.to_string region)
+		        (Path.name path)
+	          | None | Some _ -> ()
+	          end
+              | _ -> ()) annots) !!(file.Unit.rannots)
 	| _ -> ());
     in
 
 open Format
 
 let magic_number = "OCamlSpot"
-let ocaml_version = "4.00.1" (* 4.00.1 also works *)
-let version = "2.0.0"
+let ocaml_version = "4.01.0"
+let version = "2.1.0"
 
 (** Kind of ``object`` *)
 module Kind = struct
     | Value | Type | Exception
     | Module | Module_type
     | Class | Class_type
+    | Constructor | Field
 
   let to_string = function
     | Value       -> "v"
     | Module_type -> "mt"
     | Class       -> "c"
     | Class_type  -> "ct"
+    | Constructor -> "constr"
+    | Field       -> "field"
 
   (* for messages *)
   let name = function
     | Module_type -> "module_type"
     | Class       -> "class"
     | Class_type  -> "class_type"
+    | Constructor -> "constructor"
+    | Field       -> "field"
 
   (* used for query interface *)
   let from_string = function
-    | "v"  | "value"       -> Value
-    | "t"  | "type"        -> Type
-    | "e"  | "exception"   -> Exception
-    | "m"  | "module"      -> Module
-    | "mt" | "module_type" -> Module_type
-    | "c"  | "class"       -> Class
-    | "ct" | "class_type"  -> Class_type
+    | "v"  | "value"           -> Value
+    | "t"  | "type"            -> Type
+    | "e"  | "exception"       -> Exception
+    | "m"  | "module"          -> Module
+    | "mt" | "module_type"     -> Module_type
+    | "c"  | "class"           -> Class
+    | "ct" | "class_type"      -> Class_type
+    | "constr" | "constructor" -> Constructor
+    | "field"                  -> Field
     | _ -> raise Not_found
 end
 
   and structure = structure_item list
 
   and structure_item =
-    | AStr_value      of Ident.t
-    | AStr_type       of Ident.t
-    | AStr_exception  of Ident.t
-    | AStr_module     of Ident.t * module_expr
-    | AStr_modtype    of Ident.t * module_expr
-    | AStr_class      of Ident.t
-    | AStr_class_type of Ident.t
-    | AStr_included   of Ident.t * module_expr * Kind.t * Ident.t
+    | AStr_value       of Ident.t
+    | AStr_type        of Ident.t * structure
+    | AStr_exception   of Ident.t
+    | AStr_module      of Ident.t * module_expr
+    | AStr_modtype     of Ident.t * module_expr
+    | AStr_class       of Ident.t
+    | AStr_class_type  of Ident.t
+    | AStr_included    of Ident.t * module_expr * Kind.t * Ident.t
+    | AStr_constructor of Ident.t
+    | AStr_field       of Ident.t
 
   let rec format_module_expr ppf = function
     | AMod_ident p       -> fprintf ppf "%s" (Path.name p)
 
   and format_structure_item ppf = function
     | AStr_value id     -> fprintf ppf "val %s" (Ident.name id)
-    | AStr_type id      -> fprintf ppf "type %s" (Ident.name id) (* CR jfuruse: todo *)
+    | AStr_constructor id -> fprintf ppf "constructor %s" (Ident.name id)
+    | AStr_field id     -> fprintf ppf "field %s" (Ident.name id)
+    | AStr_type (id, td) -> fprintf ppf "type %s @[%a@]" (Ident.name id) format_structure td
     | AStr_exception id -> fprintf ppf "exception %s" (Ident.name id)
     | AStr_module (id, mexp) ->
         fprintf ppf "@[<v4>module %s =@ %a@]"
 
   let ident_of_structure_item : structure_item -> (Kind.t * Ident.t) = function
     | AStr_value id                  -> (Kind.Value, id)
-    | AStr_type id                   -> (Kind.Type, id)
+    | AStr_type (id, _)              -> (Kind.Type, id)
     | AStr_exception id              -> (Kind.Exception, id)
     | AStr_module (id, _)            -> (Kind.Module, id)
     | AStr_modtype (id, _)           -> (Kind.Module_type, id)
     | AStr_class id                  -> (Kind.Class, id)
     | AStr_class_type id             -> (Kind.Class_type, id)
     | AStr_included (id, _, kind, _) -> (kind, id)
+    | AStr_constructor id            -> (Constructor, id)
+    | AStr_field id                  -> (Field, id)
 
   module Module_expr = struct
     (* cache key is Typedtree.module_expr *)
       let equal s1 s2 =
 	match s1, s2 with
 	| AStr_value id1, AStr_value id2
-	| AStr_type id1, AStr_type id2
 	| AStr_exception id1, AStr_exception id2
 	| AStr_class id1, AStr_class id2
 	| AStr_class_type id1, AStr_class_type id2 -> id1 = id2
 	| AStr_included (id1, mexp1, kind1, id1'), AStr_included (id2, mexp2, kind2, id2') ->
             id1 = id2 && kind1 = kind2 && id1' = id2'
             && Module_expr.equal mexp1 mexp2
+	| AStr_type (id1, td1), AStr_type (id2, td2) ->
+            id1 = id2 && td1 = td2
+        | AStr_constructor id1, AStr_constructor id2 -> id1 = id2
+        | AStr_field id1, AStr_field id2 -> id1 = id2
 	| (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _
-	  | AStr_class _ | AStr_class_type _ | AStr_module _ | AStr_included _),
+	  | AStr_class _ | AStr_class_type _ | AStr_module _ | AStr_included _
+          | AStr_constructor _ | AStr_field _),
 	  (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _
-	  | AStr_class _ | AStr_class_type _ | AStr_module _ | AStr_included _) -> false
+	  | AStr_class _ | AStr_class_type _ | AStr_module _ | AStr_included _
+          | AStr_constructor _ | AStr_field _) -> false
 
       let hash = Hashtbl.hash
     end
     and signature_item = function
       | Sig_value (id, _)          -> [AStr_value id]
       | Sig_exception (id, _)      -> [AStr_exception id]
-      | Sig_type (id, td, _)       -> AStr_type id :: type_declaration td
+      | Sig_type (id, td, _)       -> [type_declaration id td]
       | Sig_module (id, mty, _)    -> [AStr_module (id, module_type mty)]
       | Sig_modtype (id, mty_decl) -> [AStr_modtype (id, modtype_declaration mty_decl)]
       | Sig_class (id, _, _)       -> 
           (* CR jfuruse: Need to check what happens in includsion of class *)
-          [AStr_class id; AStr_class_type id;  AStr_type id;]
+          [AStr_class id; AStr_class_type id;  AStr_type (id, [])]
       | Sig_class_type (id, _, _)  -> [ AStr_class_type id ]
 
-    and type_declaration td = match td.type_kind with
-      | Type_abstract -> []
+    and type_declaration id td = match td.type_kind with
+      | Type_abstract -> AStr_type (id, [])
       | Type_variant lst -> 
-          (* We add constructor names as types. *)
-          List.map (fun (id, _, _) -> AStr_type id) lst
+          AStr_type (id, List.map (fun (id, _, _) -> AStr_constructor id) lst)
       | Type_record (lst, _) -> 
-          (* We add record label names as types. *)
-          List.map (fun (id, _, _) -> AStr_type id) lst
+          AStr_type (id, List.map (fun (id, _, _) -> AStr_field id) lst)
       
     and module_type = function
       | Mty_ident p -> AMod_ident p
 	List.map (fun id -> AStr_value id) (let_bound_idents pat_exps)
     | Tstr_primitive (id, _, _vdesc) ->
 	[AStr_value id]
-    | Tstr_type id_descs -> List.concat_map (fun (id, _, td) -> AStr_type id :: type_declaration td) id_descs
+    | 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? *)
     | Tsig_modtype (id, _, mty_decl) ->
         [(* todo *) AStr_modtype (id, modtype_declaration mty_decl) (* sitem.sig_final_env can be used? *) ]
 
-    | Tsig_type typs -> List.concat_map (fun (id, _, td) -> AStr_type id :: type_declaration td) typs
+    | 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]
+            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
 
     | Tmodtype_abstract -> AMod_abstract
     | Tmodtype_manifest mty -> module_type mty
 
-  and type_declaration td = match td.typ_kind with
-    | Ttype_abstract -> []
+  and type_declaration id td = match td.typ_kind with
+    | Ttype_abstract -> AStr_type (id, [])
     | Ttype_variant lst -> 
-        (* We add constructor names as types. *)
-        List.map (fun (id, {loc=_loc}, _, _) -> AStr_type id) lst
+        AStr_type (id, List.map (fun (id, {loc=_loc}, _, _) -> AStr_constructor id) lst)
     | Ttype_record lst -> 
-        (* We add record label names as types. *)
-        List.map (fun (id, {loc=_loc}, _, _, _) -> AStr_type id) 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
 module Annot = struct
   type t =
     | Use               of Kind.t * Path.t
-    | UseConstruct      of Kind.t * Path.t * string
     | 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
     | 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
-    | UseConstruct (k1,p1,n1), UseConstruct (k2,p2,n2) -> k1 = k2 && p1 = p2 && n1 = n2
     | Non_expansive b1, Non_expansive b2 -> b1 = b2
     | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
-    | (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | UseConstruct _ | Non_expansive _
+    | (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
           | Mod_type _),
-      (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | UseConstruct _ | Non_expansive _
+      (Type _ | Str_item _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
           | Mod_type _) -> false
 
   module Record = struct
       let open Types in
       let open Ctype in
       match (repr typ).desc with
-      | Tconstr (path, _, _) -> record tbl loc (Use (K.Type, path))
+      | Tconstr (path, _, _) -> record tbl loc (Use (K.Field, path))
       | _ -> (* strange.. *) ()
 
     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 = record loc (UseConstruct (kind, path, name)) in
+      and record_use_construct loc kind path name = record loc (Use (kind, Path.Pdot (path, name, -1 (* dummy *)))) in
     object
       inherit Ttfold.ovisit as super
 
               | Tconstr (p, _, _) -> p
               | _ -> assert false
             in
-            record p.pat_loc (UseConstruct (kind, path, cdesc.Types.cstr_name))
+            record p.pat_loc (Use (kind, Path.Pdot(path, cdesc.Types.cstr_name, -1 (* dummy *))))
         | Tpat_record _ -> record_record tbl p.pat_loc p.pat_type
         | _ -> ()
         end;
         | Tpat_alias (_, id, {loc}) -> record_def loc (AStr_value id)
         | Tpat_construct _ -> () (* done in #pattern *)
         | Tpat_record (lst , _) ->
+            (* CR jfuruse: we can extract the real Ident.t of the field
+               but it requires rebuilding environment. Is it worth? *)
             List.iter (fun ({loc}, ldesc, _) ->
               let path = match (Ctype.repr ldesc.Types.lbl_res).desc with
                 | Tconstr (p, _, _) -> p
         | Texp_construct (_, cdesc, _, _) ->
             let kind = match cdesc.Types.cstr_tag with
               | Types.Cstr_exception _ -> K.Exception
-              | _ -> K.Type
+              | _ -> K.Constructor
             in
             (* CR jfuruse: dupe at class fold *)
             let path = 
         | Tstr_primitive (id, {loc}, _) ->
             record_def loc (AStr_value id)
         | Tstr_type lst ->
-            List.iter (fun (id, {loc}, _) ->
-              record_def loc (AStr_type id)) 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'}) ->
                                  | Twith_module _    -> K.Module
                                  | Twith_typesubst _ -> K.Type
                                  | Twith_modsubst _  -> K.Module),
-                                path ))) lst
+                                path))) lst
         | Tmty_typeof _
         | Tmty_signature _ -> ()
         end;
         begin match sid with
         | Tsig_value (id, {loc}, _) -> record_def loc (AStr_value id)
         | Tsig_type lst ->
-            List.iter (fun (id, {loc}, _) ->
-              record_def loc (AStr_type id)) 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);
     typ_loc: Location.t }
 *)
 
+(* This is now done in the upper level
       method! type_kind tk =
         begin match tk with
         | Ttype_abstract -> ()
               record_def loc (AStr_type id)) lst
         end;
         super#type_kind tk
+*)
 
 (*
 
         (* 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);
+        record_def loc (AStr_type (ci.ci_id_object, []));
+        record_def loc (AStr_type (ci.ci_id_typesharp, []));
         super#class_infos f ci
 
     end
     | Use (use, path) ->
 	fprintf ppf "Use: %s, %s"
 	  (String.capitalize (Kind.name use)) (Path.name path)
-    | UseConstruct (use, path, name) ->
-	fprintf ppf "Use: %s, %s.%s"
-	  (String.capitalize (Kind.name use)) (Path.name path) name
     | Module mexp ->
 	fprintf ppf "Module: %a"
           Abstraction.format_module_expr mexp
     | Use (use, path) ->
 	fprintf ppf "Use: %s, %s"
 	  (String.capitalize (Kind.name use)) (Path.name path)
-    | UseConstruct (use, path, name) ->
-	fprintf ppf "Use: %s, %s.%s"
-	  (String.capitalize (Kind.name use)) (Path.name path) name
     | Module _mexp ->
 	fprintf ppf "Module: ..."
     | Functor_parameter id ->
     | Value | Type | Exception 
     | Module | Module_type 
     | Class | Class_type
+    | Constructor | Field
 
   val to_string : t -> string
   val from_string : string -> t
 
   and structure_item = 
     | AStr_value      of Ident.t
-    | AStr_type       of Ident.t
+    | AStr_type       of Ident.t * structure
     | AStr_exception  of Ident.t
     | AStr_module     of Ident.t * module_expr
     | AStr_modtype    of Ident.t * module_expr
     | AStr_class      of Ident.t
     | AStr_class_type of Ident.t
     | AStr_included   of Ident.t * module_expr * Kind.t * Ident.t
+    | AStr_constructor of Ident.t
+    | AStr_field       of Ident.t
 
   val ident_of_structure_item : structure_item -> (Kind.t * Ident.t)
 
 module Annot : sig
   type t =
     | Use of Kind.t * Path.t
-    | UseConstruct of Kind.t * Path.t * string
     | 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 

File spotconfig.ml

       try
         let at2 = String.rindex_from s (at - 1) ':' in
         String.sub s 0 at2,
-        Kind 
-          (Kind.from_string (String.sub s (at2+1) (at-at2-1)),
-           let s = String.sub s (at+1) (String.length s - at - 1) in 
-           try Path.parse s with
-           | _ -> failwithf "illegal path in <file>:<kind>:<path> : %s" s)
+        let kind = Kind.from_string (String.sub s (at2+1) (at-at2-1)) in
+        let path_string = String.sub s (at+1) (String.length s - at - 1) in
+        let path = 
+          try Path.parse s with
+          | _ -> failwithf "illegal path in <file>:<kind>:<path> : %s" path_string
+        in 
+        Kind (kind, path)
       with
       | Invalid_argument _ | Not_found -> 
           String.sub s 0 at,
   let packed = ref (fun _ _ -> assert false : Env.t -> string -> Value.t)
 
   let rec find_path env (kind, p) : Value.z = 
-    match p with
-    | Path.Papply (p1, p2) -> 
-	let v1 = find_path env (kind, p1) in (* CR jfuruse: Kind.Module ? *)
-	let v2 = find_path env (kind, p2) in
+    match kind, p with
+    | _, Path.Papply (p1, p2) ->
+	let v1 = find_path env (Kind.Module, p1) in
+	let v2 = find_path env (Kind.Module, p2) in
 	apply v1 v2
-    | Path.Pident id -> 
+    | _, Path.Pident id ->
         (* predef check first (testing) *)
         begin match Env.find Env.predef id with
         | Some (_, v) -> v
               end
             end
             end
-    | Path.Pdot (p, name, pos) ->
+    | (Kind.Constructor | Field), Path.Pdot (p, name, pos) ->
+        assert (pos = -1);
+        lazy begin
+          match !!(find_path env (Kind.Type, p)) with
+          | Structure (pid, str, _ (* CR jfuruse *)) -> 
+              begin Debug.format "Type %s found (%a)@." (Path.name p) PIdent.format pid;
+              try
+                !!(find_name str (kind, name))
+              with
+              | Not_found -> Error (Failure (Printf.sprintf "Not_found %s:any" name))
+              end
+          | _ -> assert false
+        end
+
+    | _, Path.Pdot (p, name, pos) ->
         lazy begin
           match !!(find_path env (Kind.Module, p)) with
           | Ident _ -> (try assert false with e -> Error e)
 *)
       k = kind && Ident0.name id = name in
     (* CR jfuruse: double check by pos! *)
+    (* CR jfuruse: yes it can cause a bug if two x with the same kind exist in a stucture *)
     lazy begin
       try
         !!(snd (snd (List.find (fun id_value ->
           Error (Failure (Printf.sprintf "Not found: %s__%d" name pos))
     end
 
+  (* Used for finding constructor/field *)      
+  and find_name (str : Value.structure) (kind, name) : Value.z =
+    let name_filter = fun (id, (k,_)) -> k = kind && Ident0.name id = name in
+    lazy begin
+      try
+        !!(snd (snd (List.find (fun id_value ->
+          (* pos_filter id_value && *) name_filter id_value) str)))
+      with
+      | Not_found ->
+          Debug.format "Error: Not found %s %s in { @[%a@] }@."
+            (String.capitalize (Kind.to_string kind))
+            name
+            Value.Format.structure str;
+          Error (Failure (Printf.sprintf "Not found: %s__any" name))
+    end
+
   and module_expr env idopt : module_expr -> Value.z = function
     | AMod_functor_parameter -> 
         eager (Parameter { PIdent.path= env.path; ident = idopt })
 
     List.fold_left (fun str sitem ->
       match sitem with
-      | AStr_value     id 
-      | AStr_type      id
-      | AStr_exception id
-      | AStr_class     id
-      | AStr_class_type    id ->
+      | AStr_value       id 
+      | AStr_constructor id 
+      | AStr_field       id 
+      | AStr_exception   id
+      | AStr_class       id
+      | AStr_class_type  id ->
           (* CR jfuruse: not sure *)
           let pident = { PIdent.path = env0.Env.path; ident = Some id } in
           let v = Ident pident in
           (* CR jfuruse: use ident_of_structure_item *)
           let kind = match sitem with
             | AStr_value      _ -> Kind.Value
-            | AStr_type       _ -> Kind.Type
+            | AStr_type       _ -> assert false
+            | AStr_constructor _ -> Kind.Constructor
+            | AStr_field      _ -> Kind.Field
             | AStr_exception  _ -> Kind.Exception
             | AStr_modtype    _ -> Kind.Module_type
             | AStr_class      _ -> Kind.Class
           in
           (id, (Kind.Module, v)) :: str
 
+      | AStr_type (id, td) ->
+          let v = lazy begin
+            let pident = { PIdent.path = env0.Env.path; ident = Some id } in
+            try
+              Structure (pident, structure env0 td, None)
+            with
+            | exn -> Error exn
+          end
+          in
+          (id, (Kind.Type, v)) :: str
+
       | AStr_modtype (id, mexp) ->
           (* CR jfuruse: dup code *)
           let v = lazy begin