diff --git a/.gitignore b/.gitignore index ec464113b6..87b0876181 100644 --- a/.gitignore +++ b/.gitignore @@ -56,3 +56,6 @@ setup.log # Backup of opam lock file hazel.opam.locked.old + +# Code coverage +_coverage/ diff --git a/Makefile b/Makefile index 773e900d38..234ee71cc2 100644 --- a/Makefile +++ b/Makefile @@ -25,7 +25,7 @@ setup-student: dev-helper: dune fmt --auto-promote || true - dune build @src/fmt --auto-promote src --profile dev + dune build @ocaml-index @src/fmt --auto-promote src --profile dev dev: setup-instructor dev-helper @@ -35,7 +35,7 @@ fmt: dune fmt --auto-promote watch: setup-instructor - dune build @src/fmt --auto-promote src --profile dev --watch + dune build @ocaml-index @src/fmt --auto-promote src --profile dev --watch watch-release: setup-instructor dune build @src/fmt --auto-promote src --profile release --watch @@ -60,11 +60,19 @@ repl: test: dune fmt --auto-promote || true - dune build @src/fmt @test/fmt --auto-promote src test --profile dev + dune build @ocaml-index @src/fmt @test/fmt --auto-promote src test --profile dev node $(TEST_DIR)/haz3ltest.bc.js watch-test: - dune build @fmt @runtest --auto-promote --watch + dune build @ocaml-index @fmt @runtest --auto-promote --watch + +coverage: + dune build @src/fmt @test/fmt --auto-promote src test --profile dev + dune runtest --instrument-with bisect_ppx --force + bisect-ppx-report summary + +generate-coverage-html: + bisect-ppx-report html clean: dune clean diff --git a/README.md b/README.md index a15bdd424e..15caf27308 100644 --- a/README.md +++ b/README.md @@ -197,6 +197,9 @@ You can run all of the unit tests located in `test` by running `make test`. Unit tests are written using the [Alcotest framework](https://github.com/mirage/alcotest). +#### Coverage +Code coverage is provided by [bisect_ppx](https://github.com/aantron/bisect_ppx). To collect coverage statistics from tests run `make coverage`. After coverage statistics are generated, running `make generate-coverage-html` will generate a local webpage at `_coverage/index.html` that can be viewed to see line coverage per module. + ### Continuous Integration When you push your branch to the main `hazelgrove/hazel` repository, we diff --git a/dune-project b/dune-project index 335194ae48..4dd3442bc4 100644 --- a/dune-project +++ b/dune-project @@ -26,16 +26,17 @@ (menhir (>= 2.0)) yojson - reason + (reason (>= 3.12.0)) ppx_yojson_conv_lib ppx_yojson_conv incr_dom + bisect_ppx (omd (>= 2.0.0~alpha4)) ezjs_idb - virtual_dom + bonsai ppx_deriving ptmap - uuidm + (uuidm (= 0.9.8)) ; 0.9.9 has breaking deprecated changes unionFind ocamlformat (junit_alcotest :with-test) diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 0000000000..93d6e50904 --- /dev/null +++ b/dune-workspace @@ -0,0 +1,10 @@ +(lang dune 3.16) + +; List of warning codes found at https://ocaml.org/manual/5.2/comp.html#s:comp-options +(env + (dev + (flags + (:standard -warn-error +A-26-27-K-58))) ; Disable some unused warnings. + (release + (flags + (:standard -warn-error +A-58)))) diff --git a/hazel.opam b/hazel.opam index 36a81b933a..09ee887ab3 100644 --- a/hazel.opam +++ b/hazel.opam @@ -11,16 +11,16 @@ depends: [ "ocaml" {>= "5.2.0"} "menhir" {>= "2.0"} "yojson" - "reason" + "reason" {>= "3.12.0"} "ppx_yojson_conv_lib" "ppx_yojson_conv" - "incr_dom" + "bisect_ppx" "omd" {>= "2.0.0~alpha4"} "ezjs_idb" - "virtual_dom" + "bonsai" "ppx_deriving" "ptmap" - "uuidm" + "uuidm" {= "0.9.8"} "unionFind" "ocamlformat" "junit_alcotest" {with-test} diff --git a/hazel.opam.locked b/hazel.opam.locked index 31fd8b2c15..856b83ad33 100644 --- a/hazel.opam.locked +++ b/hazel.opam.locked @@ -1,7 +1,7 @@ opam-version: "2.0" name: "hazel" -version: "~dev" +version: "dev" synopsis: "Hazel, a live functional programming environment with typed holes" maintainer: "Hazel Development Team" authors: "Hazel Development Team" @@ -11,11 +11,19 @@ bug-reports: "https://github.com/hazelgrove/hazel/issues" depends: [ "abstract_algebra" {= "v0.16.0"} "alcotest" {= "1.8.0" & with-test} - "angstrom" {= "0.16.0"} + "angstrom" {= "0.16.1"} "astring" {= "0.8.5"} + "async" {= "v0.16.0"} + "async_durable" {= "v0.16.0"} + "async_extra" {= "v0.16.0"} "async_js" {= "v0.16.0"} "async_kernel" {= "v0.16.0"} "async_rpc_kernel" {= "v0.16.0"} + "async_rpc_websocket" {= "v0.16.0"} + "async_ssl" {= "v0.16.1"} + "async_unix" {= "v0.16.0"} + "async_websocket" {= "v0.16.0"} + "babel" {= "v0.16.0"} "base" {= "v0.16.3"} "base-bigarray" {= "base"} "base-bytes" {= "base"} @@ -26,85 +34,118 @@ depends: [ "base64" {= "3.5.1"} "base_bigstring" {= "v0.16.0"} "base_quickcheck" {= "v0.16.0"} + "bigarray-compat" {= "1.1.0"} "bignum" {= "v0.16.0"} - "bigstringaf" {= "0.9.1"} + "bigstringaf" {= "0.10.0"} "bin_prot" {= "v0.16.0"} + "bonsai" {= "v0.16.0"} + "bisect_ppx" {= "2.8.3"} "camlp-streams" {= "5.0.1"} "chrome-trace" {= "3.16.0"} "cmdliner" {= "1.3.0"} + "cohttp" {= "5.3.1"} + "cohttp-async" {= "5.3.0"} + "cohttp_async_websocket" {= "v0.16.0"} + "conduit" {= "7.1.0"} + "conduit-async" {= "7.1.0"} "conf-bash" {= "1"} "conf-gmp" {= "4"} + "conf-gmp-powm-sec" {= "3"} + "conf-libffi" {= "2.0.0"} + "conf-libssl" {= "4"} + "conf-pkg-config" {= "3"} + "conf-zlib" {= "1"} "core" {= "v0.16.2"} + "core_bench" {= "v0.16.0"} "core_kernel" {= "v0.16.0"} - "cppo" {= "1.6.9"} + "core_unix" {= "v0.16.0"} + "cppo" {= "1.7.0"} "crunch" {= "3.3.1" & with-doc} + "cryptokit" {= "1.16.1"} "csexp" {= "1.5.2"} + "ctypes" {= "0.23.0"} + "ctypes-foreign" {= "0.23.0"} "diffable" {= "v0.16.0"} + "domain-name" {= "0.4.0"} "dune" {= "3.16.0"} "dune-build-info" {= "3.16.0"} "dune-configurator" {= "3.16.0"} "dune-rpc" {= "3.16.0"} "dyn" {= "3.16.0"} "either" {= "1.0.0"} + "expect_test_helpers_core" {= "v0.16.0"} "ezjs_idb" {= "0.1.1"} "ezjs_min" {= "0.3.0"} "fiber" {= "3.7.0"} "fieldslib" {= "v0.16.0"} "fix" {= "20230505"} - "fmt" {= "0.9.0" & with-test} + "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} + "fuzzy_match" {= "v0.16.0"} "gen" {= "1.1"} - "gen_js_api" {= "1.1.2"} + "gen_js_api" {= "1.1.3"} "incr_dom" {= "v0.16.0"} "incr_map" {= "v0.16.0"} "incr_select" {= "v0.16.0"} "incremental" {= "v0.16.1"} + "indentation_buffer" {= "v0.16.0"} "int_repr" {= "v0.16.0"} + "integers" {= "0.7.0"} + "ipaddr" {= "5.6.0"} + "ipaddr-sexp" {= "5.6.0"} "jane-street-headers" {= "v0.16.0"} "janestreet_lru_cache" {= "v0.16.1"} "js_of_ocaml" {= "5.8.2"} "js_of_ocaml-compiler" {= "5.8.2"} "js_of_ocaml-ppx" {= "5.8.2"} "js_of_ocaml_patches" {= "v0.16.0"} + "jsonm" {= "1.0.2"} "jsonrpc" {= "1.19.0"} "jst-config" {= "v0.16.0"} "junit" {= "2.0.2" & with-test} "junit_alcotest" {= "2.0.2" & with-test} - "lambdasoup" {= "1.0.0"} + "lambdasoup" {= "1.1.1"} + "logs" {= "0.7.0"} "lsp" {= "1.19.0"} - "lwt" {= "5.7.0"} + "macaddr" {= "5.6.0"} + "magic-mime" {= "1.3.1"} "markup" {= "1.0.3"} - "menhir" {= "20231231"} - "menhirCST" {= "20231231"} - "menhirLib" {= "20231231"} - "menhirSdk" {= "20231231"} + "menhir" {= "20240715"} + "menhirCST" {= "20240715"} + "menhirLib" {= "20240715"} + "menhirSdk" {= "20240715"} "merlin-extend" {= "0.6.1"} - "merlin-lib" {= "5.1-502"} - "num" {= "1.5"} + "merlin-lib" {= "5.2.1-502"} + "num" {= "1.5-1"} "ocaml" {= "5.2.0"} "ocaml-base-compiler" {= "5.2.0"} "ocaml-compiler-libs" {= "v0.17.0"} "ocaml-config" {= "3"} - "ocaml-index" {= "1.0"} + "ocaml-embed-file" {= "v0.16.0"} + "ocaml-index" {= "1.1"} "ocaml-lsp-server" {= "1.19.0"} "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} - "ocaml-version" {= "3.6.7"} - "ocamlbuild" {= "0.14.3"} + "ocaml-version" {= "3.6.9"} + "ocaml_intrinsics" {= "v0.16.1"} + "ocamlbuild" {= "0.15.0"} "ocamlc-loc" {= "3.16.0"} "ocamlfind" {= "1.9.6"} "ocamlformat" {= "0.26.2"} "ocamlformat-lib" {= "0.26.2"} "ocamlformat-rpc-lib" {= "0.26.2"} "ocp-indent" {= "1.8.1"} - "ocplib-endian" {= "1.2"} "octavius" {= "1.2.2"} - "odoc" {= "2.4.2" & with-doc} - "odoc-parser" {= "2.4.2" & with-doc} - "ojs" {= "1.1.2"} + "odoc" {= "2.4.3" & with-doc} + "odoc-parser" {= "2.4.3" & with-doc} + "ojs" {= "1.1.3"} "omd" {= "2.0.0~alpha4"} "ordering" {= "3.16.0"} + "ordinal_abbreviation" {= "v0.16.0"} "parsexp" {= "v0.16.0"} + "patdiff" {= "v0.16.1"} + "patience_diff" {= "v0.16.0"} + "polling_state_rpc" {= "v0.16.0"} "pp" {= "1.2.0"} "ppx_assert" {= "v0.16.0"} "ppx_base" {= "v0.16.0"} @@ -112,6 +153,7 @@ depends: [ "ppx_bin_prot" {= "v0.16.0"} "ppx_cold" {= "v0.16.0"} "ppx_compare" {= "v0.16.0"} + "ppx_css" {= "v0.16.0"} "ppx_custom_printf" {= "v0.16.0"} "ppx_derivers" {= "1.2.1"} "ppx_deriving" {= "6.0.2"} @@ -141,19 +183,24 @@ depends: [ "ppx_stable_witness" {= "v0.16.0"} "ppx_string" {= "v0.16.0"} "ppx_tydi" {= "v0.16.0"} + "ppx_typed_fields" {= "v0.16.0"} "ppx_typerep_conv" {= "v0.16.0"} "ppx_variants_conv" {= "v0.16.0"} "ppx_yojson_conv" {= "v0.16.0"} "ppx_yojson_conv_lib" {= "v0.16.0"} - "ppxlib" {= "0.32.1"} + "ppxlib" {= "0.33.0"} + "profunctor" {= "v0.16.0"} "protocol_version_header" {= "v0.16.0"} - "ptime" {= "1.1.0" & with-test} + "ptime" {= "1.2.0" & with-test} "ptmap" {= "2.0.5"} - "re" {= "1.11.0"} + "re" {= "1.12.0"} "reason" {= "3.12.0"} + "record_builder" {= "v0.16.0"} "result" {= "1.5"} "sedlex" {= "3.2"} "seq" {= "base"} + "sexp_grammar" {= "v0.16.0"} + "sexp_pretty" {= "v0.16.0"} "sexplib" {= "v0.16.0"} "sexplib0" {= "v0.16.0"} "spawn" {= "v0.15.1"} @@ -164,7 +211,11 @@ depends: [ "stored_reversed" {= "v0.16.0"} "streamable" {= "v0.16.1"} "stringext" {= "1.6.0"} + "textutils" {= "v0.16.0"} + "textutils_kernel" {= "v0.16.0"} + "tilde_f" {= "v0.16.0"} "time_now" {= "v0.16.0"} + "timezone" {= "v0.16.0"} "topkg" {= "1.0.7"} "typerep" {= "v0.16.0"} "tyxml" {= "4.6.0"} @@ -172,16 +223,16 @@ depends: [ "unionFind" {= "20220122"} "uri" {= "4.4.0"} "uri-sexp" {= "4.4.0"} - "uucp" {= "15.1.0"} + "uucp" {= "16.0.0"} "uuidm" {= "0.9.8"} - "uunf" {= "15.1.0"} - "uuseg" {= "15.1.0"} + "uunf" {= "16.0.0"} + "uuseg" {= "16.0.0"} "uutf" {= "1.0.3"} "variantslib" {= "v0.16.0"} "virtual_dom" {= "v0.16.0"} "xdg" {= "3.16.0"} "yojson" {= "2.2.2"} - "zarith" {= "1.13"} + "zarith" {= "1.14"} "zarith_stubs_js" {= "v0.16.1"} ] build: [ diff --git a/src/haz3lcore/dune b/src/haz3lcore/dune index 77e2ca3fe1..a0d9770816 100644 --- a/src/haz3lcore/dune +++ b/src/haz3lcore/dune @@ -4,6 +4,8 @@ (name haz3lcore) (libraries util sexplib unionFind uuidm virtual_dom yojson core) (js_of_ocaml) + (instrumentation + (backend bisect_ppx)) (preprocess (pps ppx_yojson_conv diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 05d255cc8e..fc4027f4d6 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -99,6 +99,7 @@ module EvaluatorEVMode: { | (BoxedReady, Constructor) => (BoxedValue, c) | (IndetReady, Constructor) => (Indet, c) | (IndetBlocked, _) => (Indet, c) + | (_, Value) => (BoxedValue, c) | (_, Indet) => (Indet, c) }; }; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 7d0a37e15f..3416a46742 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -315,6 +315,7 @@ module Decompose = { | (undo, Result.BoxedValue, env, v) => switch (rl(v)) { | Constructor => Result.BoxedValue + | Value => Result.BoxedValue | Indet => Result.Indet | Step(s) => Result.Step([EvalObj.mk(Mark, env, undo, s.kind)]) // TODO: Actually show these exceptions to the user! @@ -366,6 +367,7 @@ module TakeStep = { state_update(); Some(expr); | Constructor + | Value | Indet => None }; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index a68b2add46..c178a49dfa 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -91,7 +91,8 @@ type rule = is_value: bool, }) | Constructor - | Indet; + | Indet + | Value; let (let-unbox) = ((request, v), f) => switch (Unboxing.unbox(request, v)) { @@ -331,7 +332,7 @@ module Transition = (EV: EV_MODE) => { (d2, ds) => DeferredAp2(d1, d2, ds) |> wrap_ctx, ds, ); - Constructor; + Value; | Ap(dir, d1, d2) => let. _ = otherwise(env, (d1, (d2, _)) => Ap(dir, d1, d2) |> rewrap) and. d1' = @@ -392,18 +393,25 @@ module Transition = (EV: EV_MODE) => { } else { Indet; } - /* This case isn't currently used because deferrals are elaborated away */ | DeferredAp(d3, d4s) => let n_args = List.length( - List.map( + List.filter( fun | {term: Deferral(_), _} => true | _ => false: Exp.t => bool, d4s, ), ); - let-unbox args = (Tuple(n_args), d2); + let-unbox args = + if (n_args == 1) { + ( + Tuple(n_args), + Tuple([d2]) |> fresh // TODO Should we not be going to a tuple? + ); + } else { + (Tuple(n_args), d2); + }; let new_args = { let rec go = (deferred, args) => switch ((deferred: list(Exp.t))) { diff --git a/src/haz3lcore/dynamics/ValueChecker.re b/src/haz3lcore/dynamics/ValueChecker.re index 39f43daeed..c99a90db6f 100644 --- a/src/haz3lcore/dynamics/ValueChecker.re +++ b/src/haz3lcore/dynamics/ValueChecker.re @@ -69,6 +69,7 @@ module ValueCheckerEVMode: { | (_, _, Constructor) => r | (_, Expr, Indet) => Expr | (_, _, Indet) => Indet + | (_, _, Value) => Value | (true, _, Step(_)) => Expr | (false, _, Step(_)) => r }; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 147482613b..200be8a4ab 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -14,6 +14,11 @@ type t('a) = { term: 'a, }; +// To be used if you want to remove the id from the debug output +// let pp: ((Format.formatter, 'a) => unit, Format.formatter, t('a)) => unit = +// (fmt_a, formatter, ta) => { +// fmt_a(formatter, ta.term); +// }; let fresh = term => { {ids: [Id.mk()], copied: false, term}; }; diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index c599af61c7..0d068dcfcb 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -335,6 +335,7 @@ let is_consistent = (ctx: Ctx.t, ty1: t, ty2: t): bool => let rec weak_head_normalize = (ctx: Ctx.t, ty: t): t => switch (term_of(ty)) { + | Parens(t) => weak_head_normalize(ctx, t) | Var(x) => switch (Ctx.lookup_alias(ctx, x)) { | Some(ty) => weak_head_normalize(ctx, ty) diff --git a/src/haz3lcore/statics/Elaborator.re b/src/haz3lcore/statics/Elaborator.re index d752fe089b..f00b021130 100644 --- a/src/haz3lcore/statics/Elaborator.re +++ b/src/haz3lcore/statics/Elaborator.re @@ -355,7 +355,10 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { ((arg, _)) => Exp.is_deferral(arg), List.combine(args, ty_fargs), ); - let remaining_arg_ty = Prod(List.map(snd, remaining_args)) |> Typ.temp; + let remaining_arg_ty = + List.length(remaining_args) == 1 + ? snd(List.hd(remaining_args)) + : Prod(List.map(snd, remaining_args)) |> Typ.temp; DeferredAp(f'', args'') |> rewrap |> cast_from(Arrow(remaining_arg_ty, tyf2) |> Typ.temp); diff --git a/src/haz3lweb/Main.re b/src/haz3lweb/Main.re index c244632e0c..bc1521dd86 100644 --- a/src/haz3lweb/Main.re +++ b/src/haz3lweb/Main.re @@ -1,28 +1,9 @@ open Util; open Js_of_ocaml; -open Incr_dom; open Haz3lweb; +open Bonsai.Let_syntax; let scroll_to_caret = ref(true); -let edit_action_applied = ref(true); -let last_edit_action = ref(JsUtil.timestamp()); - -let observe_font_specimen = (id, update) => - ResizeObserver.observe( - ~node=JsUtil.get_elem_by_id(id), - ~f= - (entries, _) => { - let specimen = Js.to_array(entries)[0]; - let rect = specimen##.contentRect; - update( - Haz3lweb.FontMetrics.{ - row_height: rect##.bottom -. rect##.top, - col_width: rect##.right -. rect##.left, - }, - ); - }, - (), - ); let restart_caret_animation = () => // necessary to trigger reflow @@ -40,8 +21,8 @@ let apply = ( model: Page.Model.t, action: Page.Update.t, - _state: unit, ~schedule_action, + ~schedule_autosave, ) : Page.Model.t => { restart_caret_animation(); @@ -75,8 +56,17 @@ let apply = : updated.model; if (updated.is_edit) { - last_edit_action := JsUtil.timestamp(); - edit_action_applied := true; + schedule_autosave( + BonsaiUtil.Alarm.Action.SetAlarm( + Core.Time_ns.add(Core.Time_ns.now(), Core.Time_ns.Span.of_sec(1.0)), + ), + ); + } else { + schedule_autosave( + BonsaiUtil.Alarm.Action.SnoozeAlarm( + Core.Time_ns.add(Core.Time_ns.now(), Core.Time_ns.Span.of_sec(1.0)), + ), + ); }; if (updated.scroll_active) { scroll_to_caret := true; @@ -84,78 +74,109 @@ let apply = model'; }; -module App = { - module Model = Page.Model; - module Action = Page.Update; - module State = { - type t = unit; - let init = () => (); - }; - - let on_startup = (~schedule_action, _: Model.t) => { - let _ = - observe_font_specimen("font-specimen", fm => - schedule_action(Haz3lweb.Page.Update.Globals(SetFontMetrics(fm))) - ); - - NinjaKeys.initialize(Shortcut.options(schedule_action)); - JsUtil.focus_clipboard_shim(); - - Js.Unsafe.set( - Js.Unsafe.global##._Error, - "stackTraceLimit", - Js.number_of_float(infinity), +let start = { + let%sub save_scheduler = BonsaiUtil.Alarm.alarm; + let%sub (app_model, app_inject) = + Bonsai.state_machine1( + (module Page.Model), + (module Page.Update), + ~apply_action= + (~inject, ~schedule_event, input) => { + let schedule_action = x => schedule_event(inject(x)); + let schedule_autosave = action => + switch (input) { + | Active((_, alarm_inject)) => + schedule_event(alarm_inject(action)) + | Inactive => () + }; + apply(~schedule_action, ~schedule_autosave); + }, + ~default_model=Page.Store.load(), + save_scheduler, ); - /* initialize state. */ - let state = State.init(); + // Autosave every second + let save_effect = + Bonsai.Value.map(~f=g => g(Page.Update.Save), app_inject); + let%sub () = BonsaiUtil.Alarm.listen(save_scheduler, ~event=save_effect); - schedule_action(Start); + // Update font metrics on resize + let%sub size = + BonsaiUtil.SizeObserver.observer( + () => JsUtil.get_elem_by_id("font-specimen"), + ~default=BonsaiUtil.SizeObserver.Size.{width: 10., height: 10.}, + ); + let%sub () = + /* Note: once Bonsai is threaded through the system, we won't need + on_change here */ + Bonsai.Edge.on_change( + (module BonsaiUtil.SizeObserver.Size), + size, + ~callback= + app_inject + |> Bonsai.Value.map(~f=(i, rect: BonsaiUtil.SizeObserver.Size.t) => + i( + Page.Update.Globals( + SetFontMetrics({ + row_height: rect.height, + col_width: rect.width, + }), + ), + ) + ), + ); + // Other Initialization + let on_startup = (schedule_action, ()): unit => { + NinjaKeys.initialize(Shortcut.options(schedule_action)); + JsUtil.focus_clipboard_shim(); Os.is_mac := Dom_html.window##.navigator##.platform##toUpperCase##indexOf( Js.string("MAC"), ) >= 0; - Async_kernel.Deferred.return(state); }; + let%sub () = + BonsaiUtil.OnStartup.on_startup( + { + let%map app_inject = app_inject; + Bonsai.Effect.Many([ + // Initialize state + Bonsai.Effect.of_sync_fun( + on_startup(x => x |> app_inject |> Bonsai.Effect.Expert.handle), + (), + ), + // Initialize evaluation on a worker + app_inject(Start), + ]); + }, + ); - let create = - (model: Incr.t(Model.t), ~old_model as _: Incr.t(Model.t), ~inject) => { - open Incr.Let_syntax; - let%map model = model; - /* Note: mapping over the old_model here may - trigger an additional redraw */ - Component.create( - ~apply_action=apply(model), - model, - Haz3lweb.Page.View.view(~get_log_and=Log.get_and, ~inject, model), - ~on_display=(_, ~schedule_action) => { - if (edit_action_applied^ - && JsUtil.timestamp() - -. last_edit_action^ > 1000.0) { - /* If an edit action has been applied, but no other edit action - has been applied for 1 second, save the model. */ - edit_action_applied := false; - print_endline("Saving..."); - schedule_action(Page.Update.Save); - }; + // Triggers after every update + let after_display = { + Bonsai.Effect.of_sync_fun( + () => if (scroll_to_caret.contents) { scroll_to_caret := false; JsUtil.scroll_cursor_into_view_if_needed(); - }; - }, + }, + (), ); }; + let%sub () = + Bonsai.Edge.after_display(after_display |> Bonsai.Value.return); + + // View function + let%arr app_model = app_model + and app_inject = app_inject; + Haz3lweb.Page.View.view( + app_model, + ~inject=app_inject, + ~get_log_and=Log.get_and, + ); }; switch (JsUtil.Fragment.get_current()) { | Some("debug") => DebugMode.go() -| _ => - Incr_dom.Start_app.start( - (module App), - ~debug=false, - ~bind_to_element_with_id="container", - ~initial_model=Page.Store.load(), - ) +| _ => Bonsai_web.Start.start(start, ~bind_to_element_with_id="container") }; diff --git a/src/haz3lweb/app/Page.re b/src/haz3lweb/app/Page.re index 673e32726b..70422b0dd7 100644 --- a/src/haz3lweb/app/Page.re +++ b/src/haz3lweb/app/Page.re @@ -9,6 +9,7 @@ open Util; type selection = Editors.Selection.t; module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] type t = { globals: Globals.Model.t, editors: Editors.Model.t, @@ -16,7 +17,7 @@ module Model = { selection, }; - let cutoff = (===); + let equal = (===); }; module Store = { @@ -239,6 +240,7 @@ module Update = { model |> Updated.return_quiet; | Start => model |> return // Triggers recalculation at the start | Save => + print_endline("Saving..."); Store.save(model); model |> return_quiet; }; @@ -498,11 +500,7 @@ module View = { let cursor = Selection.get_cursor_info(~selection=model.selection, model); div( ~attrs=[Attr.id("page"), ...handlers(~cursor, ~inject, model)], - [ - FontSpecimen.view("font-specimen"), - DecUtil.filters, - JsUtil.clipboard_shim, - ] + [FontSpecimen.view, DecUtil.filters, JsUtil.clipboard_shim] @ main_view(~get_log_and, ~cursor, ~inject, model), ); }; diff --git a/src/haz3lweb/app/common/FontSpecimen.re b/src/haz3lweb/app/common/FontSpecimen.re index f5a5e6ab38..214d4cd24b 100644 --- a/src/haz3lweb/app/common/FontSpecimen.re +++ b/src/haz3lweb/app/common/FontSpecimen.re @@ -1,4 +1,9 @@ open Virtual_dom.Vdom; -let view = id => - Node.span(~attrs=[Attr.id(id), Attr.class_("code")], [Node.text("X")]); +exception CallbackError; + +let view = + Node.span( + ~attrs=[Attr.id("font-specimen"), Attr.class_("code")], + [Node.text("X")], + ) /* */; diff --git a/src/haz3lweb/app/globals/Globals.re b/src/haz3lweb/app/globals/Globals.re index 13d19d8419..a1608dad4c 100644 --- a/src/haz3lweb/app/globals/Globals.re +++ b/src/haz3lweb/app/globals/Globals.re @@ -21,6 +21,7 @@ module Action = { }; module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] type t = { // Persistent: settings: Settings.t, diff --git a/src/haz3lweb/debug/DebugMode.re b/src/haz3lweb/debug/DebugMode.re index 58208f0b82..6963af03bd 100644 --- a/src/haz3lweb/debug/DebugMode.re +++ b/src/haz3lweb/debug/DebugMode.re @@ -48,35 +48,8 @@ let view = { ); }; -module App = { - module Model = { - type t = unit; - let cutoff = (_, _) => false; - }; - module Action = { - type t = unit; - let sexp_of_t = _ => Sexplib.Sexp.unit; - }; - module State = { - type t = unit; - }; - let on_startup = (~schedule_action as _, _) => - Async_kernel.Deferred.return(); - let create = (_, ~old_model as _, ~inject as _) => - Incr_dom.Incr.return() - |> Incr_dom.Incr.map(~f=_ => - Incr_dom.Component.create( - ~apply_action=(_, _, ~schedule_action as _) => (), - (), - view, - ) - ); -}; - let go = () => - Incr_dom.Start_app.start( - (module App), - ~debug=false, + Bonsai_web.Start.start( + Bonsai.Computation.return(view), ~bind_to_element_with_id="container", - ~initial_model=(), ); diff --git a/src/haz3lweb/dune b/src/haz3lweb/dune index a87a4ce70e..616712dd3c 100644 --- a/src/haz3lweb/dune +++ b/src/haz3lweb/dune @@ -8,9 +8,12 @@ (library (name workerServer) (modules WorkerServer) + (instrumentation + (backend bisect_ppx)) (libraries str - incr_dom + bonsai + bonsai.web virtual_dom.input_widgets util ppx_yojson_conv.expander @@ -28,6 +31,8 @@ (library (name haz3lweb) + (instrumentation + (backend bisect_ppx)) (modules (:standard \ Main Gradescope) \ @@ -38,7 +43,8 @@ ezjs_idb workerServer str - incr_dom + bonsai + bonsai.web virtual_dom.input_widgets util ppx_yojson_conv.expander @@ -52,7 +58,8 @@ ppx_let ppx_sexp_conv ppx_deriving.show - ppx_yojson_conv))) + ppx_yojson_conv + bonsai.ppx_bonsai))) (executable (name main) @@ -65,7 +72,8 @@ js_of_ocaml-ppx ppx_let ppx_sexp_conv - ppx_deriving.show))) + ppx_deriving.show + bonsai.ppx_bonsai))) (executable (name worker) diff --git a/src/pretty/dune b/src/pretty/dune index 868d03defc..c131965aff 100644 --- a/src/pretty/dune +++ b/src/pretty/dune @@ -3,6 +3,8 @@ (library (name pretty) (libraries util sexplib) + (instrumentation + (backend bisect_ppx)) (preprocess (pps ppx_let ppx_sexp_conv))) diff --git a/src/util/BonsaiUtil.re b/src/util/BonsaiUtil.re new file mode 100644 index 0000000000..a5b9ce4057 --- /dev/null +++ b/src/util/BonsaiUtil.re @@ -0,0 +1,104 @@ +open Core; +open Bonsai; +open Bonsai.Let_syntax; +open Js_of_ocaml; + +module Alarm = { + module Action = { + [@deriving sexp] + type t = + | SetAlarm(Time_ns.Alternate_sexp.t) + | SnoozeAlarm(Time_ns.Alternate_sexp.t) + | UnsetAlarm; + }; + + let alarm = + state_machine0( + (module Time_ns.Alternate_sexp), + (module Action), + ~default_model=Time_ns.max_value_representable, + ~apply_action=(~inject as _, ~schedule_event as _, model, action) => { + switch (action) { + | SetAlarm(time) => time + | SnoozeAlarm(time) => Time_ns.max(time, model) + | UnsetAlarm => Time_ns.max_value_representable + } + }); + + let listen = (alarm, ~event) => { + let%sub before_or_after = Clock.at(alarm |> Value.map(~f=fst)); + Edge.on_change( + (module Clock.Before_or_after), + before_or_after, + ~callback={ + open Clock.Before_or_after; + let%map (_, inject) = alarm + and event = event; + fun + | After => Effect.Many([inject(Action.UnsetAlarm), event]) + | Before => Effect.Ignore; + }, + ); + }; +}; + +module OnStartup = { + let on_startup = (effect: Value.t(Effect.t(unit))) => { + let%sub startup_completed = Bonsai.toggle'(~default_model=false); + let%sub after_display = { + switch%sub (startup_completed) { + | {state: false, set_state, _} => + let%arr effect = effect + and set_state = set_state; + Bonsai.Effect.Many([set_state(true), effect]); + | {state: true, _} => Bonsai.Computation.return(Ui_effect.Ignore) + }; + }; + Edge.after_display(after_display); + }; +}; + +module SizeObserver = { + module Size = { + [@deriving sexp] + type t = { + width: float, + height: float, + }; + + let equal = phys_equal; + }; + + let observer = + (node: unit => Js.t(Dom_html.element), ~default: Size.t) + : Computation.t(Size.t) => { + let%sub (size, update) = state((module Size), ~default_model=default); + let startup = { + let%map update = update; + Effect.of_sync_fun( + () => { + let _ = + ResizeObserver.observe( + ~node=node(), + ~f= + (entries, _) => { + let rect = Js.to_array(entries)[0]##.contentRect; + Size.{ + width: rect##.right -. rect##.left, + height: rect##.bottom -. rect##.top, + } + |> update + |> Effect.Expert.handle; + }, + (), + ); + (); + }, + (), + ); + }; + let%sub () = OnStartup.on_startup(startup); + let%arr size = size; + size; + }; +}; diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 350838a870..1e7e87a1af 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -1,12 +1,5 @@ let rev_if = (b: bool) => b ? List.rev : Fun.id; -let dedup = xs => - List.fold_right( - (x, deduped) => List.mem(x, deduped) ? deduped : [x, ...deduped], - xs, - [], - ); - let dedup_f = (f, xs) => List.fold_right( (x, deduped) => List.exists(f(x), deduped) ? deduped : [x, ...deduped], @@ -14,9 +7,22 @@ let dedup_f = (f, xs) => [], ); -let are_duplicates = xs => - List.length(List.sort_uniq(compare, xs)) == List.length(xs); +let dedup = xs => dedup_f((==), xs); +/** + Groups elements of a list by a specified key. + + {b Note: The groups are not guaranteed to preserve the order of elements from the original list. } + + @param key + The key function used to determine the grouping key. + + @param xs + The list of elements to be grouped. + + @return + A list of tuples where each tuple contains the grouping key and a list of elements that belong to that group. +*/ let group_by = (key: 'x => 'k, xs: list('x)): list(('k, list('x))) => List.fold_left( (grouped, x) => { @@ -32,7 +38,7 @@ let group_by = (key: 'x => 'k, xs: list('x)): list(('k, list('x))) => xs, ); -let rec range = (~lo=0, hi) => +let rec range = (~lo: int=0, hi: int) => if (lo > hi) { raise(Invalid_argument("ListUtil.range")); } else if (lo == hi) { @@ -171,7 +177,15 @@ let split_sublist_opt = let split_sublist = (i: int, j: int, xs: list('x)): (list('x), list('x), list('x)) => switch (split_sublist_opt(i, j, xs)) { - | None => raise(Invalid_argument("ListUtil.split_sublist")) + | None => + raise( + Invalid_argument( + "ListUtil.split_sublist: " + ++ string_of_int(i) + ++ ", " + ++ string_of_int(j), + ), + ) | Some(r) => r }; let sublist = ((i, j), xs: list('x)): list('x) => { diff --git a/src/util/Util.re b/src/util/Util.re index 60e65c5227..cc5b2f5b21 100644 --- a/src/util/Util.re +++ b/src/util/Util.re @@ -1,4 +1,5 @@ module Aba = Aba; +module BonsaiUtil = BonsaiUtil; module Direction = Direction; module Either = Either; module IntMap = IntMap; diff --git a/src/util/dune b/src/util/dune index 889c95bd2c..f50e6ac0f7 100644 --- a/src/util/dune +++ b/src/util/dune @@ -1,19 +1,24 @@ (library (name util) - (libraries re base ptmap incr_dom virtual_dom yojson) + (libraries re base ptmap bonsai bonsai.web virtual_dom yojson) (js_of_ocaml) + (instrumentation + (backend bisect_ppx)) (preprocess (pps ppx_yojson_conv js_of_ocaml-ppx ppx_let ppx_sexp_conv - ppx_deriving.show))) + ppx_deriving.show + bonsai.ppx_bonsai))) (env (dev + (flags :standard -warn-error -A) (js_of_ocaml (flags :standard --debuginfo --noinline --dynlink --linkall --sourcemap))) (release + (flags :standard -warn-error +A-58) (js_of_ocaml (flags :standard)))) diff --git a/test/Test_Elaboration.re b/test/Test_Elaboration.re index 1c5a7c7271..c515487535 100644 --- a/test/Test_Elaboration.re +++ b/test/Test_Elaboration.re @@ -74,20 +74,18 @@ let consistent_if = () => dhexp_of_uexp(u6), ); -let u7: Exp.t = - Ap( - Forward, - Fun( - Var("x") |> Pat.fresh, - BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) - |> Exp.fresh, - None, - None, - ) - |> Exp.fresh, - Var("y") |> Exp.fresh, +// x => 4 + 5 +let f = + Fun( + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) |> Exp.fresh, + None, + None, ) |> Exp.fresh; +let unapplied_function = () => alco_check("A function", f, dhexp_of_uexp(f)); + +let u7: Exp.t = Ap(Forward, f, Var("y") |> Exp.fresh) |> Exp.fresh; let ap_fun = () => alco_check("Application of a function", u7, dhexp_of_uexp(u7)); @@ -179,6 +177,148 @@ let let_fun = () => dhexp_of_uexp(u9), ); +let deferral = () => + alco_check( + "string_sub(\"hello\", 1, _)", + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + dhexp_of_uexp( + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + ), + ); + +let ap_deferral_single_argument = () => + alco_check( + "string_sub(\"hello\", 1, _)(2)", + Ap( + Forward, + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + Int(2) |> Exp.fresh, + ) + |> Exp.fresh, + dhexp_of_uexp( + Ap( + Forward, + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + Int(2) |> Exp.fresh, + ) + |> Exp.fresh, + ), + ); + +let ap_of_deferral_of_hole = () => + alco_check( + "?(_, _, 3)(1., true)", + Ap( + Forward, + DeferredAp( + Cast( + Cast( + EmptyHole |> Exp.fresh, + Unknown(Internal) |> Typ.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + Arrow( + Prod([ + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ]) + |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + [ + Deferral(InAp) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + Cast( + Int(3) |> Exp.fresh, + Int |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ], + ) + |> Exp.fresh, + Tuple([ + Cast( + Float(1.) |> Exp.fresh, + Float |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + Cast( + Bool(true) |> Exp.fresh, + Bool |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ]) + |> Exp.fresh, + ) + |> Exp.fresh, + dhexp_of_uexp( + Ap( + Forward, + DeferredAp( + EmptyHole |> Exp.fresh, + [ + Deferral(InAp) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + Int(3) |> Exp.fresh, + ], + ) + |> Exp.fresh, + Tuple([Float(1.) |> Exp.fresh, Bool(true) |> Exp.fresh]) + |> Exp.fresh, + ) + |> Exp.fresh, + ), + ); + let elaboration_tests = [ test_case("Single integer", `Quick, single_integer), test_case("Empty hole", `Quick, empty_hole), @@ -186,7 +326,23 @@ let elaboration_tests = [ test_case("Let expression", `Quick, let_exp), test_case("Inconsistent binary operation", `Quick, bin_op), test_case("Consistent if statement", `Quick, consistent_if), + test_case("An unapplied function", `Quick, unapplied_function), test_case("Application of function on free variable", `Quick, ap_fun), test_case("Inconsistent case statement", `Quick, inconsistent_case), test_case("Let expression for a function", `Quick, let_fun), + test_case( + "Function application with a deferred argument", + `Quick, + deferral, + ), + test_case( + "Function application with a single remaining argument after deferral", + `Quick, + ap_deferral_single_argument, + ), + test_case( + "Function application with a deferral of a hole", + `Quick, + ap_of_deferral_of_hole, + ), ]; diff --git a/test/Test_Evaluator.re b/test/Test_Evaluator.re new file mode 100644 index 0000000000..24ff5af4c7 --- /dev/null +++ b/test/Test_Evaluator.re @@ -0,0 +1,177 @@ +open Alcotest; +open Haz3lcore; +let dhexp_typ = testable(Fmt.using(Exp.show, Fmt.string), DHExp.fast_equal); + +let evaluation_test = (msg, expected, unevaluated) => + check( + dhexp_typ, + msg, + expected, + ProgramResult.Result.unbox( + snd(Evaluator.evaluate'(Builtins.env_init, {d: unevaluated})), + ), + ); + +let test_int = () => + evaluation_test("8", Int(8) |> Exp.fresh, Int(8) |> Exp.fresh); + +let test_sum = () => + evaluation_test( + "4 + 5", + Int(9) |> Exp.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) |> Exp.fresh, + ); + +let test_function_application = () => + evaluation_test( + "float_of_int(1)", + Float(1.0) |> Exp.fresh, + Ap(Forward, Var("float_of_int") |> Exp.fresh, Int(1) |> Exp.fresh) + |> Exp.fresh, + ); + +let test_function_deferral = () => + evaluation_test( + "string_sub(\"hello\", 1, _)(2)", + String("el") |> Exp.fresh, + Ap( + Forward, + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + Int(2) |> Exp.fresh, + ) + |> Exp.fresh, + ); + +let tet_ap_of_hole_deferral = () => + evaluation_test( + "?(_, _, 3)(1., true)", + Ap( + Forward, + Cast( + Cast( + EmptyHole |> Exp.fresh, + Unknown(Internal) |> Typ.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + Arrow( + Prod([ + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ]) + |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + Tuple([ + Cast( + Float(1.) |> Exp.fresh, + Float |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + Cast( + Bool(true) |> Exp.fresh, + Bool |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + Cast( + Int(3) |> Exp.fresh, + Int |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ]) + |> Exp.fresh, + ) + |> Exp.fresh, + Ap( + Forward, + DeferredAp( + Cast( + Cast( + EmptyHole |> Exp.fresh, + Unknown(Internal) |> Typ.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + Arrow( + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + Arrow( + Prod([ + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ]) + |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Typ.fresh, + ) + |> Exp.fresh, + [ + Deferral(InAp) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + Cast( + Int(3) |> Exp.fresh, + Int |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ], + ) + |> Exp.fresh, + Tuple([ + Cast( + Float(1.) |> Exp.fresh, + Float |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + Cast( + Bool(true) |> Exp.fresh, + Bool |> Typ.fresh, + Unknown(Internal) |> Typ.fresh, + ) + |> Exp.fresh, + ]) + |> Exp.fresh, + ) + |> Exp.fresh, + ); + +let tests = [ + test_case("Integer literal", `Quick, test_int), + test_case("Integer sum", `Quick, test_sum), + test_case("Function application", `Quick, test_function_application), + test_case("Function deferral", `Quick, test_function_deferral), + test_case("Deferral applied to hole", `Quick, tet_ap_of_hole_deferral), +]; diff --git a/test/Test_ListUtil.re b/test/Test_ListUtil.re new file mode 100644 index 0000000000..9abfca4f07 --- /dev/null +++ b/test/Test_ListUtil.re @@ -0,0 +1,610 @@ +open Alcotest; +open Util; + +let tests = ( + "ListUtil", + [ + test_case( + "rev_if with false", + `Quick, + () => { + let xs = [1, 2, 3]; + check(list(int), "Same list", xs, ListUtil.rev_if(false, xs)); + }, + ), + test_case( + "rev_if with true", + `Quick, + () => { + let xs = [1, 2, 3]; + check( + list(int), + "Reversed list", + [3, 2, 1], + ListUtil.rev_if(true, xs), + ); + }, + ), + test_case( + "dedup", + `Quick, + () => { + let xs = [1, 2, 3, 2]; + check(list(int), "Unique list", [1, 3, 2], ListUtil.dedup(xs)); // TODO: Interesting the order here is messed up because of fold_right + }, + ), + test_case( + "dedup_f", + `Quick, + () => { + let xs = [1, 2, 3, 2]; + check( + list(int), + "Unique list", + [1, 3, 2], + ListUtil.dedup_f((==), xs), + ); // TODO: Interesting the order here is messed up because of fold_right + }, + ), + test_case( + "group_by with constant function preserves list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + list(pair(unit, list(int))), + "singleton group", + [((), List.rev(xs))], + ListUtil.group_by(__ => (), xs), + ); + }, + ), + test_case( + "group_by groups into evens/odds", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + list(pair(int, list(int))), + "odds and evens", + [(1, [5, 3, 1]), (0, [4, 2])], + ListUtil.group_by(x => x mod 2, xs), + ); + }, + ), + test_case("range generates sequential integers [1,6)", `Quick, () => { + check(list(int), "1-5", [1, 2, 3, 4, 5], ListUtil.range(~lo=1, 6)) + }), + test_case("range defaults lower bound to 0", `Quick, () => { + check(list(int), "0-5", [0, 1, 2, 3, 4, 5], ListUtil.range(6)) + }), + test_case("range lo = hi is empty", `Quick, () => { + check(list(int), "empty list", [], ListUtil.range(~lo=1, 1)) + }), + test_case("Invalid range raises error", `Quick, () => { + check_raises( + "Invalid range", + Invalid_argument("ListUtil.range"), + () => { + let _ = ListUtil.range(~lo=2, 1); + (); + }, + ) + }), + test_case( + "mk_frame creates a frame from the beginning", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "frame", + ([], xs), + ListUtil.mk_frame(0, xs), + ); + }, + ), + test_case( + "mk_frame creates a frame from the end", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "frame", + (List.rev(xs), []), + ListUtil.mk_frame(5, xs), + ); + }, + ), + test_case( + "mk_frame raises when making a frame past the end", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check_raises( + "raises invalid argument", + Invalid_argument("ListUtil.mk_frame"), + () => { + let _ = ListUtil.mk_frame(6, xs); + (); + }, + ); + }, + ), + test_case( + "mk_frame raises when making a frame before the beginning", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check_raises( + "raises invalid argument", + Invalid_argument("ListUtil.mk_frame"), + () => { + let _ = ListUtil.mk_frame(-1, xs); + (); + }, + ); + }, + ), + test_case( + "mk_frame makes a frame splitting the list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "frame", + (List.rev([1, 2, 3]), [4, 5]), + ListUtil.mk_frame(3, xs), + ); + }, + ), + test_case( + "mk_frame makes a frame splitting the list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "frame", + (List.rev([1, 2, 3]), [4, 5]), + ListUtil.mk_frame(3, xs), + ); + }, + ), + test_case( + "split with no found element returns the original list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + triple(list(int), option(int), list(int)), + "split", + (xs, None, []), + ListUtil.split(xs, __ => false), + ); + }, + ), + test_case( + "split with first found returns the head and tail", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + triple(list(int), option(int), list(int)), + "split", + ([], Some(1), [2, 3, 4, 5]), + ListUtil.split(xs, __ => true), + ); + }, + ), + test_case( + "splits on the middle element", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + triple(list(int), option(int), list(int)), + "split", + ([1, 2], Some(3), [4, 5]), + ListUtil.split(xs, (==)(3)), + ); + }, + ), + test_case( + "combine_opt", + `Quick, + () => { + check( + option(list(pair(string, int))), + "Same size lists", + Some([("a", 1), ("b", 2), ("c", 3)]), + ListUtil.combine_opt(["a", "b", "c"], [1, 2, 3]), + ); + check( + option(list(pair(string, int))), + "Empty Lists", + Some([]), + ListUtil.combine_opt([], []), + ); + check( + option(list(pair(string, int))), + "Inconsistent size lists", + None, + ListUtil.combine_opt(["a"], [1, 2]), + ); + }, + ), + test_case( + "is_empty with empty list", + `Quick, + () => { + let xs = []; + check(bool, "Returns true", true, ListUtil.is_empty(xs)); + }, + ), + test_case( + "is_empty with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3]; + check(bool, "Returns false", false, ListUtil.is_empty(xs)); + }, + ), + test_case( + "flat_map with empty list", + `Quick, + () => { + let xs = []; + let f = x => [x, x]; + check(list(int), "Empty list", [], ListUtil.flat_map(f, xs)); + }, + ), + test_case( + "flat_map with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3]; + let f = x => [x, x]; + check( + list(int), + "Doubled list", + [1, 1, 2, 2, 3, 3], + ListUtil.flat_map(f, xs), + ); + }, + ), + test_case( + "flat_map with non-empty list and empty result", + `Quick, + () => { + let xs = [1, 2, 3]; + let f = _ => []; + check(list(int), "Empty list", [], ListUtil.flat_map(f, xs)); + }, + ), + test_case( + "join with empty list", + `Quick, + () => { + let xs = []; + check(list(string), "Empty list", ListUtil.join(",", xs), []); + }, + ), + test_case( + "join with single element list", + `Quick, + () => { + let xs = ["a"]; + check( + list(string), + "Single element list", + ListUtil.join(",", xs), + ["a"], + ); + }, + ), + test_case( + "join with multiple element list", + `Quick, + () => { + let xs = ["a", "b", "c"]; + check( + list(string), + "Multiple element list", + ListUtil.join(",", xs), + ["a", ",", "b", ",", "c"], + ); + }, + ), + test_case( + "hd_opt with empty list", + `Quick, + () => { + let xs = []; + check(option(int), "None", None, ListUtil.hd_opt(xs)); + }, + ), + test_case( + "hd_opt with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3]; + check(option(int), "Some", Some(1), ListUtil.hd_opt(xs)); + }, + ), + test_case( + "nth_opt with empty list", + `Quick, + () => { + let xs = []; + check(option(int), "None", None, ListUtil.nth_opt(0, xs)); + }, + ), + test_case( + "nth_opt with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3]; + check(option(int), "Some", Some(2), ListUtil.nth_opt(1, xs)); + }, + ), + test_case( + "nth_opt with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3]; + check(option(int), "None", None, ListUtil.nth_opt(3, xs)); + }, + ), + test_case( + "split_n_opt with empty list", + `Quick, + () => { + let xs = []; + check( + option(pair(list(int), list(int))), + "Empty list", + Some(([], [])), + ListUtil.split_n_opt(0, xs), + ); + }, + ), + test_case( + "split_n_opt with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(pair(list(int), list(int))), + "Split list", + Some(([1, 2, 3], [4, 5])), + ListUtil.split_n_opt(3, xs), + ); + }, + ), + test_case( + "split_n_opt with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(pair(list(int), list(int))), + "None", + None, + ListUtil.split_n_opt(6, xs), + ); + }, + ), + test_case( + "split_n_opt with zero index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(pair(list(int), list(int))), + "Empty first part", + Some(([], xs)), + ListUtil.split_n_opt(0, xs), + ); + }, + ), + test_case( + "split_n with empty list", + `Quick, + () => { + let xs = []; + check( + pair(list(int), list(int)), + "Empty list", + ([], []), + ListUtil.split_n(0, xs), + ); + }, + ), + test_case( + "split_n with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "Split list", + ([1, 2, 3], [4, 5]), + ListUtil.split_n(3, xs), + ); + }, + ), + test_case( + "split_n with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check_raises( + "raises invalid argument", + Invalid_argument("ListUtil.split_n: 6"), + () => { + let _ = ListUtil.split_n(6, xs); + (); + }, + ); + }, + ), + test_case( + "split_n with zero index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + pair(list(int), list(int)), + "Empty first part", + ([], xs), + ListUtil.split_n(0, xs), + ); + }, + ), + test_case( + "split_sublist_opt with empty list", + `Quick, + () => { + let xs = []; + check( + option(triple(list(int), list(int), list(int))), + "Empty list", + Some(([], [], [])), + ListUtil.split_sublist_opt(0, 0, xs), + ); + }, + ), + test_case( + "split_sublist_opt with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(triple(list(int), list(int), list(int))), + "Split list", + Some(([1, 2], [3, 4], [5])), + ListUtil.split_sublist_opt(2, 4, xs), + ); + }, + ), + test_case( + "split_sublist_opt with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(triple(list(int), list(int), list(int))), + "None", + None, + ListUtil.split_sublist_opt(6, 7, xs), + ); + }, + ), + test_case( + "split_sublist_opt with zero index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + option(triple(list(int), list(int), list(int))), + "Empty first part", + Some(([], [], xs)), + ListUtil.split_sublist_opt(0, 0, xs), + ); + }, + ), + test_case( + "split_sublist with empty list", + `Quick, + () => { + let xs = []; + check( + triple(list(int), list(int), list(int)), + "Empty list", + ([], [], []), + ListUtil.split_sublist(0, 0, xs), + ); + }, + ), + test_case( + "split_sublist with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + triple(list(int), list(int), list(int)), + "Split list", + ([1, 2], [3, 4], [5]), + ListUtil.split_sublist(2, 4, xs), + ); + }, + ), + test_case( + "split_sublist with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check_raises( + "raises invalid argument", + Invalid_argument("ListUtil.split_sublist: 6, 7"), + () => { + let _ = ListUtil.split_sublist(6, 7, xs); + (); + }, + ); + }, + ), + test_case( + "split_sublist with zero index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + triple(list(int), list(int), list(int)), + "Empty first part", + ([], [], xs), + ListUtil.split_sublist(0, 0, xs), + ); + }, + ), + test_case( + "sublist with empty list", + `Quick, + () => { + let xs = []; + check(list(int), "Empty list", [], ListUtil.sublist((0, 0), xs)); + }, + ), + test_case( + "sublist with non-empty list", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check( + list(int), + "Sublist", + [2, 3, 4], + ListUtil.sublist((1, 4), xs), + ); + }, + ), + test_case( + "sublist with out of bounds index", + `Quick, + () => { + let xs = [1, 2, 3, 4, 5]; + check_raises( + "raises invalid argument", + Invalid_argument("ListUtil.split_sublist: 6, 7"), + () => { + let _ = ListUtil.sublist((6, 7), xs); + (); + }, + ); + }, + ), + ], +); diff --git a/test/Test_MakeTerm.re b/test/Test_MakeTerm.re new file mode 100644 index 0000000000..46818664a9 --- /dev/null +++ b/test/Test_MakeTerm.re @@ -0,0 +1,82 @@ +/** + * This file contains tests to validate the `MakeTerm` module's ability to convert + * zippers into expressions. + */ +open Alcotest; +open Haz3lcore; + +let exp_typ = testable(Fmt.using(Exp.show, Fmt.string), Exp.fast_equal); + +let parse_exp = (s: string) => + MakeTerm.from_zip_for_sem(Option.get(Printer.zipper_of_string(s))).term; +let exp_check = (expected, actual) => + check(exp_typ, actual, expected, parse_exp(actual)); + +let tests = [ + test_case("Integer Literal", `Quick, () => { + exp_check(Int(0) |> Exp.fresh, "0") + }), + test_case("Empty Hole", `Quick, () => { + exp_check(EmptyHole |> Exp.fresh, "?") + }), + test_case("Free Variable", `Quick, () => { + exp_check(Var("x") |> Exp.fresh, "x") + }), + test_case("Parenthesized Expression", `Quick, () => { + exp_check(Parens(Int(0) |> Exp.fresh) |> Exp.fresh, "(0)") + }), + test_case("Let Expression", `Quick, () => { + exp_check( + Let( + Var("x") |> Pat.fresh, + Int(1) |> Exp.fresh, + Var("x") |> Exp.fresh, + ) + |> Exp.fresh, + "let x = 1 in x", + ) + }), + test_case("Function Application", `Quick, () => { + exp_check( + Ap(Forward, Var("f") |> Exp.fresh, Var("x") |> Exp.fresh) |> Exp.fresh, + "f(x)", + ) + }), + test_case("Named Function Definition", `Quick, () => { + exp_check( + Let( + Var("f") |> Pat.fresh, + Fun(Var("x") |> Pat.fresh, Var("x") |> Exp.fresh, None, None) // It seems as though the function naming happens during elaboration and not during parsing + |> Exp.fresh, + Int(1) |> Exp.fresh, + ) + |> Exp.fresh, + "let f = fun x -> x in 1", + ) + }), + test_case("Incomplete Function Definition", `Quick, () => { + exp_check( + Let( + EmptyHole |> Pat.fresh, + Fun(Var("x") |> Pat.fresh, EmptyHole |> Exp.fresh, None, None) + |> Exp.fresh, + EmptyHole |> Exp.fresh, + ) + |> Exp.fresh, + "let = fun x -> in ", + ) + }), + test_case("Constructor", `Quick, () => { + exp_check( + Constructor("A", Unknown(Internal) |> Typ.fresh) |> Exp.fresh, + "A", + ) + }), + test_case("Type Alias", `Quick, () => { + exp_check( + TyAlias(Var("x") |> TPat.fresh, Int |> Typ.fresh, Int(1) |> Exp.fresh) + |> Exp.fresh, + "type x = Int in 1", + ) + }), +]; diff --git a/test/Test_Statics.re b/test/Test_Statics.re new file mode 100644 index 0000000000..71fdafc8ba --- /dev/null +++ b/test/Test_Statics.re @@ -0,0 +1,126 @@ +open Alcotest; +open Haz3lcore; + +let testable_typ = testable(Fmt.using(Typ.show, Fmt.string), Typ.fast_equal); +module FreshId = { + let arrow = (a, b) => Arrow(a, b) |> Typ.fresh; + let unknown = a => Unknown(a) |> Typ.fresh; + let int = Typ.fresh(Int); + let float = Typ.fresh(Float); + let prod = a => Prod(a) |> Typ.fresh; + let string = Typ.fresh(String); +}; +let ids = List.init(12, _ => Id.mk()); +let id_at = x => x |> List.nth(ids); +let statics = Statics.mk(CoreSettings.on, Builtins.ctx_init); +let alco_check = Alcotest.option(testable_typ) |> Alcotest.check; + +// Get the type from the statics +let type_of = f => { + let s = statics(f); + switch (Id.Map.find(IdTagged.rep_id(f), s)) { + | InfoExp({ty, _}) => Some(ty) + | _ => None + }; +}; + +let unapplied_function = () => + alco_check( + "Unknown param", + Some(FreshId.(arrow(unknown(Internal), int))), + type_of( + Fun( + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) + |> Exp.fresh, + None, + None, + ) + |> Exp.fresh, + ), + ); + +let tests = + FreshId.[ + test_case("Function with unknown param", `Quick, () => + alco_check( + "x => 4 + 5", + Some(arrow(unknown(Internal), int)), + type_of( + Fun( + Var("x") |> Pat.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) + |> Exp.fresh, + None, + None, + ) + |> Exp.fresh, + ), + ) + ), + test_case("Function with known param", `Quick, () => + alco_check( + "x : Int => 4 + 5", + Some(arrow(int, int)), + type_of( + Fun( + Cast(Var("x") |> Pat.fresh, int, unknown(Internal)) |> Pat.fresh, + BinOp(Int(Plus), Int(4) |> Exp.fresh, Int(5) |> Exp.fresh) + |> Exp.fresh, + None, + None, + ) + |> Exp.fresh, + ), + ) + ), + test_case("bifunction", `Quick, () => + alco_check( + "x : Int, y: Int => x + y", + Some(arrow(prod([int, int]), int)), + type_of( + Fun( + Tuple([ + Cast(Var("x") |> Pat.fresh, int, unknown(Internal)) + |> Pat.fresh, + Cast(Var("y") |> Pat.fresh, int, unknown(Internal)) + |> Pat.fresh, + ]) + |> Pat.fresh, + BinOp(Int(Plus), Var("x") |> Exp.fresh, Var("y") |> Exp.fresh) + |> Exp.fresh, + None, + None, + ) + |> Exp.fresh, + ), + ) + ), + test_case("function application", `Quick, () => + alco_check( + "float_of_int(1)", + Some(float), + type_of( + Ap(Forward, Var("float_of_int") |> Exp.fresh, Int(1) |> Exp.fresh) + |> Exp.fresh, + ), + ) + ), + test_case("function deferral", `Quick, () => + alco_check( + "string_sub(\"hello\", 1, _)", + Some(arrow(int, string)), + type_of( + DeferredAp( + Var("string_sub") |> Exp.fresh, + [ + String("hello") |> Exp.fresh, + Int(1) |> Exp.fresh, + Deferral(InAp) |> Exp.fresh, + ], + ) + |> Exp.fresh, + ), + ) + ), + ]; diff --git a/test/dune b/test/dune index 832c9689f2..3b9dc8bb2e 100644 --- a/test/dune +++ b/test/dune @@ -2,7 +2,7 @@ (test (name haz3ltest) - (libraries haz3lcore alcotest junit junit_alcotest) + (libraries haz3lcore alcotest junit junit_alcotest bisect_ppx.runtime) (modes js) (preprocess - (pps js_of_ocaml-ppx))) + (pps js_of_ocaml-ppx ppx_deriving.show))) diff --git a/test/haz3ltest.re b/test/haz3ltest.re index e405fba7b8..8e4a838b0a 100644 --- a/test/haz3ltest.re +++ b/test/haz3ltest.re @@ -3,7 +3,14 @@ open Junit_alcotest; let (suite, _) = run_and_report( ~and_exit=false, - "Dynamics", - [("Elaboration", Test_Elaboration.elaboration_tests)], + "HazelTests", + [ + ("Elaboration", Test_Elaboration.elaboration_tests), + ("Statics", Test_Statics.tests), + ("Evaluator", Test_Evaluator.tests), + Test_ListUtil.tests, + ("MakeTerm", Test_MakeTerm.tests), + ], ); Junit.to_file(Junit.make([suite]), "junit_tests.xml"); +Bisect.Runtime.write_coverage_data();