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 diff --git a/.merlin b/.merlin index e3a6ddc..1567446 100644 --- a/.merlin +++ b/.merlin @@ -1,3 +1,5 @@ +REC B _build PKG str PKG compiler-libs.common +PKG ocaml-migrate-parsetree 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/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 c1202b8..0000000 --- a/README.org +++ /dev/null @@ -1,111 +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 moands is provided in `monad_mapping` of - monad_ppx.ml, but is reproduced below for convenience: - - run - - string - - object - - value - - prim - - number - - some - - bool - - void - - success - - not_throw - - ter - - break diff --git a/TODO b/TODO index d318021..f6e03dc 100644 --- a/TODO +++ b/TODO @@ -8,22 +8,18 @@ => 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; 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. *) 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 @@ -58,10 +54,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 diff --git a/js_of_ast.ml b/js_of_ast.ml index b28fc0f..2551395 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 @@ -48,19 +47,21 @@ let rename_constructor s = (****************************************************************) (* SHADOWING CHECKER *) -let report_shadowing = - !current_mode = Mode_cmi +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 -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 - if is_shadowing - then warning ?loc:loc (" !!!!! shadowing of variable: " ^ id); - end +(* 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 +(* 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 *) @@ -127,30 +128,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 *) @@ -262,31 +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 [ - "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";] - | _ -> false - - - (****************************************************************) (* PPF HELPERS *) @@ -313,10 +270,12 @@ 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) -> Printf.sprintf "%s = %s" id se) binders) in - Printf.sprintf "@[var %s;@]" binds + let binds = show_list "@," (List.map + (fun (id,se) -> Printf.sprintf "var %s = %s;" id se) binders) in + Printf.sprintf "@[%s@]" binds let ppf_let_tuple ids sbody = assert (ids <> []); @@ -360,10 +319,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 = @@ -400,14 +355,42 @@ let ppf_pat_array id_list array_expr = let ppf_field_access expr field = Printf.sprintf "%s.%s" expr field -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 - -let ppf_ident i = - i |> Ident.name |> ppf_ident_name +(****************************************************) +(* 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"; + "export"; "extends"; "finally"; "for"; "function"; "if"; "import"; "in"; "instanceof"; "new"; "return"; "super"; + "switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while"; "with"; "yield"; "enum"] + +(** 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) + +(** 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 @@ -520,7 +503,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 pairs of id *) (* Note: if binders = [], then newctx = ctx *) let (token_start, token_stop, token_loc) = token_fresh !current_mode loc in let sbinders_common () = @@ -668,17 +650,17 @@ let generate_logged_return loc ctx sbody = (** Destination-style translation of expressions *) -type dest = +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 *) @@ -702,7 +684,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 @@ -727,50 +709,52 @@ 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 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) (* 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 pat (result, index, sm) = let loc = pat.pat_loc in match pat.pat_desc with - | 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" + | 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) | _ -> 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 - +let tuple_binders stupleobj sm pl = + 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) (****************************************************************) (* TRANSLATION *) @@ -788,31 +772,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 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 - 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 = 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 let s = Printf.sprintf "@[var %s = %s;@]" id sbody in (s, [id]))) | Tstr_type (rec_flag, decls) -> @@ -824,7 +795,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 @@ -835,10 +806,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" @@ -850,43 +818,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) 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 @@ -894,33 +864,37 @@ and js_of_expression 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; - 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 (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) - | [ { vb_pat = { pat_desc = Tpat_record (args, closed_flag) }; vb_expr = obj } ] -> (* binding records --- TODO: this code does not seem to be used *) + (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) + 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 sm', binders = map_state bind sm args in let ids = List.map fst binders in let sdecl = if is_mode_pseudo() then begin @@ -928,22 +902,27 @@ and js_of_expression ctx dest e = 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 recur 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 | 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 ident_of_pat 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 @@ -977,11 +956,11 @@ 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) - | 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" @@ -1003,27 +982,24 @@ and js_of_expression 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 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 -> - match pat.pat_desc with - | Tpat_var (id, _) -> let x = ppf_ident id 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 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 @@ -1039,6 +1015,9 @@ and js_of_expression 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 @@ -1099,7 +1078,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 @@ -1145,8 +1124,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 @@ -1199,13 +1178,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" @@ -1232,11 +1211,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; @@ -1264,13 +1238,13 @@ 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" | 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" @@ -1282,14 +1256,15 @@ 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 recur = + let { vb_pat = pat; vb_expr = expr } = vb in + let id = match pat.pat_desc with - | Tpat_var (id, _) -> ppf_ident id - | Tpat_any -> out_of_scope pat.pat_loc "_ in let" + | Tpat_var (id, _) -> id + | 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" @@ -1301,8 +1276,11 @@ 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) expr) + 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) (* LATER: for let (x,y) = e, encode as translate(e,assign z); x = z[0]; y=z[1] | Tpat_tuple (pat_l) @@ -1320,26 +1298,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, _) -> - Some (ppf_ident id, Printf.sprintf "%s.%s" obj field) + | Tpat_var (id, _) -> + 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/monad_ppx.ml b/monad_ppx.ml index 4a96094..db0837b 100644 --- a/monad_ppx.ml +++ b/monad_ppx.ml @@ -3,22 +3,7 @@ open Ast_helper 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"); - ] +open Monadic_binder_list (* e.g. @@ -36,57 +21,50 @@ 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_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 - (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)))] - | _ -> - 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; + | 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 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 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")) + + 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 new file mode 100644 index 0000000..bda44aa --- /dev/null +++ b/monadic_binder_list.ml @@ -0,0 +1,51 @@ +let monad_mapping = [ + ("string", "if_string"); + ("STRING", "assert_string"); + ("object", "if_object"); + ("OBJECT", "assert_object"); + ("value", "if_value"); + ("VALUE", "assert_value"); + ("prim", "if_prim"); + ("number", "if_number"); + ("some", "if_some"); + ("bool", "if_bool"); + ("BOOL", "assert_bool"); + ("void", "if_void"); + ("success", "if_success"); + ("SUCCESS", "assert_success"); + ("not_throw", "if_not_throw"); + ("ter", "if_ter"); + ("break", "if_break"); + ("spec", "if_spec"); + ("assert", "check_assert"); + + ("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"); + ("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 + +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 3f41fc5..46165a0 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 = @@ -54,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 | [] -> [] @@ -65,6 +66,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 @@ -113,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/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 diff --git a/stdlib_ml/stdlib.js b/stdlib_ml/stdlib.js index 2eee1a4..b1a0306 100644 --- a/stdlib_ml/stdlib.js +++ b/stdlib_ml/stdlib.js @@ -29,7 +29,8 @@ 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); }; //---------------------------------------------------------------------------- // Boolean operations diff --git a/stdlib_ml/stdlib.ml b/stdlib_ml/stdlib.ml index e97cc85..a79ec1d 100644 --- a/stdlib_ml/stdlib.ml +++ b/stdlib_ml/stdlib.ml @@ -9,12 +9,13 @@ 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. *) 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..bf6d64e 100644 --- a/stdlib_ml/stdlib.mli +++ b/stdlib_ml/stdlib.mli @@ -28,14 +28,15 @@ 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 (**{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" 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/.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/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..18901ac 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,11 +1,61 @@ -test: ../monad_ppx.byte let.ml - ocamlc -ppx ../monad_ppx.byte let.ml +STDLIB_DIR := ../stdlib_ml +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 +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" + @../../node_modules/mocha/bin/mocha -R list $^ + +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 -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode unlog $(LIBS) $< %.log.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode log -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode log $(LIBS) $< %.token.js: %.ml ../main.byte ../monad_ppx.byte - ../main.byte -mode token -ppx ../monad_ppx.byte -I ../stdlib_ml $< + ../main.byte -mode token $(LIBS) $< + +# $$^ 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 + ocamlfind ocamlc -package alcotest -c $< -o $@ + +lib/mocha.cmo: lib/mocha.ml lib/mocha.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} *.{unlog,log,token,as}.js + +.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 new file mode 100644 index 0000000..192a70a --- /dev/null +++ b/tests/lettuple.ml @@ -0,0 +1,40 @@ +open Mocha + +let test _ = + let (y,z) = (1,2) + in y + +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..d1a8d20 --- /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 + , 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')); +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 new file mode 100644 index 0000000..c0d2b5a --- /dev/null +++ b/tests/shadow.ml @@ -0,0 +1,75 @@ +open Mocha +open Shadow_include + +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 _ -> + 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 "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 _ -> + 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" + ); + + 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 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]