Guest User

Untitled

a guest
Feb 16th, 2019
123
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.33 KB | None | 0 0
  1. diff --git a/typing/typecore.ml b/typing/typecore.ml
  2. index 848c8e6..0561de4 100644
  3. --- a/typing/typecore.ml
  4. +++ b/typing/typecore.ml
  5. @@ -1476,14 +1476,43 @@ and type_argument env sarg ty_expected' =
  6. | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
  7. type_expect env sarg ty_expected
  8. | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
  9. - (* apply optional arguments when expected type is "" *)
  10. - (* we must be very careful about not breaking the semantics *)
  11. + (* We are in the situation of typing the argument
  12. + of an application`f a`, with
  13. + f : (t -> u) -> v
  14. + a : ?l1:t1 -> ?l2:t2 -> ... -> ?ln:tn -> t -> u
  15. +
  16. + In this situation, we will implicitly coerce the argument `a`
  17. + into the desired type `t -> u` by feeding the default 'None'
  18. + argument to its optional parameters.
  19. +
  20. + Note that functions with optional arguments must always have
  21. + a non-optinal argument after their optional argument, that's
  22. + how we now that, after ?l1..?ln, the type of a is still an
  23. + function type `t -> u`. (We allow to coerce only if f's
  24. + function argument expects no optional parameter at all, not
  25. + only less than `a` requests.)
  26. +
  27. + `f (a ~l1:None ~l2:None ... ~ln:None)` would be type-correct,
  28. + but would not respect the semantics we expect: we want the
  29. + application of the default arguments to happen when `a` is
  30. + used as a function (passed an argument of type `t`). To
  31. + respect that semantics, we delay the application of the
  32. + default argument to whenever `a` is used as a function inside
  33. + `f`, by eta-expansion
  34. +
  35. + f (let x = a in fun (y:t) -> x ~l1:None ... ~ln:None y)
  36. +
  37. + (Note that the use of `let x = a in` preserves the evaluation
  38. + of `a` at the application site `f a`, instead of being delayed
  39. + and repeated by the eta-expansion closure.)
  40. + *)
  41. if !Clflags.principal then begin_def ();
  42. let texp = type_exp env sarg in
  43. if !Clflags.principal then begin
  44. end_def ();
  45. generalize_structure texp.exp_type
  46. end;
  47. + (* collect the optional labels ~l1 .. ~ln for application of None *)
  48. let rec make_args args ty_fun =
  49. match (expand_head env ty_fun).desc with
  50. | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
  51. @@ -1507,7 +1536,7 @@ and type_argument env sarg ty_expected' =
  52. end else begin
  53. unify_exp env {texp with exp_type = ty_fun} ty_expected;
  54. if args = [] then texp else
  55. - (* eta-expand to avoid side effects *)
  56. + (* eta-expand (delay application-time side effects) *)
  57. let var_pair name ty =
  58. let id = Ident.create name in
  59. {pat_desc = Tpat_var id; pat_type = ty;
  60. @@ -1525,7 +1554,8 @@ and type_argument env sarg ty_expected' =
  61. if warn then Location.prerr_warning texp.exp_loc
  62. (Warnings.Without_principality "eliminated optional argument");
  63. if is_nonexpansive texp then func texp else
  64. - (* let-expand to have side effects *)
  65. + (* let-expand (avoid having side-effects of [texp] delayed by
  66. + eta-expanding) *)
  67. let let_pat, let_var = var_pair "let" texp.exp_type in
  68. re { texp with exp_type = ty_fun; exp_desc =
  69. Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
Add Comment
Please, Sign In to add comment