Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/experimental/garrigue/with-module-type.diff

531 lines
21 KiB
Diff
Raw Blame History

Index: typing/typemod.ml
===================================================================
--- typing/typemod.ml (revision 13947)
+++ typing/typemod.ml (working copy)
@@ -80,6 +80,9 @@
Typedtree.module_expr * Types.module_type) ref
= ref (fun env m -> assert false)
+let transl_modtype_fwd =
+ ref (fun env m -> (assert false : Typedtree.module_type))
+
(* Merge one "with" constraint in a signature *)
let rec add_rec_types env = function
@@ -191,6 +194,21 @@
merge env (extract_sig env loc mty) namelist None in
(path_concat id path, lid, tcstr),
Sig_module(id, Mty_signature newsg, rs) :: rem
+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
+ Sig_modtype(id, mtd') :: rem
+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ real_id := Some id;
+ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
+ rem
| (item :: rem, _, _) ->
let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
in
@@ -233,6 +251,12 @@
let (path, _) = Typetexp.find_module initial_env loc lid.txt in
let sub = Subst.add_module id path Subst.identity in
Subst.signature sub sg
+ | [s], Pwith_modtypesubst pmty ->
+ let id =
+ match !real_id with None -> assert false | Some id -> id in
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
+ Subst.signature sub sg
| _ ->
sg
in
@@ -649,6 +673,8 @@
check_recmod_typedecls env2 sdecls dcl2;
(dcl2, env2)
+let () = transl_modtype_fwd := transl_modtype
+
(* Try to convert a module expression to a module path. *)
exception Not_a_path
Index: typing/typedtreeMap.ml
===================================================================
--- typing/typedtreeMap.ml (revision 13947)
+++ typing/typedtreeMap.ml (working copy)
@@ -457,6 +457,9 @@
| Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
| Twith_module (path, lid) -> cstr
| Twith_modsubst (path, lid) -> cstr
+ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
+ | Twith_modtypesubst decl ->
+ Twith_modtypesubst (map_modtype_declaration decl)
in
Map.leave_with_constraint cstr
Index: typing/typedtree.ml
===================================================================
--- typing/typedtree.ml (revision 13947)
+++ typing/typedtree.ml (working copy)
@@ -255,6 +255,8 @@
| Twith_module of Path.t * Longident.t loc
| Twith_typesubst of type_declaration
| Twith_modsubst of Path.t * Longident.t loc
+ | Twith_modtype of modtype_declaration
+ | Twith_modtypesubst of modtype_declaration
and core_type =
(* mutable because of [Typeclass.declare_method] *)
Index: typing/typedtree.mli
===================================================================
--- typing/typedtree.mli (revision 13947)
+++ typing/typedtree.mli (working copy)
@@ -254,6 +254,8 @@
| Twith_module of Path.t * Longident.t loc
| Twith_typesubst of type_declaration
| Twith_modsubst of Path.t * Longident.t loc
+ | Twith_modtype of modtype_declaration
+ | Twith_modtypesubst of modtype_declaration
and core_type =
(* mutable because of [Typeclass.declare_method] *)
Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml (revision 13947)
+++ typing/includemod.ml (working copy)
@@ -346,10 +346,10 @@
(* Hide the context and substitution parameters to the outside world *)
-let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
-let type_declarations env id decl1 decl2 =
- type_declarations env [] Subst.identity id decl1 decl2
+let modtypes env = modtypes env [] Subst.identity
+let signatures env = signatures env [] Subst.identity
+let type_declarations env = type_declarations env [] Subst.identity
+let modtype_declarations env = modtype_infos env [] Subst.identity
(* Error report *)
Index: typing/typedtreeIter.ml
===================================================================
--- typing/typedtreeIter.ml (revision 13947)
+++ typing/typedtreeIter.ml (working copy)
@@ -408,6 +408,8 @@
| Twith_module _ -> ()
| Twith_typesubst decl -> iter_type_declaration decl
| Twith_modsubst _ -> ()
+ | Twith_modtype decl -> iter_modtype_declaration decl
+ | Twith_modtypesubst decl -> iter_modtype_declaration decl
end;
Iter.leave_with_constraint cstr;
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli (revision 13947)
+++ typing/includemod.mli (working copy)
@@ -21,6 +21,8 @@
val compunit: string -> signature -> string -> signature -> module_coercion
val type_declarations:
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
+val modtype_declarations:
+ Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit
type symptom =
Missing_field of Ident.t
Index: typing/printtyped.ml
===================================================================
--- typing/printtyped.ml (revision 13947)
+++ typing/printtyped.ml (working copy)
@@ -608,6 +608,12 @@
type_declaration (i+1) ppf td;
| Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
| Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
+ | Twith_modtype (td) ->
+ line i ppf "Pwith_modtype\n";
+ modtype_declaration (i+1) ppf td;
+ | Twith_modtypesubst (td) ->
+ line i ppf "Pwith_modtypesubst\n";
+ modtype_declaration (i+1) ppf td;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.mod_loc;
Index: experimental/garrigue/with-module-type.diffs
===================================================================
--- experimental/garrigue/with-module-type.diffs (revision 13947)
+++ experimental/garrigue/with-module-type.diffs (working copy)
@@ -1,95 +1,53 @@
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 12005)
-+++ parsing/parser.mly (working copy)
-@@ -1504,6 +1504,10 @@
- { ($2, Pwith_module $4) }
- | MODULE mod_longident COLONEQUAL mod_ext_longident
- { ($2, Pwith_modsubst $4) }
-+ | MODULE TYPE mod_longident EQUAL module_type
-+ { ($3, Pwith_modtype $5) }
-+ | MODULE TYPE mod_longident COLONEQUAL module_type
-+ { ($3, Pwith_modtypesubst $5) }
- ;
- with_type_binder:
- EQUAL { Public }
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 12005)
-+++ parsing/parsetree.mli (working copy)
-@@ -239,6 +239,8 @@
- | Pwith_module of Longident.t
- | Pwith_typesubst of type_declaration
- | Pwith_modsubst of Longident.t
-+ | Pwith_modtype of module_type
-+ | Pwith_modtypesubst of module_type
-
- (* Value expressions for the module language *)
-
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 12005)
-+++ parsing/printast.ml (working copy)
-@@ -575,6 +575,12 @@
- type_declaration (i+1) ppf td;
- | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
- | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
-+ | Pwith_modtype (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-+ | Pwith_modtypesubst (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-
- and module_expr i ppf x =
- line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
Index: typing/typemod.ml
===================================================================
---- typing/typemod.ml (revision 12005)
+--- typing/typemod.ml (revision 13947)
+++ typing/typemod.ml (working copy)
-@@ -74,6 +74,8 @@
- : (Env.t -> Parsetree.module_expr -> module_type) ref
+@@ -80,6 +80,9 @@
+ Typedtree.module_expr * Types.module_type) ref
= ref (fun env m -> assert false)
-+let transl_modtype_fwd = ref (fun env m -> assert false)
++let transl_modtype_fwd =
++ ref (fun env m -> (assert false : Typedtree.module_type))
+
(* Merge one "with" constraint in a signature *)
let rec add_rec_types env = function
-@@ -163,6 +165,19 @@
- ignore(Includemod.modtypes env newmty mty);
- real_id := Some id;
- make_next_first rs rem
-+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+@@ -191,6 +194,21 @@
+ merge env (extract_sig env loc mty) namelist None in
+ (path_concat id path, lid, tcstr),
+ Sig_module(id, Mty_signature newsg, rs) :: rem
++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Tmodtype_manifest mty in
++ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
-+ Tsig_modtype(id, mtd') :: rem
-+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
++ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
++ Sig_modtype(id, mtd') :: rem
++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Tmodtype_manifest mty in
++ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ real_id := Some id;
++ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
+ rem
- | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
- when Ident.name id = s ->
- let newsg = merge env (extract_sig env loc mty) namelist None in
-@@ -200,6 +215,12 @@
- let (path, _) = Typetexp.find_module initial_env loc lid in
+ | (item :: rem, _, _) ->
+ let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
+ in
+@@ -233,6 +251,12 @@
+ let (path, _) = Typetexp.find_module initial_env loc lid.txt in
let sub = Subst.add_module id path Subst.identity in
Subst.signature sub sg
+ | [s], Pwith_modtypesubst pmty ->
+ let id =
+ match !real_id with None -> assert false | Some id -> id in
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let sub = Subst.add_modtype id mty Subst.identity in
++ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
+ Subst.signature sub sg
| _ ->
- sg
- with Includemod.Error explanation ->
-@@ -499,6 +520,8 @@
+ sg
+ in
+@@ -649,6 +673,8 @@
check_recmod_typedecls env2 sdecls dcl2;
(dcl2, env2)
@@ -98,11 +56,51 @@
(* Try to convert a module expression to a module path. *)
exception Not_a_path
+Index: typing/typedtreeMap.ml
+===================================================================
+--- typing/typedtreeMap.ml (revision 13947)
++++ typing/typedtreeMap.ml (working copy)
+@@ -457,6 +457,9 @@
+ | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
+ | Twith_module (path, lid) -> cstr
+ | Twith_modsubst (path, lid) -> cstr
++ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
++ | Twith_modtypesubst decl ->
++ Twith_modtypesubst (map_modtype_declaration decl)
+ in
+ Map.leave_with_constraint cstr
+
+Index: typing/typedtree.ml
+===================================================================
+--- typing/typedtree.ml (revision 13947)
++++ typing/typedtree.ml (working copy)
+@@ -255,6 +255,8 @@
+ | Twith_module of Path.t * Longident.t loc
+ | Twith_typesubst of type_declaration
+ | Twith_modsubst of Path.t * Longident.t loc
++ | Twith_modtype of modtype_declaration
++ | Twith_modtypesubst of modtype_declaration
+
+ and core_type =
+ (* mutable because of [Typeclass.declare_method] *)
+Index: typing/typedtree.mli
+===================================================================
+--- typing/typedtree.mli (revision 13947)
++++ typing/typedtree.mli (working copy)
+@@ -254,6 +254,8 @@
+ | Twith_module of Path.t * Longident.t loc
+ | Twith_typesubst of type_declaration
+ | Twith_modsubst of Path.t * Longident.t loc
++ | Twith_modtype of modtype_declaration
++ | Twith_modtypesubst of modtype_declaration
+
+ and core_type =
+ (* mutable because of [Typeclass.declare_method] *)
Index: typing/includemod.ml
===================================================================
---- typing/includemod.ml (revision 12005)
+--- typing/includemod.ml (revision 13947)
+++ typing/includemod.ml (working copy)
-@@ -326,10 +326,10 @@
+@@ -346,10 +346,10 @@
(* Hide the context and substitution parameters to the outside world *)
@@ -117,11 +115,24 @@
(* Error report *)
+Index: typing/typedtreeIter.ml
+===================================================================
+--- typing/typedtreeIter.ml (revision 13947)
++++ typing/typedtreeIter.ml (working copy)
+@@ -408,6 +408,8 @@
+ | Twith_module _ -> ()
+ | Twith_typesubst decl -> iter_type_declaration decl
+ | Twith_modsubst _ -> ()
++ | Twith_modtype decl -> iter_modtype_declaration decl
++ | Twith_modtypesubst decl -> iter_modtype_declaration decl
+ end;
+ Iter.leave_with_constraint cstr;
+
Index: typing/includemod.mli
===================================================================
---- typing/includemod.mli (revision 12005)
+--- typing/includemod.mli (revision 13947)
+++ typing/includemod.mli (working copy)
-@@ -23,6 +23,8 @@
+@@ -21,6 +21,8 @@
val compunit: string -> signature -> string -> signature -> module_coercion
val type_declarations:
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
@@ -130,53 +141,20 @@
type symptom =
Missing_field of Ident.t
-Index: testsuite/tests/typing-modules/Test.ml.reference
+Index: typing/printtyped.ml
===================================================================
---- testsuite/tests/typing-modules/Test.ml.reference (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml.reference (working copy)
-@@ -6,4 +6,12 @@
- # type -'a t
- class type c = object method m : [ `A ] t end
- # module M : sig val v : (#c as 'a) -> 'a end
-+# module type S = sig module type T module F : functor (X : T) -> T end
-+# module type T0 = sig type t end
-+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
-+# module type S2 = sig module F : functor (X : T0) -> T0 end
-+# module type S3 =
-+ sig
-+ module F : functor (X : sig type t = int end) -> sig type t = int end
-+ end
- #
-Index: testsuite/tests/typing-modules/Test.ml.principal.reference
-===================================================================
---- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy)
-@@ -6,4 +6,12 @@
- # type -'a t
- class type c = object method m : [ `A ] t end
- # module M : sig val v : (#c as 'a) -> 'a end
-+# module type S = sig module type T module F : functor (X : T) -> T end
-+# module type T0 = sig type t end
-+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
-+# module type S2 = sig module F : functor (X : T0) -> T0 end
-+# module type S3 =
-+ sig
-+ module F : functor (X : sig type t = int end) -> sig type t = int end
-+ end
- #
-Index: testsuite/tests/typing-modules/Test.ml
-===================================================================
---- testsuite/tests/typing-modules/Test.ml (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml (working copy)
-@@ -9,3 +9,11 @@
- class type c = object method m : [ `A ] t end;;
- module M : sig val v : (#c as 'a) -> 'a end =
- struct let v x = ignore (x :> c); x end;;
-+
-+(* with module type *)
-+
-+module type S = sig module type T module F(X:T) : T end;;
-+module type T0 = sig type t end;;
-+module type S1 = S with module type T = T0;;
-+module type S2 = S with module type T := T0;;
-+module type S3 = S with module type T := sig type t = int end;;
+--- typing/printtyped.ml (revision 13947)
++++ typing/printtyped.ml (working copy)
+@@ -608,6 +608,12 @@
+ type_declaration (i+1) ppf td;
+ | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
+ | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
++ | Twith_modtype (td) ->
++ line i ppf "Pwith_modtype\n";
++ modtype_declaration (i+1) ppf td;
++ | Twith_modtypesubst (td) ->
++ line i ppf "Pwith_modtypesubst\n";
++ modtype_declaration (i+1) ppf td;
+
+ and module_expr i ppf x =
+ line i ppf "module_expr %a\n" fmt_location x.mod_loc;
Index: parsing/pprintast.ml
===================================================================
--- parsing/pprintast.ml (revision 13947)
+++ parsing/pprintast.ml (working copy)
@@ -847,18 +847,28 @@
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li self#type_declaration td
| Pwith_module (li2) ->
- pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
+ pp f "module %a =@ %a"
+ self#longident_loc li self#longident_loc li2
| Pwith_typesubst ({ptype_params=ls;_} as td) ->
pp f "type@ %a %a :=@ %a"
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li
self#type_declaration td
| Pwith_modsubst (li2) ->
- pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
+ pp f "module %a :=@ %a"
+ self#longident_loc li self#longident_loc li2
+ | Pwith_modtype mty ->
+ pp f "module type %a =@ %a"
+ self#longident_loc li self#module_type mty
+ | Pwith_modtypesubst mty ->
+ pp f "module type %a :=@ %a"
+ self#longident_loc li self#module_type mty
+ in
(match l with
| [] -> pp f "@[<hov2>%a@]" self#module_type mt
| _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
- self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
+ self#module_type mt
+ (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
| Pmty_typeof me ->
pp f "@[<hov2>module@ type@ of@ %a@]"
self#module_expr me
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 13947)
+++ parsing/parser.mly (working copy)
@@ -1506,6 +1506,10 @@
{ (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
| MODULE UIDENT COLONEQUAL mod_ext_longident
{ (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
+ | MODULE TYPE mty_longident EQUAL module_type
+ { (mkrhs $3 3, Pwith_modtype $5) }
+ | MODULE TYPE ident COLONEQUAL module_type
+ { (mkrhs (Lident $3) 3, Pwith_modtypesubst $5) }
;
with_type_binder:
EQUAL { Public }
Index: parsing/ast_mapper.ml
===================================================================
--- parsing/ast_mapper.ml (revision 13947)
+++ parsing/ast_mapper.ml (working copy)
@@ -164,6 +164,8 @@
| Pwith_module s -> Pwith_module (map_loc sub s)
| Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
| Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
+ | Pwith_modtype m -> Pwith_modtype (sub # module_type m)
+ | Pwith_modtypesubst m -> Pwith_modtypesubst (sub # module_type m)
let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
Index: parsing/parsetree.mli
===================================================================
--- parsing/parsetree.mli (revision 13947)
+++ parsing/parsetree.mli (working copy)
@@ -256,6 +256,8 @@
| Pwith_module of Longident.t loc
| Pwith_typesubst of type_declaration
| Pwith_modsubst of Longident.t loc
+ | Pwith_modtype of module_type
+ | Pwith_modtypesubst of module_type
(* Value expressions for the module language *)
Index: parsing/printast.ml
===================================================================
--- parsing/printast.ml (revision 13947)
+++ parsing/printast.ml (working copy)
@@ -590,6 +590,12 @@
type_declaration (i+1) ppf td;
| Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
| Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
+ | Pwith_modtype (mty) ->
+ line i ppf "Pwith_modtype\n";
+ module_type (i+1) ppf mty;
+ | Pwith_modtypesubst (mty) ->
+ line i ppf "Pwith_modtype\n";
+ module_type (i+1) ppf mty;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
Reference in New Issue View Git Blame Copy Permalink