Merge pull request ocaml#1353 from ocaml/construct-funs

[Construct] eagerly build functions

src/analysis/construct.ml

@@ -278,6 +278,11 @@ module Gen = struct
         (* else we return a hole *)
         [ Ast_helper.Exp.hole () ]
     in
+    let arrow_rhs env typ =
+      match (Ctype.repr typ).desc with
+      | Tarrow _ -> expression ~idents_table values_scope ~depth env typ
+      | _ -> exp_or_hole env typ
+    in
 
     (* [make_arg] tries to provide a nice default name for function args *)
     let make_arg =
@@ -442,7 +447,7 @@ module Gen = struct
             }
           in
           let env = Env.add_value (Ident.create_local name) value_description env in
-          let exps = exp_or_hole env tyright in
+          let exps = arrow_rhs env tyright in
           List.map exps ~f:(Ast_helper.Exp.fun_ label None argument)
         | Ttuple types ->
           let choices = List.map types ~f:(exp_or_hole env)

src/ocaml/parsing/pprintast.ml

@@ -600,6 +600,12 @@ and sugar_expr ctxt f e =
     end
   | _ -> false
 
+and uncurry params e =
+  match e.pexp_desc with
+  | Pexp_fun (l, e0, p, e) ->
+    uncurry ((l, e0, p) :: params) e
+  | _ -> List.rev params, e
+
 and expression ctxt f x =
   if x.pexp_attributes <> [] then
     pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
@@ -616,9 +622,10 @@ and expression ctxt f x =
         when ctxt.semi ->
         paren true (expression reset_ctxt) f x
     | Pexp_fun (l, e0, p, e) ->
+        let params, body = uncurry [l, e0, p] e in
         pp f "@[<2>fun@;%a->@;%a@]"
-          (label_exp ctxt) (l, e0, p)
-          (expression ctxt) e
+          (pp_print_list (label_exp ctxt)) params
+          (expression ctxt) body
     | Pexp_newtype (lid, e) ->
         pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt
           (expression ctxt) e

tests/test-dirs/construct/c-simple.t

@@ -242,6 +242,24 @@ Test 3.2
   > let x : v:string -> float -> mytype -> mytype -> int = _
   > EOF
 
+  $ $MERLIN single construct -position 2:55 \
+  > -filename c32.ml <c32.ml | jq ".value"
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 55
+      },
+      "end": {
+        "line": 2,
+        "col": 56
+      }
+    },
+    [
+      "(fun ~v float mytype mytype_1 -> _)"
+    ]
+  ]
+
   $ $MERLIN single construct -depth 4 -position 2:55 \
   > -filename c32.ml <c32.ml | jq ".value"
   [
@@ -256,7 +274,7 @@ Test 3.2
       }
     },
     [
-      "(fun ~v -> fun float -> fun mytype -> fun mytype_1 -> _)"
+      "(fun ~v float mytype mytype_1 -> 0)"
     ]
   ]