Skip to content

Commit 6dcf0b5

Browse files
JulowJulow
committed
Support the new functor type syntax MT -> MT
Support the unnamed functor parameters in module types: module type F = ARG -> S The extended parser is changed to preserve the concrete syntax of functor arguments in module types. Notably, these three lines are no longer equivalent and the first two are no longer turned into the third: module M : (_ : S) -> (_ : S) -> S = N module M : S -> S -> S = N module M : (_ : S) (_ : S) -> S = N
1 parent cc1de11 commit 6dcf0b5

40 files changed

+851
-133
lines changed

‎lib/Ast.ml‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -277,9 +277,9 @@ let rec mty_is_simple x =
277277
| Pmty_signature (_ :: _)
278278
|Pmty_with (_, _ :: _ :: _)
279279
|Pmty_extension _
280-
|Pmty_functor (_, _, false) ->
280+
|Pmty_functor (Pfunctorty_keyword _, _) ->
281281
false
282-
| Pmty_functor (_, t, true) -> mty_is_simple t
282+
| Pmty_functor (_, t) -> mty_is_simple t
283283
| Pmty_typeof e -> mod_is_simple e
284284
| Pmty_with (t, ([] | [_])) -> mty_is_simple t
285285

@@ -1915,6 +1915,13 @@ end = struct
19151915
||
19161916
match (ctx, mty.pmty_desc) with
19171917
| Mty {pmty_desc= Pmty_with _; _}, Pmty_with _ -> true
1918+
| ( Mty
1919+
{ pmty_desc=
1920+
Pmty_with (lhs, _) | Pmty_functor (Pfunctorty_unnamed lhs, _)
1921+
; _ }
1922+
, Pmty_functor _ )
1923+
when lhs == mty ->
1924+
true
19181925
| _ -> false
19191926

19201927
(** [parenze_mod {ctx; ast}] holds when module expr [ast] should be

‎lib/Fmt_ast.ml‎

Lines changed: 19 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -3860,6 +3860,16 @@ and fmt_functor_param c ctx {loc; txt= arg} =
38603860
( hovbox 0 (fmt_str_loc_opt c name $ space_break $ str ": ")
38613861
$ compose_module (fmt_module_type c xmt) ~f:Fn.id ) ) ) )
38623862

3863+
and fmt_functor_param_type c ctx = function
3864+
| Pfunctorty_short args -> list args (break 1 2) (fmt_functor_param c ctx)
3865+
| Pfunctorty_keyword (attrs, args) ->
3866+
str "functor"
3867+
$ fmt_attributes c ?pre:None attrs
3868+
$ break 1 2
3869+
$ list args (break 1 2) (fmt_functor_param c ctx)
3870+
| Pfunctorty_unnamed arg ->
3871+
compose_module (fmt_module_type c (sub_mty ~ctx arg)) ~f:Fn.id
3872+
38633873
and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) =
38643874
let ctx = Mty mty in
38653875
let {pmty_desc; pmty_loc; pmty_attributes} = mty in
@@ -3904,24 +3914,22 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) =
39043914
Some
39053915
( str "end" $ after
39063916
$ fmt_attributes_and_docstrings c pmty_attributes ) }
3907-
| Pmty_functor (args, mt, short) ->
3908-
let keyword =
3909-
if short && List.is_empty pmty_attributes then noop
3910-
else
3911-
str "functor"
3912-
$ fmt_attributes c ~pre:Blank pmty_attributes
3913-
$ break 1 2
3914-
in
3917+
| Pmty_functor (paramty, mt) ->
39153918
let blk = fmt_module_type c (sub_mty ~ctx mt) in
39163919
{ blk with
39173920
pro=
39183921
Some
39193922
( Cmts.fmt_before c pmty_loc
3920-
$ keyword
3921-
$ list args (break 1 2) (fmt_functor_param c ctx)
3923+
$ fmt_if parens (str "(")
3924+
$ fmt_functor_param_type c ctx paramty
39223925
$ break 1 2 $ str "->"
39233926
$ opt blk.pro (fun pro -> str " " $ pro) )
3924-
; epi= Some (fmt_opt blk.epi $ Cmts.fmt_after c pmty_loc)
3927+
; epi=
3928+
Some
3929+
( fmt_opt blk.epi
3930+
$ fmt_if parens (str ")")
3931+
$ fmt_attributes c pmty_attributes ~pre:Space
3932+
$ Cmts.fmt_after c pmty_loc )
39253933
; psp=
39263934
fmt_or (Option.is_none blk.pro)
39273935
(fits_breaks " " ~hint:(1, 2) "")

‎test/passing/gen/dune.inc‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2312,6 +2312,24 @@
23122312
(package ocamlformat)
23132313
(action (diff function_indent.ml.err function_indent.ml.stderr)))
23142314

2315+
(rule
2316+
(deps .ocamlformat)
2317+
(package ocamlformat)
2318+
(action
2319+
(with-stdout-to functor-414.ml.stdout
2320+
(with-stderr-to functor-414.ml.stderr
2321+
(run %{bin:ocamlformat} --name functor-414.ml --margin-check --ocaml-version=4.14 %{dep:../tests/functor.ml})))))
2322+
2323+
(rule
2324+
(alias runtest)
2325+
(package ocamlformat)
2326+
(action (diff functor-414.ml.ref functor-414.ml.stdout)))
2327+
2328+
(rule
2329+
(alias runtest)
2330+
(package ocamlformat)
2331+
(action (diff functor-414.ml.err functor-414.ml.stderr)))
2332+
23152333
(rule
23162334
(deps .ocamlformat)
23172335
(package ocamlformat)

‎test/passing/refs.ahrefs/functor-414.ml.err‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
Warning: functor-414.ml:85 exceeds the margin
2+
Warning: functor-414.ml:100 exceeds the margin

‎test/passing/refs.ahrefs/functor-414.ml.ref‎

Lines changed: 141 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,141 @@
1+
module type S = functor () -> sig end
2+
3+
module type S = functor () () -> sig end
4+
5+
module type M = functor () -> sig end
6+
7+
module type M = functor (S : S) -> sig end
8+
9+
module type M = functor (S : S) (T : T) -> sig end
10+
11+
module type M = functor (S : S) (T : T) -> U
12+
13+
module type M = functor (S : S) () -> sig end
14+
15+
module type M = functor
16+
(SSSSS : SSSSSSSSSSSSSS)
17+
(TTTTT : TTTTTTTTTTTTTTTT)
18+
-> sig
19+
val t1 : a
20+
21+
val t2 : b
22+
end
23+
24+
module M : functor () -> sig end = functor () -> struct end
25+
26+
module M = (functor (S : S) -> struct end) (S)
27+
28+
module M = (functor (S : S) (T : T) -> struct end) (S) (T)
29+
30+
module M = (functor (S : S) (T : T) -> struct end : U) (S) (T)
31+
32+
module M = (functor (S : S) () -> struct end : U) (S) (T)
33+
34+
module M = (functor (S : S) (T : T) -> (struct end : U)) (S) (T)
35+
36+
module rec A (S : S) = S
37+
38+
module type S = S -> S -> S
39+
module type S = (S -> S) -> S
40+
module type S = (functor (M : S) -> S) -> S
41+
module type S = functor (M : S -> S) -> S
42+
module type S = ((M : S) -> S) -> S
43+
module type S = (M : S -> S) -> S
44+
45+
module M : X -> X = Y
46+
module M : X -> (Y : T) -> (_ : T) -> Z = M
47+
module M : X -> (Y : T) (_ : T) -> Z = M
48+
module M : (X : T) -> T -> (_ : T) -> Z = M
49+
module M : (_ : X) -> X = Y
50+
51+
module type S = sig
52+
module rec A : functor (S : S) -> S
53+
end
54+
55+
module M =
56+
(functor
57+
(SSSSS : sssssSSSSSSSSSSSSSS)
58+
(TTTTT : TTTTTTTTTTTTTTTTTTTTT)
59+
->
60+
struct
61+
let x = 2
62+
63+
let y = 3
64+
end)
65+
(S)
66+
(T)
67+
68+
module type Module_type_fail = sig
69+
include S
70+
71+
module F : functor (_ : T) -> sig end
72+
73+
include S
74+
end
75+
76+
module type KV_MAKER = functor (G : Irmin_git.G) (C : Irmin.Contents.S) ->
77+
S
78+
with type key = string list
79+
and type step = string
80+
and type contents = C.t
81+
and type branch = string
82+
and module Git = G
83+
84+
module Make
85+
(TT : TableFormat.TABLES)
86+
(IT : InspectionTableFormat.TABLES__________________________________________)
87+
(ET :
88+
EngineTypes.TABLE
89+
with type terminal = int
90+
and type nonterminal = int
91+
and type semantic_value = Obj.t)
92+
(E : sig
93+
type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env
94+
end) =
95+
struct
96+
type t = t
97+
end
98+
99+
module Make
100+
(TT : TableFormat.TABLES)
101+
(IT : InspectionTableFormat.TABLES__________________________________________) =
102+
struct
103+
type t = t
104+
end
105+
106+
(* Long syntax should be preserved *)
107+
module M = functor (_ : S) -> struct end
108+
109+
module M (_ : S) = struct end
110+
111+
module M : functor (_ : S) -> S' = functor (_ : S) -> struct end
112+
113+
module type SETFUNCTOR = (Elt : ORDERED_TYPE) -> sig end
114+
115+
module WrongSet : (Elt : ORDERED_TYPE) -> SET = Set
116+
117+
module M : (A : S) (B : S) -> S = N
118+
module M : (A : S) -> (B : S) -> S = N
119+
module M : functor (A : S) -> (B : S) -> S = N
120+
module M : functor (A : S) -> functor (B : S) -> S = N
121+
module M : functor (A : S) (B : S) -> S = N
122+
module M : functor (A : S) -> functor (B : S) -> S = N
123+
module M : (A : S) -> functor (B : S) -> S = N
124+
125+
module M : X -> X =
126+
functor
127+
(X : X)
128+
->
129+
struct
130+
let x = X.x
131+
end
132+
133+
module M : (_ : X) -> X = Y
134+
135+
[@@@ocamlformat "break-struct=natural"]
136+
137+
module M = F (struct type t end : sig type t end)
138+
139+
module M = struct type t end
140+
141+
module type S = sig type t end

‎test/passing/refs.ahrefs/functor.ml.err‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,2 @@
1-
Warning: functor.ml:72 exceeds the margin
2-
Warning: functor.ml:87 exceeds the margin
1+
Warning: functor.ml:85 exceeds the margin
2+
Warning: functor.ml:100 exceeds the margin

‎test/passing/refs.ahrefs/functor.ml.ref‎

Lines changed: 26 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,19 @@ module M = (functor (S : S) (T : T) -> (struct end : U)) (S) (T)
3535

3636
module rec A (S : S) = S
3737

38+
module type S = S -> S -> S
39+
module type S = (S -> S) -> S
40+
module type S = (functor (M : S) -> S) -> S
41+
module type S = functor (M : S -> S) -> S
42+
module type S = ((M : S) -> S) -> S
43+
module type S = (M : S -> S) -> S
44+
45+
module M : X -> X = Y
46+
module M : X -> (Y : T) -> (_ : T) -> Z = M
47+
module M : X -> (Y : T) (_ : T) -> Z = M
48+
module M : (X : T) -> T -> (_ : T) -> Z = M
49+
module M : (_ : X) -> X = Y
50+
3851
module type S = sig
3952
module rec A : functor (S : S) -> S
4053
end
@@ -102,13 +115,23 @@ module type SETFUNCTOR = (Elt : ORDERED_TYPE) -> sig end
102115
module WrongSet : (Elt : ORDERED_TYPE) -> SET = Set
103116

104117
module M : (A : S) (B : S) -> S = N
105-
module M : (A : S) (B : S) -> S = N
118+
module M : (A : S) -> (B : S) -> S = N
106119
module M : functor (A : S) -> (B : S) -> S = N
120+
module M : functor (A : S) -> functor (B : S) -> S = N
107121
module M : functor (A : S) (B : S) -> S = N
108-
module M : functor (A : S) (B : S) -> S = N
109-
module M : functor (A : S) (B : S) -> S = N
122+
module M : functor (A : S) -> functor (B : S) -> S = N
110123
module M : (A : S) -> functor (B : S) -> S = N
111124

125+
module M : X -> X =
126+
functor
127+
(X : X)
128+
->
129+
struct
130+
let x = X.x
131+
end
132+
133+
module M : (_ : X) -> X = Y
134+
112135
[@@@ocamlformat "break-struct=natural"]
113136

114137
module M = F (struct type t end : sig type t end)

‎test/passing/refs.ahrefs/generative.ml.ref‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,6 @@ module M = String_id (M) ()
66
module F2 : functor () -> sig end = F1
77
module F2 : functor () () -> sig end = F1
88
module F2 : (*xx*) ( (*yy*) ) (*zz*) -> sig end = F1
9-
module F2 : () -> functor [@attr] () () -> sig end = F1
9+
module F2 : () -> functor[@attr] () () -> sig end = F1
1010
module F2 : () -> functor () () -> () -> sig end = F1
11-
module F2 : () () () -> functor () () -> () -> sig end = F1
11+
module F2 : () -> () -> () -> functor () () -> () -> sig end = F1

‎test/passing/refs.ahrefs/shortcut_ext_attr.ml.ref‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -83,7 +83,7 @@ type t = [%foo: ((module M)[@foo])]
8383
module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo]))
8484

8585
(* Module type expression *)
86-
module type S = functor [@foo1]
86+
module type S = functor[@foo1]
8787
(M : S)
8888
-> functor
8989
(_ : (module type of M) [@foo2])

‎test/passing/refs.ahrefs/source.ml.err‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
Warning: source.ml:3419 exceeds the margin
2-
Warning: source.ml:6553 exceeds the margin
3-
Warning: source.ml:6987 exceeds the margin
4-
Warning: source.ml:7819 exceeds the margin
1+
Warning: source.ml:3417 exceeds the margin
2+
Warning: source.ml:6551 exceeds the margin
3+
Warning: source.ml:6985 exceeds the margin
4+
Warning: source.ml:7817 exceeds the margin

0 commit comments

Comments
 (0)