Permalink
Browse files

Tried generalizing value completion ; stuck by the bad front-end

Owz_parser is in an inconsistent state w.r.t. longident table !
  • Loading branch information...
1 parent ef8f55e commit 4c9ab9f4aa4731373500a0ae6a429d57ddf12fe3 Tiphaine Turpin committed Jul 11, 2011
View
@@ -144,6 +144,7 @@ CMO_SYNTACTIC = \
$(PATH_COMMON)incLexer.cmo \
$(PATH_COMMON)incParser.cmo \
$(PATH_COMMON)typedtreeOps.cmo \
+ $(PATH_COMMON)locate.cmo \
$(PATH_SYNTACTIC)syntax_completion.cmo
View
@@ -1,4 +1,3 @@
-- Git add renameLetModule/ModuleRec.ml
- Rename: replace in multiple files
- Grep: should be easy to implement using rename
- Rename: return a list of files that emacs should revert
@@ -10,7 +9,6 @@
- Rename: warn about potential future captures
- Binannot: only record locs and envs if annot is set
- Completion: Use a best qualification for labels
-- Errors: do not output anything, and stop everything in the emacs mode
- Match_cases completion: indent the cases correctly
- Match_cases completion: allow an optional |
- Incremental parsing: recover from errors in the unmodified part
@@ -0,0 +1,127 @@
+(**************************************************************************)
+(* *)
+(* Ocamlwizard-Binannot *)
+(* Tiphaine Turpin *)
+(* Copyright 2011 INRIA Saclay - Ile-de-France *)
+(* *)
+(* This software is free software; you can redistribute it and/or *)
+(* modify it under the terms of the GNU Library General Public *)
+(* License version 2.1, with the special exception on linking *)
+(* described in file LICENSE. *)
+(* *)
+(* This software is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
+(* *)
+(**************************************************************************)
+
+open Util
+open Location
+open Types
+open Typedtree
+open TypedtreeOps
+open Env
+
+let contains loc (b', e') =
+ let b, e = Util.get_c_num loc in
+ b <= b' && e' <= e
+
+let locate_map priority f loc =
+ find_map priority
+ (function t ->
+ if
+ (match t with
+ | `module_expr e -> contains e.mod_loc
+ | `module_type t -> contains t.mty_loc
+ | `pattern p -> contains p.pat_loc
+ | `expression e -> contains e.exp_loc
+ | `structure_item i -> contains i.str_loc
+ | `signature_item i -> contains i.sig_loc
+ | `type_declaration d -> contains d.typ_loc
+ | _ -> function _ -> false)
+ loc
+ then f t
+ else None)
+
+let locate priority = locate_map priority (function x -> Some x)
+
+let locate_field loc pid ploc fs tfs =
+ let f, _ =
+ List.find
+ (function _, tf -> contains (ploc tf) loc)
+ (List.combine fs tfs)
+ in
+ pid f
+
+let locate_id loc pid ploc decls =
+ pid
+ (List.find
+ (function d -> contains (ploc d) loc)
+ decls)
+
+let ident_def table id = StringTbl.find table (Ident.name id)
+
+(* Missing: Tstr_class_type, class_infos, Tmeth_val, cstr_meths,
+ Tcf_inher, Tcf_val, Tcf_let *)
+let longident table loc =
+ locate_map `innermost
+ (function n ->
+ try Some (match n with
+
+ (* Values *)
+ | `pattern {pat_desc = Tpat_var id}
+ | `pattern {pat_desc = Tpat_alias (_, TPat_alias id)}
+ | `expression {exp_desc = Texp_for (id, _, _, _, _)}
+ | `structure_item {str_desc = Tstr_primitive (id, _)}
+ | `signature_item {sig_desc = Tsig_value (id, _)} -> Value, id
+
+ | `class_expr {cl_desc =
+ Tcl_fun (_, _, bs, _, _) | Tcl_let (_, _, bs, _)} ->
+ Value, locate_id loc fst (function id, _ -> ident_def table id) bs
+
+ (* Modules *)
+ | `structure_item {str_desc = Tstr_module (id, _)}
+ | `signature_item {sig_desc = Tsig_module (id, _)}
+ | `module_expr {mod_desc = Tmod_functor (id, _, _)}
+ | `module_type {mty_desc = Tmty_functor (id, _, _)}
+ | `expression {exp_desc = Texp_letmodule (id, _, _)} -> Module, id
+
+ | `structure_item {str_desc = Tstr_recmodule mods} ->
+ Module,
+ locate_id loc (function id, _, _ -> id)
+ (function id, _, _ -> ident_def table id) mods
+
+ | `signature_item {sig_desc = Tsig_recmodule mods} ->
+ Module,
+ locate_id loc fst (function id, _ -> ident_def table id) mods
+
+ (* Module types *)
+ | `structure_item {str_desc = Tstr_modtype (id, _)}
+ | `signature_item {sig_desc = Tsig_modtype (id, _)} -> Modtype, id
+
+ (* Types *)
+ | `structure_item {str_desc = Tstr_type types}
+ | `signature_item {sig_desc = Tsig_type types} ->
+ Type, locate_id loc fst (function _, d -> d.typ_loc) types
+
+ (* Constructors, fields, and exceptions *)
+ | `type_declaration d ->
+ (match d.typ_type.type_kind, d.typ_kind with
+ | Type_variant cs, Ttype_variant tcs ->
+ Constructor,
+ locate_field loc fst (function _, _, loc -> loc) cs tcs
+ | Type_record (fs, _), Ttype_record tfs ->
+ Label,
+ locate_field loc
+ (function id, _, _ -> id) (function _, _, _, loc -> loc)
+ fs tfs
+ | Type_abstract, Ttype_abstract -> raise Not_found
+ | _ -> assert false)
+
+ | `structure_item {str_desc = Tstr_exception (id, _)}
+ | `structure_item {str_desc = Tstr_exn_rebind (id, _)}
+ | `signature_item {sig_desc = Tsig_exception (id, _)} -> Constructor, id
+
+ | _ -> raise Not_found)
+ with Not_found -> None)
+ loc
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(* *)
+(* Ocamlwizard-Binannot *)
+(* Tiphaine Turpin *)
+(* Copyright 2011 INRIA Saclay - Ile-de-France *)
+(* *)
+(* This software is free software; you can redistribute it and/or *)
+(* modify it under the terms of the GNU Library General Public *)
+(* License version 2.1, with the special exception on linking *)
+(* described in file LICENSE. *)
+(* *)
+(* This software is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
+(* *)
+(**************************************************************************)
+
+val contains : Location.t -> int * int -> bool
+
+(** Return the innermost subtree whose locations contains a given
+ character number interval [a, b[.
+
+ Warning: most node kinds are missing ! *)
+val locate : [`outermost | `innermost] -> int * int ->
+ TypedtreeOps.node TypedtreeOps.sfun
+
+(** Simliar to locate, but we return the first node along a path (in
+ the sense of the given priority) for which the parameter function
+ returns some result. *)
+val locate_map : [`outermost | `innermost] -> (TypedtreeOps.node -> 'a option) ->
+ int * int -> 'a TypedtreeOps.sfun
+
+(*
+(** The same as locate, but with exceptions *)
+val locate_map_exn : [`outermost | `innermost] -> (node -> 'a) ->
+ int * int -> 'a sfun
+*)
+
+(** Return the location of a longident. Objects are not implemented. *)
+val longident :
+ Location.string_table -> int * int ->
+ [ `signature of Typedtree.signature | `structure of Typedtree.structure ] ->
+ Env.path_sort * Ident.t
+
+(** Return the location of the definition of an ident. *)
+val ident_def :
+(*
+ [ `signature of Typedtree.signature | `structure of Typedtree.structure ] ->
+*)
+ Location.string_table -> Ident.t -> Location.t
@@ -182,29 +182,6 @@ let find_map priority (type a) cond s =
with
M.Found x -> x
-let contains loc (b', e') =
- let b, e = Util.get_c_num loc in
- b <= b' && e' <= e
-
-let locate_map priority f loc =
- find_map priority
- (function t ->
- if
- (match t with
- | `module_expr e -> contains e.mod_loc
- | `module_type t -> contains t.mty_loc
- | `pattern p -> contains p.pat_loc
- | `expression e -> contains e.exp_loc
- | `structure_item i -> contains i.str_loc
- | `signature_item i -> contains i.sig_loc
- | `type_declaration d -> contains d.typ_loc
- | _ -> function _ -> false)
- loc
- then f t
- else None)
-
-let locate priority = locate_map priority (function x -> Some x)
-
let find_pattern priority cond =
find_map priority (function `pattern p -> cond p | _ -> None)
@@ -69,26 +69,6 @@ val find_map : [`outermost | `innermost] -> (node -> 'a option) -> 'a sfun
(** Find all nodes satisfying some condition. *)
val find_all_map : (node -> 'a option) -> 'a list sfun
-val contains : Location.t -> int * int -> bool
-
-(** Return the innermost subtree whose locations contains a given
- character number interval [a, b[.
-
- Warning: most node kinds are missing ! *)
-val locate : [`outermost | `innermost] -> int * int -> node sfun
-
-(** Simliar to locate, but we return the first node along a path (in
- the sense of the given priority) for which the parameter function
- returns some result. *)
-val locate_map : [`outermost | `innermost] -> (node -> 'a option) ->
- int * int -> 'a sfun
-
-(*
-(** The same as locate, but with exceptions *)
-val locate_map_exn : [`outermost | `innermost] -> (node -> 'a) ->
- int * int -> 'a sfun
-*)
-
(** Finding only one sort of nodes: *)
val find_pattern :
@@ -36,6 +36,7 @@ let compile_file ast c_env =
Config.load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
Clflags.compile_only := true;
let env = initial_env () in
+ Env.record_path_environments ();
(* This is probably not needed *)
Typecore.reset_delayed_checks ();
let str, sg, _ =
@@ -61,7 +62,7 @@ let compile_file ast c_env =
Format.pp_print_flush err_formatter ();
failwith "Error while typing"
in
- str, sg, c_env
+ str, sg, c_env, Env.flush_paths ()
(** *)
let step msg =
@@ -79,9 +80,10 @@ let main ce =
(* Typing the completed file *)
step "Typing the the completed parsetree";
- let structure, sg, ce = compile_file se.ast ce in
+ let structure, sg, ce, lidents = compile_file se.ast ce in
Util.debugln "OK";
-
+
+ (* Get the type of the thing to complete *)
let pattern_env, pattern_type =
match se.comp with
| Match (AllCs | MissCs _) -> (* We should rather look at the pattern. *)
@@ -97,16 +99,10 @@ let main ce =
let place =
Expression_typing.locate_expansion_place structure
! Common_config.expand_loc
-(*
- p.Parsetree.ppat_loc
-*)
in
- let env, desc =
- Expression_typing.expansion_type place in
+ let env, desc = Expression_typing.expansion_type place in
env,
- {Types.desc = desc;
- level = 0; (* Meaningless ! *)
- id = 0}
+ {Types.desc = desc; level = 0; (* Meaningless ! *) id = 0}
| Try _ -> assert false
| Path {p_kd = Record (Faccess e)} ->
let match_exp =
@@ -25,7 +25,3 @@
val main : Interface.completion_infos -> unit
(** The main entry of the completion command *)
-
-val compile_file : Parsetree.structure ->
- Interface.completion_infos ->
- Typedtree.structure * Types.signature * Interface.completion_infos
Oops, something went wrong.

0 comments on commit 4c9ab9f

Please sign in to comment.