summaryrefslogtreecommitdiff
path: root/parsing
diff options
context:
space:
mode:
Diffstat (limited to 'parsing')
-rw-r--r--parsing/ast_helper.ml7
-rw-r--r--parsing/ast_helper.mli15
-rw-r--r--parsing/ast_iterator.ml16
-rw-r--r--parsing/ast_mapper.ml18
-rw-r--r--parsing/depend.ml64
-rw-r--r--parsing/parser.mly66
-rw-r--r--parsing/parsetree.mli16
-rw-r--r--parsing/pprintast.ml62
-rw-r--r--parsing/printast.ml33
9 files changed, 186 insertions, 111 deletions
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 9aa40bcaac..e9e8dee05b 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -24,6 +24,7 @@ type loc = Location.t
type lid = Longident.t with_loc
type str = string with_loc
+type str_opt = string option with_loc
type attrs = attribute list
let default_loc = ref Location.none
@@ -236,7 +237,7 @@ module Mty = struct
let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
- let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c))
+ let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
@@ -249,8 +250,8 @@ let mk ?(loc = !default_loc) ?(attrs = []) d =
let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
- let functor_ ?loc ?attrs arg arg_ty body =
- mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body))
+ let functor_ ?loc ?attrs arg body =
+ mk ?loc ?attrs (Pmod_functor (arg, body))
let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 9bb0aad0e8..8bae954791 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -29,6 +29,7 @@ type loc = Location.t
type lid = Longident.t with_loc
type str = string with_loc
+type str_opt = string option with_loc
type attrs = attribute list
(** {1 Default locations} *)
@@ -116,7 +117,7 @@ module Pat:
val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
- val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
+ val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern
val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
@@ -168,8 +169,8 @@ module Exp:
val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
-> expression
- val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
- -> expression
+ val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
+ -> expression -> expression
val letexception:
?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
-> expression
@@ -246,7 +247,7 @@ module Mty:
val alias: ?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 option -> module_type -> module_type
+ functor_parameter -> 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
@@ -262,7 +263,7 @@ 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 option -> module_expr -> module_expr
+ functor_parameter -> 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 ->
@@ -321,7 +322,7 @@ module Str:
module Md:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
- str -> module_type -> module_declaration
+ str_opt -> module_type -> module_declaration
end
(** Module substitutions *)
@@ -342,7 +343,7 @@ module Mtd:
module Mb:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
- str -> module_expr -> module_binding
+ str_opt -> module_expr -> module_binding
end
(** Opens *)
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index c6806a9bb9..5f016c0089 100644
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -233,6 +233,12 @@ module CT = struct
List.iter (sub.class_type_field sub) pcsig_fields
end
+let iter_functor_param sub = function
+ | Unit -> ()
+ | Named (name, mty) ->
+ iter_loc sub name;
+ sub.module_type sub mty
+
module MT = struct
(* Type expressions for the module language *)
@@ -243,9 +249,8 @@ module MT = struct
| Pmty_ident s -> iter_loc sub s
| Pmty_alias s -> iter_loc sub s
| Pmty_signature sg -> sub.signature sub sg
- | Pmty_functor (s, mt1, mt2) ->
- iter_loc sub s;
- iter_opt (sub.module_type sub) mt1;
+ | Pmty_functor (param, mt2) ->
+ iter_functor_param sub param;
sub.module_type sub mt2
| Pmty_with (mt, l) ->
sub.module_type sub mt;
@@ -298,9 +303,8 @@ module M = struct
match desc with
| Pmod_ident x -> iter_loc sub x
| Pmod_structure str -> sub.structure sub str
- | Pmod_functor (arg, arg_ty, body) ->
- iter_loc sub arg;
- iter_opt (sub.module_type sub) arg_ty;
+ | Pmod_functor (param, body) ->
+ iter_functor_param sub param;
sub.module_expr sub body
| Pmod_apply (m1, m2) ->
sub.module_expr sub m1; sub.module_expr sub m2
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 93d3b2dada..174fe08f36 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -249,6 +249,10 @@ module CT = struct
(List.map (sub.class_type_field sub) pcsig_fields)
end
+let map_functor_param sub = function
+ | Unit -> Unit
+ | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
+
module MT = struct
(* Type expressions for the module language *)
@@ -260,10 +264,10 @@ module MT = struct
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
| Pmty_alias s -> alias ~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)
- (Option.map (sub.module_type sub) mt1)
- (sub.module_type sub mt2)
+ | Pmty_functor (param, mt) ->
+ functor_ ~loc ~attrs
+ (map_functor_param sub param)
+ (sub.module_type sub mt)
| Pmty_with (mt, l) ->
with_ ~loc ~attrs (sub.module_type sub mt)
(List.map (sub.with_constraint sub) l)
@@ -318,9 +322,9 @@ module M = struct
match desc with
| 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)
- (Option.map (sub.module_type sub) arg_ty)
+ | Pmod_functor (param, body) ->
+ functor_ ~loc ~attrs
+ (map_functor_param sub param)
(sub.module_expr sub body)
| Pmod_apply (m1, m2) ->
apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
diff --git a/parsing/depend.ml b/parsing/depend.ml
index 8e0a3711f7..f513144b02 100644
--- a/parsing/depend.ml
+++ b/parsing/depend.ml
@@ -182,7 +182,9 @@ let rec add_pattern bv pat =
| Ppat_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type li -> add bv li
| Ppat_lazy p -> add_pattern bv p
- | Ppat_unpack id -> pattern_bv := String.Map.add id.txt bound !pattern_bv
+ | Ppat_unpack id ->
+ Option.iter
+ (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt
| Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
| Ppat_exception p -> add_pattern bv p
| Ppat_extension e -> handle_extension e
@@ -234,7 +236,12 @@ let rec add_expr bv exp =
| Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in
- add_expr (String.Map.add id.txt b bv) e
+ let bv =
+ match id.txt with
+ | None -> bv
+ | Some id -> String.Map.add id b bv
+ in
+ add_expr bv e
| Pexp_letexception(_, e) -> add_expr bv e
| Pexp_assert (e) -> add_expr bv e
| Pexp_lazy (e) -> add_expr bv e
@@ -283,9 +290,17 @@ and add_modtype bv mty =
Pmty_ident l -> add bv l
| Pmty_alias l -> add_module_path bv l
| Pmty_signature s -> add_signature bv s
- | Pmty_functor(id, mty1, mty2) ->
- Option.iter (add_modtype bv) mty1;
- add_modtype (String.Map.add id.txt bound bv) mty2
+ | Pmty_functor(param, mty2) ->
+ let bv =
+ match param with
+ | Unit -> bv
+ | Named (id, mty1) ->
+ add_modtype bv mty1;
+ match id.txt with
+ | None -> bv
+ | Some name -> String.Map.add name bound bv
+ in
+ add_modtype bv mty2
| Pmty_with(mty, cstrl) ->
add_modtype bv mty;
List.iter
@@ -340,7 +355,11 @@ and add_sig_item (bv, m) item =
add_type_exception bv te; (bv, m)
| Psig_module pmd ->
let m' = add_modtype_binding bv pmd.pmd_type in
- let add = String.Map.add pmd.pmd_name.txt m' in
+ let add map =
+ match pmd.pmd_name.txt with
+ | None -> map
+ | Some name -> String.Map.add name m' map
+ in
(add bv, add m)
| Psig_modsubst pms ->
let m' = add_module_alias bv pms.pms_manifest in
@@ -348,8 +367,11 @@ and add_sig_item (bv, m) item =
(add bv, add m)
| Psig_recmodule decls ->
let add =
- List.fold_right (fun pmd -> String.Map.add pmd.pmd_name.txt bound)
- decls
+ List.fold_right (fun pmd map ->
+ match pmd.pmd_name.txt with
+ | None -> map
+ | Some name -> String.Map.add name bound map
+ ) decls
in
let bv' = add bv and m' = add m in
List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
@@ -397,9 +419,17 @@ and add_module_expr bv modl =
match modl.pmod_desc with
Pmod_ident l -> add_module_path bv l
| Pmod_structure s -> ignore (add_structure bv s)
- | Pmod_functor(id, mty, modl) ->
- Option.iter (add_modtype bv) mty;
- add_module_expr (String.Map.add id.txt bound bv) modl
+ | Pmod_functor(param, modl) ->
+ let bv =
+ match param with
+ | Unit -> bv
+ | Named (id, mty) ->
+ add_modtype bv mty;
+ match id.txt with
+ | None -> bv
+ | Some name -> String.Map.add name bound bv
+ in
+ add_module_expr bv modl
| Pmod_apply(mod1, mod2) ->
add_module_expr bv mod1; add_module_expr bv mod2
| Pmod_constraint(modl, mty) ->
@@ -463,11 +493,19 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
(bv, m)
| Pstr_module x ->
let b = add_module_binding bv x.pmb_expr in
- let add = String.Map.add x.pmb_name.txt b in
+ let add map =
+ match x.pmb_name.txt with
+ | None -> map
+ | Some name -> String.Map.add name b map
+ in
(add bv, add m)
| Pstr_recmodule bindings ->
let add =
- List.fold_right (fun x -> String.Map.add x.pmb_name.txt bound) bindings
+ List.fold_right (fun x map ->
+ match x.pmb_name.txt with
+ | None -> map
+ | Some name -> String.Map.add name bound map
+ ) bindings
in
let bv' = add bv and m = add m in
List.iter
diff --git a/parsing/parser.mly b/parsing/parser.mly
index ff49244ed2..f6206179b5 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1132,20 +1132,20 @@ parse_pattern:
functor_arg:
(* An anonymous and untyped argument. *)
- x = mkrhs(LPAREN RPAREN {"*"})
- { x, None }
+ LPAREN RPAREN
+ { Unit }
| (* An argument accompanied with an explicit type. *)
- LPAREN x = mkrhs(functor_arg_name) COLON mty = module_type RPAREN
- { x, Some mty }
+ LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
+ { Named (x, mty) }
;
-functor_arg_name:
+module_name:
(* A named argument. *)
x = UIDENT
- { x }
+ { Some x }
| (* An anonymous argument. *)
UNDERSCORE
- { "_" }
+ { None }
;
(* -------------------------------------------------------------------------- *)
@@ -1164,8 +1164,8 @@ module_expr:
{ unclosed "struct" $loc($1) "end" $loc($4) }
| FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
{ wrap_mod_attrs ~loc:$sloc attrs (
- List.fold_left (fun acc (x, mty) ->
- mkmod ~loc:$sloc (Pmod_functor (x, mty, acc))
+ List.fold_left (fun acc arg ->
+ mkmod ~loc:$sloc (Pmod_functor (arg, acc))
) me args
) }
| me = paren_module_expr
@@ -1307,13 +1307,13 @@ structure_item:
%inline module_binding:
MODULE
ext = ext attrs1 = attributes
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{ let docs = symbol_docs $sloc in
let loc = make_loc $sloc in
let attrs = attrs1 @ attrs2 in
- let body = Mb.mk uid body ~attrs ~loc ~docs in
+ let body = Mb.mk name body ~attrs ~loc ~docs in
Pstr_module body, ext }
;
@@ -1325,8 +1325,7 @@ module_binding_body:
COLON mty = module_type EQUAL me = module_expr
{ Pmod_constraint(me, mty) }
| arg = functor_arg body = module_binding_body
- { let (x, mty) = arg in
- Pmod_functor(x, mty, body) }
+ { Pmod_functor(arg, body) }
) { $1 }
;
@@ -1342,7 +1341,7 @@ module_binding_body:
ext = ext
attrs1 = attributes
REC
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{
@@ -1350,7 +1349,7 @@ module_binding_body:
let attrs = attrs1 @ attrs2 in
let docs = symbol_docs $sloc in
ext,
- Mb.mk uid body ~attrs ~loc ~docs
+ Mb.mk name body ~attrs ~loc ~docs
}
;
@@ -1358,7 +1357,7 @@ module_binding_body:
%inline and_module_binding:
AND
attrs1 = attributes
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{
@@ -1366,7 +1365,7 @@ module_binding_body:
let attrs = attrs1 @ attrs2 in
let docs = symbol_docs $sloc in
let text = symbol_text $symbolstartpos in
- Mb.mk uid body ~attrs ~loc ~text ~docs
+ Mb.mk name body ~attrs ~loc ~text ~docs
}
;
@@ -1459,8 +1458,8 @@ module_type:
MINUSGREATER mty = module_type
%prec below_WITH
{ wrap_mty_attrs ~loc:$sloc attrs (
- List.fold_left (fun acc (x, mty) ->
- mkmty ~loc:$sloc (Pmty_functor (x, mty, acc))
+ List.fold_left (fun acc arg ->
+ mkmty ~loc:$sloc (Pmty_functor (arg, acc))
) mty args
) }
| MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
@@ -1476,7 +1475,7 @@ module_type:
{ Pmty_ident $1 }
| module_type MINUSGREATER module_type
%prec below_WITH
- { Pmty_functor(mknoloc "_", Some $1, $3) }
+ { Pmty_functor(Named (mknoloc None, $1), $3) }
| module_type WITH separated_nonempty_llist(AND, with_constraint)
{ Pmty_with($1, $3) }
/* | LPAREN MODULE mkrhs(mod_longident) RPAREN
@@ -1550,14 +1549,14 @@ signature_item:
%inline module_declaration:
MODULE
ext = ext attrs1 = attributes
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
body = module_declaration_body
attrs2 = post_item_attributes
{
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
- Md.mk uid body ~attrs ~loc ~docs, ext
+ Md.mk name body ~attrs ~loc ~docs, ext
}
;
@@ -1567,8 +1566,7 @@ module_declaration_body:
{ mty }
| mkmty(
arg = functor_arg body = module_declaration_body
- { let (x, mty) = arg in
- Pmty_functor(x, mty, body) }
+ { Pmty_functor(arg, body) }
)
{ $1 }
;
@@ -1577,7 +1575,7 @@ module_declaration_body:
%inline module_alias:
MODULE
ext = ext attrs1 = attributes
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
EQUAL
body = module_expr_alias
attrs2 = post_item_attributes
@@ -1585,7 +1583,7 @@ module_declaration_body:
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
- Md.mk uid body ~attrs ~loc ~docs, ext
+ Md.mk name body ~attrs ~loc ~docs, ext
}
;
%inline module_expr_alias:
@@ -1620,7 +1618,7 @@ module_subst:
ext = ext
attrs1 = attributes
REC
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
COLON
mty = module_type
attrs2 = post_item_attributes
@@ -1628,13 +1626,13 @@ module_subst:
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
- ext, Md.mk uid mty ~attrs ~loc ~docs
+ ext, Md.mk name mty ~attrs ~loc ~docs
}
;
%inline and_module_declaration:
AND
attrs1 = attributes
- uid = mkrhs(UIDENT)
+ name = mkrhs(module_name)
COLON
mty = module_type
attrs2 = post_item_attributes
@@ -1643,7 +1641,7 @@ module_subst:
let docs = symbol_docs $sloc in
let loc = make_loc $sloc in
let text = symbol_text $symbolstartpos in
- Md.mk uid mty ~attrs ~loc ~text ~docs
+ Md.mk name mty ~attrs ~loc ~text ~docs
}
;
@@ -2131,7 +2129,7 @@ expr:
{ not_expecting $loc($1) "wildcard \"_\"" }
;
%inline expr_attrs:
- | LET MODULE ext_attributes mkrhs(UIDENT) module_binding_body IN seq_expr
+ | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
{ Pexp_letmodule($4, $5, $7), $3 }
| LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
{ Pexp_letexception($4, $6), $3 }
@@ -2625,9 +2623,9 @@ simple_pattern_not_ident:
{ reloc_pat ~loc:$sloc $2 }
| simple_delimited_pattern
{ $1 }
- | LPAREN MODULE ext_attributes mkrhs(UIDENT) RPAREN
+ | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
{ mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
- | LPAREN MODULE ext_attributes mkrhs(UIDENT) COLON package_type RPAREN
+ | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
{ mkpat_attrs ~loc:$sloc
(Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
$3 }
@@ -2667,7 +2665,7 @@ simple_pattern_not_ident:
{ unclosed "(" $loc($1) ")" $loc($5) }
| LPAREN pattern COLON error
{ expecting $loc($4) "type" }
- | LPAREN MODULE ext_attributes UIDENT COLON package_type
+ | LPAREN MODULE ext_attributes module_name COLON package_type
error
{ unclosed "(" $loc($1) ")" $loc($7) }
| extension
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 4046249894..ab60827cd8 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -238,7 +238,7 @@ and pattern_desc =
(* #tconst *)
| Ppat_lazy of pattern
(* lazy P *)
- | Ppat_unpack of string loc
+ | Ppat_unpack of string option loc
(* (module P)
Note: (module P : S) is represented as
Ppat_constraint(Ppat_unpack, Ptyp_package)
@@ -346,7 +346,7 @@ and expression_desc =
(* x <- 2 *)
| Pexp_override of (label loc * expression) list
(* {< x1 = E1; ...; Xn = En >} *)
- | Pexp_letmodule of string loc * module_expr * expression
+ | Pexp_letmodule of string option loc * module_expr * expression
(* let module M = ME in E *)
| Pexp_letexception of extension_constructor * expression
(* let exception C in E *)
@@ -713,7 +713,7 @@ and module_type_desc =
(* S *)
| Pmty_signature of signature
(* sig ... end *)
- | Pmty_functor of string loc * module_type option * module_type
+ | Pmty_functor of functor_parameter * module_type
(* functor(X : MT1) -> MT2 *)
| Pmty_with of module_type * with_constraint list
(* MT with ... *)
@@ -724,6 +724,10 @@ and module_type_desc =
| Pmty_alias of Longident.t loc
(* (module M) *)
+and functor_parameter =
+ | Unit
+ | Named of string option loc * module_type
+
and signature = signature_item list
and signature_item =
@@ -771,7 +775,7 @@ and signature_item_desc =
and module_declaration =
{
- pmd_name: string loc;
+ pmd_name: string option loc;
pmd_type: module_type;
pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
pmd_loc: Location.t;
@@ -858,7 +862,7 @@ and module_expr_desc =
(* X *)
| Pmod_structure of structure
(* struct ... end *)
- | Pmod_functor of string loc * module_type option * module_expr
+ | Pmod_functor of functor_parameter * module_expr
(* functor(X : MT1) -> ME *)
| Pmod_apply of module_expr * module_expr
(* ME1(ME2) *)
@@ -923,7 +927,7 @@ and value_binding =
and module_binding =
{
- pmb_name: string loc;
+ pmb_name: string option loc;
pmb_expr: module_expr;
pmb_attributes: attributes;
pmb_loc: Location.t;
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 06f8b18e43..f8839bd150 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -442,8 +442,10 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
| Ppat_var ({txt = txt;_}) -> protect_ident f txt
| Ppat_array l ->
pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l
- | Ppat_unpack (s) ->
- pp f "(module@ %s)@ " s.txt
+ | Ppat_unpack { txt = None } ->
+ pp f "(module@ _)@ "
+ | Ppat_unpack { txt = Some s } ->
+ pp f "(module@ %s)@ " s
| Ppat_type li ->
pp f "#%a" longident_loc li
| Ppat_record (l, closed) ->
@@ -704,7 +706,8 @@ and expression ctxt f x =
pp f "@[<hov2>{<%a>}@]"
(list string_x_expression ~sep:";" ) l;
| Pexp_letmodule (s, me, e) ->
- pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
+ pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+ (Option.value s.txt ~default:"_")
(module_expr reset_ctxt) me (expression ctxt) e
| Pexp_letexception (cd, e) ->
pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
@@ -1025,15 +1028,17 @@ and module_type ctxt f x =
(attributes ctxt) x.pmty_attributes
end else
match x.pmty_desc with
- | Pmty_functor (_, None, mt2) ->
+ | Pmty_functor (Unit, mt2) ->
pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
- | Pmty_functor (s, Some mt1, mt2) ->
- if s.txt = "_" then
- pp f "@[<hov2>%a@ ->@ %a@]"
- (module_type1 ctxt) mt1 (module_type ctxt) mt2
- else
- pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
- (module_type ctxt) mt1 (module_type ctxt) mt2
+ | Pmty_functor (Named (s, mt1), mt2) ->
+ begin match s.txt with
+ | None ->
+ pp f "@[<hov2>%a@ ->@ %a@]"
+ (module_type1 ctxt) mt1 (module_type ctxt) mt2
+ | Some name ->
+ pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+ (module_type ctxt) mt1 (module_type ctxt) mt2
+ end
| Pmty_with (mt, []) -> module_type ctxt f mt
| Pmty_with (mt, l) ->
let with_constraint f = function
@@ -1107,12 +1112,13 @@ and signature_item ctxt f x : unit =
end
| Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
pmty_attributes=[]; _};_} as pmd) ->
- pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
+ pp f "@[<hov>module@ %s@ =@ %a@]%a"
+ (Option.value pmd.pmd_name.txt ~default:"_")
longident_loc alias
(item_attributes ctxt) pmd.pmd_attributes
| Psig_module pmd ->
pp f "@[<hov>module@ %s@ :@ %a@]%a"
- pmd.pmd_name.txt
+ (Option.value pmd.pmd_name.txt ~default:"_")
(module_type ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
| Psig_modsubst pms ->
@@ -1145,11 +1151,13 @@ and signature_item ctxt f x : unit =
| [] -> () ;
| pmd :: tl ->
if not first then
- pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
+ pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+ (Option.value pmd.pmd_name.txt ~default:"_")
(module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
else
- pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
+ pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+ (Option.value pmd.pmd_name.txt ~default:"_")
(module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes;
string_x_module_type_list f ~first:false tl
@@ -1174,11 +1182,12 @@ and module_expr ctxt f x =
(module_type ctxt) mt
| Pmod_ident (li) ->
pp f "%a" longident_loc li;
- | Pmod_functor (_, None, me) ->
+ | Pmod_functor (Unit, me) ->
pp f "functor ()@;->@;%a" (module_expr ctxt) me
- | Pmod_functor (s, Some mt, me) ->
+ | Pmod_functor (Named (s, mt), me) ->
pp f "functor@ (%s@ :@ %a)@;->@;%a"
- s.txt (module_type ctxt) mt (module_expr ctxt) me
+ (Option.value s.txt ~default:"_")
+ (module_type ctxt) mt (module_expr ctxt) me
| Pmod_apply (me1, me2) ->
pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
(* Cf: #7200 *)
@@ -1303,14 +1312,18 @@ and structure_item ctxt f x =
| Pstr_exception ed -> exception_declaration ctxt f ed
| Pstr_module x ->
let rec module_helper = function
- | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
- if mt = None then pp f "()"
- else Option.iter (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
+ | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+ begin match arg_opt with
+ | Unit -> pp f "()"
+ | Named (s, mt) ->
+ pp f "(%s:%a)" (Option.value s.txt ~default:"_")
+ (module_type ctxt) mt
+ end;
module_helper me'
| me -> me
in
pp f "@[<hov2>module %s%a@]%a"
- x.pmb_name.txt
+ (Option.value x.pmb_name.txt ~default:"_")
(fun f me ->
let me = module_helper me in
match me with
@@ -1389,7 +1402,8 @@ and structure_item ctxt f x =
| Pstr_recmodule decls -> (* 3.07 *)
let aux f = function
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
- pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
+ pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+ (Option.value pmb.pmb_name.txt ~default:"_")
(module_type ctxt) typ
(module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes
@@ -1398,7 +1412,7 @@ and structure_item ctxt f x =
begin match decls with
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
- pmb.pmb_name.txt
+ (Option.value pmb.pmb_name.txt ~default:"_")
(module_type ctxt) typ
(module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 085e0d797b..30a0eeb305 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -52,6 +52,10 @@ let fmt_string_loc f (x : string loc) =
fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
;;
+let fmt_str_opt_loc f (x : string option loc) =
+ fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
+;;
+
let fmt_char_option f = function
| None -> fprintf f "None"
| Some c -> fprintf f "Some %c" c
@@ -132,6 +136,7 @@ let option i f ppf x =
let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
let string i ppf s = line i ppf "\"%s\"\n" s;;
let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
let arg_label i ppf = function
| Nolabel -> line i ppf "Nolabel\n"
| Optional s -> line i ppf "Optional \"%s\"\n" s
@@ -240,7 +245,7 @@ and pattern i ppf x =
line i ppf "Ppat_type\n";
longident_loc i ppf li
| Ppat_unpack s ->
- line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
+ line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
| Ppat_exception p ->
line i ppf "Ppat_exception\n";
pattern i ppf p
@@ -347,7 +352,7 @@ and expression i ppf x =
line i ppf "Pexp_override\n";
list i string_x_expression ppf l;
| Pexp_letmodule (s, me, e) ->
- line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
+ line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
module_expr i ppf me;
expression i ppf e;
| Pexp_letexception (cd, e) ->
@@ -662,9 +667,12 @@ and module_type i ppf x =
| Pmty_signature (s) ->
line i ppf "Pmty_signature\n";
signature i ppf s;
- | Pmty_functor (s, mt1, mt2) ->
- line i ppf "Pmty_functor %a\n" fmt_string_loc s;
- Option.iter (module_type i ppf) mt1;
+ | Pmty_functor (Unit, mt2) ->
+ line i ppf "Pmty_functor ()\n";
+ module_type i ppf mt2;
+ | Pmty_functor (Named (s, mt1), mt2) ->
+ line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
+ module_type i ppf mt1;
module_type i ppf mt2;
| Pmty_with (mt, l) ->
line i ppf "Pmty_with\n";
@@ -699,7 +707,7 @@ and signature_item i ppf x =
line i ppf "Psig_exception\n";
type_exception i ppf te
| Psig_module pmd ->
- line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
+ line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
attributes i ppf pmd.pmd_attributes;
module_type i ppf pmd.pmd_type
| Psig_modsubst pms ->
@@ -765,9 +773,12 @@ and module_expr i ppf x =
| Pmod_structure (s) ->
line i ppf "Pmod_structure\n";
structure i ppf s;
- | Pmod_functor (s, mt, me) ->
- line i ppf "Pmod_functor %a\n" fmt_string_loc s;
- Option.iter (module_type i ppf) mt;
+ | Pmod_functor (Unit, me) ->
+ line i ppf "Pmod_functor ()\n";
+ module_expr i ppf me;
+ | Pmod_functor (Named (s, mt), me) ->
+ line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
+ module_type i ppf mt;
module_expr i ppf me;
| Pmod_apply (me1, me2) ->
line i ppf "Pmod_apply\n";
@@ -841,12 +852,12 @@ and structure_item i ppf x =
attribute i ppf "Pstr_attribute" a
and module_declaration i ppf pmd =
- string_loc i ppf pmd.pmd_name;
+ str_opt_loc i ppf pmd.pmd_name;
attributes i ppf pmd.pmd_attributes;
module_type (i+1) ppf pmd.pmd_type;
and module_binding i ppf x =
- string_loc i ppf x.pmb_name;
+ str_opt_loc i ppf x.pmb_name;
attributes i ppf x.pmb_attributes;
module_expr (i+1) ppf x.pmb_expr
View Lorry Controller Status