Pretty_print_lem.untuple_args_pat: temporary hack to allow functions that actually take a tuple argument

1 files changed, 26 insertions, 21 deletions

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 232c3aee..8138a04e 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1238,27 +1238,32 @@ let args_of_typ l env typ =
     E_aux (E_id id, (l, mk_tannot env typ no_effect)) in
   List.split (List.mapi arg typs)
 
-let rec untuple_args_pat (P_aux (paux, ((l, _) as annot)) as pat) =
-  let env = env_of_annot annot in
-  let (Typ_aux (taux, _)) = typ_of_annot annot in
+let rec untuple_args_pat fun_typ (P_aux (paux, ((l, _) as annot)) as pat) =
   let identity = (fun body -> body) in
-  match paux, taux with
-  | P_tup [], _ ->
-     let annot = (l, mk_tannot Env.empty unit_typ no_effect) in
-     [P_aux (P_lit (mk_lit L_unit), annot)], identity
-  | P_tup pats, _ -> pats, identity
-  | P_wild, Typ_tup typs ->
-     let wild typ = P_aux (P_wild, (l, mk_tannot env typ no_effect)) in
-     List.map wild typs, identity
-  | P_typ (_, pat), _ -> untuple_args_pat pat
-  | P_as _, Typ_tup _ | P_id _, Typ_tup _ ->
-     let argpats, argexps = args_of_typ l env (pat_typ_of pat) in
-     let argexp = E_aux (E_tuple argexps, annot) in
-     let bindargs (E_aux (_, bannot) as body) =
-       E_aux (E_let (LB_aux (LB_val (pat, argexp), annot), body), bannot) in
-     argpats, bindargs
-  | _, _ ->
-     [pat], identity
+  let env = env_of_annot annot in 
+  (* Hack until we get proper multiple-argument-patterns *)
+  match fun_typ with
+  | Typ_aux(Typ_fn([_], _, _), _) -> [pat], identity
+  | _ -> begin
+      let (Typ_aux (taux, _)) = typ_of_annot annot in
+      match paux, taux with
+      | P_tup [], _ ->
+         let annot = (l, mk_tannot Env.empty unit_typ no_effect) in
+         [P_aux (P_lit (mk_lit L_unit), annot)], identity
+      | P_tup pats, _ -> pats, identity
+      | P_wild, Typ_tup typs ->
+         let wild typ = P_aux (P_wild, (l, mk_tannot env typ no_effect)) in
+         List.map wild typs, identity
+      | P_typ (_, pat), _ -> untuple_args_pat fun_typ pat
+      | P_as _, Typ_tup _ | P_id _, Typ_tup _ ->
+         let argpats, argexps = args_of_typ l env (pat_typ_of pat) in
+         let argexp = E_aux (E_tuple argexps, annot) in
+         let bindargs (E_aux (_, bannot) as body) =
+           E_aux (E_let (LB_aux (LB_val (pat, argexp), annot), body), bannot) in
+         argpats, bindargs
+      | _, _ ->
+         [pat], identity
+    end
 
 let doc_rec_lem force_rec (Rec_aux(r,_)) = match r with
   | Rec_nonrec when not force_rec -> space
@@ -1281,7 +1286,7 @@ let doc_funcl_lem (FCL_aux(FCL_Funcl(id, pexp), annot)) =
     { early_ret = contains_early_return exp;
       bound_nexps = NexpSet.union (lem_nexps_of_typ typ) (typeclass_nexps typ);
       top_env = env_of_annot annot } in
-  let pats, bind = untuple_args_pat pat in
+  let pats, bind = untuple_args_pat (typ_of_annot annot) pat in
   let patspp = separate_map space (doc_pat_lem ctxt true) pats in
   let _ = match guard with
     | None -> ()