Skip to content

Commit

Permalink
Pretty error message for variadic functor inclusion
Browse files Browse the repository at this point in the history
  • Loading branch information
@Octachron
Octachron committed Apr 2, 2020
1 parent aaf69d9 commit 8d629b6
Show file tree
Hide file tree
Showing 3 changed files with 212 additions and 55 deletions.
129 changes: 129 additions & 0 deletions testsuite/tests/typing-modules/functors.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1436,6 +1436,135 @@ Error: Signature mismatch:
|}]


module M: sig
module F(X: sig
module type T
module type t = T -> T -> T
module M: t
end
)(_:X.T)(_:X.T): X.T
end = struct
module F (Wrong: sig type wrong end)
(X: sig
module type t
module M: t
end) = (X.M : X.t)
end
[%%expect {|
Lines 8-14, characters 6-3:
8 | ......struct
9 | module F (Wrong: sig type wrong end)
10 | (X: sig
11 | module type t
12 | module M: t
13 | end) = (X.M : X.t)
14 | end
Error: Signature mismatch:
Modules do not match:
sig
module F :
functor (Wrong : sig type wrong end)
(X : sig module type t module M : t end) -> X.t
end
is not included in
sig
module F :
functor
(X : sig
module type T
module type t = T -> T -> T
module M : t
end)
-> X.T -> X.T -> X.T
end
In module F:
Modules do not match:
functor (Wrong : ...(Wrong)) (X : ...(X)) X/2.T X/2.T -> ...
is not included in
functor (X : ...(X)) X/3.T X/3.T -> ...
1. An extra argument is provided of module type
...(Wrong) = sig type wrong end
2. Module types ...(X) and ...(X) match
3. Module types X/3.T and X/2.T match
4. Module types X/3.T and X/2.T match
|}]


module M: sig
module F(_:sig end)(X:
sig
module type T
module type inner = sig
module type t
module M: t
end
module F(X: inner)(_:T -> T->T):
sig module type res = X.t end
module Y: sig
module type t = T -> T -> T
module M(X:T)(Y:T): T
end
end):
X.F(X.Y)(X.Y.M).res
end = struct
module F(_:sig type wrong end) (X:
sig module type T end
)(Res: X.T)(Res: X.T)(Res: X.T) = Res
end
[%%expect {|
Lines 17-21, characters 6-3:
17 | ......struct
18 | module F(_:sig type wrong end) (X:
19 | sig module type T end
20 | )(Res: X.T)(Res: X.T)(Res: X.T) = Res
21 | end
Error: Signature mismatch:
Modules do not match:
sig
module F :
sig type wrong end ->
functor (X : sig module type T end) (Res : X.T) (Res :
X.T) (Res : X.T)
-> X.T
end
is not included in
sig
module F :
sig end ->
functor
(X : sig
module type T
module type inner =
sig module type t module M : t end
module F :
functor (X : inner) -> (T -> T -> T) ->
sig module type res = X.t end
module Y :
sig
module type t = T -> T -> T
module M : functor (X : T) (Y : T) -> T
end
end)
-> X.F(X.Y)(X.Y.M).res
end
In module F:
Modules do not match:
functor (Arg : ...(Arg)) (X : ...(X)) (Res : X/2.T) (Res : X/2.T)
(Res : X/2.T) -> ...
is not included in
functor sig end (X : ...(X)) X/2.T X/2.T -> ...
1. Module types do not match:
...(Arg) = sig type wrong end
does not include
sig end
The type `wrong' is required but not provided
2. Module types ...(X) and ...(X) match
3. Module types X/2.T and X/2.T match
4. Module types X/2.T and X/2.T match
5. An extra argument is provided of module type X/2.T
|}]


(** The price of Gluttony: glutton update of environment leads to a non-optimal edit distance. *)

module F(X:sig type t end)(Y:sig type t = Y of X.t end)(Z:sig type t = Z of X.t end) = struct end
Expand Down
133 changes: 78 additions & 55 deletions typing/includemod.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -90,7 +90,7 @@ and ('arg,'path) functor_param_syndrom =
and arg_functor_param_syndrom =
(functor_parameter, Ident.t) functor_param_syndrom

and functor_params_diff = (functor_parameter list) core_diff
and functor_params_diff = (functor_parameter list * module_type) core_diff

and signature_symptom = {
env: Env.t;
Expand Down Expand Up @@ -405,8 +405,8 @@ and try_modtypes ~loc env ~mark dont_match subst mty1 mty2 =
| Error Incompatible_aliases ->
begin match mty1 with
| Mty_functor _ ->
let params1 = fst @@ retrieve_functor_params env mty1 in
let d = E.sdiff params1 [] in
let params1 = retrieve_functor_params env mty1 in
let d = E.sdiff params1 ([],mty2) in
dont_match E.(Functor (Params d))
| _ ->
dont_match E.(Mt_core Not_an_identifier)
Expand All @@ -428,20 +428,24 @@ and try_modtypes ~loc env ~mark dont_match subst mty1 mty2 =
| Ok Tcoerce_none, Ok Tcoerce_none -> Ok Tcoerce_none
| Ok cc_arg, Ok cc_res -> Ok (Tcoerce_functor(cc_arg, cc_res))
| _, Error {E.symptom = E.Functor E.Params res; _} ->
let d = E.sdiff (param1::res.got) (param2::res.expected) in
let got_params, got_res = res.got in
let expected_params, expected_res = res.expected in
let d = E.sdiff
(param1::got_params, got_res)
(param2::expected_params, expected_res) in
dont_match E.(Functor (Params d))
| Error _, _ ->
let params1 = fst (retrieve_functor_params env res1) in
let params2 = fst (retrieve_functor_params env res2) in
let d = E.sdiff (param1::params1) (param2::params2) in
let params1, res1 = retrieve_functor_params env res1 in
let params2, res2 = retrieve_functor_params env res2 in
let d = E.sdiff (param1::params1, res1) (param2::params2, res2) in
dont_match E.(Functor (Params d))
| Ok _, Error res ->
dont_match E.(Functor (Result res))
end
| Mty_functor _, _
| _, Mty_functor _ ->
let params1 = fst @@ retrieve_functor_params env mty1 in
let params2 = fst @@ retrieve_functor_params env mty2 in
let params1 = retrieve_functor_params env mty1 in
let params2 = retrieve_functor_params env mty2 in
let d = E.sdiff params1 params2 in
dont_match E.(Functor (Params d))
| _, Mty_alias _ ->
Expand Down Expand Up @@ -864,7 +868,39 @@ module FunctorDiff = struct
| Some _, None | None, Some _ -> 1
end

let arg_update d ((env, subst) as st) = match data d with
type state = {
res: module_type option;
env: Env.t;
subst: Subst.t;
}

let keep_expansible_param = function
| Mty_ident _ | Mty_alias _ as mty -> Some mty
| Mty_signature _ | Mty_functor _ -> None

let param_preprocess data =
let metadata =
match data with
| Named(x,_) -> x
| Unit -> None in
{ data; metadata }

let need_expansion env array = function
| None -> None
| Some res ->
match retrieve_functor_params env res with
| [], _ -> None
| params, res ->
let more = Array.of_list @@ List.map param_preprocess @@ params in
Some (keep_expansible_param res, Array.append array more)

let expand_arg_params state inner =
match need_expansion inner.env state.line inner.res with
| None -> { state with inner }
| Some (res, line) ->
{ state with line; inner = { inner with res } }

let arg_update d st = match data d with
| Insert (Unit | Named (None,_))
| Delete (Unit | Named (None,_))
| Keep (Unit,_,_)
Expand All @@ -874,80 +910,67 @@ module FunctorDiff = struct
| Insert (Named (Some p, arg))
| Delete (Named (Some p, arg))
| Change (Unit, Named (Some p, arg), _) ->
let arg' = Subst.modtype Keep subst arg in
Env.add_module p Mp_present arg' env, subst
let arg' = Subst.modtype Keep st.inner.subst arg in
let env = Env.add_module p Mp_present arg' st.inner.env in
expand_arg_params st { st.inner with env }
| Keep (Named (name1, _), Named (name2, arg2), _)
| Change (Named (name1, _), Named (name2, arg2), _) -> begin
let arg' = Subst.modtype Keep subst arg2 in
let arg' = Subst.modtype Keep st.inner.subst arg2 in
match name1, name2 with
| Some p1, Some p2 ->
Env.add_module p1 Mp_present arg' env,
Subst.add_module p2 (Path.Pident p1) subst
let env = Env.add_module p1 Mp_present arg' st.inner.env in
let subst = Subst.add_module p2 (Path.Pident p1) st.inner.subst in
expand_arg_params st { st.inner with env; subst }
| None, Some p2 ->
Env.add_module p2 Mp_present arg' env, subst
let env = Env.add_module p2 Mp_present arg' st.inner.env in
{ st with inner = { st.inner with env } }
| Some p1, None ->
Env.add_module p1 Mp_present arg' env, subst
let env = Env.add_module p1 Mp_present arg' st.inner.env in
expand_arg_params st { st.inner with env }
| None, None ->
env, subst
st
end

let param_preprocess data =
let metadata =
match data with
| Named(x,_) -> x
| Unit -> None in
{ data; metadata }

let arg_diff env0 _ctxt l1 l2 =
let arg_diff env0 _ctxt (l1,res1) (l2,_res2) =
let update = arg_update in
let test (env, subst) mty1 mty2 =
let test st mty1 mty2 =
let loc = Location.none in
let snap = Btype.snapshot () in
let res, _, _ =
functor_param ~loc env ~mark:Mark_neither subst mty1.data mty2.data
functor_param ~loc st.env ~mark:Mark_neither st.subst mty1.data
mty2.data
in
Btype.backtrack snap;
res
in
let state0 = (env0, Subst.identity) in
Diff.diff ~weight ~test ~update
state0
(Array.map param_preprocess @@ Array.of_list l1)
(Array.map param_preprocess @@ Array.of_list l2)
let state0 =
{ line = Array.map param_preprocess @@ Array.of_list l1;
col = Array.map param_preprocess @@ Array.of_list l2;
inner = {
env=env0;
subst = Subst.identity;
res = keep_expansible_param res1;
}
} in
Diff.dynamically_resized_diff ~weight ~test ~update state0

let data_preprocess (parg,_,_,fn) =
match fn with
| Unit -> None
| Named(_,mty) -> Some {path=parg; mty}

type app_state = {
res: module_type option;
env: Env.t;
subst: Subst.t;
}

let arg_preprocess (_,_,_,fn as data) =
let metadata =
match fn with
| Unit ->None
| Named(x,_) -> x in
{ data; metadata }

let keep_expansible_param = function
| Mty_ident _ | Mty_alias _ as mty -> Some mty
| Mty_signature _ | Mty_functor _ -> None

let expand_params st inner =
match inner.res with
let expand_app_params st inner =
match need_expansion inner.env st.col inner.res with
| None -> { st with inner }
| Some res ->
match retrieve_functor_params inner.env res with
| [], _ -> { st with inner }
| args, res ->
let more = Array.of_list @@ List.map param_preprocess @@ args in
let params = Array.append st.col more in
let res = keep_expansible_param res in
{ st with inner= { inner with res }; col = params }
| Some (res, col) ->
{ st with inner= { inner with res }; col }

let app_update d ({inner; _} as st) =
match Diff.map data_preprocess Fun.id (data d) with
Expand All @@ -968,13 +991,13 @@ module FunctorDiff = struct
let subst = Subst.add_module param arg Subst.identity in
Subst.modtype (Rescope scope) subst res) inner.res in
let subst = Subst.add_module param arg inner.subst in
expand_params st { st.inner with subst; res }
expand_app_params st { st.inner with subst; res }
| None, Some param ->
let env =
Env.add_module ~arg:true param Mp_present arg' inner.env in
let res =
Option.map (Mtype.nondep_supertype env [param]) inner.res in
expand_params st { inner with env; res}
expand_app_params st { inner with env; res}
| _, None -> st
end

Expand Down
5 changes: 5 additions & 0 deletions utils/compilerlibs_edit_distance.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,11 @@ val diff :
'state -> 'a array -> 'b array -> ('a, 'b, 'c, 'd) patch


(** Using the full state make it possible to resize the
number of lines and columns dynamically.
If only one side is ever expanded by the update function,
the patch computation is guaranteed to terminate *)
type ('inner,'line,'col) full_state =
{
line: 'line array;
Expand Down

0 comments on commit 8d629b6

Please sign in to comment.