From 955b5e6ff3dc28b8d518c424117e89c2d7d5d6eb Mon Sep 17 00:00:00 2001
From: charguer <arthur@chargueraud.org>
Date: Thu, 26 Nov 2015 11:00:43 +0100
Subject: [PATCH] pairs
---
generator/js_of_ast.ml | 49 ++++++++++++++++++++++++++------------
generator/tests/testctx.ml | 5 ++++
2 files changed, 39 insertions(+), 15 deletions(-)
diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index 098d259..49c8246 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -473,6 +473,15 @@ and js_of_expression_inline_or_wrap ctx e =
and js_of_expression_wrapped ctx e = (* dest = Dest_return *)
ppf_lambda_wrap (js_of_expression ctx Dest_return e)
+and js_of_expression_naming_argument_if_non_variable ctx obj name_prefix =
+ match obj.exp_desc with
+ | Texp_ident (_, ident, _) ->
+ "", (js_of_longident ident)
+ | _ -> (* generate var id = sexp; *)
+ let id = id_fresh "_switch_arg_" in
+ let sintro = js_of_expression ctx (Dest_assign id) obj in
+ (sintro ^ "@,"), id
+
and js_of_expression ctx dest e =
let inline_of_wrap = js_of_expression_inline_or_wrap ctx in (* shorthand *)
let loc = e.exp_loc in
@@ -488,13 +497,31 @@ and js_of_expression ctx dest e =
| Texp_let (_, vb_l, e) ->
reject_inline dest;
- let (ids,sdecls) = List.split (List.map (fun vb -> show_value_binding ctx vb) @@ vb_l) in
- let sdecl = String.concat lin1 @@ sdecls in
+ let (ids, sdecl) = begin match vb_l with
+ | [ { vb_pat = { pat_desc = Tpat_tuple el }; vb_expr = obj } ] -> (* binding tuples *)
+ let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_switch_arg_" in
+ let bind i var =
+ match var.pat_desc with
+ | Tpat_var (id, _) ->
+ let sid = ppf_ident id in
+ (sid, Printf.sprintf "%s[%d]" seobj i)
+ | Tpat_any -> out_of_scope var.pat_loc "Underscore pattern in let tuple"
+ | _ -> out_of_scope var.pat_loc "Nested pattern matching"
+ in
+ let binders = List.mapi bind el in
+ let ids = List.map fst binders in
+ let sdecl = ppf_match_binders binders in
+ (ids, sdecl)
+ | _ -> (* other cases *)
+ let (ids,sdecls) = List.split (List.map (fun vb -> show_value_binding ctx vb) @@ vb_l) in
+ let sdecl = String.concat lin1 @@ sdecls in
+ (ids, sdecl)
+ end in
let newctx = ctx_fresh() in
let sbody = js_of_expression newctx dest e in
let sexp = generate_logged_let ids ctx newctx sdecl sbody in
sexp
-
+
| Texp_function (_, c :: [], Total) ->
let rec explore pats e = match e.exp_desc with
| Texp_function (_, c :: [], Total) ->
@@ -527,19 +554,11 @@ and js_of_expression ctx dest e =
in
apply_dest ctx dest sexp
- | Texp_match (exp, l, [], Total) ->
+ | Texp_match (obj, l, [], Total) ->
reject_inline dest;
- let (sintro, seobj) =
- match exp.exp_desc with
- | Texp_ident (_, ident, _) ->
- "", (js_of_longident ident)
- | _ -> (* generate var id = sexp; *)
- let id = id_fresh "_switch_arg_" in
- let sintro = js_of_expression ctx (Dest_assign id) exp in
- (sintro ^ "@,"), id
- in
+ let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_switch_arg_" in
let sb = String.concat "@," (List.map (fun b -> js_of_branch ctx dest b seobj) l) in
- let const = exp_type_is_constant exp in
+ let const = exp_type_is_constant obj in
let sexp = sintro ^ (ppf_match seobj sb const) in
sexp
@@ -655,7 +674,7 @@ and js_of_pattern pat obj =
let binders = map_cstr_fields ~loc bind cd el in
spat, binders
| Tpat_var (id, _) -> unsupported ~loc "Tpat_var"
- | Tpat_tuple el -> unsupported ~loc "tuple matching"
+ | Tpat_tuple el -> unsupported ~loc "tuple matching, if not in a simple let-binding"
| Tpat_array el -> unsupported ~loc "array-match"
| Tpat_record (_,_) -> unsupported ~loc "record"
| Tpat_or (_,_,_) -> error ~loc "not implemented yet"
diff --git a/generator/tests/testctx.ml b/generator/tests/testctx.ml
index 2cc1040..9effd6c 100644
--- a/generator/tests/testctx.ml
+++ b/generator/tests/testctx.ml
@@ -1,4 +1,9 @@
+let testp1 x =
+ let (a,b,c) = x in
+ a+b
+
+
let testa x =
x
--
GitLab