diff options
Diffstat (limited to 'typing/includemod.ml')
| -rw-r--r-- | typing/includemod.ml | 49 |
1 files changed, 31 insertions, 18 deletions
diff --git a/typing/includemod.ml b/typing/includemod.ml index c15a53808e..d92b0fe090 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -41,7 +41,10 @@ type symptom = | Invalid_module_alias of Path.t type pos = - Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t + | Module of Ident.t + | Modtype of Ident.t + | Arg of functor_parameter + | Body of functor_parameter type error = pos list * Env.t * symptom exception Error of error list @@ -294,25 +297,32 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 = try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype Keep subst mty2) | (Mty_signature sig1, Mty_signature sig2) -> signatures ~loc env ~mark cxt subst sig1 sig2 - | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) -> + | (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) -> begin - match modtypes ~loc env ~mark (Body param1::cxt) subst res1 res2 with + match modtypes ~loc env ~mark (Body Unit::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)) -> + | (Mty_functor(Named (param1, arg1) as arg, res1), + Mty_functor(Named (param2, arg2), res2)) -> let arg2' = Subst.modtype Keep subst arg2 in let cc_arg = modtypes ~loc env ~mark:(negate_mark mark) - (Arg param1::cxt) Subst.identity arg2' arg1 + (Arg arg::cxt) Subst.identity arg2' arg1 in - let cc_res = - modtypes ~loc (Env.add_module param1 Mp_present arg2' env) ~mark - (Body param1::cxt) - (Subst.add_module param2 (Path.Pident param1) subst) - res1 res2 + let env, subst = + match param1, param2 with + | Some p1, Some p2 -> + Env.add_module p1 Mp_present arg2' env, + Subst.add_module p2 (Path.Pident p1) subst + | None, Some p2 -> + Env.add_module p2 Mp_present arg2' env, subst + | Some p1, None -> + Env.add_module p1 Mp_present arg2' env, subst + | None, None -> + env, subst in + let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in begin match (cc_arg, cc_res) with (Tcoerce_none, Tcoerce_none) -> Tcoerce_none | _ -> Tcoerce_functor(cc_arg, cc_res) @@ -661,8 +671,10 @@ module Illegal_permutation = struct | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type | _ -> raise Not_found end - | Mty_functor(x,Some mt,_), InArg :: q -> find env (Arg x :: ctx) q mt - | Mty_functor(x,_,mt), InBody :: q -> find env (Body x :: ctx) q mt + | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> + find env (Arg arg :: ctx) q mt + | Mty_functor(arg, mt), InBody :: q -> + find env (Body arg :: ctx) q mt | _ -> raise Not_found let find env path mt = find env [] path mt @@ -716,7 +728,7 @@ let rec context ppf = function | Body x :: rem -> fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem + fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem | [] -> fprintf ppf "<here>" and context_mty ppf = function @@ -727,12 +739,13 @@ and args ppf = function Body x :: rem -> fprintf ppf "(%s)%a" (argname x) args rem | Arg x :: rem -> - fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem + fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem | cxt -> fprintf ppf " :@ %a" context_mty cxt -and argname x = - let s = Ident.name x in - if s = "*" then "" else s +and argname = function + | Unit -> "" + | Named (None, _) -> "_" + | Named (Some id, _) -> Ident.name id let alt_context ppf cxt = if cxt = [] then () else |