diff options
| -rw-r--r-- | parsing/longident.ml | 23 | ||||
| -rw-r--r-- | parsing/longident.mli | 2 | ||||
| -rw-r--r-- | parsing/parser.mly | 12 | ||||
| -rw-r--r-- | typing/env.ml | 35 | ||||
| -rw-r--r-- | typing/typetexp.ml | 102 | ||||
| -rw-r--r-- | typing/typetexp.mli | 3 |
6 files changed, 153 insertions, 24 deletions
diff --git a/parsing/longident.ml b/parsing/longident.ml index 706881af3..bb7778725 100644 --- a/parsing/longident.ml +++ b/parsing/longident.ml @@ -39,3 +39,26 @@ let parse s = [] -> Lident "" (* should not happen, but don't put assert false so as not to crash the toplevel (see Genprintval) *) | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl + + + +let rec concat t = function + | Lident s -> Ldot (t, s) + | Ldot (a, s) -> Ldot (concat t a, s) + | _ -> assert false + +let is_lident s = + match s.[0] with + | 'a'..'z' | '_' -> true + | _ -> false + +let rec split_lident = function + | Ldot(t, s) when is_lident (last t) -> + Some (t, Lident s) + | Ldot(Ldot (t1, s1) as t, s) -> + begin match split_lident t with + | None -> None + | Some (x, y) -> Some (x, Ldot(y, s)) + end + | _ -> + None diff --git a/parsing/longident.mli b/parsing/longident.mli index 9e7958550..132e46901 100644 --- a/parsing/longident.mli +++ b/parsing/longident.mli @@ -20,3 +20,5 @@ type t = val flatten: t -> string list val last: t -> string val parse: string -> t +val concat: t -> t -> t +val split_lident: t -> (t * t) option diff --git a/parsing/parser.mly b/parsing/parser.mly index f723e5aeb..3da50bd15 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1995,12 +1995,22 @@ val_longident: | mod_longident DOT val_ident { Ldot($1, $3) } ; constr_longident: - mod_longident %prec below_DOT { $1 } + constr_longident2 %prec below_DOT { $1 } | LBRACKET RBRACKET { Lident "[]" } | LPAREN RPAREN { Lident "()" } | FALSE { Lident "false" } | TRUE { Lident "true" } ; +constr_longident2: + mod_longident %prec below_DOT { $1 } + | mod_longident DOT LIDENT DOT mod_longident %prec below_DOT { + Longident.concat (Ldot($1, $3)) $5 + } + + | LIDENT DOT mod_longident %prec below_DOT { + Longident.concat (Lident $1) $3 + } +; label_longident: LIDENT { Lident $1 } | mod_longident DOT LIDENT { Ldot($1, $3) } diff --git a/typing/env.ml b/typing/env.ml index 5b89b0bd9..fe1eee1cd 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -860,6 +860,41 @@ let lookup_constructor lid env = use (); desc +(* +let lookup_constructor lid env = + match Longident.split_lident lid with + | None -> lookup_constructor lid env + | Some (ty_id, cstr_id) -> + let (ty_path, ty_decl) = lookup_type ty_id env in + match ty_decl.type_kind with + | Type_variant _ -> + let (cstrs, _, _) = find_type_descrs ty_path env in + begin match cstr_id with + | Lident s -> + List.find (fun c -> c.cstr_name = s) cstrs + | _ -> + failwith "Type %s is a regular variant type: constructor name must be local" + end + | Type_open -> + let cstrs = lookup_all_constructors cstr_id env in + let (c, use) = + try + List.find + (fun (c, _) -> + match (repr c.cstr_res).desc with + | Tconstr(p, _, _) -> Path.same ty_path p + | _ -> false + ) + cstrs + with Not_found -> + failwith "No constructor with qualified name %s found in type %s" + in + use (); + c + | _ -> + failwith "Type %s is not a variant type" +*) + let is_lident = function Lident _ -> true | _ -> false diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 739c18c1f..6929614ff 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -49,9 +49,12 @@ type error = | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t + | Unbound_constructor_in_type of Longident.t * Longident.t | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module | Access_functor_as_structure of Longident.t + | Constructor_must_be_local of Longident.t + | Not_a_variant_type of Longident.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -225,29 +228,6 @@ let find_type env loc lid = let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) -let find_type env loc lid = - let s = Longident.last lid in - match s.[0] with - | 'A'..'Z' -> - let cstr = find_constructor env loc lid in - if not cstr.cstr_inlined then - failwith (Printf.sprintf - "Constructor %s does not have an inline record argument" - s - ); - begin match cstr.cstr_args with - | [{desc=Tconstr(path, _, _)}] -> - let decl = - try Env.find_type path env - with Not_found -> - assert false - in - (path, decl) - | _ -> assert false - end - | _ -> - find_type env loc lid - let find_all_constructors = find_component Env.lookup_all_constructors (fun lid -> Unbound_constructor lid) @@ -306,6 +286,70 @@ let unbound_label_error env lid = narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> Unbound_label lid) +let find_constructor_in_type env loc ty_id cstr_id = + let err e = raise (Error (loc, env, e)) in + let (ty_path, ty_decl) = find_type env loc ty_id in + match ty_decl.type_kind with + | Type_variant _ -> + let (cstrs, _, _) = + try Env.find_type_descrs ty_path env + with Not_found -> assert false + in + begin match cstr_id with + | Longident.Lident s -> + begin try List.find (fun c -> c.cstr_name = s) cstrs + with Not_found -> + err (Unbound_constructor_in_type (cstr_id, ty_id)) + end + | _ -> + err (Constructor_must_be_local ty_id) + end + | Type_open -> + let cstrs = find_all_constructors env loc cstr_id in + let has_type (c, _) = + match (repr c.cstr_res).desc with + | Tconstr(p, _, _) -> Path.same ty_path p + | _ -> false + in + let (c, use) = + try List.find has_type cstrs + with Not_found -> + err (Unbound_constructor_in_type (cstr_id, ty_id)) + in + use (); + c + | _ -> + err (Not_a_variant_type ty_id) + +let find_constructor env loc lid = + match Longident.split_lident lid with + | None -> find_constructor env loc lid + | Some (ty_id, cstr_id) -> find_constructor_in_type env loc ty_id cstr_id + +let find_type env loc lid = + let s = Longident.last lid in + match s.[0] with + | 'A'..'Z' -> + let cstr = find_constructor env loc lid in + if not cstr.cstr_inlined then + failwith (Printf.sprintf + "Constructor %s does not have an inline record argument" + s + ); + begin match cstr.cstr_args with + | [{desc=Tconstr(path, _, _)}] -> + let decl = + try Env.find_type path env + with Not_found -> + assert false + in + (path, decl) + | _ -> assert false + end + | _ -> + find_type env loc lid + + (* Support for first-class modules. *) let transl_modtype_longident = ref (fun _ -> assert false) @@ -1021,12 +1065,24 @@ let report_error env ppf = function | Unbound_cltype lid -> fprintf ppf "Unbound class type %a" longident lid; spellcheck ppf Env.fold_cltypes env lid; + | Unbound_constructor_in_type (c_lid, t_lid) -> + fprintf ppf "Unbound constructor %a in type %a" longident c_lid + longident t_lid | Ill_typed_functor_application lid -> fprintf ppf "Ill-typed functor application %a" longident lid | Illegal_reference_to_recursive_module -> fprintf ppf "Illegal recursive module reference" | Access_functor_as_structure lid -> fprintf ppf "The module %a is a functor, not a structure" longident lid + | Constructor_must_be_local lid -> + fprintf ppf + "The type %a is a regular variant type (not an extensible one);@ " + longident lid; + fprintf ppf "qualified constructors are not allowed" + | Not_a_variant_type lid -> + fprintf ppf + "The type %a is not a variant type" + longident lid let () = Location.register_error_of_exn diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 7bff403f0..a1ae0d694 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -61,9 +61,12 @@ type error = | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t + | Unbound_constructor_in_type of Longident.t * Longident.t | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module | Access_functor_as_structure of Longident.t + | Constructor_must_be_local of Longident.t + | Not_a_variant_type of Longident.t exception Error of Location.t * Env.t * error |