Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- diff --git a/typing/typecore.ml b/typing/typecore.ml
- index 848c8e6..0561de4 100644
- --- a/typing/typecore.ml
- +++ b/typing/typecore.ml
- @@ -1476,14 +1476,43 @@ and type_argument env sarg ty_expected' =
- | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
- type_expect env sarg ty_expected
- | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
- - (* apply optional arguments when expected type is "" *)
- - (* we must be very careful about not breaking the semantics *)
- + (* We are in the situation of typing the argument
- + of an application`f a`, with
- + f : (t -> u) -> v
- + a : ?l1:t1 -> ?l2:t2 -> ... -> ?ln:tn -> t -> u
- +
- + In this situation, we will implicitly coerce the argument `a`
- + into the desired type `t -> u` by feeding the default 'None'
- + argument to its optional parameters.
- +
- + Note that functions with optional arguments must always have
- + a non-optinal argument after their optional argument, that's
- + how we now that, after ?l1..?ln, the type of a is still an
- + function type `t -> u`. (We allow to coerce only if f's
- + function argument expects no optional parameter at all, not
- + only less than `a` requests.)
- +
- + `f (a ~l1:None ~l2:None ... ~ln:None)` would be type-correct,
- + but would not respect the semantics we expect: we want the
- + application of the default arguments to happen when `a` is
- + used as a function (passed an argument of type `t`). To
- + respect that semantics, we delay the application of the
- + default argument to whenever `a` is used as a function inside
- + `f`, by eta-expansion
- +
- + f (let x = a in fun (y:t) -> x ~l1:None ... ~ln:None y)
- +
- + (Note that the use of `let x = a in` preserves the evaluation
- + of `a` at the application site `f a`, instead of being delayed
- + and repeated by the eta-expansion closure.)
- + *)
- if !Clflags.principal then begin_def ();
- let texp = type_exp env sarg in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure texp.exp_type
- end;
- + (* collect the optional labels ~l1 .. ~ln for application of None *)
- let rec make_args args ty_fun =
- match (expand_head env ty_fun).desc with
- | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
- @@ -1507,7 +1536,7 @@ and type_argument env sarg ty_expected' =
- end else begin
- unify_exp env {texp with exp_type = ty_fun} ty_expected;
- if args = [] then texp else
- - (* eta-expand to avoid side effects *)
- + (* eta-expand (delay application-time side effects) *)
- let var_pair name ty =
- let id = Ident.create name in
- {pat_desc = Tpat_var id; pat_type = ty;
- @@ -1525,7 +1554,8 @@ and type_argument env sarg ty_expected' =
- if warn then Location.prerr_warning texp.exp_loc
- (Warnings.Without_principality "eliminated optional argument");
- if is_nonexpansive texp then func texp else
- - (* let-expand to have side effects *)
- + (* let-expand (avoid having side-effects of [texp] delayed by
- + eta-expanding) *)
- let let_pat, let_var = var_pair "let" texp.exp_type in
- re { texp with exp_type = ty_fun; exp_desc =
- Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
Add Comment
Please, Sign In to add comment