Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
DIFF between OCaml 4.02.3 and 4.02.3+curried-constr
diff --git a/README_curried_constr.md b/README_curried_constr.md
new file mode 100644
index 0000000..12ed175
--- /dev/null
+++ b/README_curried_constr.md
@@ -0,0 +1,66 @@
+Variant constructors as functions
+==================================
+
+Suppose we have:
+
+```ocaml
+type t = Foo of int * float
+```
+
+Then
+
+```ocaml
+Foo
+```
+
+is equal to `fun (x,y) -> Foo (x,y)`. And,
+
+```ocaml
+(Foo ..) (* This is not valid in the vanilla OCaml *)
+```
+
+and
+```
+!Foo (* If you keep the vanilla syntax *)
+```
+
+are equal to `fun x y -> Foo (x,y)`.
+
+It works for list cons constructor too:
+
+```ocaml
+(::) : ('a * 'a list) -> 'a list
+(:: ..) : 'a -> 'a list -> 'a list
+!(::) : 'a -> 'a list -> 'a list
+```
+
+Polymorphic variants as functions
+---------------------------------------------
+
+```ocaml
+(`Foo ..) (* This is not valid in the vanilla OCaml *)
+!`Foo
+```
+
+are equivalent to
+
+```ocaml
+fun x -> `Foo x
+```
+
+Note that ``(`Foo ..)`` always take only one argument:
+the arity of the polymorphic variant constructors is at most one
+and it is determined purely syntactically.
+
+
+```ocaml
+(`Foo..) (1,2,3) (* `Foo (1,2,3) *)
+(`Foo..) 1 2 3 (* (`Foo 1) 2 3 which ends in a type error *)
+```
+
+Code ``(`Foo)`` has no special meaning. It is just equivalent to `` `Foo``.
+
+Samples
+---------------------------------------------
+
+You can try examples at `testsuite/curried_constr/test.ml`.
diff --git a/VERSION b/VERSION
index dbd6b8f..53e43b1 100644
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-4.02.3
+4.02.3+curried-constr
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
diff --git a/boot/ocamlc b/boot/ocamlc
index 41eb9b4..f1c354f 100755
Binary files a/boot/ocamlc and b/boot/ocamlc differ
diff --git a/boot/ocamldep b/boot/ocamldep
index 383b3d1..1cc76a9 100755
Binary files a/boot/ocamldep and b/boot/ocamldep differ
diff --git a/boot/ocamllex b/boot/ocamllex
index 8a2e0d8..57df0da 100755
Binary files a/boot/ocamllex and b/boot/ocamllex differ
diff --git a/testsuite/curried_constr/test.ml b/testsuite/curried_constr/test.ml
new file mode 100644
index 0000000..b181272
--- /dev/null
+++ b/testsuite/curried_constr/test.ml
@@ -0,0 +1,24 @@
+let x : int option = Some 1
+let x = (Some) 1
+let x = Some @@ 1
+(* let x = (Some..) 1 Error: Unary constructor cannot be curried. *)
+let x = (None)
+(* let x = (None..) Error: Nullary constructor cannot be curried. *)
+
+type t = Foo of int * float
+let x : t = (Foo) (1,1.0)
+
+let x : t = !Foo 1 1.0
+let x : int -> float -> t = !Foo
+let x : float -> t = !Foo 1
+let x : (int * float) -> t = Foo
+let x : (int * float) -> t = fun x -> (Foo) x
+
+(* (::)(x,xs) has a special parsing rule. We can handle it but requires parser.mly modificaiton *)
+let cons0 = (::)(1,[])
+(*
+let cons1 = ((::)) (1,[])
+let cons2 = !(::) 1 []
+*)
+
+
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d237cfe..c9e8e18 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -67,6 +67,7 @@ type error =
| Invalid_for_loop_index
| No_value_clauses
| Exception_pattern_below_toplevel
+ | Other of string
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
@@ -1885,6 +1886,49 @@ and type_expect_ ?in_function env sexp ty_expected =
| Pexp_function caselist ->
type_function ?in_function
loc sexp.pexp_attributes env ty_expected "" caselist
+
+ (* ((!F) 1) 2 3 == !F 1 2 3
+
+ We here to try contract applications as possible...
+ *)
+ | Pexp_apply ( { pexp_desc = Pexp_apply(x,xs);
+ pexp_attributes = [] }, ys ) ->
+
+ type_expect_ ?in_function env
+ { sexp with pexp_desc = Pexp_apply (x, xs @ ys) }
+ ty_expected
+
+ | Pexp_apply({ pexp_desc = Pexp_ident {txt=Longident.Lident "!"; loc=loc'} },
+ ("", ({ pexp_desc = Pexp_construct (lid, None) } as con)) :: xs) ->
+ (* ! C a b *)
+ type_construct_curried ?in_function env loc ty_expected
+ sexp.pexp_attributes
+ con loc' xs
+
+ | Pexp_apply({ pexp_desc = Pexp_ident {txt=Longident.Lident "!"; loc=loc'} },
+ ("", ({ pexp_desc = Pexp_variant (l, None) } as e)) :: xs) ->
+ (* ! `F a b *)
+ let open Ast_helper in
+ begin match xs with
+ | ("",x)::xs -> (* (`A..) a b => (`A a) b *)
+ let sexp = Exp.apply ~loc { e with pexp_desc = Pexp_variant (l, Some x) } xs in
+ type_expect_ ?in_function env sexp ty_expected
+ | [] -> (* (`A..) => fun x -> `A x *)
+ let pat = Pat.var ~loc:loc' {txt="x"; loc=loc'} in
+ let var = Exp.ident ~loc:loc' {txt=Longident.Lident "x"; loc=loc'} in
+ let sexp = Ast_helper.Exp.fun_ ~loc "" None pat
+ { e with pexp_desc = Pexp_variant (l, Some var) }
+ in
+ type_expect_ ?in_function env sexp ty_expected
+ | _ -> assert false (* CR jfuruse: TODO *)
+ end
+
+ (*
+ [(Some) e] and [Some @@ e] should be translated to [Some e],
+ not [(fun x -> Some x) e], but this optimization should be done in
+ bytecomp level, not here. And actually bytecomp does it!
+ *)
+
| Pexp_apply(sfunct, sargs) ->
if sargs = [] then
Syntaxerr.ill_formed_ast loc "Function application with no argument.";
@@ -1972,7 +2016,12 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
exp_attributes = sexp.pexp_attributes;
exp_env = env }
- | Pexp_construct(lid, sarg) ->
+ | Pexp_construct(lid, None) ->
+ (* None or (Some) *)
+ (* type_construct env loc lid sarg ty_expected sexp.pexp_attributes *)
+ type_construct_maybe_uncurried ?in_function env loc ty_expected sexp lid
+ | Pexp_construct(lid, sarg) ->
+ (* Some e *)
type_construct env loc lid sarg ty_expected sexp.pexp_attributes
| Pexp_variant(l, sarg) ->
(* Keep sharing *)
@@ -3382,6 +3431,142 @@ and type_construct env loc lid sarg ty_expected attrs =
{ texp with
exp_desc = Texp_construct(lid, constr, args) }
+and type_construct_curried ?in_function env loc ty_expected app_attrs sexp apploc xs =
+
+ let lid = match sexp.pexp_desc with
+ | Pexp_construct (lid, None) -> lid
+ | _ -> assert false (* impos *)
+ in
+
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_variant env ty_expected in
+ Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+ let constr =
+ wrap_disambiguate "This variant expression is expected to have" ty_expected
+ (Constructor.disambiguate lid env opath) constrs in
+ Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
+
+ match constr.cstr_arity with
+ | 0 ->
+ (* !None must be rejected *)
+ raise (Error(loc, env, Other "Nullary constructor cannot be curried."))
+ | 1 ->
+ (* !Some must be rejected *)
+ raise (Error(loc, env, Other "Unary constructor cannot be curried."))
+ | n ->
+ (* Format.eprintf "Debug: applied args: %d@." (List.length xs); *)
+ (* Unlike (Some) x, here we should optimize partial applications *)
+ (* !C a1 => (fun a2 a3 -> C (a1,a2,a3)) *)
+ (* !C a1 a2 a3 => C (a1,a2,a3) *)
+ (* !C a1 a2 a3 a4 => C (a1,a2,a3) a4 *)
+ let open Ast_helper in
+ let patterns, sarg, remain =
+ let xi i = Exp.ident {txt=Longident.Lident ("x" ^ string_of_int i); loc=Location.none} in
+ let pi i = Pat.var {txt="x" ^ string_of_int i; loc=Location.none} in
+ let rec loop i xs =
+ if i > n then [], [], xs
+ else
+ match xs with
+ | [] ->
+ let patterns, args, remain = loop (i+1) [] in
+ assert (remain = []);
+ pi i :: patterns,
+ xi i :: args,
+ []
+ | (l,x)::xs ->
+ assert (l = ""); (* CR jfuruse: TODO *)
+ let patterns, args, remain = loop (i+1) xs in
+ patterns,
+ x :: args,
+ remain
+ in
+ let patterns, args, remain = loop 1 xs in
+ patterns,
+ begin match args with
+ | [] -> assert false
+ | [sarg] -> sarg
+ | args -> Exp.tuple args
+ end,
+ remain
+ in
+ match patterns, remain with
+ | [], [] -> (* C (a1,a2,a3) *)
+ (* Format.eprintf "Debug0: full@."; *)
+ type_construct env loc lid (Some sarg) ty_expected app_attrs
+ | [], _ -> (* C (a1,a2,a3) a4 a5 *)
+ (* clearly an error but we delegate to the original typer *)
+ let sexp =
+ Exp.apply ~loc:apploc ~attrs:app_attrs
+ { sexp with pexp_desc = Pexp_construct (lid, Some sarg) }
+ remain
+ in
+ (* Format.eprintf "Debug1: %a@." Pprintast.expression sexp; *)
+ type_expect_ ?in_function env sexp ty_expected
+ | _, [] -> (* fun a3 -> C (a1,a2,a3) *)
+ let sexp =
+ let rec funs = function
+ | [] ->
+ { sexp with pexp_desc = Pexp_construct (lid, Some sarg) }
+ | x::xs ->
+ Exp.fun_ ~loc:apploc ~attrs:app_attrs
+ "" None x
+ (funs xs)
+ in
+ funs patterns
+ in
+ (* Format.eprintf "Debug2: %a@." Pprintast.expression sexp; *)
+ type_expect_ ?in_function env sexp ty_expected
+ | _, _ -> assert false
+
+and type_construct_maybe_uncurried ?in_function env loc ty_expected sexp lid =
+ (* None or (Some) *)
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_variant env ty_expected in
+ Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+ let constr =
+ wrap_disambiguate "This variant expression is expected to have" ty_expected
+ (Constructor.disambiguate lid env opath) constrs in
+ Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
+
+ match constr.cstr_arity with
+ | 0 -> (* None *)
+ type_construct env loc lid None ty_expected sexp.pexp_attributes
+ | 1 -> (* (Some) => fun x -> Some x *)
+ let sexp =
+ let open Ast_helper in
+ let p = Pat.var {txt= "x"; loc= Location.none } in
+ let x = Exp.ident {txt= Longident.Lident "x"; loc= Location.none } in
+ let e = { sexp with pexp_desc = Pexp_construct (lid, Some x) } in
+ Exp.fun_ "" None p e
+ in
+ type_expect_ ?in_function env sexp ty_expected
+
+ | n -> (* (F) => fun (x,y) -> F (x,y) *)
+ let sexp =
+ let open Ast_helper in
+ let make_n n f =
+ let rec loop st = function
+ | 0 -> List.rev st
+ | n -> loop (f n :: st) (n-1)
+ in
+ loop [] n
+ in
+ let names = make_n n (fun i -> "x" ^ string_of_int i) in
+ let p = Pat.(tuple (List.map (fun txt -> var {txt; loc= Location.none}) names)) in
+ let x = Exp.(tuple (List.map (fun txt -> ident {txt= Longident.Lident txt; loc= Location.none }) names)) in
+ let e = { sexp with pexp_desc = Pexp_construct (lid, Some x) } in
+ Exp.fun_ "" None p e
+ in
+ type_expect_ ?in_function env sexp ty_expected
+
(* Typing of statements (expressions whose values are discarded) *)
and type_statement env sexp =
@@ -3975,6 +4160,9 @@ let report_error env ppf = function
| Exception_pattern_below_toplevel ->
fprintf ppf
"@[Exception patterns must be at the top level of a match case.@]"
+ | Other s ->
+ fprintf ppf
+ "@[%s@]" s
let report_error env ppf err =
wrap_printing_env env (fun () -> report_error env ppf err)
diff --git a/typing/typecore.mli b/typing/typecore.mli
index ee16c3b..8b7e24a 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -112,6 +112,7 @@ type error =
| Invalid_for_loop_index
| No_value_clauses
| Exception_pattern_below_toplevel
+ | Other of string
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.