From f9a7f229c52110978e624b2c4ea883546e2e6adc Mon Sep 17 00:00:00 2001
From: charguer <arthur@chargueraud.org>
Date: Wed, 6 Apr 2016 09:08:33 +0200
Subject: [PATCH] convert
---
generator/parse_type.ml | 2 +
generator/tests/jsref/JsInterpreter.ml | 94 ++++----
generator/tests/jsref/JsInterpreterMonads.ml | 7 +
.../tests/jsref/convert_monads_to_ppx.php | 224 ++++++++++++++++++
4 files changed, 284 insertions(+), 43 deletions(-)
create mode 100644 generator/tests/jsref/convert_monads_to_ppx.php
diff --git a/generator/parse_type.ml b/generator/parse_type.ml
index 71a81c9..96beaf6 100644
--- a/generator/parse_type.ml
+++ b/generator/parse_type.ml
@@ -59,6 +59,8 @@ exception Outdated_version
(** Parse a file or get a dumped syntax tree in it *)
let parse_file inputfile parse_fun ast_magic =
+(* TODO new version is:
+ let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in *)
let ic = open_in_bin inputfile in
let is_ast_file =
try
diff --git a/generator/tests/jsref/JsInterpreter.ml b/generator/tests/jsref/JsInterpreter.ml
index 153775e..458c6c0 100644
--- a/generator/tests/jsref/JsInterpreter.ml
+++ b/generator/tests/jsref/JsInterpreter.ml
@@ -364,7 +364,7 @@ and object_get_builtin s c b vthis l x =
| Coq_builtin_get_function -> function0 s
| Coq_builtin_get_args_obj ->
if_some (run_object_method object_parameter_map_ s l) (fun lmapo ->
- if_some lmapo (fun lmap ->
+ if_some (lmapo) (fun lmap ->
if_spec (run_object_get_own_prop s c lmap x)
(fun s0 d ->
match d with
@@ -883,7 +883,7 @@ and object_define_own_prop s c l x desc throwcont =
("Array length property descriptor cannot be accessor.")))
| Coq_builtin_define_own_prop_args_obj ->
if_some (run_object_method object_parameter_map_ s l) (fun lmapo ->
- if_some lmapo (fun lmap ->
+ if_some (lmapo) (fun lmap ->
if_spec (run_object_get_own_prop s c lmap x)
(fun s0 d ->
if_bool (def s0 x desc false) (fun s1 b0 ->
@@ -926,7 +926,13 @@ and run_to_descriptor s c _foo_ = match _foo_ with
if neg has
then k s1 desc
else if_value (run_object_get s1 c l name) (fun s2 v0 ->
- if_spec (conv s2 v0 desc) k))
+ if_spec (conv s2 v0 desc) (fun s3 r -> k s3 r)))
+ (*let%bool (s1,has) = object_has_prop s0 c l name in
+ if neg has
+ then k s1 desc
+ else let%value (s2,v0) = run_object_get s1 c l name in
+ let%spec (s3,r) = conv s2 v0 desc in
+ k s3 r))*)
in
sub0 s descriptor_intro_empty
("enumerable")
@@ -1051,7 +1057,7 @@ and to_object s _foo_ = match _foo_ with
and run_object_prim_value s l =
if_some (run_object_method object_prim_value_ s l) (fun ov ->
- if_some ov (fun v -> res_ter s (res_val v)))
+ if_some (ov) (fun v -> res_ter s (res_val v)))
(** val prim_value_get :
state -> execution_ctx -> value -> prop_name -> result **)
@@ -1114,7 +1120,7 @@ and object_delete s c l x str =
| Coq_builtin_delete_default -> object_delete_default s c l x str
| Coq_builtin_delete_args_obj ->
if_some (run_object_method object_parameter_map_ s l) (fun mo ->
- if_some mo (fun m ->
+ if_some (mo) (fun m ->
if_spec (run_object_get_own_prop s c m x) (fun s1 d ->
if_bool (object_delete_default s1 c l x str) (fun s2 b0 ->
if b0
@@ -1217,14 +1223,14 @@ and ref_get_value s c _foo_ = match _foo_ with
match r.ref_base with
| Coq_ref_base_type_value v ->
if ref_kind_comparable (ref_kind_of r) Coq_ref_kind_primitive_base
- then if_value (prim_value_get s c v r.ref_name) res_spec
+ then if_value (prim_value_get s c v r.ref_name) (fun s2 v -> res_spec s2 v)
else (match v with
| Coq_value_prim p ->
(fun s m -> Debug.impossible_with_heap_because __LOC__ s m; Coq_result_impossible)
s
("[ref_get_value] received a primitive value whose kind is not primitive.")
| Coq_value_object l ->
- if_value (run_object_get s c l r.ref_name) res_spec)
+ if_value (run_object_get s c l r.ref_name) (fun s2 v -> res_spec s2 v))
| Coq_ref_base_type_env_loc l ->
(fun s m -> Debug.impossible_with_heap_because __LOC__ s m; Coq_result_impossible)
s
@@ -1247,7 +1253,7 @@ and ref_get_value s c _foo_ = match _foo_ with
| Coq_ref_base_type_env_loc l ->
if_value
(env_record_get_binding_value s c l r.ref_name r.ref_strict)
- res_spec))
+ (fun s2 v -> res_spec s2 v)))
(* DEBUG
and ref_get_value runs s c r =
@@ -1872,12 +1878,12 @@ and run_construct s c co l args =
| Coq_construct_default -> run_construct_default s c l args
| Coq_construct_after_bind ->
if_some (run_object_method object_target_function_ s l) (fun otrg ->
- if_some otrg (fun target ->
+ if_some (otrg) (fun target ->
if_some (run_object_method object_construct_ s target) (fun oco ->
match oco with
| Some co0 ->
if_some (run_object_method object_bound_args_ s l) (fun oarg ->
- if_some oarg (fun boundArgs ->
+ if_some (oarg) (fun boundArgs ->
let_binding (LibList.append boundArgs args) (fun arguments_ ->
run_construct s c co0 target arguments_)))
| None -> run_error s Coq_native_error_type)))
@@ -1998,13 +2004,14 @@ and binding_inst_formal_params s c l args names str =
then follow s1
else if_void
(env_record_create_mutable_binding s1 c l argname
- None) follow))))
+ None) (fun s2 -> follow s2)))))
(** val binding_inst_function_decls :
state -> execution_ctx -> env_loc -> funcdecl list ->
strictness_flag -> bool -> result_void **)
and binding_inst_function_decls s c l fds str bconfig =
+
match fds with
| [] -> res_void s
| fd :: fds_2 ->
@@ -2063,7 +2070,7 @@ and binding_inst_function_decls s c l fds str bconfig =
else follow s2
else if_void
(env_record_create_mutable_binding s2 c l
- fname (Some bconfig)) follow)))))))
+ fname (Some bconfig)) (fun s3 -> follow s3))))))))
(** val make_arg_getter :
state -> execution_ctx -> prop_name -> lexical_env -> result **)
@@ -2248,7 +2255,7 @@ and binding_inst_var_decls s c l vds bconfig str =
then bivd s1
else if_void
(env_record_create_set_mutable_binding s1 c l vd (Some
- bconfig) (Coq_value_prim Coq_prim_undef) str) bivd))
+ bconfig) (Coq_value_prim Coq_prim_undef) str) (fun s2 -> bivd s2)))
(** val execution_ctx_binding_inst :
state -> execution_ctx -> codetype -> object_loc option ->
@@ -2285,7 +2292,7 @@ and execution_ctx_binding_inst s c ct funco p args =
then follow2 s2
else if_void
(binding_inst_arg_obj s2 c func p names
- args l) follow2
+ args l) (fun s3 -> follow2 s3)
| None ->
if bdefined
then follow2 s2
@@ -2300,7 +2307,7 @@ and execution_ctx_binding_inst s c ct funco p args =
| Some func ->
if_some (run_object_method object_formal_parameters_ s func)
(fun nameso ->
- if_some nameso (fun names ->
+ if_some (nameso) (fun names ->
if_void
(binding_inst_formal_params s c l args names str)
(fun s_2 -> follow s_2 names)))
@@ -2329,11 +2336,11 @@ and execution_ctx_binding_inst s c ct funco p args =
and entering_func_code s c lf vthis args =
if_some (run_object_method object_code_ s lf) (fun bdo ->
- if_some bdo (fun bd ->
+ if_some (bdo) (fun bd ->
let_binding (funcbody_is_strict bd) (fun str ->
let_binding (fun s_2 vthis_2 ->
if_some (run_object_method object_scope_ s_2 lf) (fun lexo ->
- if_some lexo (fun lex ->
+ if_some (lexo) (fun lex ->
let_binding (lexical_env_alloc_decl s_2 lex) (fun p ->
let (lex_2, s1) = p in
let_binding (execution_ctx_intro_same lex_2 vthis_2 str)
@@ -2353,10 +2360,10 @@ and entering_func_code s c lf vthis args =
| Coq_prim_null ->
follow s (Coq_value_object (Coq_object_loc_prealloc
Coq_prealloc_global))
- | Coq_prim_bool b -> if_value (to_object s vthis) follow
- | Coq_prim_number n -> if_value (to_object s vthis) follow
+ | Coq_prim_bool b -> if_value (to_object s vthis) (fun s2 v -> follow s2 v)
+ | Coq_prim_number n -> if_value (to_object s vthis) (fun s2 v -> follow s2 v)
| Coq_prim_string s0 ->
- if_value (to_object s vthis) follow)
+ if_value (to_object s vthis) (fun s2 v -> follow s2 v))
| Coq_value_object lthis -> follow s vthis)))))
(** val run_object_get_own_prop :
@@ -2382,7 +2389,7 @@ and run_object_get_own_prop s c l x =
| Coq_full_descriptor_some a ->
if_some (run_object_method object_parameter_map_ s1 l)
(fun lmapo ->
- if_some lmapo (fun lmap ->
+ if_some (lmapo) (fun lmap ->
if_spec (run_object_get_own_prop s1 c lmap x)
(fun s2 d0 ->
let_binding (fun s_2 a0 ->
@@ -2479,7 +2486,7 @@ and run_object_has_instance s c b l v =
lproto)))
| Coq_builtin_has_instance_after_bind ->
if_some (run_object_method object_target_function_ s l) (fun ol ->
- if_some ol (fun l0 ->
+ if_some (ol) (fun l0 ->
if_some (run_object_method object_has_instance_ s l0) (fun ob ->
match ob with
| Some b0 -> run_object_has_instance s c b0 l0 v
@@ -2528,7 +2535,7 @@ and from_prop_descriptor s c _foo_ = match _foo_ with
(object_define_own_prop s2 c l
("writable")
(descriptor_of_attributes (Coq_attributes_data_of a2))
- throw_false) follow)))
+ throw_false) (fun s3 v -> follow s3 v))))
| Coq_attributes_accessor_of aa ->
let_binding
(attributes_data_intro_all_true aa.attributes_accessor_get)
@@ -2543,7 +2550,8 @@ and from_prop_descriptor s c _foo_ = match _foo_ with
if_bool
(object_define_own_prop s2 c l ("set")
(descriptor_of_attributes (Coq_attributes_data_of a2))
- throw_false) follow)))))
+ throw_false) (fun s3 v -> follow s3 v))))
+ ))
(** val is_lazy_op : binary_op -> bool option **)
@@ -2762,21 +2770,21 @@ and convert_twice :
specres **)
and convert_twice_primitive s c v1 v2 =
- convert_twice if_prim (fun s0 v -> to_primitive s0 c v None) s v1 v2
+ convert_twice ifx_prim (fun s0 v -> to_primitive s0 c v None) s v1 v2
(** val convert_twice_number :
state -> execution_ctx -> value -> value ->
(number * number) specres **)
and convert_twice_number s c v1 v2 =
- convert_twice if_number (fun s0 v -> to_number s0 c v) s v1 v2
+ convert_twice ifx_number (fun s0 v -> to_number s0 c v) s v1 v2
(** val convert_twice_string :
state -> execution_ctx -> value -> value ->
(string * string) specres **)
and convert_twice_string s c v1 v2 =
- convert_twice if_string (fun s0 v -> to_string s0 c v) s v1 v2
+ convert_twice ifx_string (fun s0 v -> to_string s0 c v) s v1 v2
(** val issome : 'a1 option -> bool **)
@@ -2791,8 +2799,8 @@ match _foo_ with
and run_binary_op s c op v1 v2 =
if binary_op_comparable op Coq_binary_op_add
- then (* if_spec (convert_twice_primitive s c v1 v2) (fun s1 ww ->*)
- (let%spec (s1,ww) = convert_twice_primitive s c v1 v2 in
+ then if_spec (convert_twice_primitive s c v1 v2) (fun s1 ww ->
+ (* let%spec (s1,ww) = convert_twice_primitive s c v1 v2 in *)
let (w1, w2) = ww in
if or_decidable
(type_comparable (type_of (Coq_value_prim w1)) Coq_type_string)
@@ -3188,7 +3196,7 @@ and run_block s c _foo_ = match _foo_ with
| [] -> res_ter s (res_normal Coq_resvalue_empty)
| t :: ts_rev_2 ->
if_success (run_block s c ts_rev_2) (fun s0 rv0 ->
- if_success_state rv0 (run_stat s0 c t) (fun x x0 ->
+ ifx_success_state rv0 (run_stat s0 c t) (fun x x0 ->
result_out (Coq_out_ter (x, (res_normal x0)))))
(** val run_expr_binary_op :
@@ -3246,7 +3254,7 @@ and run_expr_assign s c opo e1 e2 =
| Some op ->
if_spec (ref_get_value s1 c rv1) (fun s2 v1 ->
if_spec (run_expr_get_value s2 c e2) (fun s3 v2 ->
- if_success (run_binary_op s3 c op v1 v2) follow))
+ if_success (run_binary_op s3 c op v1 v2) (fun s4 v -> follow s4 v)))
| None ->
if_spec (run_expr_get_value s1 c e2) (fun x x0 ->
follow x (Coq_resvalue_value x0))))
@@ -3389,7 +3397,7 @@ and run_expr_call s c e1 e2s =
s3
("[run_expr_call] unable to call a non-property function.")
| Coq_ref_base_type_env_loc l0 ->
- if_some (env_record_implicit_this_value s3 l0) follow))
+ if_some (env_record_implicit_this_value s3 l0) (fun s4 v -> follow s4 v)))
else run_error s3 Coq_native_error_type))))
(** val run_expr_conditionnal :
@@ -3493,7 +3501,7 @@ and run_stat_switch_end s c rv _foo_ = match _foo_ with
| [] -> result_out (Coq_out_ter (s, (res_normal rv)))
| y :: scs_2 ->
match y with Coq_switchclause_intro (e, ts) ->
- if_success_state rv (run_block s c (rev ts)) (fun s1 rv1 ->
+ ifx_success_state rv (run_block s c (rev ts)) (fun s1 rv1 ->
run_stat_switch_end s1 c rv1 scs_2)
(** val run_stat_switch_no_default :
@@ -3547,7 +3555,7 @@ and run_stat_switch_with_default_A s c found vi rv scs1 ts0 scs2 =
| y :: scs_2 ->
match y with Coq_switchclause_intro (e, ts) ->
let_binding (fun s0 ->
- if_success_state rv (run_block s0 c (rev ts)) (fun s1 rv0 ->
+ ifx_success_state rv (run_block s0 c (rev ts)) (fun s1 rv0 ->
run_stat_switch_with_default_A s1 c true vi rv0 scs_2 ts0 scs2))
(fun follow ->
if found
@@ -3636,7 +3644,7 @@ and run_stat_try s c t1 t2o t3o =
(env_record_create_set_mutable_binding s_2 c l x None v
throw_irrelevant) (fun s2 ->
let c_2 = execution_ctx_with_lex c lex_2 in
- if_ter (run_stat s2 c_2 t2) finallycont))))
+ if_ter (run_stat s2 c_2 t2) (fun s3 r -> finallycont s3 r)))))
| None -> finallycont s1 (res_throw (Coq_resvalue_value v))))
(** val run_stat_throw :
@@ -3946,7 +3954,7 @@ and run_get_args_for_apply s c l index n =
let_binding
(run_get_args_for_apply s1 c l (index +. 1.) n)
(fun tail_args ->
- if_spec tail_args (fun s2 tail -> res_spec s2 (v :: tail)))))
+ if_spec (tail_args) (fun s2 tail -> res_spec s2 (v :: tail)))))
else res_spec s []
(** val valueToStringForJoin :
@@ -3980,7 +3988,7 @@ and run_array_join_elements s c l k length0 sep sR =
if k < length0
then let_binding (strappend sR sep) (fun ss ->
let_binding (valueToStringForJoin s c l k) (fun sE ->
- if_spec sE (fun s0 element ->
+ if_spec (sE) (fun s0 element ->
let_binding (strappend ss element) (fun sR0 ->
run_array_join_elements s0 c l (k +. 1.)
length0 sep sR0))))
@@ -4270,7 +4278,7 @@ and run_call_prealloc s c b vthis args =
(ilen -.
(number_of_int (LibList.length a)))))
else res_spec s_2 0.)) (fun vlength ->
- if_spec vlength (fun s10 length0 ->
+ if_spec (vlength) (fun s10 length0 ->
let_binding { attributes_data_value =
(Coq_value_prim (Coq_prim_number
(of_int length0)));
@@ -4470,7 +4478,7 @@ and run_call_prealloc s c b vthis args =
(res_val (Coq_value_prim (Coq_prim_string "")))
else let_binding (valueToStringForJoin s3 c l 0.)
(fun sR ->
- if_spec sR (fun s4 sR0 ->
+ if_spec (sR) (fun s4 sR0 ->
run_array_join_elements s4 c l 1. ilen sep sR0))))))))
| Coq_prealloc_array_proto_pop ->
if_object (to_object s vthis) (fun s0 l ->
@@ -4557,17 +4565,17 @@ and run_call_prealloc s c b vthis args =
and run_call s c l vthis args =
if_some (run_object_method object_call_ s l) (fun co ->
- if_some co (fun c0 ->
+ if_some (co) (fun c0 ->
match c0 with
| Coq_call_default -> entering_func_code s c l vthis args
| Coq_call_after_bind ->
if_some (run_object_method object_bound_args_ s l) (fun oarg ->
- if_some oarg (fun boundArgs ->
+ if_some (oarg) (fun boundArgs ->
if_some (run_object_method object_bound_this_ s l) (fun obnd ->
- if_some obnd (fun boundThis ->
+ if_some (obnd) (fun boundThis ->
if_some (run_object_method object_target_function_ s l)
(fun otrg ->
- if_some otrg (fun target ->
+ if_some (otrg) (fun target ->
let_binding (LibList.append boundArgs args)
(fun arguments_ ->
run_call s c target boundThis arguments_)))))))
diff --git a/generator/tests/jsref/JsInterpreterMonads.ml b/generator/tests/jsref/JsInterpreterMonads.ml
index 3912e4f..15e0a29 100644
--- a/generator/tests/jsref/JsInterpreterMonads.ml
+++ b/generator/tests/jsref/JsInterpreterMonads.ml
@@ -381,3 +381,10 @@ let if_spec w k =
| Coq_specret_val (s0, a) -> k s0 a
| Coq_specret_out o -> if_abort o (fun x -> res_out o))
+
+
+
+let ifx_prim w k = if_prim w k
+let ifx_number w k = ifx_number w k
+let ifx_string w k = ifx_string w k
+let ifx_success_state a b c = if_success_state a b c
diff --git a/generator/tests/jsref/convert_monads_to_ppx.php b/generator/tests/jsref/convert_monads_to_ppx.php
new file mode 100644
index 0000000..f9db8ff
--- /dev/null
+++ b/generator/tests/jsref/convert_monads_to_ppx.php
@@ -0,0 +1,224 @@
+<?php
+
+// usage: php -f convert_monads_to_ppx.php
+
+/*
+$x = "aa";
+$y = $x;
+$y[1] = "c";
+//$x[0] = "b";
+//$x[1] = "d";
+printf("%s %s\n", $x, $y);
+*/
+
+
+$input = "JsInterpreter.ml";
+$output = "JsOutput.ml";
+
+$sinput = file_get_contents($input);
+/*
+
+$sinput = <<<EOF
+
+
+and run_expr_assign s c opo e1 e2 =
+ if_success (run_expr s c e1) (fun s1 rv1 ->
+ let_binding (fun s0 rv_2 ->
+ match rv_2 with
+ | Coq_resvalue_empty ->
+ (fun s m -> Debug.impossible_with_heap_because __LOC__ s m; Coq_result_impossible)
+ s0
+ ("Non-value result in [run_expr_assign].")
+ | Coq_resvalue_value v ->
+ if_void (ref_put_value s0 c rv1 v) (fun s_2 ->
+ result_out (Coq_out_ter (s_2, (res_val v))))
+ | Coq_resvalue_ref r ->
+ (fun s m -> Debug.impossible_with_heap_because __LOC__ s m; Coq_result_impossible)
+ s0
+ ("Non-value result in [run_expr_assign]."))
+ (fun follow ->
+ match opo with
+ | Some op ->
+ if_spec (ref_get_value s1 c rv1) (fun s2 v1 ->
+ if_spec (run_expr_get_value s2 c e2) (fun s3 v2 ->
+ if_success (run_binary_op s3 c op v1 v2) (fun s4 v -> follow s4 v)))
+ | None ->
+ if_spec (run_expr_get_value s1 c e2) (fun x x0 ->
+ follow x (Coq_resvalue_value x0))))
+EOF;
+*/
+$ninput = strlen($sinput);
+
+/*
+$matches = array();
+$n = preg_match('/\G\s*run_([^ ]*)/', $sinput, $matches, PREG_OFFSET_CAPTURE, 3);
+print_r($matches);
+exit;
+*/
+//printf("%d\n", $n);
+
+
+//printf("%s\n", $sinput);
+
+/*
+let if_some op k =
+let if_some_or_default o d k =
+let if_result_some w k =
+let if_out_some w k =
+let if_ter w k =
+let if_success_state rv w k =
+let if_success w k =
+let if_void w k =
+let if_not_throw w k =
+let if_any_or_throw w k1 k2 =
+let if_success_or_return w k1 k2 =
+let if_break w k =
+let if_value w k =
+let if_bool w k =
+let if_object w k =
+let if_string w k =
+let if_number w k =
+let if_prim w k =
+let if_abort o k =
+let if_spec w k =
+*/
+
+function fail($s, $i) {
+ global $sinput;
+ printf("error: %s\n", $s);
+ printf("at: %s\n", substr($sinput, $i, 200));
+ exit(1);
+}
+
+
+// return index of matching parent
+function matching_parenthesis($iOpenParent) {
+ global $sinput, $ninput;
+ if ($sinput[$iOpenParent] != "(") {
+ fail("matching not open", $iOpenParent);
+ }
+ $d = 1;
+ for ($i = $iOpenParent+1; $i < $ninput; $i++) {
+ $c = $sinput[$i];
+ if ($c == '(') {
+ $d++;
+ } else if ($c == ')') {
+ $d--;
+ if ($d == 0) {
+ return $i;
+ }
+ }
+ }
+ return -1;
+}
+
+
+$soutput = '';
+
+function process($start, $stop) {
+ //printf("process %d to %d\n", $start, $stop);
+ global $sinput, $soutput;
+ for ($i = $start; $i <= $stop;) {
+ $matches = array();
+ $n = preg_match('/if_([^ \n]*)/', $sinput, $matches, PREG_OFFSET_CAPTURE, $i);
+ if ($n != 1) {
+ break;
+ }
+ $occ = $matches[0][1];
+ if ($occ > $stop) {
+ break;
+ }
+ $npat = strlen($matches[0][0]);
+ $key = $matches[1][0];
+ if ($key == "some_or_default" || $key == "empty_label" || $key == "any_or_throw" || $key == "empty") {
+ $i = $occ+1;
+ continue;
+ }
+ //printf("in %d to %d, offset %d, found %s at %s\n", $start, $stop, $i, $key, $occ);
+ //print_r($matches);
+ $matches1 = $matches;
+ $add = substr($sinput, $i, ($occ-1) - $i + 1);
+ $soutput .= $add;
+
+ $n = preg_match('/\G\s*(\()/', $sinput, $matches, PREG_OFFSET_CAPTURE, $occ + $npat);
+ if ($n != 1) {
+ fail("no open parent for first arg of monad", $occ);
+ }
+ $open = $matches[1][1];
+ if ($open > $stop) {
+ fail("no open parent for first arg of monad", $occ);
+ }
+ $close = matching_parenthesis($open);
+ //printf("-- first open from %d to %d\n", $open, $close);
+ if ($close == -1 || $close > $stop) {
+ fail("unclosed first parent", $open);
+ }
+
+ $matches = array();
+ $n = preg_match('/\G\s*(\(fun(.*?)->[ ]*)/', $sinput, $matches, PREG_OFFSET_CAPTURE, $close+1);
+ if ($n != 1) {
+ printf("key = '%s'\n", $key);
+ printf("when: %s\n", substr($sinput, $occ, 100));
+ fail("no bopen parent for second arg of monad", $close+1);
+ }
+ $bopen = $matches[1][1];
+ if ($bopen > $stop) {
+ fail("no bopen parent for second arg of monad", $occ);
+ }
+ //print_r($matches);
+ $bsize = strlen($matches[1][0]);
+ $args = $matches[2][0];
+ // printf("args=%s\n", $args);
+ $args_pieces = preg_split('/\s+/', $args, NULL, PREG_SPLIT_NO_EMPTY);
+ // print_r($args_pieces);
+ if (count($args_pieces) == 1) {
+ $arg = $args_pieces[0];
+ } else if (count($args_pieces) == 2) {
+ $arg = "(" . $args_pieces[0] . "," . $args_pieces[1] . ")";
+ } else {
+ printf("when: %s\n", substr($sinput, $i, 100));
+ printf("added: %s\n", $add);
+ print_r($matches1);
+ print_r($matches);
+ print_r($args_pieces);
+ fail("invalid count for pieces: " . count($args_pieces), $close);
+ }
+
+ $bclose = matching_parenthesis($bopen);
+ if ($bclose == -1 || $bclose > $stop) {
+ printf("bclose=%d, stop=%d\n", $bclose, $stop);
+ printf("bopen: %s\n", substr($sinput, $bopen, 100));
+ printf("when: %s\n", substr($sinput, $occ, 100));
+ fail("unclosed second parent", $bopen);
+ }
+ $sinput[$bclose] = " ";
+ // &("-- second from %d to %d\n", $bopen, $bclose);
+ $len = ($close - 1) - ($open + 1) + 1;
+ $def = substr($sinput, $open + 1, $len);
+ $add = 'let%' . $key . " " . $arg . ' = ' . $def . " in\n";
+ // printf("-- add: %s\n", $add);
+ $soutput .= $add;
+
+ $sub = $bopen + $bsize;
+ $n = preg_match('/\G[ ]*(\n)/', $sinput, $matches, PREG_OFFSET_CAPTURE, $sub);
+ if ($n == 1) {
+ $sub = $matches[1][1] + 1;
+ }
+ process($sub, $bclose - 1);
+ $i = $bclose + 1;
+ // printf("-- continue at offset: %d\n", $i);
+ }
+ if ($i <= $stop) {
+ $add = substr($sinput, $i, $stop - $i);
+ $soutput .= $add;
+ }
+ // printf("-- add rest: %s\n", $add);
+ // printf("return %d to %d\n", $start, $stop);
+}
+
+
+process(0, $ninput-1);
+ file_put_contents($output, $soutput);
+// printf("%s\n", $soutput);
+
+?>
\ No newline at end of file
--
GitLab