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

merge generative functors 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14365 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2013-12-17 03:52:50 +00:00
parent 024c8ad498
commit cfa350c31a
43 changed files with 269 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -13,9 +13,13 @@ Type system:
* Keep typing of pattern cases independent in principal mode
(i.e. information from previous cases is no longer used when typing
patterns; cf. PR6235' in typing-warnings/records.ml)
- Allow opening a first-class module or applying a generative functor
in the body of a generative functor. Allow it also in the body of
an applicative functor if no types are created
Language features:
- Attributes and extension nodes
- Generative functors
Compilers:
- Experimental native code generator for AArch64 (ARM 64 bits)

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

17
ocamldoc/odoc_ast.ml
View File

@ -1606,18 +1606,25 @@ module Analyser =
| (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) ->
let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
let loc = match pmodule_type with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_name = Name.from_ident ident in
let mp_kind = Sig.analyse_module_type_kind env
current_module_name pmodule_type mtyp.mty_type
let mp_kind =
match pmodule_type, mtyp with
Some pmty, Some mty ->
Sig.analyse_module_type_kind env current_module_name pmty
mty.mty_type
| _ -> Module_type_struct []
in
let param =
{
mp_name = mp_name ;
mp_type = Odoc_env.subst_module_type env mtyp.mty_type ;
mp_type = Misc.may_map
(fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ;
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
}

2
ocamldoc/odoc_env.ml
View File

@ -223,7 +223,7 @@ let subst_module_type env t =
| Types.Mty_signature _ ->
t
| Types.Mty_functor (id, mt1, mt2) ->
Types.Mty_functor (id, iter mt1, iter mt2)
Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2)
in
iter t

3
ocamldoc/odoc_html.ml
View File

@ -1384,7 +1384,8 @@ class html =
(** Print html code to display the type of a module parameter.. *)
method html_of_module_parameter_type b m_name p =
self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type
match p.mp_type with None -> bs b "<code>()</code>"
| Some mty -> self#html_of_module_type b m_name ~code: p.mp_type_code mty
(** Generate a file containing the module type in the given file name. *)
method output_module_type in_title file mtyp =

2
ocamldoc/odoc_info.mli
View File

@ -434,7 +434,7 @@ module Module :
and module_parameter = Odoc_module.module_parameter = {
mp_name : string ; (** the name *)
mp_type : Types.module_type ; (** the type *)
mp_type : Types.module_type option ; (** the type *)
mp_type_code : string ; (** the original code *)
mp_kind : module_type_kind ; (** the way the parameter was built *)
}

2
ocamldoc/odoc_man.ml
View File

@ -637,7 +637,7 @@ class man =
(fun (p, desc_opt) ->
bs b ".sp\n";
bs b ("\""^p.mp_name^"\"\n");
self#man_of_module_type b m_name p.mp_type;
Misc.may (self#man_of_module_type b m_name) p.mp_type;
bs b "\n";
(
match desc_opt with

2
ocamldoc/odoc_module.ml
View File

@ -46,7 +46,7 @@ and module_alias = {
and module_parameter = {
mp_name : string ; (** the name *)
mp_type : Types.module_type ; (** the type *)
mp_type : Types.module_type option ; (** the type *)
mp_type_code : string ; (** the original code *)
mp_kind : module_type_kind ; (** the way the parameter was built *)
}

2
ocamldoc/odoc_print.ml
View File

@ -62,7 +62,7 @@ let simpl_module_type ?code t =
| Some s -> raise (Use_code s)
)
| Types.Mty_functor (id, mt1, mt2) ->
Types.Mty_functor (id, iter mt1, iter mt2)
Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2)
in
iter t

33
ocamldoc/odoc_sig.ml
View File

@ -1076,19 +1076,26 @@ module Analyser =
| Parsetree.Pmty_functor (_, pmodule_type2, module_type2) ->
(
let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
let loc = match pmodule_type2 with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) ->
let mp_kind = analyse_module_type_kind env
current_module_name pmodule_type2 param_module_type
let mp_kind =
match pmodule_type2, param_module_type with
Some pmty, Some mty ->
analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct []
in
let param =
{
mp_name = Name.from_ident ident ;
mp_type = Odoc_env.subst_module_type env param_module_type ;
mp_type =
Misc.may_map (Odoc_env.subst_module_type env)
param_module_type;
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
}
@ -1155,17 +1162,23 @@ module Analyser =
(
match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) ->
let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
let loc = match pmodule_type2 with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_kind = analyse_module_type_kind env
current_module_name pmodule_type2 param_module_type
let mp_kind =
match pmodule_type2, param_module_type with
Some pmty, Some mty ->
analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct []
in
let param =
{
mp_name = Name.from_ident ident ;
mp_type = Odoc_env.subst_module_type env param_module_type ;
mp_type = Misc.may_map
(Odoc_env.subst_module_type env) param_module_type ;
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
}

7
ocamldoc/odoc_to_text.ml
View File

@ -428,8 +428,11 @@ class virtual to_text =
List
(List.map
(fun (p, desc_opt) ->
[Code (p.mp_name^" : ")] @
(self#text_of_module_type p.mp_type) @
begin match p.mp_type with None -> [Raw ""]
| Some mty ->
[Code (p.mp_name^" : ")] @
(self#text_of_module_type mty)
end @
(match desc_opt with
None -> []
| Some t -> (Raw " ") :: t)

6
parsing/ast_helper.mli
View File

@ -145,7 +145,8 @@ module Mty:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_type -> module_type
val functor_: ?loc:loc -> ?attrs:attrs ->
str -> module_type option -> module_type -> module_type
val with_: ?loc:loc -> ?attrs:attrs -> module_type -> with_constraint list -> module_type
val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
@ -159,7 +160,8 @@ module Mod:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_expr -> module_expr
val functor_: ?loc:loc -> ?attrs:attrs ->
str -> module_type option -> module_expr -> module_expr
val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr
val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr
val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr

6
parsing/ast_mapper.ml
View File

@ -161,7 +161,8 @@ module MT = struct
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
| Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
| Pmty_functor (s, mt1, mt2) ->
functor_ ~loc ~attrs (map_loc sub s) (sub.module_type sub mt1)
functor_ ~loc ~attrs (map_loc sub s)
(Misc.may_map (sub.module_type sub) mt1)
(sub.module_type sub mt2)
| Pmty_with (mt, l) ->
with_ ~loc ~attrs (sub.module_type sub mt)
@ -213,7 +214,8 @@ module M = struct
| Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
| Pmod_functor (arg, arg_ty, body) ->
functor_ ~loc ~attrs (map_loc sub arg) (sub.module_type sub arg_ty)
functor_ ~loc ~attrs (map_loc sub arg)
(Misc.may_map (sub.module_type sub) arg_ty)
(sub.module_expr sub body)
| Pmod_apply (m1, m2) ->
apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)

19
parsing/parser.mly
View File

@ -541,9 +541,13 @@ module_expr:
| STRUCT structure error
{ unclosed "struct" 1 "end" 3 }
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
{ mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
{ mkmod(Pmod_functor(mkrhs $3 3, Some $5, $8)) }
| FUNCTOR LPAREN RPAREN MINUSGREATER module_expr
{ mkmod(Pmod_functor(mkrhs "()" 3, None, $5)) }
| module_expr LPAREN module_expr RPAREN
{ mkmod(Pmod_apply($1, $3)) }
| module_expr LPAREN RPAREN
{ mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
| module_expr LPAREN module_expr error
{ unclosed "(" 2 ")" 4 }
| LPAREN module_expr COLON module_type RPAREN
@ -640,7 +644,9 @@ module_binding_body:
| COLON module_type EQUAL module_expr
{ mkmod(Pmod_constraint($4, $2)) }
| LPAREN UIDENT COLON module_type RPAREN module_binding_body
{ mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
{ mkmod(Pmod_functor(mkrhs $2 2, Some $4, $6)) }
| LPAREN RPAREN module_binding_body
{ mkmod(Pmod_functor(mkrhs "()" 1, None, $3)) }
;
module_bindings:
module_binding { [$1] }
@ -662,7 +668,10 @@ module_type:
{ unclosed "sig" 1 "end" 3 }
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
%prec below_WITH
{ mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
{ mkmty(Pmty_functor(mkrhs $3 3, Some $5, $8)) }
| FUNCTOR LPAREN RPAREN MINUSGREATER module_type
%prec below_WITH
{ mkmty(Pmty_functor(mkrhs "()" 2, None, $5)) }
| module_type WITH with_constraints
{ mkmty(Pmty_with($1, List.rev $3)) }
| MODULE TYPE OF module_expr %prec below_LBRACKETAT
@ -724,7 +733,9 @@ module_declaration:
COLON module_type
{ $2 }
| LPAREN UIDENT COLON module_type RPAREN module_declaration
{ mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
{ mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) }
| LPAREN RPAREN module_declaration
{ mkmty(Pmty_functor(mkrhs "()" 1, None, $3)) }
;
module_rec_declarations:
module_rec_declaration { [$1] }

4
parsing/parsetree.mli
View File

@ -543,7 +543,7 @@ and module_type_desc =
(* S *)
| Pmty_signature of signature
(* sig ... end *)
| Pmty_functor of string loc * module_type * module_type
| Pmty_functor of string loc * module_type option * module_type
(* functor(X : MT1) -> MT2 *)
| Pmty_with of module_type * with_constraint list
(* MT with ... *)
@ -637,7 +637,7 @@ and module_expr_desc =
(* X *)
| Pmod_structure of structure
(* struct ... end *)
| Pmod_functor of string loc * module_type * module_expr
| Pmod_functor of string loc * module_type option * module_expr
(* functor(X : MT1) -> ME *)
| Pmod_apply of module_expr * module_expr
(* ME1(ME2) *)

11
parsing/pprintast.ml
View File

@ -834,7 +834,9 @@ class printer ()= object(self:'self)
| Pmty_signature (s) ->
pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
(self#list self#signature_item ) s (* FIXME wrong indentation*)
| Pmty_functor (s, mt1, mt2) ->
| Pmty_functor (_, None, mt2) ->
pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
| Pmty_functor (s, Some mt1, mt2) ->
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
self#module_type mt1 self#module_type mt2
| Pmty_with (mt, l) ->
@ -940,7 +942,9 @@ class printer ()= object(self:'self)
self#module_type mt
| Pmod_ident (li) ->
pp f "%a" self#longident_loc li;
| Pmod_functor (s, mt, me) ->
| Pmod_functor (_, None, me) ->
pp f "functor ()@;->@;%a" self#module_expr me
| Pmod_functor (s, Some mt, me) ->
pp f "functor@ (%s@ :@ %a)@;->@;%a"
s.txt self#module_type mt self#module_expr me
| Pmod_apply (me1, me2) ->
@ -1025,7 +1029,8 @@ class printer ()= object(self:'self)
| Pstr_module x ->
let rec module_helper me = match me.pmod_desc with
| Pmod_functor(s,mt,me) ->
pp f "(%s:%a)" s.txt self#module_type mt ;
if mt = None then pp f "()"
else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt;
module_helper me
| _ -> me in
pp f "@[<hov2>module %s%a@]"

4
parsing/printast.ml
View File

@ -577,7 +577,7 @@ and module_type i ppf x =
signature i ppf s;
| Pmty_functor (s, mt1, mt2) ->
line i ppf "Pmty_functor %a\n" fmt_string_loc s;
module_type i ppf mt1;
Misc.may (module_type i ppf) mt1;
module_type i ppf mt2;
| Pmty_with (mt, l) ->
line i ppf "Pmty_with\n";
@ -671,7 +671,7 @@ and module_expr i ppf x =
structure i ppf s;
| Pmod_functor (s, mt, me) ->
line i ppf "Pmod_functor %a\n" fmt_string_loc s;
module_type i ppf mt;
Misc.may (module_type i ppf) mt;
module_expr i ppf me;
| Pmod_apply (me1, me2) ->
line i ppf "Pmod_apply\n";

26
testsuite/tests/typing-modules/generative.ml Normal file
View File

@ -0,0 +1,26 @@
(* Using generative functors *)
(* Without type *)
module type S = sig val x : int end;;
let v = (module struct let x = 3 end : S);;
module F() = (val v);; (* ok *)
module G (X : sig end) : S = F ();; (* ok *)
module H (X : sig end) = (val v);; (* ok *)
(* With type *)
module type S = sig type t val x : t end;;
let v = (module struct type t = int let x = 3 end : S);;
module F() = (val v);; (* ok *)
module G (X : sig end) : S = F ();; (* fail *)
module H() = F();; (* ok *)
(* Alias *)
module U = struct end;;
module M = F(struct end);; (* ok *)
module M = F(U);; (* fail *)
(* Cannot coerce between applicative and generative *)
module F1 (X : sig end) = struct end;;
module F2 : functor () -> sig end = F1;; (* fail *)
module F3 () = struct end;;
module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)

40
testsuite/tests/typing-modules/generative.ml.reference Normal file
View File

@ -0,0 +1,40 @@
# module type S = sig val x : int end
# val v : (module S) = <module>
# module F : functor () -> S
# module G : functor (X : sig end) -> S
# module H : functor (X : sig end) -> S
# module type S = sig type t val x : t end
# val v : (module S) = <module>
# module F : functor () -> S
# Characters 29-33:
module G (X : sig end) : S = F ();; (* fail *)
^^^^
Error: This expression creates fresh types.
It is not allowed inside applicative functors.
# module H : functor () -> S
# module U : sig end
# module M : S
# Characters 11-12:
module M = F(U);; (* fail *)
^
Error: This is a generative functor. It can only be applied to ()
# module F1 : functor (X : sig end) -> sig end
# Characters 36-38:
module F2 : functor () -> sig end = F1;; (* fail *)
^^
Error: Signature mismatch:
Modules do not match:
functor (X : sig end) -> sig end
is not included in
functor () -> sig end
# module F3 : functor () -> sig end
# Characters 47-49:
module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
^^
Error: Signature mismatch:
Modules do not match:
functor () -> sig end
is not included in
functor (X : sig end) -> sig end
#

5
tools/depend.ml
View File

@ -201,7 +201,8 @@ and add_modtype bv mty =
Pmty_ident l -> add bv l
| Pmty_signature s -> add_signature bv s
| Pmty_functor(id, mty1, mty2) ->
add_modtype bv mty1; add_modtype (StringSet.add id.txt bv) mty2
Misc.may (add_modtype bv) mty1;
add_modtype (StringSet.add id.txt bv) mty2
| Pmty_with(mty, cstrl) ->
add_modtype bv mty;
List.iter
@ -258,7 +259,7 @@ and add_module bv modl =
Pmod_ident l -> addmodule bv l
| Pmod_structure s -> ignore (add_structure bv s)
| Pmod_functor(id, mty, modl) ->
add_modtype bv mty;
Misc.may (add_modtype bv) mty;
add_module (StringSet.add id.txt bv) modl
| Pmod_apply(mod1, mod2) ->
add_module bv mod1; add_module bv mod2

4
tools/tast_iter.ml
View File

@ -193,7 +193,7 @@ let module_type sub mty =
| Tmty_ident (_path, _) -> ()
| Tmty_signature sg -> sub # signature sg
| Tmty_functor (_id, _, mtype1, mtype2) ->
sub # module_type mtype1; sub # module_type mtype2
Misc.may (sub # module_type) mtype1; sub # module_type mtype2
| Tmty_with (mtype, list) ->
sub # module_type mtype;
List.iter (fun (_, _, withc) -> sub # with_constraint withc) list
@ -212,7 +212,7 @@ let module_expr sub mexpr =
| Tmod_ident (_p, _) -> ()
| Tmod_structure st -> sub # structure st
| Tmod_functor (_id, _, mtype, mexpr) ->
sub # module_type mtype;
Misc.may (sub # module_type) mtype;
sub # module_expr mexpr
| Tmod_apply (mexp1, mexp2, _) ->
sub # module_expr mexp1;

4
tools/untypeast.ml
View File

@ -376,7 +376,7 @@ and untype_module_type mty =
Tmty_ident (_path, lid) -> Pmty_ident (lid)
| Tmty_signature sg -> Pmty_signature (untype_signature sg)
| Tmty_functor (_id, name, mtype1, mtype2) ->
Pmty_functor (name, untype_module_type mtype1,
Pmty_functor (name, Misc.may_map untype_module_type mtype1,
untype_module_type mtype2)
| Tmty_with (mtype, list) ->
Pmty_with (untype_module_type mtype,
@ -405,7 +405,7 @@ and untype_module_expr mexpr =
Tmod_ident (_p, lid) -> Pmod_ident (lid)
| Tmod_structure st -> Pmod_structure (untype_structure st)
| Tmod_functor (_id, name, mtype, mexpr) ->
Pmod_functor (name, untype_module_type mtype,
Pmod_functor (name, Misc.may_map untype_module_type mtype,
untype_module_expr mexpr)
| Tmod_apply (mexp1, mexp2, _) ->
Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2)

3
typing/btype.ml
View File

@ -56,6 +56,9 @@ let is_Tvar = function {desc=Tvar _} -> true | _ -> false
let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
let dummy_method = "*dummy method*"
let default_mty = function
Some mty -> mty
| None -> Mty_signature []
(**** Representative of a type ****)

3
typing/btype.mli
View File

@ -39,9 +39,12 @@ val newmarkedgenvar: unit -> type_expr
(* Return a fresh marked generic variable *)
*)
(**** Types ****)
val is_Tvar: type_expr -> bool
val is_Tunivar: type_expr -> bool
val dummy_method: label
val default_mty: module_type option -> module_type
val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *)

8
typing/env.ml
View File

@ -201,7 +201,7 @@ and structure_components = {
and functor_components = {
fcomp_param: Ident.t; (* Formal parameter *)
fcomp_arg: module_type; (* Argument signature *)
fcomp_arg: module_type option; (* Argument signature *)
fcomp_res: module_type; (* Result signature *)
fcomp_env: t; (* Environment in which the result signature makes sense *)
fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *)
@ -522,7 +522,7 @@ let rec lookup_module_descr lid env =
let (p2, {md_type=mty2}) = lookup_module l2 env in
begin match EnvLazy.force !components_of_module_maker' desc1 with
Functor_comps f ->
!check_modtype_inclusion env mty2 p2 f.fcomp_arg;
Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
(Papply(p1, p2), !components_of_functor_appl' f p1 p2)
| Structure_comps c ->
raise Not_found
@ -562,7 +562,7 @@ and lookup_module lid env : Path.t * module_declaration =
let p = Papply(p1, p2) in
begin match EnvLazy.force !components_of_module_maker' desc1 with
Functor_comps f ->
!check_modtype_inclusion env mty2 p2 f.fcomp_arg;
Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
let mty =
Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
f.fcomp_res in
@ -1120,7 +1120,7 @@ and components_of_module_maker (env, sub, path, mty) =
fcomp_param = param;
(* fcomp_arg must be prefixed eagerly, because it is interpreted
in the outer environment, not in env *)
fcomp_arg = Subst.modtype sub ty_arg;
fcomp_arg = may_map (Subst.modtype sub) ty_arg;
(* fcomp_res is prefixed lazily, because it is interpreted in env *)
fcomp_res = ty_res;
fcomp_env = env;

8
typing/includemod.ml
View File

@ -168,7 +168,13 @@ and try_modtypes env cxt subst mty1 mty2 =
try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
| (Mty_signature sig1, Mty_signature sig2) ->
signatures env cxt subst sig1 sig2
| (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
| (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) ->
begin match modtypes env (Body param1::cxt) subst res1 res2 with
Tcoerce_none -> Tcoerce_none
| cc -> Tcoerce_functor (Tcoerce_none, cc)
end
| (Mty_functor(param1, Some arg1, res1),
Mty_functor(param2, Some arg2, res2)) ->
let arg2' = Subst.modtype subst arg2 in
let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
let cc_res =

39
typing/mtype.ml
View File

@ -34,7 +34,8 @@ let rec strengthen env mty p =
match scrape env mty with
Mty_signature sg ->
Mty_signature(strengthen_sig env sg p)
| Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
| Mty_functor(param, arg, res)
when !Clflags.applicative_functors && Ident.name param <> "*" ->
Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
| mty ->
mty
@ -105,8 +106,9 @@ let nondep_supertype env mid mty =
| Mty_functor(param, arg, res) ->
let var_inv =
match va with Co -> Contra | Contra -> Co | Strict -> Strict in
Mty_functor(param, nondep_mty env var_inv arg,
nondep_mty (Env.add_module param arg env) va res)
Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg,
nondep_mty
(Env.add_module param (Btype.default_mty arg) env) va res)
and nondep_sig env va = function
[] -> []
@ -228,3 +230,34 @@ and no_code_needed_sig env sg =
no_code_needed_sig env rem
| (Sig_exception _ | Sig_class _) :: rem ->
false
(* Check whether a module type may return types *)
let rec contains_type env = function
Mty_ident path ->
(try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type
with Not_found -> raise Exit)
| Mty_signature sg ->
contains_type_sig env sg
| Mty_functor (_, _, body) ->
contains_type env body
and contains_type_sig env = List.iter (contains_type_item env)
and contains_type_item env = function
Sig_type (_,({type_manifest = None} |
{type_kind = Type_abstract; type_private = Private}),_)
| Sig_modtype _ ->
raise Exit
| Sig_module (_, {md_type = mty}, _) ->
contains_type env mty
| Sig_value _
| Sig_type _
| Sig_exception _
| Sig_class _
| Sig_class_type _ ->
()
let contains_type env mty =
try contains_type env mty; false with Exit -> true

1
typing/mtype.mli
View File

@ -36,3 +36,4 @@ val no_code_needed_sig: Env.t -> signature -> bool
val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
val contains_type: Env.t -> module_type -> bool

4
typing/oprint.ml
View File

@ -344,7 +344,9 @@ let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
let rec print_out_module_type ppf =
function
Omty_abstract -> ()
| Omty_functor (name, mty_arg, mty_res) ->
| Omty_functor (_, None, mty_res) ->
fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
| Omty_functor (name, Some mty_arg, mty_res) ->
fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
print_out_module_type mty_arg print_out_module_type mty_res
| Omty_ident id -> fprintf ppf "%a" print_ident id

2
typing/outcometree.mli
View File

@ -75,7 +75,7 @@ and out_class_sig_item =
type out_module_type =
| Omty_abstract
| Omty_functor of string * out_module_type * out_module_type
| Omty_functor of string * out_module_type option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
and out_sig_item =

9
typing/printtyp.ml
View File

@ -1116,9 +1116,12 @@ let rec tree_of_modtype = function
| Mty_signature sg ->
Omty_signature (tree_of_signature sg)
| Mty_functor(param, ty_arg, ty_res) ->
Omty_functor
(Ident.name param, tree_of_modtype ty_arg,
wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res)
let res =
match ty_arg with None -> tree_of_modtype ty_res
| Some mty ->
wrap_env (Env.add_module param mty) tree_of_modtype ty_res
in
Omty_functor (Ident.name param, may_map tree_of_modtype ty_arg, res)
and tree_of_signature sg =
wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg

4
typing/printtyped.ml
View File

@ -562,7 +562,7 @@ and module_type i ppf x =
signature i ppf s;
| Tmty_functor (s, _, mt1, mt2) ->
line i ppf "Pmty_functor \"%a\"\n" fmt_ident s;
module_type i ppf mt1;
Misc.may (module_type i ppf) mt1;
module_type i ppf mt2;
| Tmty_with (mt, l) ->
line i ppf "Pmty_with\n";
@ -651,7 +651,7 @@ and module_expr i ppf x =
structure i ppf s;
| Tmod_functor (s, _, mt, me) ->
line i ppf "Pmod_functor \"%a\"\n" fmt_ident s;
module_type i ppf mt;
Misc.may (module_type i ppf) mt;
module_expr i ppf me;
| Tmod_apply (me1, me2, _) ->
line i ppf "Pmod_apply\n";

4
typing/subst.ml
View File

@ -327,8 +327,8 @@ let rec modtype s = function
Mty_signature(signature s sg)
| Mty_functor(id, arg, res) ->
let id' = Ident.rename id in
Mty_functor(id', modtype s arg,
modtype (add_module id (Pident id') s) res)
Mty_functor(id', may_map (modtype s) arg,
modtype (add_module id (Pident id') s) res)
and signature s sg =
(* Components of signature may be mutually recursive (e.g. type declarations

4
typing/typedtree.ml
View File

@ -187,7 +187,7 @@ and module_type_constraint =
and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure
| Tmod_functor of Ident.t * string loc * module_type * module_expr
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
| Tmod_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion
@ -253,7 +253,7 @@ and module_type =
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature
| Tmty_functor of Ident.t * string loc * module_type * module_type
| Tmty_functor of Ident.t * string loc * module_type option * module_type
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr

4
typing/typedtree.mli
View File

@ -186,7 +186,7 @@ and module_type_constraint =
and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure
| Tmod_functor of Ident.t * string loc * module_type * module_expr
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
| Tmod_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion
@ -252,7 +252,7 @@ and module_type =
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature
| Tmty_functor of Ident.t * string loc * module_type * module_type
| Tmty_functor of Ident.t * string loc * module_type option * module_type
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr

4
typing/typedtreeIter.ml
View File

@ -383,7 +383,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
Tmty_ident (path, _) -> ()
| Tmty_signature sg -> iter_signature sg
| Tmty_functor (id, _, mtype1, mtype2) ->
iter_module_type mtype1; iter_module_type mtype2
Misc.may iter_module_type mtype1; iter_module_type mtype2
| Tmty_with (mtype, list) ->
iter_module_type mtype;
List.iter (fun (path, _, withc) ->
@ -412,7 +412,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
Tmod_ident (p, _) -> ()
| Tmod_structure st -> iter_structure st
| Tmod_functor (id, _, mtype, mexpr) ->
iter_module_type mtype;
Misc.may iter_module_type mtype;
iter_module_expr mexpr
| Tmod_apply (mexp1, mexp2, _) ->
iter_module_expr mexp1;

4
typing/typedtreeMap.ml
View File

@ -426,7 +426,7 @@ module MakeMap(Map : MapArgument) = struct
Tmty_ident (path, lid) -> mty.mty_desc
| Tmty_signature sg -> Tmty_signature (map_signature sg)
| Tmty_functor (id, name, mtype1, mtype2) ->
Tmty_functor (id, name, map_module_type mtype1,
Tmty_functor (id, name, Misc.may_map map_module_type mtype1,
map_module_type mtype2)
| Tmty_with (mtype, list) ->
Tmty_with (map_module_type mtype,
@ -456,7 +456,7 @@ module MakeMap(Map : MapArgument) = struct
Tmod_ident (p, lid) -> mexpr.mod_desc
| Tmod_structure st -> Tmod_structure (map_structure st)
| Tmod_functor (id, name, mtype, mexpr) ->
Tmod_functor (id, name, map_module_type mtype,
Tmod_functor (id, name, Misc.may_map map_module_type mtype,
map_module_expr mexpr)
| Tmod_apply (mexp1, mexp2, coercion) ->
Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)

43
typing/typemod.ml
View File

@ -39,6 +39,7 @@ type error =
| Scoping_pack of Longident.t * type_expr
| Extension of string
| Recursive_module_require_explicit_type
| Apply_generative
exception Error of Location.t * Env.t * error
@ -299,8 +300,9 @@ let rec approx_modtype env smty =
| Pmty_signature ssg ->
Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) ->
let arg = approx_modtype env sarg in
let (id, newenv) = Env.enter_module param.txt arg env in
let arg = may_map (approx_modtype env) sarg in
let (id, newenv) =
Env.enter_module param.txt (Btype.default_mty arg) env in
let res = approx_modtype newenv sres in
Mty_functor(id, arg, res)
| Pmty_with(sbody, constraints) ->
@ -472,11 +474,13 @@ let rec transl_modtype env smty =
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
smty.pmty_attributes
| Pmty_functor(param, sarg, sres) ->
let arg = transl_modtype env sarg in
let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
let arg = Misc.may_map (transl_modtype env) sarg in
let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
let (id, newenv) =
Env.enter_module param.txt (Btype.default_mty ty_arg) env in
let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, arg.mty_type, res.mty_type)) env loc
(Mty_functor(id, ty_arg, res.mty_type)) env loc
smty.pmty_attributes
| Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in
@ -949,11 +953,14 @@ let rec type_module sttn funct_body anchor env smod =
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_functor(name, smty, sbody) ->
let mty = transl_modtype env smty in
let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
let body = type_module sttn true None newenv sbody in
let mty = may_map (transl_modtype env) smty in
let ty_arg = may_map (fun m -> m.mty_type) mty in
let (id, newenv), funct_body =
match ty_arg with None -> (Ident.create "*", env), false
| Some mty -> Env.enter_module name.txt mty env, true in
let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(id, name, mty, body);
mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
mod_type = Mty_functor(id, ty_arg, body.mod_type);
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
@ -964,6 +971,14 @@ let rec type_module sttn funct_body anchor env smod =
type_module (sttn && path <> None) funct_body None env sfunct in
begin match Mtype.scrape env funct.mod_type with
Mty_functor(param, mty_param, mty_res) as mty_functor ->
let generative, mty_param =
(mty_param = None, Btype.default_mty mty_param) in
if generative then begin
if sarg.pmod_desc <> Pmod_structure [] then
raise (Error (sfunct.pmod_loc, env, Apply_generative));
if funct_body && Mtype.contains_type env funct.mod_type then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
end;
let coercion =
try
Includemod.modtypes env arg.mod_type mty_param
@ -975,6 +990,7 @@ let rec type_module sttn funct_body anchor env smod =
Subst.modtype (Subst.add_module param path Subst.identity)
mty_res
| None ->
if generative then mty_res else
try
Mtype.nondep_supertype
(Env.add_module param arg.mod_type env) param mty_res
@ -999,8 +1015,6 @@ let rec type_module sttn funct_body anchor env smod =
}
| Pmod_unpack sexp ->
if funct_body then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
if !Clflags.principal then Ctype.begin_def ();
let exp = Typecore.type_exp env sexp in
if !Clflags.principal then begin
@ -1025,6 +1039,8 @@ let rec type_module sttn funct_body anchor env smod =
| _ ->
raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
in
if funct_body && Mtype.contains_type env mty then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
rm { mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
mod_env = env;
@ -1549,7 +1565,8 @@ let report_error ppf = function
Location.print_filename intf_name
| Not_allowed_in_functor_body ->
fprintf ppf
"This kind of expression is not allowed within the body of a functor."
"@[This expression creates fresh types.@ %s@]"
"It is not allowed inside applicative functors."
| With_need_typeconstr ->
fprintf ppf
"Only type constructors with identical parameters can be substituted."
@ -1570,6 +1587,8 @@ let report_error ppf = function
fprintf ppf "Uninterpreted extension '%s'." s
| Recursive_module_require_explicit_type ->
fprintf ppf "Recursive modules require an explicit module type."
| Apply_generative ->
fprintf ppf "This is a generative functor. It can only be applied to ()"
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)

1
typing/typemod.mli
View File

@ -60,6 +60,7 @@ type error =
| Scoping_pack of Longident.t * type_expr
| Extension of string
| Recursive_module_require_explicit_type
| Apply_generative
exception Error of Location.t * Env.t * error

2
typing/types.ml
View File

@ -264,7 +264,7 @@ type class_type_declaration =
type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type * module_type
| Mty_functor of Ident.t * module_type option * module_type
and signature = signature_item list

2
typing/types.mli
View File

@ -251,7 +251,7 @@ type class_type_declaration =
type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type * module_type
| Mty_functor of Ident.t * module_type option * module_type
and signature = signature_item list