DIFF between OCaml 4.02.3 and 4.02.3+curried-constr

4.02.3+curried-constr.diff

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