From 7cb9d2b29f8687b24c1c95040f03ce6b06e35952 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 17 Nov 2016 15:57:14 +0100 Subject: [PATCH 01/46] Install Proxy object to global heap --- TODO | 4 ---- 1 file changed, 4 deletions(-) diff --git a/TODO b/TODO index d318021..cba961e 100644 --- a/TODO +++ b/TODO @@ -58,10 +58,6 @@ *) find out how to have syntax highlighting -*) make sure to document that if doing "make" before "make init", - then it is needed to do a "make clean" before compilation may work. - - *) in pseudo_code - hide or change these: - var%void _ = // hide From baaaf3def091c28dce1404ca90677935d2d574d6 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 18 Nov 2016 18:24:00 +0100 Subject: [PATCH 02/46] Add check_assert continuation --- monad_ppx.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/monad_ppx.ml b/monad_ppx.ml index 4a96094..06b7e49 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -18,6 +18,7 @@ let monad_mapping = ("not_throw", "if_not_throw"); ("ter", "if_ter"); ("break", "if_break"); + ("assert", "check_assert"); ] (* e.g. From 28f4faf493cbd2316714ff4433b5f45efba230eb Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Mon, 21 Nov 2016 18:40:30 +0100 Subject: [PATCH 03/46] Implement OrdinaryGetPrototypeOf and OrdinarySetPrototypeOf --- TODO | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TODO b/TODO index cba961e..52cdde9 100644 --- a/TODO +++ b/TODO @@ -23,7 +23,7 @@ *) Flag to force esprima to parse in strict mode -*) put online the tool on the jscert website +*) put online the tool on the jscert website (DONE, needs below:) - make sure to describe the supported features (ecma5 minus for-in and a few other things) - explain that currently JS files are generated From 52db4e055ccc676dc8a81d3dc5d91c36cb9bf03c Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 23 Nov 2016 11:49:23 +0100 Subject: [PATCH 04/46] Add let%spec, allow _ patterns in let%assert construct. --- monad_ppx.ml | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/monad_ppx.ml b/monad_ppx.ml index 06b7e49..cab1b92 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -18,6 +18,7 @@ let monad_mapping = ("not_throw", "if_not_throw"); ("ter", "if_ter"); ("break", "if_break"); + ("spec", "if_spec"); ("assert", "check_assert"); ] @@ -50,19 +51,6 @@ let generate_mapper namesid = function argv -> try let ident = List.assoc name namesid in match pstr with - | PStr [{ pstr_desc = - Pstr_eval ({ pexp_loc = loc; - pexp_desc = Pexp_let - (rf, - [{pvb_pat = {ppat_desc = Ppat_var _} as p; - pvb_expr = e}], - cont) - }, _)}] -> - Exp.apply ~loc (Exp.ident - (Location.mkloc - (Longident.Lident ident) Location.none)) - [(Nolabel, aux e); - (Nolabel, Exp.fun_ Nolabel None p (aux cont))] | PStr [{ pstr_desc = Pstr_eval ({ pexp_loc = loc; pexp_desc = Pexp_let @@ -78,6 +66,21 @@ let generate_mapper namesid = function argv -> (Longident.Lident ident) Location.none)) [(Nolabel, aux e); (Nolabel, Exp.fun_ Nolabel None p1 (Exp.fun_ Nolabel None p2 (aux cont)))] + | PStr [{ pstr_desc = + Pstr_eval ({ pexp_loc = loc; + pexp_desc = Pexp_let (rf, [{pvb_pat = p; pvb_expr = e}], cont) + }, _)}] -> + begin + match p.ppat_desc with + | Ppat_var _ + | Ppat_any -> + Exp.apply ~loc (Exp.ident + (Location.mkloc + (Longident.Lident ident) Location.none)) + [(Nolabel, aux e); + (Nolabel, Exp.fun_ Nolabel None p (aux cont))] + | _ -> raise (Location.Error (Location.error ~loc:p.ppat_loc ("unknown pattern type with let%"^name))) + end | _ -> raise (Location.Error ( Location.error ~loc ("error with let%"^name))) From c7b3ce61d2908d47b65386a32695bed984824b28 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 24 Nov 2016 19:08:04 +0100 Subject: [PATCH 05/46] Add ECMAScript Specification links to ocamldoc documentation --- .gitignore | 4 ---- 1 file changed, 4 deletions(-) diff --git a/.gitignore b/.gitignore index 324e675..16aea75 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,3 @@ _build -*.byte -*.native -stdlib_ml/stdlib.cmi -stdlib_ml/stdlib.cmo .ocamldebug From 4272db417502ce02d3da15051007ee5954b44baf Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Sat, 26 Nov 2016 15:08:57 +0100 Subject: [PATCH 06/46] Flatten prim type into value. --- TODO | 3 --- 1 file changed, 3 deletions(-) diff --git a/TODO b/TODO index 52cdde9..10dccc4 100644 --- a/TODO +++ b/TODO @@ -8,9 +8,6 @@ => inline the definition of "if_ter" inside its body and assign an explicit name to the local function there -*) remove Coq_value_prim (flatten the value data type) - - *) make sure the "reach condition" works properly *) clean up the ML code for: type_compare mutability_compare prim_compare; From aa0e1af47bc9cdeee23b176a8a9f55332ca1eaf2 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 13 Dec 2016 18:31:30 +0100 Subject: [PATCH 07/46] Use single-source of truth for the monadic binder list --- README.org | 6 ++++-- js_of_ast.ml | 15 +-------------- monad_ppx.ml | 18 +----------------- monadic_binder_list.ml | 19 +++++++++++++++++++ 4 files changed, 25 insertions(+), 33 deletions(-) create mode 100644 monadic_binder_list.ml diff --git a/README.org b/README.org index c1202b8..8580649 100644 --- a/README.org +++ b/README.org @@ -94,8 +94,8 @@ type 'a tree = - ~let%some x = expr in cont~ becomes ~if_some expr (fun x -> cont)~ - ~let%if_spec (s,x) = expr in cont~ becomes ~if_spec expr (fun s x -> cont)~ - The full list of available moands is provided in `monad_mapping` of - monad_ppx.ml, but is reproduced below for convenience: + The full list of available monads is provided in the file + [[monadic_binder_list.ml]], but is reproduced below for convenience: - run - string - object @@ -109,3 +109,5 @@ type 'a tree = - not_throw - ter - break + - spec + - assert diff --git a/js_of_ast.ml b/js_of_ast.ml index 645df2b..01ea7bc 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -266,20 +266,7 @@ let is_monadic_function f = match f.exp_desc with | Texp_ident (path, ident, _) -> let x = Path.name path in - List.mem x [ - "JsInterpreterMonads.if_run"; - "JsInterpreterMonads.if_string"; - "JsInterpreterMonads.if_object"; - "JsInterpreterMonads.if_value"; - "JsInterpreterMonads.if_prim"; - "JsInterpreterMonads.if_number"; - "JsInterpreterMonads.if_some"; - "JsInterpreterMonads.if_bool"; - "JsInterpreterMonads.if_void"; - "JsInterpreterMonads.if_success"; - "JsInterpreterMonads.if_not_throw"; - "JsInterpreterMonads.if_ter"; - "JsInterpreterMonads.if_break";] + List.mem x Monadic_binder_list.monad_identifiers | _ -> false diff --git a/monad_ppx.ml b/monad_ppx.ml index cab1b92..dd48c23 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -4,23 +4,7 @@ open Asttypes open Parsetree open Longident -let monad_mapping = - [("run", "if_run"); - ("string", "if_string"); - ("object", "if_object"); - ("value", "if_value"); - ("prim", "if_prim"); - ("number", "if_number"); - ("some", "if_some"); - ("bool", "if_bool"); - ("void", "if_void"); - ("success", "if_success"); - ("not_throw", "if_not_throw"); - ("ter", "if_ter"); - ("break", "if_break"); - ("spec", "if_spec"); - ("assert", "check_assert"); - ] +let monad_mapping = Monadic_binder_list.monad_mapping (* e.g. diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml new file mode 100644 index 0000000..aab88f6 --- /dev/null +++ b/monadic_binder_list.ml @@ -0,0 +1,19 @@ +let monad_mapping = + [("run", "if_run"); + ("string", "if_string"); + ("object", "if_object"); + ("value", "if_value"); + ("prim", "if_prim"); + ("number", "if_number"); + ("some", "if_some"); + ("bool", "if_bool"); + ("void", "if_void"); + ("success", "if_success"); + ("not_throw", "if_not_throw"); + ("ter", "if_ter"); + ("break", "if_break"); + ("spec", "if_spec"); + ("assert", "check_assert"); + ] + +let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping From 28c4fc489ac282c8ef3c21690d619c4e35479d78 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 9 Dec 2016 16:13:54 +0100 Subject: [PATCH 08/46] s/let%run/let%spec/g --- README.org | 1 - TODO | 1 - monadic_binder_list.ml | 3 +-- 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/README.org b/README.org index 8580649..dd430b9 100644 --- a/README.org +++ b/README.org @@ -96,7 +96,6 @@ type 'a tree = The full list of available monads is provided in the file [[monadic_binder_list.ml]], but is reproduced below for convenience: - - run - string - object - value diff --git a/TODO b/TODO index 10dccc4..f6e03dc 100644 --- a/TODO +++ b/TODO @@ -14,7 +14,6 @@ for prim_compare, we should be able to match on pairs of arguments, with a catch-all *) move prim_compare and value_compare to JsInterpreter because it is interesting and should be logged; - move same_value_dec from jscommonaux *) bigger test262 testing. diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index aab88f6..6fad12e 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -1,5 +1,4 @@ -let monad_mapping = - [("run", "if_run"); +let monad_mapping = [ ("string", "if_string"); ("object", "if_object"); ("value", "if_value"); From 665e243b11ae9d83bba42fdd879e4e9367af61a0 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 13 Dec 2016 18:39:47 +0100 Subject: [PATCH 09/46] Implement new Ordinary Object [[DefineOwnProperty]] and [[GetOwnProperty]] --- README.org | 1 + monadic_binder_list.ml | 1 + 2 files changed, 2 insertions(+) diff --git a/README.org b/README.org index dd430b9..9363dc0 100644 --- a/README.org +++ b/README.org @@ -110,3 +110,4 @@ type 'a tree = - break - spec - assert + - can_return diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index 6fad12e..b0366c1 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -13,6 +13,7 @@ let monad_mapping = [ ("break", "if_break"); ("spec", "if_spec"); ("assert", "check_assert"); + ("can_return", "if_spec_else_return"); ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping From facf59a958f295e593b99e972f4fe7cd7d05d728 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 11 Jan 2017 17:30:43 +0000 Subject: [PATCH 10/46] Add let%ret and if%ret extensions to allow "Return" expressions from conditionals --- README.org | 22 +++++++++- monad_ppx.ml | 99 ++++++++++++++++++++++-------------------- monadic_binder_list.ml | 2 +- tests/if.ml | 17 ++++++++ 4 files changed, 91 insertions(+), 49 deletions(-) create mode 100644 tests/if.ml diff --git a/README.org b/README.org index 9363dc0..3881f3f 100644 --- a/README.org +++ b/README.org @@ -110,4 +110,24 @@ type 'a tree = - break - spec - assert - - can_return + - ret + +*** ~if%ret~ Syntax Extension + + The ~if%ret~ syntax, which allows else + branches to be elided in place of writing ~else Continue s~ + + Extended syntax: ~if%ret condition, s then r1~ + Maps to: ~if condition then Return r1 else Continue s~ + + It is syntactically required that the first expr position is a pair of + condition expression and initial state variable to Continue with. + + Extended syntax: + ~if%ret condition, s then r1 else r2~ + Maps to: + ~if condition then Return r1 else Return r2~ + Note that the state parameter of the tuple is still required in this + instance, but is ignored. + + Nesting ~if%ret~s is currently unsupported. :( diff --git a/monad_ppx.ml b/monad_ppx.ml index dd48c23..83b719d 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -22,59 +22,64 @@ and in pseudo: *) +let mk_lid ?(loc=Location.none) ident = Location.mkloc (Longident.Lident ident) loc +let mk_ident ?loc ident = Exp.ident (mk_lid ?loc ident) let generate_mapper namesid = function argv -> { default_mapper with expr = fun mapper expr -> - let aux e = mapper.expr mapper e in - match expr with - (* Is this an extension node? *) - | { pexp_desc = - Pexp_extension ({ txt = name; loc }, pstr)} -> - begin - try - let ident = List.assoc name namesid in + let aux e = mapper.expr mapper e in + match expr with + (* Is this an extension node? *) + | { pexp_desc = Pexp_extension ({txt = name; loc}, pstr)} -> + begin try match pstr with - | PStr [{ pstr_desc = - Pstr_eval ({ pexp_loc = loc; - pexp_desc = Pexp_let - (rf, - [{pvb_pat = - {ppat_desc = - Ppat_tuple [p1;p2]}; - pvb_expr = e}], - cont) - }, _)}] -> - Exp.apply ~loc (Exp.ident - (Location.mkloc - (Longident.Lident ident) Location.none)) - [(Nolabel, aux e); - (Nolabel, Exp.fun_ Nolabel None p1 (Exp.fun_ Nolabel None p2 (aux cont)))] - | PStr [{ pstr_desc = - Pstr_eval ({ pexp_loc = loc; - pexp_desc = Pexp_let (rf, [{pvb_pat = p; pvb_expr = e}], cont) - }, _)}] -> - begin - match p.ppat_desc with - | Ppat_var _ - | Ppat_any -> - Exp.apply ~loc (Exp.ident - (Location.mkloc - (Longident.Lident ident) Location.none)) - [(Nolabel, aux e); - (Nolabel, Exp.fun_ Nolabel None p (aux cont))] - | _ -> raise (Location.Error (Location.error ~loc:p.ppat_loc ("unknown pattern type with let%"^name))) + | PStr [{ pstr_desc = Pstr_eval ({pexp_loc = loc; pexp_desc = extended_expression}, _)}] -> + + begin match extended_expression with + (* let%exn bindings *) + | Pexp_let (rf, [{pvb_pat = pat; pvb_expr = e}], cont) -> + begin try + let ident = List.assoc name namesid in + let (param, body) = match pat.ppat_desc with + (* let%exn _ = ... or let%exn a = ... *) + | Ppat_var _ + | Ppat_any -> (pat, aux cont) + (* let%exn (a,b) = ... *) + | Ppat_tuple [p1;p2] -> (p1, (Exp.fun_ Nolabel None p2 (aux cont))) + | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("unknown pattern type with let%"^name))) + in + Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ Nolabel None param body)] + with + | Not_found -> raise (Location.Error (Location.error ~loc ("no let%"^name))) + end + + (* if%exn e_if then e_then else e_else *) + | Pexp_ifthenelse (e_if, e_then, e_else) -> + if name <> "ret" then + raise (Location.Error (Location.error ~loc ("if%"^ name ^ " extension is unknown"))) + else begin + let (e_if, e_then, e_else) = (aux e_if, aux e_then, map_opt aux e_else) in + match e_if.pexp_desc with + + (* if%ret (condition, state) then e_then else e_else *) + | Pexp_tuple [condition; state] -> + Exp.ifthenelse ~loc condition (Exp.construct (mk_lid ~loc "Return") (Some e_then)) (Some + (Mytools.option_app + (Exp.construct (mk_lid ~loc "Continue") (Some state)) + (fun rv -> Exp.construct (mk_lid ~loc "Return") (Some rv)) + e_else)) + + | _ -> raise (Location.Error (Location.error ~loc:e_if.pexp_loc "conditional of if%ret must syntactically be a pair")) + end + + | _ -> raise (Location.Error (Location.error ~loc "unable to extend this sort of expression")) end - | _ -> - raise (Location.Error ( - Location.error ~loc ("error with let%"^name))) - with - | Not_found -> - raise (Location.Error ( - Location.error ~loc ("no let%"^name))) - end - (* Delegate to the default mapper. *) - | x -> default_mapper.expr mapper x; + | _ -> raise (Location.Error ( Location.error ~loc "Expression extension node containing non-expression")) + with Location.Error error -> {expr with pexp_desc = Pexp_extension (extension_of_error error)} + end + (* Delegate to the default mapper. *) + | x -> default_mapper.expr mapper x; } let () = register "my_monads" (generate_mapper monad_mapping) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index b0366c1..26d25f5 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -13,7 +13,7 @@ let monad_mapping = [ ("break", "if_break"); ("spec", "if_spec"); ("assert", "check_assert"); - ("can_return", "if_spec_else_return"); + ("ret", "let_ret"); ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping diff --git a/tests/if.ml b/tests/if.ml new file mode 100644 index 0000000..6661572 --- /dev/null +++ b/tests/if.ml @@ -0,0 +1,17 @@ +type monadic_continue_type = +| Return of int +| Continue of char + +let x = if%ret (true, 'a') then 0 +let x1 = if true then Return 0 else Continue 'a' +let y = if%ret (false, 'b') then 0 +let z = if%ret (false, 'c') then 0 else 1 + +(* Parans-less tuple syntax *) +let x0 = if%ret true, 'a' then 0 +;; + +assert (x = Return 0); +assert (y = Continue 'b'); +assert (z = Return 1); +assert (x0 = Return 0) From 8bba8ffce8d9c7ac179f3904c0318c8c47aadf94 Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Wed, 22 Feb 2017 17:06:52 +0000 Subject: [PATCH 11/46] extending monadic operators adding a 2 version with additional continuation for abort behavior let_value_ret --- monadic_binder_list.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index 26d25f5..bc152d7 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -14,6 +14,7 @@ let monad_mapping = [ ("spec", "if_spec"); ("assert", "check_assert"); ("ret", "let_ret"); + ("value_ret", "if_value_ret"); ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping From 9a18e2e159cfc30820eea25c3f38b8d4af1e3c34 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 23 Feb 2017 14:56:17 +0000 Subject: [PATCH 12/46] monad_ppx: Pass more location information through tree transformation --- monad_ppx.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/monad_ppx.ml b/monad_ppx.ml index 83b719d..b05bc2f 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -46,10 +46,10 @@ let generate_mapper namesid = function argv -> | Ppat_var _ | Ppat_any -> (pat, aux cont) (* let%exn (a,b) = ... *) - | Ppat_tuple [p1;p2] -> (p1, (Exp.fun_ Nolabel None p2 (aux cont))) + | Ppat_tuple [p1;p2] -> (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("unknown pattern type with let%"^name))) in - Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ Nolabel None param body)] + Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ ~loc Nolabel None param body)] with | Not_found -> raise (Location.Error (Location.error ~loc ("no let%"^name))) end @@ -64,10 +64,10 @@ let generate_mapper namesid = function argv -> (* if%ret (condition, state) then e_then else e_else *) | Pexp_tuple [condition; state] -> - Exp.ifthenelse ~loc condition (Exp.construct (mk_lid ~loc "Return") (Some e_then)) (Some + Exp.ifthenelse ~loc condition (Exp.construct ~loc (mk_lid ~loc "Return") (Some e_then)) (Some (Mytools.option_app - (Exp.construct (mk_lid ~loc "Continue") (Some state)) - (fun rv -> Exp.construct (mk_lid ~loc "Return") (Some rv)) + (Exp.construct ~loc (mk_lid ~loc "Continue") (Some state)) + (fun rv -> Exp.construct ~loc (mk_lid ~loc "Return") (Some rv)) e_else)) | _ -> raise (Location.Error (Location.error ~loc:e_if.pexp_loc "conditional of if%ret must syntactically be a pair")) From 6c2143c5da26bef25a70be4c845f1ca494e9d55c Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 24 Feb 2017 15:37:22 +0000 Subject: [PATCH 13/46] monad_ppx: Remove if%ret syntax. --- README.org | 20 -------------------- monad_ppx.ml | 19 ------------------- tests/if.ml | 17 ----------------- 3 files changed, 56 deletions(-) delete mode 100644 tests/if.ml diff --git a/README.org b/README.org index 3881f3f..61e9e4e 100644 --- a/README.org +++ b/README.org @@ -111,23 +111,3 @@ type 'a tree = - spec - assert - ret - -*** ~if%ret~ Syntax Extension - - The ~if%ret~ syntax, which allows else - branches to be elided in place of writing ~else Continue s~ - - Extended syntax: ~if%ret condition, s then r1~ - Maps to: ~if condition then Return r1 else Continue s~ - - It is syntactically required that the first expr position is a pair of - condition expression and initial state variable to Continue with. - - Extended syntax: - ~if%ret condition, s then r1 else r2~ - Maps to: - ~if condition then Return r1 else Return r2~ - Note that the state parameter of the tuple is still required in this - instance, but is ignored. - - Nesting ~if%ret~s is currently unsupported. :( diff --git a/monad_ppx.ml b/monad_ppx.ml index b05bc2f..eeb3fd7 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -54,25 +54,6 @@ let generate_mapper namesid = function argv -> | Not_found -> raise (Location.Error (Location.error ~loc ("no let%"^name))) end - (* if%exn e_if then e_then else e_else *) - | Pexp_ifthenelse (e_if, e_then, e_else) -> - if name <> "ret" then - raise (Location.Error (Location.error ~loc ("if%"^ name ^ " extension is unknown"))) - else begin - let (e_if, e_then, e_else) = (aux e_if, aux e_then, map_opt aux e_else) in - match e_if.pexp_desc with - - (* if%ret (condition, state) then e_then else e_else *) - | Pexp_tuple [condition; state] -> - Exp.ifthenelse ~loc condition (Exp.construct ~loc (mk_lid ~loc "Return") (Some e_then)) (Some - (Mytools.option_app - (Exp.construct ~loc (mk_lid ~loc "Continue") (Some state)) - (fun rv -> Exp.construct ~loc (mk_lid ~loc "Return") (Some rv)) - e_else)) - - | _ -> raise (Location.Error (Location.error ~loc:e_if.pexp_loc "conditional of if%ret must syntactically be a pair")) - end - | _ -> raise (Location.Error (Location.error ~loc "unable to extend this sort of expression")) end | _ -> raise (Location.Error ( Location.error ~loc "Expression extension node containing non-expression")) diff --git a/tests/if.ml b/tests/if.ml deleted file mode 100644 index 6661572..0000000 --- a/tests/if.ml +++ /dev/null @@ -1,17 +0,0 @@ -type monadic_continue_type = -| Return of int -| Continue of char - -let x = if%ret (true, 'a') then 0 -let x1 = if true then Return 0 else Continue 'a' -let y = if%ret (false, 'b') then 0 -let z = if%ret (false, 'c') then 0 else 1 - -(* Parans-less tuple syntax *) -let x0 = if%ret true, 'a' then 0 -;; - -assert (x = Return 0); -assert (y = Continue 'b'); -assert (z = Return 1); -assert (x0 = Return 0) From 614fa8b1626fcb3817f36279cd4e5ec886291610 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Mon, 27 Feb 2017 20:01:42 +0000 Subject: [PATCH 14/46] generator: More binders * Add let%*_ret binders for use within let%ret contexts, they ensure all returned values are packed in Return/Continue as appropriate * Add let%CAPITAL forms of binders for "never abrupt"/! spec syntax * Special-case let%ret to pass tuples to continuation instead of unpack to argument application. --- README.org | 7 ++++++- monad_ppx.ml | 3 ++- monadic_binder_list.ml | 5 +++++ 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/README.org b/README.org index 61e9e4e..37d7ef3 100644 --- a/README.org +++ b/README.org @@ -110,4 +110,9 @@ type 'a tree = - break - spec - assert - - ret + - ret /Note: argument is special-cased to pass tuples rather than unpack to argument application/ + + ~_ret~ forms of binders are provided to be wrapped in the Return monad for + use inside of a ~let%ret~, + UPPERCASE forms of binders are the ~!~/"never abrupt" spec-text equivalent + binders to the standard (~ReturnIfAbrupt~/~?~) binders. diff --git a/monad_ppx.ml b/monad_ppx.ml index eeb3fd7..5909df9 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -46,7 +46,8 @@ let generate_mapper namesid = function argv -> | Ppat_var _ | Ppat_any -> (pat, aux cont) (* let%exn (a,b) = ... *) - | Ppat_tuple [p1;p2] -> (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) + | Ppat_tuple [p1;p2] -> + if name = "ret" then (pat, aux cont) else (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("unknown pattern type with let%"^name))) in Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ ~loc Nolabel None param body)] diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index bc152d7..b2cf57e 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -1,6 +1,7 @@ let monad_mapping = [ ("string", "if_string"); ("object", "if_object"); + ("OBJECT", "assert_object"); ("value", "if_value"); ("prim", "if_prim"); ("number", "if_number"); @@ -13,8 +14,12 @@ let monad_mapping = [ ("break", "if_break"); ("spec", "if_spec"); ("assert", "check_assert"); + ("ret", "let_ret"); ("value_ret", "if_value_ret"); + ("object_ret", "if_object_ret"); + ("OBJECT_ret", "assert_object_ret"); + ("assert_ret", "check_assert_ret"); ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping From abee3291fbd273d665c3a29d78d47bcaf55ce002 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 7 Mar 2017 17:22:43 +0000 Subject: [PATCH 15/46] Implement Proxy Object [[GetPrototypeOf]] [[SetPrototypeOf]] [[IsExtensible]] [[PreventExtensions]] --- monadic_binder_list.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index b2cf57e..dae026b 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -17,6 +17,7 @@ let monad_mapping = [ ("ret", "let_ret"); ("value_ret", "if_value_ret"); + ("bool_ret", "if_bool_ret"); ("object_ret", "if_object_ret"); ("OBJECT_ret", "assert_object_ret"); ("assert_ret", "check_assert_ret"); From 182f3184986ba957173af1714d704f2533efef32 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 8 Mar 2017 17:29:30 +0000 Subject: [PATCH 16/46] Implement bulk of Proxies. Proxy Object Internal Methods 9.5.5 - 9.5.10 implemented. Proxy Constructor 26.2 implemented. --- monadic_binder_list.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index dae026b..3653ab6 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -16,11 +16,15 @@ let monad_mapping = [ ("assert", "check_assert"); ("ret", "let_ret"); + ("some_ret", "if_some_ret"); ("value_ret", "if_value_ret"); ("bool_ret", "if_bool_ret"); ("object_ret", "if_object_ret"); ("OBJECT_ret", "assert_object_ret"); ("assert_ret", "check_assert_ret"); + ("spec_ret", "if_spec_ret"); + ("some_ret", "if_some_ret"); + ("ret_ret", "let_ret_ret"); ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping From c4964fd976e2aab2437f6de2bb57ed6ea1747bd0 Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Thu, 23 Mar 2017 11:03:46 -0700 Subject: [PATCH 17/46] adding support for underscore in let tuples --- js_of_ast.ml | 23 +++++++++++++++++------ tests/lettuple.ml | 7 +++++++ 2 files changed, 24 insertions(+), 6 deletions(-) create mode 100644 tests/lettuple.ml diff --git a/js_of_ast.ml b/js_of_ast.ml index 01ea7bc..5edf6a0 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -738,23 +738,34 @@ let combine_list_output args = let (strs,bss) = List.split args in (show_list "@,@," strs), (List.flatten bss) +let mapiopt f = + let rec aux i = function + | [] -> [] + | hd :: tl -> + let ro = f i hd in begin + match ro with + | Some r -> r :: aux (i+1) tl + | None -> aux (i+1) tl + end + in + aux 0 + (* returns a pair (x,e), where [x] in the name in [pat] and where [e] is the access to "stupleobj[index]" *) -let tuple_component_bind stupleobj index pat = +let tuple_component_bind stupleobj index pat = let loc = pat.pat_loc in match pat.pat_desc with - | Tpat_var (id, _) -> + | Tpat_var (id, _) -> let sid = ppf_ident id in - (sid, Printf.sprintf "%s[%d]" stupleobj index) - | Tpat_any -> out_of_scope loc "Underscore pattern in let-tuple" + Some (sid, Printf.sprintf "%s[%d]" stupleobj index) + | Tpat_any -> None | _ -> out_of_scope loc "Nested pattern matching" (* returns a list of pairs of the form (x,e), corresponding to the bindings to be performed for decomposing [stupleobj] as the tuple of patterns [pl]. *) let tuple_binders stupleobj pl = - List.mapi (tuple_component_bind stupleobj) pl - + mapiopt (tuple_component_bind stupleobj) pl (****************************************************************) (* TRANSLATION *) diff --git a/tests/lettuple.ml b/tests/lettuple.ml new file mode 100644 index 0000000..e0d9ee5 --- /dev/null +++ b/tests/lettuple.ml @@ -0,0 +1,7 @@ +let test _ = + let (y,z) = (1,2) + in y + +let test2 _ = + let _,z = (1,2) + in z From a52019f3ff7e1e27c7ee57f8f40cc1d3f4f01ca6 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Mon, 20 Mar 2017 03:07:26 +0000 Subject: [PATCH 18/46] Implement Construct, CreateArrayFromList, CreateListFromArrayLike, Proxy [[OwnPropertyKeys]], [[Call]] and [[Construct]] --- monad_ppx.ml | 7 +++++-- monadic_binder_list.ml | 7 +++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/monad_ppx.ml b/monad_ppx.ml index 5909df9..46d405b 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -46,8 +46,11 @@ let generate_mapper namesid = function argv -> | Ppat_var _ | Ppat_any -> (pat, aux cont) (* let%exn (a,b) = ... *) - | Ppat_tuple [p1;p2] -> - if name = "ret" then (pat, aux cont) else (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) + | Ppat_tuple t -> + if name = "ret" then (pat, aux cont) + else (match t with + | [p1;p2] -> (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) + | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("let%"^name^" expects exactly 2 variables to bind")))) | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("unknown pattern type with let%"^name))) in Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ ~loc Nolabel None param body)] diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index 3653ab6..d6580db 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -1,5 +1,6 @@ let monad_mapping = [ ("string", "if_string"); + ("STRING", "assert_string"); ("object", "if_object"); ("OBJECT", "assert_object"); ("value", "if_value"); @@ -7,6 +8,7 @@ let monad_mapping = [ ("number", "if_number"); ("some", "if_some"); ("bool", "if_bool"); + ("BOOL", "assert_bool"); ("void", "if_void"); ("success", "if_success"); ("not_throw", "if_not_throw"); @@ -17,8 +19,13 @@ let monad_mapping = [ ("ret", "let_ret"); ("some_ret", "if_some_ret"); + ("number_ret", "if_number_ret"); + ("string_ret", "if_string_ret"); + ("STRING_ret", "assert_string_ret"); ("value_ret", "if_value_ret"); + ("VALUE_ret", "assert_value_ret"); ("bool_ret", "if_bool_ret"); + ("BOOL_ret", "assert_bool_ret"); ("object_ret", "if_object_ret"); ("OBJECT_ret", "assert_object_ret"); ("assert_ret", "check_assert_ret"); From 23e8f6bc0389a5178608c6f2e29821f4f3c8480a Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 19 Apr 2017 21:26:48 +0100 Subject: [PATCH 19/46] generator stdlib: && and || are not short circuited unless defined as externals --- stdlib_ml/stdlib.ml | 4 ++-- stdlib_ml/stdlib.mli | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/stdlib_ml/stdlib.ml b/stdlib_ml/stdlib.ml index e97cc85..0339449 100644 --- a/stdlib_ml/stdlib.ml +++ b/stdlib_ml/stdlib.ml @@ -13,8 +13,8 @@ let raise = Pervasives.raise;; (**{6 Boolean operations }*) (** Note: Both OCaml and JS implement lazy evaluation for boolean operators. *) let not = Pervasives.not;; -let ( && ) = Pervasives.( && );; -let ( || ) = Pervasives.( || );; +external ( && ) : bool -> bool -> bool = "%sequand";; +external ( || ) : bool -> bool -> bool = "%sequor";; (**{6 Debugging }*) external __LOC__ : string = "%loc_LOC" diff --git a/stdlib_ml/stdlib.mli b/stdlib_ml/stdlib.mli index bf651ff..2f53639 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -34,8 +34,8 @@ val raise : exn -> 'a (**{6 Boolean operations }*) (** Note: Both OCaml and JS implement lazy evaluation for boolean operators. *) val not : bool -> bool -val ( && ) : bool -> bool -> bool -val ( || ) : bool -> bool -> bool +external ( && ) : bool -> bool -> bool = "%sequand";; +external ( || ) : bool -> bool -> bool = "%sequor";; (**{6 Debugging }*) external __LOC__ : string = "%loc_LOC" From 81bfb54c6eb7d770c8fecfffa2b02619ada33426 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 25 Apr 2017 22:54:15 +0100 Subject: [PATCH 20/46] Function Object [[Get]] is no longer special. --- monadic_binder_list.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index d6580db..974c3ab 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -11,6 +11,7 @@ let monad_mapping = [ ("BOOL", "assert_bool"); ("void", "if_void"); ("success", "if_success"); + ("SUCCESS", "assert_success"); ("not_throw", "if_not_throw"); ("ter", "if_ter"); ("break", "if_break"); From 8f427ccb6862a9a7903172048385f9275b3f3113 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 14 Nov 2017 20:45:36 +0000 Subject: [PATCH 21/46] Prefix JS keywords that are used as OCaml identifiers. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We were already disallowing some JS keywords from being used as identifiers, this patch completes the set of recognised keywords. Instead of disallowing, we can safely prefix or suffix the name with a character that is not permitted in OCaml identifiers, but is permitted in JS identifiers. This includes $ and a substantial set of unicode characters. (Those listed in the below tables, AND contain at least one byte that is forbidden by the OCaml rules). In this case, I've opted to prefix the variables by 𝕍 (Mathematical Double-Struck Capital V). I've also updated the substitution of the ' (Apostrophe) character from $ to ΚΉ (Modifier Letter Prime), to improve the readability of the code. https://unicode.org/cldr/utility/list-unicodeset.jsp?a=[:ID_Start=Yes:] https://unicode.org/cldr/utility/list-unicodeset.jsp?a=[:ID_Continue=Yes:] --- js_of_ast.ml | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 5edf6a0..5977cef 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -384,11 +384,19 @@ let ppf_pat_array id_list array_expr = let ppf_field_access expr field = Printf.sprintf "%s.%s" expr field +(* List of JavaScript keywords that cannot be used as identifiers *) +let js_keywords = + ["await"; "break"; "case"; "catch"; "class"; "const"; "continue"; "debugger"; "default"; "delete"; "do"; "else"; + "export"; "extends"; "finally"; "for"; "function"; "if"; "import"; "in"; "instanceof"; "new"; "return"; "super"; + "switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while"; "with"; "yield"; "enum"] + let ppf_ident_name x = - if List.mem x ["arguments"; "eval"; "caller"] - then unsupported ("use of reserved keyword: " ^ x); - (* TODO: complete the list *) - Str.global_replace (Str.regexp "'") "$" x + if List.mem x js_keywords then + (* Variable name clashes with JS keyword: prefix with a \mathbb{V} character (\u1d54d) *) + "\xf0\x9d\x95\x8d" ^ x + else + (* Variable name contains ' (not supported by JS): replace with unicode prime symbol (\u02b9) *) + Str.global_replace (Str.regexp "'") "\xca\xb9" x let ppf_ident i = i |> Ident.name |> ppf_ident_name From d485cb76babb4cfff4368bf121e8dc87ebb36ac9 Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Thu, 11 May 2017 16:05:08 +0200 Subject: [PATCH 22/46] fixing is_infix cherrypick of 2443692 92fbd9d 4246e97 Fixes #12 --- js_of_ast.ml | 9 ++++++--- tests/.gitignore | 6 +++++- tests/Makefile | 3 +++ tests/arith.ml | 2 ++ tests/mini.ml | 5 +++++ 5 files changed, 21 insertions(+), 4 deletions(-) create mode 100644 tests/mini.ml diff --git a/js_of_ast.ml b/js_of_ast.ml index 5977cef..b9241f7 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -120,9 +120,12 @@ let is_infix f args = match args with | _ :: [] | [] -> false | x :: xs -> let open Location in - let f_loc = (f.exp_loc.loc_start, f.exp_loc.loc_end) in - let args_loc = (x.exp_loc.loc_start, x.exp_loc.loc_end) in - if fst args_loc < fst f_loc then true else false + let open Lexing in + if f.exp_loc.loc_ghost then false else + if x.exp_loc.loc_ghost then false else + x.exp_loc.loc_start.pos_lnum < f.exp_loc.loc_start.pos_lnum || + (x.exp_loc.loc_start.pos_lnum = f.exp_loc.loc_start.pos_lnum && + x.exp_loc.loc_start.pos_cnum < f.exp_loc.loc_start.pos_cnum) exception Map_fields_elements_mismatch_number_args diff --git a/tests/.gitignore b/tests/.gitignore index b4f843b..32b0e23 100644 --- a/tests/.gitignore +++ b/tests/.gitignore @@ -1,2 +1,6 @@ *.log.js -*.unlog.js \ No newline at end of file +*.unlog.js +*.cmo +*.cmi +*.token.js +*.mlloc.js diff --git a/tests/Makefile b/tests/Makefile index 76b62cf..f716ec9 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -6,3 +6,6 @@ test: ../monad_ppx.byte let.ml %.log.js: %.ml ../main.byte ../monad_ppx.byte ../main.byte -mode log -ppx ../monad_ppx.byte -I ../stdlib_ml $< + +%.token.js: %.ml ../main.byte ../monad_ppx.byte + ../main.byte -mode token -ppx ../monad_ppx.byte -I ../stdlib_ml $< diff --git a/tests/arith.ml b/tests/arith.ml index d5ee32b..0e62112 100644 --- a/tests/arith.ml +++ b/tests/arith.ml @@ -1 +1,3 @@ let myadd x y = x +. y + +let subst x = x-1 diff --git a/tests/mini.ml b/tests/mini.ml new file mode 100644 index 0000000..7492e5c --- /dev/null +++ b/tests/mini.ml @@ -0,0 +1,5 @@ +type toto = + Foo of int [@f foo] + +let test f = match f with + Foo x -> x From f63eac854bef2a7f25744b7b8bd7a5ff065c9c97 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 22 Nov 2017 15:08:06 +0000 Subject: [PATCH 23/46] Test case for shadowed variable declarations. --- tests/shadow.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 tests/shadow.ml diff --git a/tests/shadow.ml b/tests/shadow.ml new file mode 100644 index 0000000..5db7605 --- /dev/null +++ b/tests/shadow.ml @@ -0,0 +1,12 @@ +(* `make shadow.unlog.js` and test resulting function in node + add a print_int to the shadower line and `ocamlc shadow.ml` to validate ml *) + +let shadower n = + let f _ = + let n = n+1 in + let n = n+1 in + n+1 in + f () ;; + +shadower 1 +(* Expected return value: 4 *) From 7253b12ec2e8e034473bed2c49ebeec06c30a742 Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Wed, 22 Nov 2017 16:11:22 +0100 Subject: [PATCH 24/46] dealing with shadowing --- js_of_ast.ml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index b9241f7..7fca3fb 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -51,12 +51,13 @@ let rename_constructor s = let report_shadowing = !current_mode = Mode_cmi +let do_check_shadowing env id = + try ignore (Env.lookup_value (Longident.Lident id) env); true + with Not_found -> false + let check_shadowing ?loc env id = if report_shadowing then begin - let is_shadowing = - try ignore (Env.lookup_value (Longident.Lident id) env); true - with Not_found -> false - in + let is_shadowing = do_check_shadowing env id in if is_shadowing then warning ?loc:loc (" !!!!! shadowing of variable: " ^ id); end @@ -666,14 +667,14 @@ let generate_logged_return loc ctx sbody = type dest = | Dest_ignore | Dest_return - | Dest_assign of string + | Dest_assign of string * bool (* bool indicates shadowing *) | Dest_inline let apply_dest loc ctx dest sbody = match dest with | Dest_ignore -> sbody | Dest_return -> generate_logged_return loc ctx sbody - | Dest_assign id -> Printf.sprintf "var %s = %s;" id sbody + | Dest_assign (id,s) -> Printf.sprintf "%s%s = %s;" (if s then "" else "var ") id sbody | Dest_inline -> sbody (* LATER: pull out the "var" out of switch *) @@ -881,7 +882,7 @@ and js_of_expression_naming_argument_if_non_variable ctx obj name_prefix = "", (js_of_path_longident path ident) | _ -> (* generate var id = sexp; *) let id = id_fresh name_prefix in - let sintro = js_of_expression ctx (Dest_assign id) obj in + let sintro = js_of_expression ctx (Dest_assign (id, false)) obj in (sintro ^ "@,"), id end @@ -1308,7 +1309,7 @@ and js_of_let_pattern ctx pat expr = (* error ~loc:pat.pat_loc "let can't deconstruct values" *) in check_shadowing ~loc:pat.pat_loc pat.pat_env id; - (id, js_of_expression ctx (Dest_assign id) expr) + (id, js_of_expression ctx (Dest_assign (id, do_check_shadowing pat.pat_env id)) expr) (* LATER: for let (x,y) = e, encode as translate(e,assign z); x = z[0]; y=z[1] | Tpat_tuple (pat_l) From db42cff30a75ff82bfc9dcb014c4ba9dfef855ab Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Wed, 22 Nov 2017 16:15:06 +0100 Subject: [PATCH 25/46] check shadowing all the time --- js_of_ast.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 7fca3fb..73f5158 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -48,8 +48,8 @@ let rename_constructor s = (****************************************************************) (* SHADOWING CHECKER *) -let report_shadowing = - !current_mode = Mode_cmi +let report_shadowing = true + (* !current_mode = Mode_cmi *) let do_check_shadowing env id = try ignore (Env.lookup_value (Longident.Lident id) env); true @@ -1308,7 +1308,6 @@ and js_of_let_pattern ctx pat expr = | Tpat_lazy _ -> out_of_scope pat.pat_loc "lazy" (* error ~loc:pat.pat_loc "let can't deconstruct values" *) in - check_shadowing ~loc:pat.pat_loc pat.pat_env id; (id, js_of_expression ctx (Dest_assign (id, do_check_shadowing pat.pat_env id)) expr) (* LATER: for let (x,y) = e, encode as translate(e,assign z); x = z[0]; y=z[1] From ee48ec99e04de34aaf8e0c313f46514ec7426a3b Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Wed, 13 Dec 2017 15:38:17 +0100 Subject: [PATCH 26/46] merlin tweak --- .merlin | 1 + 1 file changed, 1 insertion(+) diff --git a/.merlin b/.merlin index e3a6ddc..47d9f3f 100644 --- a/.merlin +++ b/.merlin @@ -1,3 +1,4 @@ B _build PKG str PKG compiler-libs.common +PKG ocaml-migrate-parsetree From e1d800b32d547f4901b1c84476fd87e39569c32e Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 13 Dec 2017 15:23:06 +0000 Subject: [PATCH 27/46] Add patten binder shadowing test --- tests/shadow.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/tests/shadow.ml b/tests/shadow.ml index 5db7605..ed14501 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -3,10 +3,22 @@ let shadower n = let f _ = - let n = n+1 in let n = n+1 in n+1 in f () ;; -shadower 1 -(* Expected return value: 4 *) +shadower 1;; (* Expected return value: 3 *) + + +type shadow = +| Shadow of int [@f num] + +let shadower2 n = + let f _ = + match n with + | Shadow n -> n+1 + in + f () +;; + +shadower2 (Shadow 1) (* Expected return value: 2 *) From 27f424c15a89483229333869e99ff33f550c7c26 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 20 Dec 2017 14:27:12 +0000 Subject: [PATCH 28/46] Handle shadowing in match patterns. --- js_of_ast.ml | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 73f5158..9e328df 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -303,8 +303,9 @@ let ppf_match_case c = let ppf_match_binders binders = if binders = [] then "" else - let binds = show_list ",@ " (List.map (fun (id,se) -> Printf.sprintf "%s = %s" id se) binders) in - Printf.sprintf "@[var %s;@]" binds + let binds = show_list "@," (List.map + (fun (id,se,shadows) -> Printf.sprintf "%s%s = %s;" (if shadows then "" else "var ") id se) binders) in + Printf.sprintf "@[%s@]" binds let ppf_let_tuple ids sbody = assert (ids <> []); @@ -516,7 +517,7 @@ let generate_logged_if loc ctx sintro sarg siftrue siffalse = (*--------- match ---------*) let generate_logged_case loc spat binders ctx newctx sbody need_break = - (* Note: binders is a list of pairs of id *) + (* Note: binders is a list of triples of id, shadowing flag *) (* Note: if binders = [], then newctx = ctx *) let (token_start, token_stop, token_loc) = token_fresh !current_mode loc in let sbinders_common () = @@ -525,7 +526,7 @@ let generate_logged_case loc spat binders ctx newctx sbody need_break = match !current_mode with | Mode_cmi -> assert false | Mode_pseudo _ -> - let args = List.map fst binders in + let args = List.map fst3 binders in let spat = (* LATER: use a cleaner separation with Case of (cstr,args) | Default *) if spat = "case ::" then begin let (x,y) = match args with [x;y] -> (x,y) | _ -> assert false in @@ -539,7 +540,7 @@ let generate_logged_case loc spat binders ctx newctx sbody need_break = | Mode_unlogged _ -> (token_start, spat, sbinders_common(), token_stop) | Mode_logged -> - let ids = List.map fst binders in + let ids = List.map fst3 binders in let mk_binding x = Printf.sprintf "{key: \"%s\", val: %s}" x x in @@ -769,7 +770,7 @@ let tuple_component_bind stupleobj index pat = match pat.pat_desc with | Tpat_var (id, _) -> let sid = ppf_ident id in - Some (sid, Printf.sprintf "%s[%d]" stupleobj index) + Some (sid, Printf.sprintf "%s[%d]" stupleobj index, do_check_shadowing pat.pat_env sid) | Tpat_any -> None | _ -> out_of_scope loc "Nested pattern matching" @@ -907,7 +908,7 @@ and js_of_expression ctx dest e = | [ { vb_pat = { pat_desc = Tpat_tuple pl }; vb_expr = obj } ] -> (* binding tuples *) let (sintro, stupleobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_tuple_arg_" in let binders = tuple_binders stupleobj pl in - let ids = List.map fst binders in + let ids = List.map fst3 binders in let sdecl = if is_mode_pseudo() then begin ppf_let_tuple ids stupleobj @@ -915,7 +916,8 @@ and js_of_expression ctx dest e = ppf_match_binders binders end in (ids, sintro ^ sdecl) - | [ { vb_pat = { pat_desc = Tpat_record (args, closed_flag) }; vb_expr = obj } ] -> (* binding records --- TODO: this code does not seem to be used *) + | [ { vb_pat = { pat_desc = Tpat_record (args, closed_flag) }; vb_expr = obj } ] -> + (* binding records -- used in JsCommon.ml *) (* args : (Longident.t loc * label_description * pattern) list *) let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_record_arg_" in let bind (arg_loc,label_descr,pat) = @@ -923,12 +925,12 @@ and js_of_expression ctx dest e = match pat.pat_desc with | Tpat_var (id, _) -> let sid = ppf_ident id in - (sid, Printf.sprintf "%s.%s" seobj name) + (sid, Printf.sprintf "%s.%s" seobj name, do_check_shadowing pat.pat_env sid) | Tpat_any -> out_of_scope e.exp_loc "Underscore pattern in let-record" | _ -> out_of_scope e.exp_loc "Nested pattern matching" in let binders = List.map bind args in - let ids = List.map fst binders in + let ids = List.map fst3 binders in let sdecl = if is_mode_pseudo() then begin ppf_let_record ids seobj @@ -1021,7 +1023,7 @@ and js_of_expression ctx dest e = | Tpat_tuple pl -> let a = id_fresh "_tuple_arg_" in let binders = tuple_binders a pl in - let xs = List.map fst binders in + let xs = List.map fst3 binders in if is_mode_pseudo() then begin (* the name [a] is ignored in this case *) let arg = Printf.sprintf "(%s)" (show_list ",@ " xs) in @@ -1339,8 +1341,9 @@ and js_of_pattern pat obj = if is_sbool c || is_mode_pseudo() then ppf_match_case c else ppf_match_case ("\"" ^ c ^ "\"") in let bind field var = match var.pat_desc with - | Tpat_var (id, _) -> - Some (ppf_ident id, Printf.sprintf "%s.%s" obj field) + | Tpat_var (id, _) -> + let sid = ppf_ident id in + Some (sid, Printf.sprintf "%s.%s" obj field, do_check_shadowing var.pat_env sid) | Tpat_any -> None | _ -> out_of_scope var.pat_loc "Nested pattern matching" in From 29eb18f70adca0e761f49e169ebb482721bfff38 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Wed, 20 Dec 2017 14:53:37 +0000 Subject: [PATCH 29/46] New broken shadowing test case. References #15 --- stdlib_ml/stdlib.js | 2 ++ stdlib_ml/stdlib.ml | 2 ++ stdlib_ml/stdlib.mli | 2 ++ tests/shadow.ml | 11 +++++++++++ 4 files changed, 17 insertions(+) diff --git a/stdlib_ml/stdlib.js b/stdlib_ml/stdlib.js index 2eee1a4..48475c5 100644 --- a/stdlib_ml/stdlib.js +++ b/stdlib_ml/stdlib.js @@ -182,3 +182,5 @@ var substring = function(n, m, s) { throw "strlength invalid arguments"; return s.slice(n, n+m); }; + +var console_int = console.log; diff --git a/stdlib_ml/stdlib.ml b/stdlib_ml/stdlib.ml index 0339449..7a80e20 100644 --- a/stdlib_ml/stdlib.ml +++ b/stdlib_ml/stdlib.ml @@ -148,3 +148,5 @@ val string_concat : string -> string -> string (* + *) let strlength = String.length;; let substring n m s = String.sub s n m;; + +let console_int = Pervasives.print_int;; diff --git a/stdlib_ml/stdlib.mli b/stdlib_ml/stdlib.mli index 2f53639..af6f687 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -185,3 +185,5 @@ val strlength : string -> int (* in JS : function (x) { return x.length; } *) (** Substring extraction. Note different ordering of arguments from String.sub: [ substring n m s = String.sub s n m ] *) val substring : int -> int -> string -> string (* function(x) { return x.slice(n, n+m); } *) + +val console_int : int -> unit diff --git a/tests/shadow.ml b/tests/shadow.ml index ed14501..e7b8ff9 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -22,3 +22,14 @@ let shadower2 n = ;; shadower2 (Shadow 1) (* Expected return value: 2 *) +;; + +let f _ = + let x = 1 in + let y n = + let x = x + n in + x in + y (y x) +;; + +console_int (f ()) (* Expected return value: 3 *) From db888c2a42f7afa611fea5d8e74a023bc43f2823 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 21 Dec 2017 17:40:41 +0000 Subject: [PATCH 30/46] `assert` expression no longer supported `assert x` was being compiled as `throw x`, this was clearly wrong. To fix: * Remove support for assert expressions. * Rehook let%assert (specification assertions) to throw in JS, raise in OCaml * Add `failwith` to stdlib: intended use is for impossible cases in generic code. * Replace any remaining `assert false` instances with `failwith` calls --- js_of_ast.ml | 6 +----- stdlib_ml/stdlib.js | 1 + stdlib_ml/stdlib.ml | 1 + stdlib_ml/stdlib.mli | 1 + 4 files changed, 4 insertions(+), 5 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 9e328df..6dc9b0b 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -1241,11 +1241,6 @@ and js_of_expression ctx dest e = let sexp = ppf_field_access (inline_of_wrap exp) lbl.lbl_name in apply_dest' ctx dest sexp - | Texp_assert e -> - let sexp = inline_of_wrap e in - Printf.sprintf "throw %s;" sexp - (* TODO: what about apply_dest? *) - | Texp_function (Nolabel, cases, Total) -> let mk_pat pat_des = { pat_desc = pat_des; @@ -1275,6 +1270,7 @@ and js_of_expression ctx dest e = let exp = mk_exp (Texp_function (Nolabel, [thecase], Total)) in js_of_expression ctx dest exp + | Texp_assert _ -> out_of_scope loc "assert (please use assert ppx syntax)" | Texp_match (_,_,_, Partial) -> out_of_scope loc "partial matching" | Texp_match (_,_,_,_) -> out_of_scope loc "matching with exception branches" | Texp_try (_,_) -> out_of_scope loc "exceptions" diff --git a/stdlib_ml/stdlib.js b/stdlib_ml/stdlib.js index 48475c5..705788e 100644 --- a/stdlib_ml/stdlib.js +++ b/stdlib_ml/stdlib.js @@ -30,6 +30,7 @@ var mk_cons = function(head, tail) { // val raise : exn -> 'a var raise = function(x) { throw "Not_found"; }; +var failwith = function(str) { throw str; }; //---------------------------------------------------------------------------- // Boolean operations diff --git a/stdlib_ml/stdlib.ml b/stdlib_ml/stdlib.ml index 7a80e20..3a1506f 100644 --- a/stdlib_ml/stdlib.ml +++ b/stdlib_ml/stdlib.ml @@ -9,6 +9,7 @@ This file is to be compiled with the standard OCaml compiler with the library into the end program file. *) let raise = Pervasives.raise;; +let failwith = Pervasives.failwith;; (**{6 Boolean operations }*) (** Note: Both OCaml and JS implement lazy evaluation for boolean operators. *) diff --git a/stdlib_ml/stdlib.mli b/stdlib_ml/stdlib.mli index af6f687..2c19e3b 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -30,6 +30,7 @@ implementation of this library as the functions None, Some, mk_nil, mk_cons. (**{6 Exceptions }*) (** Behaves as [throw "Not_found"] in JS. *) val raise : exn -> 'a +val failwith : string -> 'a (**{6 Boolean operations }*) (** Note: Both OCaml and JS implement lazy evaluation for boolean operators. *) From 875c70d75703d2300e4af128d3f6796c2defbe4a Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Mon, 22 Jan 2018 14:14:41 +0000 Subject: [PATCH 31/46] Remove inline module support --- js_of_ast.ml | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 6dc9b0b..fd80d71 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -796,17 +796,6 @@ let rec js_of_structure s = let postfix = List.fold_left (fun str path -> str ^ "@,}// end of with " ^ ppf_path path) "" open_paths in (prefix ^ "@," ^ contents ^ postfix, namesbound) -and js_of_submodule m = - warning "code generation is incorrect for local modules\n"; - let loc = m.mod_loc in - match m.mod_desc with - | Tmod_structure s -> ppf_module (fst (*TODO*) (js_of_structure s)) - | Tmod_functor (id, _, mtyp, mexp) -> ppf_function (ppf_ident id) (js_of_submodule mexp) - | Tmod_apply (m1, m2, _) -> ppf_apply (js_of_submodule m1) (js_of_submodule m2) - | Tmod_ident (p,_) -> ppf_path p - | Tmod_constraint _ -> out_of_scope loc "module constraint" - | Tmod_unpack _ -> out_of_scope loc "module unpack" - and show_value_binding ctx vb = (* dest is Ignore *) js_of_let_pattern ctx vb.vb_pat vb.vb_expr @@ -843,10 +832,7 @@ and js_of_structure_item s = )) | Tstr_open _ -> ("",[]) (* Handle modules by use of multiple compilation/linking *) | Tstr_modtype _ -> ("",[]) - | Tstr_module b -> - let id = ppf_ident b.mb_id in - let sbody = ppf_decl id (js_of_submodule b.mb_expr) in - (sbody, [id]) + | Tstr_module b -> out_of_scope loc "modules" (* Partial implementation present in commit e1e6e4b *) | Tstr_primitive _ -> out_of_scope loc "primitive functions" | Tstr_typext _ -> out_of_scope loc "type extensions" | Tstr_exception _ -> out_of_scope loc "exceptions" From c7c0b6bdb1f198723a239dc8c8d1eb66924f51b4 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 18 Jan 2018 14:16:44 +0000 Subject: [PATCH 32/46] Fix shadowing of variables by tracking variable scope and renaming as required. Includes some tidy-up of custom versions of standard library functions. --- js_of_ast.ml | 309 ++++++++++++++++++++++++------------------------ map406.ml | 110 +++++++++++++++++ mytools.ml | 41 ++++++- tests/shadow.ml | 16 ++- 4 files changed, 316 insertions(+), 160 deletions(-) create mode 100644 map406.ml diff --git a/js_of_ast.ml b/js_of_ast.ml index fd80d71..eb7b358 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -48,20 +48,21 @@ let rename_constructor s = (****************************************************************) (* SHADOWING CHECKER *) -let report_shadowing = true - (* !current_mode = Mode_cmi *) - -let do_check_shadowing env id = - try ignore (Env.lookup_value (Longident.Lident id) env); true +module ShadowMapM = Map406.Make(String) +type shadow_map = int ShadowMapM.t +let increment_sm sm id = + ShadowMapM.update id (option_app (Some 0) (fun i -> Some (i+1))) sm + +(* Checks if ident is defined in env, and thus would shadow if redefined. *) +let ident_is_shadowing env str_ident = + try ignore (Env.lookup_value (Longident.Lident str_ident) env); + true with Not_found -> false -let check_shadowing ?loc env id = - if report_shadowing then begin - let is_shadowing = do_check_shadowing env id in - if is_shadowing - then warning ?loc:loc (" !!!!! shadowing of variable: " ^ id); - end - +(* If the identifier is shadowing another, then update shadow map *) +let update_shadow_map sm env id = + let str_id = Ident.name id in + if ident_is_shadowing env str_id then increment_sm sm str_id else sm (****************************************************************) (* STRING UTILITIES *) @@ -128,30 +129,11 @@ let is_infix f args = match args with (x.exp_loc.loc_start.pos_lnum = f.exp_loc.loc_start.pos_lnum && x.exp_loc.loc_start.pos_cnum < f.exp_loc.loc_start.pos_cnum) -exception Map_fields_elements_mismatch_number_args - -(* here, bind is the function to be applied to a field and an element, - and it returns an option, with None when the entry should be ignored, - and with a result otherwise, to be added to the list of results *) - -let map_filter_fields_elements bind fields elements = - let rec aux = function - | [], [] -> [] - | f :: fs, e :: es -> - let res = aux (fs,es) in - begin match bind f e with - | None -> res - | Some p -> p :: res (* p is a pair identifier, code to be bound *) - end - | _ -> raise Map_fields_elements_mismatch_number_args - in aux (fields, elements) - -let map_cstr_fields ?loc bind (cstr : constructor_description) elements = +let map_cstr_fields ?loc (sm : shadow_map) bind cstr elements = let fields = extract_cstr_attrs cstr in - try map_filter_fields_elements bind fields elements - with Map_fields_elements_mismatch_number_args -> + try map_opt_state2 bind sm fields elements + with Invalid_argument _ -> error ?loc ("Insufficient fieldnames for arguments to " ^ cstr.cstr_name) - (** Decomposition of functions *) @@ -301,10 +283,11 @@ let ppf_apply_infix f arg1 arg2 = let ppf_match_case c = Printf.sprintf "case %s" c +(* FIXME: shadows now a sm, always should introduce a var *) let ppf_match_binders binders = if binders = [] then "" else let binds = show_list "@," (List.map - (fun (id,se,shadows) -> Printf.sprintf "%s%s = %s;" (if shadows then "" else "var ") id se) binders) in + (fun (id,se) -> Printf.sprintf "var %s = %s;" id se) binders) in Printf.sprintf "@[%s@]" binds let ppf_let_tuple ids sbody = @@ -349,10 +332,6 @@ let ppf_for id start ed flag body = let ppf_cstr tag value = Some (Printf.sprintf "%s: %s" tag value) -(* deprecated: - let expanded_constructors = map_cstr_fields (*~loc*) ppf_cstr cd args in -*) - let ppf_cstrs styp cstr_name rest = let comma = if rest = "" then "" else "," in let styp_full = @@ -395,16 +374,34 @@ let js_keywords = "export"; "extends"; "finally"; "for"; "function"; "if"; "import"; "in"; "instanceof"; "new"; "return"; "super"; "switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while"; "with"; "yield"; "enum"] -let ppf_ident_name x = - if List.mem x js_keywords then - (* Variable name clashes with JS keyword: prefix with a \mathbb{V} character (\u1d54d) *) - "\xf0\x9d\x95\x8d" ^ x - else - (* Variable name contains ' (not supported by JS): replace with unicode prime symbol (\u02b9) *) - Str.global_replace (Str.regexp "'") "\xca\xb9" x +(** Conversion between integers and unicode \mathbb strings *) +(* 0-9 as unicode \mathbb{d} multibyte character strings *) +let ustr_bb_digits = Array.init 10 (fun i -> Printf.sprintf "\xf0\x9d\x9F%c" (char_of_int (0x98 + i))) + +(** Converts an integer into an array of decimal digits *) +let int_to_array = function +| 0 -> [0] +| i -> let rec f i acc = if i = 0 then acc else f (i/10) (i mod 10 :: acc) in f i [] + +(** Converts an integer i into a unicode string representation of \mathbb{i} *) +let int_to_bb_ustr i = String.concat "" (List.map (fun d -> ustr_bb_digits.(d)) (int_to_array i)) + +(* On with the variable name mangling *) + +let ppf_ident_name x sm = + let x' = + if List.mem x js_keywords then + (* Variable name clashes with JS keyword: prefix with a \mathbb{V} character (\u1d54d) *) + "\xf0\x9d\x95\x8d" ^ x + else + (* Variable name contains ' (not supported by JS): replace with unicode prime symbol (\u02b9) *) + Str.global_replace (Str.regexp "'") "\xca\xb9" x + in (* Append digits to handle non-shadowed ML variables that become shadowed in JS scopes *) + option_app x' (fun i -> x' ^ (int_to_bb_ustr i)) (ShadowMapM.find_opt x sm) -let ppf_ident i = - i |> Ident.name |> ppf_ident_name +(** Returns the JS version of the Ident name *) + let ppf_ident id sm = + ppf_ident_name (Ident.name id) sm let ppf_path = Path.name @@ -517,7 +514,6 @@ let generate_logged_if loc ctx sintro sarg siftrue siffalse = (*--------- match ---------*) let generate_logged_case loc spat binders ctx newctx sbody need_break = - (* Note: binders is a list of triples of id, shadowing flag *) (* Note: if binders = [], then newctx = ctx *) let (token_start, token_stop, token_loc) = token_fresh !current_mode loc in let sbinders_common () = @@ -526,7 +522,7 @@ let generate_logged_case loc spat binders ctx newctx sbody need_break = match !current_mode with | Mode_cmi -> assert false | Mode_pseudo _ -> - let args = List.map fst3 binders in + let args = List.map fst binders in let spat = (* LATER: use a cleaner separation with Case of (cstr,args) | Default *) if spat = "case ::" then begin let (x,y) = match args with [x;y] -> (x,y) | _ -> assert false in @@ -540,7 +536,7 @@ let generate_logged_case loc spat binders ctx newctx sbody need_break = | Mode_unlogged _ -> (token_start, spat, sbinders_common(), token_stop) | Mode_logged -> - let ids = List.map fst3 binders in + let ids = List.map fst binders in let mk_binding x = Printf.sprintf "{key: \"%s\", val: %s}" x x in @@ -665,7 +661,7 @@ let generate_logged_return loc ctx sbody = (** Destination-style translation of expressions *) -type dest = +type dest = | Dest_ignore | Dest_return | Dest_assign of string * bool (* bool indicates shadowing *) @@ -699,7 +695,7 @@ and js_of_constant = function | Const_int64 n -> Int64.to_string n | Const_nativeint n -> Nativeint.to_string n -let js_of_path_longident path ident = +let js_of_path_longident sm path ident = match String.concat "." @@ Longident.flatten ident.txt with (* for unit: *) | "()" -> unit_repr @@ -724,61 +720,56 @@ let js_of_path_longident path ident = | "/" -> "/" (* for string *) | "^" -> "+" (* !!TODO: we want to claim ability to type our sublanguage, so we should not use this *) - | res -> - let res = if !generate_qualified_names && (Path.head path).Ident.name <> "Stdlib" + | res -> + let res = if !generate_qualified_names && (Path.head path).Ident.name <> "Stdlib" then ppf_path path else res in - ppf_ident_name res + ppf_ident_name res sm -let is_triple_equal_comparison e = +let is_triple_equal_comparison e sm = match e.exp_desc with | Texp_ident (path, ident, _) -> - let sexp = js_of_path_longident path ident in + let sexp = js_of_path_longident sm path ident in sexp = "===" (* TODO: this text could be optimized *) | _ -> false -let ident_of_pat pat = match pat.pat_desc with - | Tpat_var (id, _) -> ppf_ident id +let str_ident_of_pat sm pat = match pat.pat_desc with + | Tpat_var (id, _) -> Ident.name id + | Tpat_any -> id_fresh "_pat_any_" + | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values" + +let ppf_ident_of_pat sm pat = match pat.pat_desc with + | Tpat_var (id, _) -> ppf_ident id sm | Tpat_any -> id_fresh "_pat_any_" | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values" -(* takes a list of pairs made of: list of strings, and list of strings, +(* takes a list of pairs made of: list of strings, and list of strings, and return a pair of a string (the string concat with newlines of the fst strings), and a list of strings (the list flatten of the snd strings) *) -let combine_list_output args = +let combine_list_output args = let (strs,bss) = List.split args in (show_list "@,@," strs), (List.flatten bss) -let mapiopt f = - let rec aux i = function - | [] -> [] - | hd :: tl -> - let ro = f i hd in begin - match ro with - | Some r -> r :: aux (i+1) tl - | None -> aux (i+1) tl - end - in - aux 0 - (* returns a pair (x,e), where [x] in the name in [pat] and where [e] is the access to "stupleobj[index]" *) -let tuple_component_bind stupleobj index pat = +let tuple_component_bind stupleobj (result, index, sm) pat = let loc = pat.pat_loc in match pat.pat_desc with | Tpat_var (id, _) -> - let sid = ppf_ident id in - Some (sid, Printf.sprintf "%s[%d]" stupleobj index, do_check_shadowing pat.pat_env sid) - | Tpat_any -> None + let sm = update_shadow_map sm pat.pat_env id in + let sid = ppf_ident id sm in + ((sid, Printf.sprintf "%s[%d]" stupleobj index)::result, index+1, sm) + | Tpat_any -> (result, index+1, sm) | _ -> out_of_scope loc "Nested pattern matching" (* returns a list of pairs of the form (x,e), corresponding to the bindings to be performed for decomposing [stupleobj] as the tuple of patterns [pl]. *) -let tuple_binders stupleobj pl = - mapiopt (tuple_component_bind stupleobj) pl +let tuple_binders stupleobj sm pl = + let (result, _, sm) = List.fold_left (tuple_component_bind stupleobj) ([], 0, sm) pl in + (result, sm) (****************************************************************) (* TRANSLATION *) @@ -796,20 +787,18 @@ let rec js_of_structure s = let postfix = List.fold_left (fun str path -> str ^ "@,}// end of with " ^ ppf_path path) "" open_paths in (prefix ^ "@," ^ contents ^ postfix, namesbound) -and show_value_binding ctx vb = (* dest is Ignore *) - js_of_let_pattern ctx vb.vb_pat vb.vb_expr - and js_of_structure_item s = let loc = s.str_loc in match s.str_desc with | Tstr_eval (e, _) -> - let str = Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore e in + let str = Printf.sprintf "%s" @@ js_of_expression ShadowMapM.empty ctx_initial Dest_ignore e in (str, []) - | Tstr_value (_, vb_l) -> - combine_list_output (~~ List.map vb_l (fun vb -> - let id = ident_of_pat vb.vb_pat in - check_shadowing ~loc:loc s.str_env id; - let sbody = js_of_expression_inline_or_wrap ctx_initial vb.vb_expr in + | Tstr_value (_, vb_l) -> + combine_list_output (~~ List.map vb_l (fun vb -> + let id = str_ident_of_pat ShadowMapM.empty vb.vb_pat in + if ident_is_shadowing s.str_env id then error ~loc "Variable shadowing not permitted at toplevel" + else + let sbody = js_of_expression_inline_or_wrap ShadowMapM.empty ctx_initial vb.vb_expr in let s = Printf.sprintf "@[var %s = %s;@]" id sbody in (s, [id]))) | Tstr_type (rec_flag, decls) -> @@ -821,7 +810,7 @@ and js_of_structure_item s = let cstr_name = cd.Types.cd_id.Ident.name in let fields = extract_cstr_attrs_basic cstr_name cd.cd_attributes in let sargs = show_list ", " fields in - let sbindings = map_filter_fields_elements ppf_cstr fields fields in + let sbindings = map_opt2 (fun x y -> ppf_cstr x y) fields fields in (* FIXME: twice fields, really?! *) let rest = show_list ", " sbindings in let cstr_name = rename_constructor cstr_name in let sobj = ppf_cstrs styp cstr_name rest in @@ -844,43 +833,45 @@ and js_of_structure_item s = if l.txt = "ocaml.doc" || l.txt = "ocaml.text" then ("",[]) else out_of_scope loc "attributes" -and js_of_branch ctx dest b eobj = - let spat, binders = js_of_pattern b.c_lhs eobj in +(* Translates each pattern/subexpression pair branch of a match expression *) +and js_of_branch sm ctx dest b eobj = + let spat, binders, sm = js_of_pattern sm b.c_lhs eobj in let newctx = if binders = [] then ctx else ctx_fresh() in - let sbody = js_of_expression newctx dest b.c_rhs in + let sbody = js_of_expression sm newctx dest b.c_rhs in let need_break = (dest <> Dest_return) in - generate_logged_case b.c_lhs.pat_loc spat binders ctx newctx sbody need_break - -and js_of_expression_inline_or_wrap ctx e = + generate_logged_case b.c_lhs.pat_loc spat binders ctx newctx sbody need_break + (* there is no need to propagate the updated [sm] back up the tree, as pattern bound only in [sbody] *) + +and js_of_expression_inline_or_wrap sm ctx e = try - js_of_expression ctx Dest_inline e + js_of_expression sm ctx Dest_inline e with Not_good_for_dest_inline -> - js_of_expression_wrapped ctx e + js_of_expression_wrapped sm 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_wrapped sm ctx e = (* dest = Dest_return *) + ppf_lambda_wrap (js_of_expression sm ctx Dest_return e) -and js_of_expression_naming_argument_if_non_variable ctx obj name_prefix = +and js_of_expression_naming_argument_if_non_variable sm ctx obj name_prefix = if is_mode_pseudo() then begin - "", js_of_expression ctx Dest_ignore obj + "", js_of_expression sm ctx Dest_ignore obj end else begin match obj.exp_desc with | Texp_ident (path, ident, _) -> - "", (js_of_path_longident path ident) + "", (js_of_path_longident sm path ident) | _ -> (* generate var id = sexp; *) let id = id_fresh name_prefix in - let sintro = js_of_expression ctx (Dest_assign (id, false)) obj in + let sintro = js_of_expression sm ctx (Dest_assign (id, false)) obj in (sintro ^ "@,"), id end -and js_of_expression ctx dest e = - let inline_of_wrap = js_of_expression_inline_or_wrap ctx in (* shorthand *) +and js_of_expression (sm : shadow_map) ctx dest e = + let inline_of_wrap = js_of_expression_inline_or_wrap sm ctx in (* shorthand *) let loc = e.exp_loc in let apply_dest' = apply_dest loc in match e.exp_desc with | Texp_ident (path, ident, _) -> - let sexp = js_of_path_longident path ident in + let sexp = js_of_path_longident sm path ident in let sexp = if sexp = "not" then "!" else sexp in (* hack for renaming "not" on the fly *) apply_dest' ctx dest sexp @@ -889,48 +880,57 @@ and js_of_expression ctx dest e = apply_dest' ctx dest sexp | Texp_let (_, vb_l, e) -> + (* [vb_l] is a list of value bindings, corresponding to each term of a [let vb_0 and vb_1 and vb_2] *) + (* TODO: Handle mixed tuple/record/standard vbs let expressions *) reject_inline dest; - let (ids, sdecl) = begin match vb_l with + let (ids, sdecl, sm') = begin match vb_l with | [ { vb_pat = { pat_desc = Tpat_tuple pl }; vb_expr = obj } ] -> (* binding tuples *) - let (sintro, stupleobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_tuple_arg_" in - let binders = tuple_binders stupleobj pl in - let ids = List.map fst3 binders in + let (sintro, stupleobj) = js_of_expression_naming_argument_if_non_variable sm ctx obj "_tuple_arg_" in + let (binders, sm') = tuple_binders stupleobj sm pl in + let ids = List.map fst binders in let sdecl = if is_mode_pseudo() then begin - ppf_let_tuple ids stupleobj + ppf_let_tuple ids stupleobj end else begin ppf_match_binders binders end in - (ids, sintro ^ sdecl) + (ids, sintro ^ sdecl, sm') | [ { vb_pat = { pat_desc = Tpat_record (args, closed_flag) }; vb_expr = obj } ] -> (* binding records -- used in JsCommon.ml *) (* args : (Longident.t loc * label_description * pattern) list *) - let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_record_arg_" in - let bind (arg_loc,label_descr,pat) = + let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable sm ctx obj "_record_arg_" in + let bind sm' (arg_loc,label_descr,pat) = let name = label_descr.lbl_name in match pat.pat_desc with | Tpat_var (id, _) -> - let sid = ppf_ident id in - (sid, Printf.sprintf "%s.%s" seobj name, do_check_shadowing pat.pat_env sid) + let sm' = update_shadow_map sm' pat.pat_env id in + let sid = ppf_ident id sm' in + (sm', (sid, Printf.sprintf "%s.%s" seobj name)) | Tpat_any -> out_of_scope e.exp_loc "Underscore pattern in let-record" | _ -> out_of_scope e.exp_loc "Nested pattern matching" in - let binders = List.map bind args in - let ids = List.map fst3 binders in + let sm', binders = map_state bind sm args in + let ids = List.map fst binders in let sdecl = if is_mode_pseudo() then begin ppf_let_record ids seobj end else begin ppf_match_binders binders end in - (ids, sintro ^ sdecl) + (ids, sintro ^ sdecl, sm') | _ -> (* 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) + (* vb subexpressions are in the context of overall expression: use constant sm for this, + but fold over a changing new_sm for the created bindings *) + let folder vb (sids, jsexprs, new_sm) = + let (sid, jsexpr, new_sm) = js_of_let_pattern sm new_sm ctx vb in + (sid::sids, jsexpr::jsexprs, new_sm) + in + let (ids, sdecls, new_sm) = List.fold_right folder vb_l ([], [], sm) in + let sdecl = String.concat lin1 sdecls in + (ids, sdecl, new_sm) end in + let sbody = js_of_expression sm' ctx dest e in let newctx = ctx_fresh() in - let sbody = js_of_expression newctx dest e in let sexp = generate_logged_let loc ids ctx newctx sdecl sbody in sexp @@ -938,7 +938,7 @@ and js_of_expression ctx dest e = let pats, body = function_get_args_and_body e (* DEPRECATED: function_get_args_and_body e [c.c_lhs] c.c_rhs *) in let pats_clean = List.filter (fun pat -> is_mode_not_pseudo() || not (is_hidden_type pat.pat_type)) pats in - let arg_ids = List.map ident_of_pat pats_clean in + let arg_ids = List.map (ppf_ident_of_pat sm) pats_clean in (* FUTURE USE: (for function taking tuples as args) let arg_idss, tuplebindingss = List.split (List.map (fun pat -> match pat.pat_desc with @@ -972,7 +972,7 @@ and js_of_expression ctx dest e = *) let stuplebindings = "" in let newctx = ctx_fresh() in - let sbody = js_of_expression newctx Dest_return body in + let sbody = js_of_expression sm newctx Dest_return body in let sexp = generate_logged_enter body.exp_loc arg_ids ctx newctx sbody in apply_dest' ctx dest (stuplebindings ^ sexp) @@ -999,17 +999,18 @@ and js_of_expression ctx dest e = let sexp1 = inline_of_wrap e1 in let pats,body = function_get_args_and_body e2 in let newctx = ctx_fresh() in - let sbody = js_of_expression newctx Dest_return body in + let sbody = js_of_expression sm newctx Dest_return body in let pats_clean = List.filter (fun pat -> is_mode_not_pseudo() || not (is_hidden_type pat.pat_type)) pats in (* OLD let arg_ids = List.map ident_of_pat pats_clean in*) let arg_idss, bound_idss, tuplebindingss = list_split3 (List.map (fun pat -> + (* FIXME: todo later *) match pat.pat_desc with - | Tpat_var (id, _) -> let x = ppf_ident id in [x], [x], [] + | Tpat_var (id, _) -> let x = ppf_ident id sm in [x], [x], [] | Tpat_any -> let x = id_fresh "_pat_any_" in [x], [], [] | Tpat_tuple pl -> let a = id_fresh "_tuple_arg_" in - let binders = tuple_binders a pl in - let xs = List.map fst3 binders in + let binders, sm = tuple_binders a sm pl in + let xs = List.map fst binders in if is_mode_pseudo() then begin (* the name [a] is ignored in this case *) let arg = Printf.sprintf "(%s)" (show_list ",@ " xs) in @@ -1094,7 +1095,7 @@ and js_of_expression ctx dest e = let se = inline_of_wrap f in let sexp = - if is_triple_equal_comparison f then begin + if is_triple_equal_comparison f sm then begin if (List.length exp_l <> 2) then out_of_scope loc "=== should be applied to 2 arguments"; let typ = (List.hd sl_clean).exp_type in @@ -1140,8 +1141,8 @@ and js_of_expression ctx dest e = | Texp_match (obj, l, [], Total) -> reject_inline dest; - let (sintro, sarg) = js_of_expression_naming_argument_if_non_variable ctx obj "_switch_arg_" in - let sbranches = String.concat "@," (List.map (fun b -> js_of_branch ctx dest b sarg) l) in + let (sintro, sarg) = js_of_expression_naming_argument_if_non_variable sm ctx obj "_switch_arg_" in + let sbranches = String.concat "@," (List.map (fun b -> js_of_branch sm ctx dest b sarg) l) in let arg_is_constant = exp_type_is_constant obj in generate_logged_match loc ctx sintro sarg sbranches arg_is_constant @@ -1194,13 +1195,13 @@ and js_of_expression ctx dest e = let (sintro, se1) = match !current_mode with | Mode_logged -> - let (sintro, sobj) = js_of_expression_naming_argument_if_non_variable ctx e1 "_if_arg_" in + let (sintro, sobj) = js_of_expression_naming_argument_if_non_variable sm ctx e1 "_if_arg_" in (sintro, sobj) | _ -> ("", inline_of_wrap e1) in - generate_logged_if loc ctx sintro se1 (js_of_expression ctx dest e2) (js_of_expression ctx dest e3) + generate_logged_if loc ctx sintro se1 (js_of_expression sm ctx dest e2) (js_of_expression sm ctx dest e3) | Texp_sequence (e1, e2) -> - ppf_sequence (inline_of_wrap e1) (js_of_expression ctx dest e2) + ppf_sequence (inline_of_wrap e1) (js_of_expression sm ctx dest e2) | Texp_while (cd, body) -> out_of_scope loc "while" (* ppf_while (js_of_expression cd) (js_of_expression body) *) | Texp_for (id, _, st, ed, fl, body) -> out_of_scope loc "for" @@ -1254,7 +1255,7 @@ and js_of_expression ctx dest e = c_rhs = mk_exp (Texp_match (thearg, cases, [], Total)); } in let exp = mk_exp (Texp_function (Nolabel, [thecase], Total)) in - js_of_expression ctx dest exp + js_of_expression sm ctx dest exp | Texp_assert _ -> out_of_scope loc "assert (please use assert ppx syntax)" | Texp_match (_,_,_, Partial) -> out_of_scope loc "partial matching" @@ -1273,13 +1274,14 @@ and js_of_expression ctx dest e = | Texp_lazy _ -> out_of_scope loc "lazy expressions" | Texp_object (_,_) -> out_of_scope loc "objects" | Texp_pack _ -> out_of_scope loc "packing" - | _ -> out_of_scope loc "ADD ME" + | _ -> out_of_scope loc "Unknown js_of_expression Texp value" (* returns the name bound and the code that assigns a value to this name *) -and js_of_let_pattern ctx pat expr = - let id = +and js_of_let_pattern sm new_sm ctx vb = + let { vb_pat = pat; vb_expr = expr } = vb in + let id = match pat.pat_desc with - | Tpat_var (id, _) -> ppf_ident id + | Tpat_var (id, _) -> id | Tpat_any -> out_of_scope pat.pat_loc "_ in let" | Tpat_alias _ -> out_of_scope pat.pat_loc "alias in let" | Tpat_constant _ -> out_of_scope pat.pat_loc "constant in let" @@ -1292,7 +1294,10 @@ and js_of_let_pattern ctx pat expr = | Tpat_lazy _ -> out_of_scope pat.pat_loc "lazy" (* error ~loc:pat.pat_loc "let can't deconstruct values" *) in - (id, js_of_expression ctx (Dest_assign (id, do_check_shadowing pat.pat_env id)) expr) + let new_sm = update_shadow_map new_sm pat.pat_env id in + let sid = ppf_ident id new_sm in + let js_expr = js_of_expression sm ctx (Dest_assign (sid, false (*FIXME*))) expr in + (sid, js_expr, new_sm) (* LATER: for let (x,y) = e, encode as translate(e,assign z); x = z[0]; y=z[1] | Tpat_tuple (pat_l) @@ -1310,27 +1315,27 @@ and js_of_let_pattern ctx pat expr = and a list of assignements of variables (pairs of identifier and body). Nested patterns are not supported. It returns a pair: spat (the "case" instruction), binders (the assignements) *) -and js_of_pattern pat obj = +and js_of_pattern sm pat obj = let loc = pat.pat_loc in match pat.pat_desc with | Tpat_any -> - "default", [] + "default", [], sm | Tpat_constant c -> - ppf_match_case (js_of_constant c), [] + ppf_match_case (js_of_constant c), [], sm | Tpat_construct (_, cd, el) -> let c = cd.cstr_name in - let spat = - if is_sbool c || is_mode_pseudo() then ppf_match_case c else ppf_match_case ("\"" ^ c ^ "\"") in - let bind field var = + let spat = if is_sbool c || is_mode_pseudo() then ppf_match_case c else ppf_match_case ("\"" ^ c ^ "\"") in + let bind sm field var = match var.pat_desc with | Tpat_var (id, _) -> - let sid = ppf_ident id in - Some (sid, Printf.sprintf "%s.%s" obj field, do_check_shadowing var.pat_env sid) + let sm = update_shadow_map sm var.pat_env id in + let sid = ppf_ident id sm in + Some (sm, (sid, Printf.sprintf "%s.%s" obj field)) | Tpat_any -> None | _ -> out_of_scope var.pat_loc "Nested pattern matching" in - let binders = map_cstr_fields ~loc bind cd el in - spat, binders + let sm, binders = map_cstr_fields ~loc sm bind cd el in + spat, binders, sm | Tpat_var (id, _) -> unsupported ~loc "Tpat_var" | Tpat_tuple el -> unsupported ~loc "tuple matching, if not in a simple let-binding" | Tpat_array el -> unsupported ~loc "array-match" diff --git a/map406.ml b/map406.ml new file mode 100644 index 0000000..5ae8c53 --- /dev/null +++ b/map406.ml @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) +(* Functions backported from OCaml 4.06 *) +(* TODO: Remove this file once js_of_ast.ml is converted to 4.06 *) + +module Make(Ord:Map.OrderedType) = + struct + include Map.Make(Ord) + type 'a impl = + Empty + | Node of {l:'a impl; v:key; d:'a; r:'a impl; h:int} + + external impl_of_t : 'a t -> 'a impl = "%identity" + external t_of_impl : 'a impl -> 'a t = "%identity" + + let height = function + Empty -> 0 + | Node {h} -> h + + let create l x d r = + let hl = height l and hr = height r in + Node{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let bal l x d r = + let hl = match l with Empty -> 0 | Node {h} -> h in + let hr = match r with Empty -> 0 | Node {h} -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node{l=ll; v=lv; d=ld; r=lr} -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node{l=lrl; v=lrv; d=lrd; r=lrr}-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node{l=rl; v=rv; d=rd; r=rr} -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node{l=rll; v=rlv; d=rld; r=rlr} -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node {l=Empty; r} -> r + | Node {l; v; d; r} -> bal (remove_min_binding l) v d r + + let merge' t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding (t_of_impl t2) in + bal t1 x d (remove_min_binding t2) + + let update x f t = + let rec update' x f = function + Empty -> + begin match f None with + | None -> Empty + | Some data -> Node{l=Empty; v=x; d=data; r=Empty; h=1} + end + | Node {l; v; d; r; h} as m -> + let c = Ord.compare x v in + if c = 0 then begin + match f (Some d) with + | None -> merge' l r + | Some data -> + if d == data then m else Node{l; v=x; d=data; r; h} + end else if c < 0 then + let ll = update' x f l in + if l == ll then m else bal ll v d r + else + let rr = update' x f r in + if r == rr then m else bal l v d rr + in t_of_impl (update' x f (impl_of_t t)) + + let rec find_opt x m = + match (impl_of_t m) with + Empty -> + None + | Node {l; v; d; r} -> + let c = Ord.compare x v in + if c = 0 then Some d + else find_opt x (t_of_impl (if c < 0 then l else r)) + end + diff --git a/mytools.ml b/mytools.ml index 3f41fc5..3f0b857 100644 --- a/mytools.ml +++ b/mytools.ml @@ -40,12 +40,7 @@ let bool_of_option xo = let rec list_make n v = if n = 0 then [] else v::(list_make (n-1) v) -let list_mapi f l = - let rec aux i = function - | [] -> [] - | h::t -> (f i h)::(aux (i+1) t) - in - aux 0 l +let list_mapi f l = List.mapi let range i j = let rec aux j acc = @@ -65,6 +60,40 @@ let rec filter_somes = function | None :: l -> filter_somes l | (Some x) :: l -> x :: filter_somes l +let map_opt f l = filter_somes @@ List.map f l +let map_opt2 f l1 l2 = filter_somes @@ List.map2 f l1 l2 + +(* A list map with left-fold for state update propagation *) +let rec map_state f st l = match l with + | [] -> (st, []) + | i :: l' -> + let (st', i') = f st i in + let (st'', l'') = map_state f st' l' in + (st'', i' :: l'') + +(* A list map with left-fold for state update propagation, removing any None results *) +let rec map_opt_state f st l = match l with + | [] -> (st, []) + | i :: l' -> begin + match f st i with + | None -> map_opt_state f st l' + | Some (st', i') -> + let (st'', rl) = map_opt_state f st' l' in + (st'', i' :: rl) + end + +(* A 2 list version of map_opt_state *) +let rec map_opt_state2 f st l1 l2 = match (l1, l2) with + | [], [] -> (st, []) + | i1 :: l1', i2 :: l2' -> begin + match f st i1 i2 with + | None -> map_opt_state2 f st l1' l2' + | Some (st', r) -> + let (st'', rl) = map_opt_state2 f st' l1' l2' in + (st'', r :: rl) + end + | _ -> raise (Invalid_argument "map_opt_state2 called with lists of differing lengths") + let list_unique l = let rec aux acc = function | [] -> acc diff --git a/tests/shadow.ml b/tests/shadow.ml index e7b8ff9..fb735ea 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -1,15 +1,18 @@ (* `make shadow.unlog.js` and test resulting function in node add a print_int to the shadower line and `ocamlc shadow.ml` to validate ml *) +(** Inner-most scope should not hide outermost, incorrect JS behaviour would be to execute undefined + 1 **) let shadower n = let f _ = - let n = n+1 in + let (n, z) = n+1, () in n+1 in f () ;; shadower 1;; (* Expected return value: 3 *) +(** As previous, but using a pattern binder instead of let **) + type shadow = | Shadow of int [@f num] @@ -32,4 +35,13 @@ let f _ = y (y x) ;; -console_int (f ()) (* Expected return value: 3 *) +f () (* Expected return value: 3 *) +;; + +(** Things we want to be able to do, for example: **) +let x = 10 in +let x = x + x in +let x = x + x + x in +x + +;; From 0095a23dee576957e22760297e99e135e85ec528 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 1 Jun 2018 20:25:43 +0100 Subject: [PATCH 33/46] Unit tests for generator Implement a test framework that can run unit tests for generated code in both ml and js. The test framework has a similar library interface to the JS Mocha library. The JS implementation is backed by Mocha, the ML implementation is backed by Alcotest. Add assertions to existing hand-run testcases. Note that not all the testcases are passing at present -- this exercise has revealed some known (scope) and unknown (tuple) bugs. --- Makefile | 4 ++ stdlib_ml/stdlib.js | 4 +- stdlib_ml/stdlib.ml | 2 - stdlib_ml/stdlib.mli | 2 - tests/.gitignore | 2 + tests/Compare.js | 2 + tests/Makefile | 50 +++++++++++++++++++--- tests/apply.ml | 10 +++++ tests/arith.ml | 23 ++++++++++ tests/calc.ml | 80 ++++++++++++++++++++++++++++------ tests/let.ml | 50 +++++++++++++++++++++- tests/letno.ml | 11 +++++ tests/lettuple.ml | 33 ++++++++++++++ tests/lib/mocha.js | 23 ++++++++++ tests/lib/mocha.ml | 78 +++++++++++++++++++++++++++++++++ tests/lib/mocha.mli | 86 +++++++++++++++++++++++++++++++++++++ tests/mini.ml | 10 +++++ tests/mylist.ml | 100 ++++++++++++++++++++++++++++++------------- tests/records.ml | 33 ++++++++++++-- tests/shadow.ml | 81 +++++++++++++++++------------------ tests/stack.ml | 12 ------ tests/testctx.ml | 53 ++++++++++++++++++++++- tests/types.ml | 8 ---- 23 files changed, 636 insertions(+), 121 deletions(-) create mode 100644 tests/Compare.js create mode 100644 tests/lib/mocha.js create mode 100644 tests/lib/mocha.ml create mode 100644 tests/lib/mocha.mli delete mode 100644 tests/stack.ml delete mode 100644 tests/types.ml diff --git a/Makefile b/Makefile index a427db5..7ab0c6f 100644 --- a/Makefile +++ b/Makefile @@ -7,6 +7,9 @@ all: byte native stdlib byte: $(addsuffix .byte,$(EXECUTABLES)) native: $(addsuffix .native,$(EXECUTABLES)) +test: byte stdlib + $(MAKE) -C tests test + stdlib: $(MAKE) -C $(STDLIB_DIR) @@ -27,6 +30,7 @@ clean: ocamlbuild -clean bash -c "rm -f .ocamldebug" $(MAKE) -C $(STDLIB_DIR) clean + $(MAKE) -C tests clean .PHONY: default all byte native stdlib debug clean diff --git a/stdlib_ml/stdlib.js b/stdlib_ml/stdlib.js index 705788e..59e2c7b 100644 --- a/stdlib_ml/stdlib.js +++ b/stdlib_ml/stdlib.js @@ -30,7 +30,7 @@ var mk_cons = function(head, tail) { // val raise : exn -> 'a var raise = function(x) { throw "Not_found"; }; -var failwith = function(str) { throw str; }; +var failwith = function(str) { throw Error(str); }; //---------------------------------------------------------------------------- // Boolean operations @@ -183,5 +183,3 @@ var substring = function(n, m, s) { throw "strlength invalid arguments"; return s.slice(n, n+m); }; - -var console_int = console.log; diff --git a/stdlib_ml/stdlib.ml b/stdlib_ml/stdlib.ml index 3a1506f..a79ec1d 100644 --- a/stdlib_ml/stdlib.ml +++ b/stdlib_ml/stdlib.ml @@ -149,5 +149,3 @@ val string_concat : string -> string -> string (* + *) let strlength = String.length;; let substring n m s = String.sub s n m;; - -let console_int = Pervasives.print_int;; diff --git a/stdlib_ml/stdlib.mli b/stdlib_ml/stdlib.mli index 2c19e3b..7fc4c62 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -186,5 +186,3 @@ val strlength : string -> int (* in JS : function (x) { return x.length; } *) (** Substring extraction. Note different ordering of arguments from String.sub: [ substring n m s = String.sub s n m ] *) val substring : int -> int -> string -> string (* function(x) { return x.slice(n, n+m); } *) - -val console_int : int -> unit diff --git a/tests/.gitignore b/tests/.gitignore index 32b0e23..bffca1e 100644 --- a/tests/.gitignore +++ b/tests/.gitignore @@ -4,3 +4,5 @@ *.cmi *.token.js *.mlloc.js +*.as.js +test_ml diff --git a/tests/Compare.js b/tests/Compare.js new file mode 100644 index 0000000..688b317 --- /dev/null +++ b/tests/Compare.js @@ -0,0 +1,2 @@ +const _compare_generic = require('util').isDeepStrictEqual; +const _compare_stack = _compare_generic; diff --git a/tests/Makefile b/tests/Makefile index f716ec9..f83bb7e 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,11 +1,51 @@ -test: ../monad_ppx.byte let.ml - ocamlc -ppx ../monad_ppx.byte let.ml +STDLIB_DIR := ../stdlib_ml +LIBS := -I lib -I $(STDLIB_DIR) +REPLACE_STDLIB := -nopervasives -nostdlib -open Stdlib +LINK_LIBS := $(STDLIB_DIR)/stdlib.cmo lib/mocha.cmo + +TESTS := $(wildcard *.ml) +TESTS_JS := $(patsubst %.ml,%.unlog.as.js,$(TESTS)) + +test: test_ml test_js + $(MAKE) -k _run_test + +_run_test: run_test_ml run_test_js + +run_test_ml: + @./test_ml + +test_ml: $(LINK_LIBS) $(patsubst %.ml,%.cmo,$(TESTS)) | lib/mocha.cmi + ocamlfind ocamlc -package alcotest -linkpkg -g $(LIBS) $^ -o $@ + +run_test_js: $(TESTS_JS) + @echo -e "\n*** Testing JS-generated tests ***\n" + @mocha -R list $^ + +test_js: $(TESTS_JS) %.unlog.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode unlog -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode unlog -ppx ../monad_ppx.byte $(LIBS) $< %.log.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode log -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode log -ppx ../monad_ppx.byte $(LIBS) $< %.token.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode token -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode token -ppx ../monad_ppx.byte $(LIBS) $< + +%.as.js: $(patsubst %.cmo,%.js,$(LINK_LIBS)) Compare.js %.js + ../assembly.byte -o $@ $^ + +lib/%.cmi: lib/%.mli + ocamlfind ocamlc -package alcotest -c $< -o $@ + +lib/%.cmo: lib/%.ml lib/%.cmi + ocamlfind ocamlc -package alcotest -c -I lib $< -o $@ + +%.cmo: %.ml + ocamlc -c -g $(REPLACE_STDLIB) $(LIBS) $< -o $@ + +clean: + rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} + +.PRECIOUS: %.js %.unlog.js +.NOTPARALLEL: diff --git a/tests/apply.ml b/tests/apply.ml index 113b1a5..5b7242e 100644 --- a/tests/apply.ml +++ b/tests/apply.ml @@ -1,3 +1,13 @@ +open Mocha + let foo y = () let x = foo () + +;; + +describe "apply.ml" (fun _ -> + it "foo ()" (fun _ -> + assert_unit x + ) +) diff --git a/tests/arith.ml b/tests/arith.ml index 0e62112..91d9c99 100644 --- a/tests/arith.ml +++ b/tests/arith.ml @@ -1,3 +1,26 @@ +open Mocha + let myadd x y = x +. y let subst x = x-1 + +;; + +describe "arith.ml" (fun _ -> + describe "myadd x y" (fun _ -> + it "1 2" (fun _ -> + assert_float (myadd 1. 2.) 3. "!= 3" + ); + it "-1 1" (fun _ -> + assert_float (myadd 1. (-1.)) 0. "!= 0" + ) + ); + describe "subst x" (fun _ -> + it "1" (fun _ -> + assert_int (subst 1) 0 "!= 0" + ); + it "0" (fun _ -> + assert_int (subst 0) (-1) "!= -1" + ) + ) +) diff --git a/tests/calc.ml b/tests/calc.ml index 5a0daa1..5d41f24 100644 --- a/tests/calc.ml +++ b/tests/calc.ml @@ -1,13 +1,28 @@ +open Mocha + +type stack = + | C of int * stack [@f value, stack] + | N [@f] + +let is_empty s = s === N + +let push x stack = C(x, stack) + +let pop stack = + match stack with + | C (x, xs) -> x + | N -> failwith "Empty list" + type expr = - | Const [@f value] of int - | Add [@f left, right] of expr * expr - | Sub [@f left, right] of expr * expr - | Mul [@f left, right] of expr * expr - | Div [@f left, right] of expr * expr - | Pop [@f stack] of sexpr + | Const of int [@f value] + | Add of expr * expr [@f left, right] + | Sub of expr * expr [@f left, right] + | Mul of expr * expr [@f left, right] + | Div of expr * expr [@f left, right] + | Pop of sexpr [@f stack] and sexpr = | Emp [@f] - | Push [@f value, stack] of expr * sexpr + | Push of expr * sexpr [@f value, stack] let rec run expr = match expr with | Const n -> n @@ -15,11 +30,50 @@ let rec run expr = match expr with | Sub (ls, rs) -> run ls - run rs | Mul (ls, rs) -> run ls * run rs | Div (ls, rs) -> run ls / run rs - | Pop s -> Stack.pop (evals s) + | Pop s -> pop (evals s) and evals sexpr = match sexpr with - | Emp -> Stack.N - | Push (v, s) -> Stack.push (run v) (evals s) + | Emp -> N + | Push (v, s) -> push (run v) (evals s) + +let rec mapMystack f s = match s with + | N -> N + | C (x, xs) -> C (f x, mapMystack f xs) + +;; -let rec mapStack f s = match s with - | Stack.N -> Stack.N - | Stack.C (x, xs) -> Stack.C (f x, mapStack f xs) +describe "calc.ml" (fun _ -> + it "is_empty" (fun _ -> + assert_ok (is_empty N) "N => true"; + assert_ok (not (is_empty (C(0,N)))) "C(0,N) => false"; + assert_ok (not (is_empty (C(1,N)))) "C(1,N) => false"; + assert_ok (not (is_empty (C(0,C(0,N))))) "C(0,C(0,N)) => false" + ); + it "push" (fun _ -> + let s = push 0 N in + assert_struct_eq s (C(0,N)) "push 0 N === C(0,N)"; + let s = push 1 s in + assert_struct_eq s (C(1,C(0,N))) "push 1 s === C(1,C(0,N))" + ); + it "pop" (fun _ -> + assert_int (pop (C (4,N))) 4 "pop S(4,N) === 4"; + assert_failwith (fun _ -> pop N) "Empty list" "Popping an empty list should fail" + ); + it "run" (fun _ -> + assert_int (run (Const 42)) 42 "run (Const 42) === 42"; + assert_int (run (Add(Const 10, Const 20))) 30 "run (10+20) === 30"; + assert_int (run (Add (Add(Const 1, Const 2), Const 3))) 6 "run (1+2)+3 === 6"; + assert_int (run (Div(Const 6, Add(Const 1, Const 1)))) 3 "run 6/(1+1) === 3"; + assert_int (run (Mul (Const 2, Const 3))) 6 "run 2*3 === 6"; + assert_int (run (Sub (Sub (Const 6, Const 2), Const 1))) 3 "run (6-2)-1 === 3"; + assert_int (run (Pop (Push (Const 1, Emp)))) 1 "run pop [1] === 1"; + assert_struct_eq (evals Emp) N "evals Emp === N"; + assert_struct_eq (evals (Push(Const 1, Emp))) (C(1,N)) "evals push 1 [] === [1]"; + assert_failwith (fun _ -> run (Pop Emp)) "Empty list" "Popping an empty list should fail" + ); + it "mapMystack" (fun _ -> + let f1 x = x + 1 in + let f2 _ = 0 in + assert_struct_eq (mapMystack f1 (C(0,C(1,C(2,C(3,N)))))) (C(1,C(2,C(3,C(4,N))))) "mapMystack (+1) [0,1,2,3] === [1,2,3,4]"; + assert_struct_eq (mapMystack f2 (C(0,C(1,C(2,C(3,N)))))) (C(0,C(0,C(0,C(0,N))))) "mapMystack (_->0) [0,1,2,3] === [0,0,0,0]" + ) +) diff --git a/tests/let.ml b/tests/let.ml index 1dd4f2b..41048d8 100644 --- a/tests/let.ml +++ b/tests/let.ml @@ -1,3 +1,5 @@ +open Mocha + let test0 x = let y = 2*x in y+y @@ -24,11 +26,55 @@ let affiche x = match x with let pet = Petite 5 let cinq = 5 -let test b = match b with +let test1 b = match b with | true -> () | false -> () -let test x = match x with +let test2 x = match x with | 1 -> () | 2 -> () | _ -> () + +;; + +describe "let.ml" (fun _ -> + it "test0" (fun _ -> + assert_int (test0 5) 20 "test0 5 === 20"; + assert_int (test0 0) 0 "test0 0 === 0" + ); + it "foo" (fun _ -> + assert_int (foo 1) 1 "foo _ === 1"; + assert_int (foo 0) 1 "foo _ === 1" + ); + it "app" (fun _ -> + assert_int (app 0) 0 "app x === x"; + assert_string (app "test") "test" "app x === x"; + assert_float (app 1.1) 1.1 "app x === x"; + assert_bool (app true) true "app x === x"; + assert_unit (app ()) + ); + it "app2" (fun _ -> + assert_int (app2 0) 0 "app2 x === x"; + assert_string (app2 "test") "test" "app2 x === x"; + assert_float (app2 1.1) 1.1 "app2 x === x"; + assert_bool (app2 true) true "app2 x === x"; + assert_unit (app2 ()) + ); + it "affiche" (fun _ -> + assert_string (affiche As) "As" "affiche As === 'As'"; + assert_string (affiche (Petite 1)) "Petite" "affiche (Petite _) === 'Petite'"; + ); + it "consts" (fun _ -> + assert_struct_eq pet (Petite 5) "pet === (Petite 5)"; + assert_int cinq 5 "cinq === 5" + ); + it "test1" (fun _ -> + assert_unit (test1 true); + assert_unit (test1 false) + ); + it "test2" (fun _ -> + assert_unit (test2 0); + assert_unit (test2 1); + assert_unit (test2 2) + ) +) diff --git a/tests/letno.ml b/tests/letno.ml index 4b20936..d397b55 100644 --- a/tests/letno.ml +++ b/tests/letno.ml @@ -1,3 +1,14 @@ +open Mocha + let test x = let r = () in r + +;; + +describe "letno.ml" (fun _ -> + it "test" (fun _ -> + assert_unit (test 0); + assert_unit (test 1) + ) +) diff --git a/tests/lettuple.ml b/tests/lettuple.ml index e0d9ee5..192a70a 100644 --- a/tests/lettuple.ml +++ b/tests/lettuple.ml @@ -1,3 +1,5 @@ +open Mocha + let test _ = let (y,z) = (1,2) in y @@ -5,3 +7,34 @@ let test _ = let test2 _ = let _,z = (1,2) in z + +let test3 _ = + let (x,y,z) = (1,2,3) + in (x,y,z) + +(* +let test3a _ = + let (x,x,x) = (1,2,3) +(* ^--- OCaml Syntax Error expected here *) + in x +*) + +let test4 _ = + let (w,x,y,z) = (1,2,3,4) + in (w,x,y,z) +;; + +describe "lettuple.ml" (fun _ -> + it "test" (fun _ -> + assert_int (test ()) 1 "test () === 1" + ); + it "test2" (fun _ -> + assert_int (test2 ()) 2 "test2 () === 2" + ); + it "test3" (fun _ -> + assert_struct_eq (test3 ()) (1,2,3) "test3 () === (1,2,3)" + ); + it "test4" (fun _ -> + assert_struct_eq (test4 ()) (1,2,3,4) "test4 () === (1,2,3,4)" + ) +) diff --git a/tests/lib/mocha.js b/tests/lib/mocha.js new file mode 100644 index 0000000..f4abe6a --- /dev/null +++ b/tests/lib/mocha.js @@ -0,0 +1,23 @@ +/* Mocha-compatible shim for OCaml, JS support implementation, see mocha.mli for documentation */ +var Mocha = {}; +({ ok : Mocha.assert_ok + , fail : Mocha.assert_fail + , equal: Mocha.assert_bool + , equal: Mocha.assert_int + , equal: Mocha.assert_float + , equal: Mocha.assert_char + , equal: Mocha.assert_string + , deepEqual : Mocha.assert_struct_eq + , throws: Mocha.throws +} = require('assert').strict); +var old_it = it; +it = function(string, callback) { + old_it(string, function(done) { + callback(); + done(); + }) +} +Mocha.assert_unit = x => { + Mocha.assert_struct_eq(x, {}, x + " is not unit ({}).") +} +Mocha.assert_failwith = (f, e, m) => Mocha.throws(f, Error(e), m); diff --git a/tests/lib/mocha.ml b/tests/lib/mocha.ml new file mode 100644 index 0000000..480886a --- /dev/null +++ b/tests/lib/mocha.ml @@ -0,0 +1,78 @@ +(** Mocha-compatible shim for OCaml, OCaml implementation, see mocha.mli for documentation *) + +let caller = ref "" +let test_path = ref None +let tests = ref [] +let test_cases = ref [] + +let opt_iter f = function + | None -> () + | Some v -> f v + +let opt_default f def = function + | None -> def + | Some v -> f v + +let end_caller () = + tests := (!caller, List.rev !test_cases) :: !tests; + test_cases := [] + +let update_caller () = + if !test_path = None then + let open Printexc in + let opt_slots = backtrace_slots (get_callstack 3) in + opt_iter (fun slots -> + let opt_loc = Slot.location slots.(2) in + opt_iter (fun loc -> + let new_caller = loc.filename in + if new_caller <> !caller then (end_caller (); caller := new_caller) + ) opt_loc + ) opt_slots + + +let get_test_path path test_name = + opt_default (fun p -> Printf.sprintf "%s:%s" p test_name) test_name path + +let update_test_path app = + let old_path = !test_path in + test_path := Some (get_test_path old_path app); + old_path + + +let describe str f_suite = + update_caller (); + let old_path = update_test_path str in + f_suite (); + test_path := old_path + +let it str f_test = + update_caller (); + let name = get_test_path (!test_path) str in + test_cases := (Alcotest.test_case name `Quick f_test) :: !test_cases + +let exit_hooked = ref false +let () = at_exit (fun () -> + if not !exit_hooked then begin + exit_hooked := true; + end_caller (); + print_string "*** "; + Alcotest.run "OCaml generated tests ***\n" !tests + end +) + +(* Assertions + A compatible subset of node.js' assert library, and Alcotest *) +open Alcotest +let assert_ok value msg = check bool msg value true +let assert_fail = fail + +let assertion typ act exp msg = check typ msg act exp +let assert_bool = assertion bool +let assert_int = assertion int +let assert_float = assertion (float 0.001) +let assert_char = assertion char +let assert_string = assertion string +let assert_unit x = assertion unit x () "is not unit" +let assert_struct_eq a b x = assertion (testable (Fmt.always "") (=)) a b x +let assert_failwith f e m = check_raises m (Failure e) (fun _ -> f (); ()) + diff --git a/tests/lib/mocha.mli b/tests/lib/mocha.mli new file mode 100644 index 0000000..014b17b --- /dev/null +++ b/tests/lib/mocha.mli @@ -0,0 +1,86 @@ +(** Mocha-compatible shim for OCaml and js_of_ocaml_bis + + This shim is designed to provide a similar interface and test runner to the JavaScript mocha library + (https://mochajs.org/) + + A set of test suite modules linked together with this module will run each together in sequence when executed as a + main program. For example: + +[ + describe "test_module_1" (fun _ -> + describe "function_1" (fun _ -> + it "should return 1" (fun _ -> + assert_equal (function_1 ()) 1 + ) + ) + ) +] + + Alcotest uses 3 levels to test hierarchy: + * test_case (string * speed * fun), where fun consists of assertions + * test (string * test_case list) + * test suite (string * test list) + + For this shim, there will be one test suite with a constant name, + each test file this module is compiled with will be a test. + Each mocha test ("it" definitions) will be test_cases, with names + generated from the describe calls. + + To compile with the stock OCaml compiler, link your test case files + against this and the Alcotest library. This library will then discover + and execute your test cases. For example: + ocamlfind ocamlc -package alcotest -linkpkg -g -o tests -I lib lib/mocha.cmo test1.ml test2.ml test3.ml ... + executing "tests" will execute all test cases. + Note that compilation with debug symbols is required to get source file + information for test case failures. + + To compile with our OCaml-JS backend, compile each test case as usual, + link each to the Mocha shim individually, and then execute all using + the mocha command line tool: + ../generator.byte -mode unlog -I lib test1.ml + ../assembly.byte -o test1.unlog.assembly.js lib/mocha.js test1.unlog.js + mocha test1.unlog.assembly.js + + + A full sample test case file: +[ +open Mocha + +let test _ = assert_ok true "pass!" + +let _ = describe "suite 1" (fun _ -> + it "test 1" test; + it "test 2" test; + describe "nest 1" (fun _ -> + it "test3" test; + describe "nest2" (fun _ -> + it "test4" test + ); + describe "nest3" (fun _ -> + it "test5" test + ) + ) +) +] + +*) + + +val describe : string -> (unit -> unit) -> unit +val it : string -> (unit -> unit) -> unit + +val assert_ok : bool -> string -> unit +val assert_fail : string -> unit + +val assert_bool : bool -> bool -> string -> unit +val assert_int : int -> int -> string -> unit +val assert_float : float -> float -> string -> unit +val assert_char : char -> char -> string -> unit +val assert_string : string -> string -> string -> unit + +(** Assert that a value is unit. This doesn't make much sense in ml, but does for the js compile target *) +val assert_unit : unit -> unit +val assert_struct_eq : 'a -> 'a -> string -> unit + +(** [assert_failwith f e m] Assert that [f] raises a Failure with string [e]. The assert is labelled with [m]. *) +val assert_failwith : (unit -> 'a) -> string -> string -> unit diff --git a/tests/mini.ml b/tests/mini.ml index 7492e5c..bd5efaa 100644 --- a/tests/mini.ml +++ b/tests/mini.ml @@ -1,5 +1,15 @@ +open Mocha + type toto = Foo of int [@f foo] let test f = match f with Foo x -> x + +;; + +describe "mini.ml" (fun _ -> + it "test" (fun _ -> + assert_int (test (Foo 5)) 5 "test (Foo 5) === 5" + ) +) diff --git a/tests/mylist.ml b/tests/mylist.ml index 5304e5d..abeaecf 100644 --- a/tests/mylist.ml +++ b/tests/mylist.ml @@ -1,8 +1,10 @@ +open Mocha + let incr i = i + 1 type 'a liste = | Nil - | Cons [@f hd, tl] of 'a * 'a liste + | Cons of 'a * 'a liste [@f hd, tl] let head d l = match l with | Nil -> d @@ -16,11 +18,11 @@ let init l = match l with | Nil -> Nil | Cons (x, xs) -> xs -let rec last l = match l with - | Nil -> Nil +let rec last d l = match l with + | Nil -> d | Cons (x, xs) -> (match xs with | Nil -> x - | _ -> last xs) + | _ -> last d xs) let rec fold_left f acc l = match l with | Nil -> acc @@ -36,28 +38,68 @@ let rev l = fold_left (fun acc x -> Cons(x, acc)) Nil l let length l = fold_left (fun acc x -> incr acc) 0 l -let rec range i j acc = if i <= j then range (incr i) j (Cons (i, acc)) else acc - -(* Test *) - -let list0 = Nil -let list1 = range 0 1 Nil -let list2 = range 1 5 Nil - -let sqr x = x * x - -(* -let print_list l = - let rec aux acc l = match l with - | Nil -> acc - | Cons (x, xs) -> print xs; if xs === Nil then aux (x + acc) xs else aux (x + "," + acc) xs - in "[" + aux "" (rev l) + "]" -;; -let f = 1 in - print (length list0); - print (length list1); - print (length list2); - print (print_list (map (fun x -> x * x) list0)); - print (print_list (map sqr list1)); - print (print_list (map sqr list2)); - *) +let rec range i j acc = if int_le i j then range (incr i) j (Cons (i, acc)) else acc + +;; + +(* Tests *) +describe "mylist.ml" (fun _ -> + let list0 = Nil in + let list1 = range 0 1 Nil in + let list2 = range 1 5 Nil in + + let sub x y = x - y in + let sqr x = x * x in + + it "head" (fun _ -> + assert_int (head 42 list0) 42 "default returned for head Nil"; + assert_int (head 42 list1) 1 "head value returned"; + assert_int (head 42 list2) 5 "head value returned" + ); + it "tail" (fun _ -> + assert_struct_eq (tail list1 list0) list1 "default returned for tail Nil"; + assert_struct_eq (tail list0 list1) (Cons(0,Nil)) "tail list1"; + assert_struct_eq (tail list0 list2) (Cons(4,Cons(3,Cons(2,Cons(1,Nil))))) "tail list2" + ); + it "init" (fun _ -> + assert_struct_eq (init list0) Nil "init list0"; + assert_struct_eq (init list1) (Cons(0,Nil)) "init list1"; + assert_struct_eq (init list2) (Cons(4,Cons(3,Cons(2,Cons(1,Nil))))) "init list2" + ); + it "last" (fun _ -> + assert_int (last 42 list0) 42 "last list0"; + assert_int (last 42 list1) 0 "last list1"; + assert_int (last 42 list2) 1 "last list2"; + ); + it "fold_left" (fun _ -> + assert_int (fold_left sub 0 list0) 0 "fold_left sub 0 list0"; + assert_int (fold_left sub 3 list1) 2 "fold_left sub 0 list1"; + assert_int (fold_left sub 0 list2) (-15) "fold_left sub 0 list2" + ); + it "fold_right" (fun _ -> + assert_int (fold_right sub list0 0) 0 "fold_right sub 0 list0"; + assert_int (fold_right sub list1 3) 2 "fold_right sub 0 list1"; + assert_int (fold_right sub list2 0) (-15) "fold_right sub 0 list2" + (* FIXME: The fold_left and fold_right functions should probably not return the same values... *) + ); + it "rev_map" (fun _ -> + assert_struct_eq (rev_map sqr list0) Nil "rev_map _ Nil === Nil"; + assert_struct_eq (rev_map sqr list1) (Cons(0, Cons(1,Nil))) "rev_map sqr [1,0] === [0,1]"; + assert_struct_eq (rev_map sqr list2) (Cons(1, Cons(4, Cons(9, Cons(16, Cons(25, Nil)))))) "rev_map sqr [1..5] === [1,4,9,16,25]" + ); + it "map" (fun _ -> + assert_struct_eq (map sqr list0) Nil "map _ Nil === Nil"; + assert_struct_eq (map sqr list1) (Cons(1, Cons(0,Nil))) "map sqr [0,1] === [0,1]"; + assert_struct_eq (map sqr list2) (Cons(25, Cons(16, Cons(9, Cons(4, Cons(1, Nil)))))) "map sqr [1..5] === [1,4,9,16,25]" + ); + it "rev" (fun _ -> + assert_struct_eq (rev list0) Nil "rev Nil === Nil"; + assert_struct_eq (rev list1) (Cons(0, Cons(1,Nil))) "rev [0,1] === [1,0]"; + assert_struct_eq (rev list2) (Cons(1, Cons(2, Cons(3, Cons(4, Cons(5, Nil)))))) "rev [1..5] === [5..1]" + ); + it "length" (fun _ -> + assert_int (length list0) 0 "length [] === 0"; + assert_int (length list1) 2 "length [0..1] === 1"; + assert_int (length list2) 5 "length [1..5] === 5" + ); +) diff --git a/tests/records.ml b/tests/records.ml index 45badc7..00b2526 100644 --- a/tests/records.ml +++ b/tests/records.ml @@ -1,3 +1,5 @@ +open Mocha + type pers = { name : string ; status : string @@ -12,13 +14,38 @@ let boss = let ab = boss.age -let newboss = { boss with name = "john" } +let newboss1 = { boss with name = "john" } -let newboss = { boss with name = "john"; status = "newboss" } +let newboss2 = { boss with name = "john"; status = "newboss" } (* Field punning *) -let newboss = +let newboss3 = let name = "pun" in let status = "awful" in let age = 0 in { name; status; age } + +;; + +describe "records.ml" (fun _ -> + it "boss" (fun _ -> + assert_string boss.name "smith" "boss name correct"; + assert_string boss.status "boss" "boss status correct"; + assert_int boss.age 48 "boss age correct" + ); + it "newboss1" (fun _ -> + assert_string newboss1.name "john" "newboss1 name correct"; + assert_string newboss1.status "boss" "newboss1 status correct"; + assert_int newboss1.age 48 "newboss1 age correct" + ); + it "newboss2" (fun _ -> + assert_string newboss2.name "john" "newboss2 name correct"; + assert_string newboss2.status "newboss" "newboss2 status correct"; + assert_int newboss2.age 48 "newboss2 age correct" + ); + it "newboss3" (fun _ -> + assert_string newboss3.name "pun" "newboss3 name correct"; + assert_string newboss3.status "awful" "newboss3 status correct"; + assert_int newboss3.age 0 "newboss3 age correct" + ) +) diff --git a/tests/shadow.ml b/tests/shadow.ml index fb735ea..2a1c1f0 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -1,47 +1,46 @@ -(* `make shadow.unlog.js` and test resulting function in node - add a print_int to the shadower line and `ocamlc shadow.ml` to validate ml *) - -(** Inner-most scope should not hide outermost, incorrect JS behaviour would be to execute undefined + 1 **) -let shadower n = - let f _ = - let (n, z) = n+1, () in - n+1 in - f () ;; - -shadower 1;; (* Expected return value: 3 *) - - -(** As previous, but using a pattern binder instead of let **) +open Mocha type shadow = | Shadow of int [@f num] -let shadower2 n = - let f _ = - match n with - | Shadow n -> n+1 - in - f () -;; - -shadower2 (Shadow 1) (* Expected return value: 2 *) ;; -let f _ = - let x = 1 in - let y n = - let x = x + n in - x in - y (y x) -;; - -f () (* Expected return value: 3 *) -;; - -(** Things we want to be able to do, for example: **) -let x = 10 in -let x = x + x in -let x = x + x + x in -x - -;; +describe "shadow.ml" (fun _ -> + it "shadower" (fun _ -> + let shadower n = + let f _ = + let (n, z) = n+1, () in + n+1 in + f () in + assert_int (shadower 1) 3 "Inner-most scope should not hide outermost, incorrect JS behaviour would be to execute undefined + 1" + ); + + it "shadower2" (fun _ -> + + let shadower2 n = + let f _ = + match n with + | Shadow n -> n+1 + in + f () in + assert_int (shadower2 (Shadow 1)) 2 "Inner-most scope should not hide outermost, incorrect JS behaviour would be to execute undefined + 1" + ); + + it "shadower3" (fun _ -> + let shadower3 _ = + let x = 1 in + let y n = + let x = x + n in + x in + y (y x) + in + assert_int (shadower3 ()) 3 "shadower3 failed?" + ); + + it "variable rebinding" (fun _ -> + let x = 10 in + let x = x + x in + let x = x + x + x in + assert_int x 60 "x should be able to be redeclared based upon the previous value of x" + ) +) diff --git a/tests/stack.ml b/tests/stack.ml deleted file mode 100644 index c35297f..0000000 --- a/tests/stack.ml +++ /dev/null @@ -1,12 +0,0 @@ -type stack = - | C [@f value, stack] of int * stack - | N [@f] - -let is_empty s = s === N - -let push x stack = C(x, stack) - -let pop stack = - match stack with - | C (x, xs) -> x - | N -> stuck "Empty list" diff --git a/tests/testctx.ml b/tests/testctx.ml index 9effd6c..ef58daa 100644 --- a/tests/testctx.ml +++ b/tests/testctx.ml @@ -1,3 +1,4 @@ +open Mocha let testp1 x = let (a,b,c) = x in @@ -105,4 +106,54 @@ let test6 (x,y) = x *) - \ No newline at end of file +;; + +describe "testctx.ml" (fun _ -> + it "testp1" (fun _ -> + assert_int (testp1 (40,2,10)) 42 "testp1 (40,2,10) == 42" + ); + it "testa" (fun _ -> + assert_int (testa 42) 42 "testa 42 == 42" + ); + it "testb" (fun _ -> + assert_int (testb 42) 42 "testb 42 == 42" + ); + it "testc" (fun _ -> + assert_int (testc 42) 85 "testc 42 == 85" + ); + it "testd" (fun _ -> + assert_int (testd 42) 42 "testd 42 == 42" + ); + it "teste" (fun _ -> + assert_int (teste 42) 42 "teste 42 == 42" + ); + it "testf" (fun _ -> + assert_int (testf 42) 84 "testf 42 == 84" + ); + it "testg" (fun _ -> + assert_int (testg true) 1 "testg true == 1"; + assert_int (testg false) 0 "testg false == 0" + ); + it "test00" (fun _ -> + assert_int (test00 None) 2 "test00 None == 2"; + assert_int (test00 (Some 3)) 3 "test00 (Some 3) == 3" + ); + it "test1" (fun _ -> + assert_int (test1 None) 0 "test1 None == 0"; + assert_int (test1 (Some 42)) 84 "test1 (Some 42) == 84" + ); + it "test2" (fun _ -> + assert_int (test2 42) 4 "test2 _ == 4"; + assert_int (test2 ()) 4 "test2 _ == 4"; + assert_int (test2 "test") 4 "test2 _ == 4" + ); + it "test3" (fun _ -> + assert_int (test3 None) 1 "test3 None == 1"; + assert_int (test3 (Some 42)) 44 "test3 (Some 42) == 44" + ); + it "test4" (fun _ -> + assert_int (test4 None) 1 "test4 None == 1"; + assert_int (test4 (Some None)) 2 "test4 Some None == 2"; + assert_int (test4 (Some (Some 42))) 42 "test4 (Some (Some 42)) == 42" + ) +) diff --git a/tests/types.ml b/tests/types.ml deleted file mode 100644 index fa24fe8..0000000 --- a/tests/types.ml +++ /dev/null @@ -1,8 +0,0 @@ -open Stack -open Calc - -type exprone = - | Alpha [@f] - | Gamma [@f] -and exprtwo = - | Beta [@f] From 3ab014eca659bcf782bf1e9433ebc7a7662ad641 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 7 Jun 2018 13:15:08 +0100 Subject: [PATCH 34/46] generator: top level identifiers require name munging --- js_of_ast.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index eb7b358..3757816 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -368,6 +368,8 @@ let ppf_pat_array id_list array_expr = let ppf_field_access expr field = Printf.sprintf "%s.%s" expr field +(****************************************************) +(* Identifier Rewriting *) (* List of JavaScript keywords that cannot be used as identifiers *) let js_keywords = ["await"; "break"; "case"; "catch"; "class"; "const"; "continue"; "debugger"; "default"; "delete"; "do"; "else"; @@ -733,11 +735,6 @@ let is_triple_equal_comparison e sm = (* TODO: this text could be optimized *) | _ -> false -let str_ident_of_pat sm pat = match pat.pat_desc with - | Tpat_var (id, _) -> Ident.name id - | Tpat_any -> id_fresh "_pat_any_" - | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values" - let ppf_ident_of_pat sm pat = match pat.pat_desc with | Tpat_var (id, _) -> ppf_ident id sm | Tpat_any -> id_fresh "_pat_any_" @@ -795,7 +792,7 @@ and js_of_structure_item s = (str, []) | Tstr_value (_, vb_l) -> combine_list_output (~~ List.map vb_l (fun vb -> - let id = str_ident_of_pat ShadowMapM.empty vb.vb_pat in + let id = ppf_ident_of_pat ShadowMapM.empty vb.vb_pat in if ident_is_shadowing s.str_env id then error ~loc "Variable shadowing not permitted at toplevel" else let sbody = js_of_expression_inline_or_wrap ShadowMapM.empty ctx_initial vb.vb_expr in From ef7674276d1ac1984a8bc12fa18181690529a478 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 8 Jun 2018 19:23:33 +0100 Subject: [PATCH 35/46] Makefile test target fixes --- tests/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Makefile b/tests/Makefile index f83bb7e..461e177 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -19,7 +19,7 @@ test_ml: $(LINK_LIBS) $(patsubst %.ml,%.cmo,$(TESTS)) | lib/mocha.cmi run_test_js: $(TESTS_JS) @echo -e "\n*** Testing JS-generated tests ***\n" - @mocha -R list $^ + @../../node_modules/mocha/bin/mocha -R list $^ test_js: $(TESTS_JS) From 5f46223c5505fa59d58de1e2858729f95fecd188 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 15 Jun 2018 13:31:47 +0100 Subject: [PATCH 36/46] Fixing variable renaming for continuation bodies. Function code generation is handled in two places, we'd previously missed the special-cased monadic codepath when implementing shadowed variable rewriting. Fixes #15 (hopefully!) --- js_of_ast.ml | 66 ++++++++++++++++-------------------------- monad_ppx.ml | 12 ++++---- monadic_binder_list.ml | 12 ++++++++ mytools.ml | 12 ++++---- tests/Makefile | 20 +++++++++---- tests/shadow.ml | 19 +++++++++++- 6 files changed, 82 insertions(+), 59 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 3757816..16d77e7 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -22,11 +22,10 @@ open Misc open Mytools open Types open Typedtree +open Monadic_binder_list module L = Logged (Token_generator) (struct let size = 256 end) -(* TODO: Field annotations for builtin type constructors *) - let string_of_longident i = String.concat "." @@ Longident.flatten @@ i @@ -245,18 +244,6 @@ let is_coercion_constructor lident = (* if (is_mode_pseudo()) then Printf.printf "%s %s\n" x (if b then " [yes]" else ""); *) b - -(* Do not generate events for particular functions *) - -let is_monadic_function f = - match f.exp_desc with - | Texp_ident (path, ident, _) -> - let x = Path.name path in - List.mem x Monadic_binder_list.monad_identifiers - | _ -> false - - - (****************************************************************) (* PPF HELPERS *) @@ -932,10 +919,9 @@ and js_of_expression (sm : shadow_map) ctx dest e = sexp | Texp_function (_, c :: [], Total) -> - let pats, body = function_get_args_and_body e - (* DEPRECATED: function_get_args_and_body e [c.c_lhs] c.c_rhs *) in + let pats, body = function_get_args_and_body e in let pats_clean = List.filter (fun pat -> is_mode_not_pseudo() || not (is_hidden_type pat.pat_type)) pats in - let arg_ids = List.map (ppf_ident_of_pat sm) pats_clean in + let arg_ids = List.map (ppf_ident_of_pat sm) pats_clean in (******* HERE *******) (* FUTURE USE: (for function taking tuples as args) let arg_idss, tuplebindingss = List.split (List.map (fun pat -> match pat.pat_desc with @@ -973,7 +959,7 @@ and js_of_expression (sm : shadow_map) ctx dest e = let sexp = generate_logged_enter body.exp_loc arg_ids ctx newctx sbody in apply_dest' ctx dest (stuplebindings ^ sexp) - | Texp_apply (f, exp_l) when is_monadic_function f -> + | Texp_apply (f, exp_l) when is_monadic_texpr e -> let sl_clean = exp_l |> List.map (fun (_, eo) -> match eo with | None -> out_of_scope loc "optional apply arguments" @@ -995,28 +981,24 @@ and js_of_expression (sm : shadow_map) ctx dest e = in let sexp1 = inline_of_wrap e1 in let pats,body = function_get_args_and_body e2 in - let newctx = ctx_fresh() in - let sbody = js_of_expression sm newctx Dest_return body in let pats_clean = List.filter (fun pat -> is_mode_not_pseudo() || not (is_hidden_type pat.pat_type)) pats in - (* OLD let arg_ids = List.map ident_of_pat pats_clean in*) - let arg_idss, bound_idss, tuplebindingss = list_split3 (List.map (fun pat -> - (* FIXME: todo later *) - match pat.pat_desc with - | Tpat_var (id, _) -> let x = ppf_ident id sm in [x], [x], [] - | Tpat_any -> let x = id_fresh "_pat_any_" in [x], [], [] - | Tpat_tuple pl -> - let a = id_fresh "_tuple_arg_" in - let binders, sm = tuple_binders a sm pl in - let xs = List.map fst binders in - if is_mode_pseudo() then begin - (* the name [a] is ignored in this case *) - let arg = Printf.sprintf "(%s)" (show_list ",@ " xs) in - [arg], xs, [] - end else begin - [a], xs, binders - end - | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values unless tuple" - ) pats_clean) in + let sm, bindings = map_state (fun sm pat -> + match pat.pat_desc with + | Tpat_var (id, _) -> let x = ppf_ident id sm in sm, ([x], [x], []) + | Tpat_any -> let x = id_fresh "_pat_any_" in sm, ([x], [], []) + | Tpat_tuple pl -> + let a = id_fresh "_tuple_arg_" in + let binders, sm = tuple_binders a sm pl in + let xs = List.map fst binders in + if is_mode_pseudo() then + (* the name [a] is ignored in this case *) + let arg = Printf.sprintf "(%s)" (show_list ",@ " xs) in + sm, ([arg], xs, []) + else + sm, ([a], xs, binders) + | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values unless tuple" + ) sm pats_clean in + let arg_idss, bound_idss, tuplebindingss = list_split3 bindings in let arg_ids = List.concat arg_idss in let bound_ids = List.concat bound_idss in let tuple_bindings = List.concat tuplebindingss in @@ -1032,6 +1014,9 @@ and js_of_expression (sm : shadow_map) ctx dest e = as before, and [tuplebindings] are empty. *) let stuplebindings = ppf_match_binders tuple_bindings in + let newctx = ctx_fresh() in + let sbody = js_of_expression sm newctx Dest_return body in + let (token_start1, token_stop1, _token_loc) = token_fresh !current_mode loc in let (token_start2, token_stop2, _token_loc) = token_fresh !current_mode loc in (* token1 placed on sexp1 @@ -1258,8 +1243,7 @@ and js_of_expression (sm : shadow_map) ctx dest e = | Texp_match (_,_,_, Partial) -> out_of_scope loc "partial matching" | Texp_match (_,_,_,_) -> out_of_scope loc "matching with exception branches" | Texp_try (_,_) -> out_of_scope loc "exceptions" - | Texp_function (_, _, _) -> out_of_scope loc "use of labels" - + | Texp_function (_, _, _) -> out_of_scope loc "use of labels" | Texp_variant (_,_) -> out_of_scope loc "polymorphic variant" | Texp_setfield (_,_,_,_) -> out_of_scope loc "setting field" | Texp_send (_,_,_) -> out_of_scope loc "objects" diff --git a/monad_ppx.ml b/monad_ppx.ml index 46d405b..db0837b 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -3,8 +3,7 @@ open Ast_helper open Asttypes open Parsetree open Longident - -let monad_mapping = Monadic_binder_list.monad_mapping +open Monadic_binder_list (* e.g. @@ -31,7 +30,7 @@ let generate_mapper namesid = function argv -> let aux e = mapper.expr mapper e in match expr with (* Is this an extension node? *) - | { pexp_desc = Pexp_extension ({txt = name; loc}, pstr)} -> + | { pexp_desc = Pexp_extension ({txt = name; loc }, pstr)} -> begin try match pstr with | PStr [{ pstr_desc = Pstr_eval ({pexp_loc = loc; pexp_desc = extended_expression}, _)}] -> @@ -52,15 +51,16 @@ let generate_mapper namesid = function argv -> | [p1;p2] -> (p1, (Exp.fun_ ~loc Nolabel None p2 (aux cont))) | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("let%"^name^" expects exactly 2 variables to bind")))) | _ -> raise (Location.Error (Location.error ~loc:pat.ppat_loc ("unknown pattern type with let%"^name))) - in - Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ ~loc Nolabel None param body)] + in monadic_expr (Exp.apply ~loc (mk_ident ident) [(Nolabel, aux e); (Nolabel, Exp.fun_ ~loc Nolabel None param body)]) + with | Not_found -> raise (Location.Error (Location.error ~loc ("no let%"^name))) end | _ -> raise (Location.Error (Location.error ~loc "unable to extend this sort of expression")) end - | _ -> raise (Location.Error ( Location.error ~loc "Expression extension node containing non-expression")) + | _ -> raise (Location.Error (Location.error ~loc "Expression extension node containing non-expression")) + with Location.Error error -> {expr with pexp_desc = Pexp_extension (extension_of_error error)} end (* Delegate to the default mapper. *) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index 974c3ab..6914cf1 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -36,3 +36,15 @@ let monad_mapping = [ ] let monad_identifiers = List.map (fun (_, f) -> "JsInterpreterMonads." ^ f) monad_mapping + +open Ast_helper +open Asttypes +open Parsetree +open Typedtree + +let attr_tag = "jsexplain.monad" + +let monadic_expr e = Exp.attr e ({ txt = attr_tag; loc = e.pexp_loc }, PStr []) +let is_monadic_attr ({ txt = a; _ }, _) = a = attr_tag +let is_monadic_expr e = List.exists is_monadic_attr e.pexp_attributes +let is_monadic_texpr e = List.exists is_monadic_attr e.exp_attributes diff --git a/mytools.ml b/mytools.ml index 3f0b857..46165a0 100644 --- a/mytools.ml +++ b/mytools.ml @@ -49,6 +49,12 @@ let range i j = let list_nat n = (* for n >= 0 *) range 0 n + +let rec list_split3 = function + | [] -> [], [], [] + | (x, y, z)::ls -> + let xs, ys, zs = list_split3 ls in + x::xs, y::ys, z::zs let rec list_separ sep = function | [] -> [] @@ -142,12 +148,6 @@ let list_index k l = in aux 0 l -let list_split3 l = - let l1 = List.map (fun (x,_,_) -> x) l in - let l2 = List.map (fun (_,x,_) -> x) l in - let l3 = List.map (fun (_,_,x) -> x) l in - (l1,l2,l3) - let add_to_list li s = li := s :: !li diff --git a/tests/Makefile b/tests/Makefile index 461e177..1720480 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,7 @@ STDLIB_DIR := ../stdlib_ml -LIBS := -I lib -I $(STDLIB_DIR) +PPX := -ppx ../monad_ppx.byte +LIBDIRS := lib $(STDLIB_DIR) +LIBS := $(PPX) $(foreach lib,$(LIBDIRS),-I $(lib)) REPLACE_STDLIB := -nopervasives -nostdlib -open Stdlib LINK_LIBS := $(STDLIB_DIR)/stdlib.cmo lib/mocha.cmo @@ -9,6 +11,14 @@ TESTS_JS := $(patsubst %.ml,%.unlog.as.js,$(TESTS)) test: test_ml test_js $(MAKE) -k _run_test +init: .merlin + +.merlin: + echo "B ." > .merlin + echo -n "FLG $(PPX)" >> .merlin + echo -en "$(foreach lib,$(LIBDIRS),\nS $(lib))" >> .merlin + echo -en "$(foreach lib,$(LIBDIRS),\nB $(lib))" >> .merlin + _run_test: run_test_ml run_test_js run_test_ml: @@ -24,13 +34,13 @@ run_test_js: $(TESTS_JS) test_js: $(TESTS_JS) %.unlog.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode unlog -ppx ../monad_ppx.byte $(LIBS) $< + ../main.byte -mode unlog $(LIBS) $< %.log.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode log -ppx ../monad_ppx.byte $(LIBS) $< + ../main.byte -mode log $(LIBS) $< %.token.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode token -ppx ../monad_ppx.byte $(LIBS) $< + ../main.byte -mode token $(LIBS) $< %.as.js: $(patsubst %.cmo,%.js,$(LINK_LIBS)) Compare.js %.js ../assembly.byte -o $@ $^ @@ -45,7 +55,7 @@ lib/%.cmo: lib/%.ml lib/%.cmi ocamlc -c -g $(REPLACE_STDLIB) $(LIBS) $< -o $@ clean: - rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} + rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} .merlin .PRECIOUS: %.js %.unlog.js .NOTPARALLEL: diff --git a/tests/shadow.ml b/tests/shadow.ml index 2a1c1f0..e012a42 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -3,6 +3,15 @@ open Mocha type shadow = | Shadow of int [@f num] +type ('t, 'a) if_ret_type = +| Return of 't [@f result] +| Continue of 'a [@f cont] + +let let_ret w k = + match w with + | Continue s -> k s + | Return r -> r + ;; describe "shadow.ml" (fun _ -> @@ -34,7 +43,15 @@ describe "shadow.ml" (fun _ -> x in y (y x) in - assert_int (shadower3 ()) 3 "shadower3 failed?" + assert_int (shadower3 ()) 3 "shadower3 failed?" + ); + + it "monadic_tuple_shadow" (fun _ -> + let monadic_tuple_shadow x s base = + let%ret (s, base) = Continue x + in (s, base) + in + assert_struct_eq (monadic_tuple_shadow (1, 2) 0 0) (1, 2) "Tuple rebinding not working." ); it "variable rebinding" (fun _ -> From eac1e0ff65c4bbf9a76851f9162d3e890ed9d489 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 22 Jun 2018 21:13:18 +0100 Subject: [PATCH 37/46] Merlin configuration. Sigh ppx paths are annoying as ocaml/merlin#571 hasn't been fixed. --- .merlin | 1 + tests/.merlin | 7 +++++++ tests/Makefile | 10 +--------- 3 files changed, 9 insertions(+), 9 deletions(-) create mode 100644 tests/.merlin diff --git a/.merlin b/.merlin index 47d9f3f..1567446 100644 --- a/.merlin +++ b/.merlin @@ -1,3 +1,4 @@ +REC B _build PKG str PKG compiler-libs.common diff --git a/tests/.merlin b/tests/.merlin new file mode 100644 index 0000000..e30c059 --- /dev/null +++ b/tests/.merlin @@ -0,0 +1,7 @@ +REC +B . +S lib +B lib +S ../stdlib_ml +B ../stdlib_ml +FLG -nopervasives -nostdlib -open Stdlib diff --git a/tests/Makefile b/tests/Makefile index 1720480..a2be4a2 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -11,14 +11,6 @@ TESTS_JS := $(patsubst %.ml,%.unlog.as.js,$(TESTS)) test: test_ml test_js $(MAKE) -k _run_test -init: .merlin - -.merlin: - echo "B ." > .merlin - echo -n "FLG $(PPX)" >> .merlin - echo -en "$(foreach lib,$(LIBDIRS),\nS $(lib))" >> .merlin - echo -en "$(foreach lib,$(LIBDIRS),\nB $(lib))" >> .merlin - _run_test: run_test_ml run_test_js run_test_ml: @@ -55,7 +47,7 @@ lib/%.cmo: lib/%.ml lib/%.cmi ocamlc -c -g $(REPLACE_STDLIB) $(LIBS) $< -o $@ clean: - rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} .merlin + rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} .PRECIOUS: %.js %.unlog.js .NOTPARALLEL: From 260525a7d2daa0d0d63f54d5c43361229e4fb847 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 10 Jul 2018 14:41:25 +0100 Subject: [PATCH 38/46] Remove instances of Not_found from jsref -- not declared in stdlib --- stdlib_ml/stdlib.js | 2 +- stdlib_ml/stdlib.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stdlib_ml/stdlib.js b/stdlib_ml/stdlib.js index 59e2c7b..b1a0306 100644 --- a/stdlib_ml/stdlib.js +++ b/stdlib_ml/stdlib.js @@ -29,7 +29,7 @@ var mk_cons = function(head, tail) { // Exceptions // val raise : exn -> 'a -var raise = function(x) { throw "Not_found"; }; +var raise = function(x) { throw x; }; var failwith = function(str) { throw Error(str); }; //---------------------------------------------------------------------------- diff --git a/stdlib_ml/stdlib.mli b/stdlib_ml/stdlib.mli index 7fc4c62..bf6d64e 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -28,7 +28,7 @@ implementation of this library as the functions None, Some, mk_nil, mk_cons. *) (**{6 Exceptions }*) -(** Behaves as [throw "Not_found"] in JS. *) +(** Behaves as [throw x] in JS. *) val raise : exn -> 'a val failwith : string -> 'a From cc847d911e09a2909b2e937491ff64e43c5cf427 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Sun, 15 Jul 2018 00:59:09 +0100 Subject: [PATCH 39/46] Attempt to make generator tests work on Travis Travis only has make 3.81, which has considerably different semantics from make 3.82... --- tests/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/Makefile b/tests/Makefile index a2be4a2..d6f320a 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -37,10 +37,10 @@ test_js: $(TESTS_JS) %.as.js: $(patsubst %.cmo,%.js,$(LINK_LIBS)) Compare.js %.js ../assembly.byte -o $@ $^ -lib/%.cmi: lib/%.mli +lib/mocha.cmi: lib/mocha.mli ocamlfind ocamlc -package alcotest -c $< -o $@ -lib/%.cmo: lib/%.ml lib/%.cmi +lib/mocha.cmo: lib/mocha.ml lib/mocha.cmi ocamlfind ocamlc -package alcotest -c -I lib $< -o $@ %.cmo: %.ml From 31766af9a628b45db322ea9edafbd3fde8b1f689 Mon Sep 17 00:00:00 2001 From: Alan Schmitt Date: Thu, 19 Jul 2018 14:54:11 +0200 Subject: [PATCH 40/46] Reverse again iteration order for `tuple-binders` The previous fix was correct but would leave the list of binders in reverse order (but with correctly assigned index). This broke pseudo generation that only looks at the binders and not the assigned index. This generates a list in the same order than the initial list, but the the correct indices. Fixes #24 --- js_of_ast.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index 16d77e7..9c73ecb 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -738,21 +738,22 @@ let combine_list_output args = (* returns a pair (x,e), where [x] in the name in [pat] and where [e] is the access to "stupleobj[index]" *) -let tuple_component_bind stupleobj (result, index, sm) pat = +let tuple_component_bind stupleobj pat (result, index, sm) = let loc = pat.pat_loc in match pat.pat_desc with | Tpat_var (id, _) -> let sm = update_shadow_map sm pat.pat_env id in let sid = ppf_ident id sm in - ((sid, Printf.sprintf "%s[%d]" stupleobj index)::result, index+1, sm) - | Tpat_any -> (result, index+1, sm) + ((sid, Printf.sprintf "%s[%d]" stupleobj index)::result, index-1, sm) + | Tpat_any -> (result, index-1, sm) | _ -> out_of_scope loc "Nested pattern matching" (* returns a list of pairs of the form (x,e), corresponding to the bindings to be performed for decomposing [stupleobj] as the tuple of patterns [pl]. *) let tuple_binders stupleobj sm pl = - let (result, _, sm) = List.fold_left (tuple_component_bind stupleobj) ([], 0, sm) pl in + let nb_args = List.length pl in + let (result, _, sm) = List.fold_right (tuple_component_bind stupleobj) pl ([], nb_args - 1, sm) in (result, sm) (****************************************************************) From 41aaf19c17b4c3a69a448bd268f96508e65dff98 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 19 Jul 2018 19:14:10 +0100 Subject: [PATCH 41/46] generator: recursive function bindings should be shadow mapped in bodies Also additional test for cross-module shadowing (which wasn't a bug) --- js_of_ast.ml | 7 ++++--- tests/Makefile | 12 ++++++++++-- tests/shadow.ml | 12 ++++++++++++ tests/shadow_include.ml | 5 +++++ 4 files changed, 31 insertions(+), 5 deletions(-) create mode 100644 tests/shadow_include.ml diff --git a/js_of_ast.ml b/js_of_ast.ml index 9c73ecb..dfe5cd6 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -864,7 +864,7 @@ and js_of_expression (sm : shadow_map) ctx dest e = let sexp = js_of_constant c in apply_dest' ctx dest sexp - | Texp_let (_, vb_l, e) -> + | Texp_let (recur, vb_l, e) -> (* [vb_l] is a list of value bindings, corresponding to each term of a [let vb_0 and vb_1 and vb_2] *) (* TODO: Handle mixed tuple/record/standard vbs let expressions *) reject_inline dest; @@ -907,7 +907,7 @@ and js_of_expression (sm : shadow_map) ctx dest e = (* vb subexpressions are in the context of overall expression: use constant sm for this, but fold over a changing new_sm for the created bindings *) let folder vb (sids, jsexprs, new_sm) = - let (sid, jsexpr, new_sm) = js_of_let_pattern sm new_sm ctx vb in + let (sid, jsexpr, new_sm) = js_of_let_pattern sm new_sm ctx vb recur in (sid::sids, jsexpr::jsexprs, new_sm) in let (ids, sdecls, new_sm) = List.fold_right folder vb_l ([], [], sm) in @@ -1259,7 +1259,7 @@ and js_of_expression (sm : shadow_map) ctx dest e = | _ -> out_of_scope loc "Unknown js_of_expression Texp value" (* returns the name bound and the code that assigns a value to this name *) -and js_of_let_pattern sm new_sm ctx vb = +and js_of_let_pattern sm new_sm ctx vb recur = let { vb_pat = pat; vb_expr = expr } = vb in let id = match pat.pat_desc with @@ -1278,6 +1278,7 @@ and js_of_let_pattern sm new_sm ctx vb = in let new_sm = update_shadow_map new_sm pat.pat_env id in let sid = ppf_ident id new_sm in + let sm = if recur = Recursive then update_shadow_map sm pat.pat_env id else sm in let js_expr = js_of_expression sm ctx (Dest_assign (sid, false (*FIXME*))) expr in (sid, js_expr, new_sm) diff --git a/tests/Makefile b/tests/Makefile index d6f320a..18901ac 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -25,6 +25,13 @@ run_test_js: $(TESTS_JS) test_js: $(TESTS_JS) +.SECONDEXPANSION: # Start seconday expansion from here. Cannot be moved after any $$ variables. + +# Explicit dependencies (must go before rules to build these targets) +shadow.cmo: shadow_include.cmo +shadow.unlog.as.js: shadow_include.unlog.js + +# Pattern rules %.unlog.js: %.ml ../main.byte ../monad_ppx.byte ../main.byte -mode unlog $(LIBS) $< @@ -34,7 +41,8 @@ test_js: $(TESTS_JS) %.token.js: %.ml ../main.byte ../monad_ppx.byte ../main.byte -mode token $(LIBS) $< -%.as.js: $(patsubst %.cmo,%.js,$(LINK_LIBS)) Compare.js %.js +# $$^ expands to all previously defined dependencies for the given file +%.as.js: $(patsubst %.cmo,%.js,$(LINK_LIBS)) Compare.js $$^ %.js ../assembly.byte -o $@ $^ lib/mocha.cmi: lib/mocha.mli @@ -47,7 +55,7 @@ lib/mocha.cmo: lib/mocha.ml lib/mocha.cmi ocamlc -c -g $(REPLACE_STDLIB) $(LIBS) $< -o $@ clean: - rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} + rm -rf *.{cmi,cmo} test_ml _build lib/*.{cmi,cmo} *.{unlog,log,token,as}.js .PRECIOUS: %.js %.unlog.js .NOTPARALLEL: diff --git a/tests/shadow.ml b/tests/shadow.ml index e012a42..c0d2b5a 100644 --- a/tests/shadow.ml +++ b/tests/shadow.ml @@ -1,4 +1,5 @@ open Mocha +open Shadow_include type shadow = | Shadow of int [@f num] @@ -59,5 +60,16 @@ describe "shadow.ml" (fun _ -> let x = x + x in let x = x + x + x in assert_int x 60 "x should be able to be redeclared based upon the previous value of x" + ); + + it "recursively shadows" (fun _ -> + let myrec x = 0 in + let rec myrec y = if y then 1 else myrec true in + assert_int (myrec false) 1 "recursive function should shadow" + )[@ocaml.warning "-26"]; + + it "shadows across modules" (fun _ -> + let external_def c = 0 in + assert_int (external_def ()) 0 "external_def should have been shadowed" ) ) diff --git a/tests/shadow_include.ml b/tests/shadow_include.ml new file mode 100644 index 0000000..2f0a507 --- /dev/null +++ b/tests/shadow_include.ml @@ -0,0 +1,5 @@ +let external_def a b = + 42 + +let rec external_rec_def a b = + 43 From 9414e98d141bf4a913111f752d8c3ab38a5357c6 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 20 Jul 2018 23:08:17 +0100 Subject: [PATCH 42/46] generator/jsref: Rework spec assertions. Spec assertions now return Coq_result_impossible. Pure spec assertions now failwith, causing a native throw. This should probably be reworked in the future, possibly back to the monadic style. Associated generator change to allow `let _ = assert_spec ... in` syntax. --- js_of_ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/js_of_ast.ml b/js_of_ast.ml index dfe5cd6..2551395 100644 --- a/js_of_ast.ml +++ b/js_of_ast.ml @@ -1264,7 +1264,7 @@ and js_of_let_pattern sm new_sm ctx vb recur = let id = match pat.pat_desc with | Tpat_var (id, _) -> id - | Tpat_any -> out_of_scope pat.pat_loc "_ in let" + | Tpat_any -> Ident.create (id_fresh "_pat_any_") | Tpat_alias _ -> out_of_scope pat.pat_loc "alias in let" | Tpat_constant _ -> out_of_scope pat.pat_loc "constant in let" | Tpat_tuple _ -> out_of_scope pat.pat_loc "tuple in let" From 280b5b6b6b99760d6a56deedbd46432911f4de99 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Fri, 20 Jul 2018 23:10:47 +0100 Subject: [PATCH 43/46] jsref: Implement the Reflect standard library. Not all tests pass yet, one test fails due to ordering of ownKeys, three other failures are undiagnosed. --- monadic_binder_list.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/monadic_binder_list.ml b/monadic_binder_list.ml index 6914cf1..bda44aa 100644 --- a/monadic_binder_list.ml +++ b/monadic_binder_list.ml @@ -4,6 +4,7 @@ let monad_mapping = [ ("object", "if_object"); ("OBJECT", "assert_object"); ("value", "if_value"); + ("VALUE", "assert_value"); ("prim", "if_prim"); ("number", "if_number"); ("some", "if_some"); From fa3b8f472c873453ed0400f6cecd50859aa5a872 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 24 Jul 2018 19:24:30 +0100 Subject: [PATCH 44/46] Hopefully make compatible with nodejs 8.11 (LTS) --- tests/lib/mocha.js | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/lib/mocha.js b/tests/lib/mocha.js index f4abe6a..d1a8d20 100644 --- a/tests/lib/mocha.js +++ b/tests/lib/mocha.js @@ -2,14 +2,14 @@ var Mocha = {}; ({ ok : Mocha.assert_ok , fail : Mocha.assert_fail - , equal: Mocha.assert_bool - , equal: Mocha.assert_int - , equal: Mocha.assert_float - , equal: Mocha.assert_char - , equal: Mocha.assert_string - , deepEqual : Mocha.assert_struct_eq + , strictEqual: Mocha.assert_bool + , strictEqual: Mocha.assert_int + , strictEqual: Mocha.assert_float + , strictEqual: Mocha.assert_char + , strictEqual: Mocha.assert_string + , deepStrictEqual : Mocha.assert_struct_eq , throws: Mocha.throws -} = require('assert').strict); +} = require('assert')); var old_it = it; it = function(string, callback) { old_it(string, function(done) { From ac1d6926590d46b1d5f72133cf46bee733dce309 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Tue, 14 Aug 2018 16:29:46 +0100 Subject: [PATCH 45/46] Remove more unused files. --- run.debug.sh | 8 -------- run.sh | 8 -------- 2 files changed, 16 deletions(-) delete mode 100755 run.debug.sh delete mode 100755 run.sh diff --git a/run.debug.sh b/run.debug.sh deleted file mode 100755 index 51dec5d..0000000 --- a/run.debug.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -cat stdlib_js/stdlib.debug.js >> _____tmp.js -cat $1 >> _____tmp.js - -node _____tmp.js - -rm _____tmp.js diff --git a/run.sh b/run.sh deleted file mode 100755 index 620e6fd..0000000 --- a/run.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -cat stdlib_js/stdlib.js >> _____tmp.js -cat $1 >> _____tmp.js - -node _____tmp.js - -rm _____tmp.js From 5b8b3a5506b60fee30cb593554685542f69815a4 Mon Sep 17 00:00:00 2001 From: Thomas Wood Date: Thu, 6 Sep 2018 12:57:19 +0100 Subject: [PATCH 46/46] Some documentation updates. --- README.md | 123 +++++++++++++++++++++++++++++++++++++++++++++++++++++ README.org | 118 -------------------------------------------------- 2 files changed, 123 insertions(+), 118 deletions(-) create mode 100644 README.md delete mode 100644 README.org diff --git a/README.md b/README.md new file mode 100644 index 0000000..f93bd7f --- /dev/null +++ b/README.md @@ -0,0 +1,123 @@ +# Js\_of\_ocaml bis ("The Generator") +## Why bis? & Purpose + Because, there is already a tool named `js_of_ocaml` whose job is + to produce efficient Javascript from OCaml bytecode. We are not that tool. + + Here, we try to translate OCaml syntax to 'simple' ECMAScript syntax, the + purpose of it is to generate readable ECMAScript code, so that it + could later be use in a step-by-step ECMAScript interpreter. + +## Dependencies + See parent directory. + +## What is built + * **main**: The main ml-to-js compiler. Can produce files in one of 5 modes, + using the `-mode` parameter: + * `log`: Executable JS output with logging function calls for use with the + debugger. + * `unlog`: Plain executable JS output + * `token`: Produces `unlog` annotated with token identifiers for `log`. And + produces an `.mlloc.js` file mapping token identifiers to locations of the + input `.ml` source file. + * `pseudo`: 'Pseudo'-js output. Makes use of monadic let bindings alike the + input OCaml to improve readability. + * `ptoken`: `token` equivalent for `pseudo` output files. + * **lineof**: Converts and combines `.token.js`, `.ptoken.js`, and `.mlloc.js` + files into `lineof.js` which maps token identifiers to file locations. + * **assembly**: Linker for compiled `.log.js` files into a single executable + `.js` file. + * **displayed_sources**: Produces string versions of the relevant source + files, for display. + * **monad_ppx**: PPX rewriter for monadic binder extension syntax. See below. + + Each of these programs may be compiled to a bytecode or native target as + desired. Bytecode is the default. + +### Makefile Targets + The following `make` targets are defined: + * `default`: Compiles bytecode versions of the programs and the stdlib. + * `all`: Compiles bytecode and native versions of the programs and the stdlib. + * `byte` / `native`: Compiles bytecode or native versions of the programs. + * \*`.byte` / \*`.native`: Compiles the specified program into bytecode or + native code. + * `debug`: Compiles bytecode versions of the programs with debug symbols, and + the appropriate `.ocamldebug` configuration file. + * `test`: Compiles and executes the test suite. See below. + * `clean`: Cleans built targets. + +## How does it work? + In order to get the statically typed abstract syntax tree (STAST) of OCaml we + link against compiler-libs, we have tested against versions 4.04.0. Previous + versions are available for >= 4.02.1. + + On top, of this STAST, there is a custom back-end that compiles OCaml to + ECMAScript. The code written in OCaml cannot rely on code from the typical + standard library. Therefore a file named `stdlib.mli` (found in the directory + `stdlib_ml`) contains all the required definitions for the examples to work. + This file as a twin which is `stdlib.js`, in this file the functions whose + prototype is in `stdlib.mli` are defined here. + +## About the subset of OCaml supported + * **Let** declarations, except `let () =`. Recursive declarations are + supported. + * **If then else** statements, as expected `if then else` expressions return a + value. + * **Pattern matching**, only one level of pattern matching over arbitrary + types. + * **Type declarations**, if a constructor take arguments (one or more), you + should add an annotations to provide default names for the parameters. See + example below. + ```ocaml + type 'a tree = | Leaf of 'a [@f value] | Node of 'a + tree * 'a * 'a tree [@f left, value, right] + ``` + * **Records** Records are translated to objects. Record copying using the + OCaml `with` syntax is supported for any number of field updates. + +## About the Subset of JavaScript Used + * Object.assign (ES6) + * No type casting + * No prototypes + * Arrays (for tuples) + * Switch on strings (used for type constructor matching) + * `with` as a simplistic means of linking module definitions. + +## About the Monadic Rewriter PPX + This is a OCaml AST preprocessor that converts `let%x` syntax into the + monadic binder `if_x` with the continuation as the bound expression of the + let term. + + For example: + * `let%some x = expr in cont` ↝ `if_some expr (fun x -> cont)` + * `let%spec (s,x) = expr in cont` ↝ `if_spec expr (fun s x -> cont)` + + The full list of available monads is provided in the file + [`monadic_binder_list.ml`](./monadic_binder_list.ml). This file should be + configured as appropriate for the target application. The current + configuration is for jsref. + +## Test Suite + The `tests` directory contains test files for the generator to compile. Test + cases will first be built and run with the standard OCaml compiler to check + that the assertions made within the tests are correct. The tests are then + compiled with the generator and executed with Nodejs to ensure that the + compiled versions are also correct. Cross-checking of results is not + performed, it is expected that all tests should pass under both execution + environments. + + The test case library interface is described in + (tests/lib/mocha.mli)[./tests/lib/mocha.mli], it is designed to be similar in + style to the Mocha JS testing framework. The JS test environment is backed + directly by Mocha, the OCaml test environment is Alcotest with a wrapper to + provide a Mocha interface. + + Tests are built and executed using the `make test` command in this directory. + +## Other Notes + Historical versions of the repository required the OCaml 4.02.1 compiler + source code to compile directly against. We are unable to redistribute + these files for licensing reasons. If for some reason you want to build a + historic version, then drop the parsing, typing and utils directories from + the OCaml distribution into this directory, some further configuration may + be required... The whole historic distribution archived in the private + jscert\_dev repository. diff --git a/README.org b/README.org deleted file mode 100644 index 37d7ef3..0000000 --- a/README.org +++ /dev/null @@ -1,118 +0,0 @@ -* Js_of_ocaml bis - -** Why bis? & Purpose - - Because, there is already a tool named `js_of_ocaml` whose job is - to produce efficient Javascript from OCaml bytecode. - - Here, we try to translate OCaml syntax to ECMAScript5 syntax, the - purpose of it is to generate readable ECMAScript code, so that it - could later be use in a step-by-step ECMAScript interpreter. - -** Dependencies - - - `node.js` and the `esprima` package. In order to get the esprima - package the more convenient way is to get `npm` (/node package - manager/) and run ~npm install esprima~. - - ocaml 4.04.0 - -** How to run it - -#+BEGIN_src -make -make tests -./run.sh tests/js/the_file_you_want_to_run.js -#+END_src - - I you run into any error about *.cmi files that should not be - present run the following command: - -#+BEGIN_src -make cleanall -#+END_src - -** How does it work? - - In order to get the statically typed abstract syntax tree (STAST) of - OCaml we link against compiler-libs, we have tested against versions - 4.04.0. Previous versions are available for >= 4.02.1. - - On top, of this STAST, there is a custom back-end that - transliterate OCaml to ECMAScript. The code written in OCaml cannot - rely on code from the typical standard library. Therefore a - file named `stdlib.mli` (found in the directory `stdlib_ml`) contains - all the required definitions for the exemples to work. This file as - a twin which is `stdlib.js` found in `stdlib_js`, in this file the - functions whose prototype is in `stdlib.mli` are defined here. - -** About the subset of OCaml supported - - * *Let (rec)* declarations, except ~let () =~ and ~let _ =~. - * *If then else* statements, as excepted ~if then else~ - statements return a value. - * *Pattern matching*, only one level of pattern matching over - arbitrary types. - * *Types declarations*, if a constructor take arguments (one or - more), you should add an annotations to provide default names for - the parameters. See example below. - -#+BEGIN_src - -type 'a tree = - | Leaf of `a [@f value] - | Node of `a tree * `a * `a tree [@f left, value, right] - -#+END_src - - * *Records* Records are translated to objects. Record copying - ~with~ syntax is supported with any number of field updates. - -** About the Subset of JavaScript Used -- Object.assign (ES6) -- No type casting -- No prototypes -- Arrays (for tuples) -- Switch on strings -- ... - -** Notes - - Historical versions of the repository required the OCaml 4.02.1 compiler - source code to compile directly against. We are unable to redistribute - these files for licensing reasons. If for some reason you want to build a - historic version, then drop the parsing, typing and utils directories from - the OCaml distribution into this directory, some further configuration may - be required... Team members may find the whole historic distribution - archived in the private jscert_dev repository. - -** About the Monadic Rewriter PPX - This is a OCaml AST preprocessor that converts ~let%x~ syntax into the - monadic binder ~if_x~ with the continuation as the bound expression of the - let term. - - For example: - - ~let%some x = expr in cont~ becomes ~if_some expr (fun x -> cont)~ - - ~let%if_spec (s,x) = expr in cont~ becomes ~if_spec expr (fun s x -> cont)~ - - The full list of available monads is provided in the file - [[monadic_binder_list.ml]], but is reproduced below for convenience: - - string - - object - - value - - prim - - number - - some - - bool - - void - - success - - not_throw - - ter - - break - - spec - - assert - - ret /Note: argument is special-cased to pass tuples rather than unpack to argument application/ - - ~_ret~ forms of binders are provided to be wrapped in the Return monad for - use inside of a ~let%ret~, - UPPERCASE forms of binders are the ~!~/"never abrupt" spec-text equivalent - binders to the standard (~ReturnIfAbrupt~/~?~) binders.