Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Allow qualified reference to constructors (at least in bang-types). A regular variant type supports qualified constructors of the form: M.t.X. An extensible variant type supports qualified constructors of the form: M.t.N.X. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record3@15332 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-09-25 15:16:19 +00:00
parent 4aa48476d8
commit 5dac90505f
6 changed files with 153 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
parsing/longident.ml
View File

@ -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

2
parsing/longident.mli
View File

@ -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

12
parsing/parser.mly
View File

@ -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) }

35
typing/env.ml
View File

@ -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

102
typing/typetexp.ml
View File

@ -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

3
typing/typetexp.mli
View File

@ -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